1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects
; use Aspects
;
33 with Atree
; use Atree
;
34 with Casing
; use Casing
;
35 with Checks
; use Checks
;
36 with Contracts
; use Contracts
;
37 with Csets
; use Csets
;
38 with Debug
; use Debug
;
39 with Einfo
; use Einfo
;
40 with Elists
; use Elists
;
41 with Errout
; use Errout
;
42 with Exp_Dist
; use Exp_Dist
;
43 with Exp_Util
; use Exp_Util
;
44 with Freeze
; use Freeze
;
45 with Ghost
; use Ghost
;
47 with Lib
.Writ
; use Lib
.Writ
;
48 with Lib
.Xref
; use Lib
.Xref
;
49 with Namet
.Sp
; use Namet
.Sp
;
50 with Nlists
; use Nlists
;
51 with Nmake
; use Nmake
;
52 with Output
; use Output
;
53 with Par_SCO
; use Par_SCO
;
54 with Restrict
; use Restrict
;
55 with Rident
; use Rident
;
56 with Rtsfind
; use Rtsfind
;
58 with Sem_Aux
; use Sem_Aux
;
59 with Sem_Ch3
; use Sem_Ch3
;
60 with Sem_Ch6
; use Sem_Ch6
;
61 with Sem_Ch8
; use Sem_Ch8
;
62 with Sem_Ch12
; use Sem_Ch12
;
63 with Sem_Ch13
; use Sem_Ch13
;
64 with Sem_Disp
; use Sem_Disp
;
65 with Sem_Dist
; use Sem_Dist
;
66 with Sem_Elim
; use Sem_Elim
;
67 with Sem_Eval
; use Sem_Eval
;
68 with Sem_Intr
; use Sem_Intr
;
69 with Sem_Mech
; use Sem_Mech
;
70 with Sem_Res
; use Sem_Res
;
71 with Sem_Type
; use Sem_Type
;
72 with Sem_Util
; use Sem_Util
;
73 with Sem_Warn
; use Sem_Warn
;
74 with Stand
; use Stand
;
75 with Sinfo
; use Sinfo
;
76 with Sinfo
.CN
; use Sinfo
.CN
;
77 with Sinput
; use Sinput
;
78 with Stringt
; use Stringt
;
79 with Stylesw
; use Stylesw
;
81 with Targparm
; use Targparm
;
82 with Tbuild
; use Tbuild
;
84 with Uintp
; use Uintp
;
85 with Uname
; use Uname
;
86 with Urealp
; use Urealp
;
87 with Validsw
; use Validsw
;
88 with Warnsw
; use Warnsw
;
90 package body Sem_Prag
is
92 ----------------------------------------------
93 -- Common Handling of Import-Export Pragmas --
94 ----------------------------------------------
96 -- In the following section, a number of Import_xxx and Export_xxx pragmas
97 -- are defined by GNAT. These are compatible with the DEC pragmas of the
98 -- same name, and all have the following common form and processing:
101 -- [Internal =>] LOCAL_NAME
102 -- [, [External =>] EXTERNAL_SYMBOL]
103 -- [, other optional parameters ]);
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
110 -- EXTERNAL_SYMBOL ::=
112 -- | static_string_EXPRESSION
114 -- The internal LOCAL_NAME designates the entity that is imported or
115 -- exported, and must refer to an entity in the current declarative
116 -- part (as required by the rules for LOCAL_NAME).
118 -- The external linker name is designated by the External parameter if
119 -- given, or the Internal parameter if not (if there is no External
120 -- parameter, the External parameter is a copy of the Internal name).
122 -- If the External parameter is given as a string, then this string is
123 -- treated as an external name (exactly as though it had been given as an
124 -- External_Name parameter for a normal Import pragma).
126 -- If the External parameter is given as an identifier (or there is no
127 -- External parameter, so that the Internal identifier is used), then
128 -- the external name is the characters of the identifier, translated
129 -- to all lower case letters.
131 -- Note: the external name specified or implied by any of these special
132 -- Import_xxx or Export_xxx pragmas override an external or link name
133 -- specified in a previous Import or Export pragma.
135 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
136 -- named notation, following the standard rules for subprogram calls, i.e.
137 -- parameters can be given in any order if named notation is used, and
138 -- positional and named notation can be mixed, subject to the rule that all
139 -- positional parameters must appear first.
141 -- Note: All these pragmas are implemented exactly following the DEC design
142 -- and implementation and are intended to be fully compatible with the use
143 -- of these pragmas in the DEC Ada compiler.
145 --------------------------------------------
146 -- Checking for Duplicated External Names --
147 --------------------------------------------
149 -- It is suspicious if two separate Export pragmas use the same external
150 -- name. The following table is used to diagnose this situation so that
151 -- an appropriate warning can be issued.
153 -- The Node_Id stored is for the N_String_Literal node created to hold
154 -- the value of the external name. The Sloc of this node is used to
155 -- cross-reference the location of the duplication.
157 package Externals
is new Table
.Table
(
158 Table_Component_Type
=> Node_Id
,
159 Table_Index_Type
=> Int
,
160 Table_Low_Bound
=> 0,
161 Table_Initial
=> 100,
162 Table_Increment
=> 100,
163 Table_Name
=> "Name_Externals");
165 -------------------------------------
166 -- Local Subprograms and Variables --
167 -------------------------------------
169 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
170 -- This routine is used for possible casing adjustment of an explicit
171 -- external name supplied as a string literal (the node N), according to
172 -- the casing requirement of Opt.External_Name_Casing. If this is set to
173 -- As_Is, then the string literal is returned unchanged, but if it is set
174 -- to Uppercase or Lowercase, then a new string literal with appropriate
175 -- casing is constructed.
177 procedure Analyze_Part_Of
181 Encap_Id
: out Entity_Id
;
182 Legal
: out Boolean);
183 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
184 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
185 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
186 -- package instantiation. Encap denotes the encapsulating state or single
187 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
188 -- the indicator is legal.
190 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
191 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
192 -- Query whether a particular item appears in a mixed list of nodes and
193 -- entities. It is assumed that all nodes in the list have entities.
195 procedure Check_Postcondition_Use_In_Inlined_Subprogram
197 Spec_Id
: Entity_Id
);
198 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
199 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
200 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
202 procedure Check_State_And_Constituent_Use
206 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
207 -- Global and Initializes. Determine whether a state from list States and a
208 -- corresponding constituent from list Constits (if any) appear in the same
209 -- context denoted by Context. If this is the case, emit an error.
211 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
212 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
213 -- Prag that duplicates previous pragma Prev.
215 function Find_Related_Context
217 Do_Checks
: Boolean := False) return Node_Id
;
218 -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers,
219 -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and
220 -- Part_Of. Find the first source declaration or statement found while
221 -- traversing the previous node chain starting from pragma Prag. If flag
222 -- Do_Checks is set, the routine reports duplicate pragmas. The routine
223 -- returns Empty when reaching the start of the node chain.
225 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
226 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
227 -- original one, following the renaming chain) is returned. Otherwise the
228 -- entity is returned unchanged. Should be in Einfo???
230 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
231 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
232 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
235 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
236 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
237 -- Determine whether dependency clause Clause is surrounded by extra
238 -- parentheses. If this is the case, issue an error message.
240 function Is_CCT_Instance
(Ref
: Node_Id
) return Boolean;
241 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
242 -- Global. Determine whether reference Ref denotes the current instance of
243 -- a concurrent type.
245 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
246 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
247 -- pragma Depends. Determine whether the type of dependency item Item is
248 -- tagged, unconstrained array, unconstrained record or a record with at
249 -- least one unconstrained component.
251 procedure Record_Possible_Body_Reference
252 (State_Id
: Entity_Id
;
254 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
255 -- Global. Given an abstract state denoted by State_Id and a reference Ref
256 -- to it, determine whether the reference appears in a package body that
257 -- will eventually refine the state. If this is the case, record the
258 -- reference for future checks (see Analyze_Refined_State_In_Decls).
260 procedure Resolve_State
(N
: Node_Id
);
261 -- Handle the overloading of state names by functions. When N denotes a
262 -- function, this routine finds the corresponding state and sets the entity
263 -- of N to that of the state.
265 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
266 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
267 -- then it is rewritten as an identifier with the corresponding special
268 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
271 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
272 -- Place semantic information on the argument of an Elaborate/Elaborate_All
273 -- pragma. Entity name for unit and its parents is taken from item in
274 -- previous with_clause that mentions the unit.
276 Dummy
: Integer := 0;
277 pragma Volatile
(Dummy
);
278 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
281 pragma No_Inline
(ip
);
282 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
283 -- is just to help debugging the front end. If a pragma Inspection_Point
284 -- is added to a source program, then breaking on ip will get you to that
285 -- point in the program.
288 pragma No_Inline
(rv
);
289 -- This is a dummy function called by the processing for pragma Reviewable.
290 -- It is there for assisting front end debugging. By placing a Reviewable
291 -- pragma in the source program, a breakpoint on rv catches this place in
292 -- the source, allowing convenient stepping to the point of interest.
294 -------------------------------
295 -- Adjust_External_Name_Case --
296 -------------------------------
298 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
302 -- Adjust case of literal if required
304 if Opt
.External_Name_Exp_Casing
= As_Is
then
308 -- Copy existing string
314 for J
in 1 .. String_Length
(Strval
(N
)) loop
315 CC
:= Get_String_Char
(Strval
(N
), J
);
317 if Opt
.External_Name_Exp_Casing
= Uppercase
318 and then CC
>= Get_Char_Code
('a')
319 and then CC
<= Get_Char_Code
('z')
321 Store_String_Char
(CC
- 32);
323 elsif Opt
.External_Name_Exp_Casing
= Lowercase
324 and then CC
>= Get_Char_Code
('A')
325 and then CC
<= Get_Char_Code
('Z')
327 Store_String_Char
(CC
+ 32);
330 Store_String_Char
(CC
);
335 Make_String_Literal
(Sloc
(N
),
336 Strval
=> End_String
);
338 end Adjust_External_Name_Case
;
340 -----------------------------------------
341 -- Analyze_Contract_Cases_In_Decl_Part --
342 -----------------------------------------
344 procedure Analyze_Contract_Cases_In_Decl_Part
(N
: Node_Id
) is
345 Others_Seen
: Boolean := False;
347 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
348 -- Verify the legality of a single contract case
350 ---------------------------
351 -- Analyze_Contract_Case --
352 ---------------------------
354 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
355 Case_Guard
: Node_Id
;
357 Extra_Guard
: Node_Id
;
360 if Nkind
(CCase
) = N_Component_Association
then
361 Case_Guard
:= First
(Choices
(CCase
));
362 Conseq
:= Expression
(CCase
);
364 -- Each contract case must have exactly one case guard
366 Extra_Guard
:= Next
(Case_Guard
);
368 if Present
(Extra_Guard
) then
370 ("contract case must have exactly one case guard",
374 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
376 if Nkind
(Case_Guard
) = N_Others_Choice
then
379 ("only one others choice allowed in contract cases",
385 elsif Others_Seen
then
387 ("others must be the last choice in contract cases", N
);
390 -- Preanalyze the case guard and consequence
392 if Nkind
(Case_Guard
) /= N_Others_Choice
then
393 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
396 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
398 -- The contract case is malformed
401 Error_Msg_N
("wrong syntax in contract case", CCase
);
403 end Analyze_Contract_Case
;
407 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
408 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
409 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
411 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
414 Restore_Scope
: Boolean := False;
416 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
419 -- Do not analyze the pragma multiple times
421 if Is_Analyzed_Pragma
(N
) then
425 -- Set the Ghost mode in effect from the pragma. Due to the delayed
426 -- analysis of the pragma, the Ghost mode at point of declaration and
427 -- point of analysis may not necessarely be the same. Use the mode in
428 -- effect at the point of declaration.
432 -- Single and multiple contract cases must appear in aggregate form. If
433 -- this is not the case, then either the parser of the analysis of the
434 -- pragma failed to produce an aggregate.
436 pragma Assert
(Nkind
(CCases
) = N_Aggregate
);
438 if Present
(Component_Associations
(CCases
)) then
440 -- Ensure that the formal parameters are visible when analyzing all
441 -- clauses. This falls out of the general rule of aspects pertaining
442 -- to subprogram declarations.
444 if not In_Open_Scopes
(Spec_Id
) then
445 Restore_Scope
:= True;
446 Push_Scope
(Spec_Id
);
448 if Is_Generic_Subprogram
(Spec_Id
) then
449 Install_Generic_Formals
(Spec_Id
);
451 Install_Formals
(Spec_Id
);
455 CCase
:= First
(Component_Associations
(CCases
));
456 while Present
(CCase
) loop
457 Analyze_Contract_Case
(CCase
);
461 if Restore_Scope
then
465 -- Currently it is not possible to inline pre/postconditions on a
466 -- subprogram subject to pragma Inline_Always.
468 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
470 -- Otherwise the pragma is illegal
473 Error_Msg_N
("wrong syntax for constract cases", N
);
476 Ghost_Mode
:= Save_Ghost_Mode
;
477 Set_Is_Analyzed_Pragma
(N
);
478 end Analyze_Contract_Cases_In_Decl_Part
;
480 ----------------------------------
481 -- Analyze_Depends_In_Decl_Part --
482 ----------------------------------
484 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
485 Loc
: constant Source_Ptr
:= Sloc
(N
);
486 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
487 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
489 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
490 -- A list containing the entities of all the inputs processed so far.
491 -- The list is populated with unique entities because the same input
492 -- may appear in multiple input lists.
494 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
495 -- A list containing the entities of all the outputs processed so far.
496 -- The list is populated with unique entities because output items are
497 -- unique in a dependence relation.
499 Constits_Seen
: Elist_Id
:= No_Elist
;
500 -- A list containing the entities of all constituents processed so far.
501 -- It aids in detecting illegal usage of a state and a corresponding
502 -- constituent in pragma [Refinde_]Depends.
504 Global_Seen
: Boolean := False;
505 -- A flag set when pragma Global has been processed
507 Null_Output_Seen
: Boolean := False;
508 -- A flag used to track the legality of a null output
510 Result_Seen
: Boolean := False;
511 -- A flag set when Spec_Id'Result is processed
513 States_Seen
: Elist_Id
:= No_Elist
;
514 -- A list containing the entities of all states processed so far. It
515 -- helps in detecting illegal usage of a state and a corresponding
516 -- constituent in pragma [Refined_]Depends.
518 Subp_Inputs
: Elist_Id
:= No_Elist
;
519 Subp_Outputs
: Elist_Id
:= No_Elist
;
520 -- Two lists containing the full set of inputs and output of the related
521 -- subprograms. Note that these lists contain both nodes and entities.
523 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
524 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
525 -- to the name buffer. The individual kinds are as follows:
526 -- E_Abstract_State - "state"
527 -- E_Constant - "constant"
528 -- E_Discriminant - "discriminant"
529 -- E_Generic_In_Out_Parameter - "generic parameter"
530 -- E_Generic_Out_Parameter - "generic parameter"
531 -- E_In_Parameter - "parameter"
532 -- E_In_Out_Parameter - "parameter"
533 -- E_Out_Parameter - "parameter"
534 -- E_Protected_Type - "current instance of protected type"
535 -- E_Task_Type - "current instance of task type"
536 -- E_Variable - "global"
538 procedure Analyze_Dependency_Clause
541 -- Verify the legality of a single dependency clause. Flag Is_Last
542 -- denotes whether Clause is the last clause in the relation.
544 procedure Check_Function_Return
;
545 -- Verify that Funtion'Result appears as one of the outputs
546 -- (SPARK RM 6.1.5(10)).
553 -- Ensure that an item fulfils its designated input and/or output role
554 -- as specified by pragma Global (if any) or the enclosing context. If
555 -- this is not the case, emit an error. Item and Item_Id denote the
556 -- attributes of an item. Flag Is_Input should be set when item comes
557 -- from an input list. Flag Self_Ref should be set when the item is an
558 -- output and the dependency clause has operator "+".
560 procedure Check_Usage
561 (Subp_Items
: Elist_Id
;
562 Used_Items
: Elist_Id
;
564 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
565 -- error if this is not the case.
567 procedure Normalize_Clause
(Clause
: Node_Id
);
568 -- Remove a self-dependency "+" from the input list of a clause
570 -----------------------------
571 -- Add_Item_To_Name_Buffer --
572 -----------------------------
574 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
576 if Ekind
(Item_Id
) = E_Abstract_State
then
577 Add_Str_To_Name_Buffer
("state");
579 elsif Ekind
(Item_Id
) = E_Constant
then
580 Add_Str_To_Name_Buffer
("constant");
582 elsif Ekind
(Item_Id
) = E_Discriminant
then
583 Add_Str_To_Name_Buffer
("discriminant");
585 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
586 E_Generic_In_Parameter
)
588 Add_Str_To_Name_Buffer
("generic parameter");
590 elsif Is_Formal
(Item_Id
) then
591 Add_Str_To_Name_Buffer
("parameter");
593 elsif Ekind
(Item_Id
) = E_Protected_Type
then
594 Add_Str_To_Name_Buffer
("current instance of protected type");
596 elsif Ekind
(Item_Id
) = E_Task_Type
then
597 Add_Str_To_Name_Buffer
("current instance of task type");
599 elsif Ekind
(Item_Id
) = E_Variable
then
600 Add_Str_To_Name_Buffer
("global");
602 -- The routine should not be called with non-SPARK items
607 end Add_Item_To_Name_Buffer
;
609 -------------------------------
610 -- Analyze_Dependency_Clause --
611 -------------------------------
613 procedure Analyze_Dependency_Clause
617 procedure Analyze_Input_List
(Inputs
: Node_Id
);
618 -- Verify the legality of a single input list
620 procedure Analyze_Input_Output
625 Seen
: in out Elist_Id
;
626 Null_Seen
: in out Boolean;
627 Non_Null_Seen
: in out Boolean);
628 -- Verify the legality of a single input or output item. Flag
629 -- Is_Input should be set whenever Item is an input, False when it
630 -- denotes an output. Flag Self_Ref should be set when the item is an
631 -- output and the dependency clause has a "+". Flag Top_Level should
632 -- be set whenever Item appears immediately within an input or output
633 -- list. Seen is a collection of all abstract states, objects and
634 -- formals processed so far. Flag Null_Seen denotes whether a null
635 -- input or output has been encountered. Flag Non_Null_Seen denotes
636 -- whether a non-null input or output has been encountered.
638 ------------------------
639 -- Analyze_Input_List --
640 ------------------------
642 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
643 Inputs_Seen
: Elist_Id
:= No_Elist
;
644 -- A list containing the entities of all inputs that appear in the
645 -- current input list.
647 Non_Null_Input_Seen
: Boolean := False;
648 Null_Input_Seen
: Boolean := False;
649 -- Flags used to check the legality of an input list
654 -- Multiple inputs appear as an aggregate
656 if Nkind
(Inputs
) = N_Aggregate
then
657 if Present
(Component_Associations
(Inputs
)) then
659 ("nested dependency relations not allowed", Inputs
);
661 elsif Present
(Expressions
(Inputs
)) then
662 Input
:= First
(Expressions
(Inputs
));
663 while Present
(Input
) loop
670 Null_Seen
=> Null_Input_Seen
,
671 Non_Null_Seen
=> Non_Null_Input_Seen
);
676 -- Syntax error, always report
679 Error_Msg_N
("malformed input dependency list", Inputs
);
682 -- Process a solitary input
691 Null_Seen
=> Null_Input_Seen
,
692 Non_Null_Seen
=> Non_Null_Input_Seen
);
695 -- Detect an illegal dependency clause of the form
699 if Null_Output_Seen
and then Null_Input_Seen
then
701 ("null dependency clause cannot have a null input list",
704 end Analyze_Input_List
;
706 --------------------------
707 -- Analyze_Input_Output --
708 --------------------------
710 procedure Analyze_Input_Output
715 Seen
: in out Elist_Id
;
716 Null_Seen
: in out Boolean;
717 Non_Null_Seen
: in out Boolean)
719 Is_Output
: constant Boolean := not Is_Input
;
724 -- Multiple input or output items appear as an aggregate
726 if Nkind
(Item
) = N_Aggregate
then
727 if not Top_Level
then
728 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
730 elsif Present
(Component_Associations
(Item
)) then
732 ("nested dependency relations not allowed", Item
);
734 -- Recursively analyze the grouped items
736 elsif Present
(Expressions
(Item
)) then
737 Grouped
:= First
(Expressions
(Item
));
738 while Present
(Grouped
) loop
741 Is_Input
=> Is_Input
,
742 Self_Ref
=> Self_Ref
,
745 Null_Seen
=> Null_Seen
,
746 Non_Null_Seen
=> Non_Null_Seen
);
751 -- Syntax error, always report
754 Error_Msg_N
("malformed dependency list", Item
);
757 -- Process attribute 'Result in the context of a dependency clause
759 elsif Is_Attribute_Result
(Item
) then
760 Non_Null_Seen
:= True;
764 -- Attribute 'Result is allowed to appear on the output side of
765 -- a dependency clause (SPARK RM 6.1.5(6)).
768 SPARK_Msg_N
("function result cannot act as input", Item
);
772 ("cannot mix null and non-null dependency items", Item
);
778 -- Detect multiple uses of null in a single dependency list or
779 -- throughout the whole relation. Verify the placement of a null
780 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
782 elsif Nkind
(Item
) = N_Null
then
785 ("multiple null dependency relations not allowed", Item
);
787 elsif Non_Null_Seen
then
789 ("cannot mix null and non-null dependency items", Item
);
797 ("null output list must be the last clause in a "
798 & "dependency relation", Item
);
800 -- Catch a useless dependence of the form:
805 ("useless dependence, null depends on itself", Item
);
813 Non_Null_Seen
:= True;
816 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
820 Resolve_State
(Item
);
822 -- Find the entity of the item. If this is a renaming, climb
823 -- the renaming chain to reach the root object. Renamings of
824 -- non-entire objects do not yield an entity (Empty).
826 Item_Id
:= Entity_Of
(Item
);
828 if Present
(Item_Id
) then
829 if Ekind_In
(Item_Id
, E_Abstract_State
,
832 E_Generic_In_Out_Parameter
,
833 E_Generic_In_Parameter
,
841 -- The item denotes a concurrent type, but it is not the
842 -- current instance of an enclosing concurrent type.
844 if Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
845 and then not Is_CCT_Instance
(Item
)
848 ("invalid use of subtype mark in dependency "
852 -- Ensure that the item fulfils its role as input and/or
853 -- output as specified by pragma Global or the enclosing
856 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
858 -- Detect multiple uses of the same state, variable or
859 -- formal parameter. If this is not the case, add the
860 -- item to the list of processed relations.
862 if Contains
(Seen
, Item_Id
) then
864 ("duplicate use of item &", Item
, Item_Id
);
866 Append_New_Elmt
(Item_Id
, Seen
);
869 -- Detect illegal use of an input related to a null
870 -- output. Such input items cannot appear in other
871 -- input lists (SPARK RM 6.1.5(13)).
874 and then Null_Output_Seen
875 and then Contains
(All_Inputs_Seen
, Item_Id
)
878 ("input of a null output list cannot appear in "
879 & "multiple input lists", Item
);
882 -- Add an input or a self-referential output to the list
883 -- of all processed inputs.
885 if Is_Input
or else Self_Ref
then
886 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
889 -- State related checks (SPARK RM 6.1.5(3))
891 if Ekind
(Item_Id
) = E_Abstract_State
then
893 -- Package and subprogram bodies are instantiated
894 -- individually in a separate compiler pass. Due to
895 -- this mode of instantiation, the refinement of a
896 -- state may no longer be visible when a subprogram
897 -- body contract is instantiated. Since the generic
898 -- template is legal, do not perform this check in
899 -- the instance to circumvent this oddity.
901 if Is_Generic_Instance
(Spec_Id
) then
904 -- An abstract state with visible refinement cannot
905 -- appear in pragma [Refined_]Depends as its place
906 -- must be taken by some of its constituents
907 -- (SPARK RM 6.1.4(7)).
909 elsif Has_Visible_Refinement
(Item_Id
) then
911 ("cannot mention state & in dependence relation",
913 SPARK_Msg_N
("\use its constituents instead", Item
);
916 -- If the reference to the abstract state appears in
917 -- an enclosing package body that will eventually
918 -- refine the state, record the reference for future
922 Record_Possible_Body_Reference
923 (State_Id
=> Item_Id
,
928 -- When the item renames an entire object, replace the
929 -- item with a reference to the object.
931 if Entity
(Item
) /= Item_Id
then
933 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
937 -- Add the entity of the current item to the list of
940 if Ekind
(Item_Id
) = E_Abstract_State
then
941 Append_New_Elmt
(Item_Id
, States_Seen
);
944 if Ekind_In
(Item_Id
, E_Abstract_State
,
947 and then Present
(Encapsulating_State
(Item_Id
))
949 Append_New_Elmt
(Item_Id
, Constits_Seen
);
952 -- All other input/output items are illegal
953 -- (SPARK RM 6.1.5(1)).
957 ("item must denote parameter, variable, state or "
958 & "current instance of concurren type", Item
);
961 -- All other input/output items are illegal
962 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
966 ("item must denote parameter, variable, state or current "
967 & "instance of concurrent type", Item
);
970 end Analyze_Input_Output
;
978 Non_Null_Output_Seen
: Boolean := False;
979 -- Flag used to check the legality of an output list
981 -- Start of processing for Analyze_Dependency_Clause
984 Inputs
:= Expression
(Clause
);
987 -- An input list with a self-dependency appears as operator "+" where
988 -- the actuals inputs are the right operand.
990 if Nkind
(Inputs
) = N_Op_Plus
then
991 Inputs
:= Right_Opnd
(Inputs
);
995 -- Process the output_list of a dependency_clause
997 Output
:= First
(Choices
(Clause
));
998 while Present
(Output
) loop
1002 Self_Ref
=> Self_Ref
,
1004 Seen
=> All_Outputs_Seen
,
1005 Null_Seen
=> Null_Output_Seen
,
1006 Non_Null_Seen
=> Non_Null_Output_Seen
);
1011 -- Process the input_list of a dependency_clause
1013 Analyze_Input_List
(Inputs
);
1014 end Analyze_Dependency_Clause
;
1016 ---------------------------
1017 -- Check_Function_Return --
1018 ---------------------------
1020 procedure Check_Function_Return
is
1022 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
1023 and then not Result_Seen
1026 ("result of & must appear in exactly one output list",
1029 end Check_Function_Return
;
1035 procedure Check_Role
1037 Item_Id
: Entity_Id
;
1042 (Item_Is_Input
: out Boolean;
1043 Item_Is_Output
: out Boolean);
1044 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1045 -- Item_Is_Output are set depending on the role.
1047 procedure Role_Error
1048 (Item_Is_Input
: Boolean;
1049 Item_Is_Output
: Boolean);
1050 -- Emit an error message concerning the incorrect use of Item in
1051 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1052 -- denote whether the item is an input and/or an output.
1059 (Item_Is_Input
: out Boolean;
1060 Item_Is_Output
: out Boolean)
1063 Item_Is_Input
:= False;
1064 Item_Is_Output
:= False;
1066 -- Abstract state cases
1068 if Ekind
(Item_Id
) = E_Abstract_State
then
1070 -- When pragma Global is present, the mode of the state may be
1071 -- further constrained by setting a more restrictive mode.
1074 if Appears_In
(Subp_Inputs
, Item_Id
) then
1075 Item_Is_Input
:= True;
1078 if Appears_In
(Subp_Outputs
, Item_Id
) then
1079 Item_Is_Output
:= True;
1082 -- Otherwise the state has a default IN OUT mode
1085 Item_Is_Input
:= True;
1086 Item_Is_Output
:= True;
1091 elsif Ekind
(Item_Id
) = E_Constant
then
1092 Item_Is_Input
:= True;
1094 elsif Ekind
(Item_Id
) = E_Discriminant
then
1095 Item_Is_Input
:= True;
1097 -- Generic parameter cases
1099 elsif Ekind
(Item_Id
) = E_Generic_In_Parameter
then
1100 Item_Is_Input
:= True;
1102 elsif Ekind
(Item_Id
) = E_Generic_In_Out_Parameter
then
1103 Item_Is_Input
:= True;
1104 Item_Is_Output
:= True;
1108 elsif Ekind
(Item_Id
) = E_In_Parameter
then
1109 Item_Is_Input
:= True;
1111 elsif Ekind
(Item_Id
) = E_In_Out_Parameter
then
1112 Item_Is_Input
:= True;
1113 Item_Is_Output
:= True;
1115 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1116 if Scope
(Item_Id
) = Spec_Id
then
1118 -- An OUT parameter of the related subprogram has mode IN
1119 -- if its type is unconstrained or tagged because array
1120 -- bounds, discriminants or tags can be read.
1122 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1123 Item_Is_Input
:= True;
1126 Item_Is_Output
:= True;
1128 -- An OUT parameter of an enclosing subprogram behaves as a
1129 -- read-write variable in which case the mode is IN OUT.
1132 Item_Is_Input
:= True;
1133 Item_Is_Output
:= True;
1138 elsif Ekind
(Item_Id
) = E_Protected_Type
then
1140 -- A protected type acts as a formal parameter of mode IN when
1141 -- it applies to a protected function.
1143 if Ekind
(Spec_Id
) = E_Function
then
1144 Item_Is_Input
:= True;
1146 -- Otherwise the protected type acts as a formal of mode IN OUT
1149 Item_Is_Input
:= True;
1150 Item_Is_Output
:= True;
1155 elsif Ekind
(Item_Id
) = E_Task_Type
then
1156 Item_Is_Input
:= True;
1157 Item_Is_Output
:= True;
1161 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1163 -- When pragma Global is present, the mode of the variable may
1164 -- be further constrained by setting a more restrictive mode.
1168 -- A variable has mode IN when its type is unconstrained or
1169 -- tagged because array bounds, discriminants or tags can be
1172 if Appears_In
(Subp_Inputs
, Item_Id
)
1173 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1175 Item_Is_Input
:= True;
1178 if Appears_In
(Subp_Outputs
, Item_Id
) then
1179 Item_Is_Output
:= True;
1182 -- Otherwise the variable has a default IN OUT mode
1185 Item_Is_Input
:= True;
1186 Item_Is_Output
:= True;
1195 procedure Role_Error
1196 (Item_Is_Input
: Boolean;
1197 Item_Is_Output
: Boolean)
1199 Error_Msg
: Name_Id
;
1204 -- When the item is not part of the input and the output set of
1205 -- the related subprogram, then it appears as extra in pragma
1206 -- [Refined_]Depends.
1208 if not Item_Is_Input
and then not Item_Is_Output
then
1209 Add_Item_To_Name_Buffer
(Item_Id
);
1210 Add_Str_To_Name_Buffer
1211 (" & cannot appear in dependence relation");
1213 Error_Msg
:= Name_Find
;
1214 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1216 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1218 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1219 & "set of subprogram %"), Item
, Item_Id
);
1221 -- The mode of the item and its role in pragma [Refined_]Depends
1222 -- are in conflict. Construct a detailed message explaining the
1223 -- illegality (SPARK RM 6.1.5(5-6)).
1226 if Item_Is_Input
then
1227 Add_Str_To_Name_Buffer
("read-only");
1229 Add_Str_To_Name_Buffer
("write-only");
1232 Add_Char_To_Name_Buffer
(' ');
1233 Add_Item_To_Name_Buffer
(Item_Id
);
1234 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1236 if Item_Is_Input
then
1237 Add_Str_To_Name_Buffer
("output");
1239 Add_Str_To_Name_Buffer
("input");
1242 Add_Str_To_Name_Buffer
(" in dependence relation");
1243 Error_Msg
:= Name_Find
;
1244 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1250 Item_Is_Input
: Boolean;
1251 Item_Is_Output
: Boolean;
1253 -- Start of processing for Check_Role
1256 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1261 if not Item_Is_Input
then
1262 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1265 -- Self-referential item
1268 if not Item_Is_Input
or else not Item_Is_Output
then
1269 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1274 elsif not Item_Is_Output
then
1275 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1283 procedure Check_Usage
1284 (Subp_Items
: Elist_Id
;
1285 Used_Items
: Elist_Id
;
1288 procedure Usage_Error
(Item_Id
: Entity_Id
);
1289 -- Emit an error concerning the illegal usage of an item
1295 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1296 Error_Msg
: Name_Id
;
1303 -- Unconstrained and tagged items are not part of the explicit
1304 -- input set of the related subprogram, they do not have to be
1305 -- present in a dependence relation and should not be flagged
1306 -- (SPARK RM 6.1.5(8)).
1308 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1311 Add_Item_To_Name_Buffer
(Item_Id
);
1312 Add_Str_To_Name_Buffer
1313 (" & is missing from input dependence list");
1315 Error_Msg
:= Name_Find
;
1316 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1319 -- Output case (SPARK RM 6.1.5(10))
1324 Add_Item_To_Name_Buffer
(Item_Id
);
1325 Add_Str_To_Name_Buffer
1326 (" & is missing from output dependence list");
1328 Error_Msg
:= Name_Find
;
1329 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1337 Item_Id
: Entity_Id
;
1339 -- Start of processing for Check_Usage
1342 if No
(Subp_Items
) then
1346 -- Each input or output of the subprogram must appear in a dependency
1349 Elmt
:= First_Elmt
(Subp_Items
);
1350 while Present
(Elmt
) loop
1351 Item
:= Node
(Elmt
);
1353 if Nkind
(Item
) = N_Defining_Identifier
then
1356 Item_Id
:= Entity_Of
(Item
);
1359 -- The item does not appear in a dependency
1361 if Present
(Item_Id
)
1362 and then not Contains
(Used_Items
, Item_Id
)
1364 -- The current instance of a concurrent type behaves as a
1365 -- formal parameter (SPARK RM 6.1.4).
1367 if Is_Formal
(Item_Id
)
1368 or else Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
1370 Usage_Error
(Item_Id
);
1372 -- States and global objects are not used properly only when
1373 -- the subprogram is subject to pragma Global.
1375 elsif Global_Seen
then
1376 Usage_Error
(Item_Id
);
1384 ----------------------
1385 -- Normalize_Clause --
1386 ----------------------
1388 procedure Normalize_Clause
(Clause
: Node_Id
) is
1389 procedure Create_Or_Modify_Clause
1395 Multiple
: Boolean);
1396 -- Create a brand new clause to represent the self-reference or
1397 -- modify the input and/or output lists of an existing clause. Output
1398 -- denotes a self-referencial output. Outputs is the output list of a
1399 -- clause. Inputs is the input list of a clause. After denotes the
1400 -- clause after which the new clause is to be inserted. Flag In_Place
1401 -- should be set when normalizing the last output of an output list.
1402 -- Flag Multiple should be set when Output comes from a list with
1405 -----------------------------
1406 -- Create_Or_Modify_Clause --
1407 -----------------------------
1409 procedure Create_Or_Modify_Clause
1417 procedure Propagate_Output
1420 -- Handle the various cases of output propagation to the input
1421 -- list. Output denotes a self-referencial output item. Inputs
1422 -- is the input list of a clause.
1424 ----------------------
1425 -- Propagate_Output --
1426 ----------------------
1428 procedure Propagate_Output
1432 function In_Input_List
1434 Inputs
: List_Id
) return Boolean;
1435 -- Determine whether a particulat item appears in the input
1436 -- list of a clause.
1442 function In_Input_List
1444 Inputs
: List_Id
) return Boolean
1449 Elmt
:= First
(Inputs
);
1450 while Present
(Elmt
) loop
1451 if Entity_Of
(Elmt
) = Item
then
1463 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1466 -- Start of processing for Propagate_Output
1469 -- The clause is of the form:
1471 -- (Output =>+ null)
1473 -- Remove null input and replace it with a copy of the output:
1475 -- (Output => Output)
1477 if Nkind
(Inputs
) = N_Null
then
1478 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1480 -- The clause is of the form:
1482 -- (Output =>+ (Input1, ..., InputN))
1484 -- Determine whether the output is not already mentioned in the
1485 -- input list and if not, add it to the list of inputs:
1487 -- (Output => (Output, Input1, ..., InputN))
1489 elsif Nkind
(Inputs
) = N_Aggregate
then
1490 Grouped
:= Expressions
(Inputs
);
1492 if not In_Input_List
1496 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1499 -- The clause is of the form:
1501 -- (Output =>+ Input)
1503 -- If the input does not mention the output, group the two
1506 -- (Output => (Output, Input))
1508 elsif Entity_Of
(Inputs
) /= Output_Id
then
1510 Make_Aggregate
(Loc
,
1511 Expressions
=> New_List
(
1512 New_Copy_Tree
(Output
),
1513 New_Copy_Tree
(Inputs
))));
1515 end Propagate_Output
;
1519 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1520 New_Clause
: Node_Id
;
1522 -- Start of processing for Create_Or_Modify_Clause
1525 -- A null output depending on itself does not require any
1528 if Nkind
(Output
) = N_Null
then
1531 -- A function result cannot depend on itself because it cannot
1532 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1534 elsif Is_Attribute_Result
(Output
) then
1535 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1539 -- When performing the transformation in place, simply add the
1540 -- output to the list of inputs (if not already there). This
1541 -- case arises when dealing with the last output of an output
1542 -- list. Perform the normalization in place to avoid generating
1543 -- a malformed tree.
1546 Propagate_Output
(Output
, Inputs
);
1548 -- A list with multiple outputs is slowly trimmed until only
1549 -- one element remains. When this happens, replace aggregate
1550 -- with the element itself.
1554 Rewrite
(Outputs
, Output
);
1560 -- Unchain the output from its output list as it will appear in
1561 -- a new clause. Note that we cannot simply rewrite the output
1562 -- as null because this will violate the semantics of pragma
1567 -- Generate a new clause of the form:
1568 -- (Output => Inputs)
1571 Make_Component_Association
(Loc
,
1572 Choices
=> New_List
(Output
),
1573 Expression
=> New_Copy_Tree
(Inputs
));
1575 -- The new clause contains replicated content that has already
1576 -- been analyzed. There is not need to reanalyze or renormalize
1579 Set_Analyzed
(New_Clause
);
1582 (Output
=> First
(Choices
(New_Clause
)),
1583 Inputs
=> Expression
(New_Clause
));
1585 Insert_After
(After
, New_Clause
);
1587 end Create_Or_Modify_Clause
;
1591 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1593 Last_Output
: Node_Id
;
1594 Next_Output
: Node_Id
;
1597 -- Start of processing for Normalize_Clause
1600 -- A self-dependency appears as operator "+". Remove the "+" from the
1601 -- tree by moving the real inputs to their proper place.
1603 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1604 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1605 Inputs
:= Expression
(Clause
);
1607 -- Multiple outputs appear as an aggregate
1609 if Nkind
(Outputs
) = N_Aggregate
then
1610 Last_Output
:= Last
(Expressions
(Outputs
));
1612 Output
:= First
(Expressions
(Outputs
));
1613 while Present
(Output
) loop
1615 -- Normalization may remove an output from its list,
1616 -- preserve the subsequent output now.
1618 Next_Output
:= Next
(Output
);
1620 Create_Or_Modify_Clause
1625 In_Place
=> Output
= Last_Output
,
1628 Output
:= Next_Output
;
1634 Create_Or_Modify_Clause
1643 end Normalize_Clause
;
1647 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1648 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1652 Last_Clause
: Node_Id
;
1653 Restore_Scope
: Boolean := False;
1655 -- Start of processing for Analyze_Depends_In_Decl_Part
1658 -- Do not analyze the pragma multiple times
1660 if Is_Analyzed_Pragma
(N
) then
1664 -- Empty dependency list
1666 if Nkind
(Deps
) = N_Null
then
1668 -- Gather all states, objects and formal parameters that the
1669 -- subprogram may depend on. These items are obtained from the
1670 -- parameter profile or pragma [Refined_]Global (if available).
1672 Collect_Subprogram_Inputs_Outputs
1673 (Subp_Id
=> Subp_Id
,
1674 Subp_Inputs
=> Subp_Inputs
,
1675 Subp_Outputs
=> Subp_Outputs
,
1676 Global_Seen
=> Global_Seen
);
1678 -- Verify that every input or output of the subprogram appear in a
1681 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1682 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1683 Check_Function_Return
;
1685 -- Dependency clauses appear as component associations of an aggregate
1687 elsif Nkind
(Deps
) = N_Aggregate
then
1689 -- Do not attempt to perform analysis of a syntactically illegal
1690 -- clause as this will lead to misleading errors.
1692 if Has_Extra_Parentheses
(Deps
) then
1696 if Present
(Component_Associations
(Deps
)) then
1697 Last_Clause
:= Last
(Component_Associations
(Deps
));
1699 -- Gather all states, objects and formal parameters that the
1700 -- subprogram may depend on. These items are obtained from the
1701 -- parameter profile or pragma [Refined_]Global (if available).
1703 Collect_Subprogram_Inputs_Outputs
1704 (Subp_Id
=> Subp_Id
,
1705 Subp_Inputs
=> Subp_Inputs
,
1706 Subp_Outputs
=> Subp_Outputs
,
1707 Global_Seen
=> Global_Seen
);
1709 -- When pragma [Refined_]Depends appears on a single concurrent
1710 -- type, it is relocated to the anonymous object.
1712 if Is_Single_Concurrent_Object
(Spec_Id
) then
1715 -- Ensure that the formal parameters are visible when analyzing
1716 -- all clauses. This falls out of the general rule of aspects
1717 -- pertaining to subprogram declarations.
1719 elsif not In_Open_Scopes
(Spec_Id
) then
1720 Restore_Scope
:= True;
1721 Push_Scope
(Spec_Id
);
1723 if Ekind
(Spec_Id
) = E_Task_Type
then
1724 if Has_Discriminants
(Spec_Id
) then
1725 Install_Discriminants
(Spec_Id
);
1728 elsif Is_Generic_Subprogram
(Spec_Id
) then
1729 Install_Generic_Formals
(Spec_Id
);
1732 Install_Formals
(Spec_Id
);
1736 Clause
:= First
(Component_Associations
(Deps
));
1737 while Present
(Clause
) loop
1738 Errors
:= Serious_Errors_Detected
;
1740 -- The normalization mechanism may create extra clauses that
1741 -- contain replicated input and output names. There is no need
1742 -- to reanalyze them.
1744 if not Analyzed
(Clause
) then
1745 Set_Analyzed
(Clause
);
1747 Analyze_Dependency_Clause
1749 Is_Last
=> Clause
= Last_Clause
);
1752 -- Do not normalize a clause if errors were detected (count
1753 -- of Serious_Errors has increased) because the inputs and/or
1754 -- outputs may denote illegal items. Normalization is disabled
1755 -- in ASIS mode as it alters the tree by introducing new nodes
1756 -- similar to expansion.
1758 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1759 Normalize_Clause
(Clause
);
1765 if Restore_Scope
then
1769 -- Verify that every input or output of the subprogram appear in a
1772 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1773 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1774 Check_Function_Return
;
1776 -- The dependency list is malformed. This is a syntax error, always
1780 Error_Msg_N
("malformed dependency relation", Deps
);
1784 -- The top level dependency relation is malformed. This is a syntax
1785 -- error, always report.
1788 Error_Msg_N
("malformed dependency relation", Deps
);
1792 -- Ensure that a state and a corresponding constituent do not appear
1793 -- together in pragma [Refined_]Depends.
1795 Check_State_And_Constituent_Use
1796 (States
=> States_Seen
,
1797 Constits
=> Constits_Seen
,
1801 Set_Is_Analyzed_Pragma
(N
);
1802 end Analyze_Depends_In_Decl_Part
;
1804 --------------------------------------------
1805 -- Analyze_External_Property_In_Decl_Part --
1806 --------------------------------------------
1808 procedure Analyze_External_Property_In_Decl_Part
1810 Expr_Val
: out Boolean)
1812 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1813 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
1814 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
1820 -- Do not analyze the pragma multiple times
1822 if Is_Analyzed_Pragma
(N
) then
1826 Error_Msg_Name_1
:= Pragma_Name
(N
);
1828 -- An external property pragma must apply to an effectively volatile
1829 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1830 -- The check is performed at the end of the declarative region due to a
1831 -- possible out-of-order arrangement of pragmas:
1834 -- pragma Async_Readers (Obj);
1835 -- pragma Volatile (Obj);
1837 if not Is_Effectively_Volatile
(Obj_Id
) then
1839 ("external property % must apply to a volatile object", N
);
1842 -- Ensure that the Boolean expression (if present) is static. A missing
1843 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1847 if Present
(Arg1
) then
1848 Expr
:= Get_Pragma_Arg
(Arg1
);
1850 if Is_OK_Static_Expression
(Expr
) then
1851 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
1855 Set_Is_Analyzed_Pragma
(N
);
1856 end Analyze_External_Property_In_Decl_Part
;
1858 ---------------------------------
1859 -- Analyze_Global_In_Decl_Part --
1860 ---------------------------------
1862 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
1863 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
1864 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
1865 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1867 Constits_Seen
: Elist_Id
:= No_Elist
;
1868 -- A list containing the entities of all constituents processed so far.
1869 -- It aids in detecting illegal usage of a state and a corresponding
1870 -- constituent in pragma [Refinde_]Global.
1872 Seen
: Elist_Id
:= No_Elist
;
1873 -- A list containing the entities of all the items processed so far. It
1874 -- plays a role in detecting distinct entities.
1876 States_Seen
: Elist_Id
:= No_Elist
;
1877 -- A list containing the entities of all states processed so far. It
1878 -- helps in detecting illegal usage of a state and a corresponding
1879 -- constituent in pragma [Refined_]Global.
1881 In_Out_Seen
: Boolean := False;
1882 Input_Seen
: Boolean := False;
1883 Output_Seen
: Boolean := False;
1884 Proof_Seen
: Boolean := False;
1885 -- Flags used to verify the consistency of modes
1887 procedure Analyze_Global_List
1889 Global_Mode
: Name_Id
:= Name_Input
);
1890 -- Verify the legality of a single global list declaration. Global_Mode
1891 -- denotes the current mode in effect.
1893 -------------------------
1894 -- Analyze_Global_List --
1895 -------------------------
1897 procedure Analyze_Global_List
1899 Global_Mode
: Name_Id
:= Name_Input
)
1901 procedure Analyze_Global_Item
1903 Global_Mode
: Name_Id
);
1904 -- Verify the legality of a single global item declaration denoted by
1905 -- Item. Global_Mode denotes the current mode in effect.
1907 procedure Check_Duplicate_Mode
1909 Status
: in out Boolean);
1910 -- Flag Status denotes whether a particular mode has been seen while
1911 -- processing a global list. This routine verifies that Mode is not a
1912 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1914 procedure Check_Mode_Restriction_In_Enclosing_Context
1916 Item_Id
: Entity_Id
);
1917 -- Verify that an item of mode In_Out or Output does not appear as an
1918 -- input in the Global aspect of an enclosing subprogram. If this is
1919 -- the case, emit an error. Item and Item_Id are respectively the
1920 -- item and its entity.
1922 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
1923 -- Mode denotes either In_Out or Output. Depending on the kind of the
1924 -- related subprogram, emit an error if those two modes apply to a
1925 -- function (SPARK RM 6.1.4(10)).
1927 -------------------------
1928 -- Analyze_Global_Item --
1929 -------------------------
1931 procedure Analyze_Global_Item
1933 Global_Mode
: Name_Id
)
1935 Item_Id
: Entity_Id
;
1938 -- Detect one of the following cases
1940 -- with Global => (null, Name)
1941 -- with Global => (Name_1, null, Name_2)
1942 -- with Global => (Name, null)
1944 if Nkind
(Item
) = N_Null
then
1945 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
1950 Resolve_State
(Item
);
1952 -- Find the entity of the item. If this is a renaming, climb the
1953 -- renaming chain to reach the root object. Renamings of non-
1954 -- entire objects do not yield an entity (Empty).
1956 Item_Id
:= Entity_Of
(Item
);
1958 if Present
(Item_Id
) then
1960 -- A global item may denote a formal parameter of an enclosing
1961 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1962 -- provide a better error diagnostic.
1964 if Is_Formal
(Item_Id
) then
1965 if Scope
(Item_Id
) = Spec_Id
then
1967 (Fix_Msg
(Spec_Id
, "global item cannot reference "
1968 & "parameter of subprogram &"), Item
, Spec_Id
);
1972 -- A global item may denote a concurrent type as long as it is
1973 -- the current instance of an enclosing concurrent type
1974 -- (SPARK RM 6.1.4).
1976 elsif Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
1977 if Is_CCT_Instance
(Item
) then
1979 -- Pragma [Refined_]Global associated with a protected
1980 -- subprogram cannot mention the current instance of a
1981 -- protected type because the instance behaves as a
1982 -- formal parameter.
1984 if Ekind
(Item_Id
) = E_Protected_Type
1985 and then Scope
(Spec_Id
) = Item_Id
1987 Error_Msg_Name_1
:= Chars
(Item_Id
);
1989 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
1990 & "cannot reference current instance of protected "
1991 & "type %"), Item
, Spec_Id
);
1994 -- Pragma [Refined_]Global associated with a task type
1995 -- cannot mention the current instance of a task type
1996 -- because the instance behaves as a formal parameter.
1998 elsif Ekind
(Item_Id
) = E_Task_Type
1999 and then Spec_Id
= Item_Id
2001 Error_Msg_Name_1
:= Chars
(Item_Id
);
2003 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2004 & "cannot reference current instance of task type "
2005 & "%"), Item
, Spec_Id
);
2009 -- Otherwise the global item denotes a subtype mark that is
2010 -- not a current instance.
2014 ("invalid use of subtype mark in global list", Item
);
2018 -- A formal object may act as a global item inside a generic
2020 elsif Is_Formal_Object
(Item_Id
) then
2023 -- The only legal references are those to abstract states,
2024 -- discriminants and objects (SPARK RM 6.1.4(4)).
2026 elsif not Ekind_In
(Item_Id
, E_Abstract_State
,
2032 ("global item must denote object, state or current "
2033 & "instance of concurrent type", Item
);
2037 -- State related checks
2039 if Ekind
(Item_Id
) = E_Abstract_State
then
2041 -- Package and subprogram bodies are instantiated
2042 -- individually in a separate compiler pass. Due to this
2043 -- mode of instantiation, the refinement of a state may
2044 -- no longer be visible when a subprogram body contract
2045 -- is instantiated. Since the generic template is legal,
2046 -- do not perform this check in the instance to circumvent
2049 if Is_Generic_Instance
(Spec_Id
) then
2052 -- An abstract state with visible refinement cannot appear
2053 -- in pragma [Refined_]Global as its place must be taken by
2054 -- some of its constituents (SPARK RM 6.1.4(7)).
2056 elsif Has_Visible_Refinement
(Item_Id
) then
2058 ("cannot mention state & in global refinement",
2060 SPARK_Msg_N
("\use its constituents instead", Item
);
2063 -- An external state cannot appear as a global item of a
2064 -- nonvolatile function (SPARK RM 7.1.3(8)).
2066 elsif Is_External_State
(Item_Id
)
2067 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2068 and then not Is_Volatile_Function
(Spec_Id
)
2071 ("external state & cannot act as global item of "
2072 & "nonvolatile function", Item
, Item_Id
);
2075 -- If the reference to the abstract state appears in an
2076 -- enclosing package body that will eventually refine the
2077 -- state, record the reference for future checks.
2080 Record_Possible_Body_Reference
2081 (State_Id
=> Item_Id
,
2085 -- Constant related checks
2087 elsif Ekind
(Item_Id
) = E_Constant
then
2089 -- A constant is a read-only item, therefore it cannot act
2092 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2094 ("constant & cannot act as output", Item
, Item_Id
);
2098 -- Discriminant related checks
2100 elsif Ekind
(Item_Id
) = E_Discriminant
then
2102 -- A discriminant is a read-only item, therefore it cannot
2103 -- act as an output.
2105 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2107 ("discriminant & cannot act as output", Item
, Item_Id
);
2111 -- Variable related checks. These are only relevant when
2112 -- SPARK_Mode is on as they are not standard Ada legality
2115 elsif SPARK_Mode
= On
2116 and then Ekind
(Item_Id
) = E_Variable
2117 and then Is_Effectively_Volatile
(Item_Id
)
2119 -- An effectively volatile object cannot appear as a global
2120 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2122 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2123 and then not Is_Volatile_Function
(Spec_Id
)
2126 ("volatile object & cannot act as global item of a "
2127 & "function", Item
, Item_Id
);
2130 -- An effectively volatile object with external property
2131 -- Effective_Reads set to True must have mode Output or
2132 -- In_Out (SPARK RM 7.1.3(11)).
2134 elsif Effective_Reads_Enabled
(Item_Id
)
2135 and then Global_Mode
= Name_Input
2138 ("volatile object & with property Effective_Reads must "
2139 & "have mode In_Out or Output", Item
, Item_Id
);
2144 -- When the item renames an entire object, replace the item
2145 -- with a reference to the object.
2147 if Entity
(Item
) /= Item_Id
then
2148 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2152 -- Some form of illegal construct masquerading as a name
2153 -- (SPARK RM 6.1.4(4)).
2157 ("global item must denote object, state or current instance "
2158 & "of concurrent type", Item
);
2162 -- Verify that an output does not appear as an input in an
2163 -- enclosing subprogram.
2165 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2166 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2169 -- The same entity might be referenced through various way.
2170 -- Check the entity of the item rather than the item itself
2171 -- (SPARK RM 6.1.4(10)).
2173 if Contains
(Seen
, Item_Id
) then
2174 SPARK_Msg_N
("duplicate global item", Item
);
2176 -- Add the entity of the current item to the list of processed
2180 Append_New_Elmt
(Item_Id
, Seen
);
2182 if Ekind
(Item_Id
) = E_Abstract_State
then
2183 Append_New_Elmt
(Item_Id
, States_Seen
);
2186 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
2187 and then Present
(Encapsulating_State
(Item_Id
))
2189 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2192 end Analyze_Global_Item
;
2194 --------------------------
2195 -- Check_Duplicate_Mode --
2196 --------------------------
2198 procedure Check_Duplicate_Mode
2200 Status
: in out Boolean)
2204 SPARK_Msg_N
("duplicate global mode", Mode
);
2208 end Check_Duplicate_Mode
;
2210 -------------------------------------------------
2211 -- Check_Mode_Restriction_In_Enclosing_Context --
2212 -------------------------------------------------
2214 procedure Check_Mode_Restriction_In_Enclosing_Context
2216 Item_Id
: Entity_Id
)
2218 Context
: Entity_Id
;
2220 Inputs
: Elist_Id
:= No_Elist
;
2221 Outputs
: Elist_Id
:= No_Elist
;
2224 -- Traverse the scope stack looking for enclosing subprograms
2225 -- subject to pragma [Refined_]Global.
2227 Context
:= Scope
(Subp_Id
);
2228 while Present
(Context
) and then Context
/= Standard_Standard
loop
2229 if Is_Subprogram
(Context
)
2231 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2233 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2235 Collect_Subprogram_Inputs_Outputs
2236 (Subp_Id
=> Context
,
2237 Subp_Inputs
=> Inputs
,
2238 Subp_Outputs
=> Outputs
,
2239 Global_Seen
=> Dummy
);
2241 -- The item is classified as In_Out or Output but appears as
2242 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2244 if Appears_In
(Inputs
, Item_Id
)
2245 and then not Appears_In
(Outputs
, Item_Id
)
2248 ("global item & cannot have mode In_Out or Output",
2252 (Fix_Msg
(Subp_Id
, "\item already appears as input of "
2253 & "subprogram &"), Item
, Context
);
2255 -- Stop the traversal once an error has been detected
2261 Context
:= Scope
(Context
);
2263 end Check_Mode_Restriction_In_Enclosing_Context
;
2265 ----------------------------------------
2266 -- Check_Mode_Restriction_In_Function --
2267 ----------------------------------------
2269 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2271 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2273 ("global mode & is not applicable to functions", Mode
);
2275 end Check_Mode_Restriction_In_Function
;
2283 -- Start of processing for Analyze_Global_List
2286 if Nkind
(List
) = N_Null
then
2287 Set_Analyzed
(List
);
2289 -- Single global item declaration
2291 elsif Nkind_In
(List
, N_Expanded_Name
,
2293 N_Selected_Component
)
2295 Analyze_Global_Item
(List
, Global_Mode
);
2297 -- Simple global list or moded global list declaration
2299 elsif Nkind
(List
) = N_Aggregate
then
2300 Set_Analyzed
(List
);
2302 -- The declaration of a simple global list appear as a collection
2305 if Present
(Expressions
(List
)) then
2306 if Present
(Component_Associations
(List
)) then
2308 ("cannot mix moded and non-moded global lists", List
);
2311 Item
:= First
(Expressions
(List
));
2312 while Present
(Item
) loop
2313 Analyze_Global_Item
(Item
, Global_Mode
);
2317 -- The declaration of a moded global list appears as a collection
2318 -- of component associations where individual choices denote
2321 elsif Present
(Component_Associations
(List
)) then
2322 if Present
(Expressions
(List
)) then
2324 ("cannot mix moded and non-moded global lists", List
);
2327 Assoc
:= First
(Component_Associations
(List
));
2328 while Present
(Assoc
) loop
2329 Mode
:= First
(Choices
(Assoc
));
2331 if Nkind
(Mode
) = N_Identifier
then
2332 if Chars
(Mode
) = Name_In_Out
then
2333 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2334 Check_Mode_Restriction_In_Function
(Mode
);
2336 elsif Chars
(Mode
) = Name_Input
then
2337 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2339 elsif Chars
(Mode
) = Name_Output
then
2340 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2341 Check_Mode_Restriction_In_Function
(Mode
);
2343 elsif Chars
(Mode
) = Name_Proof_In
then
2344 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2347 SPARK_Msg_N
("invalid mode selector", Mode
);
2351 SPARK_Msg_N
("invalid mode selector", Mode
);
2354 -- Items in a moded list appear as a collection of
2355 -- expressions. Reuse the existing machinery to analyze
2359 (List
=> Expression
(Assoc
),
2360 Global_Mode
=> Chars
(Mode
));
2368 raise Program_Error
;
2371 -- Any other attempt to declare a global item is illegal. This is a
2372 -- syntax error, always report.
2375 Error_Msg_N
("malformed global list", List
);
2377 end Analyze_Global_List
;
2381 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2383 Restore_Scope
: Boolean := False;
2385 -- Start of processing for Analyze_Global_In_Decl_Part
2388 -- Do not analyze the pragma multiple times
2390 if Is_Analyzed_Pragma
(N
) then
2394 -- There is nothing to be done for a null global list
2396 if Nkind
(Items
) = N_Null
then
2397 Set_Analyzed
(Items
);
2399 -- Analyze the various forms of global lists and items. Note that some
2400 -- of these may be malformed in which case the analysis emits error
2404 -- When pragma [Refined_]Global appears on a single concurrent type,
2405 -- it is relocated to the anonymous object.
2407 if Is_Single_Concurrent_Object
(Spec_Id
) then
2410 -- Ensure that the formal parameters are visible when processing an
2411 -- item. This falls out of the general rule of aspects pertaining to
2412 -- subprogram declarations.
2414 elsif not In_Open_Scopes
(Spec_Id
) then
2415 Restore_Scope
:= True;
2416 Push_Scope
(Spec_Id
);
2418 if Ekind
(Spec_Id
) = E_Task_Type
then
2419 if Has_Discriminants
(Spec_Id
) then
2420 Install_Discriminants
(Spec_Id
);
2423 elsif Is_Generic_Subprogram
(Spec_Id
) then
2424 Install_Generic_Formals
(Spec_Id
);
2427 Install_Formals
(Spec_Id
);
2431 Analyze_Global_List
(Items
);
2433 if Restore_Scope
then
2438 -- Ensure that a state and a corresponding constituent do not appear
2439 -- together in pragma [Refined_]Global.
2441 Check_State_And_Constituent_Use
2442 (States
=> States_Seen
,
2443 Constits
=> Constits_Seen
,
2446 Set_Is_Analyzed_Pragma
(N
);
2447 end Analyze_Global_In_Decl_Part
;
2449 --------------------------------------------
2450 -- Analyze_Initial_Condition_In_Decl_Part --
2451 --------------------------------------------
2453 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2454 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2455 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2456 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2458 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2461 -- Do not analyze the pragma multiple times
2463 if Is_Analyzed_Pragma
(N
) then
2467 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2468 -- analysis of the pragma, the Ghost mode at point of declaration and
2469 -- point of analysis may not necessarely be the same. Use the mode in
2470 -- effect at the point of declaration.
2474 -- The expression is preanalyzed because it has not been moved to its
2475 -- final place yet. A direct analysis may generate side effects and this
2476 -- is not desired at this point.
2478 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2479 Ghost_Mode
:= Save_Ghost_Mode
;
2481 Set_Is_Analyzed_Pragma
(N
);
2482 end Analyze_Initial_Condition_In_Decl_Part
;
2484 --------------------------------------
2485 -- Analyze_Initializes_In_Decl_Part --
2486 --------------------------------------
2488 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2489 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2490 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2492 Constits_Seen
: Elist_Id
:= No_Elist
;
2493 -- A list containing the entities of all constituents processed so far.
2494 -- It aids in detecting illegal usage of a state and a corresponding
2495 -- constituent in pragma Initializes.
2497 Items_Seen
: Elist_Id
:= No_Elist
;
2498 -- A list of all initialization items processed so far. This list is
2499 -- used to detect duplicate items.
2501 Non_Null_Seen
: Boolean := False;
2502 Null_Seen
: Boolean := False;
2503 -- Flags used to check the legality of a null initialization list
2505 States_And_Objs
: Elist_Id
:= No_Elist
;
2506 -- A list of all abstract states and objects declared in the visible
2507 -- declarations of the related package. This list is used to detect the
2508 -- legality of initialization items.
2510 States_Seen
: Elist_Id
:= No_Elist
;
2511 -- A list containing the entities of all states processed so far. It
2512 -- helps in detecting illegal usage of a state and a corresponding
2513 -- constituent in pragma Initializes.
2515 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2516 -- Verify the legality of a single initialization item
2518 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2519 -- Verify the legality of a single initialization item followed by a
2520 -- list of input items.
2522 procedure Collect_States_And_Objects
;
2523 -- Inspect the visible declarations of the related package and gather
2524 -- the entities of all abstract states and objects in States_And_Objs.
2526 ---------------------------------
2527 -- Analyze_Initialization_Item --
2528 ---------------------------------
2530 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2531 Item_Id
: Entity_Id
;
2534 -- Null initialization list
2536 if Nkind
(Item
) = N_Null
then
2538 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2540 elsif Non_Null_Seen
then
2542 ("cannot mix null and non-null initialization items", Item
);
2547 -- Initialization item
2550 Non_Null_Seen
:= True;
2554 ("cannot mix null and non-null initialization items", Item
);
2558 Resolve_State
(Item
);
2560 if Is_Entity_Name
(Item
) then
2561 Item_Id
:= Entity_Of
(Item
);
2563 if Ekind_In
(Item_Id
, E_Abstract_State
,
2567 -- The state or variable must be declared in the visible
2568 -- declarations of the package (SPARK RM 7.1.5(7)).
2570 if not Contains
(States_And_Objs
, Item_Id
) then
2571 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2573 ("initialization item & must appear in the visible "
2574 & "declarations of package %", Item
, Item_Id
);
2576 -- Detect a duplicate use of the same initialization item
2577 -- (SPARK RM 7.1.5(5)).
2579 elsif Contains
(Items_Seen
, Item_Id
) then
2580 SPARK_Msg_N
("duplicate initialization item", Item
);
2582 -- The item is legal, add it to the list of processed states
2586 Append_New_Elmt
(Item_Id
, Items_Seen
);
2588 if Ekind
(Item_Id
) = E_Abstract_State
then
2589 Append_New_Elmt
(Item_Id
, States_Seen
);
2592 if Present
(Encapsulating_State
(Item_Id
)) then
2593 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2597 -- The item references something that is not a state or object
2598 -- (SPARK RM 7.1.5(3)).
2602 ("initialization item must denote object or state", Item
);
2605 -- Some form of illegal construct masquerading as a name
2606 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2610 ("initialization item must denote object or state", Item
);
2613 end Analyze_Initialization_Item
;
2615 ---------------------------------------------
2616 -- Analyze_Initialization_Item_With_Inputs --
2617 ---------------------------------------------
2619 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2620 Inputs_Seen
: Elist_Id
:= No_Elist
;
2621 -- A list of all inputs processed so far. This list is used to detect
2622 -- duplicate uses of an input.
2624 Non_Null_Seen
: Boolean := False;
2625 Null_Seen
: Boolean := False;
2626 -- Flags used to check the legality of an input list
2628 procedure Analyze_Input_Item
(Input
: Node_Id
);
2629 -- Verify the legality of a single input item
2631 ------------------------
2632 -- Analyze_Input_Item --
2633 ------------------------
2635 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2636 Input_Id
: Entity_Id
;
2641 if Nkind
(Input
) = N_Null
then
2644 ("multiple null initializations not allowed", Item
);
2646 elsif Non_Null_Seen
then
2648 ("cannot mix null and non-null initialization item", Item
);
2656 Non_Null_Seen
:= True;
2660 ("cannot mix null and non-null initialization item", Item
);
2664 Resolve_State
(Input
);
2666 if Is_Entity_Name
(Input
) then
2667 Input_Id
:= Entity_Of
(Input
);
2669 if Ekind_In
(Input_Id
, E_Abstract_State
,
2676 -- The input cannot denote states or objects declared
2677 -- within the related package (SPARK RM 7.1.5(4)).
2679 if Within_Scope
(Input_Id
, Current_Scope
) then
2680 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2682 ("input item & cannot denote a visible object or "
2683 & "state of package %", Input
, Input_Id
);
2685 -- Detect a duplicate use of the same input item
2686 -- (SPARK RM 7.1.5(5)).
2688 elsif Contains
(Inputs_Seen
, Input_Id
) then
2689 SPARK_Msg_N
("duplicate input item", Input
);
2691 -- Input is legal, add it to the list of processed inputs
2694 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2696 if Ekind
(Input_Id
) = E_Abstract_State
then
2697 Append_New_Elmt
(Input_Id
, States_Seen
);
2700 if Ekind_In
(Input_Id
, E_Abstract_State
,
2703 and then Present
(Encapsulating_State
(Input_Id
))
2705 Append_New_Elmt
(Input_Id
, Constits_Seen
);
2709 -- The input references something that is not a state or an
2710 -- object (SPARK RM 7.1.5(3)).
2714 ("input item must denote object or state", Input
);
2717 -- Some form of illegal construct masquerading as a name
2718 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2722 ("input item must denote object or state", Input
);
2725 end Analyze_Input_Item
;
2729 Inputs
: constant Node_Id
:= Expression
(Item
);
2733 Name_Seen
: Boolean := False;
2734 -- A flag used to detect multiple item names
2736 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2739 -- Inspect the name of an item with inputs
2741 Elmt
:= First
(Choices
(Item
));
2742 while Present
(Elmt
) loop
2744 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
2747 Analyze_Initialization_Item
(Elmt
);
2753 -- Multiple input items appear as an aggregate
2755 if Nkind
(Inputs
) = N_Aggregate
then
2756 if Present
(Expressions
(Inputs
)) then
2757 Input
:= First
(Expressions
(Inputs
));
2758 while Present
(Input
) loop
2759 Analyze_Input_Item
(Input
);
2764 if Present
(Component_Associations
(Inputs
)) then
2766 ("inputs must appear in named association form", Inputs
);
2769 -- Single input item
2772 Analyze_Input_Item
(Inputs
);
2774 end Analyze_Initialization_Item_With_Inputs
;
2776 --------------------------------
2777 -- Collect_States_And_Objects --
2778 --------------------------------
2780 procedure Collect_States_And_Objects
is
2781 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
2785 -- Collect the abstract states defined in the package (if any)
2787 if Present
(Abstract_States
(Pack_Id
)) then
2788 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
2791 -- Collect all objects the appear in the visible declarations of the
2794 if Present
(Visible_Declarations
(Pack_Spec
)) then
2795 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
2796 while Present
(Decl
) loop
2797 if Comes_From_Source
(Decl
)
2798 and then Nkind
(Decl
) = N_Object_Declaration
2800 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
2806 end Collect_States_And_Objects
;
2810 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2813 -- Start of processing for Analyze_Initializes_In_Decl_Part
2816 -- Do not analyze the pragma multiple times
2818 if Is_Analyzed_Pragma
(N
) then
2822 -- Nothing to do when the initialization list is empty
2824 if Nkind
(Inits
) = N_Null
then
2828 -- Single and multiple initialization clauses appear as an aggregate. If
2829 -- this is not the case, then either the parser or the analysis of the
2830 -- pragma failed to produce an aggregate.
2832 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
2834 -- Initialize the various lists used during analysis
2836 Collect_States_And_Objects
;
2838 if Present
(Expressions
(Inits
)) then
2839 Init
:= First
(Expressions
(Inits
));
2840 while Present
(Init
) loop
2841 Analyze_Initialization_Item
(Init
);
2846 if Present
(Component_Associations
(Inits
)) then
2847 Init
:= First
(Component_Associations
(Inits
));
2848 while Present
(Init
) loop
2849 Analyze_Initialization_Item_With_Inputs
(Init
);
2854 -- Ensure that a state and a corresponding constituent do not appear
2855 -- together in pragma Initializes.
2857 Check_State_And_Constituent_Use
2858 (States
=> States_Seen
,
2859 Constits
=> Constits_Seen
,
2862 Set_Is_Analyzed_Pragma
(N
);
2863 end Analyze_Initializes_In_Decl_Part
;
2865 ---------------------
2866 -- Analyze_Part_Of --
2867 ---------------------
2869 procedure Analyze_Part_Of
2871 Item_Id
: Entity_Id
;
2873 Encap_Id
: out Entity_Id
;
2874 Legal
: out Boolean)
2876 Encap_Typ
: Entity_Id
;
2877 Item_Decl
: Node_Id
;
2878 Pack_Id
: Entity_Id
;
2879 Placement
: State_Space_Kind
;
2880 Parent_Unit
: Entity_Id
;
2883 -- Assume that the indicator is illegal
2888 if Nkind_In
(Encap
, N_Expanded_Name
,
2890 N_Selected_Component
)
2893 Resolve_State
(Encap
);
2895 Encap_Id
:= Entity
(Encap
);
2897 -- The encapsulator is an abstract state
2899 if Ekind
(Encap_Id
) = E_Abstract_State
then
2902 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
2904 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
2907 -- Otherwise the encapsulator is not a legal choice
2911 ("indicator Part_Of must denote abstract state, single "
2912 & "protected type or single task type", Encap
);
2916 -- This is a syntax error, always report
2920 ("indicator Part_Of must denote abstract state, single protected "
2921 & "type or single task type", Encap
);
2925 -- Catch a case where indicator Part_Of denotes the abstract view of a
2926 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
2928 if From_Limited_With
(Encap_Id
)
2929 and then Present
(Non_Limited_View
(Encap_Id
))
2930 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
2932 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
2933 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
2937 -- The encapsulator is an abstract state
2939 if Ekind
(Encap_Id
) = E_Abstract_State
then
2941 -- Determine where the object, package instantiation or state lives
2942 -- with respect to the enclosing packages or package bodies.
2944 Find_Placement_In_State_Space
2945 (Item_Id
=> Item_Id
,
2946 Placement
=> Placement
,
2947 Pack_Id
=> Pack_Id
);
2949 -- The item appears in a non-package construct with a declarative
2950 -- part (subprogram, block, etc). As such, the item is not allowed
2951 -- to be a part of an encapsulating state because the item is not
2954 if Placement
= Not_In_Package
then
2956 ("indicator Part_Of cannot appear in this context "
2957 & "(SPARK RM 7.2.6(5))", Indic
);
2958 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
2960 ("\& is not part of the hidden state of package %",
2963 -- The item appears in the visible state space of some package. In
2964 -- general this scenario does not warrant Part_Of except when the
2965 -- package is a private child unit and the encapsulating state is
2966 -- declared in a parent unit or a public descendant of that parent
2969 elsif Placement
= Visible_State_Space
then
2970 if Is_Child_Unit
(Pack_Id
)
2971 and then Is_Private_Descendant
(Pack_Id
)
2973 -- A variable or state abstraction which is part of the visible
2974 -- state of a private child unit (or one of its public
2975 -- descendants) must have its Part_Of indicator specified. The
2976 -- Part_Of indicator must denote a state abstraction declared
2977 -- by either the parent unit of the private unit or by a public
2978 -- descendant of that parent unit.
2980 -- Find nearest private ancestor (which can be the current unit
2983 Parent_Unit
:= Pack_Id
;
2984 while Present
(Parent_Unit
) loop
2987 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
2988 Parent_Unit
:= Scope
(Parent_Unit
);
2991 Parent_Unit
:= Scope
(Parent_Unit
);
2993 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
2995 ("indicator Part_Of must denote abstract state or public "
2996 & "descendant of & (SPARK RM 7.2.6(3))",
2997 Indic
, Parent_Unit
);
2999 elsif Scope
(Encap_Id
) = Parent_Unit
3001 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3002 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3008 ("indicator Part_Of must denote abstract state or public "
3009 & "descendant of & (SPARK RM 7.2.6(3))",
3010 Indic
, Parent_Unit
);
3013 -- Indicator Part_Of is not needed when the related package is not
3014 -- a private child unit or a public descendant thereof.
3018 ("indicator Part_Of cannot appear in this context "
3019 & "(SPARK RM 7.2.6(5))", Indic
);
3020 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3022 ("\& is declared in the visible part of package %",
3026 -- When the item appears in the private state space of a package, the
3027 -- encapsulating state must be declared in the same package.
3029 elsif Placement
= Private_State_Space
then
3030 if Scope
(Encap_Id
) /= Pack_Id
then
3032 ("indicator Part_Of must designate an abstract state of "
3033 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3034 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3036 ("\& is declared in the private part of package %",
3040 -- Items declared in the body state space of a package do not need
3041 -- Part_Of indicators as the refinement has already been seen.
3045 ("indicator Part_Of cannot appear in this context "
3046 & "(SPARK RM 7.2.6(5))", Indic
);
3048 if Scope
(Encap_Id
) = Pack_Id
then
3049 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3051 ("\& is declared in the body of package %", Indic
, Item_Id
);
3055 -- The encapsulator is a single concurrent type
3058 Encap_Typ
:= Etype
(Encap_Id
);
3060 -- Only abstract states and variables can act as constituents of an
3061 -- encapsulating single concurrent type.
3063 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3066 -- The constituent is a constant
3068 elsif Ekind
(Item_Id
) = E_Constant
then
3069 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3071 (Fix_Msg
(Encap_Typ
, "consant & cannot act as constituent of "
3072 & "single protected type %"), Indic
, Item_Id
);
3074 -- The constituent is a package instantiation
3077 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3079 (Fix_Msg
(Encap_Typ
, "package instantiation & cannot act as "
3080 & "constituent of single protected type %"), Indic
, Item_Id
);
3083 -- When the item denotes an abstract state of a nested package, use
3084 -- the declaration of the package to detect proper placement.
3089 -- with Abstract_State => (State with Part_Of => T)
3091 if Ekind
(Item_Id
) = E_Abstract_State
then
3092 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3094 Item_Decl
:= Declaration_Node
(Item_Id
);
3097 -- Both the item and its encapsulating single concurrent type must
3098 -- appear in the same declarative region (SPARK RM 9.3). Note that
3099 -- privacy is ignored.
3101 if Parent
(Item_Decl
) /= Parent
(Declaration_Node
(Encap_Id
)) then
3102 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3104 (Fix_Msg
(Encap_Typ
, "constituent & must be declared "
3105 & "immediately within the same region as single protected "
3106 & "type %"), Indic
, Item_Id
);
3111 end Analyze_Part_Of
;
3113 ----------------------------------
3114 -- Analyze_Part_Of_In_Decl_Part --
3115 ----------------------------------
3117 procedure Analyze_Part_Of_In_Decl_Part
(N
: Node_Id
) is
3118 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3119 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3120 Encap_Id
: Entity_Id
;
3124 -- Detect any discrepancies between the placement of the variable with
3125 -- respect to general state space and the encapsulating state or single
3131 Encap
=> Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
))),
3132 Encap_Id
=> Encap_Id
,
3135 -- The Part_Of indicator turns the variable into a constituent of the
3136 -- encapsulating state or single concurrent type.
3139 pragma Assert
(Present
(Encap_Id
));
3141 Append_Elmt
(Var_Id
, Part_Of_Constituents
(Encap_Id
));
3142 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3144 end Analyze_Part_Of_In_Decl_Part
;
3146 --------------------
3147 -- Analyze_Pragma --
3148 --------------------
3150 procedure Analyze_Pragma
(N
: Node_Id
) is
3151 Loc
: constant Source_Ptr
:= Sloc
(N
);
3152 Prag_Id
: Pragma_Id
;
3155 -- Name of the source pragma, or name of the corresponding aspect for
3156 -- pragmas which originate in a source aspect. In the latter case, the
3157 -- name may be different from the pragma name.
3159 Pragma_Exit
: exception;
3160 -- This exception is used to exit pragma processing completely. It
3161 -- is used when an error is detected, and no further processing is
3162 -- required. It is also used if an earlier error has left the tree in
3163 -- a state where the pragma should not be processed.
3166 -- Number of pragma argument associations
3172 -- First four pragma arguments (pragma argument association nodes, or
3173 -- Empty if the corresponding argument does not exist).
3175 type Name_List
is array (Natural range <>) of Name_Id
;
3176 type Args_List
is array (Natural range <>) of Node_Id
;
3177 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3179 -----------------------
3180 -- Local Subprograms --
3181 -----------------------
3183 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3184 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3185 -- get the given string argument, and place it in Name_Buffer, adding
3186 -- leading and trailing asterisks if they are not already present. The
3187 -- caller has already checked that Arg is a static string expression.
3189 procedure Ada_2005_Pragma
;
3190 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3191 -- Ada 95 mode, these are implementation defined pragmas, so should be
3192 -- caught by the No_Implementation_Pragmas restriction.
3194 procedure Ada_2012_Pragma
;
3195 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3196 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3197 -- should be caught by the No_Implementation_Pragmas restriction.
3199 procedure Analyze_Depends_Global
3200 (Spec_Id
: out Entity_Id
;
3201 Subp_Decl
: out Node_Id
;
3202 Legal
: out Boolean);
3203 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3204 -- legality of the placement and related context of the pragma. Spec_Id
3205 -- is the entity of the related subprogram. Subp_Decl is the declaration
3206 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3208 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3209 -- Inspect the remainder of the list containing pragma N and look for
3210 -- a pragma that matches Id. If found, analyze the pragma.
3212 procedure Analyze_Pre_Post_Condition
;
3213 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3215 procedure Analyze_Refined_Depends_Global_Post
3216 (Spec_Id
: out Entity_Id
;
3217 Body_Id
: out Entity_Id
;
3218 Legal
: out Boolean);
3219 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3220 -- Refined_Global and Refined_Post. Verify the legality of the placement
3221 -- and related context of the pragma. Spec_Id is the entity of the
3222 -- related subprogram. Body_Id is the entity of the subprogram body.
3223 -- Flag Legal is set when the pragma is legal.
3225 procedure Check_Ada_83_Warning
;
3226 -- Issues a warning message for the current pragma if operating in Ada
3227 -- 83 mode (used for language pragmas that are not a standard part of
3228 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3231 procedure Check_Arg_Count
(Required
: Nat
);
3232 -- Check argument count for pragma is equal to given parameter. If not,
3233 -- then issue an error message and raise Pragma_Exit.
3235 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3236 -- Arg which can either be a pragma argument association, in which case
3237 -- the check is applied to the expression of the association or an
3238 -- expression directly.
3240 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3241 -- Check that an argument has the right form for an EXTERNAL_NAME
3242 -- parameter of an extended import/export pragma. The rule is that the
3243 -- name must be an identifier or string literal (in Ada 83 mode) or a
3244 -- static string expression (in Ada 95 mode).
3246 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3247 -- Check the specified argument Arg to make sure that it is an
3248 -- identifier. If not give error and raise Pragma_Exit.
3250 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3251 -- Check the specified argument Arg to make sure that it is an integer
3252 -- literal. If not give error and raise Pragma_Exit.
3254 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3255 -- Check the specified argument Arg to make sure that it has the proper
3256 -- syntactic form for a local name and meets the semantic requirements
3257 -- for a local name. The local name is analyzed as part of the
3258 -- processing for this call. In addition, the local name is required
3259 -- to represent an entity at the library level.
3261 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
3262 -- Check the specified argument Arg to make sure that it has the proper
3263 -- syntactic form for a local name and meets the semantic requirements
3264 -- for a local name. The local name is analyzed as part of the
3265 -- processing for this call.
3267 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3268 -- Check the specified argument Arg to make sure that it is a valid
3269 -- locking policy name. If not give error and raise Pragma_Exit.
3271 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3272 -- Check the specified argument Arg to make sure that it is a valid
3273 -- elaboration policy name. If not give error and raise Pragma_Exit.
3275 procedure Check_Arg_Is_One_Of
3278 procedure Check_Arg_Is_One_Of
3280 N1
, N2
, N3
: Name_Id
);
3281 procedure Check_Arg_Is_One_Of
3283 N1
, N2
, N3
, N4
: Name_Id
);
3284 procedure Check_Arg_Is_One_Of
3286 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3287 -- Check the specified argument Arg to make sure that it is an
3288 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3289 -- present). If not then give error and raise Pragma_Exit.
3291 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3292 -- Check the specified argument Arg to make sure that it is a valid
3293 -- queuing policy name. If not give error and raise Pragma_Exit.
3295 procedure Check_Arg_Is_OK_Static_Expression
3297 Typ
: Entity_Id
:= Empty
);
3298 -- Check the specified argument Arg to make sure that it is a static
3299 -- expression of the given type (i.e. it will be analyzed and resolved
3300 -- using this type, which can be any valid argument to Resolve, e.g.
3301 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3302 -- Typ is left Empty, then any static expression is allowed. Includes
3303 -- checking that the argument does not raise Constraint_Error.
3305 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3306 -- Check the specified argument Arg to make sure that it is a valid task
3307 -- dispatching policy name. If not give error and raise Pragma_Exit.
3309 procedure Check_Arg_Order
(Names
: Name_List
);
3310 -- Checks for an instance of two arguments with identifiers for the
3311 -- current pragma which are not in the sequence indicated by Names,
3312 -- and if so, generates a fatal message about bad order of arguments.
3314 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3315 -- Check there are at least N arguments present
3317 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3318 -- Check there are no more than N arguments present
3320 procedure Check_Component
3323 In_Variant_Part
: Boolean := False);
3324 -- Examine an Unchecked_Union component for correct use of per-object
3325 -- constrained subtypes, and for restrictions on finalizable components.
3326 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3327 -- should be set when Comp comes from a record variant.
3329 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3330 -- Check if a rep item of the same name as the current pragma is already
3331 -- chained as a rep pragma to the given entity. If so give a message
3332 -- about the duplicate, and then raise Pragma_Exit so does not return.
3333 -- Note that if E is a type, then this routine avoids flagging a pragma
3334 -- which applies to a parent type from which E is derived.
3336 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3337 -- Nam is an N_String_Literal node containing the external name set by
3338 -- an Import or Export pragma (or extended Import or Export pragma).
3339 -- This procedure checks for possible duplications if this is the export
3340 -- case, and if found, issues an appropriate error message.
3342 procedure Check_Expr_Is_OK_Static_Expression
3344 Typ
: Entity_Id
:= Empty
);
3345 -- Check the specified expression Expr to make sure that it is a static
3346 -- expression of the given type (i.e. it will be analyzed and resolved
3347 -- using this type, which can be any valid argument to Resolve, e.g.
3348 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3349 -- Typ is left Empty, then any static expression is allowed. Includes
3350 -- checking that the expression does not raise Constraint_Error.
3352 procedure Check_First_Subtype
(Arg
: Node_Id
);
3353 -- Checks that Arg, whose expression is an entity name, references a
3356 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3357 -- Checks that the given argument has an identifier, and if so, requires
3358 -- it to match the given identifier name. If there is no identifier, or
3359 -- a non-matching identifier, then an error message is given and
3360 -- Pragma_Exit is raised.
3362 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3363 -- Checks that the given argument has an identifier, and if so, requires
3364 -- it to match one of the given identifier names. If there is no
3365 -- identifier, or a non-matching identifier, then an error message is
3366 -- given and Pragma_Exit is raised.
3368 procedure Check_In_Main_Program
;
3369 -- Common checks for pragmas that appear within a main program
3370 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3372 procedure Check_Interrupt_Or_Attach_Handler
;
3373 -- Common processing for first argument of pragma Interrupt_Handler or
3374 -- pragma Attach_Handler.
3376 procedure Check_Loop_Pragma_Placement
;
3377 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3378 -- appear immediately within a construct restricted to loops, and that
3379 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3381 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3382 -- Check that pragma appears in a declarative part, or in a package
3383 -- specification, i.e. that it does not occur in a statement sequence
3386 procedure Check_No_Identifier
(Arg
: Node_Id
);
3387 -- Checks that the given argument does not have an identifier. If
3388 -- an identifier is present, then an error message is issued, and
3389 -- Pragma_Exit is raised.
3391 procedure Check_No_Identifiers
;
3392 -- Checks that none of the arguments to the pragma has an identifier.
3393 -- If any argument has an identifier, then an error message is issued,
3394 -- and Pragma_Exit is raised.
3396 procedure Check_No_Link_Name
;
3397 -- Checks that no link name is specified
3399 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3400 -- Checks if the given argument has an identifier, and if so, requires
3401 -- it to match the given identifier name. If there is a non-matching
3402 -- identifier, then an error message is given and Pragma_Exit is raised.
3404 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3405 -- Checks if the given argument has an identifier, and if so, requires
3406 -- it to match the given identifier name. If there is a non-matching
3407 -- identifier, then an error message is given and Pragma_Exit is raised.
3408 -- In this version of the procedure, the identifier name is given as
3409 -- a string with lower case letters.
3411 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3412 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3413 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3414 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3415 -- is an OK static boolean expression. Emit an error if this is not the
3418 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3419 -- Constr is a constraint from an N_Subtype_Indication node from a
3420 -- component constraint in an Unchecked_Union type. This routine checks
3421 -- that the constraint is static as required by the restrictions for
3424 procedure Check_Valid_Configuration_Pragma
;
3425 -- Legality checks for placement of a configuration pragma
3427 procedure Check_Valid_Library_Unit_Pragma
;
3428 -- Legality checks for library unit pragmas. A special case arises for
3429 -- pragmas in generic instances that come from copies of the original
3430 -- library unit pragmas in the generic templates. In the case of other
3431 -- than library level instantiations these can appear in contexts which
3432 -- would normally be invalid (they only apply to the original template
3433 -- and to library level instantiations), and they are simply ignored,
3434 -- which is implemented by rewriting them as null statements.
3436 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3437 -- Check an Unchecked_Union variant for lack of nested variants and
3438 -- presence of at least one component. UU_Typ is the related Unchecked_
3441 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3442 -- Subsidiary routine to the processing of pragmas Abstract_State,
3443 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3444 -- Refined_Global and Refined_State. Transform argument Arg into
3445 -- an aggregate if not one already. N_Null is never transformed.
3446 -- Arg may denote an aspect specification or a pragma argument
3449 procedure Error_Pragma
(Msg
: String);
3450 pragma No_Return
(Error_Pragma
);
3451 -- Outputs error message for current pragma. The message contains a %
3452 -- that will be replaced with the pragma name, and the flag is placed
3453 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3454 -- calls Fix_Error (see spec of that procedure for details).
3456 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3457 pragma No_Return
(Error_Pragma_Arg
);
3458 -- Outputs error message for current pragma. The message may contain
3459 -- a % that will be replaced with the pragma name. The parameter Arg
3460 -- may either be a pragma argument association, in which case the flag
3461 -- is placed on the expression of this association, or an expression,
3462 -- in which case the flag is placed directly on the expression. The
3463 -- message is placed using Error_Msg_N, so the message may also contain
3464 -- an & insertion character which will reference the given Arg value.
3465 -- After placing the message, Pragma_Exit is raised. Note: this routine
3466 -- calls Fix_Error (see spec of that procedure for details).
3468 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3469 pragma No_Return
(Error_Pragma_Arg
);
3470 -- Similar to above form of Error_Pragma_Arg except that two messages
3471 -- are provided, the second is a continuation comment starting with \.
3473 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3474 pragma No_Return
(Error_Pragma_Arg_Ident
);
3475 -- Outputs error message for current pragma. The message may contain a %
3476 -- that will be replaced with the pragma name. The parameter Arg must be
3477 -- a pragma argument association with a non-empty identifier (i.e. its
3478 -- Chars field must be set), and the error message is placed on the
3479 -- identifier. The message is placed using Error_Msg_N so the message
3480 -- may also contain an & insertion character which will reference
3481 -- the identifier. After placing the message, Pragma_Exit is raised.
3482 -- Note: this routine calls Fix_Error (see spec of that procedure for
3485 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3486 pragma No_Return
(Error_Pragma_Ref
);
3487 -- Outputs error message for current pragma. The message may contain
3488 -- a % that will be replaced with the pragma name. The parameter Ref
3489 -- must be an entity whose name can be referenced by & and sloc by #.
3490 -- After placing the message, Pragma_Exit is raised. Note: this routine
3491 -- calls Fix_Error (see spec of that procedure for details).
3493 function Find_Lib_Unit_Name
return Entity_Id
;
3494 -- Used for a library unit pragma to find the entity to which the
3495 -- library unit pragma applies, returns the entity found.
3497 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3498 -- If the pragma is a compilation unit pragma, the id must denote the
3499 -- compilation unit in the same compilation, and the pragma must appear
3500 -- in the list of preceding or trailing pragmas. If it is a program
3501 -- unit pragma that is not a compilation unit pragma, then the
3502 -- identifier must be visible.
3504 function Find_Unique_Parameterless_Procedure
3506 Arg
: Node_Id
) return Entity_Id
;
3507 -- Used for a procedure pragma to find the unique parameterless
3508 -- procedure identified by Name, returns it if it exists, otherwise
3509 -- errors out and uses Arg as the pragma argument for the message.
3511 function Fix_Error
(Msg
: String) return String;
3512 -- This is called prior to issuing an error message. Msg is the normal
3513 -- error message issued in the pragma case. This routine checks for the
3514 -- case of a pragma coming from an aspect in the source, and returns a
3515 -- message suitable for the aspect case as follows:
3517 -- Each substring "pragma" is replaced by "aspect"
3519 -- If "argument of" is at the start of the error message text, it is
3520 -- replaced by "entity for".
3522 -- If "argument" is at the start of the error message text, it is
3523 -- replaced by "entity".
3525 -- So for example, "argument of pragma X must be discrete type"
3526 -- returns "entity for aspect X must be a discrete type".
3528 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3529 -- be different from the pragma name). If the current pragma results
3530 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3531 -- original pragma name.
3533 procedure Gather_Associations
3535 Args
: out Args_List
);
3536 -- This procedure is used to gather the arguments for a pragma that
3537 -- permits arbitrary ordering of parameters using the normal rules
3538 -- for named and positional parameters. The Names argument is a list
3539 -- of Name_Id values that corresponds to the allowed pragma argument
3540 -- association identifiers in order. The result returned in Args is
3541 -- a list of corresponding expressions that are the pragma arguments.
3542 -- Note that this is a list of expressions, not of pragma argument
3543 -- associations (Gather_Associations has completely checked all the
3544 -- optional identifiers when it returns). An entry in Args is Empty
3545 -- on return if the corresponding argument is not present.
3547 procedure GNAT_Pragma
;
3548 -- Called for all GNAT defined pragmas to check the relevant restriction
3549 -- (No_Implementation_Pragmas).
3551 function Is_Before_First_Decl
3552 (Pragma_Node
: Node_Id
;
3553 Decls
: List_Id
) return Boolean;
3554 -- Return True if Pragma_Node is before the first declarative item in
3555 -- Decls where Decls is the list of declarative items.
3557 function Is_Configuration_Pragma
return Boolean;
3558 -- Determines if the placement of the current pragma is appropriate
3559 -- for a configuration pragma.
3561 function Is_In_Context_Clause
return Boolean;
3562 -- Returns True if pragma appears within the context clause of a unit,
3563 -- and False for any other placement (does not generate any messages).
3565 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3566 -- Analyzes the argument, and determines if it is a static string
3567 -- expression, returns True if so, False if non-static or not String.
3568 -- A special case is that a string literal returns True in Ada 83 mode
3569 -- (which has no such thing as static string expressions). Note that
3570 -- the call analyzes its argument, so this cannot be used for the case
3571 -- where an identifier might not be declared.
3573 procedure Pragma_Misplaced
;
3574 pragma No_Return
(Pragma_Misplaced
);
3575 -- Issue fatal error message for misplaced pragma
3577 procedure Process_Atomic_Independent_Shared_Volatile
;
3578 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3579 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3580 -- and treated as being identical in effect to pragma Atomic.
3582 procedure Process_Compile_Time_Warning_Or_Error
;
3583 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3585 procedure Process_Convention
3586 (C
: out Convention_Id
;
3587 Ent
: out Entity_Id
);
3588 -- Common processing for Convention, Interface, Import and Export.
3589 -- Checks first two arguments of pragma, and sets the appropriate
3590 -- convention value in the specified entity or entities. On return
3591 -- C is the convention, Ent is the referenced entity.
3593 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3594 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3595 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3597 procedure Process_Extended_Import_Export_Object_Pragma
3598 (Arg_Internal
: Node_Id
;
3599 Arg_External
: Node_Id
;
3600 Arg_Size
: Node_Id
);
3601 -- Common processing for the pragmas Import/Export_Object. The three
3602 -- arguments correspond to the three named parameters of the pragmas. An
3603 -- argument is empty if the corresponding parameter is not present in
3606 procedure Process_Extended_Import_Export_Internal_Arg
3607 (Arg_Internal
: Node_Id
:= Empty
);
3608 -- Common processing for all extended Import and Export pragmas. The
3609 -- argument is the pragma parameter for the Internal argument. If
3610 -- Arg_Internal is empty or inappropriate, an error message is posted.
3611 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3612 -- set to identify the referenced entity.
3614 procedure Process_Extended_Import_Export_Subprogram_Pragma
3615 (Arg_Internal
: Node_Id
;
3616 Arg_External
: Node_Id
;
3617 Arg_Parameter_Types
: Node_Id
;
3618 Arg_Result_Type
: Node_Id
:= Empty
;
3619 Arg_Mechanism
: Node_Id
;
3620 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3621 -- Common processing for all extended Import and Export pragmas applying
3622 -- to subprograms. The caller omits any arguments that do not apply to
3623 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3624 -- only in the Import_Function and Export_Function cases). The argument
3625 -- names correspond to the allowed pragma association identifiers.
3627 procedure Process_Generic_List
;
3628 -- Common processing for Share_Generic and Inline_Generic
3630 procedure Process_Import_Or_Interface
;
3631 -- Common processing for Import or Interface
3633 procedure Process_Import_Predefined_Type
;
3634 -- Processing for completing a type with pragma Import. This is used
3635 -- to declare types that match predefined C types, especially for cases
3636 -- without corresponding Ada predefined type.
3638 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3639 -- Inline status of a subprogram, indicated as follows:
3640 -- Suppressed: inlining is suppressed for the subprogram
3641 -- Disabled: no inlining is requested for the subprogram
3642 -- Enabled: inlining is requested/required for the subprogram
3644 procedure Process_Inline
(Status
: Inline_Status
);
3645 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3646 -- indicates the inline status specified by the pragma.
3648 procedure Process_Interface_Name
3649 (Subprogram_Def
: Entity_Id
;
3651 Link_Arg
: Node_Id
);
3652 -- Given the last two arguments of pragma Import, pragma Export, or
3653 -- pragma Interface_Name, performs validity checks and sets the
3654 -- Interface_Name field of the given subprogram entity to the
3655 -- appropriate external or link name, depending on the arguments given.
3656 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3657 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3658 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3659 -- nor Link_Arg is present, the interface name is set to the default
3660 -- from the subprogram name.
3662 procedure Process_Interrupt_Or_Attach_Handler
;
3663 -- Common processing for Interrupt and Attach_Handler pragmas
3665 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3666 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3667 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3668 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3669 -- is not set in the Restrictions case.
3671 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3672 -- Common processing for Suppress and Unsuppress. The boolean parameter
3673 -- Suppress_Case is True for the Suppress case, and False for the
3676 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
3677 -- Subsidiary to the analysis of pragmas Independent[_Components].
3678 -- Record such a pragma N applied to entity E for future checks.
3680 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3681 -- This procedure sets the Is_Exported flag for the given entity,
3682 -- checking that the entity was not previously imported. Arg is
3683 -- the argument that specified the entity. A check is also made
3684 -- for exporting inappropriate entities.
3686 procedure Set_Extended_Import_Export_External_Name
3687 (Internal_Ent
: Entity_Id
;
3688 Arg_External
: Node_Id
);
3689 -- Common processing for all extended import export pragmas. The first
3690 -- argument, Internal_Ent, is the internal entity, which has already
3691 -- been checked for validity by the caller. Arg_External is from the
3692 -- Import or Export pragma, and may be null if no External parameter
3693 -- was present. If Arg_External is present and is a non-null string
3694 -- (a null string is treated as the default), then the Interface_Name
3695 -- field of Internal_Ent is set appropriately.
3697 procedure Set_Imported
(E
: Entity_Id
);
3698 -- This procedure sets the Is_Imported flag for the given entity,
3699 -- checking that it is not previously exported or imported.
3701 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3702 -- Mech is a parameter passing mechanism (see Import_Function syntax
3703 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3704 -- has the right form, and if not issues an error message. If the
3705 -- argument has the right form then the Mechanism field of Ent is
3706 -- set appropriately.
3708 procedure Set_Rational_Profile
;
3709 -- Activate the set of configuration pragmas and permissions that make
3710 -- up the Rational profile.
3712 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
3713 -- Activate the set of configuration pragmas and restrictions that make
3714 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3715 -- is used for error messages on any constructs violating the profile.
3717 ----------------------------------
3718 -- Acquire_Warning_Match_String --
3719 ----------------------------------
3721 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3723 String_To_Name_Buffer
3724 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3726 -- Add asterisk at start if not already there
3728 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3729 Name_Buffer
(2 .. Name_Len
+ 1) :=
3730 Name_Buffer
(1 .. Name_Len
);
3731 Name_Buffer
(1) := '*';
3732 Name_Len
:= Name_Len
+ 1;
3735 -- Add asterisk at end if not already there
3737 if Name_Buffer
(Name_Len
) /= '*' then
3738 Name_Len
:= Name_Len
+ 1;
3739 Name_Buffer
(Name_Len
) := '*';
3741 end Acquire_Warning_Match_String
;
3743 ---------------------
3744 -- Ada_2005_Pragma --
3745 ---------------------
3747 procedure Ada_2005_Pragma
is
3749 if Ada_Version
<= Ada_95
then
3750 Check_Restriction
(No_Implementation_Pragmas
, N
);
3752 end Ada_2005_Pragma
;
3754 ---------------------
3755 -- Ada_2012_Pragma --
3756 ---------------------
3758 procedure Ada_2012_Pragma
is
3760 if Ada_Version
<= Ada_2005
then
3761 Check_Restriction
(No_Implementation_Pragmas
, N
);
3763 end Ada_2012_Pragma
;
3765 ----------------------------
3766 -- Analyze_Depends_Global --
3767 ----------------------------
3769 procedure Analyze_Depends_Global
3770 (Spec_Id
: out Entity_Id
;
3771 Subp_Decl
: out Node_Id
;
3772 Legal
: out Boolean)
3775 -- Assume that the pragma is illegal
3782 Check_Arg_Count
(1);
3784 -- Ensure the proper placement of the pragma. Depends/Global must be
3785 -- associated with a subprogram declaration or a body that acts as a
3788 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
3792 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
3795 -- Generic subprogram
3797 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
3800 -- Object declaration of a single concurrent type
3802 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
then
3807 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
3810 -- Subprogram body acts as spec
3812 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
3813 and then No
(Corresponding_Spec
(Subp_Decl
))
3817 -- Subprogram body stub acts as spec
3819 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
3820 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
3824 -- Subprogram declaration
3826 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
3831 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
3839 -- If we get here, then the pragma is legal
3842 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
3844 -- When the related context is an entry, the entry must belong to a
3845 -- protected unit (SPARK RM 6.1.4(6)).
3847 if Is_Entry_Declaration
(Spec_Id
)
3848 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
3853 -- When the related context is an anonymous object created for a
3854 -- simple concurrent type, the type must be a task
3855 -- (SPARK RM 6.1.4(6)).
3857 elsif Is_Single_Concurrent_Object
(Spec_Id
)
3858 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
3864 -- A pragma that applies to a Ghost entity becomes Ghost for the
3865 -- purposes of legality checks and removal of ignored Ghost code.
3867 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
3868 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
3869 end Analyze_Depends_Global
;
3871 ------------------------
3872 -- Analyze_If_Present --
3873 ------------------------
3875 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
3879 pragma Assert
(Is_List_Member
(N
));
3881 -- Inspect the declarations or statements following pragma N looking
3882 -- for another pragma whose Id matches the caller's request. If it is
3883 -- available, analyze it.
3886 while Present
(Stmt
) loop
3887 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
3888 Analyze_Pragma
(Stmt
);
3891 -- The first source declaration or statement immediately following
3892 -- N ends the region where a pragma may appear.
3894 elsif Comes_From_Source
(Stmt
) then
3900 end Analyze_If_Present
;
3902 --------------------------------
3903 -- Analyze_Pre_Post_Condition --
3904 --------------------------------
3906 procedure Analyze_Pre_Post_Condition
is
3907 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
3908 Subp_Decl
: Node_Id
;
3909 Subp_Id
: Entity_Id
;
3911 Duplicates_OK
: Boolean := False;
3912 -- Flag set when a pre/postcondition allows multiple pragmas of the
3915 In_Body_OK
: Boolean := False;
3916 -- Flag set when a pre/postcondition is allowed to appear on a body
3917 -- even though the subprogram may have a spec.
3919 Is_Pre_Post
: Boolean := False;
3920 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
3924 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
3925 -- offer uniformity among the various kinds of pre/postconditions by
3926 -- rewriting the pragma identifier. This allows the retrieval of the
3927 -- original pragma name by routine Original_Aspect_Pragma_Name.
3929 if Comes_From_Source
(N
) then
3930 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
3931 Is_Pre_Post
:= True;
3932 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
3933 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
3935 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
3936 Is_Pre_Post
:= True;
3937 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
3938 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
3942 -- Determine the semantics with respect to duplicates and placement
3943 -- in a body. Pragmas Precondition and Postcondition were introduced
3944 -- before aspects and are not subject to the same aspect-like rules.
3946 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
3947 Duplicates_OK
:= True;
3953 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
3954 -- argument without an identifier.
3957 Check_Arg_Count
(1);
3958 Check_No_Identifiers
;
3960 -- Pragmas Precondition and Postcondition have complex argument
3964 Check_At_Least_N_Arguments
(1);
3965 Check_At_Most_N_Arguments
(2);
3966 Check_Optional_Identifier
(Arg1
, Name_Check
);
3968 if Present
(Arg2
) then
3969 Check_Optional_Identifier
(Arg2
, Name_Message
);
3970 Preanalyze_Spec_Expression
3971 (Get_Pragma_Arg
(Arg2
), Standard_String
);
3975 -- For a pragma PPC in the extended main source unit, record enabled
3977 -- ??? nothing checks that the pragma is in the main source unit
3979 if Is_Checked
(N
) and then not Split_PPC
(N
) then
3980 Set_SCO_Pragma_Enabled
(Loc
);
3983 -- Ensure the proper placement of the pragma
3986 Find_Related_Declaration_Or_Body
3987 (N
, Do_Checks
=> not Duplicates_OK
);
3989 -- When a pre/postcondition pragma applies to an abstract subprogram,
3990 -- its original form must be an aspect with 'Class.
3992 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
3993 if not From_Aspect_Specification
(N
) then
3995 ("pragma % cannot be applied to abstract subprogram");
3997 elsif not Class_Present
(N
) then
3999 ("aspect % requires ''Class for abstract subprogram");
4002 -- Entry declaration
4004 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4007 -- Generic subprogram declaration
4009 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4014 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4015 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4019 -- Subprogram body stub
4021 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4022 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4026 -- Subprogram declaration
4028 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4030 -- AI05-0230: When a pre/postcondition pragma applies to a null
4031 -- procedure, its original form must be an aspect with 'Class.
4033 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4034 and then Null_Present
(Specification
(Subp_Decl
))
4035 and then From_Aspect_Specification
(N
)
4036 and then not Class_Present
(N
)
4038 Error_Pragma
("aspect % requires ''Class for null procedure");
4041 -- Otherwise the placement is illegal
4048 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4050 -- Chain the pragma on the contract for further processing by
4051 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4053 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4055 -- A pragma that applies to a Ghost entity becomes Ghost for the
4056 -- purposes of legality checks and removal of ignored Ghost code.
4058 Mark_Pragma_As_Ghost
(N
, Subp_Id
);
4060 -- Fully analyze the pragma when it appears inside an entry or
4061 -- subprogram body because it cannot benefit from forward references.
4063 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4065 N_Subprogram_Body_Stub
)
4067 -- The legality checks of pragmas Precondition and Postcondition
4068 -- are affected by the SPARK mode in effect and the volatility of
4069 -- the context. Analyze all pragmas in a specific order.
4071 Analyze_If_Present
(Pragma_SPARK_Mode
);
4072 Analyze_If_Present
(Pragma_Volatile_Function
);
4073 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4075 end Analyze_Pre_Post_Condition
;
4077 -----------------------------------------
4078 -- Analyze_Refined_Depends_Global_Post --
4079 -----------------------------------------
4081 procedure Analyze_Refined_Depends_Global_Post
4082 (Spec_Id
: out Entity_Id
;
4083 Body_Id
: out Entity_Id
;
4084 Legal
: out Boolean)
4086 Body_Decl
: Node_Id
;
4087 Spec_Decl
: Node_Id
;
4090 -- Assume that the pragma is illegal
4097 Check_Arg_Count
(1);
4098 Check_No_Identifiers
;
4100 -- Verify the placement of the pragma and check for duplicates. The
4101 -- pragma must apply to a subprogram body [stub].
4103 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4107 if Nkind
(Body_Decl
) = N_Entry_Body
then
4112 elsif Nkind
(Body_Decl
) = N_Subprogram_Body
then
4115 -- Subprogram body stub
4117 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
4122 elsif Nkind
(Body_Decl
) = N_Task_Body
then
4130 Body_Id
:= Defining_Entity
(Body_Decl
);
4131 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4133 -- The pragma must apply to the second declaration of a subprogram.
4134 -- In other words, the body [stub] cannot acts as a spec.
4136 if No
(Spec_Id
) then
4137 Error_Pragma
("pragma % cannot apply to a stand alone body");
4140 -- Catch the case where the subprogram body is a subunit and acts as
4141 -- the third declaration of the subprogram.
4143 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4144 Error_Pragma
("pragma % cannot apply to a subunit");
4148 -- A refined pragma can only apply to the body [stub] of a subprogram
4149 -- declared in the visible part of a package. Retrieve the context of
4150 -- the subprogram declaration.
4152 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4154 -- When dealing with protected entries or protected subprograms, use
4155 -- the enclosing protected type as the proper context.
4157 if Ekind_In
(Spec_Id
, E_Entry
,
4161 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4163 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4166 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4168 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4169 & "subprogram declared in a package specification"));
4173 -- If we get here, then the pragma is legal
4177 -- A pragma that applies to a Ghost entity becomes Ghost for the
4178 -- purposes of legality checks and removal of ignored Ghost code.
4180 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
4182 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4183 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4185 end Analyze_Refined_Depends_Global_Post
;
4187 --------------------------
4188 -- Check_Ada_83_Warning --
4189 --------------------------
4191 procedure Check_Ada_83_Warning
is
4193 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
4194 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
4196 end Check_Ada_83_Warning
;
4198 ---------------------
4199 -- Check_Arg_Count --
4200 ---------------------
4202 procedure Check_Arg_Count
(Required
: Nat
) is
4204 if Arg_Count
/= Required
then
4205 Error_Pragma
("wrong number of arguments for pragma%");
4207 end Check_Arg_Count
;
4209 --------------------------------
4210 -- Check_Arg_Is_External_Name --
4211 --------------------------------
4213 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
4214 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4217 if Nkind
(Argx
) = N_Identifier
then
4221 Analyze_And_Resolve
(Argx
, Standard_String
);
4223 if Is_OK_Static_Expression
(Argx
) then
4226 elsif Etype
(Argx
) = Any_Type
then
4229 -- An interesting special case, if we have a string literal and
4230 -- we are in Ada 83 mode, then we allow it even though it will
4231 -- not be flagged as static. This allows expected Ada 83 mode
4232 -- use of external names which are string literals, even though
4233 -- technically these are not static in Ada 83.
4235 elsif Ada_Version
= Ada_83
4236 and then Nkind
(Argx
) = N_String_Literal
4240 -- Static expression that raises Constraint_Error. This has
4241 -- already been flagged, so just exit from pragma processing.
4243 elsif Is_OK_Static_Expression
(Argx
) then
4246 -- Here we have a real error (non-static expression)
4249 Error_Msg_Name_1
:= Pname
;
4252 Msg
: constant String :=
4253 "argument for pragma% must be a identifier or "
4254 & "static string expression!";
4256 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
4261 end Check_Arg_Is_External_Name
;
4263 -----------------------------
4264 -- Check_Arg_Is_Identifier --
4265 -----------------------------
4267 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
4268 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4270 if Nkind
(Argx
) /= N_Identifier
then
4272 ("argument for pragma% must be identifier", Argx
);
4274 end Check_Arg_Is_Identifier
;
4276 ----------------------------------
4277 -- Check_Arg_Is_Integer_Literal --
4278 ----------------------------------
4280 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
4281 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4283 if Nkind
(Argx
) /= N_Integer_Literal
then
4285 ("argument for pragma% must be integer literal", Argx
);
4287 end Check_Arg_Is_Integer_Literal
;
4289 -------------------------------------------
4290 -- Check_Arg_Is_Library_Level_Local_Name --
4291 -------------------------------------------
4295 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4296 -- | library_unit_NAME
4298 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
4300 Check_Arg_Is_Local_Name
(Arg
);
4302 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
4303 and then Comes_From_Source
(N
)
4306 ("argument for pragma% must be library level entity", Arg
);
4308 end Check_Arg_Is_Library_Level_Local_Name
;
4310 -----------------------------
4311 -- Check_Arg_Is_Local_Name --
4312 -----------------------------
4316 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4317 -- | library_unit_NAME
4319 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
4320 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4325 if Nkind
(Argx
) not in N_Direct_Name
4326 and then (Nkind
(Argx
) /= N_Attribute_Reference
4327 or else Present
(Expressions
(Argx
))
4328 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
4329 and then (not Is_Entity_Name
(Argx
)
4330 or else not Is_Compilation_Unit
(Entity
(Argx
)))
4332 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
4335 -- No further check required if not an entity name
4337 if not Is_Entity_Name
(Argx
) then
4343 Ent
: constant Entity_Id
:= Entity
(Argx
);
4344 Scop
: constant Entity_Id
:= Scope
(Ent
);
4347 -- Case of a pragma applied to a compilation unit: pragma must
4348 -- occur immediately after the program unit in the compilation.
4350 if Is_Compilation_Unit
(Ent
) then
4352 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
4355 -- Case of pragma placed immediately after spec
4357 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
4360 -- Case of pragma placed immediately after body
4362 elsif Nkind
(Decl
) = N_Subprogram_Declaration
4363 and then Present
(Corresponding_Body
(Decl
))
4367 (Parent
(Unit_Declaration_Node
4368 (Corresponding_Body
(Decl
))));
4370 -- All other cases are illegal
4377 -- Special restricted placement rule from 10.2.1(11.8/2)
4379 elsif Is_Generic_Formal
(Ent
)
4380 and then Prag_Id
= Pragma_Preelaborable_Initialization
4382 OK
:= List_Containing
(N
) =
4383 Generic_Formal_Declarations
4384 (Unit_Declaration_Node
(Scop
));
4386 -- If this is an aspect applied to a subprogram body, the
4387 -- pragma is inserted in its declarative part.
4389 elsif From_Aspect_Specification
(N
)
4390 and then Ent
= Current_Scope
4392 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
4396 -- If the aspect is a predicate (possibly others ???) and the
4397 -- context is a record type, this is a discriminant expression
4398 -- within a type declaration, that freezes the predicated
4401 elsif From_Aspect_Specification
(N
)
4402 and then Prag_Id
= Pragma_Predicate
4403 and then Ekind
(Current_Scope
) = E_Record_Type
4404 and then Scop
= Scope
(Current_Scope
)
4408 -- Default case, just check that the pragma occurs in the scope
4409 -- of the entity denoted by the name.
4412 OK
:= Current_Scope
= Scop
;
4417 ("pragma% argument must be in same declarative part", Arg
);
4421 end Check_Arg_Is_Local_Name
;
4423 ---------------------------------
4424 -- Check_Arg_Is_Locking_Policy --
4425 ---------------------------------
4427 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
4428 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4431 Check_Arg_Is_Identifier
(Argx
);
4433 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
4434 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
4436 end Check_Arg_Is_Locking_Policy
;
4438 -----------------------------------------------
4439 -- Check_Arg_Is_Partition_Elaboration_Policy --
4440 -----------------------------------------------
4442 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
4443 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4446 Check_Arg_Is_Identifier
(Argx
);
4448 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
4450 ("& is not a valid partition elaboration policy name", Argx
);
4452 end Check_Arg_Is_Partition_Elaboration_Policy
;
4454 -------------------------
4455 -- Check_Arg_Is_One_Of --
4456 -------------------------
4458 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4459 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4462 Check_Arg_Is_Identifier
(Argx
);
4464 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
4465 Error_Msg_Name_2
:= N1
;
4466 Error_Msg_Name_3
:= N2
;
4467 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
4469 end Check_Arg_Is_One_Of
;
4471 procedure Check_Arg_Is_One_Of
4473 N1
, N2
, N3
: Name_Id
)
4475 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4478 Check_Arg_Is_Identifier
(Argx
);
4480 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
4481 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
4483 end Check_Arg_Is_One_Of
;
4485 procedure Check_Arg_Is_One_Of
4487 N1
, N2
, N3
, N4
: Name_Id
)
4489 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4492 Check_Arg_Is_Identifier
(Argx
);
4494 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
4495 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
4497 end Check_Arg_Is_One_Of
;
4499 procedure Check_Arg_Is_One_Of
4501 N1
, N2
, N3
, N4
, N5
: Name_Id
)
4503 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4506 Check_Arg_Is_Identifier
(Argx
);
4508 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
4509 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
4511 end Check_Arg_Is_One_Of
;
4513 ---------------------------------
4514 -- Check_Arg_Is_Queuing_Policy --
4515 ---------------------------------
4517 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
4518 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4521 Check_Arg_Is_Identifier
(Argx
);
4523 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
4524 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
4526 end Check_Arg_Is_Queuing_Policy
;
4528 ---------------------------------------
4529 -- Check_Arg_Is_OK_Static_Expression --
4530 ---------------------------------------
4532 procedure Check_Arg_Is_OK_Static_Expression
4534 Typ
: Entity_Id
:= Empty
)
4537 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
4538 end Check_Arg_Is_OK_Static_Expression
;
4540 ------------------------------------------
4541 -- Check_Arg_Is_Task_Dispatching_Policy --
4542 ------------------------------------------
4544 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
4545 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4548 Check_Arg_Is_Identifier
(Argx
);
4550 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
4552 ("& is not an allowed task dispatching policy name", Argx
);
4554 end Check_Arg_Is_Task_Dispatching_Policy
;
4556 ---------------------
4557 -- Check_Arg_Order --
4558 ---------------------
4560 procedure Check_Arg_Order
(Names
: Name_List
) is
4563 Highest_So_Far
: Natural := 0;
4564 -- Highest index in Names seen do far
4568 for J
in 1 .. Arg_Count
loop
4569 if Chars
(Arg
) /= No_Name
then
4570 for K
in Names
'Range loop
4571 if Chars
(Arg
) = Names
(K
) then
4572 if K
< Highest_So_Far
then
4573 Error_Msg_Name_1
:= Pname
;
4575 ("parameters out of order for pragma%", Arg
);
4576 Error_Msg_Name_1
:= Names
(K
);
4577 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
4578 Error_Msg_N
("\% must appear before %", Arg
);
4582 Highest_So_Far
:= K
;
4590 end Check_Arg_Order
;
4592 --------------------------------
4593 -- Check_At_Least_N_Arguments --
4594 --------------------------------
4596 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
4598 if Arg_Count
< N
then
4599 Error_Pragma
("too few arguments for pragma%");
4601 end Check_At_Least_N_Arguments
;
4603 -------------------------------
4604 -- Check_At_Most_N_Arguments --
4605 -------------------------------
4607 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
4610 if Arg_Count
> N
then
4612 for J
in 1 .. N
loop
4614 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
4617 end Check_At_Most_N_Arguments
;
4619 ---------------------
4620 -- Check_Component --
4621 ---------------------
4623 procedure Check_Component
4626 In_Variant_Part
: Boolean := False)
4628 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
4629 Sindic
: constant Node_Id
:=
4630 Subtype_Indication
(Component_Definition
(Comp
));
4631 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
4634 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4635 -- object constraint, then the component type shall be an Unchecked_
4638 if Nkind
(Sindic
) = N_Subtype_Indication
4639 and then Has_Per_Object_Constraint
(Comp_Id
)
4640 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4643 ("component subtype subject to per-object constraint "
4644 & "must be an Unchecked_Union", Comp
);
4646 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4647 -- the body of a generic unit, or within the body of any of its
4648 -- descendant library units, no part of the type of a component
4649 -- declared in a variant_part of the unchecked union type shall be of
4650 -- a formal private type or formal private extension declared within
4651 -- the formal part of the generic unit.
4653 elsif Ada_Version
>= Ada_2012
4654 and then In_Generic_Body
(UU_Typ
)
4655 and then In_Variant_Part
4656 and then Is_Private_Type
(Typ
)
4657 and then Is_Generic_Type
(Typ
)
4660 ("component of unchecked union cannot be of generic type", Comp
);
4662 elsif Needs_Finalization
(Typ
) then
4664 ("component of unchecked union cannot be controlled", Comp
);
4666 elsif Has_Task
(Typ
) then
4668 ("component of unchecked union cannot have tasks", Comp
);
4670 end Check_Component
;
4672 ----------------------------
4673 -- Check_Duplicate_Pragma --
4674 ----------------------------
4676 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4677 Id
: Entity_Id
:= E
;
4681 -- Nothing to do if this pragma comes from an aspect specification,
4682 -- since we could not be duplicating a pragma, and we dealt with the
4683 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4685 if From_Aspect_Specification
(N
) then
4689 -- Otherwise current pragma may duplicate previous pragma or a
4690 -- previously given aspect specification or attribute definition
4691 -- clause for the same pragma.
4693 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4697 -- If the entity is a type, then we have to make sure that the
4698 -- ostensible duplicate is not for a parent type from which this
4702 if Nkind
(P
) = N_Pragma
then
4704 Args
: constant List_Id
:=
4705 Pragma_Argument_Associations
(P
);
4708 and then Is_Entity_Name
(Expression
(First
(Args
)))
4709 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4710 and then Entity
(Expression
(First
(Args
))) /= E
4716 elsif Nkind
(P
) = N_Aspect_Specification
4717 and then Is_Type
(Entity
(P
))
4718 and then Entity
(P
) /= E
4724 -- Here we have a definite duplicate
4726 Error_Msg_Name_1
:= Pragma_Name
(N
);
4727 Error_Msg_Sloc
:= Sloc
(P
);
4729 -- For a single protected or a single task object, the error is
4730 -- issued on the original entity.
4732 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4733 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4736 if Nkind
(P
) = N_Aspect_Specification
4737 or else From_Aspect_Specification
(P
)
4739 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4741 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4746 end Check_Duplicate_Pragma
;
4748 ----------------------------------
4749 -- Check_Duplicated_Export_Name --
4750 ----------------------------------
4752 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4753 String_Val
: constant String_Id
:= Strval
(Nam
);
4756 -- We are only interested in the export case, and in the case of
4757 -- generics, it is the instance, not the template, that is the
4758 -- problem (the template will generate a warning in any case).
4760 if not Inside_A_Generic
4761 and then (Prag_Id
= Pragma_Export
4763 Prag_Id
= Pragma_Export_Procedure
4765 Prag_Id
= Pragma_Export_Valued_Procedure
4767 Prag_Id
= Pragma_Export_Function
)
4769 for J
in Externals
.First
.. Externals
.Last
loop
4770 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4771 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4772 Error_Msg_N
("external name duplicates name given#", Nam
);
4777 Externals
.Append
(Nam
);
4779 end Check_Duplicated_Export_Name
;
4781 ----------------------------------------
4782 -- Check_Expr_Is_OK_Static_Expression --
4783 ----------------------------------------
4785 procedure Check_Expr_Is_OK_Static_Expression
4787 Typ
: Entity_Id
:= Empty
)
4790 if Present
(Typ
) then
4791 Analyze_And_Resolve
(Expr
, Typ
);
4793 Analyze_And_Resolve
(Expr
);
4796 if Is_OK_Static_Expression
(Expr
) then
4799 elsif Etype
(Expr
) = Any_Type
then
4802 -- An interesting special case, if we have a string literal and we
4803 -- are in Ada 83 mode, then we allow it even though it will not be
4804 -- flagged as static. This allows the use of Ada 95 pragmas like
4805 -- Import in Ada 83 mode. They will of course be flagged with
4806 -- warnings as usual, but will not cause errors.
4808 elsif Ada_Version
= Ada_83
4809 and then Nkind
(Expr
) = N_String_Literal
4813 -- Static expression that raises Constraint_Error. This has already
4814 -- been flagged, so just exit from pragma processing.
4816 elsif Is_OK_Static_Expression
(Expr
) then
4819 -- Finally, we have a real error
4822 Error_Msg_Name_1
:= Pname
;
4823 Flag_Non_Static_Expr
4824 (Fix_Error
("argument for pragma% must be a static expression!"),
4828 end Check_Expr_Is_OK_Static_Expression
;
4830 -------------------------
4831 -- Check_First_Subtype --
4832 -------------------------
4834 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4835 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4836 Ent
: constant Entity_Id
:= Entity
(Argx
);
4839 if Is_First_Subtype
(Ent
) then
4842 elsif Is_Type
(Ent
) then
4844 ("pragma% cannot apply to subtype", Argx
);
4846 elsif Is_Object
(Ent
) then
4848 ("pragma% cannot apply to object, requires a type", Argx
);
4852 ("pragma% cannot apply to&, requires a type", Argx
);
4854 end Check_First_Subtype
;
4856 ----------------------
4857 -- Check_Identifier --
4858 ----------------------
4860 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4863 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4865 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4866 Error_Msg_Name_1
:= Pname
;
4867 Error_Msg_Name_2
:= Id
;
4868 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4872 end Check_Identifier
;
4874 --------------------------------
4875 -- Check_Identifier_Is_One_Of --
4876 --------------------------------
4878 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4881 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4883 if Chars
(Arg
) = No_Name
then
4884 Error_Msg_Name_1
:= Pname
;
4885 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
4888 elsif Chars
(Arg
) /= N1
4889 and then Chars
(Arg
) /= N2
4891 Error_Msg_Name_1
:= Pname
;
4892 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
4896 end Check_Identifier_Is_One_Of
;
4898 ---------------------------
4899 -- Check_In_Main_Program --
4900 ---------------------------
4902 procedure Check_In_Main_Program
is
4903 P
: constant Node_Id
:= Parent
(N
);
4906 -- Must be in subprogram body
4908 if Nkind
(P
) /= N_Subprogram_Body
then
4909 Error_Pragma
("% pragma allowed only in subprogram");
4911 -- Otherwise warn if obviously not main program
4913 elsif Present
(Parameter_Specifications
(Specification
(P
)))
4914 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
4916 Error_Msg_Name_1
:= Pname
;
4918 ("??pragma% is only effective in main program", N
);
4920 end Check_In_Main_Program
;
4922 ---------------------------------------
4923 -- Check_Interrupt_Or_Attach_Handler --
4924 ---------------------------------------
4926 procedure Check_Interrupt_Or_Attach_Handler
is
4927 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4928 Handler_Proc
, Proc_Scope
: Entity_Id
;
4933 if Prag_Id
= Pragma_Interrupt_Handler
then
4934 Check_Restriction
(No_Dynamic_Attachment
, N
);
4937 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
4938 Proc_Scope
:= Scope
(Handler_Proc
);
4940 -- On AAMP only, a pragma Interrupt_Handler is supported for
4941 -- nonprotected parameterless procedures.
4943 if not AAMP_On_Target
4944 or else Prag_Id
= Pragma_Attach_Handler
4946 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
4948 ("argument of pragma% must be protected procedure", Arg1
);
4951 -- For pragma case (as opposed to access case), check placement.
4952 -- We don't need to do that for aspects, because we have the
4953 -- check that they aspect applies an appropriate procedure.
4955 if not From_Aspect_Specification
(N
)
4956 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
4958 Error_Pragma
("pragma% must be in protected definition");
4962 if not Is_Library_Level_Entity
(Proc_Scope
)
4963 or else (AAMP_On_Target
4964 and then not Is_Library_Level_Entity
(Handler_Proc
))
4967 ("argument for pragma% must be library level entity", Arg1
);
4970 -- AI05-0033: A pragma cannot appear within a generic body, because
4971 -- instance can be in a nested scope. The check that protected type
4972 -- is itself a library-level declaration is done elsewhere.
4974 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4975 -- handle code prior to AI-0033. Analysis tools typically are not
4976 -- interested in this pragma in any case, so no need to worry too
4977 -- much about its placement.
4979 if Inside_A_Generic
then
4980 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
4981 and then In_Package_Body
(Scope
(Current_Scope
))
4982 and then not Relaxed_RM_Semantics
4984 Error_Pragma
("pragma% cannot be used inside a generic");
4987 end Check_Interrupt_Or_Attach_Handler
;
4989 ---------------------------------
4990 -- Check_Loop_Pragma_Placement --
4991 ---------------------------------
4993 procedure Check_Loop_Pragma_Placement
is
4994 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
4995 -- Verify whether the current pragma is properly grouped with other
4996 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4997 -- related loop where the pragma appears.
4999 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5000 -- Determine whether an arbitrary statement Stmt denotes pragma
5001 -- Loop_Invariant or Loop_Variant.
5003 procedure Placement_Error
(Constr
: Node_Id
);
5004 pragma No_Return
(Placement_Error
);
5005 -- Node Constr denotes the last loop restricted construct before we
5006 -- encountered an illegal relation between enclosing constructs. Emit
5007 -- an error depending on what Constr was.
5009 --------------------------------
5010 -- Check_Loop_Pragma_Grouping --
5011 --------------------------------
5013 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
5014 Stop_Search
: exception;
5015 -- This exception is used to terminate the recursive descent of
5016 -- routine Check_Grouping.
5018 procedure Check_Grouping
(L
: List_Id
);
5019 -- Find the first group of pragmas in list L and if successful,
5020 -- ensure that the current pragma is part of that group. The
5021 -- routine raises Stop_Search once such a check is performed to
5022 -- halt the recursive descent.
5024 procedure Grouping_Error
(Prag
: Node_Id
);
5025 pragma No_Return
(Grouping_Error
);
5026 -- Emit an error concerning the current pragma indicating that it
5027 -- should be placed after pragma Prag.
5029 --------------------
5030 -- Check_Grouping --
5031 --------------------
5033 procedure Check_Grouping
(L
: List_Id
) is
5039 -- Inspect the list of declarations or statements looking for
5040 -- the first grouping of pragmas:
5043 -- pragma Loop_Invariant ...;
5044 -- pragma Loop_Variant ...;
5046 -- pragma Loop_Variant ...; -- current pragma
5048 -- If the current pragma is not in the grouping, then it must
5049 -- either appear in a different declarative or statement list
5050 -- or the construct at (1) is separating the pragma from the
5054 while Present
(Stmt
) loop
5056 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5057 -- inside a loop or a block housed inside a loop. Inspect
5058 -- the declarations and statements of the block as they may
5059 -- contain the first grouping.
5061 if Nkind
(Stmt
) = N_Block_Statement
then
5062 HSS
:= Handled_Statement_Sequence
(Stmt
);
5064 Check_Grouping
(Declarations
(Stmt
));
5066 if Present
(HSS
) then
5067 Check_Grouping
(Statements
(HSS
));
5070 -- First pragma of the first topmost grouping has been found
5072 elsif Is_Loop_Pragma
(Stmt
) then
5074 -- The group and the current pragma are not in the same
5075 -- declarative or statement list.
5077 if List_Containing
(Stmt
) /= List_Containing
(N
) then
5078 Grouping_Error
(Stmt
);
5080 -- Try to reach the current pragma from the first pragma
5081 -- of the grouping while skipping other members:
5083 -- pragma Loop_Invariant ...; -- first pragma
5084 -- pragma Loop_Variant ...; -- member
5086 -- pragma Loop_Variant ...; -- current pragma
5089 while Present
(Stmt
) loop
5091 -- The current pragma is either the first pragma
5092 -- of the group or is a member of the group. Stop
5093 -- the search as the placement is legal.
5098 -- Skip group members, but keep track of the last
5099 -- pragma in the group.
5101 elsif Is_Loop_Pragma
(Stmt
) then
5104 -- Skip declarations and statements generated by
5105 -- the compiler during expansion.
5107 elsif not Comes_From_Source
(Stmt
) then
5110 -- A non-pragma is separating the group from the
5111 -- current pragma, the placement is illegal.
5114 Grouping_Error
(Prag
);
5120 -- If the traversal did not reach the current pragma,
5121 -- then the list must be malformed.
5123 raise Program_Error
;
5131 --------------------
5132 -- Grouping_Error --
5133 --------------------
5135 procedure Grouping_Error
(Prag
: Node_Id
) is
5137 Error_Msg_Sloc
:= Sloc
(Prag
);
5138 Error_Pragma
("pragma% must appear next to pragma#");
5141 -- Start of processing for Check_Loop_Pragma_Grouping
5144 -- Inspect the statements of the loop or nested blocks housed
5145 -- within to determine whether the current pragma is part of the
5146 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5148 Check_Grouping
(Statements
(Loop_Stmt
));
5151 when Stop_Search
=> null;
5152 end Check_Loop_Pragma_Grouping
;
5154 --------------------
5155 -- Is_Loop_Pragma --
5156 --------------------
5158 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
5160 -- Inspect the original node as Loop_Invariant and Loop_Variant
5161 -- pragmas are rewritten to null when assertions are disabled.
5163 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
5165 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
5166 Name_Loop_Invariant
,
5173 ---------------------
5174 -- Placement_Error --
5175 ---------------------
5177 procedure Placement_Error
(Constr
: Node_Id
) is
5178 LA
: constant String := " with Loop_Entry";
5181 if Prag_Id
= Pragma_Assert
then
5182 Error_Msg_String
(1 .. LA
'Length) := LA
;
5183 Error_Msg_Strlen
:= LA
'Length;
5185 Error_Msg_Strlen
:= 0;
5188 if Nkind
(Constr
) = N_Pragma
then
5190 ("pragma %~ must appear immediately within the statements "
5194 ("block containing pragma %~ must appear immediately within "
5195 & "the statements of a loop", Constr
);
5197 end Placement_Error
;
5199 -- Local declarations
5204 -- Start of processing for Check_Loop_Pragma_Placement
5207 -- Check that pragma appears immediately within a loop statement,
5208 -- ignoring intervening block statements.
5212 while Present
(Stmt
) loop
5214 -- The pragma or previous block must appear immediately within the
5215 -- current block's declarative or statement part.
5217 if Nkind
(Stmt
) = N_Block_Statement
then
5218 if (No
(Declarations
(Stmt
))
5219 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
5221 List_Containing
(Prev
) /=
5222 Statements
(Handled_Statement_Sequence
(Stmt
))
5224 Placement_Error
(Prev
);
5227 -- Keep inspecting the parents because we are now within a
5228 -- chain of nested blocks.
5232 Stmt
:= Parent
(Stmt
);
5235 -- The pragma or previous block must appear immediately within the
5236 -- statements of the loop.
5238 elsif Nkind
(Stmt
) = N_Loop_Statement
then
5239 if List_Containing
(Prev
) /= Statements
(Stmt
) then
5240 Placement_Error
(Prev
);
5243 -- Stop the traversal because we reached the innermost loop
5244 -- regardless of whether we encountered an error or not.
5248 -- Ignore a handled statement sequence. Note that this node may
5249 -- be related to a subprogram body in which case we will emit an
5250 -- error on the next iteration of the search.
5252 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
5253 Stmt
:= Parent
(Stmt
);
5255 -- Any other statement breaks the chain from the pragma to the
5259 Placement_Error
(Prev
);
5264 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5265 -- grouped together with other such pragmas.
5267 if Is_Loop_Pragma
(N
) then
5269 -- The previous check should have located the related loop
5271 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
5272 Check_Loop_Pragma_Grouping
(Stmt
);
5274 end Check_Loop_Pragma_Placement
;
5276 -------------------------------------------
5277 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5278 -------------------------------------------
5280 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
5289 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
5292 elsif Nkind_In
(P
, N_Package_Specification
,
5297 -- Note: the following tests seem a little peculiar, because
5298 -- they test for bodies, but if we were in the statement part
5299 -- of the body, we would already have hit the handled statement
5300 -- sequence, so the only way we get here is by being in the
5301 -- declarative part of the body.
5303 elsif Nkind_In
(P
, N_Subprogram_Body
,
5314 Error_Pragma
("pragma% is not in declarative part or package spec");
5315 end Check_Is_In_Decl_Part_Or_Package_Spec
;
5317 -------------------------
5318 -- Check_No_Identifier --
5319 -------------------------
5321 procedure Check_No_Identifier
(Arg
: Node_Id
) is
5323 if Nkind
(Arg
) = N_Pragma_Argument_Association
5324 and then Chars
(Arg
) /= No_Name
5326 Error_Pragma_Arg_Ident
5327 ("pragma% does not permit identifier& here", Arg
);
5329 end Check_No_Identifier
;
5331 --------------------------
5332 -- Check_No_Identifiers --
5333 --------------------------
5335 procedure Check_No_Identifiers
is
5339 for J
in 1 .. Arg_Count
loop
5340 Check_No_Identifier
(Arg_Node
);
5343 end Check_No_Identifiers
;
5345 ------------------------
5346 -- Check_No_Link_Name --
5347 ------------------------
5349 procedure Check_No_Link_Name
is
5351 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
5355 if Present
(Arg4
) then
5357 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
5359 end Check_No_Link_Name
;
5361 -------------------------------
5362 -- Check_Optional_Identifier --
5363 -------------------------------
5365 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5368 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5369 and then Chars
(Arg
) /= No_Name
5371 if Chars
(Arg
) /= Id
then
5372 Error_Msg_Name_1
:= Pname
;
5373 Error_Msg_Name_2
:= Id
;
5374 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5378 end Check_Optional_Identifier
;
5380 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
5382 Name_Buffer
(1 .. Id
'Length) := Id
;
5383 Name_Len
:= Id
'Length;
5384 Check_Optional_Identifier
(Arg
, Name_Find
);
5385 end Check_Optional_Identifier
;
5387 -------------------------------------
5388 -- Check_Static_Boolean_Expression --
5389 -------------------------------------
5391 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
5393 if Present
(Expr
) then
5394 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
5396 if not Is_OK_Static_Expression
(Expr
) then
5398 ("expression of pragma % must be static", Expr
);
5401 end Check_Static_Boolean_Expression
;
5403 -----------------------------
5404 -- Check_Static_Constraint --
5405 -----------------------------
5407 -- Note: for convenience in writing this procedure, in addition to
5408 -- the officially (i.e. by spec) allowed argument which is always a
5409 -- constraint, it also allows ranges and discriminant associations.
5410 -- Above is not clear ???
5412 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5414 procedure Require_Static
(E
: Node_Id
);
5415 -- Require given expression to be static expression
5417 --------------------
5418 -- Require_Static --
5419 --------------------
5421 procedure Require_Static
(E
: Node_Id
) is
5423 if not Is_OK_Static_Expression
(E
) then
5424 Flag_Non_Static_Expr
5425 ("non-static constraint not allowed in Unchecked_Union!", E
);
5430 -- Start of processing for Check_Static_Constraint
5433 case Nkind
(Constr
) is
5434 when N_Discriminant_Association
=>
5435 Require_Static
(Expression
(Constr
));
5438 Require_Static
(Low_Bound
(Constr
));
5439 Require_Static
(High_Bound
(Constr
));
5441 when N_Attribute_Reference
=>
5442 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5443 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5445 when N_Range_Constraint
=>
5446 Check_Static_Constraint
(Range_Expression
(Constr
));
5448 when N_Index_Or_Discriminant_Constraint
=>
5452 IDC
:= First
(Constraints
(Constr
));
5453 while Present
(IDC
) loop
5454 Check_Static_Constraint
(IDC
);
5462 end Check_Static_Constraint
;
5464 --------------------------------------
5465 -- Check_Valid_Configuration_Pragma --
5466 --------------------------------------
5468 -- A configuration pragma must appear in the context clause of a
5469 -- compilation unit, and only other pragmas may precede it. Note that
5470 -- the test also allows use in a configuration pragma file.
5472 procedure Check_Valid_Configuration_Pragma
is
5474 if not Is_Configuration_Pragma
then
5475 Error_Pragma
("incorrect placement for configuration pragma%");
5477 end Check_Valid_Configuration_Pragma
;
5479 -------------------------------------
5480 -- Check_Valid_Library_Unit_Pragma --
5481 -------------------------------------
5483 procedure Check_Valid_Library_Unit_Pragma
is
5485 Parent_Node
: Node_Id
;
5486 Unit_Name
: Entity_Id
;
5487 Unit_Kind
: Node_Kind
;
5488 Unit_Node
: Node_Id
;
5489 Sindex
: Source_File_Index
;
5492 if not Is_List_Member
(N
) then
5496 Plist
:= List_Containing
(N
);
5497 Parent_Node
:= Parent
(Plist
);
5499 if Parent_Node
= Empty
then
5502 -- Case of pragma appearing after a compilation unit. In this case
5503 -- it must have an argument with the corresponding name and must
5504 -- be part of the following pragmas of its parent.
5506 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5507 if Plist
/= Pragmas_After
(Parent_Node
) then
5510 elsif Arg_Count
= 0 then
5512 ("argument required if outside compilation unit");
5515 Check_No_Identifiers
;
5516 Check_Arg_Count
(1);
5517 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5518 Unit_Kind
:= Nkind
(Unit_Node
);
5520 Analyze
(Get_Pragma_Arg
(Arg1
));
5522 if Unit_Kind
= N_Generic_Subprogram_Declaration
5523 or else Unit_Kind
= N_Subprogram_Declaration
5525 Unit_Name
:= Defining_Entity
(Unit_Node
);
5527 elsif Unit_Kind
in N_Generic_Instantiation
then
5528 Unit_Name
:= Defining_Entity
(Unit_Node
);
5531 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5534 if Chars
(Unit_Name
) /=
5535 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5538 ("pragma% argument is not current unit name", Arg1
);
5541 if Ekind
(Unit_Name
) = E_Package
5542 and then Present
(Renamed_Entity
(Unit_Name
))
5544 Error_Pragma
("pragma% not allowed for renamed package");
5548 -- Pragma appears other than after a compilation unit
5551 -- Here we check for the generic instantiation case and also
5552 -- for the case of processing a generic formal package. We
5553 -- detect these cases by noting that the Sloc on the node
5554 -- does not belong to the current compilation unit.
5556 Sindex
:= Source_Index
(Current_Sem_Unit
);
5558 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5559 Rewrite
(N
, Make_Null_Statement
(Loc
));
5562 -- If before first declaration, the pragma applies to the
5563 -- enclosing unit, and the name if present must be this name.
5565 elsif Is_Before_First_Decl
(N
, Plist
) then
5566 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5567 Unit_Kind
:= Nkind
(Unit_Node
);
5569 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5572 elsif Unit_Kind
= N_Subprogram_Body
5573 and then not Acts_As_Spec
(Unit_Node
)
5577 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5580 elsif Nkind
(Parent_Node
) = N_Package_Specification
5581 and then Plist
= Private_Declarations
(Parent_Node
)
5585 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5586 or else Nkind
(Parent_Node
) =
5587 N_Generic_Subprogram_Declaration
)
5588 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5592 elsif Arg_Count
> 0 then
5593 Analyze
(Get_Pragma_Arg
(Arg1
));
5595 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5597 ("name in pragma% must be enclosing unit", Arg1
);
5600 -- It is legal to have no argument in this context
5606 -- Error if not before first declaration. This is because a
5607 -- library unit pragma argument must be the name of a library
5608 -- unit (RM 10.1.5(7)), but the only names permitted in this
5609 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5610 -- generic subprogram declarations or generic instantiations.
5614 ("pragma% misplaced, must be before first declaration");
5618 end Check_Valid_Library_Unit_Pragma
;
5624 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5625 Clist
: constant Node_Id
:= Component_List
(Variant
);
5629 Comp
:= First
(Component_Items
(Clist
));
5630 while Present
(Comp
) loop
5631 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5636 ---------------------------
5637 -- Ensure_Aggregate_Form --
5638 ---------------------------
5640 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5641 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
5642 Expr
: constant Node_Id
:= Expression
(Arg
);
5643 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
5644 Comps
: List_Id
:= No_List
;
5645 Exprs
: List_Id
:= No_List
;
5646 Nam
: Name_Id
:= No_Name
;
5647 Nam_Loc
: Source_Ptr
;
5650 -- The pragma argument is in positional form:
5652 -- pragma Depends (Nam => ...)
5656 -- Note that the Sloc of the Chars field is the Sloc of the pragma
5657 -- argument association.
5659 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5661 Nam_Loc
:= Sloc
(Arg
);
5663 -- Remove the pragma argument name as this will be captured in the
5666 Set_Chars
(Arg
, No_Name
);
5669 -- The argument is already in aggregate form, but the presence of a
5670 -- name causes this to be interpreted as named association which in
5671 -- turn must be converted into an aggregate.
5673 -- pragma Global (In_Out => (A, B, C))
5677 -- pragma Global ((In_Out => (A, B, C)))
5679 -- aggregate aggregate
5681 if Nkind
(Expr
) = N_Aggregate
then
5682 if Nam
= No_Name
then
5686 -- Do not transform a null argument into an aggregate as N_Null has
5687 -- special meaning in formal verification pragmas.
5689 elsif Nkind
(Expr
) = N_Null
then
5693 -- Everything comes from source if the original comes from source
5695 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
5697 -- Positional argument is transformed into an aggregate with an
5698 -- Expressions list.
5700 if Nam
= No_Name
then
5701 Exprs
:= New_List
(Relocate_Node
(Expr
));
5703 -- An associative argument is transformed into an aggregate with
5704 -- Component_Associations.
5708 Make_Component_Association
(Loc
,
5709 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
5710 Expression
=> Relocate_Node
(Expr
)));
5713 Set_Expression
(Arg
,
5714 Make_Aggregate
(Loc
,
5715 Component_Associations
=> Comps
,
5716 Expressions
=> Exprs
));
5718 -- Restore Comes_From_Source default
5720 Set_Comes_From_Source_Default
(CFSD
);
5721 end Ensure_Aggregate_Form
;
5727 procedure Error_Pragma
(Msg
: String) is
5729 Error_Msg_Name_1
:= Pname
;
5730 Error_Msg_N
(Fix_Error
(Msg
), N
);
5734 ----------------------
5735 -- Error_Pragma_Arg --
5736 ----------------------
5738 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5740 Error_Msg_Name_1
:= Pname
;
5741 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
5743 end Error_Pragma_Arg
;
5745 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5747 Error_Msg_Name_1
:= Pname
;
5748 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
5749 Error_Pragma_Arg
(Msg2
, Arg
);
5750 end Error_Pragma_Arg
;
5752 ----------------------------
5753 -- Error_Pragma_Arg_Ident --
5754 ----------------------------
5756 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5758 Error_Msg_Name_1
:= Pname
;
5759 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
5761 end Error_Pragma_Arg_Ident
;
5763 ----------------------
5764 -- Error_Pragma_Ref --
5765 ----------------------
5767 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5769 Error_Msg_Name_1
:= Pname
;
5770 Error_Msg_Sloc
:= Sloc
(Ref
);
5771 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
5773 end Error_Pragma_Ref
;
5775 ------------------------
5776 -- Find_Lib_Unit_Name --
5777 ------------------------
5779 function Find_Lib_Unit_Name
return Entity_Id
is
5781 -- Return inner compilation unit entity, for case of nested
5782 -- categorization pragmas. This happens in generic unit.
5784 if Nkind
(Parent
(N
)) = N_Package_Specification
5785 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5787 return Defining_Entity
(Parent
(N
));
5789 return Current_Scope
;
5791 end Find_Lib_Unit_Name
;
5793 ----------------------------
5794 -- Find_Program_Unit_Name --
5795 ----------------------------
5797 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5798 Unit_Name
: Entity_Id
;
5799 Unit_Kind
: Node_Kind
;
5800 P
: constant Node_Id
:= Parent
(N
);
5803 if Nkind
(P
) = N_Compilation_Unit
then
5804 Unit_Kind
:= Nkind
(Unit
(P
));
5806 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
5807 N_Package_Declaration
)
5808 or else Unit_Kind
in N_Generic_Declaration
5810 Unit_Name
:= Defining_Entity
(Unit
(P
));
5812 if Chars
(Id
) = Chars
(Unit_Name
) then
5813 Set_Entity
(Id
, Unit_Name
);
5814 Set_Etype
(Id
, Etype
(Unit_Name
));
5816 Set_Etype
(Id
, Any_Type
);
5818 ("cannot find program unit referenced by pragma%");
5822 Set_Etype
(Id
, Any_Type
);
5823 Error_Pragma
("pragma% inapplicable to this unit");
5829 end Find_Program_Unit_Name
;
5831 -----------------------------------------
5832 -- Find_Unique_Parameterless_Procedure --
5833 -----------------------------------------
5835 function Find_Unique_Parameterless_Procedure
5837 Arg
: Node_Id
) return Entity_Id
5839 Proc
: Entity_Id
:= Empty
;
5842 -- The body of this procedure needs some comments ???
5844 if not Is_Entity_Name
(Name
) then
5846 ("argument of pragma% must be entity name", Arg
);
5848 elsif not Is_Overloaded
(Name
) then
5849 Proc
:= Entity
(Name
);
5851 if Ekind
(Proc
) /= E_Procedure
5852 or else Present
(First_Formal
(Proc
))
5855 ("argument of pragma% must be parameterless procedure", Arg
);
5860 Found
: Boolean := False;
5862 Index
: Interp_Index
;
5865 Get_First_Interp
(Name
, Index
, It
);
5866 while Present
(It
.Nam
) loop
5869 if Ekind
(Proc
) = E_Procedure
5870 and then No
(First_Formal
(Proc
))
5874 Set_Entity
(Name
, Proc
);
5875 Set_Is_Overloaded
(Name
, False);
5878 ("ambiguous handler name for pragma% ", Arg
);
5882 Get_Next_Interp
(Index
, It
);
5887 ("argument of pragma% must be parameterless procedure",
5890 Proc
:= Entity
(Name
);
5896 end Find_Unique_Parameterless_Procedure
;
5902 function Fix_Error
(Msg
: String) return String is
5903 Res
: String (Msg
'Range) := Msg
;
5904 Res_Last
: Natural := Msg
'Last;
5908 -- If we have a rewriting of another pragma, go to that pragma
5910 if Is_Rewrite_Substitution
(N
)
5911 and then Nkind
(Original_Node
(N
)) = N_Pragma
5913 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
5916 -- Case where pragma comes from an aspect specification
5918 if From_Aspect_Specification
(N
) then
5920 -- Change appearence of "pragma" in message to "aspect"
5923 while J
<= Res_Last
- 5 loop
5924 if Res
(J
.. J
+ 5) = "pragma" then
5925 Res
(J
.. J
+ 5) := "aspect";
5933 -- Change "argument of" at start of message to "entity for"
5936 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
5938 Res
(Res
'First .. Res
'First + 9) := "entity for";
5939 Res
(Res
'First + 10 .. Res_Last
- 1) :=
5940 Res
(Res
'First + 11 .. Res_Last
);
5941 Res_Last
:= Res_Last
- 1;
5944 -- Change "argument" at start of message to "entity"
5947 and then Res
(Res
'First .. Res
'First + 7) = "argument"
5949 Res
(Res
'First .. Res
'First + 5) := "entity";
5950 Res
(Res
'First + 6 .. Res_Last
- 2) :=
5951 Res
(Res
'First + 8 .. Res_Last
);
5952 Res_Last
:= Res_Last
- 2;
5955 -- Get name from corresponding aspect
5957 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
5960 -- Return possibly modified message
5962 return Res
(Res
'First .. Res_Last
);
5965 -------------------------
5966 -- Gather_Associations --
5967 -------------------------
5969 procedure Gather_Associations
5971 Args
: out Args_List
)
5976 -- Initialize all parameters to Empty
5978 for J
in Args
'Range loop
5982 -- That's all we have to do if there are no argument associations
5984 if No
(Pragma_Argument_Associations
(N
)) then
5988 -- Otherwise first deal with any positional parameters present
5990 Arg
:= First
(Pragma_Argument_Associations
(N
));
5991 for Index
in Args
'Range loop
5992 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
5993 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5997 -- Positional parameters all processed, if any left, then we
5998 -- have too many positional parameters.
6000 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6002 ("too many positional associations for pragma%", Arg
);
6005 -- Process named parameters if any are present
6007 while Present
(Arg
) loop
6008 if Chars
(Arg
) = No_Name
then
6010 ("positional association cannot follow named association",
6014 for Index
in Names
'Range loop
6015 if Names
(Index
) = Chars
(Arg
) then
6016 if Present
(Args
(Index
)) then
6018 ("duplicate argument association for pragma%", Arg
);
6020 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6025 if Index
= Names
'Last then
6026 Error_Msg_Name_1
:= Pname
;
6027 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6029 -- Check for possible misspelling
6031 for Index1
in Names
'Range loop
6032 if Is_Bad_Spelling_Of
6033 (Chars
(Arg
), Names
(Index1
))
6035 Error_Msg_Name_1
:= Names
(Index1
);
6036 Error_Msg_N
-- CODEFIX
6037 ("\possible misspelling of%", Arg
);
6049 end Gather_Associations
;
6055 procedure GNAT_Pragma
is
6057 -- We need to check the No_Implementation_Pragmas restriction for
6058 -- the case of a pragma from source. Note that the case of aspects
6059 -- generating corresponding pragmas marks these pragmas as not being
6060 -- from source, so this test also catches that case.
6062 if Comes_From_Source
(N
) then
6063 Check_Restriction
(No_Implementation_Pragmas
, N
);
6067 --------------------------
6068 -- Is_Before_First_Decl --
6069 --------------------------
6071 function Is_Before_First_Decl
6072 (Pragma_Node
: Node_Id
;
6073 Decls
: List_Id
) return Boolean
6075 Item
: Node_Id
:= First
(Decls
);
6078 -- Only other pragmas can come before this pragma
6081 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6084 elsif Item
= Pragma_Node
then
6090 end Is_Before_First_Decl
;
6092 -----------------------------
6093 -- Is_Configuration_Pragma --
6094 -----------------------------
6096 -- A configuration pragma must appear in the context clause of a
6097 -- compilation unit, and only other pragmas may precede it. Note that
6098 -- the test below also permits use in a configuration pragma file.
6100 function Is_Configuration_Pragma
return Boolean is
6101 Lis
: constant List_Id
:= List_Containing
(N
);
6102 Par
: constant Node_Id
:= Parent
(N
);
6106 -- If no parent, then we are in the configuration pragma file,
6107 -- so the placement is definitely appropriate.
6112 -- Otherwise we must be in the context clause of a compilation unit
6113 -- and the only thing allowed before us in the context list is more
6114 -- configuration pragmas.
6116 elsif Nkind
(Par
) = N_Compilation_Unit
6117 and then Context_Items
(Par
) = Lis
6124 elsif Nkind
(Prg
) /= N_Pragma
then
6134 end Is_Configuration_Pragma
;
6136 --------------------------
6137 -- Is_In_Context_Clause --
6138 --------------------------
6140 function Is_In_Context_Clause
return Boolean is
6142 Parent_Node
: Node_Id
;
6145 if not Is_List_Member
(N
) then
6149 Plist
:= List_Containing
(N
);
6150 Parent_Node
:= Parent
(Plist
);
6152 if Parent_Node
= Empty
6153 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6154 or else Context_Items
(Parent_Node
) /= Plist
6161 end Is_In_Context_Clause
;
6163 ---------------------------------
6164 -- Is_Static_String_Expression --
6165 ---------------------------------
6167 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6168 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6169 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6172 Analyze_And_Resolve
(Argx
);
6174 -- Special case Ada 83, where the expression will never be static,
6175 -- but we will return true if we had a string literal to start with.
6177 if Ada_Version
= Ada_83
then
6180 -- Normal case, true only if we end up with a string literal that
6181 -- is marked as being the result of evaluating a static expression.
6184 return Is_OK_Static_Expression
(Argx
)
6185 and then Nkind
(Argx
) = N_String_Literal
;
6188 end Is_Static_String_Expression
;
6190 ----------------------
6191 -- Pragma_Misplaced --
6192 ----------------------
6194 procedure Pragma_Misplaced
is
6196 Error_Pragma
("incorrect placement of pragma%");
6197 end Pragma_Misplaced
;
6199 ------------------------------------------------
6200 -- Process_Atomic_Independent_Shared_Volatile --
6201 ------------------------------------------------
6203 procedure Process_Atomic_Independent_Shared_Volatile
is
6209 procedure Set_Atomic_VFA
(E
: Entity_Id
);
6210 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6211 -- no explicit alignment was given, set alignment to unknown, since
6212 -- back end knows what the alignment requirements are for atomic and
6213 -- full access arrays. Note: this is necessary for derived types.
6215 --------------------
6216 -- Set_Atomic_VFA --
6217 --------------------
6219 procedure Set_Atomic_VFA
(E
: Entity_Id
) is
6221 if Prag_Id
= Pragma_Volatile_Full_Access
then
6222 Set_Is_Volatile_Full_Access
(E
);
6227 if not Has_Alignment_Clause
(E
) then
6228 Set_Alignment
(E
, Uint_0
);
6232 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6235 Check_Ada_83_Warning
;
6236 Check_No_Identifiers
;
6237 Check_Arg_Count
(1);
6238 Check_Arg_Is_Local_Name
(Arg1
);
6239 E_Id
:= Get_Pragma_Arg
(Arg1
);
6241 if Etype
(E_Id
) = Any_Type
then
6246 D
:= Declaration_Node
(E
);
6249 -- A pragma that applies to a Ghost entity becomes Ghost for the
6250 -- purposes of legality checks and removal of ignored Ghost code.
6252 Mark_Pragma_As_Ghost
(N
, E
);
6254 -- Check duplicate before we chain ourselves
6256 Check_Duplicate_Pragma
(E
);
6258 -- Check Atomic and VFA used together
6260 if (Is_Atomic
(E
) and then Prag_Id
= Pragma_Volatile_Full_Access
)
6261 or else (Is_Volatile_Full_Access
(E
)
6262 and then (Prag_Id
= Pragma_Atomic
6264 Prag_Id
= Pragma_Shared
))
6267 ("cannot have Volatile_Full_Access and Atomic for same entity");
6270 -- Check for applying VFA to an entity which has aliased component
6272 if Prag_Id
= Pragma_Volatile_Full_Access
then
6275 Aliased_Comp
: Boolean := False;
6276 -- Set True if aliased component present
6279 if Is_Array_Type
(Etype
(E
)) then
6280 Aliased_Comp
:= Has_Aliased_Components
(Etype
(E
));
6282 -- Record case, too bad Has_Aliased_Components is not also
6283 -- set for records, should it be ???
6285 elsif Is_Record_Type
(Etype
(E
)) then
6286 Comp
:= First_Component_Or_Discriminant
(Etype
(E
));
6287 while Present
(Comp
) loop
6288 if Is_Aliased
(Comp
)
6289 or else Is_Aliased
(Etype
(Comp
))
6291 Aliased_Comp
:= True;
6295 Next_Component_Or_Discriminant
(Comp
);
6299 if Aliased_Comp
then
6301 ("cannot apply Volatile_Full_Access (aliased component "
6307 -- Now check appropriateness of the entity
6310 if Rep_Item_Too_Early
(E
, N
)
6312 Rep_Item_Too_Late
(E
, N
)
6316 Check_First_Subtype
(Arg1
);
6319 -- Attribute belongs on the base type. If the view of the type is
6320 -- currently private, it also belongs on the underlying type.
6322 if Prag_Id
= Pragma_Atomic
6324 Prag_Id
= Pragma_Shared
6326 Prag_Id
= Pragma_Volatile_Full_Access
6329 Set_Atomic_VFA
(Base_Type
(E
));
6330 Set_Atomic_VFA
(Underlying_Type
(E
));
6333 -- Atomic/Shared/Volatile_Full_Access imply Independent
6335 if Prag_Id
/= Pragma_Volatile
then
6336 Set_Is_Independent
(E
);
6337 Set_Is_Independent
(Base_Type
(E
));
6338 Set_Is_Independent
(Underlying_Type
(E
));
6340 if Prag_Id
= Pragma_Independent
then
6341 Record_Independence_Check
(N
, Base_Type
(E
));
6345 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6347 if Prag_Id
/= Pragma_Independent
then
6348 Set_Is_Volatile
(E
);
6349 Set_Is_Volatile
(Base_Type
(E
));
6350 Set_Is_Volatile
(Underlying_Type
(E
));
6352 Set_Treat_As_Volatile
(E
);
6353 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6356 elsif K
= N_Object_Declaration
6357 or else (K
= N_Component_Declaration
6358 and then Original_Record_Component
(E
) = E
)
6360 if Rep_Item_Too_Late
(E
, N
) then
6364 if Prag_Id
= Pragma_Atomic
6366 Prag_Id
= Pragma_Shared
6368 Prag_Id
= Pragma_Volatile_Full_Access
6370 if Prag_Id
= Pragma_Volatile_Full_Access
then
6371 Set_Is_Volatile_Full_Access
(E
);
6376 -- If the object declaration has an explicit initialization, a
6377 -- temporary may have to be created to hold the expression, to
6378 -- ensure that access to the object remain atomic.
6380 if Nkind
(Parent
(E
)) = N_Object_Declaration
6381 and then Present
(Expression
(Parent
(E
)))
6383 Set_Has_Delayed_Freeze
(E
);
6387 -- Atomic/Shared/Volatile_Full_Access imply Independent
6389 if Prag_Id
/= Pragma_Volatile
then
6390 Set_Is_Independent
(E
);
6392 if Prag_Id
= Pragma_Independent
then
6393 Record_Independence_Check
(N
, E
);
6397 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6399 if Prag_Id
/= Pragma_Independent
then
6400 Set_Is_Volatile
(E
);
6401 Set_Treat_As_Volatile
(E
);
6405 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6408 -- The following check is only relevant when SPARK_Mode is on as
6409 -- this is not a standard Ada legality rule. Pragma Volatile can
6410 -- only apply to a full type declaration or an object declaration
6411 -- (SPARK RM C.6(1)).
6414 and then Prag_Id
= Pragma_Volatile
6415 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6416 N_Object_Declaration
)
6419 ("argument of pragma % must denote a full type or object "
6420 & "declaration", Arg1
);
6422 end Process_Atomic_Independent_Shared_Volatile
;
6424 -------------------------------------------
6425 -- Process_Compile_Time_Warning_Or_Error --
6426 -------------------------------------------
6428 procedure Process_Compile_Time_Warning_Or_Error
is
6429 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6432 Check_Arg_Count
(2);
6433 Check_No_Identifiers
;
6434 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6435 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6437 if Compile_Time_Known_Value
(Arg1x
) then
6438 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6440 Str
: constant String_Id
:=
6441 Strval
(Get_Pragma_Arg
(Arg2
));
6442 Len
: constant Int
:= String_Length
(Str
);
6447 Cent
: constant Entity_Id
:=
6448 Cunit_Entity
(Current_Sem_Unit
);
6450 Force
: constant Boolean :=
6451 Prag_Id
= Pragma_Compile_Time_Warning
6453 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6454 and then (Ekind
(Cent
) /= E_Package
6455 or else not In_Private_Part
(Cent
));
6456 -- Set True if this is the warning case, and we are in the
6457 -- visible part of a package spec, or in a subprogram spec,
6458 -- in which case we want to force the client to see the
6459 -- warning, even though it is not in the main unit.
6462 -- Loop through segments of message separated by line feeds.
6463 -- We output these segments as separate messages with
6464 -- continuation marks for all but the first.
6469 Error_Msg_Strlen
:= 0;
6471 -- Loop to copy characters from argument to error message
6475 exit when Ptr
> Len
;
6476 CC
:= Get_String_Char
(Str
, Ptr
);
6479 -- Ignore wide chars ??? else store character
6481 if In_Character_Range
(CC
) then
6482 C
:= Get_Character
(CC
);
6483 exit when C
= ASCII
.LF
;
6484 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6485 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6489 -- Here with one line ready to go
6491 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6493 -- If this is a warning in a spec, then we want clients
6494 -- to see the warning, so mark the message with the
6495 -- special sequence !! to force the warning. In the case
6496 -- of a package spec, we do not force this if we are in
6497 -- the private part of the spec.
6500 if Cont
= False then
6501 Error_Msg_N
("<<~!!", Arg1
);
6504 Error_Msg_N
("\<<~!!", Arg1
);
6507 -- Error, rather than warning, or in a body, so we do not
6508 -- need to force visibility for client (error will be
6509 -- output in any case, and this is the situation in which
6510 -- we do not want a client to get a warning, since the
6511 -- warning is in the body or the spec private part).
6514 if Cont
= False then
6515 Error_Msg_N
("<<~", Arg1
);
6518 Error_Msg_N
("\<<~", Arg1
);
6522 exit when Ptr
> Len
;
6527 end Process_Compile_Time_Warning_Or_Error
;
6529 ------------------------
6530 -- Process_Convention --
6531 ------------------------
6533 procedure Process_Convention
6534 (C
: out Convention_Id
;
6535 Ent
: out Entity_Id
)
6539 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6540 -- Called if we have more than one Export/Import/Convention pragma.
6541 -- This is generally illegal, but we have a special case of allowing
6542 -- Import and Interface to coexist if they specify the convention in
6543 -- a consistent manner. We are allowed to do this, since Interface is
6544 -- an implementation defined pragma, and we choose to do it since we
6545 -- know Rational allows this combination. S is the entity id of the
6546 -- subprogram in question. This procedure also sets the special flag
6547 -- Import_Interface_Present in both pragmas in the case where we do
6548 -- have matching Import and Interface pragmas.
6550 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6551 -- Set convention in entity E, and also flag that the entity has a
6552 -- convention pragma. If entity is for a private or incomplete type,
6553 -- also set convention and flag on underlying type. This procedure
6554 -- also deals with the special case of C_Pass_By_Copy convention,
6555 -- and error checks for inappropriate convention specification.
6557 -------------------------------
6558 -- Diagnose_Multiple_Pragmas --
6559 -------------------------------
6561 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6562 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6566 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6567 -- Decl is a pragma node. This function returns True if this
6568 -- pragma has a first argument that is an identifier with a
6569 -- Chars field corresponding to the Convention_Id C.
6571 function Same_Name
(Decl
: Node_Id
) return Boolean;
6572 -- Decl is a pragma node. This function returns True if this
6573 -- pragma has a second argument that is an identifier with a
6574 -- Chars field that matches the Chars of the current subprogram.
6576 ---------------------
6577 -- Same_Convention --
6578 ---------------------
6580 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6581 Arg1
: constant Node_Id
:=
6582 First
(Pragma_Argument_Associations
(Decl
));
6585 if Present
(Arg1
) then
6587 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6589 if Nkind
(Arg
) = N_Identifier
6590 and then Is_Convention_Name
(Chars
(Arg
))
6591 and then Get_Convention_Id
(Chars
(Arg
)) = C
6599 end Same_Convention
;
6605 function Same_Name
(Decl
: Node_Id
) return Boolean is
6606 Arg1
: constant Node_Id
:=
6607 First
(Pragma_Argument_Associations
(Decl
));
6615 Arg2
:= Next
(Arg1
);
6622 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6624 if Nkind
(Arg
) = N_Identifier
6625 and then Chars
(Arg
) = Chars
(S
)
6634 -- Start of processing for Diagnose_Multiple_Pragmas
6639 -- Definitely give message if we have Convention/Export here
6641 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6644 -- If we have an Import or Export, scan back from pragma to
6645 -- find any previous pragma applying to the same procedure.
6646 -- The scan will be terminated by the start of the list, or
6647 -- hitting the subprogram declaration. This won't allow one
6648 -- pragma to appear in the public part and one in the private
6649 -- part, but that seems very unlikely in practice.
6653 while Present
(Decl
) and then Decl
/= Pdec
loop
6655 -- Look for pragma with same name as us
6657 if Nkind
(Decl
) = N_Pragma
6658 and then Same_Name
(Decl
)
6660 -- Give error if same as our pragma or Export/Convention
6662 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6668 -- Case of Import/Interface or the other way round
6670 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6673 -- Here we know that we have Import and Interface. It
6674 -- doesn't matter which way round they are. See if
6675 -- they specify the same convention. If so, all OK,
6676 -- and set special flags to stop other messages
6678 if Same_Convention
(Decl
) then
6679 Set_Import_Interface_Present
(N
);
6680 Set_Import_Interface_Present
(Decl
);
6683 -- If different conventions, special message
6686 Error_Msg_Sloc
:= Sloc
(Decl
);
6688 ("convention differs from that given#", Arg1
);
6698 -- Give message if needed if we fall through those tests
6699 -- except on Relaxed_RM_Semantics where we let go: either this
6700 -- is a case accepted/ignored by other Ada compilers (e.g.
6701 -- a mix of Convention and Import), or another error will be
6702 -- generated later (e.g. using both Import and Export).
6704 if Err
and not Relaxed_RM_Semantics
then
6706 ("at most one Convention/Export/Import pragma is allowed",
6709 end Diagnose_Multiple_Pragmas
;
6711 --------------------------------
6712 -- Set_Convention_From_Pragma --
6713 --------------------------------
6715 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6717 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6718 -- for an overridden dispatching operation. Technically this is
6719 -- an amendment and should only be done in Ada 2005 mode. However,
6720 -- this is clearly a mistake, since the problem that is addressed
6721 -- by this AI is that there is a clear gap in the RM.
6723 if Is_Dispatching_Operation
(E
)
6724 and then Present
(Overridden_Operation
(E
))
6725 and then C
/= Convention
(Overridden_Operation
(E
))
6728 ("cannot change convention for overridden dispatching "
6729 & "operation", Arg1
);
6732 -- Special checks for Convention_Stdcall
6734 if C
= Convention_Stdcall
then
6736 -- A dispatching call is not allowed. A dispatching subprogram
6737 -- cannot be used to interface to the Win32 API, so in fact
6738 -- this check does not impose any effective restriction.
6740 if Is_Dispatching_Operation
(E
) then
6741 Error_Msg_Sloc
:= Sloc
(E
);
6743 -- Note: make this unconditional so that if there is more
6744 -- than one call to which the pragma applies, we get a
6745 -- message for each call. Also don't use Error_Pragma,
6746 -- so that we get multiple messages.
6749 ("dispatching subprogram# cannot use Stdcall convention!",
6752 -- Subprograms are not allowed
6754 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6758 and then Ekind
(E
) /= E_Variable
6760 -- An access to subprogram is also allowed
6764 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6766 -- Allow internal call to set convention of subprogram type
6768 and then not (Ekind
(E
) = E_Subprogram_Type
)
6771 ("second argument of pragma% must be subprogram (type)",
6776 -- Set the convention
6778 Set_Convention
(E
, C
);
6779 Set_Has_Convention_Pragma
(E
);
6781 -- For the case of a record base type, also set the convention of
6782 -- any anonymous access types declared in the record which do not
6783 -- currently have a specified convention.
6785 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6790 Comp
:= First_Component
(E
);
6791 while Present
(Comp
) loop
6792 if Present
(Etype
(Comp
))
6793 and then Ekind_In
(Etype
(Comp
),
6794 E_Anonymous_Access_Type
,
6795 E_Anonymous_Access_Subprogram_Type
)
6796 and then not Has_Convention_Pragma
(Comp
)
6798 Set_Convention
(Comp
, C
);
6801 Next_Component
(Comp
);
6806 -- Deal with incomplete/private type case, where underlying type
6807 -- is available, so set convention of that underlying type.
6809 if Is_Incomplete_Or_Private_Type
(E
)
6810 and then Present
(Underlying_Type
(E
))
6812 Set_Convention
(Underlying_Type
(E
), C
);
6813 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6816 -- A class-wide type should inherit the convention of the specific
6817 -- root type (although this isn't specified clearly by the RM).
6819 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6820 Set_Convention
(Class_Wide_Type
(E
), C
);
6823 -- If the entity is a record type, then check for special case of
6824 -- C_Pass_By_Copy, which is treated the same as C except that the
6825 -- special record flag is set. This convention is only permitted
6826 -- on record types (see AI95-00131).
6828 if Cname
= Name_C_Pass_By_Copy
then
6829 if Is_Record_Type
(E
) then
6830 Set_C_Pass_By_Copy
(Base_Type
(E
));
6831 elsif Is_Incomplete_Or_Private_Type
(E
)
6832 and then Is_Record_Type
(Underlying_Type
(E
))
6834 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6837 ("C_Pass_By_Copy convention allowed only for record type",
6842 -- If the entity is a derived boolean type, check for the special
6843 -- case of convention C, C++, or Fortran, where we consider any
6844 -- nonzero value to represent true.
6846 if Is_Discrete_Type
(E
)
6847 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6853 C
= Convention_Fortran
)
6855 Set_Nonzero_Is_True
(Base_Type
(E
));
6857 end Set_Convention_From_Pragma
;
6861 Comp_Unit
: Unit_Number_Type
;
6866 -- Start of processing for Process_Convention
6869 Check_At_Least_N_Arguments
(2);
6870 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6871 Check_Arg_Is_Identifier
(Arg1
);
6872 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6874 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6875 -- tested again below to set the critical flag).
6877 if Cname
= Name_C_Pass_By_Copy
then
6880 -- Otherwise we must have something in the standard convention list
6882 elsif Is_Convention_Name
(Cname
) then
6883 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6885 -- Otherwise warn on unrecognized convention
6888 if Warn_On_Export_Import
then
6890 ("??unrecognized convention name, C assumed",
6891 Get_Pragma_Arg
(Arg1
));
6897 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6898 Check_Arg_Is_Local_Name
(Arg2
);
6900 Id
:= Get_Pragma_Arg
(Arg2
);
6903 if not Is_Entity_Name
(Id
) then
6904 Error_Pragma_Arg
("entity name required", Arg2
);
6909 -- Set entity to return
6913 -- Ada_Pass_By_Copy special checking
6915 if C
= Convention_Ada_Pass_By_Copy
then
6916 if not Is_First_Subtype
(E
) then
6918 ("convention `Ada_Pass_By_Copy` only allowed for types",
6922 if Is_By_Reference_Type
(E
) then
6924 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6928 -- Ada_Pass_By_Reference special checking
6930 elsif C
= Convention_Ada_Pass_By_Reference
then
6931 if not Is_First_Subtype
(E
) then
6933 ("convention `Ada_Pass_By_Reference` only allowed for types",
6937 if Is_By_Copy_Type
(E
) then
6939 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6944 -- Go to renamed subprogram if present, since convention applies to
6945 -- the actual renamed entity, not to the renaming entity. If the
6946 -- subprogram is inherited, go to parent subprogram.
6948 if Is_Subprogram
(E
)
6949 and then Present
(Alias
(E
))
6951 if Nkind
(Parent
(Declaration_Node
(E
))) =
6952 N_Subprogram_Renaming_Declaration
6954 if Scope
(E
) /= Scope
(Alias
(E
)) then
6956 ("cannot apply pragma% to non-local entity&#", E
);
6961 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6962 N_Private_Extension_Declaration
)
6963 and then Scope
(E
) = Scope
(Alias
(E
))
6967 -- Return the parent subprogram the entity was inherited from
6973 -- Check that we are not applying this to a specless body. Relax this
6974 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
6976 if Is_Subprogram
(E
)
6977 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6978 and then not Relaxed_RM_Semantics
6981 ("pragma% requires separate spec and must come before body");
6984 -- Check that we are not applying this to a named constant
6986 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6987 Error_Msg_Name_1
:= Pname
;
6989 ("cannot apply pragma% to named constant!",
6990 Get_Pragma_Arg
(Arg2
));
6992 ("\supply appropriate type for&!", Arg2
);
6995 if Ekind
(E
) = E_Enumeration_Literal
then
6996 Error_Pragma
("enumeration literal not allowed for pragma%");
6999 -- Check for rep item appearing too early or too late
7001 if Etype
(E
) = Any_Type
7002 or else Rep_Item_Too_Early
(E
, N
)
7006 elsif Present
(Underlying_Type
(E
)) then
7007 E
:= Underlying_Type
(E
);
7010 if Rep_Item_Too_Late
(E
, N
) then
7014 if Has_Convention_Pragma
(E
) then
7015 Diagnose_Multiple_Pragmas
(E
);
7017 elsif Convention
(E
) = Convention_Protected
7018 or else Ekind
(Scope
(E
)) = E_Protected_Type
7021 ("a protected operation cannot be given a different convention",
7025 -- For Intrinsic, a subprogram is required
7027 if C
= Convention_Intrinsic
7028 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7031 ("second argument of pragma% must be a subprogram", Arg2
);
7034 -- Deal with non-subprogram cases
7036 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
7037 Set_Convention_From_Pragma
(E
);
7041 -- The pragma must apply to a first subtype, but it can also
7042 -- apply to a generic type in a generic formal part, in which
7043 -- case it will also appear in the corresponding instance.
7045 if Is_Generic_Type
(E
) or else In_Instance
then
7048 Check_First_Subtype
(Arg2
);
7051 Set_Convention_From_Pragma
(Base_Type
(E
));
7053 -- For access subprograms, we must set the convention on the
7054 -- internally generated directly designated type as well.
7056 if Ekind
(E
) = E_Access_Subprogram_Type
then
7057 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7061 -- For the subprogram case, set proper convention for all homonyms
7062 -- in same scope and the same declarative part, i.e. the same
7063 -- compilation unit.
7066 Comp_Unit
:= Get_Source_Unit
(E
);
7067 Set_Convention_From_Pragma
(E
);
7069 -- Treat a pragma Import as an implicit body, and pragma import
7070 -- as implicit reference (for navigation in GPS).
7072 if Prag_Id
= Pragma_Import
then
7073 Generate_Reference
(E
, Id
, 'b');
7075 -- For exported entities we restrict the generation of references
7076 -- to entities exported to foreign languages since entities
7077 -- exported to Ada do not provide further information to GPS and
7078 -- add undesired references to the output of the gnatxref tool.
7080 elsif Prag_Id
= Pragma_Export
7081 and then Convention
(E
) /= Convention_Ada
7083 Generate_Reference
(E
, Id
, 'i');
7086 -- If the pragma comes from an aspect, it only applies to the
7087 -- given entity, not its homonyms.
7089 if From_Aspect_Specification
(N
) then
7093 -- Otherwise Loop through the homonyms of the pragma argument's
7094 -- entity, an apply convention to those in the current scope.
7100 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7102 -- Ignore entry for which convention is already set
7104 if Has_Convention_Pragma
(E1
) then
7108 -- Do not set the pragma on inherited operations or on formal
7111 if Comes_From_Source
(E1
)
7112 and then Comp_Unit
= Get_Source_Unit
(E1
)
7113 and then not Is_Formal_Subprogram
(E1
)
7114 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7115 N_Full_Type_Declaration
7117 if Present
(Alias
(E1
))
7118 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7121 ("cannot apply pragma% to non-local entity& declared#",
7125 Set_Convention_From_Pragma
(E1
);
7127 if Prag_Id
= Pragma_Import
then
7128 Generate_Reference
(E1
, Id
, 'b');
7136 end Process_Convention
;
7138 ----------------------------------------
7139 -- Process_Disable_Enable_Atomic_Sync --
7140 ----------------------------------------
7142 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7144 Check_No_Identifiers
;
7145 Check_At_Most_N_Arguments
(1);
7147 -- Modeled internally as
7148 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7152 Pragma_Identifier
=>
7153 Make_Identifier
(Loc
, Nam
),
7154 Pragma_Argument_Associations
=> New_List
(
7155 Make_Pragma_Argument_Association
(Loc
,
7157 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7159 if Present
(Arg1
) then
7160 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7164 end Process_Disable_Enable_Atomic_Sync
;
7166 -------------------------------------------------
7167 -- Process_Extended_Import_Export_Internal_Arg --
7168 -------------------------------------------------
7170 procedure Process_Extended_Import_Export_Internal_Arg
7171 (Arg_Internal
: Node_Id
:= Empty
)
7174 if No
(Arg_Internal
) then
7175 Error_Pragma
("Internal parameter required for pragma%");
7178 if Nkind
(Arg_Internal
) = N_Identifier
then
7181 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7182 and then (Prag_Id
= Pragma_Import_Function
7184 Prag_Id
= Pragma_Export_Function
)
7190 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7193 Check_Arg_Is_Local_Name
(Arg_Internal
);
7194 end Process_Extended_Import_Export_Internal_Arg
;
7196 --------------------------------------------------
7197 -- Process_Extended_Import_Export_Object_Pragma --
7198 --------------------------------------------------
7200 procedure Process_Extended_Import_Export_Object_Pragma
7201 (Arg_Internal
: Node_Id
;
7202 Arg_External
: Node_Id
;
7208 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7209 Def_Id
:= Entity
(Arg_Internal
);
7211 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7213 ("pragma% must designate an object", Arg_Internal
);
7216 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7218 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7221 ("previous Common/Psect_Object applies, pragma % not permitted",
7225 if Rep_Item_Too_Late
(Def_Id
, N
) then
7229 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7231 if Present
(Arg_Size
) then
7232 Check_Arg_Is_External_Name
(Arg_Size
);
7235 -- Export_Object case
7237 if Prag_Id
= Pragma_Export_Object
then
7238 if not Is_Library_Level_Entity
(Def_Id
) then
7240 ("argument for pragma% must be library level entity",
7244 if Ekind
(Current_Scope
) = E_Generic_Package
then
7245 Error_Pragma
("pragma& cannot appear in a generic unit");
7248 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7250 ("exported object must have compile time known size",
7254 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7255 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7257 Set_Exported
(Def_Id
, Arg_Internal
);
7260 -- Import_Object case
7263 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7265 ("cannot use pragma% for task/protected object",
7269 if Ekind
(Def_Id
) = E_Constant
then
7271 ("cannot import a constant", Arg_Internal
);
7274 if Warn_On_Export_Import
7275 and then Has_Discriminants
(Etype
(Def_Id
))
7278 ("imported value must be initialized??", Arg_Internal
);
7281 if Warn_On_Export_Import
7282 and then Is_Access_Type
(Etype
(Def_Id
))
7285 ("cannot import object of an access type??", Arg_Internal
);
7288 if Warn_On_Export_Import
7289 and then Is_Imported
(Def_Id
)
7291 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7293 -- Check for explicit initialization present. Note that an
7294 -- initialization generated by the code generator, e.g. for an
7295 -- access type, does not count here.
7297 elsif Present
(Expression
(Parent
(Def_Id
)))
7300 (Original_Node
(Expression
(Parent
(Def_Id
))))
7302 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7304 ("imported entities cannot be initialized (RM B.1(24))",
7305 "\no initialization allowed for & declared#", Arg1
);
7307 Set_Imported
(Def_Id
);
7308 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7311 end Process_Extended_Import_Export_Object_Pragma
;
7313 ------------------------------------------------------
7314 -- Process_Extended_Import_Export_Subprogram_Pragma --
7315 ------------------------------------------------------
7317 procedure Process_Extended_Import_Export_Subprogram_Pragma
7318 (Arg_Internal
: Node_Id
;
7319 Arg_External
: Node_Id
;
7320 Arg_Parameter_Types
: Node_Id
;
7321 Arg_Result_Type
: Node_Id
:= Empty
;
7322 Arg_Mechanism
: Node_Id
;
7323 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7329 Ambiguous
: Boolean;
7332 function Same_Base_Type
7334 Formal
: Entity_Id
) return Boolean;
7335 -- Determines if Ptype references the type of Formal. Note that only
7336 -- the base types need to match according to the spec. Ptype here is
7337 -- the argument from the pragma, which is either a type name, or an
7338 -- access attribute.
7340 --------------------
7341 -- Same_Base_Type --
7342 --------------------
7344 function Same_Base_Type
7346 Formal
: Entity_Id
) return Boolean
7348 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7352 -- Case where pragma argument is typ'Access
7354 if Nkind
(Ptype
) = N_Attribute_Reference
7355 and then Attribute_Name
(Ptype
) = Name_Access
7357 Pref
:= Prefix
(Ptype
);
7360 if not Is_Entity_Name
(Pref
)
7361 or else Entity
(Pref
) = Any_Type
7366 -- We have a match if the corresponding argument is of an
7367 -- anonymous access type, and its designated type matches the
7368 -- type of the prefix of the access attribute
7370 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7371 and then Base_Type
(Entity
(Pref
)) =
7372 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7374 -- Case where pragma argument is a type name
7379 if not Is_Entity_Name
(Ptype
)
7380 or else Entity
(Ptype
) = Any_Type
7385 -- We have a match if the corresponding argument is of the type
7386 -- given in the pragma (comparing base types)
7388 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7392 -- Start of processing for
7393 -- Process_Extended_Import_Export_Subprogram_Pragma
7396 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7400 -- Loop through homonyms (overloadings) of the entity
7402 Hom_Id
:= Entity
(Arg_Internal
);
7403 while Present
(Hom_Id
) loop
7404 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7406 -- We need a subprogram in the current scope
7408 if not Is_Subprogram
(Def_Id
)
7409 or else Scope
(Def_Id
) /= Current_Scope
7416 -- Pragma cannot apply to subprogram body
7418 if Is_Subprogram
(Def_Id
)
7419 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7423 ("pragma% requires separate spec"
7424 & " and must come before body");
7427 -- Test result type if given, note that the result type
7428 -- parameter can only be present for the function cases.
7430 if Present
(Arg_Result_Type
)
7431 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7435 elsif Etype
(Def_Id
) /= Standard_Void_Type
7437 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7441 -- Test parameter types if given. Note that this parameter
7442 -- has not been analyzed (and must not be, since it is
7443 -- semantic nonsense), so we get it as the parser left it.
7445 elsif Present
(Arg_Parameter_Types
) then
7446 Check_Matching_Types
: declare
7451 Formal
:= First_Formal
(Def_Id
);
7453 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7454 if Present
(Formal
) then
7458 -- A list of one type, e.g. (List) is parsed as
7459 -- a parenthesized expression.
7461 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7462 and then Paren_Count
(Arg_Parameter_Types
) = 1
7465 or else Present
(Next_Formal
(Formal
))
7470 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7473 -- A list of more than one type is parsed as a aggregate
7475 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7476 and then Paren_Count
(Arg_Parameter_Types
) = 0
7478 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7479 while Present
(Ptype
) or else Present
(Formal
) loop
7482 or else not Same_Base_Type
(Ptype
, Formal
)
7487 Next_Formal
(Formal
);
7492 -- Anything else is of the wrong form
7496 ("wrong form for Parameter_Types parameter",
7497 Arg_Parameter_Types
);
7499 end Check_Matching_Types
;
7502 -- Match is now False if the entry we found did not match
7503 -- either a supplied Parameter_Types or Result_Types argument
7509 -- Ambiguous case, the flag Ambiguous shows if we already
7510 -- detected this and output the initial messages.
7513 if not Ambiguous
then
7515 Error_Msg_Name_1
:= Pname
;
7517 ("pragma% does not uniquely identify subprogram!",
7519 Error_Msg_Sloc
:= Sloc
(Ent
);
7520 Error_Msg_N
("matching subprogram #!", N
);
7524 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7525 Error_Msg_N
("matching subprogram #!", N
);
7530 Hom_Id
:= Homonym
(Hom_Id
);
7533 -- See if we found an entry
7536 if not Ambiguous
then
7537 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7539 ("pragma% cannot be given for generic subprogram");
7542 ("pragma% does not identify local subprogram");
7549 -- Import pragmas must be for imported entities
7551 if Prag_Id
= Pragma_Import_Function
7553 Prag_Id
= Pragma_Import_Procedure
7555 Prag_Id
= Pragma_Import_Valued_Procedure
7557 if not Is_Imported
(Ent
) then
7559 ("pragma Import or Interface must precede pragma%");
7562 -- Here we have the Export case which can set the entity as exported
7564 -- But does not do so if the specified external name is null, since
7565 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7566 -- compatible) to request no external name.
7568 elsif Nkind
(Arg_External
) = N_String_Literal
7569 and then String_Length
(Strval
(Arg_External
)) = 0
7573 -- In all other cases, set entity as exported
7576 Set_Exported
(Ent
, Arg_Internal
);
7579 -- Special processing for Valued_Procedure cases
7581 if Prag_Id
= Pragma_Import_Valued_Procedure
7583 Prag_Id
= Pragma_Export_Valued_Procedure
7585 Formal
:= First_Formal
(Ent
);
7588 Error_Pragma
("at least one parameter required for pragma%");
7590 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7591 Error_Pragma
("first parameter must have mode out for pragma%");
7594 Set_Is_Valued_Procedure
(Ent
);
7598 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7600 -- Process Result_Mechanism argument if present. We have already
7601 -- checked that this is only allowed for the function case.
7603 if Present
(Arg_Result_Mechanism
) then
7604 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7607 -- Process Mechanism parameter if present. Note that this parameter
7608 -- is not analyzed, and must not be analyzed since it is semantic
7609 -- nonsense, so we get it in exactly as the parser left it.
7611 if Present
(Arg_Mechanism
) then
7619 -- A single mechanism association without a formal parameter
7620 -- name is parsed as a parenthesized expression. All other
7621 -- cases are parsed as aggregates, so we rewrite the single
7622 -- parameter case as an aggregate for consistency.
7624 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7625 and then Paren_Count
(Arg_Mechanism
) = 1
7627 Rewrite
(Arg_Mechanism
,
7628 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7629 Expressions
=> New_List
(
7630 Relocate_Node
(Arg_Mechanism
))));
7633 -- Case of only mechanism name given, applies to all formals
7635 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7636 Formal
:= First_Formal
(Ent
);
7637 while Present
(Formal
) loop
7638 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7639 Next_Formal
(Formal
);
7642 -- Case of list of mechanism associations given
7645 if Null_Record_Present
(Arg_Mechanism
) then
7647 ("inappropriate form for Mechanism parameter",
7651 -- Deal with positional ones first
7653 Formal
:= First_Formal
(Ent
);
7655 if Present
(Expressions
(Arg_Mechanism
)) then
7656 Mname
:= First
(Expressions
(Arg_Mechanism
));
7657 while Present
(Mname
) loop
7660 ("too many mechanism associations", Mname
);
7663 Set_Mechanism_Value
(Formal
, Mname
);
7664 Next_Formal
(Formal
);
7669 -- Deal with named entries
7671 if Present
(Component_Associations
(Arg_Mechanism
)) then
7672 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7673 while Present
(Massoc
) loop
7674 Choice
:= First
(Choices
(Massoc
));
7676 if Nkind
(Choice
) /= N_Identifier
7677 or else Present
(Next
(Choice
))
7680 ("incorrect form for mechanism association",
7684 Formal
:= First_Formal
(Ent
);
7688 ("parameter name & not present", Choice
);
7691 if Chars
(Choice
) = Chars
(Formal
) then
7693 (Formal
, Expression
(Massoc
));
7695 -- Set entity on identifier (needed by ASIS)
7697 Set_Entity
(Choice
, Formal
);
7702 Next_Formal
(Formal
);
7711 end Process_Extended_Import_Export_Subprogram_Pragma
;
7713 --------------------------
7714 -- Process_Generic_List --
7715 --------------------------
7717 procedure Process_Generic_List
is
7722 Check_No_Identifiers
;
7723 Check_At_Least_N_Arguments
(1);
7725 -- Check all arguments are names of generic units or instances
7728 while Present
(Arg
) loop
7729 Exp
:= Get_Pragma_Arg
(Arg
);
7732 if not Is_Entity_Name
(Exp
)
7734 (not Is_Generic_Instance
(Entity
(Exp
))
7736 not Is_Generic_Unit
(Entity
(Exp
)))
7739 ("pragma% argument must be name of generic unit/instance",
7745 end Process_Generic_List
;
7747 ------------------------------------
7748 -- Process_Import_Predefined_Type --
7749 ------------------------------------
7751 procedure Process_Import_Predefined_Type
is
7752 Loc
: constant Source_Ptr
:= Sloc
(N
);
7754 Ftyp
: Node_Id
:= Empty
;
7760 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7763 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7764 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7768 Ftyp
:= Node
(Elmt
);
7770 if Present
(Ftyp
) then
7772 -- Don't build a derived type declaration, because predefined C
7773 -- types have no declaration anywhere, so cannot really be named.
7774 -- Instead build a full type declaration, starting with an
7775 -- appropriate type definition is built
7777 if Is_Floating_Point_Type
(Ftyp
) then
7778 Def
:= Make_Floating_Point_Definition
(Loc
,
7779 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7780 Make_Real_Range_Specification
(Loc
,
7781 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7782 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7784 -- Should never have a predefined type we cannot handle
7787 raise Program_Error
;
7790 -- Build and insert a Full_Type_Declaration, which will be
7791 -- analyzed as soon as this list entry has been analyzed.
7793 Decl
:= Make_Full_Type_Declaration
(Loc
,
7794 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7795 Type_Definition
=> Def
);
7797 Insert_After
(N
, Decl
);
7798 Mark_Rewrite_Insertion
(Decl
);
7801 Error_Pragma_Arg
("no matching type found for pragma%",
7804 end Process_Import_Predefined_Type
;
7806 ---------------------------------
7807 -- Process_Import_Or_Interface --
7808 ---------------------------------
7810 procedure Process_Import_Or_Interface
is
7816 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7817 -- pragma Import (Entity, "external name");
7819 if Relaxed_RM_Semantics
7820 and then Arg_Count
= 2
7821 and then Prag_Id
= Pragma_Import
7822 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7825 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7828 if not Is_Entity_Name
(Def_Id
) then
7829 Error_Pragma_Arg
("entity name required", Arg1
);
7832 Def_Id
:= Entity
(Def_Id
);
7833 Kill_Size_Check_Code
(Def_Id
);
7834 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7837 Process_Convention
(C
, Def_Id
);
7839 -- A pragma that applies to a Ghost entity becomes Ghost for the
7840 -- purposes of legality checks and removal of ignored Ghost code.
7842 Mark_Pragma_As_Ghost
(N
, Def_Id
);
7843 Kill_Size_Check_Code
(Def_Id
);
7844 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7847 -- Various error checks
7849 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7851 -- We do not permit Import to apply to a renaming declaration
7853 if Present
(Renamed_Object
(Def_Id
)) then
7855 ("pragma% not allowed for object renaming", Arg2
);
7857 -- User initialization is not allowed for imported object, but
7858 -- the object declaration may contain a default initialization,
7859 -- that will be discarded. Note that an explicit initialization
7860 -- only counts if it comes from source, otherwise it is simply
7861 -- the code generator making an implicit initialization explicit.
7863 elsif Present
(Expression
(Parent
(Def_Id
)))
7864 and then Comes_From_Source
7865 (Original_Node
(Expression
(Parent
(Def_Id
))))
7867 -- Set imported flag to prevent cascaded errors
7869 Set_Is_Imported
(Def_Id
);
7871 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7873 ("no initialization allowed for declaration of& #",
7874 "\imported entities cannot be initialized (RM B.1(24))",
7878 -- If the pragma comes from an aspect specification the
7879 -- Is_Imported flag has already been set.
7881 if not From_Aspect_Specification
(N
) then
7882 Set_Imported
(Def_Id
);
7885 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7887 -- Note that we do not set Is_Public here. That's because we
7888 -- only want to set it if there is no address clause, and we
7889 -- don't know that yet, so we delay that processing till
7892 -- pragma Import completes deferred constants
7894 if Ekind
(Def_Id
) = E_Constant
then
7895 Set_Has_Completion
(Def_Id
);
7898 -- It is not possible to import a constant of an unconstrained
7899 -- array type (e.g. string) because there is no simple way to
7900 -- write a meaningful subtype for it.
7902 if Is_Array_Type
(Etype
(Def_Id
))
7903 and then not Is_Constrained
(Etype
(Def_Id
))
7906 ("imported constant& must have a constrained subtype",
7911 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7913 -- If the name is overloaded, pragma applies to all of the denoted
7914 -- entities in the same declarative part, unless the pragma comes
7915 -- from an aspect specification or was generated by the compiler
7916 -- (such as for pragma Provide_Shift_Operators).
7919 while Present
(Hom_Id
) loop
7921 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7923 -- Ignore inherited subprograms because the pragma will apply
7924 -- to the parent operation, which is the one called.
7926 if Is_Overloadable
(Def_Id
)
7927 and then Present
(Alias
(Def_Id
))
7931 -- If it is not a subprogram, it must be in an outer scope and
7932 -- pragma does not apply.
7934 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7937 -- The pragma does not apply to primitives of interfaces
7939 elsif Is_Dispatching_Operation
(Def_Id
)
7940 and then Present
(Find_Dispatching_Type
(Def_Id
))
7941 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
7945 -- Verify that the homonym is in the same declarative part (not
7946 -- just the same scope). If the pragma comes from an aspect
7947 -- specification we know that it is part of the declaration.
7949 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
7950 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
7951 and then not From_Aspect_Specification
(N
)
7956 -- If the pragma comes from an aspect specification the
7957 -- Is_Imported flag has already been set.
7959 if not From_Aspect_Specification
(N
) then
7960 Set_Imported
(Def_Id
);
7963 -- Reject an Import applied to an abstract subprogram
7965 if Is_Subprogram
(Def_Id
)
7966 and then Is_Abstract_Subprogram
(Def_Id
)
7968 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7970 ("cannot import abstract subprogram& declared#",
7974 -- Special processing for Convention_Intrinsic
7976 if C
= Convention_Intrinsic
then
7978 -- Link_Name argument not allowed for intrinsic
7982 Set_Is_Intrinsic_Subprogram
(Def_Id
);
7984 -- If no external name is present, then check that this
7985 -- is a valid intrinsic subprogram. If an external name
7986 -- is present, then this is handled by the back end.
7989 Check_Intrinsic_Subprogram
7990 (Def_Id
, Get_Pragma_Arg
(Arg2
));
7994 -- Verify that the subprogram does not have a completion
7995 -- through a renaming declaration. For other completions the
7996 -- pragma appears as a too late representation.
7999 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
8003 and then Nkind
(Decl
) = N_Subprogram_Declaration
8004 and then Present
(Corresponding_Body
(Decl
))
8005 and then Nkind
(Unit_Declaration_Node
8006 (Corresponding_Body
(Decl
))) =
8007 N_Subprogram_Renaming_Declaration
8009 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8011 ("cannot import&, renaming already provided for "
8012 & "declaration #", N
, Def_Id
);
8016 -- If the pragma comes from an aspect specification, there
8017 -- must be an Import aspect specified as well. In the rare
8018 -- case where Import is set to False, the suprogram needs to
8019 -- have a local completion.
8022 Imp_Aspect
: constant Node_Id
:=
8023 Find_Aspect
(Def_Id
, Aspect_Import
);
8027 if Present
(Imp_Aspect
)
8028 and then Present
(Expression
(Imp_Aspect
))
8030 Expr
:= Expression
(Imp_Aspect
);
8031 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
8033 if Is_Entity_Name
(Expr
)
8034 and then Entity
(Expr
) = Standard_True
8036 Set_Has_Completion
(Def_Id
);
8039 -- If there is no expression, the default is True, as for
8040 -- all boolean aspects. Same for the older pragma.
8043 Set_Has_Completion
(Def_Id
);
8047 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8050 if Is_Compilation_Unit
(Hom_Id
) then
8052 -- Its possible homonyms are not affected by the pragma.
8053 -- Such homonyms might be present in the context of other
8054 -- units being compiled.
8058 elsif From_Aspect_Specification
(N
) then
8061 -- If the pragma was created by the compiler, then we don't
8062 -- want it to apply to other homonyms. This kind of case can
8063 -- occur when using pragma Provide_Shift_Operators, which
8064 -- generates implicit shift and rotate operators with Import
8065 -- pragmas that might apply to earlier explicit or implicit
8066 -- declarations marked with Import (for example, coming from
8067 -- an earlier pragma Provide_Shift_Operators for another type),
8068 -- and we don't generally want other homonyms being treated
8069 -- as imported or the pragma flagged as an illegal duplicate.
8071 elsif not Comes_From_Source
(N
) then
8075 Hom_Id
:= Homonym
(Hom_Id
);
8079 -- Import a CPP class
8081 elsif C
= Convention_CPP
8082 and then (Is_Record_Type
(Def_Id
)
8083 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8085 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8086 if Present
(Full_View
(Def_Id
)) then
8087 Def_Id
:= Full_View
(Def_Id
);
8091 ("cannot import 'C'P'P type before full declaration seen",
8092 Get_Pragma_Arg
(Arg2
));
8094 -- Although we have reported the error we decorate it as
8095 -- CPP_Class to avoid reporting spurious errors
8097 Set_Is_CPP_Class
(Def_Id
);
8102 -- Types treated as CPP classes must be declared limited (note:
8103 -- this used to be a warning but there is no real benefit to it
8104 -- since we did effectively intend to treat the type as limited
8107 if not Is_Limited_Type
(Def_Id
) then
8109 ("imported 'C'P'P type must be limited",
8110 Get_Pragma_Arg
(Arg2
));
8113 if Etype
(Def_Id
) /= Def_Id
8114 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8116 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8119 Set_Is_CPP_Class
(Def_Id
);
8121 -- Imported CPP types must not have discriminants (because C++
8122 -- classes do not have discriminants).
8124 if Has_Discriminants
(Def_Id
) then
8126 ("imported 'C'P'P type cannot have discriminants",
8127 First
(Discriminant_Specifications
8128 (Declaration_Node
(Def_Id
))));
8131 -- Check that components of imported CPP types do not have default
8132 -- expressions. For private types this check is performed when the
8133 -- full view is analyzed (see Process_Full_View).
8135 if not Is_Private_Type
(Def_Id
) then
8136 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8139 -- Import a CPP exception
8141 elsif C
= Convention_CPP
8142 and then Ekind
(Def_Id
) = E_Exception
8146 ("'External_'Name arguments is required for 'Cpp exception",
8149 -- As only a string is allowed, Check_Arg_Is_External_Name
8152 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8155 if Present
(Arg4
) then
8157 ("Link_Name argument not allowed for imported Cpp exception",
8161 -- Do not call Set_Interface_Name as the name of the exception
8162 -- shouldn't be modified (and in particular it shouldn't be
8163 -- the External_Name). For exceptions, the External_Name is the
8164 -- name of the RTTI structure.
8166 -- ??? Emit an error if pragma Import/Export_Exception is present
8168 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8170 Check_Arg_Count
(3);
8171 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8173 Process_Import_Predefined_Type
;
8177 ("second argument of pragma% must be object, subprogram "
8178 & "or incomplete type",
8182 -- If this pragma applies to a compilation unit, then the unit, which
8183 -- is a subprogram, does not require (or allow) a body. We also do
8184 -- not need to elaborate imported procedures.
8186 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8188 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8190 Set_Body_Required
(Cunit
, False);
8193 end Process_Import_Or_Interface
;
8195 --------------------
8196 -- Process_Inline --
8197 --------------------
8199 procedure Process_Inline
(Status
: Inline_Status
) is
8206 Ghost_Error_Posted
: Boolean := False;
8207 -- Flag set when an error concerning the illegal mix of Ghost and
8208 -- non-Ghost subprograms is emitted.
8210 Ghost_Id
: Entity_Id
:= Empty
;
8211 -- The entity of the first Ghost subprogram encountered while
8212 -- processing the arguments of the pragma.
8214 procedure Make_Inline
(Subp
: Entity_Id
);
8215 -- Subp is the defining unit name of the subprogram declaration. Set
8216 -- the flag, as well as the flag in the corresponding body, if there
8219 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8220 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8221 -- Has_Pragma_Inline_Always for the Inline_Always case.
8223 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8224 -- Returns True if it can be determined at this stage that inlining
8225 -- is not possible, for example if the body is available and contains
8226 -- exception handlers, we prevent inlining, since otherwise we can
8227 -- get undefined symbols at link time. This function also emits a
8228 -- warning if front-end inlining is enabled and the pragma appears
8231 -- ??? is business with link symbols still valid, or does it relate
8232 -- to front end ZCX which is being phased out ???
8234 ---------------------------
8235 -- Inlining_Not_Possible --
8236 ---------------------------
8238 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8239 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8243 if Nkind
(Decl
) = N_Subprogram_Body
then
8244 Stats
:= Handled_Statement_Sequence
(Decl
);
8245 return Present
(Exception_Handlers
(Stats
))
8246 or else Present
(At_End_Proc
(Stats
));
8248 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8249 and then Present
(Corresponding_Body
(Decl
))
8251 if Front_End_Inlining
8252 and then Analyzed
(Corresponding_Body
(Decl
))
8254 Error_Msg_N
("pragma appears too late, ignored??", N
);
8257 -- If the subprogram is a renaming as body, the body is just a
8258 -- call to the renamed subprogram, and inlining is trivially
8262 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8263 N_Subprogram_Renaming_Declaration
8269 Handled_Statement_Sequence
8270 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8273 Present
(Exception_Handlers
(Stats
))
8274 or else Present
(At_End_Proc
(Stats
));
8278 -- If body is not available, assume the best, the check is
8279 -- performed again when compiling enclosing package bodies.
8283 end Inlining_Not_Possible
;
8289 procedure Make_Inline
(Subp
: Entity_Id
) is
8290 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8291 Inner_Subp
: Entity_Id
:= Subp
;
8294 -- Ignore if bad type, avoid cascaded error
8296 if Etype
(Subp
) = Any_Type
then
8300 -- If inlining is not possible, for now do not treat as an error
8302 elsif Status
/= Suppressed
8303 and then Inlining_Not_Possible
(Subp
)
8308 -- Here we have a candidate for inlining, but we must exclude
8309 -- derived operations. Otherwise we would end up trying to inline
8310 -- a phantom declaration, and the result would be to drag in a
8311 -- body which has no direct inlining associated with it. That
8312 -- would not only be inefficient but would also result in the
8313 -- backend doing cross-unit inlining in cases where it was
8314 -- definitely inappropriate to do so.
8316 -- However, a simple Comes_From_Source test is insufficient, since
8317 -- we do want to allow inlining of generic instances which also do
8318 -- not come from source. We also need to recognize specs generated
8319 -- by the front-end for bodies that carry the pragma. Finally,
8320 -- predefined operators do not come from source but are not
8321 -- inlineable either.
8323 elsif Is_Generic_Instance
(Subp
)
8324 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8328 elsif not Comes_From_Source
(Subp
)
8329 and then Scope
(Subp
) /= Standard_Standard
8335 -- The referenced entity must either be the enclosing entity, or
8336 -- an entity declared within the current open scope.
8338 if Present
(Scope
(Subp
))
8339 and then Scope
(Subp
) /= Current_Scope
8340 and then Subp
/= Current_Scope
8343 ("argument of% must be entity in current scope", Assoc
);
8347 -- Processing for procedure, operator or function. If subprogram
8348 -- is aliased (as for an instance) indicate that the renamed
8349 -- entity (if declared in the same unit) is inlined.
8351 if Is_Subprogram
(Subp
) then
8352 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8354 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8355 Set_Inline_Flags
(Inner_Subp
);
8357 Decl
:= Parent
(Parent
(Inner_Subp
));
8359 if Nkind
(Decl
) = N_Subprogram_Declaration
8360 and then Present
(Corresponding_Body
(Decl
))
8362 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8364 elsif Is_Generic_Instance
(Subp
) then
8366 -- Indicate that the body needs to be created for
8367 -- inlining subsequent calls. The instantiation node
8368 -- follows the declaration of the wrapper package
8371 if Scope
(Subp
) /= Standard_Standard
8373 Need_Subprogram_Instance_Body
8374 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8380 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8381 -- appear in a formal part to apply to a formal subprogram.
8382 -- Do not apply check within an instance or a formal package
8383 -- the test will have been applied to the original generic.
8385 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8386 and then List_Containing
(Decl
) = List_Containing
(N
)
8387 and then not In_Instance
8390 ("Inline cannot apply to a formal subprogram", N
);
8392 -- If Subp is a renaming, it is the renamed entity that
8393 -- will appear in any call, and be inlined. However, for
8394 -- ASIS uses it is convenient to indicate that the renaming
8395 -- itself is an inlined subprogram, so that some gnatcheck
8396 -- rules can be applied in the absence of expansion.
8398 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8399 Set_Inline_Flags
(Subp
);
8405 -- For a generic subprogram set flag as well, for use at the point
8406 -- of instantiation, to determine whether the body should be
8409 elsif Is_Generic_Subprogram
(Subp
) then
8410 Set_Inline_Flags
(Subp
);
8413 -- Literals are by definition inlined
8415 elsif Kind
= E_Enumeration_Literal
then
8418 -- Anything else is an error
8422 ("expect subprogram name for pragma%", Assoc
);
8426 ----------------------
8427 -- Set_Inline_Flags --
8428 ----------------------
8430 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8432 -- First set the Has_Pragma_XXX flags and issue the appropriate
8433 -- errors and warnings for suspicious combinations.
8435 if Prag_Id
= Pragma_No_Inline
then
8436 if Has_Pragma_Inline_Always
(Subp
) then
8438 ("Inline_Always and No_Inline are mutually exclusive", N
);
8439 elsif Has_Pragma_Inline
(Subp
) then
8441 ("Inline and No_Inline both specified for& ??",
8442 N
, Entity
(Subp_Id
));
8445 Set_Has_Pragma_No_Inline
(Subp
);
8447 if Prag_Id
= Pragma_Inline_Always
then
8448 if Has_Pragma_No_Inline
(Subp
) then
8450 ("Inline_Always and No_Inline are mutually exclusive",
8454 Set_Has_Pragma_Inline_Always
(Subp
);
8456 if Has_Pragma_No_Inline
(Subp
) then
8458 ("Inline and No_Inline both specified for& ??",
8459 N
, Entity
(Subp_Id
));
8463 if not Has_Pragma_Inline
(Subp
) then
8464 Set_Has_Pragma_Inline
(Subp
);
8468 -- Then adjust the Is_Inlined flag. It can never be set if the
8469 -- subprogram is subject to pragma No_Inline.
8473 Set_Is_Inlined
(Subp
, False);
8477 if not Has_Pragma_No_Inline
(Subp
) then
8478 Set_Is_Inlined
(Subp
, True);
8482 -- A pragma that applies to a Ghost entity becomes Ghost for the
8483 -- purposes of legality checks and removal of ignored Ghost code.
8485 Mark_Pragma_As_Ghost
(N
, Subp
);
8487 -- Capture the entity of the first Ghost subprogram being
8488 -- processed for error detection purposes.
8490 if Is_Ghost_Entity
(Subp
) then
8491 if No
(Ghost_Id
) then
8495 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
8496 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
8498 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
8499 Ghost_Error_Posted
:= True;
8501 Error_Msg_Name_1
:= Pname
;
8503 ("pragma % cannot mention ghost and non-ghost subprograms",
8506 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
8507 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
8509 Error_Msg_Sloc
:= Sloc
(Subp
);
8510 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
8512 end Set_Inline_Flags
;
8514 -- Start of processing for Process_Inline
8517 Check_No_Identifiers
;
8518 Check_At_Least_N_Arguments
(1);
8520 if Status
= Enabled
then
8521 Inline_Processing_Required
:= True;
8525 while Present
(Assoc
) loop
8526 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8530 if Is_Entity_Name
(Subp_Id
) then
8531 Subp
:= Entity
(Subp_Id
);
8533 if Subp
= Any_Id
then
8535 -- If previous error, avoid cascaded errors
8537 Check_Error_Detected
;
8543 -- For the pragma case, climb homonym chain. This is
8544 -- what implements allowing the pragma in the renaming
8545 -- case, with the result applying to the ancestors, and
8546 -- also allows Inline to apply to all previous homonyms.
8548 if not From_Aspect_Specification
(N
) then
8549 while Present
(Homonym
(Subp
))
8550 and then Scope
(Homonym
(Subp
)) = Current_Scope
8552 Make_Inline
(Homonym
(Subp
));
8553 Subp
:= Homonym
(Subp
);
8560 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
8567 ----------------------------
8568 -- Process_Interface_Name --
8569 ----------------------------
8571 procedure Process_Interface_Name
8572 (Subprogram_Def
: Entity_Id
;
8578 String_Val
: String_Id
;
8580 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
8581 -- SN is a string literal node for an interface name. This routine
8582 -- performs some minimal checks that the name is reasonable. In
8583 -- particular that no spaces or other obviously incorrect characters
8584 -- appear. This is only a warning, since any characters are allowed.
8586 ----------------------------------
8587 -- Check_Form_Of_Interface_Name --
8588 ----------------------------------
8590 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
8591 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8592 SL
: constant Nat
:= String_Length
(S
);
8597 Error_Msg_N
("interface name cannot be null string", SN
);
8600 for J
in 1 .. SL
loop
8601 C
:= Get_String_Char
(S
, J
);
8603 -- Look for dubious character and issue unconditional warning.
8604 -- Definitely dubious if not in character range.
8606 if not In_Character_Range
(C
)
8608 -- Commas, spaces and (back)slashes are dubious
8610 or else Get_Character
(C
) = ','
8611 or else Get_Character
(C
) = '\'
8612 or else Get_Character
(C
) = ' '
8613 or else Get_Character
(C
) = '/'
8616 ("??interface name contains illegal character",
8617 Sloc
(SN
) + Source_Ptr
(J
));
8620 end Check_Form_Of_Interface_Name
;
8622 -- Start of processing for Process_Interface_Name
8625 if No
(Link_Arg
) then
8626 if No
(Ext_Arg
) then
8629 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8631 Link_Nam
:= Expression
(Ext_Arg
);
8634 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8635 Ext_Nam
:= Expression
(Ext_Arg
);
8640 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8641 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8642 Ext_Nam
:= Expression
(Ext_Arg
);
8643 Link_Nam
:= Expression
(Link_Arg
);
8646 -- Check expressions for external name and link name are static
8648 if Present
(Ext_Nam
) then
8649 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8650 Check_Form_Of_Interface_Name
(Ext_Nam
);
8652 -- Verify that external name is not the name of a local entity,
8653 -- which would hide the imported one and could lead to run-time
8654 -- surprises. The problem can only arise for entities declared in
8655 -- a package body (otherwise the external name is fully qualified
8656 -- and will not conflict).
8664 if Prag_Id
= Pragma_Import
then
8665 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8667 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
8669 if Nam
/= Chars
(Subprogram_Def
)
8670 and then Present
(E
)
8671 and then not Is_Overloadable
(E
)
8672 and then Is_Immediately_Visible
(E
)
8673 and then not Is_Imported
(E
)
8674 and then Ekind
(Scope
(E
)) = E_Package
8677 while Present
(Par
) loop
8678 if Nkind
(Par
) = N_Package_Body
then
8679 Error_Msg_Sloc
:= Sloc
(E
);
8681 ("imported entity is hidden by & declared#",
8686 Par
:= Parent
(Par
);
8693 if Present
(Link_Nam
) then
8694 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8695 Check_Form_Of_Interface_Name
(Link_Nam
);
8698 -- If there is no link name, just set the external name
8700 if No
(Link_Nam
) then
8701 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8703 -- For the Link_Name case, the given literal is preceded by an
8704 -- asterisk, which indicates to GCC that the given name should be
8705 -- taken literally, and in particular that no prepending of
8706 -- underlines should occur, even in systems where this is the
8711 Store_String_Char
(Get_Char_Code
('*'));
8712 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8713 Store_String_Chars
(String_Val
);
8715 Make_String_Literal
(Sloc
(Link_Nam
),
8716 Strval
=> End_String
);
8719 -- Set the interface name. If the entity is a generic instance, use
8720 -- its alias, which is the callable entity.
8722 if Is_Generic_Instance
(Subprogram_Def
) then
8723 Set_Encoded_Interface_Name
8724 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8726 Set_Encoded_Interface_Name
8727 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8730 Check_Duplicated_Export_Name
(Link_Nam
);
8731 end Process_Interface_Name
;
8733 -----------------------------------------
8734 -- Process_Interrupt_Or_Attach_Handler --
8735 -----------------------------------------
8737 procedure Process_Interrupt_Or_Attach_Handler
is
8738 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8739 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8740 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8743 -- A pragma that applies to a Ghost entity becomes Ghost for the
8744 -- purposes of legality checks and removal of ignored Ghost code.
8746 Mark_Pragma_As_Ghost
(N
, Handler_Proc
);
8747 Set_Is_Interrupt_Handler
(Handler_Proc
);
8749 -- If the pragma is not associated with a handler procedure within a
8750 -- protected type, then it must be for a nonprotected procedure for
8751 -- the AAMP target, in which case we don't associate a representation
8752 -- item with the procedure's scope.
8754 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8755 if Prag_Id
= Pragma_Interrupt_Handler
8757 Prag_Id
= Pragma_Attach_Handler
8759 Record_Rep_Item
(Proc_Scope
, N
);
8762 end Process_Interrupt_Or_Attach_Handler
;
8764 --------------------------------------------------
8765 -- Process_Restrictions_Or_Restriction_Warnings --
8766 --------------------------------------------------
8768 -- Note: some of the simple identifier cases were handled in par-prag,
8769 -- but it is harmless (and more straightforward) to simply handle all
8770 -- cases here, even if it means we repeat a bit of work in some cases.
8772 procedure Process_Restrictions_Or_Restriction_Warnings
8776 R_Id
: Restriction_Id
;
8782 -- Ignore all Restrictions pragmas in CodePeer mode
8784 if CodePeer_Mode
then
8788 Check_Ada_83_Warning
;
8789 Check_At_Least_N_Arguments
(1);
8790 Check_Valid_Configuration_Pragma
;
8793 while Present
(Arg
) loop
8795 Expr
:= Get_Pragma_Arg
(Arg
);
8797 -- Case of no restriction identifier present
8799 if Id
= No_Name
then
8800 if Nkind
(Expr
) /= N_Identifier
then
8802 ("invalid form for restriction", Arg
);
8807 (Process_Restriction_Synonyms
(Expr
));
8809 if R_Id
not in All_Boolean_Restrictions
then
8810 Error_Msg_Name_1
:= Pname
;
8812 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8814 -- Check for possible misspelling
8816 for J
in Restriction_Id
loop
8818 Rnm
: constant String := Restriction_Id
'Image (J
);
8821 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8822 Name_Len
:= Rnm
'Length;
8823 Set_Casing
(All_Lower_Case
);
8825 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8827 (Identifier_Casing
(Current_Source_File
));
8828 Error_Msg_String
(1 .. Rnm
'Length) :=
8829 Name_Buffer
(1 .. Name_Len
);
8830 Error_Msg_Strlen
:= Rnm
'Length;
8831 Error_Msg_N
-- CODEFIX
8832 ("\possible misspelling of ""~""",
8833 Get_Pragma_Arg
(Arg
));
8842 if Implementation_Restriction
(R_Id
) then
8843 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8846 -- Special processing for No_Elaboration_Code restriction
8848 if R_Id
= No_Elaboration_Code
then
8850 -- Restriction is only recognized within a configuration
8851 -- pragma file, or within a unit of the main extended
8852 -- program. Note: the test for Main_Unit is needed to
8853 -- properly include the case of configuration pragma files.
8855 if not (Current_Sem_Unit
= Main_Unit
8856 or else In_Extended_Main_Source_Unit
(N
))
8860 -- Don't allow in a subunit unless already specified in
8863 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8864 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8865 and then not Restriction_Active
(No_Elaboration_Code
)
8868 ("invalid specification of ""No_Elaboration_Code""",
8871 ("\restriction cannot be specified in a subunit", N
);
8873 ("\unless also specified in body or spec", N
);
8876 -- If we accept a No_Elaboration_Code restriction, then it
8877 -- needs to be added to the configuration restriction set so
8878 -- that we get proper application to other units in the main
8879 -- extended source as required.
8882 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8886 -- If this is a warning, then set the warning unless we already
8887 -- have a real restriction active (we never want a warning to
8888 -- override a real restriction).
8891 if not Restriction_Active
(R_Id
) then
8892 Set_Restriction
(R_Id
, N
);
8893 Restriction_Warnings
(R_Id
) := True;
8896 -- If real restriction case, then set it and make sure that the
8897 -- restriction warning flag is off, since a real restriction
8898 -- always overrides a warning.
8901 Set_Restriction
(R_Id
, N
);
8902 Restriction_Warnings
(R_Id
) := False;
8905 -- Check for obsolescent restrictions in Ada 2005 mode
8908 and then Ada_Version
>= Ada_2005
8909 and then (R_Id
= No_Asynchronous_Control
8911 R_Id
= No_Unchecked_Deallocation
8913 R_Id
= No_Unchecked_Conversion
)
8915 Check_Restriction
(No_Obsolescent_Features
, N
);
8918 -- A very special case that must be processed here: pragma
8919 -- Restrictions (No_Exceptions) turns off all run-time
8920 -- checking. This is a bit dubious in terms of the formal
8921 -- language definition, but it is what is intended by RM
8922 -- H.4(12). Restriction_Warnings never affects generated code
8923 -- so this is done only in the real restriction case.
8925 -- Atomic_Synchronization is not a real check, so it is not
8926 -- affected by this processing).
8928 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8929 -- run-time checks in CodePeer and GNATprove modes: we want to
8930 -- generate checks for analysis purposes, as set respectively
8931 -- by -gnatC and -gnatd.F
8934 and then not (CodePeer_Mode
or GNATprove_Mode
)
8935 and then R_Id
= No_Exceptions
8937 for J
in Scope_Suppress
.Suppress
'Range loop
8938 if J
/= Atomic_Synchronization
then
8939 Scope_Suppress
.Suppress
(J
) := True;
8944 -- Case of No_Dependence => unit-name. Note that the parser
8945 -- already made the necessary entry in the No_Dependence table.
8947 elsif Id
= Name_No_Dependence
then
8948 if not OK_No_Dependence_Unit_Name
(Expr
) then
8952 -- Case of No_Specification_Of_Aspect => aspect-identifier
8954 elsif Id
= Name_No_Specification_Of_Aspect
then
8959 if Nkind
(Expr
) /= N_Identifier
then
8962 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
8965 if A_Id
= No_Aspect
then
8966 Error_Pragma_Arg
("invalid restriction name", Arg
);
8968 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
8972 -- Case of No_Use_Of_Attribute => attribute-identifier
8974 elsif Id
= Name_No_Use_Of_Attribute
then
8975 if Nkind
(Expr
) /= N_Identifier
8976 or else not Is_Attribute_Name
(Chars
(Expr
))
8978 Error_Msg_N
("unknown attribute name??", Expr
);
8981 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
8984 -- Case of No_Use_Of_Entity => fully-qualified-name
8986 elsif Id
= Name_No_Use_Of_Entity
then
8988 -- Restriction is only recognized within a configuration
8989 -- pragma file, or within a unit of the main extended
8990 -- program. Note: the test for Main_Unit is needed to
8991 -- properly include the case of configuration pragma files.
8993 if Current_Sem_Unit
= Main_Unit
8994 or else In_Extended_Main_Source_Unit
(N
)
8996 if not OK_No_Dependence_Unit_Name
(Expr
) then
8997 Error_Msg_N
("wrong form for entity name", Expr
);
8999 Set_Restriction_No_Use_Of_Entity
9000 (Expr
, Warn
, No_Profile
);
9004 -- Case of No_Use_Of_Pragma => pragma-identifier
9006 elsif Id
= Name_No_Use_Of_Pragma
then
9007 if Nkind
(Expr
) /= N_Identifier
9008 or else not Is_Pragma_Name
(Chars
(Expr
))
9010 Error_Msg_N
("unknown pragma name??", Expr
);
9012 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
9015 -- All other cases of restriction identifier present
9018 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
9019 Analyze_And_Resolve
(Expr
, Any_Integer
);
9021 if R_Id
not in All_Parameter_Restrictions
then
9023 ("invalid restriction parameter identifier", Arg
);
9025 elsif not Is_OK_Static_Expression
(Expr
) then
9026 Flag_Non_Static_Expr
9027 ("value must be static expression!", Expr
);
9030 elsif not Is_Integer_Type
(Etype
(Expr
))
9031 or else Expr_Value
(Expr
) < 0
9034 ("value must be non-negative integer", Arg
);
9037 -- Restriction pragma is active
9039 Val
:= Expr_Value
(Expr
);
9041 if not UI_Is_In_Int_Range
(Val
) then
9043 ("pragma ignored, value too large??", Arg
);
9046 -- Warning case. If the real restriction is active, then we
9047 -- ignore the request, since warning never overrides a real
9048 -- restriction. Otherwise we set the proper warning. Note that
9049 -- this circuit sets the warning again if it is already set,
9050 -- which is what we want, since the constant may have changed.
9053 if not Restriction_Active
(R_Id
) then
9055 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
9056 Restriction_Warnings
(R_Id
) := True;
9059 -- Real restriction case, set restriction and make sure warning
9060 -- flag is off since real restriction always overrides warning.
9063 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
9064 Restriction_Warnings
(R_Id
) := False;
9070 end Process_Restrictions_Or_Restriction_Warnings
;
9072 ---------------------------------
9073 -- Process_Suppress_Unsuppress --
9074 ---------------------------------
9076 -- Note: this procedure makes entries in the check suppress data
9077 -- structures managed by Sem. See spec of package Sem for full
9078 -- details on how we handle recording of check suppression.
9080 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9085 In_Package_Spec
: constant Boolean :=
9086 Is_Package_Or_Generic_Package
(Current_Scope
)
9087 and then not In_Package_Body
(Current_Scope
);
9089 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9090 -- Used to suppress a single check on the given entity
9092 --------------------------------
9093 -- Suppress_Unsuppress_Echeck --
9094 --------------------------------
9096 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9098 -- Check for error of trying to set atomic synchronization for
9099 -- a non-atomic variable.
9101 if C
= Atomic_Synchronization
9102 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9105 ("pragma & requires atomic type or variable",
9106 Pragma_Identifier
(Original_Node
(N
)));
9109 Set_Checks_May_Be_Suppressed
(E
);
9111 if In_Package_Spec
then
9112 Push_Global_Suppress_Stack_Entry
9115 Suppress
=> Suppress_Case
);
9117 Push_Local_Suppress_Stack_Entry
9120 Suppress
=> Suppress_Case
);
9123 -- If this is a first subtype, and the base type is distinct,
9124 -- then also set the suppress flags on the base type.
9126 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9127 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9129 end Suppress_Unsuppress_Echeck
;
9131 -- Start of processing for Process_Suppress_Unsuppress
9134 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9135 -- on user code: we want to generate checks for analysis purposes, as
9136 -- set respectively by -gnatC and -gnatd.F
9138 if Comes_From_Source
(N
)
9139 and then (CodePeer_Mode
or GNATprove_Mode
)
9144 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9145 -- declarative part or a package spec (RM 11.5(5)).
9147 if not Is_Configuration_Pragma
then
9148 Check_Is_In_Decl_Part_Or_Package_Spec
;
9151 Check_At_Least_N_Arguments
(1);
9152 Check_At_Most_N_Arguments
(2);
9153 Check_No_Identifier
(Arg1
);
9154 Check_Arg_Is_Identifier
(Arg1
);
9156 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9158 if C
= No_Check_Id
then
9160 ("argument of pragma% is not valid check name", Arg1
);
9163 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9165 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
9167 ("Suppress of Elaboration_Check ignored in SPARK??",
9168 "\elaboration checking rules are statically enforced "
9169 & "(SPARK RM 7.7)", Arg1
);
9172 -- One-argument case
9174 if Arg_Count
= 1 then
9176 -- Make an entry in the local scope suppress table. This is the
9177 -- table that directly shows the current value of the scope
9178 -- suppress check for any check id value.
9180 if C
= All_Checks
then
9182 -- For All_Checks, we set all specific predefined checks with
9183 -- the exception of Elaboration_Check, which is handled
9184 -- specially because of not wanting All_Checks to have the
9185 -- effect of deactivating static elaboration order processing.
9186 -- Atomic_Synchronization is also not affected, since this is
9187 -- not a real check.
9189 for J
in Scope_Suppress
.Suppress
'Range loop
9190 if J
/= Elaboration_Check
9192 J
/= Atomic_Synchronization
9194 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9198 -- If not All_Checks, and predefined check, then set appropriate
9199 -- scope entry. Note that we will set Elaboration_Check if this
9200 -- is explicitly specified. Atomic_Synchronization is allowed
9201 -- only if internally generated and entity is atomic.
9203 elsif C
in Predefined_Check_Id
9204 and then (not Comes_From_Source
(N
)
9205 or else C
/= Atomic_Synchronization
)
9207 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9210 -- Also make an entry in the Local_Entity_Suppress table
9212 Push_Local_Suppress_Stack_Entry
9215 Suppress
=> Suppress_Case
);
9217 -- Case of two arguments present, where the check is suppressed for
9218 -- a specified entity (given as the second argument of the pragma)
9221 -- This is obsolescent in Ada 2005 mode
9223 if Ada_Version
>= Ada_2005
then
9224 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9227 Check_Optional_Identifier
(Arg2
, Name_On
);
9228 E_Id
:= Get_Pragma_Arg
(Arg2
);
9231 if not Is_Entity_Name
(E_Id
) then
9233 ("second argument of pragma% must be entity name", Arg2
);
9242 -- A pragma that applies to a Ghost entity becomes Ghost for the
9243 -- purposes of legality checks and removal of ignored Ghost code.
9245 Mark_Pragma_As_Ghost
(N
, E
);
9247 -- Enforce RM 11.5(7) which requires that for a pragma that
9248 -- appears within a package spec, the named entity must be
9249 -- within the package spec. We allow the package name itself
9250 -- to be mentioned since that makes sense, although it is not
9251 -- strictly allowed by 11.5(7).
9254 and then E
/= Current_Scope
9255 and then Scope
(E
) /= Current_Scope
9258 ("entity in pragma% is not in package spec (RM 11.5(7))",
9262 -- Loop through homonyms. As noted below, in the case of a package
9263 -- spec, only homonyms within the package spec are considered.
9266 Suppress_Unsuppress_Echeck
(E
, C
);
9268 if Is_Generic_Instance
(E
)
9269 and then Is_Subprogram
(E
)
9270 and then Present
(Alias
(E
))
9272 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9275 -- Move to next homonym if not aspect spec case
9277 exit when From_Aspect_Specification
(N
);
9281 -- If we are within a package specification, the pragma only
9282 -- applies to homonyms in the same scope.
9284 exit when In_Package_Spec
9285 and then Scope
(E
) /= Current_Scope
;
9288 end Process_Suppress_Unsuppress
;
9290 -------------------------------
9291 -- Record_Independence_Check --
9292 -------------------------------
9294 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
9296 -- For GCC back ends the validation is done a priori
9298 if not AAMP_On_Target
then
9302 Independence_Checks
.Append
((N
, E
));
9303 end Record_Independence_Check
;
9309 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9311 if Is_Imported
(E
) then
9313 ("cannot export entity& that was previously imported", Arg
);
9315 elsif Present
(Address_Clause
(E
))
9316 and then not Relaxed_RM_Semantics
9319 ("cannot export entity& that has an address clause", Arg
);
9322 Set_Is_Exported
(E
);
9324 -- Generate a reference for entity explicitly, because the
9325 -- identifier may be overloaded and name resolution will not
9328 Generate_Reference
(E
, Arg
);
9330 -- Deal with exporting non-library level entity
9332 if not Is_Library_Level_Entity
(E
) then
9334 -- Not allowed at all for subprograms
9336 if Is_Subprogram
(E
) then
9337 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9339 -- Otherwise set public and statically allocated
9343 Set_Is_Statically_Allocated
(E
);
9345 -- Warn if the corresponding W flag is set
9347 if Warn_On_Export_Import
9349 -- Only do this for something that was in the source. Not
9350 -- clear if this can be False now (there used for sure to be
9351 -- cases on some systems where it was False), but anyway the
9352 -- test is harmless if not needed, so it is retained.
9354 and then Comes_From_Source
(Arg
)
9357 ("?x?& has been made static as a result of Export",
9360 ("\?x?this usage is non-standard and non-portable",
9366 if Warn_On_Export_Import
and then Is_Type
(E
) then
9367 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9370 if Warn_On_Export_Import
and Inside_A_Generic
then
9372 ("all instances of& will have the same external name?x?",
9377 ----------------------------------------------
9378 -- Set_Extended_Import_Export_External_Name --
9379 ----------------------------------------------
9381 procedure Set_Extended_Import_Export_External_Name
9382 (Internal_Ent
: Entity_Id
;
9383 Arg_External
: Node_Id
)
9385 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9389 if No
(Arg_External
) then
9393 Check_Arg_Is_External_Name
(Arg_External
);
9395 if Nkind
(Arg_External
) = N_String_Literal
then
9396 if String_Length
(Strval
(Arg_External
)) = 0 then
9399 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9402 elsif Nkind
(Arg_External
) = N_Identifier
then
9403 New_Name
:= Get_Default_External_Name
(Arg_External
);
9405 -- Check_Arg_Is_External_Name should let through only identifiers and
9406 -- string literals or static string expressions (which are folded to
9407 -- string literals).
9410 raise Program_Error
;
9413 -- If we already have an external name set (by a prior normal Import
9414 -- or Export pragma), then the external names must match
9416 if Present
(Interface_Name
(Internal_Ent
)) then
9418 -- Ignore mismatching names in CodePeer mode, to support some
9419 -- old compilers which would export the same procedure under
9420 -- different names, e.g:
9422 -- pragma Export_Procedure (P, "a");
9423 -- pragma Export_Procedure (P, "b");
9425 if CodePeer_Mode
then
9429 Check_Matching_Internal_Names
: declare
9430 S1
: constant String_Id
:= Strval
(Old_Name
);
9431 S2
: constant String_Id
:= Strval
(New_Name
);
9434 pragma No_Return
(Mismatch
);
9435 -- Called if names do not match
9441 procedure Mismatch
is
9443 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9445 ("external name does not match that given #",
9449 -- Start of processing for Check_Matching_Internal_Names
9452 if String_Length
(S1
) /= String_Length
(S2
) then
9456 for J
in 1 .. String_Length
(S1
) loop
9457 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9462 end Check_Matching_Internal_Names
;
9464 -- Otherwise set the given name
9467 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9468 Check_Duplicated_Export_Name
(New_Name
);
9470 end Set_Extended_Import_Export_External_Name
;
9476 procedure Set_Imported
(E
: Entity_Id
) is
9478 -- Error message if already imported or exported
9480 if Is_Exported
(E
) or else Is_Imported
(E
) then
9482 -- Error if being set Exported twice
9484 if Is_Exported
(E
) then
9485 Error_Msg_NE
("entity& was previously exported", N
, E
);
9487 -- Ignore error in CodePeer mode where we treat all imported
9488 -- subprograms as unknown.
9490 elsif CodePeer_Mode
then
9493 -- OK if Import/Interface case
9495 elsif Import_Interface_Present
(N
) then
9498 -- Error if being set Imported twice
9501 Error_Msg_NE
("entity& was previously imported", N
, E
);
9504 Error_Msg_Name_1
:= Pname
;
9506 ("\(pragma% applies to all previous entities)", N
);
9508 Error_Msg_Sloc
:= Sloc
(E
);
9509 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9511 -- Here if not previously imported or exported, OK to import
9514 Set_Is_Imported
(E
);
9516 -- For subprogram, set Import_Pragma field
9518 if Is_Subprogram
(E
) then
9519 Set_Import_Pragma
(E
, N
);
9522 -- If the entity is an object that is not at the library level,
9523 -- then it is statically allocated. We do not worry about objects
9524 -- with address clauses in this context since they are not really
9525 -- imported in the linker sense.
9528 and then not Is_Library_Level_Entity
(E
)
9529 and then No
(Address_Clause
(E
))
9531 Set_Is_Statically_Allocated
(E
);
9538 -------------------------
9539 -- Set_Mechanism_Value --
9540 -------------------------
9542 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9543 -- analyzed, since it is semantic nonsense), so we get it in the exact
9544 -- form created by the parser.
9546 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9547 procedure Bad_Mechanism
;
9548 pragma No_Return
(Bad_Mechanism
);
9549 -- Signal bad mechanism name
9551 -------------------------
9552 -- Bad_Mechanism_Value --
9553 -------------------------
9555 procedure Bad_Mechanism
is
9557 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9560 -- Start of processing for Set_Mechanism_Value
9563 if Mechanism
(Ent
) /= Default_Mechanism
then
9565 ("mechanism for & has already been set", Mech_Name
, Ent
);
9568 -- MECHANISM_NAME ::= value | reference
9570 if Nkind
(Mech_Name
) = N_Identifier
then
9571 if Chars
(Mech_Name
) = Name_Value
then
9572 Set_Mechanism
(Ent
, By_Copy
);
9575 elsif Chars
(Mech_Name
) = Name_Reference
then
9576 Set_Mechanism
(Ent
, By_Reference
);
9579 elsif Chars
(Mech_Name
) = Name_Copy
then
9581 ("bad mechanism name, Value assumed", Mech_Name
);
9590 end Set_Mechanism_Value
;
9592 --------------------------
9593 -- Set_Rational_Profile --
9594 --------------------------
9596 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9597 -- extension to the semantics of renaming declarations.
9599 procedure Set_Rational_Profile
is
9601 Implicit_Packing
:= True;
9602 Overriding_Renamings
:= True;
9603 Use_VADS_Size
:= True;
9604 end Set_Rational_Profile
;
9606 ---------------------------
9607 -- Set_Ravenscar_Profile --
9608 ---------------------------
9610 -- The tasks to be done here are
9612 -- Set required policies
9614 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9615 -- pragma Locking_Policy (Ceiling_Locking)
9617 -- Set Detect_Blocking mode
9619 -- Set required restrictions (see System.Rident for detailed list)
9621 -- Set the No_Dependence rules
9622 -- No_Dependence => Ada.Asynchronous_Task_Control
9623 -- No_Dependence => Ada.Calendar
9624 -- No_Dependence => Ada.Execution_Time.Group_Budget
9625 -- No_Dependence => Ada.Execution_Time.Timers
9626 -- No_Dependence => Ada.Task_Attributes
9627 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9629 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9630 Prefix_Entity
: Entity_Id
;
9631 Selector_Entity
: Entity_Id
;
9632 Prefix_Node
: Node_Id
;
9636 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9638 if Task_Dispatching_Policy
/= ' '
9639 and then Task_Dispatching_Policy
/= 'F'
9641 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9642 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9644 -- Set the FIFO_Within_Priorities policy, but always preserve
9645 -- System_Location since we like the error message with the run time
9649 Task_Dispatching_Policy
:= 'F';
9651 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9652 Task_Dispatching_Policy_Sloc
:= Loc
;
9656 -- pragma Locking_Policy (Ceiling_Locking)
9658 if Locking_Policy
/= ' '
9659 and then Locking_Policy
/= 'C'
9661 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9662 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9664 -- Set the Ceiling_Locking policy, but preserve System_Location since
9665 -- we like the error message with the run time name.
9668 Locking_Policy
:= 'C';
9670 if Locking_Policy_Sloc
/= System_Location
then
9671 Locking_Policy_Sloc
:= Loc
;
9675 -- pragma Detect_Blocking
9677 Detect_Blocking
:= True;
9679 -- Set the corresponding restrictions
9681 Set_Profile_Restrictions
9682 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9684 -- Set the No_Dependence restrictions
9686 -- The following No_Dependence restrictions:
9687 -- No_Dependence => Ada.Asynchronous_Task_Control
9688 -- No_Dependence => Ada.Calendar
9689 -- No_Dependence => Ada.Task_Attributes
9690 -- are already set by previous call to Set_Profile_Restrictions.
9692 -- Set the following restrictions which were added to Ada 2005:
9693 -- No_Dependence => Ada.Execution_Time.Group_Budget
9694 -- No_Dependence => Ada.Execution_Time.Timers
9696 if Ada_Version
>= Ada_2005
then
9697 Name_Buffer
(1 .. 3) := "ada";
9700 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9702 Name_Buffer
(1 .. 14) := "execution_time";
9705 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9708 Make_Selected_Component
9710 Prefix
=> Prefix_Entity
,
9711 Selector_Name
=> Selector_Entity
);
9713 Name_Buffer
(1 .. 13) := "group_budgets";
9716 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9719 Make_Selected_Component
9721 Prefix
=> Prefix_Node
,
9722 Selector_Name
=> Selector_Entity
);
9724 Set_Restriction_No_Dependence
9726 Warn
=> Treat_Restrictions_As_Warnings
,
9727 Profile
=> Ravenscar
);
9729 Name_Buffer
(1 .. 6) := "timers";
9732 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9735 Make_Selected_Component
9737 Prefix
=> Prefix_Node
,
9738 Selector_Name
=> Selector_Entity
);
9740 Set_Restriction_No_Dependence
9742 Warn
=> Treat_Restrictions_As_Warnings
,
9743 Profile
=> Ravenscar
);
9746 -- Set the following restriction which was added to Ada 2012 (see
9748 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9750 if Ada_Version
>= Ada_2012
then
9751 Name_Buffer
(1 .. 6) := "system";
9754 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9756 Name_Buffer
(1 .. 15) := "multiprocessors";
9759 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9762 Make_Selected_Component
9764 Prefix
=> Prefix_Entity
,
9765 Selector_Name
=> Selector_Entity
);
9767 Name_Buffer
(1 .. 19) := "dispatching_domains";
9770 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9773 Make_Selected_Component
9775 Prefix
=> Prefix_Node
,
9776 Selector_Name
=> Selector_Entity
);
9778 Set_Restriction_No_Dependence
9780 Warn
=> Treat_Restrictions_As_Warnings
,
9781 Profile
=> Ravenscar
);
9783 end Set_Ravenscar_Profile
;
9785 -- Start of processing for Analyze_Pragma
9788 -- The following code is a defense against recursion. Not clear that
9789 -- this can happen legitimately, but perhaps some error situations can
9790 -- cause it, and we did see this recursion during testing.
9792 if Analyzed
(N
) then
9798 -- Deal with unrecognized pragma
9800 Pname
:= Pragma_Name
(N
);
9802 if not Is_Pragma_Name
(Pname
) then
9803 if Warn_On_Unrecognized_Pragma
then
9804 Error_Msg_Name_1
:= Pname
;
9805 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9807 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9808 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9809 Error_Msg_Name_1
:= PN
;
9810 Error_Msg_N
-- CODEFIX
9811 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9820 -- Ignore pragma if Ignore_Pragma applies
9822 if Get_Name_Table_Boolean3
(Pname
) then
9826 -- Here to start processing for recognized pragma
9828 Prag_Id
:= Get_Pragma_Id
(Pname
);
9829 Pname
:= Original_Aspect_Pragma_Name
(N
);
9831 -- Capture setting of Opt.Uneval_Old
9833 case Opt
.Uneval_Old
is
9835 Set_Uneval_Old_Accept
(N
);
9839 Set_Uneval_Old_Warn
(N
);
9841 raise Program_Error
;
9844 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9845 -- is already set, indicating that we have already checked the policy
9846 -- at the right point. This happens for example in the case of a pragma
9847 -- that is derived from an Aspect.
9849 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9852 -- For a pragma that is a rewriting of another pragma, copy the
9853 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9855 elsif Is_Rewrite_Substitution
(N
)
9856 and then Nkind
(Original_Node
(N
)) = N_Pragma
9857 and then Original_Node
(N
) /= N
9859 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
9860 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
9862 -- Otherwise query the applicable policy at this point
9865 Check_Applicable_Policy
(N
);
9867 -- If pragma is disabled, rewrite as NULL and skip analysis
9869 if Is_Disabled
(N
) then
9870 Rewrite
(N
, Make_Null_Statement
(Loc
));
9884 if Present
(Pragma_Argument_Associations
(N
)) then
9885 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
9886 Arg1
:= First
(Pragma_Argument_Associations
(N
));
9888 if Present
(Arg1
) then
9889 Arg2
:= Next
(Arg1
);
9891 if Present
(Arg2
) then
9892 Arg3
:= Next
(Arg2
);
9894 if Present
(Arg3
) then
9895 Arg4
:= Next
(Arg3
);
9901 Check_Restriction_No_Use_Of_Pragma
(N
);
9903 -- An enumeration type defines the pragmas that are supported by the
9904 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9905 -- into the corresponding enumeration value for the following case.
9913 -- pragma Abort_Defer;
9915 when Pragma_Abort_Defer
=>
9917 Check_Arg_Count
(0);
9919 -- The only required semantic processing is to check the
9920 -- placement. This pragma must appear at the start of the
9921 -- statement sequence of a handled sequence of statements.
9923 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
9924 or else N
/= First
(Statements
(Parent
(N
)))
9929 --------------------
9930 -- Abstract_State --
9931 --------------------
9933 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9935 -- ABSTRACT_STATE_LIST ::=
9937 -- | STATE_NAME_WITH_OPTIONS
9938 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9940 -- STATE_NAME_WITH_OPTIONS ::=
9942 -- | (STATE_NAME with OPTION_LIST)
9944 -- OPTION_LIST ::= OPTION {, OPTION}
9948 -- | NAME_VALUE_OPTION
9950 -- SIMPLE_OPTION ::= Ghost | Synchronous
9952 -- NAME_VALUE_OPTION ::=
9953 -- Part_Of => ABSTRACT_STATE
9954 -- | External [=> EXTERNAL_PROPERTY_LIST]
9956 -- EXTERNAL_PROPERTY_LIST ::=
9957 -- EXTERNAL_PROPERTY
9958 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9960 -- EXTERNAL_PROPERTY ::=
9961 -- Async_Readers [=> boolean_EXPRESSION]
9962 -- | Async_Writers [=> boolean_EXPRESSION]
9963 -- | Effective_Reads [=> boolean_EXPRESSION]
9964 -- | Effective_Writes [=> boolean_EXPRESSION]
9965 -- others => boolean_EXPRESSION
9967 -- STATE_NAME ::= defining_identifier
9969 -- ABSTRACT_STATE ::= name
9973 -- * Analysis - The annotation is fully analyzed immediately upon
9974 -- elaboration as it cannot forward reference entities.
9976 -- * Expansion - None.
9978 -- * Template - The annotation utilizes the generic template of the
9979 -- related package declaration.
9981 -- * Globals - The annotation cannot reference global entities.
9983 -- * Instance - The annotation is instantiated automatically when
9984 -- the related generic package is instantiated.
9986 when Pragma_Abstract_State
=> Abstract_State
: declare
9987 Missing_Parentheses
: Boolean := False;
9988 -- Flag set when a state declaration with options is not properly
9991 -- Flags used to verify the consistency of states
9993 Non_Null_Seen
: Boolean := False;
9994 Null_Seen
: Boolean := False;
9996 procedure Analyze_Abstract_State
9998 Pack_Id
: Entity_Id
);
9999 -- Verify the legality of a single state declaration. Create and
10000 -- decorate a state abstraction entity and introduce it into the
10001 -- visibility chain. Pack_Id denotes the entity or the related
10002 -- package where pragma Abstract_State appears.
10004 procedure Malformed_State_Error
(State
: Node_Id
);
10005 -- Emit an error concerning the illegal declaration of abstract
10006 -- state State. This routine diagnoses syntax errors that lead to
10007 -- a different parse tree. The error is issued regardless of the
10008 -- SPARK mode in effect.
10010 ----------------------------
10011 -- Analyze_Abstract_State --
10012 ----------------------------
10014 procedure Analyze_Abstract_State
10016 Pack_Id
: Entity_Id
)
10018 -- Flags used to verify the consistency of options
10020 AR_Seen
: Boolean := False;
10021 AW_Seen
: Boolean := False;
10022 ER_Seen
: Boolean := False;
10023 EW_Seen
: Boolean := False;
10024 External_Seen
: Boolean := False;
10025 Ghost_Seen
: Boolean := False;
10026 Others_Seen
: Boolean := False;
10027 Part_Of_Seen
: Boolean := False;
10028 Synchronous_Seen
: Boolean := False;
10030 -- Flags used to store the static value of all external states'
10033 AR_Val
: Boolean := False;
10034 AW_Val
: Boolean := False;
10035 ER_Val
: Boolean := False;
10036 EW_Val
: Boolean := False;
10038 State_Id
: Entity_Id
:= Empty
;
10039 -- The entity to be generated for the current state declaration
10041 procedure Analyze_External_Option
(Opt
: Node_Id
);
10042 -- Verify the legality of option External
10044 procedure Analyze_External_Property
10046 Expr
: Node_Id
:= Empty
);
10047 -- Verify the legailty of a single external property. Prop
10048 -- denotes the external property. Expr is the expression used
10049 -- to set the property.
10051 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
10052 -- Verify the legality of option Part_Of
10054 procedure Check_Duplicate_Option
10056 Status
: in out Boolean);
10057 -- Flag Status denotes whether a particular option has been
10058 -- seen while processing a state. This routine verifies that
10059 -- Opt is not a duplicate option and sets the flag Status
10060 -- (SPARK RM 7.1.4(1)).
10062 procedure Check_Duplicate_Property
10064 Status
: in out Boolean);
10065 -- Flag Status denotes whether a particular property has been
10066 -- seen while processing option External. This routine verifies
10067 -- that Prop is not a duplicate property and sets flag Status.
10068 -- Opt is not a duplicate property and sets the flag Status.
10069 -- (SPARK RM 7.1.4(2))
10071 procedure Create_Abstract_State
10075 Is_Null
: Boolean);
10076 -- Generate an abstract state entity with name Nam and enter it
10077 -- into visibility. Decl is the "declaration" of the state as
10078 -- it appears in pragma Abstract_State. Loc is the location of
10079 -- the related state "declaration". Flag Is_Null should be set
10080 -- when the associated Abstract_State pragma defines a null
10083 -----------------------------
10084 -- Analyze_External_Option --
10085 -----------------------------
10087 procedure Analyze_External_Option
(Opt
: Node_Id
) is
10088 Errors
: constant Nat
:= Serious_Errors_Detected
;
10090 Props
: Node_Id
:= Empty
;
10093 if Nkind
(Opt
) = N_Component_Association
then
10094 Props
:= Expression
(Opt
);
10097 -- External state with properties
10099 if Present
(Props
) then
10101 -- Multiple properties appear as an aggregate
10103 if Nkind
(Props
) = N_Aggregate
then
10105 -- Simple property form
10107 Prop
:= First
(Expressions
(Props
));
10108 while Present
(Prop
) loop
10109 Analyze_External_Property
(Prop
);
10113 -- Property with expression form
10115 Prop
:= First
(Component_Associations
(Props
));
10116 while Present
(Prop
) loop
10117 Analyze_External_Property
10118 (Prop
=> First
(Choices
(Prop
)),
10119 Expr
=> Expression
(Prop
));
10127 Analyze_External_Property
(Props
);
10130 -- An external state defined without any properties defaults
10131 -- all properties to True.
10140 -- Once all external properties have been processed, verify
10141 -- their mutual interaction. Do not perform the check when
10142 -- at least one of the properties is illegal as this will
10143 -- produce a bogus error.
10145 if Errors
= Serious_Errors_Detected
then
10146 Check_External_Properties
10147 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10149 end Analyze_External_Option
;
10151 -------------------------------
10152 -- Analyze_External_Property --
10153 -------------------------------
10155 procedure Analyze_External_Property
10157 Expr
: Node_Id
:= Empty
)
10159 Expr_Val
: Boolean;
10162 -- Check the placement of "others" (if available)
10164 if Nkind
(Prop
) = N_Others_Choice
then
10165 if Others_Seen
then
10167 ("only one others choice allowed in option External",
10170 Others_Seen
:= True;
10173 elsif Others_Seen
then
10175 ("others must be the last property in option External",
10178 -- The only remaining legal options are the four predefined
10179 -- external properties.
10181 elsif Nkind
(Prop
) = N_Identifier
10182 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10183 Name_Async_Writers
,
10184 Name_Effective_Reads
,
10185 Name_Effective_Writes
)
10189 -- Otherwise the construct is not a valid property
10192 SPARK_Msg_N
("invalid external state property", Prop
);
10196 -- Ensure that the expression of the external state property
10197 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10199 if Present
(Expr
) then
10200 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10202 if Is_OK_Static_Expression
(Expr
) then
10203 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10206 ("expression of external state property must be "
10210 -- The lack of expression defaults the property to True
10216 -- Named properties
10218 if Nkind
(Prop
) = N_Identifier
then
10219 if Chars
(Prop
) = Name_Async_Readers
then
10220 Check_Duplicate_Property
(Prop
, AR_Seen
);
10221 AR_Val
:= Expr_Val
;
10223 elsif Chars
(Prop
) = Name_Async_Writers
then
10224 Check_Duplicate_Property
(Prop
, AW_Seen
);
10225 AW_Val
:= Expr_Val
;
10227 elsif Chars
(Prop
) = Name_Effective_Reads
then
10228 Check_Duplicate_Property
(Prop
, ER_Seen
);
10229 ER_Val
:= Expr_Val
;
10232 Check_Duplicate_Property
(Prop
, EW_Seen
);
10233 EW_Val
:= Expr_Val
;
10236 -- The handling of property "others" must take into account
10237 -- all other named properties that have been encountered so
10238 -- far. Only those that have not been seen are affected by
10242 if not AR_Seen
then
10243 AR_Val
:= Expr_Val
;
10246 if not AW_Seen
then
10247 AW_Val
:= Expr_Val
;
10250 if not ER_Seen
then
10251 ER_Val
:= Expr_Val
;
10254 if not EW_Seen
then
10255 EW_Val
:= Expr_Val
;
10258 end Analyze_External_Property
;
10260 ----------------------------
10261 -- Analyze_Part_Of_Option --
10262 ----------------------------
10264 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10265 Encap
: constant Node_Id
:= Expression
(Opt
);
10266 Encap_Id
: Entity_Id
;
10270 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10273 (Indic
=> First
(Choices
(Opt
)),
10274 Item_Id
=> State_Id
,
10276 Encap_Id
=> Encap_Id
,
10279 -- The Part_Of indicator transforms the abstract state into
10280 -- a constituent of the encapsulating state or single
10281 -- concurrent type.
10284 pragma Assert
(Present
(Encap_Id
));
10286 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encap_Id
));
10287 Set_Encapsulating_State
(State_Id
, Encap_Id
);
10289 end Analyze_Part_Of_Option
;
10291 ----------------------------
10292 -- Check_Duplicate_Option --
10293 ----------------------------
10295 procedure Check_Duplicate_Option
10297 Status
: in out Boolean)
10301 SPARK_Msg_N
("duplicate state option", Opt
);
10305 end Check_Duplicate_Option
;
10307 ------------------------------
10308 -- Check_Duplicate_Property --
10309 ------------------------------
10311 procedure Check_Duplicate_Property
10313 Status
: in out Boolean)
10317 SPARK_Msg_N
("duplicate external property", Prop
);
10321 end Check_Duplicate_Property
;
10323 ---------------------------
10324 -- Create_Abstract_State --
10325 ---------------------------
10327 procedure Create_Abstract_State
10334 -- The abstract state may be semi-declared when the related
10335 -- package was withed through a limited with clause. In that
10336 -- case reuse the entity to fully declare the state.
10338 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10339 State_Id
:= Entity
(Decl
);
10341 -- Otherwise the elaboration of pragma Abstract_State
10342 -- declares the state.
10345 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10347 if Present
(Decl
) then
10348 Set_Entity
(Decl
, State_Id
);
10352 -- Null states never come from source
10354 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10355 Set_Parent
(State_Id
, State
);
10356 Set_Ekind
(State_Id
, E_Abstract_State
);
10357 Set_Etype
(State_Id
, Standard_Void_Type
);
10358 Set_Encapsulating_State
(State_Id
, Empty
);
10359 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
10360 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
10362 -- An abstract state declared within a Ghost region becomes
10363 -- Ghost (SPARK RM 6.9(2)).
10365 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
10366 Set_Is_Ghost_Entity
(State_Id
);
10369 -- Establish a link between the state declaration and the
10370 -- abstract state entity. Note that a null state remains as
10371 -- N_Null and does not carry any linkages.
10373 if not Is_Null
then
10374 if Present
(Decl
) then
10375 Set_Entity
(Decl
, State_Id
);
10376 Set_Etype
(Decl
, Standard_Void_Type
);
10379 -- Every non-null state must be defined, nameable and
10382 Push_Scope
(Pack_Id
);
10383 Generate_Definition
(State_Id
);
10384 Enter_Name
(State_Id
);
10387 end Create_Abstract_State
;
10394 -- Start of processing for Analyze_Abstract_State
10397 -- A package with a null abstract state is not allowed to
10398 -- declare additional states.
10402 ("package & has null abstract state", State
, Pack_Id
);
10404 -- Null states appear as internally generated entities
10406 elsif Nkind
(State
) = N_Null
then
10407 Create_Abstract_State
10408 (Nam
=> New_Internal_Name
('S'),
10410 Loc
=> Sloc
(State
),
10414 -- Catch a case where a null state appears in a list of
10415 -- non-null states.
10417 if Non_Null_Seen
then
10419 ("package & has non-null abstract state",
10423 -- Simple state declaration
10425 elsif Nkind
(State
) = N_Identifier
then
10426 Create_Abstract_State
10427 (Nam
=> Chars
(State
),
10429 Loc
=> Sloc
(State
),
10431 Non_Null_Seen
:= True;
10433 -- State declaration with various options. This construct
10434 -- appears as an extension aggregate in the tree.
10436 elsif Nkind
(State
) = N_Extension_Aggregate
then
10437 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10438 Create_Abstract_State
10439 (Nam
=> Chars
(Ancestor_Part
(State
)),
10440 Decl
=> Ancestor_Part
(State
),
10441 Loc
=> Sloc
(Ancestor_Part
(State
)),
10443 Non_Null_Seen
:= True;
10446 ("state name must be an identifier",
10447 Ancestor_Part
(State
));
10450 -- Options External, Ghost and Synchronous appear as
10453 Opt
:= First
(Expressions
(State
));
10454 while Present
(Opt
) loop
10455 if Nkind
(Opt
) = N_Identifier
then
10459 if Chars
(Opt
) = Name_External
then
10460 Check_Duplicate_Option
(Opt
, External_Seen
);
10461 Analyze_External_Option
(Opt
);
10465 elsif Chars
(Opt
) = Name_Ghost
then
10466 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
10468 if Present
(State_Id
) then
10469 Set_Is_Ghost_Entity
(State_Id
);
10474 elsif Chars
(Opt
) = Name_Synchronous
then
10475 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
10477 -- Option Part_Of without an encapsulating state is
10478 -- illegal (SPARK RM 7.1.4(9)).
10480 elsif Chars
(Opt
) = Name_Part_Of
then
10482 ("indicator Part_Of must denote abstract state, "
10483 & "single protected type or single task type",
10486 -- Do not emit an error message when a previous state
10487 -- declaration with options was not parenthesized as
10488 -- the option is actually another state declaration.
10490 -- with Abstract_State
10491 -- (State_1 with ..., -- missing parentheses
10492 -- (State_2 with ...),
10493 -- State_3) -- ok state declaration
10495 elsif Missing_Parentheses
then
10498 -- Otherwise the option is not allowed. Note that it
10499 -- is not possible to distinguish between an option
10500 -- and a state declaration when a previous state with
10501 -- options not properly parentheses.
10503 -- with Abstract_State
10504 -- (State_1 with ..., -- missing parentheses
10505 -- State_2); -- could be an option
10509 ("simple option not allowed in state declaration",
10513 -- Catch a case where missing parentheses around a state
10514 -- declaration with options cause a subsequent state
10515 -- declaration with options to be treated as an option.
10517 -- with Abstract_State
10518 -- (State_1 with ..., -- missing parentheses
10519 -- (State_2 with ...))
10521 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10522 Missing_Parentheses
:= True;
10524 ("state declaration must be parenthesized",
10525 Ancestor_Part
(State
));
10527 -- Otherwise the option is malformed
10530 SPARK_Msg_N
("malformed option", Opt
);
10536 -- Options External and Part_Of appear as component
10539 Opt
:= First
(Component_Associations
(State
));
10540 while Present
(Opt
) loop
10541 Opt_Nam
:= First
(Choices
(Opt
));
10543 if Nkind
(Opt_Nam
) = N_Identifier
then
10544 if Chars
(Opt_Nam
) = Name_External
then
10545 Analyze_External_Option
(Opt
);
10547 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10548 Analyze_Part_Of_Option
(Opt
);
10551 SPARK_Msg_N
("invalid state option", Opt
);
10554 SPARK_Msg_N
("invalid state option", Opt
);
10560 -- Any other attempt to declare a state is illegal
10563 Malformed_State_Error
(State
);
10567 -- Guard against a junk state. In such cases no entity is
10568 -- generated and the subsequent checks cannot be applied.
10570 if Present
(State_Id
) then
10572 -- Verify whether the state does not introduce an illegal
10573 -- hidden state within a package subject to a null abstract
10576 Check_No_Hidden_State
(State_Id
);
10578 -- Check whether the lack of option Part_Of agrees with the
10579 -- placement of the abstract state with respect to the state
10582 if not Part_Of_Seen
then
10583 Check_Missing_Part_Of
(State_Id
);
10586 -- Associate the state with its related package
10588 if No
(Abstract_States
(Pack_Id
)) then
10589 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10592 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10594 end Analyze_Abstract_State
;
10596 ---------------------------
10597 -- Malformed_State_Error --
10598 ---------------------------
10600 procedure Malformed_State_Error
(State
: Node_Id
) is
10602 Error_Msg_N
("malformed abstract state declaration", State
);
10604 -- An abstract state with a simple option is being declared
10605 -- with "=>" rather than the legal "with". The state appears
10606 -- as a component association.
10608 if Nkind
(State
) = N_Component_Association
then
10609 Error_Msg_N
("\use WITH to specify simple option", State
);
10611 end Malformed_State_Error
;
10615 Pack_Decl
: Node_Id
;
10616 Pack_Id
: Entity_Id
;
10620 -- Start of processing for Abstract_State
10624 Check_No_Identifiers
;
10625 Check_Arg_Count
(1);
10627 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
10629 -- Ensure the proper placement of the pragma. Abstract states must
10630 -- be associated with a package declaration.
10632 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
10633 N_Package_Declaration
)
10637 -- Otherwise the pragma is associated with an illegal construct
10644 Pack_Id
:= Defining_Entity
(Pack_Decl
);
10646 -- Chain the pragma on the contract for completeness
10648 Add_Contract_Item
(N
, Pack_Id
);
10650 -- The legality checks of pragmas Abstract_State, Initializes, and
10651 -- Initial_Condition are affected by the SPARK mode in effect. In
10652 -- addition, these three pragmas are subject to an inherent order:
10654 -- 1) Abstract_State
10656 -- 3) Initial_Condition
10658 -- Analyze all these pragmas in the order outlined above
10660 Analyze_If_Present
(Pragma_SPARK_Mode
);
10662 -- A pragma that applies to a Ghost entity becomes Ghost for the
10663 -- purposes of legality checks and removal of ignored Ghost code.
10665 Mark_Pragma_As_Ghost
(N
, Pack_Id
);
10666 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
10668 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
10670 -- Multiple non-null abstract states appear as an aggregate
10672 if Nkind
(States
) = N_Aggregate
then
10673 State
:= First
(Expressions
(States
));
10674 while Present
(State
) loop
10675 Analyze_Abstract_State
(State
, Pack_Id
);
10679 -- An abstract state with a simple option is being illegaly
10680 -- declared with "=>" rather than "with". In this case the
10681 -- state declaration appears as a component association.
10683 if Present
(Component_Associations
(States
)) then
10684 State
:= First
(Component_Associations
(States
));
10685 while Present
(State
) loop
10686 Malformed_State_Error
(State
);
10691 -- Various forms of a single abstract state. Note that these may
10692 -- include malformed state declarations.
10695 Analyze_Abstract_State
(States
, Pack_Id
);
10698 Analyze_If_Present
(Pragma_Initializes
);
10699 Analyze_If_Present
(Pragma_Initial_Condition
);
10700 end Abstract_State
;
10708 -- Note: this pragma also has some specific processing in Par.Prag
10709 -- because we want to set the Ada version mode during parsing.
10711 when Pragma_Ada_83
=>
10713 Check_Arg_Count
(0);
10715 -- We really should check unconditionally for proper configuration
10716 -- pragma placement, since we really don't want mixed Ada modes
10717 -- within a single unit, and the GNAT reference manual has always
10718 -- said this was a configuration pragma, but we did not check and
10719 -- are hesitant to add the check now.
10721 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10722 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10723 -- or Ada 2012 mode.
10725 if Ada_Version
>= Ada_2005
then
10726 Check_Valid_Configuration_Pragma
;
10729 -- Now set Ada 83 mode
10731 Ada_Version
:= Ada_83
;
10732 Ada_Version_Explicit
:= Ada_83
;
10733 Ada_Version_Pragma
:= N
;
10741 -- Note: this pragma also has some specific processing in Par.Prag
10742 -- because we want to set the Ada 83 version mode during parsing.
10744 when Pragma_Ada_95
=>
10746 Check_Arg_Count
(0);
10748 -- We really should check unconditionally for proper configuration
10749 -- pragma placement, since we really don't want mixed Ada modes
10750 -- within a single unit, and the GNAT reference manual has always
10751 -- said this was a configuration pragma, but we did not check and
10752 -- are hesitant to add the check now.
10754 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10755 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10757 if Ada_Version
>= Ada_2005
then
10758 Check_Valid_Configuration_Pragma
;
10761 -- Now set Ada 95 mode
10763 Ada_Version
:= Ada_95
;
10764 Ada_Version_Explicit
:= Ada_95
;
10765 Ada_Version_Pragma
:= N
;
10767 ---------------------
10768 -- Ada_05/Ada_2005 --
10769 ---------------------
10772 -- pragma Ada_05 (LOCAL_NAME);
10774 -- pragma Ada_2005;
10775 -- pragma Ada_2005 (LOCAL_NAME):
10777 -- Note: these pragmas also have some specific processing in Par.Prag
10778 -- because we want to set the Ada 2005 version mode during parsing.
10780 -- The one argument form is used for managing the transition from
10781 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10782 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10783 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10784 -- mode, a preference rule is established which does not choose
10785 -- such an entity unless it is unambiguously specified. This avoids
10786 -- extra subprograms marked this way from generating ambiguities in
10787 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10788 -- intended for exclusive use in the GNAT run-time library.
10790 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10796 if Arg_Count
= 1 then
10797 Check_Arg_Is_Local_Name
(Arg1
);
10798 E_Id
:= Get_Pragma_Arg
(Arg1
);
10800 if Etype
(E_Id
) = Any_Type
then
10804 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10805 Record_Rep_Item
(Entity
(E_Id
), N
);
10808 Check_Arg_Count
(0);
10810 -- For Ada_2005 we unconditionally enforce the documented
10811 -- configuration pragma placement, since we do not want to
10812 -- tolerate mixed modes in a unit involving Ada 2005. That
10813 -- would cause real difficulties for those cases where there
10814 -- are incompatibilities between Ada 95 and Ada 2005.
10816 Check_Valid_Configuration_Pragma
;
10818 -- Now set appropriate Ada mode
10820 Ada_Version
:= Ada_2005
;
10821 Ada_Version_Explicit
:= Ada_2005
;
10822 Ada_Version_Pragma
:= N
;
10826 ---------------------
10827 -- Ada_12/Ada_2012 --
10828 ---------------------
10831 -- pragma Ada_12 (LOCAL_NAME);
10833 -- pragma Ada_2012;
10834 -- pragma Ada_2012 (LOCAL_NAME):
10836 -- Note: these pragmas also have some specific processing in Par.Prag
10837 -- because we want to set the Ada 2012 version mode during parsing.
10839 -- The one argument form is used for managing the transition from Ada
10840 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10841 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10842 -- mode will generate a warning. In addition, in any pre-Ada_2012
10843 -- mode, a preference rule is established which does not choose
10844 -- such an entity unless it is unambiguously specified. This avoids
10845 -- extra subprograms marked this way from generating ambiguities in
10846 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10847 -- intended for exclusive use in the GNAT run-time library.
10849 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10855 if Arg_Count
= 1 then
10856 Check_Arg_Is_Local_Name
(Arg1
);
10857 E_Id
:= Get_Pragma_Arg
(Arg1
);
10859 if Etype
(E_Id
) = Any_Type
then
10863 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10864 Record_Rep_Item
(Entity
(E_Id
), N
);
10867 Check_Arg_Count
(0);
10869 -- For Ada_2012 we unconditionally enforce the documented
10870 -- configuration pragma placement, since we do not want to
10871 -- tolerate mixed modes in a unit involving Ada 2012. That
10872 -- would cause real difficulties for those cases where there
10873 -- are incompatibilities between Ada 95 and Ada 2012. We could
10874 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10876 Check_Valid_Configuration_Pragma
;
10878 -- Now set appropriate Ada mode
10880 Ada_Version
:= Ada_2012
;
10881 Ada_Version_Explicit
:= Ada_2012
;
10882 Ada_Version_Pragma
:= N
;
10886 ----------------------
10887 -- All_Calls_Remote --
10888 ----------------------
10890 -- pragma All_Calls_Remote [(library_package_NAME)];
10892 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10893 Lib_Entity
: Entity_Id
;
10896 Check_Ada_83_Warning
;
10897 Check_Valid_Library_Unit_Pragma
;
10899 if Nkind
(N
) = N_Null_Statement
then
10903 Lib_Entity
:= Find_Lib_Unit_Name
;
10905 -- A pragma that applies to a Ghost entity becomes Ghost for the
10906 -- purposes of legality checks and removal of ignored Ghost code.
10908 Mark_Pragma_As_Ghost
(N
, Lib_Entity
);
10910 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10912 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
10913 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10914 Error_Pragma
("pragma% only apply to rci unit");
10916 -- Set flag for entity of the library unit
10919 Set_Has_All_Calls_Remote
(Lib_Entity
);
10922 end All_Calls_Remote
;
10924 ---------------------------
10925 -- Allow_Integer_Address --
10926 ---------------------------
10928 -- pragma Allow_Integer_Address;
10930 when Pragma_Allow_Integer_Address
=>
10932 Check_Valid_Configuration_Pragma
;
10933 Check_Arg_Count
(0);
10935 -- If Address is a private type, then set the flag to allow
10936 -- integer address values. If Address is not private, then this
10937 -- pragma has no purpose, so it is simply ignored. Not clear if
10938 -- there are any such targets now.
10940 if Opt
.Address_Is_Private
then
10941 Opt
.Allow_Integer_Address
:= True;
10949 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10950 -- ARG ::= NAME | EXPRESSION
10952 -- The first two arguments are by convention intended to refer to an
10953 -- external tool and a tool-specific function. These arguments are
10956 when Pragma_Annotate
=> Annotate
: declare
10963 Check_At_Least_N_Arguments
(1);
10965 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
10967 -- Determine whether the last argument is "Entity => local_NAME"
10968 -- and if it is, perform the required semantic checks. Remove the
10969 -- argument from further processing.
10971 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
10972 and then Chars
(Nam_Arg
) = Name_Entity
10974 Check_Arg_Is_Local_Name
(Nam_Arg
);
10975 Arg_Count
:= Arg_Count
- 1;
10977 -- A pragma that applies to a Ghost entity becomes Ghost for
10978 -- the purposes of legality checks and removal of ignored Ghost
10981 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
10982 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
10984 Mark_Pragma_As_Ghost
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
10987 -- Not allowed in compiler units (bootstrap issues)
10989 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
10992 -- Continue the processing with last argument removed for now
10994 Check_Arg_Is_Identifier
(Arg1
);
10995 Check_No_Identifiers
;
10998 -- The second parameter is optional, it is never analyzed
11003 -- Otherwise there is a second parameter
11006 -- The second parameter must be an identifier
11008 Check_Arg_Is_Identifier
(Arg2
);
11010 -- Process the remaining parameters (if any)
11012 Arg
:= Next
(Arg2
);
11013 while Present
(Arg
) loop
11014 Expr
:= Get_Pragma_Arg
(Arg
);
11017 if Is_Entity_Name
(Expr
) then
11020 -- For string literals, we assume Standard_String as the
11021 -- type, unless the string contains wide or wide_wide
11024 elsif Nkind
(Expr
) = N_String_Literal
then
11025 if Has_Wide_Wide_Character
(Expr
) then
11026 Resolve
(Expr
, Standard_Wide_Wide_String
);
11027 elsif Has_Wide_Character
(Expr
) then
11028 Resolve
(Expr
, Standard_Wide_String
);
11030 Resolve
(Expr
, Standard_String
);
11033 elsif Is_Overloaded
(Expr
) then
11034 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
11045 -------------------------------------------------
11046 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11047 -------------------------------------------------
11050 -- ( [Check => ] Boolean_EXPRESSION
11051 -- [, [Message =>] Static_String_EXPRESSION]);
11053 -- pragma Assert_And_Cut
11054 -- ( [Check => ] Boolean_EXPRESSION
11055 -- [, [Message =>] Static_String_EXPRESSION]);
11058 -- ( [Check => ] Boolean_EXPRESSION
11059 -- [, [Message =>] Static_String_EXPRESSION]);
11061 -- pragma Loop_Invariant
11062 -- ( [Check => ] Boolean_EXPRESSION
11063 -- [, [Message =>] Static_String_EXPRESSION]);
11065 when Pragma_Assert |
11066 Pragma_Assert_And_Cut |
11068 Pragma_Loop_Invariant
=>
11070 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
11071 -- Determine whether expression Expr contains a Loop_Entry
11072 -- attribute reference.
11074 -------------------------
11075 -- Contains_Loop_Entry --
11076 -------------------------
11078 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
11079 Has_Loop_Entry
: Boolean := False;
11081 function Process
(N
: Node_Id
) return Traverse_Result
;
11082 -- Process function for traversal to look for Loop_Entry
11088 function Process
(N
: Node_Id
) return Traverse_Result
is
11090 if Nkind
(N
) = N_Attribute_Reference
11091 and then Attribute_Name
(N
) = Name_Loop_Entry
11093 Has_Loop_Entry
:= True;
11100 procedure Traverse
is new Traverse_Proc
(Process
);
11102 -- Start of processing for Contains_Loop_Entry
11106 return Has_Loop_Entry
;
11107 end Contains_Loop_Entry
;
11112 New_Args
: List_Id
;
11114 -- Start of processing for Assert
11117 -- Assert is an Ada 2005 RM-defined pragma
11119 if Prag_Id
= Pragma_Assert
then
11122 -- The remaining ones are GNAT pragmas
11128 Check_At_Least_N_Arguments
(1);
11129 Check_At_Most_N_Arguments
(2);
11130 Check_Arg_Order
((Name_Check
, Name_Message
));
11131 Check_Optional_Identifier
(Arg1
, Name_Check
);
11132 Expr
:= Get_Pragma_Arg
(Arg1
);
11134 -- Special processing for Loop_Invariant, Loop_Variant or for
11135 -- other cases where a Loop_Entry attribute is present. If the
11136 -- assertion pragma contains attribute Loop_Entry, ensure that
11137 -- the related pragma is within a loop.
11139 if Prag_Id
= Pragma_Loop_Invariant
11140 or else Prag_Id
= Pragma_Loop_Variant
11141 or else Contains_Loop_Entry
(Expr
)
11143 Check_Loop_Pragma_Placement
;
11145 -- Perform preanalysis to deal with embedded Loop_Entry
11148 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
11151 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11152 -- a corresponding Check pragma:
11154 -- pragma Check (name, condition [, msg]);
11156 -- Where name is the identifier matching the pragma name. So
11157 -- rewrite pragma in this manner, transfer the message argument
11158 -- if present, and analyze the result
11160 -- Note: When dealing with a semantically analyzed tree, the
11161 -- information that a Check node N corresponds to a source Assert,
11162 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11163 -- pragma kind of Original_Node(N).
11165 New_Args
:= New_List
(
11166 Make_Pragma_Argument_Association
(Loc
,
11167 Expression
=> Make_Identifier
(Loc
, Pname
)),
11168 Make_Pragma_Argument_Association
(Sloc
(Expr
),
11169 Expression
=> Expr
));
11171 if Arg_Count
> 1 then
11172 Check_Optional_Identifier
(Arg2
, Name_Message
);
11174 -- Provide semantic annnotations for optional argument, for
11175 -- ASIS use, before rewriting.
11177 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
11178 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
11181 -- Rewrite as Check pragma
11185 Chars
=> Name_Check
,
11186 Pragma_Argument_Associations
=> New_Args
));
11191 ----------------------
11192 -- Assertion_Policy --
11193 ----------------------
11195 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11197 -- The following form is Ada 2012 only, but we allow it in all modes
11199 -- Pragma Assertion_Policy (
11200 -- ASSERTION_KIND => POLICY_IDENTIFIER
11201 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11203 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11205 -- RM_ASSERTION_KIND ::= Assert |
11206 -- Static_Predicate |
11207 -- Dynamic_Predicate |
11212 -- Type_Invariant |
11213 -- Type_Invariant'Class
11215 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11217 -- Contract_Cases |
11219 -- Default_Initial_Condition |
11221 -- Initial_Condition |
11222 -- Loop_Invariant |
11228 -- Statement_Assertions
11230 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11231 -- ID_ASSERTION_KIND list contains implementation-defined additions
11232 -- recognized by GNAT. The effect is to control the behavior of
11233 -- identically named aspects and pragmas, depending on the specified
11234 -- policy identifier:
11236 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11238 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11239 -- implementation-defined addition that results in totally ignoring
11240 -- the corresponding assertion. If Disable is specified, then the
11241 -- argument of the assertion is not even analyzed. This is useful
11242 -- when the aspect/pragma argument references entities in a with'ed
11243 -- package that is replaced by a dummy package in the final build.
11245 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11246 -- and Type_Invariant'Class were recognized by the parser and
11247 -- transformed into references to the special internal identifiers
11248 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11249 -- processing is required here.
11251 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11260 -- This can always appear as a configuration pragma
11262 if Is_Configuration_Pragma
then
11265 -- It can also appear in a declarative part or package spec in Ada
11266 -- 2012 mode. We allow this in other modes, but in that case we
11267 -- consider that we have an Ada 2012 pragma on our hands.
11270 Check_Is_In_Decl_Part_Or_Package_Spec
;
11274 -- One argument case with no identifier (first form above)
11277 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11278 or else Chars
(Arg1
) = No_Name
)
11280 Check_Arg_Is_One_Of
11281 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11283 -- Treat one argument Assertion_Policy as equivalent to:
11285 -- pragma Check_Policy (Assertion, policy)
11287 -- So rewrite pragma in that manner and link on to the chain
11288 -- of Check_Policy pragmas, marking the pragma as analyzed.
11290 Policy
:= Get_Pragma_Arg
(Arg1
);
11294 Chars
=> Name_Check_Policy
,
11295 Pragma_Argument_Associations
=> New_List
(
11296 Make_Pragma_Argument_Association
(Loc
,
11297 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11299 Make_Pragma_Argument_Association
(Loc
,
11301 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11304 -- Here if we have two or more arguments
11307 Check_At_Least_N_Arguments
(1);
11310 -- Loop through arguments
11313 while Present
(Arg
) loop
11314 LocP
:= Sloc
(Arg
);
11316 -- Kind must be specified
11318 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11319 or else Chars
(Arg
) = No_Name
11322 ("missing assertion kind for pragma%", Arg
);
11325 -- Check Kind and Policy have allowed forms
11327 Kind
:= Chars
(Arg
);
11329 if not Is_Valid_Assertion_Kind
(Kind
) then
11331 ("invalid assertion kind for pragma%", Arg
);
11334 Check_Arg_Is_One_Of
11335 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11337 -- Rewrite the Assertion_Policy pragma as a series of
11338 -- Check_Policy pragmas of the form:
11340 -- Check_Policy (Kind, Policy);
11342 -- Note: the insertion of the pragmas cannot be done with
11343 -- Insert_Action because in the configuration case, there
11344 -- are no scopes on the scope stack and the mechanism will
11347 Insert_Before_And_Analyze
(N
,
11349 Chars
=> Name_Check_Policy
,
11350 Pragma_Argument_Associations
=> New_List
(
11351 Make_Pragma_Argument_Association
(LocP
,
11352 Expression
=> Make_Identifier
(LocP
, Kind
)),
11353 Make_Pragma_Argument_Association
(LocP
,
11354 Expression
=> Get_Pragma_Arg
(Arg
)))));
11359 -- Rewrite the Assertion_Policy pragma as null since we have
11360 -- now inserted all the equivalent Check pragmas.
11362 Rewrite
(N
, Make_Null_Statement
(Loc
));
11365 end Assertion_Policy
;
11367 ------------------------------
11368 -- Assume_No_Invalid_Values --
11369 ------------------------------
11371 -- pragma Assume_No_Invalid_Values (On | Off);
11373 when Pragma_Assume_No_Invalid_Values
=>
11375 Check_Valid_Configuration_Pragma
;
11376 Check_Arg_Count
(1);
11377 Check_No_Identifiers
;
11378 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11380 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11381 Assume_No_Invalid_Values
:= True;
11383 Assume_No_Invalid_Values
:= False;
11386 --------------------------
11387 -- Attribute_Definition --
11388 --------------------------
11390 -- pragma Attribute_Definition
11391 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11392 -- [Entity =>] LOCAL_NAME,
11393 -- [Expression =>] EXPRESSION | NAME);
11395 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11396 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11401 Check_Arg_Count
(3);
11402 Check_Optional_Identifier
(Arg1
, "attribute");
11403 Check_Optional_Identifier
(Arg2
, "entity");
11404 Check_Optional_Identifier
(Arg3
, "expression");
11406 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11407 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11411 Check_Arg_Is_Local_Name
(Arg2
);
11413 -- If the attribute is not recognized, then issue a warning (not
11414 -- an error), and ignore the pragma.
11416 Aname
:= Chars
(Attribute_Designator
);
11418 if not Is_Attribute_Name
(Aname
) then
11419 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11423 -- Otherwise, rewrite the pragma as an attribute definition clause
11426 Make_Attribute_Definition_Clause
(Loc
,
11427 Name
=> Get_Pragma_Arg
(Arg2
),
11429 Expression
=> Get_Pragma_Arg
(Arg3
)));
11431 end Attribute_Definition
;
11433 ------------------------------------------------------------------
11434 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11435 ------------------------------------------------------------------
11437 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
11438 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
11439 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
11440 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
11442 when Pragma_Async_Readers |
11443 Pragma_Async_Writers |
11444 Pragma_Effective_Reads |
11445 Pragma_Effective_Writes
=>
11446 Async_Effective
: declare
11447 Obj_Decl
: Node_Id
;
11448 Obj_Id
: Entity_Id
;
11452 Check_No_Identifiers
;
11453 Check_At_Most_N_Arguments
(1);
11455 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
11457 -- Object declaration
11459 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
11462 -- Otherwise the pragma is associated with an illegal construact
11469 Obj_Id
:= Defining_Entity
(Obj_Decl
);
11471 -- Perform minimal verification to ensure that the argument is at
11472 -- least a variable. Subsequent finer grained checks will be done
11473 -- at the end of the declarative region the contains the pragma.
11475 if Ekind
(Obj_Id
) = E_Variable
then
11477 -- Chain the pragma on the contract for further processing by
11478 -- Analyze_External_Property_In_Decl_Part.
11480 Add_Contract_Item
(N
, Obj_Id
);
11482 -- A pragma that applies to a Ghost entity becomes Ghost for
11483 -- the purposes of legality checks and removal of ignored Ghost
11486 Mark_Pragma_As_Ghost
(N
, Obj_Id
);
11488 -- Analyze the Boolean expression (if any)
11490 if Present
(Arg1
) then
11491 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
11494 -- Otherwise the external property applies to a constant
11497 Error_Pragma
("pragma % must apply to a volatile object");
11499 end Async_Effective
;
11505 -- pragma Asynchronous (LOCAL_NAME);
11507 when Pragma_Asynchronous
=> Asynchronous
: declare
11510 Formal
: Entity_Id
;
11515 procedure Process_Async_Pragma
;
11516 -- Common processing for procedure and access-to-procedure case
11518 --------------------------
11519 -- Process_Async_Pragma --
11520 --------------------------
11522 procedure Process_Async_Pragma
is
11525 Set_Is_Asynchronous
(Nm
);
11529 -- The formals should be of mode IN (RM E.4.1(6))
11532 while Present
(S
) loop
11533 Formal
:= Defining_Identifier
(S
);
11535 if Nkind
(Formal
) = N_Defining_Identifier
11536 and then Ekind
(Formal
) /= E_In_Parameter
11539 ("pragma% procedure can only have IN parameter",
11546 Set_Is_Asynchronous
(Nm
);
11547 end Process_Async_Pragma
;
11549 -- Start of processing for pragma Asynchronous
11552 Check_Ada_83_Warning
;
11553 Check_No_Identifiers
;
11554 Check_Arg_Count
(1);
11555 Check_Arg_Is_Local_Name
(Arg1
);
11557 if Debug_Flag_U
then
11561 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11562 Analyze
(Get_Pragma_Arg
(Arg1
));
11563 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11565 -- A pragma that applies to a Ghost entity becomes Ghost for the
11566 -- purposes of legality checks and removal of ignored Ghost code.
11568 Mark_Pragma_As_Ghost
(N
, Nm
);
11570 if not Is_Remote_Call_Interface
(C_Ent
)
11571 and then not Is_Remote_Types
(C_Ent
)
11573 -- This pragma should only appear in an RCI or Remote Types
11574 -- unit (RM E.4.1(4)).
11577 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11580 if Ekind
(Nm
) = E_Procedure
11581 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11583 if not Is_Remote_Call_Interface
(Nm
) then
11585 ("pragma% cannot be applied on non-remote procedure",
11589 L
:= Parameter_Specifications
(Parent
(Nm
));
11590 Process_Async_Pragma
;
11593 elsif Ekind
(Nm
) = E_Function
then
11595 ("pragma% cannot be applied to function", Arg1
);
11597 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11598 if Is_Record_Type
(Nm
) then
11600 -- A record type that is the Equivalent_Type for a remote
11601 -- access-to-subprogram type.
11603 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11606 -- A non-expanded RAS type (distribution is not enabled)
11608 Decl
:= Declaration_Node
(Nm
);
11611 if Nkind
(Decl
) = N_Full_Type_Declaration
11612 and then Nkind
(Type_Definition
(Decl
)) =
11613 N_Access_Procedure_Definition
11615 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
11616 Process_Async_Pragma
;
11618 if Is_Asynchronous
(Nm
)
11619 and then Expander_Active
11620 and then Get_PCS_Name
/= Name_No_DSA
11622 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11627 ("pragma% cannot reference access-to-function type",
11631 -- Only other possibility is Access-to-class-wide type
11633 elsif Is_Access_Type
(Nm
)
11634 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11636 Check_First_Subtype
(Arg1
);
11637 Set_Is_Asynchronous
(Nm
);
11638 if Expander_Active
then
11639 RACW_Type_Is_Asynchronous
(Nm
);
11643 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11651 -- pragma Atomic (LOCAL_NAME);
11653 when Pragma_Atomic
=>
11654 Process_Atomic_Independent_Shared_Volatile
;
11656 -----------------------
11657 -- Atomic_Components --
11658 -----------------------
11660 -- pragma Atomic_Components (array_LOCAL_NAME);
11662 -- This processing is shared by Volatile_Components
11664 when Pragma_Atomic_Components |
11665 Pragma_Volatile_Components
=>
11666 Atomic_Components
: declare
11673 Check_Ada_83_Warning
;
11674 Check_No_Identifiers
;
11675 Check_Arg_Count
(1);
11676 Check_Arg_Is_Local_Name
(Arg1
);
11677 E_Id
:= Get_Pragma_Arg
(Arg1
);
11679 if Etype
(E_Id
) = Any_Type
then
11683 E
:= Entity
(E_Id
);
11685 -- A pragma that applies to a Ghost entity becomes Ghost for the
11686 -- purposes of legality checks and removal of ignored Ghost code.
11688 Mark_Pragma_As_Ghost
(N
, E
);
11689 Check_Duplicate_Pragma
(E
);
11691 if Rep_Item_Too_Early
(E
, N
)
11693 Rep_Item_Too_Late
(E
, N
)
11698 D
:= Declaration_Node
(E
);
11701 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11703 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11704 and then Nkind
(D
) = N_Object_Declaration
11705 and then Nkind
(Object_Definition
(D
)) =
11706 N_Constrained_Array_Definition
)
11708 -- The flag is set on the object, or on the base type
11710 if Nkind
(D
) /= N_Object_Declaration
then
11711 E
:= Base_Type
(E
);
11714 -- Atomic implies both Independent and Volatile
11716 if Prag_Id
= Pragma_Atomic_Components
then
11717 Set_Has_Atomic_Components
(E
);
11718 Set_Has_Independent_Components
(E
);
11721 Set_Has_Volatile_Components
(E
);
11724 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11726 end Atomic_Components
;
11728 --------------------
11729 -- Attach_Handler --
11730 --------------------
11732 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11734 when Pragma_Attach_Handler
=>
11735 Check_Ada_83_Warning
;
11736 Check_No_Identifiers
;
11737 Check_Arg_Count
(2);
11739 if No_Run_Time_Mode
then
11740 Error_Msg_CRT
("Attach_Handler pragma", N
);
11742 Check_Interrupt_Or_Attach_Handler
;
11744 -- The expression that designates the attribute may depend on a
11745 -- discriminant, and is therefore a per-object expression, to
11746 -- be expanded in the init proc. If expansion is enabled, then
11747 -- perform semantic checks on a copy only.
11752 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11755 -- In Relaxed_RM_Semantics mode, we allow any static
11756 -- integer value, for compatibility with other compilers.
11758 if Relaxed_RM_Semantics
11759 and then Nkind
(Parg2
) = N_Integer_Literal
11761 Typ
:= Standard_Integer
;
11763 Typ
:= RTE
(RE_Interrupt_ID
);
11766 if Expander_Active
then
11767 Temp
:= New_Copy_Tree
(Parg2
);
11768 Set_Parent
(Temp
, N
);
11769 Preanalyze_And_Resolve
(Temp
, Typ
);
11772 Resolve
(Parg2
, Typ
);
11776 Process_Interrupt_Or_Attach_Handler
;
11779 --------------------
11780 -- C_Pass_By_Copy --
11781 --------------------
11783 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11785 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11791 Check_Valid_Configuration_Pragma
;
11792 Check_Arg_Count
(1);
11793 Check_Optional_Identifier
(Arg1
, "max_size");
11795 Arg
:= Get_Pragma_Arg
(Arg1
);
11796 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11798 Val
:= Expr_Value
(Arg
);
11802 ("maximum size for pragma% must be positive", Arg1
);
11804 elsif UI_Is_In_Int_Range
(Val
) then
11805 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11807 -- If a giant value is given, Int'Last will do well enough.
11808 -- If sometime someone complains that a record larger than
11809 -- two gigabytes is not copied, we will worry about it then.
11812 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11814 end C_Pass_By_Copy
;
11820 -- pragma Check ([Name =>] CHECK_KIND,
11821 -- [Check =>] Boolean_EXPRESSION
11822 -- [,[Message =>] String_EXPRESSION]);
11824 -- CHECK_KIND ::= IDENTIFIER |
11827 -- Invariant'Class |
11828 -- Type_Invariant'Class
11830 -- The identifiers Assertions and Statement_Assertions are not
11831 -- allowed, since they have special meaning for Check_Policy.
11833 when Pragma_Check
=> Check
: declare
11839 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
11842 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
11843 -- the mode now to ensure that any nodes generated during analysis
11844 -- and expansion are marked as Ghost.
11846 Set_Ghost_Mode
(N
);
11849 Check_At_Least_N_Arguments
(2);
11850 Check_At_Most_N_Arguments
(3);
11851 Check_Optional_Identifier
(Arg1
, Name_Name
);
11852 Check_Optional_Identifier
(Arg2
, Name_Check
);
11854 if Arg_Count
= 3 then
11855 Check_Optional_Identifier
(Arg3
, Name_Message
);
11856 Str
:= Get_Pragma_Arg
(Arg3
);
11859 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11860 Check_Arg_Is_Identifier
(Arg1
);
11861 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11863 -- Check forbidden name Assertions or Statement_Assertions
11866 when Name_Assertions
=>
11868 ("""Assertions"" is not allowed as a check kind for "
11869 & "pragma%", Arg1
);
11871 when Name_Statement_Assertions
=>
11873 ("""Statement_Assertions"" is not allowed as a check kind "
11874 & "for pragma%", Arg1
);
11880 -- Check applicable policy. We skip this if Checked/Ignored status
11881 -- is already set (e.g. in the case of a pragma from an aspect).
11883 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11886 -- For a non-source pragma that is a rewriting of another pragma,
11887 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11889 elsif Is_Rewrite_Substitution
(N
)
11890 and then Nkind
(Original_Node
(N
)) = N_Pragma
11891 and then Original_Node
(N
) /= N
11893 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11894 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11896 -- Otherwise query the applicable policy at this point
11899 case Check_Kind
(Cname
) is
11900 when Name_Ignore
=>
11901 Set_Is_Ignored
(N
, True);
11902 Set_Is_Checked
(N
, False);
11905 Set_Is_Ignored
(N
, False);
11906 Set_Is_Checked
(N
, True);
11908 -- For disable, rewrite pragma as null statement and skip
11909 -- rest of the analysis of the pragma.
11911 when Name_Disable
=>
11912 Rewrite
(N
, Make_Null_Statement
(Loc
));
11916 -- No other possibilities
11919 raise Program_Error
;
11923 -- If check kind was not Disable, then continue pragma analysis
11925 Expr
:= Get_Pragma_Arg
(Arg2
);
11927 -- Deal with SCO generation
11931 -- Nothing to do for invariants and predicates as the checks
11932 -- occur in the client units. The SCO for the aspect in the
11933 -- declaration unit is conservatively always enabled.
11935 when Name_Invariant | Name_Predicate
=>
11938 -- Otherwise mark aspect/pragma SCO as enabled
11941 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11942 Set_SCO_Pragma_Enabled
(Loc
);
11946 -- Deal with analyzing the string argument
11948 if Arg_Count
= 3 then
11950 -- If checks are not on we don't want any expansion (since
11951 -- such expansion would not get properly deleted) but
11952 -- we do want to analyze (to get proper references).
11953 -- The Preanalyze_And_Resolve routine does just what we want
11955 if Is_Ignored
(N
) then
11956 Preanalyze_And_Resolve
(Str
, Standard_String
);
11958 -- Otherwise we need a proper analysis and expansion
11961 Analyze_And_Resolve
(Str
, Standard_String
);
11965 -- Now you might think we could just do the same with the Boolean
11966 -- expression if checks are off (and expansion is on) and then
11967 -- rewrite the check as a null statement. This would work but we
11968 -- would lose the useful warnings about an assertion being bound
11969 -- to fail even if assertions are turned off.
11971 -- So instead we wrap the boolean expression in an if statement
11972 -- that looks like:
11974 -- if False and then condition then
11978 -- The reason we do this rewriting during semantic analysis rather
11979 -- than as part of normal expansion is that we cannot analyze and
11980 -- expand the code for the boolean expression directly, or it may
11981 -- cause insertion of actions that would escape the attempt to
11982 -- suppress the check code.
11984 -- Note that the Sloc for the if statement corresponds to the
11985 -- argument condition, not the pragma itself. The reason for
11986 -- this is that we may generate a warning if the condition is
11987 -- False at compile time, and we do not want to delete this
11988 -- warning when we delete the if statement.
11990 if Expander_Active
and Is_Ignored
(N
) then
11991 Eloc
:= Sloc
(Expr
);
11994 Make_If_Statement
(Eloc
,
11996 Make_And_Then
(Eloc
,
11997 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
11998 Right_Opnd
=> Expr
),
11999 Then_Statements
=> New_List
(
12000 Make_Null_Statement
(Eloc
))));
12002 -- Now go ahead and analyze the if statement
12004 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12006 -- One rather special treatment. If we are now in Eliminated
12007 -- overflow mode, then suppress overflow checking since we do
12008 -- not want to drag in the bignum stuff if we are in Ignore
12009 -- mode anyway. This is particularly important if we are using
12010 -- a configurable run time that does not support bignum ops.
12012 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
12014 Svo
: constant Boolean :=
12015 Scope_Suppress
.Suppress
(Overflow_Check
);
12017 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
12018 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
12020 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
12021 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
12024 -- Not that special case
12030 -- All done with this check
12032 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12034 -- Check is active or expansion not active. In these cases we can
12035 -- just go ahead and analyze the boolean with no worries.
12038 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12039 Analyze_And_Resolve
(Expr
, Any_Boolean
);
12040 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12043 Ghost_Mode
:= Save_Ghost_Mode
;
12046 --------------------------
12047 -- Check_Float_Overflow --
12048 --------------------------
12050 -- pragma Check_Float_Overflow;
12052 when Pragma_Check_Float_Overflow
=>
12054 Check_Valid_Configuration_Pragma
;
12055 Check_Arg_Count
(0);
12056 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
12062 -- pragma Check_Name (check_IDENTIFIER);
12064 when Pragma_Check_Name
=>
12066 Check_No_Identifiers
;
12067 Check_Valid_Configuration_Pragma
;
12068 Check_Arg_Count
(1);
12069 Check_Arg_Is_Identifier
(Arg1
);
12072 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
12075 for J
in Check_Names
.First
.. Check_Names
.Last
loop
12076 if Check_Names
.Table
(J
) = Nam
then
12081 Check_Names
.Append
(Nam
);
12088 -- This is the old style syntax, which is still allowed in all modes:
12090 -- pragma Check_Policy ([Name =>] CHECK_KIND
12091 -- [Policy =>] POLICY_IDENTIFIER);
12093 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12095 -- CHECK_KIND ::= IDENTIFIER |
12098 -- Type_Invariant'Class |
12101 -- This is the new style syntax, compatible with Assertion_Policy
12102 -- and also allowed in all modes.
12104 -- Pragma Check_Policy (
12105 -- CHECK_KIND => POLICY_IDENTIFIER
12106 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12108 -- Note: the identifiers Name and Policy are not allowed as
12109 -- Check_Kind values. This avoids ambiguities between the old and
12110 -- new form syntax.
12112 when Pragma_Check_Policy
=> Check_Policy
: declare
12118 Check_At_Least_N_Arguments
(1);
12120 -- A Check_Policy pragma can appear either as a configuration
12121 -- pragma, or in a declarative part or a package spec (see RM
12122 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12123 -- followed for Check_Policy).
12125 if not Is_Configuration_Pragma
then
12126 Check_Is_In_Decl_Part_Or_Package_Spec
;
12129 -- Figure out if we have the old or new syntax. We have the
12130 -- old syntax if the first argument has no identifier, or the
12131 -- identifier is Name.
12133 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
12134 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
12138 Check_Arg_Count
(2);
12139 Check_Optional_Identifier
(Arg1
, Name_Name
);
12140 Kind
:= Get_Pragma_Arg
(Arg1
);
12141 Rewrite_Assertion_Kind
(Kind
);
12142 Check_Arg_Is_Identifier
(Arg1
);
12144 -- Check forbidden check kind
12146 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
12147 Error_Msg_Name_2
:= Chars
(Kind
);
12149 ("pragma% does not allow% as check name", Arg1
);
12154 Check_Optional_Identifier
(Arg2
, Name_Policy
);
12155 Check_Arg_Is_One_Of
12157 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
12158 Ident
:= Get_Pragma_Arg
(Arg2
);
12160 if Chars
(Kind
) = Name_Ghost
then
12162 -- Pragma Check_Policy specifying a Ghost policy cannot
12163 -- occur within a ghost subprogram or package.
12165 if Ghost_Mode
> None
then
12167 ("pragma % cannot appear within ghost subprogram or "
12170 -- The policy identifier of pragma Ghost must be either
12171 -- Check or Ignore (SPARK RM 6.9(7)).
12173 elsif not Nam_In
(Chars
(Ident
), Name_Check
,
12177 ("argument of pragma % Ghost must be Check or Ignore",
12182 -- And chain pragma on the Check_Policy_List for search
12184 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
12185 Opt
.Check_Policy_List
:= N
;
12187 -- For the new syntax, what we do is to convert each argument to
12188 -- an old syntax equivalent. We do that because we want to chain
12189 -- old style Check_Policy pragmas for the search (we don't want
12190 -- to have to deal with multiple arguments in the search).
12200 while Present
(Arg
) loop
12201 LocP
:= Sloc
(Arg
);
12202 Argx
:= Get_Pragma_Arg
(Arg
);
12204 -- Kind must be specified
12206 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12207 or else Chars
(Arg
) = No_Name
12210 ("missing assertion kind for pragma%", Arg
);
12213 -- Construct equivalent old form syntax Check_Policy
12214 -- pragma and insert it to get remaining checks.
12218 Chars
=> Name_Check_Policy
,
12219 Pragma_Argument_Associations
=> New_List
(
12220 Make_Pragma_Argument_Association
(LocP
,
12222 Make_Identifier
(LocP
, Chars
(Arg
))),
12223 Make_Pragma_Argument_Association
(Sloc
(Argx
),
12224 Expression
=> Argx
))));
12229 -- Rewrite original Check_Policy pragma to null, since we
12230 -- have converted it into a series of old syntax pragmas.
12232 Rewrite
(N
, Make_Null_Statement
(Loc
));
12242 -- pragma Comment (static_string_EXPRESSION)
12244 -- Processing for pragma Comment shares the circuitry for pragma
12245 -- Ident. The only differences are that Ident enforces a limit of 31
12246 -- characters on its argument, and also enforces limitations on
12247 -- placement for DEC compatibility. Pragma Comment shares neither of
12248 -- these restrictions.
12250 -------------------
12251 -- Common_Object --
12252 -------------------
12254 -- pragma Common_Object (
12255 -- [Internal =>] LOCAL_NAME
12256 -- [, [External =>] EXTERNAL_SYMBOL]
12257 -- [, [Size =>] EXTERNAL_SYMBOL]);
12259 -- Processing for this pragma is shared with Psect_Object
12261 ------------------------
12262 -- Compile_Time_Error --
12263 ------------------------
12265 -- pragma Compile_Time_Error
12266 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12268 when Pragma_Compile_Time_Error
=>
12270 Process_Compile_Time_Warning_Or_Error
;
12272 --------------------------
12273 -- Compile_Time_Warning --
12274 --------------------------
12276 -- pragma Compile_Time_Warning
12277 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12279 when Pragma_Compile_Time_Warning
=>
12281 Process_Compile_Time_Warning_Or_Error
;
12283 ---------------------------
12284 -- Compiler_Unit_Warning --
12285 ---------------------------
12287 -- pragma Compiler_Unit_Warning;
12291 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12292 -- errors not warnings. This means that we had introduced a big extra
12293 -- inertia to compiler changes, since even if we implemented a new
12294 -- feature, and even if all versions to be used for bootstrapping
12295 -- implemented this new feature, we could not use it, since old
12296 -- compilers would give errors for using this feature in units
12297 -- having Compiler_Unit pragmas.
12299 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12300 -- problem. We no longer have any units mentioning Compiler_Unit,
12301 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12302 -- and thus generates a warning which can be ignored. So that deals
12303 -- with the problem of old compilers not implementing the newer form
12306 -- Newer compilers recognize the new pragma, but generate warning
12307 -- messages instead of errors, which again can be ignored in the
12308 -- case of an old compiler which implements a wanted new feature
12309 -- but at the time felt like warning about it for older compilers.
12311 -- We retain Compiler_Unit so that new compilers can be used to build
12312 -- older run-times that use this pragma. That's an unusual case, but
12313 -- it's easy enough to handle, so why not?
12315 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12317 Check_Arg_Count
(0);
12319 -- Only recognized in main unit
12321 if Current_Sem_Unit
= Main_Unit
then
12322 Compiler_Unit
:= True;
12325 -----------------------------
12326 -- Complete_Representation --
12327 -----------------------------
12329 -- pragma Complete_Representation;
12331 when Pragma_Complete_Representation
=>
12333 Check_Arg_Count
(0);
12335 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12337 ("pragma & must appear within record representation clause");
12340 ----------------------------
12341 -- Complex_Representation --
12342 ----------------------------
12344 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12346 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12353 Check_Arg_Count
(1);
12354 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12355 Check_Arg_Is_Local_Name
(Arg1
);
12356 E_Id
:= Get_Pragma_Arg
(Arg1
);
12358 if Etype
(E_Id
) = Any_Type
then
12362 E
:= Entity
(E_Id
);
12364 if not Is_Record_Type
(E
) then
12366 ("argument for pragma% must be record type", Arg1
);
12369 Ent
:= First_Entity
(E
);
12372 or else No
(Next_Entity
(Ent
))
12373 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12374 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12375 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12378 ("record for pragma% must have two fields of the same "
12379 & "floating-point type", Arg1
);
12382 Set_Has_Complex_Representation
(Base_Type
(E
));
12384 -- We need to treat the type has having a non-standard
12385 -- representation, for back-end purposes, even though in
12386 -- general a complex will have the default representation
12387 -- of a record with two real components.
12389 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12391 end Complex_Representation
;
12393 -------------------------
12394 -- Component_Alignment --
12395 -------------------------
12397 -- pragma Component_Alignment (
12398 -- [Form =>] ALIGNMENT_CHOICE
12399 -- [, [Name =>] type_LOCAL_NAME]);
12401 -- ALIGNMENT_CHOICE ::=
12403 -- | Component_Size_4
12407 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12408 Args
: Args_List
(1 .. 2);
12409 Names
: constant Name_List
(1 .. 2) := (
12413 Form
: Node_Id
renames Args
(1);
12414 Name
: Node_Id
renames Args
(2);
12416 Atype
: Component_Alignment_Kind
;
12421 Gather_Associations
(Names
, Args
);
12424 Error_Pragma
("missing Form argument for pragma%");
12427 Check_Arg_Is_Identifier
(Form
);
12429 -- Get proper alignment, note that Default = Component_Size on all
12430 -- machines we have so far, and we want to set this value rather
12431 -- than the default value to indicate that it has been explicitly
12432 -- set (and thus will not get overridden by the default component
12433 -- alignment for the current scope)
12435 if Chars
(Form
) = Name_Component_Size
then
12436 Atype
:= Calign_Component_Size
;
12438 elsif Chars
(Form
) = Name_Component_Size_4
then
12439 Atype
:= Calign_Component_Size_4
;
12441 elsif Chars
(Form
) = Name_Default
then
12442 Atype
:= Calign_Component_Size
;
12444 elsif Chars
(Form
) = Name_Storage_Unit
then
12445 Atype
:= Calign_Storage_Unit
;
12449 ("invalid Form parameter for pragma%", Form
);
12452 -- Case with no name, supplied, affects scope table entry
12456 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12458 -- Case of name supplied
12461 Check_Arg_Is_Local_Name
(Name
);
12463 Typ
:= Entity
(Name
);
12466 or else Rep_Item_Too_Early
(Typ
, N
)
12470 Typ
:= Underlying_Type
(Typ
);
12473 if not Is_Record_Type
(Typ
)
12474 and then not Is_Array_Type
(Typ
)
12477 ("Name parameter of pragma% must identify record or "
12478 & "array type", Name
);
12481 -- An explicit Component_Alignment pragma overrides an
12482 -- implicit pragma Pack, but not an explicit one.
12484 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12485 Set_Is_Packed
(Base_Type
(Typ
), False);
12486 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12489 end Component_AlignmentP
;
12491 --------------------------------
12492 -- Constant_After_Elaboration --
12493 --------------------------------
12495 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
12497 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
12499 Obj_Decl
: Node_Id
;
12500 Obj_Id
: Entity_Id
;
12504 Check_No_Identifiers
;
12505 Check_At_Most_N_Arguments
(1);
12507 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
12509 -- Object declaration
12511 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
12514 -- Otherwise the pragma is associated with an illegal construct
12521 Obj_Id
:= Defining_Entity
(Obj_Decl
);
12523 -- The object declaration must be a library-level variable with
12524 -- an initialization expression. The expression must depend on
12525 -- a variable, parameter, or another constant_after_elaboration,
12526 -- but the compiler cannot detect this property, as this requires
12527 -- full flow analysis (SPARK RM 3.3.1).
12529 if Ekind
(Obj_Id
) = E_Variable
then
12530 if not Is_Library_Level_Entity
(Obj_Id
) then
12532 ("pragma % must apply to a library level variable");
12535 elsif not Has_Init_Expression
(Obj_Decl
) then
12537 ("pragma % must apply to a variable with initialization "
12541 -- Otherwise the pragma applies to a constant, which is illegal
12544 Error_Pragma
("pragma % must apply to a variable declaration");
12548 -- Chain the pragma on the contract for completeness
12550 Add_Contract_Item
(N
, Obj_Id
);
12552 -- A pragma that applies to a Ghost entity becomes Ghost for the
12553 -- purposes of legality checks and removal of ignored Ghost code.
12555 Mark_Pragma_As_Ghost
(N
, Obj_Id
);
12557 -- Analyze the Boolean expression (if any)
12559 if Present
(Arg1
) then
12560 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
12562 end Constant_After_Elaboration
;
12564 --------------------
12565 -- Contract_Cases --
12566 --------------------
12568 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12570 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12572 -- CASE_GUARD ::= boolean_EXPRESSION | others
12574 -- CONSEQUENCE ::= boolean_EXPRESSION
12576 -- Characteristics:
12578 -- * Analysis - The annotation undergoes initial checks to verify
12579 -- the legal placement and context. Secondary checks preanalyze the
12582 -- Analyze_Contract_Cases_In_Decl_Part
12584 -- * Expansion - The annotation is expanded during the expansion of
12585 -- the related subprogram [body] contract as performed in:
12587 -- Expand_Subprogram_Contract
12589 -- * Template - The annotation utilizes the generic template of the
12590 -- related subprogram [body] when it is:
12592 -- aspect on subprogram declaration
12593 -- aspect on stand alone subprogram body
12594 -- pragma on stand alone subprogram body
12596 -- The annotation must prepare its own template when it is:
12598 -- pragma on subprogram declaration
12600 -- * Globals - Capture of global references must occur after full
12603 -- * Instance - The annotation is instantiated automatically when
12604 -- the related generic subprogram [body] is instantiated except for
12605 -- the "pragma on subprogram declaration" case. In that scenario
12606 -- the annotation must instantiate itself.
12608 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12609 Spec_Id
: Entity_Id
;
12610 Subp_Decl
: Node_Id
;
12614 Check_No_Identifiers
;
12615 Check_Arg_Count
(1);
12617 -- Ensure the proper placement of the pragma. Contract_Cases must
12618 -- be associated with a subprogram declaration or a body that acts
12622 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
12624 -- Generic subprogram
12626 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
12629 -- Body acts as spec
12631 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12632 and then No
(Corresponding_Spec
(Subp_Decl
))
12636 -- Body stub acts as spec
12638 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12639 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12645 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12653 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
12655 -- Chain the pragma on the contract for further processing by
12656 -- Analyze_Contract_Cases_In_Decl_Part.
12658 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12660 -- A pragma that applies to a Ghost entity becomes Ghost for the
12661 -- purposes of legality checks and removal of ignored Ghost code.
12663 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
12664 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
12666 -- Fully analyze the pragma when it appears inside an entry
12667 -- or subprogram body because it cannot benefit from forward
12670 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
12672 N_Subprogram_Body_Stub
)
12674 -- The legality checks of pragma Contract_Cases are affected by
12675 -- the SPARK mode in effect and the volatility of the context.
12676 -- Analyze all pragmas in a specific order.
12678 Analyze_If_Present
(Pragma_SPARK_Mode
);
12679 Analyze_If_Present
(Pragma_Volatile_Function
);
12680 Analyze_Contract_Cases_In_Decl_Part
(N
);
12682 end Contract_Cases
;
12688 -- pragma Controlled (first_subtype_LOCAL_NAME);
12690 when Pragma_Controlled
=> Controlled
: declare
12694 Check_No_Identifiers
;
12695 Check_Arg_Count
(1);
12696 Check_Arg_Is_Local_Name
(Arg1
);
12697 Arg
:= Get_Pragma_Arg
(Arg1
);
12699 if not Is_Entity_Name
(Arg
)
12700 or else not Is_Access_Type
(Entity
(Arg
))
12702 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12704 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12712 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12713 -- [Entity =>] LOCAL_NAME);
12715 when Pragma_Convention
=> Convention
: declare
12718 pragma Warnings
(Off
, C
);
12719 pragma Warnings
(Off
, E
);
12721 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12722 Check_Ada_83_Warning
;
12723 Check_Arg_Count
(2);
12724 Process_Convention
(C
, E
);
12726 -- A pragma that applies to a Ghost entity becomes Ghost for the
12727 -- purposes of legality checks and removal of ignored Ghost code.
12729 Mark_Pragma_As_Ghost
(N
, E
);
12732 ---------------------------
12733 -- Convention_Identifier --
12734 ---------------------------
12736 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12737 -- [Convention =>] convention_IDENTIFIER);
12739 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12745 Check_Arg_Order
((Name_Name
, Name_Convention
));
12746 Check_Arg_Count
(2);
12747 Check_Optional_Identifier
(Arg1
, Name_Name
);
12748 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12749 Check_Arg_Is_Identifier
(Arg1
);
12750 Check_Arg_Is_Identifier
(Arg2
);
12751 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12752 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12754 if Is_Convention_Name
(Cname
) then
12755 Record_Convention_Identifier
12756 (Idnam
, Get_Convention_Id
(Cname
));
12759 ("second arg for % pragma must be convention", Arg2
);
12761 end Convention_Identifier
;
12767 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12769 when Pragma_CPP_Class
=> CPP_Class
: declare
12773 if Warn_On_Obsolescent_Feature
then
12775 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12776 & "effect; replace it by pragma import?j?", N
);
12779 Check_Arg_Count
(1);
12783 Chars
=> Name_Import
,
12784 Pragma_Argument_Associations
=> New_List
(
12785 Make_Pragma_Argument_Association
(Loc
,
12786 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12787 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12791 ---------------------
12792 -- CPP_Constructor --
12793 ---------------------
12795 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12796 -- [, [External_Name =>] static_string_EXPRESSION ]
12797 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12799 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12802 Def_Id
: Entity_Id
;
12803 Tag_Typ
: Entity_Id
;
12807 Check_At_Least_N_Arguments
(1);
12808 Check_At_Most_N_Arguments
(3);
12809 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12810 Check_Arg_Is_Local_Name
(Arg1
);
12812 Id
:= Get_Pragma_Arg
(Arg1
);
12813 Find_Program_Unit_Name
(Id
);
12815 -- If we did not find the name, we are done
12817 if Etype
(Id
) = Any_Type
then
12821 Def_Id
:= Entity
(Id
);
12823 -- Check if already defined as constructor
12825 if Is_Constructor
(Def_Id
) then
12827 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12831 if Ekind
(Def_Id
) = E_Function
12832 and then (Is_CPP_Class
(Etype
(Def_Id
))
12833 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12835 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12837 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12839 ("'C'P'P constructor must be defined in the scope of "
12840 & "its returned type", Arg1
);
12843 if Arg_Count
>= 2 then
12844 Set_Imported
(Def_Id
);
12845 Set_Is_Public
(Def_Id
);
12846 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12849 Set_Has_Completion
(Def_Id
);
12850 Set_Is_Constructor
(Def_Id
);
12851 Set_Convention
(Def_Id
, Convention_CPP
);
12853 -- Imported C++ constructors are not dispatching primitives
12854 -- because in C++ they don't have a dispatch table slot.
12855 -- However, in Ada the constructor has the profile of a
12856 -- function that returns a tagged type and therefore it has
12857 -- been treated as a primitive operation during semantic
12858 -- analysis. We now remove it from the list of primitive
12859 -- operations of the type.
12861 if Is_Tagged_Type
(Etype
(Def_Id
))
12862 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12863 and then Is_Dispatching_Operation
(Def_Id
)
12865 Tag_Typ
:= Etype
(Def_Id
);
12867 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12868 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12872 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12873 Set_Is_Dispatching_Operation
(Def_Id
, False);
12876 -- For backward compatibility, if the constructor returns a
12877 -- class wide type, and we internally change the return type to
12878 -- the corresponding root type.
12880 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12881 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12885 ("pragma% requires function returning a 'C'P'P_Class type",
12888 end CPP_Constructor
;
12894 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12898 if Warn_On_Obsolescent_Feature
then
12900 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12909 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12913 if Warn_On_Obsolescent_Feature
then
12915 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12924 -- pragma CPU (EXPRESSION);
12926 when Pragma_CPU
=> CPU
: declare
12927 P
: constant Node_Id
:= Parent
(N
);
12933 Check_No_Identifiers
;
12934 Check_Arg_Count
(1);
12938 if Nkind
(P
) = N_Subprogram_Body
then
12939 Check_In_Main_Program
;
12941 Arg
:= Get_Pragma_Arg
(Arg1
);
12942 Analyze_And_Resolve
(Arg
, Any_Integer
);
12944 Ent
:= Defining_Unit_Name
(Specification
(P
));
12946 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12947 Ent
:= Defining_Identifier
(Ent
);
12952 if not Is_OK_Static_Expression
(Arg
) then
12953 Flag_Non_Static_Expr
12954 ("main subprogram affinity is not static!", Arg
);
12957 -- If constraint error, then we already signalled an error
12959 elsif Raises_Constraint_Error
(Arg
) then
12962 -- Otherwise check in range
12966 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12967 -- This is the entity System.Multiprocessors.CPU_Range;
12969 Val
: constant Uint
:= Expr_Value
(Arg
);
12972 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12974 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12977 ("main subprogram CPU is out of range", Arg1
);
12983 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12987 elsif Nkind
(P
) = N_Task_Definition
then
12988 Arg
:= Get_Pragma_Arg
(Arg1
);
12989 Ent
:= Defining_Identifier
(Parent
(P
));
12991 -- The expression must be analyzed in the special manner
12992 -- described in "Handling of Default and Per-Object
12993 -- Expressions" in sem.ads.
12995 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12997 -- Anything else is incorrect
13003 -- Check duplicate pragma before we chain the pragma in the Rep
13004 -- Item chain of Ent.
13006 Check_Duplicate_Pragma
(Ent
);
13007 Record_Rep_Item
(Ent
, N
);
13014 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13016 when Pragma_Debug
=> Debug
: declare
13023 -- The condition for executing the call is that the expander
13024 -- is active and that we are not ignoring this debug pragma.
13029 (Expander_Active
and then not Is_Ignored
(N
)),
13032 if not Is_Ignored
(N
) then
13033 Set_SCO_Pragma_Enabled
(Loc
);
13036 if Arg_Count
= 2 then
13038 Make_And_Then
(Loc
,
13039 Left_Opnd
=> Relocate_Node
(Cond
),
13040 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
13041 Call
:= Get_Pragma_Arg
(Arg2
);
13043 Call
:= Get_Pragma_Arg
(Arg1
);
13047 N_Indexed_Component
,
13051 N_Selected_Component
)
13053 -- If this pragma Debug comes from source, its argument was
13054 -- parsed as a name form (which is syntactically identical).
13055 -- In a generic context a parameterless call will be left as
13056 -- an expanded name (if global) or selected_component if local.
13057 -- Change it to a procedure call statement now.
13059 Change_Name_To_Procedure_Call_Statement
(Call
);
13061 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
13063 -- Already in the form of a procedure call statement: nothing
13064 -- to do (could happen in case of an internally generated
13070 -- All other cases: diagnose error
13073 ("argument of pragma ""Debug"" is not procedure call",
13078 -- Rewrite into a conditional with an appropriate condition. We
13079 -- wrap the procedure call in a block so that overhead from e.g.
13080 -- use of the secondary stack does not generate execution overhead
13081 -- for suppressed conditions.
13083 -- Normally the analysis that follows will freeze the subprogram
13084 -- being called. However, if the call is to a null procedure,
13085 -- we want to freeze it before creating the block, because the
13086 -- analysis that follows may be done with expansion disabled, in
13087 -- which case the body will not be generated, leading to spurious
13090 if Nkind
(Call
) = N_Procedure_Call_Statement
13091 and then Is_Entity_Name
(Name
(Call
))
13093 Analyze
(Name
(Call
));
13094 Freeze_Before
(N
, Entity
(Name
(Call
)));
13098 Make_Implicit_If_Statement
(N
,
13100 Then_Statements
=> New_List
(
13101 Make_Block_Statement
(Loc
,
13102 Handled_Statement_Sequence
=>
13103 Make_Handled_Sequence_Of_Statements
(Loc
,
13104 Statements
=> New_List
(Relocate_Node
(Call
)))))));
13107 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13108 -- after analysis of the normally rewritten node, to capture all
13109 -- references to entities, which avoids issuing wrong warnings
13110 -- about unused entities.
13112 if GNATprove_Mode
then
13113 Rewrite
(N
, Make_Null_Statement
(Loc
));
13121 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13123 when Pragma_Debug_Policy
=>
13125 Check_Arg_Count
(1);
13126 Check_No_Identifiers
;
13127 Check_Arg_Is_Identifier
(Arg1
);
13129 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13130 -- rewrite it that way, and let the rest of the checking come
13131 -- from analyzing the rewritten pragma.
13135 Chars
=> Name_Check_Policy
,
13136 Pragma_Argument_Associations
=> New_List
(
13137 Make_Pragma_Argument_Association
(Loc
,
13138 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
13140 Make_Pragma_Argument_Association
(Loc
,
13141 Expression
=> Get_Pragma_Arg
(Arg1
)))));
13144 -------------------------------
13145 -- Default_Initial_Condition --
13146 -------------------------------
13148 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
13150 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
13157 Check_No_Identifiers
;
13158 Check_At_Most_N_Arguments
(1);
13161 while Present
(Stmt
) loop
13163 -- Skip prior pragmas, but check for duplicates
13165 if Nkind
(Stmt
) = N_Pragma
then
13166 if Pragma_Name
(Stmt
) = Pname
then
13167 Error_Msg_Name_1
:= Pname
;
13168 Error_Msg_Sloc
:= Sloc
(Stmt
);
13169 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
13172 -- Skip internally generated code
13174 elsif not Comes_From_Source
(Stmt
) then
13177 -- The associated private type [extension] has been found, stop
13180 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
13181 N_Private_Type_Declaration
)
13183 Typ
:= Defining_Entity
(Stmt
);
13186 -- The pragma does not apply to a legal construct, issue an
13187 -- error and stop the analysis.
13194 Stmt
:= Prev
(Stmt
);
13197 -- A pragma that applies to a Ghost entity becomes Ghost for the
13198 -- purposes of legality checks and removal of ignored Ghost code.
13200 Mark_Pragma_As_Ghost
(N
, Typ
);
13201 Set_Has_Default_Init_Cond
(Typ
);
13202 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
13204 -- Chain the pragma on the rep item chain for further processing
13206 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
13207 end Default_Init_Cond
;
13209 ----------------------------------
13210 -- Default_Scalar_Storage_Order --
13211 ----------------------------------
13213 -- pragma Default_Scalar_Storage_Order
13214 -- (High_Order_First | Low_Order_First);
13216 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
13217 Default
: Character;
13221 Check_Arg_Count
(1);
13223 -- Default_Scalar_Storage_Order can appear as a configuration
13224 -- pragma, or in a declarative part of a package spec.
13226 if not Is_Configuration_Pragma
then
13227 Check_Is_In_Decl_Part_Or_Package_Spec
;
13230 Check_No_Identifiers
;
13231 Check_Arg_Is_One_Of
13232 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
13233 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13234 Default
:= Fold_Upper
(Name_Buffer
(1));
13236 if not Support_Nondefault_SSO_On_Target
13237 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
13239 if Warn_On_Unrecognized_Pragma
then
13241 ("non-default Scalar_Storage_Order not supported "
13242 & "on target?g?", N
);
13244 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
13247 -- Here set the specified default
13250 Opt
.Default_SSO
:= Default
;
13254 --------------------------
13255 -- Default_Storage_Pool --
13256 --------------------------
13258 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13260 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
13265 Check_Arg_Count
(1);
13267 -- Default_Storage_Pool can appear as a configuration pragma, or
13268 -- in a declarative part of a package spec.
13270 if not Is_Configuration_Pragma
then
13271 Check_Is_In_Decl_Part_Or_Package_Spec
;
13274 if Present
(Arg1
) then
13275 Pool
:= Get_Pragma_Arg
(Arg1
);
13277 -- Case of Default_Storage_Pool (null);
13279 if Nkind
(Pool
) = N_Null
then
13282 -- This is an odd case, this is not really an expression,
13283 -- so we don't have a type for it. So just set the type to
13286 Set_Etype
(Pool
, Empty
);
13288 -- Case of Default_Storage_Pool (storage_pool_NAME);
13291 -- If it's a configuration pragma, then the only allowed
13292 -- argument is "null".
13294 if Is_Configuration_Pragma
then
13295 Error_Pragma_Arg
("NULL expected", Arg1
);
13298 -- The expected type for a non-"null" argument is
13299 -- Root_Storage_Pool'Class, and the pool must be a variable.
13301 Analyze_And_Resolve
13302 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
13304 if Is_Variable
(Pool
) then
13306 -- A pragma that applies to a Ghost entity becomes Ghost
13307 -- for the purposes of legality checks and removal of
13308 -- ignored Ghost code.
13310 Mark_Pragma_As_Ghost
(N
, Entity
(Pool
));
13314 ("default storage pool must be a variable", Arg1
);
13318 -- Record the pool name (or null). Freeze.Freeze_Entity for an
13319 -- access type will use this information to set the appropriate
13320 -- attributes of the access type.
13322 Default_Pool
:= Pool
;
13324 end Default_Storage_Pool
;
13330 -- pragma Depends (DEPENDENCY_RELATION);
13332 -- DEPENDENCY_RELATION ::=
13334 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
13336 -- DEPENDENCY_CLAUSE ::=
13337 -- OUTPUT_LIST =>[+] INPUT_LIST
13338 -- | NULL_DEPENDENCY_CLAUSE
13340 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13342 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13344 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13346 -- OUTPUT ::= NAME | FUNCTION_RESULT
13349 -- where FUNCTION_RESULT is a function Result attribute_reference
13351 -- Characteristics:
13353 -- * Analysis - The annotation undergoes initial checks to verify
13354 -- the legal placement and context. Secondary checks fully analyze
13355 -- the dependency clauses in:
13357 -- Analyze_Depends_In_Decl_Part
13359 -- * Expansion - None.
13361 -- * Template - The annotation utilizes the generic template of the
13362 -- related subprogram [body] when it is:
13364 -- aspect on subprogram declaration
13365 -- aspect on stand alone subprogram body
13366 -- pragma on stand alone subprogram body
13368 -- The annotation must prepare its own template when it is:
13370 -- pragma on subprogram declaration
13372 -- * Globals - Capture of global references must occur after full
13375 -- * Instance - The annotation is instantiated automatically when
13376 -- the related generic subprogram [body] is instantiated except for
13377 -- the "pragma on subprogram declaration" case. In that scenario
13378 -- the annotation must instantiate itself.
13380 when Pragma_Depends
=> Depends
: declare
13382 Spec_Id
: Entity_Id
;
13383 Subp_Decl
: Node_Id
;
13386 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
13390 -- Chain the pragma on the contract for further processing by
13391 -- Analyze_Depends_In_Decl_Part.
13393 Add_Contract_Item
(N
, Spec_Id
);
13395 -- Fully analyze the pragma when it appears inside an entry
13396 -- or subprogram body because it cannot benefit from forward
13399 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
13401 N_Subprogram_Body_Stub
)
13403 -- The legality checks of pragmas Depends and Global are
13404 -- affected by the SPARK mode in effect and the volatility
13405 -- of the context. In addition these two pragmas are subject
13406 -- to an inherent order:
13411 -- Analyze all these pragmas in the order outlined above
13413 Analyze_If_Present
(Pragma_SPARK_Mode
);
13414 Analyze_If_Present
(Pragma_Volatile_Function
);
13415 Analyze_If_Present
(Pragma_Global
);
13416 Analyze_Depends_In_Decl_Part
(N
);
13421 ---------------------
13422 -- Detect_Blocking --
13423 ---------------------
13425 -- pragma Detect_Blocking;
13427 when Pragma_Detect_Blocking
=>
13429 Check_Arg_Count
(0);
13430 Check_Valid_Configuration_Pragma
;
13431 Detect_Blocking
:= True;
13433 ------------------------------------
13434 -- Disable_Atomic_Synchronization --
13435 ------------------------------------
13437 -- pragma Disable_Atomic_Synchronization [(Entity)];
13439 when Pragma_Disable_Atomic_Synchronization
=>
13441 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
13443 -------------------
13444 -- Discard_Names --
13445 -------------------
13447 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13449 when Pragma_Discard_Names
=> Discard_Names
: declare
13454 Check_Ada_83_Warning
;
13456 -- Deal with configuration pragma case
13458 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
13459 Global_Discard_Names
:= True;
13462 -- Otherwise, check correct appropriate context
13465 Check_Is_In_Decl_Part_Or_Package_Spec
;
13467 if Arg_Count
= 0 then
13469 -- If there is no parameter, then from now on this pragma
13470 -- applies to any enumeration, exception or tagged type
13471 -- defined in the current declarative part, and recursively
13472 -- to any nested scope.
13474 Set_Discard_Names
(Current_Scope
);
13478 Check_Arg_Count
(1);
13479 Check_Optional_Identifier
(Arg1
, Name_On
);
13480 Check_Arg_Is_Local_Name
(Arg1
);
13482 E_Id
:= Get_Pragma_Arg
(Arg1
);
13484 if Etype
(E_Id
) = Any_Type
then
13487 E
:= Entity
(E_Id
);
13490 -- A pragma that applies to a Ghost entity becomes Ghost for
13491 -- the purposes of legality checks and removal of ignored
13494 Mark_Pragma_As_Ghost
(N
, E
);
13496 if (Is_First_Subtype
(E
)
13498 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
13499 or else Ekind
(E
) = E_Exception
13501 Set_Discard_Names
(E
);
13502 Record_Rep_Item
(E
, N
);
13506 ("inappropriate entity for pragma%", Arg1
);
13512 ------------------------
13513 -- Dispatching_Domain --
13514 ------------------------
13516 -- pragma Dispatching_Domain (EXPRESSION);
13518 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13519 P
: constant Node_Id
:= Parent
(N
);
13525 Check_No_Identifiers
;
13526 Check_Arg_Count
(1);
13528 -- This pragma is born obsolete, but not the aspect
13530 if not From_Aspect_Specification
(N
) then
13532 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13535 if Nkind
(P
) = N_Task_Definition
then
13536 Arg
:= Get_Pragma_Arg
(Arg1
);
13537 Ent
:= Defining_Identifier
(Parent
(P
));
13539 -- A pragma that applies to a Ghost entity becomes Ghost for
13540 -- the purposes of legality checks and removal of ignored Ghost
13543 Mark_Pragma_As_Ghost
(N
, Ent
);
13545 -- The expression must be analyzed in the special manner
13546 -- described in "Handling of Default and Per-Object
13547 -- Expressions" in sem.ads.
13549 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13551 -- Check duplicate pragma before we chain the pragma in the Rep
13552 -- Item chain of Ent.
13554 Check_Duplicate_Pragma
(Ent
);
13555 Record_Rep_Item
(Ent
, N
);
13557 -- Anything else is incorrect
13562 end Dispatching_Domain
;
13568 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13570 when Pragma_Elaborate
=> Elaborate
: declare
13575 -- Pragma must be in context items list of a compilation unit
13577 if not Is_In_Context_Clause
then
13581 -- Must be at least one argument
13583 if Arg_Count
= 0 then
13584 Error_Pragma
("pragma% requires at least one argument");
13587 -- In Ada 83 mode, there can be no items following it in the
13588 -- context list except other pragmas and implicit with clauses
13589 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13590 -- placement rule does not apply.
13592 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13594 while Present
(Citem
) loop
13595 if Nkind
(Citem
) = N_Pragma
13596 or else (Nkind
(Citem
) = N_With_Clause
13597 and then Implicit_With
(Citem
))
13602 ("(Ada 83) pragma% must be at end of context clause");
13609 -- Finally, the arguments must all be units mentioned in a with
13610 -- clause in the same context clause. Note we already checked (in
13611 -- Par.Prag) that the arguments are all identifiers or selected
13615 Outer
: while Present
(Arg
) loop
13616 Citem
:= First
(List_Containing
(N
));
13617 Inner
: while Citem
/= N
loop
13618 if Nkind
(Citem
) = N_With_Clause
13619 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13621 Set_Elaborate_Present
(Citem
, True);
13622 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13624 -- With the pragma present, elaboration calls on
13625 -- subprograms from the named unit need no further
13626 -- checks, as long as the pragma appears in the current
13627 -- compilation unit. If the pragma appears in some unit
13628 -- in the context, there might still be a need for an
13629 -- Elaborate_All_Desirable from the current compilation
13630 -- to the named unit, so we keep the check enabled.
13632 if In_Extended_Main_Source_Unit
(N
) then
13634 -- This does not apply in SPARK mode, where we allow
13635 -- pragma Elaborate, but we don't trust it to be right
13636 -- so we will still insist on the Elaborate_All.
13638 if SPARK_Mode
/= On
then
13639 Set_Suppress_Elaboration_Warnings
13640 (Entity
(Name
(Citem
)));
13652 ("argument of pragma% is not withed unit", Arg
);
13658 -- Give a warning if operating in static mode with one of the
13659 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13662 and not Dynamic_Elaboration_Checks
13664 -- pragma Elaborate not allowed in SPARK mode anyway. We
13665 -- already complained about it, no point in generating any
13666 -- further complaint.
13668 and SPARK_Mode
/= On
13671 ("?l?use of pragma Elaborate may not be safe", N
);
13673 ("?l?use pragma Elaborate_All instead if possible", N
);
13677 -------------------
13678 -- Elaborate_All --
13679 -------------------
13681 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13683 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13688 Check_Ada_83_Warning
;
13690 -- Pragma must be in context items list of a compilation unit
13692 if not Is_In_Context_Clause
then
13696 -- Must be at least one argument
13698 if Arg_Count
= 0 then
13699 Error_Pragma
("pragma% requires at least one argument");
13702 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13703 -- have to appear at the end of the context clause, but may
13704 -- appear mixed in with other items, even in Ada 83 mode.
13706 -- Final check: the arguments must all be units mentioned in
13707 -- a with clause in the same context clause. Note that we
13708 -- already checked (in Par.Prag) that all the arguments are
13709 -- either identifiers or selected components.
13712 Outr
: while Present
(Arg
) loop
13713 Citem
:= First
(List_Containing
(N
));
13714 Innr
: while Citem
/= N
loop
13715 if Nkind
(Citem
) = N_With_Clause
13716 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13718 Set_Elaborate_All_Present
(Citem
, True);
13719 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13721 -- Suppress warnings and elaboration checks on the named
13722 -- unit if the pragma is in the current compilation, as
13723 -- for pragma Elaborate.
13725 if In_Extended_Main_Source_Unit
(N
) then
13726 Set_Suppress_Elaboration_Warnings
13727 (Entity
(Name
(Citem
)));
13736 Set_Error_Posted
(N
);
13738 ("argument of pragma% is not withed unit", Arg
);
13745 --------------------
13746 -- Elaborate_Body --
13747 --------------------
13749 -- pragma Elaborate_Body [( library_unit_NAME )];
13751 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13752 Cunit_Node
: Node_Id
;
13753 Cunit_Ent
: Entity_Id
;
13756 Check_Ada_83_Warning
;
13757 Check_Valid_Library_Unit_Pragma
;
13759 if Nkind
(N
) = N_Null_Statement
then
13763 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13764 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13766 -- A pragma that applies to a Ghost entity becomes Ghost for the
13767 -- purposes of legality checks and removal of ignored Ghost code.
13769 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
13771 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13774 Error_Pragma
("pragma% must refer to a spec, not a body");
13776 Set_Body_Required
(Cunit_Node
, True);
13777 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13779 -- If we are in dynamic elaboration mode, then we suppress
13780 -- elaboration warnings for the unit, since it is definitely
13781 -- fine NOT to do dynamic checks at the first level (and such
13782 -- checks will be suppressed because no elaboration boolean
13783 -- is created for Elaborate_Body packages).
13785 -- But in the static model of elaboration, Elaborate_Body is
13786 -- definitely NOT good enough to ensure elaboration safety on
13787 -- its own, since the body may WITH other units that are not
13788 -- safe from an elaboration point of view, so a client must
13789 -- still do an Elaborate_All on such units.
13791 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13792 -- Elaborate_Body always suppressed elab warnings.
13794 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13795 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13798 end Elaborate_Body
;
13800 ------------------------
13801 -- Elaboration_Checks --
13802 ------------------------
13804 -- pragma Elaboration_Checks (Static | Dynamic);
13806 when Pragma_Elaboration_Checks
=>
13808 Check_Arg_Count
(1);
13809 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13811 -- Set flag accordingly (ignore attempt at dynamic elaboration
13812 -- checks in SPARK mode).
13814 Dynamic_Elaboration_Checks
:=
13815 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
)
13816 and then SPARK_Mode
/= On
;
13822 -- pragma Eliminate (
13823 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13824 -- [,[Entity =>] IDENTIFIER |
13825 -- SELECTED_COMPONENT |
13827 -- [, OVERLOADING_RESOLUTION]);
13829 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13832 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13833 -- FUNCTION_PROFILE
13835 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13837 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13838 -- Result_Type => result_SUBTYPE_NAME]
13840 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13841 -- SUBTYPE_NAME ::= STRING_LITERAL
13843 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13844 -- SOURCE_TRACE ::= STRING_LITERAL
13846 when Pragma_Eliminate
=> Eliminate
: declare
13847 Args
: Args_List
(1 .. 5);
13848 Names
: constant Name_List
(1 .. 5) := (
13851 Name_Parameter_Types
,
13853 Name_Source_Location
);
13855 Unit_Name
: Node_Id
renames Args
(1);
13856 Entity
: Node_Id
renames Args
(2);
13857 Parameter_Types
: Node_Id
renames Args
(3);
13858 Result_Type
: Node_Id
renames Args
(4);
13859 Source_Location
: Node_Id
renames Args
(5);
13863 Check_Valid_Configuration_Pragma
;
13864 Gather_Associations
(Names
, Args
);
13866 if No
(Unit_Name
) then
13867 Error_Pragma
("missing Unit_Name argument for pragma%");
13871 and then (Present
(Parameter_Types
)
13873 Present
(Result_Type
)
13875 Present
(Source_Location
))
13877 Error_Pragma
("missing Entity argument for pragma%");
13880 if (Present
(Parameter_Types
)
13882 Present
(Result_Type
))
13884 Present
(Source_Location
)
13887 ("parameter profile and source location cannot be used "
13888 & "together in pragma%");
13891 Process_Eliminate_Pragma
13900 -----------------------------------
13901 -- Enable_Atomic_Synchronization --
13902 -----------------------------------
13904 -- pragma Enable_Atomic_Synchronization [(Entity)];
13906 when Pragma_Enable_Atomic_Synchronization
=>
13908 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13915 -- [ Convention =>] convention_IDENTIFIER,
13916 -- [ Entity =>] LOCAL_NAME
13917 -- [, [External_Name =>] static_string_EXPRESSION ]
13918 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13920 when Pragma_Export
=> Export
: declare
13922 Def_Id
: Entity_Id
;
13924 pragma Warnings
(Off
, C
);
13927 Check_Ada_83_Warning
;
13931 Name_External_Name
,
13934 Check_At_Least_N_Arguments
(2);
13935 Check_At_Most_N_Arguments
(4);
13937 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13938 -- pragma Export (Entity, "external name");
13940 if Relaxed_RM_Semantics
13941 and then Arg_Count
= 2
13942 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13945 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13948 if not Is_Entity_Name
(Def_Id
) then
13949 Error_Pragma_Arg
("entity name required", Arg1
);
13952 Def_Id
:= Entity
(Def_Id
);
13953 Set_Exported
(Def_Id
, Arg1
);
13956 Process_Convention
(C
, Def_Id
);
13958 -- A pragma that applies to a Ghost entity becomes Ghost for
13959 -- the purposes of legality checks and removal of ignored Ghost
13962 Mark_Pragma_As_Ghost
(N
, Def_Id
);
13964 if Ekind
(Def_Id
) /= E_Constant
then
13965 Note_Possible_Modification
13966 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13969 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13970 Set_Exported
(Def_Id
, Arg2
);
13973 -- If the entity is a deferred constant, propagate the information
13974 -- to the full view, because gigi elaborates the full view only.
13976 if Ekind
(Def_Id
) = E_Constant
13977 and then Present
(Full_View
(Def_Id
))
13980 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13982 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13983 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13984 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13989 ---------------------
13990 -- Export_Function --
13991 ---------------------
13993 -- pragma Export_Function (
13994 -- [Internal =>] LOCAL_NAME
13995 -- [, [External =>] EXTERNAL_SYMBOL]
13996 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13997 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13998 -- [, [Mechanism =>] MECHANISM]
13999 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14001 -- EXTERNAL_SYMBOL ::=
14003 -- | static_string_EXPRESSION
14005 -- PARAMETER_TYPES ::=
14007 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14009 -- TYPE_DESIGNATOR ::=
14011 -- | subtype_Name ' Access
14015 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14017 -- MECHANISM_ASSOCIATION ::=
14018 -- [formal_parameter_NAME =>] MECHANISM_NAME
14020 -- MECHANISM_NAME ::=
14024 when Pragma_Export_Function
=> Export_Function
: declare
14025 Args
: Args_List
(1 .. 6);
14026 Names
: constant Name_List
(1 .. 6) := (
14029 Name_Parameter_Types
,
14032 Name_Result_Mechanism
);
14034 Internal
: Node_Id
renames Args
(1);
14035 External
: Node_Id
renames Args
(2);
14036 Parameter_Types
: Node_Id
renames Args
(3);
14037 Result_Type
: Node_Id
renames Args
(4);
14038 Mechanism
: Node_Id
renames Args
(5);
14039 Result_Mechanism
: Node_Id
renames Args
(6);
14043 Gather_Associations
(Names
, Args
);
14044 Process_Extended_Import_Export_Subprogram_Pragma
(
14045 Arg_Internal
=> Internal
,
14046 Arg_External
=> External
,
14047 Arg_Parameter_Types
=> Parameter_Types
,
14048 Arg_Result_Type
=> Result_Type
,
14049 Arg_Mechanism
=> Mechanism
,
14050 Arg_Result_Mechanism
=> Result_Mechanism
);
14051 end Export_Function
;
14053 -------------------
14054 -- Export_Object --
14055 -------------------
14057 -- pragma Export_Object (
14058 -- [Internal =>] LOCAL_NAME
14059 -- [, [External =>] EXTERNAL_SYMBOL]
14060 -- [, [Size =>] EXTERNAL_SYMBOL]);
14062 -- EXTERNAL_SYMBOL ::=
14064 -- | static_string_EXPRESSION
14066 -- PARAMETER_TYPES ::=
14068 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14070 -- TYPE_DESIGNATOR ::=
14072 -- | subtype_Name ' Access
14076 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14078 -- MECHANISM_ASSOCIATION ::=
14079 -- [formal_parameter_NAME =>] MECHANISM_NAME
14081 -- MECHANISM_NAME ::=
14085 when Pragma_Export_Object
=> Export_Object
: declare
14086 Args
: Args_List
(1 .. 3);
14087 Names
: constant Name_List
(1 .. 3) := (
14092 Internal
: Node_Id
renames Args
(1);
14093 External
: Node_Id
renames Args
(2);
14094 Size
: Node_Id
renames Args
(3);
14098 Gather_Associations
(Names
, Args
);
14099 Process_Extended_Import_Export_Object_Pragma
(
14100 Arg_Internal
=> Internal
,
14101 Arg_External
=> External
,
14105 ----------------------
14106 -- Export_Procedure --
14107 ----------------------
14109 -- pragma Export_Procedure (
14110 -- [Internal =>] LOCAL_NAME
14111 -- [, [External =>] EXTERNAL_SYMBOL]
14112 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14113 -- [, [Mechanism =>] MECHANISM]);
14115 -- EXTERNAL_SYMBOL ::=
14117 -- | static_string_EXPRESSION
14119 -- PARAMETER_TYPES ::=
14121 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14123 -- TYPE_DESIGNATOR ::=
14125 -- | subtype_Name ' Access
14129 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14131 -- MECHANISM_ASSOCIATION ::=
14132 -- [formal_parameter_NAME =>] MECHANISM_NAME
14134 -- MECHANISM_NAME ::=
14138 when Pragma_Export_Procedure
=> Export_Procedure
: declare
14139 Args
: Args_List
(1 .. 4);
14140 Names
: constant Name_List
(1 .. 4) := (
14143 Name_Parameter_Types
,
14146 Internal
: Node_Id
renames Args
(1);
14147 External
: Node_Id
renames Args
(2);
14148 Parameter_Types
: Node_Id
renames Args
(3);
14149 Mechanism
: Node_Id
renames Args
(4);
14153 Gather_Associations
(Names
, Args
);
14154 Process_Extended_Import_Export_Subprogram_Pragma
(
14155 Arg_Internal
=> Internal
,
14156 Arg_External
=> External
,
14157 Arg_Parameter_Types
=> Parameter_Types
,
14158 Arg_Mechanism
=> Mechanism
);
14159 end Export_Procedure
;
14165 -- pragma Export_Value (
14166 -- [Value =>] static_integer_EXPRESSION,
14167 -- [Link_Name =>] static_string_EXPRESSION);
14169 when Pragma_Export_Value
=>
14171 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
14172 Check_Arg_Count
(2);
14174 Check_Optional_Identifier
(Arg1
, Name_Value
);
14175 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
14177 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
14178 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
14180 -----------------------------
14181 -- Export_Valued_Procedure --
14182 -----------------------------
14184 -- pragma Export_Valued_Procedure (
14185 -- [Internal =>] LOCAL_NAME
14186 -- [, [External =>] EXTERNAL_SYMBOL,]
14187 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14188 -- [, [Mechanism =>] MECHANISM]);
14190 -- EXTERNAL_SYMBOL ::=
14192 -- | static_string_EXPRESSION
14194 -- PARAMETER_TYPES ::=
14196 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14198 -- TYPE_DESIGNATOR ::=
14200 -- | subtype_Name ' Access
14204 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14206 -- MECHANISM_ASSOCIATION ::=
14207 -- [formal_parameter_NAME =>] MECHANISM_NAME
14209 -- MECHANISM_NAME ::=
14213 when Pragma_Export_Valued_Procedure
=>
14214 Export_Valued_Procedure
: declare
14215 Args
: Args_List
(1 .. 4);
14216 Names
: constant Name_List
(1 .. 4) := (
14219 Name_Parameter_Types
,
14222 Internal
: Node_Id
renames Args
(1);
14223 External
: Node_Id
renames Args
(2);
14224 Parameter_Types
: Node_Id
renames Args
(3);
14225 Mechanism
: Node_Id
renames Args
(4);
14229 Gather_Associations
(Names
, Args
);
14230 Process_Extended_Import_Export_Subprogram_Pragma
(
14231 Arg_Internal
=> Internal
,
14232 Arg_External
=> External
,
14233 Arg_Parameter_Types
=> Parameter_Types
,
14234 Arg_Mechanism
=> Mechanism
);
14235 end Export_Valued_Procedure
;
14237 -------------------
14238 -- Extend_System --
14239 -------------------
14241 -- pragma Extend_System ([Name =>] Identifier);
14243 when Pragma_Extend_System
=> Extend_System
: declare
14246 Check_Valid_Configuration_Pragma
;
14247 Check_Arg_Count
(1);
14248 Check_Optional_Identifier
(Arg1
, Name_Name
);
14249 Check_Arg_Is_Identifier
(Arg1
);
14251 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14254 and then Name_Buffer
(1 .. 4) = "aux_"
14256 if Present
(System_Extend_Pragma_Arg
) then
14257 if Chars
(Get_Pragma_Arg
(Arg1
)) =
14258 Chars
(Expression
(System_Extend_Pragma_Arg
))
14262 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
14263 Error_Pragma
("pragma% conflicts with that #");
14267 System_Extend_Pragma_Arg
:= Arg1
;
14269 if not GNAT_Mode
then
14270 System_Extend_Unit
:= Arg1
;
14274 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
14278 ------------------------
14279 -- Extensions_Allowed --
14280 ------------------------
14282 -- pragma Extensions_Allowed (ON | OFF);
14284 when Pragma_Extensions_Allowed
=>
14286 Check_Arg_Count
(1);
14287 Check_No_Identifiers
;
14288 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
14290 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
14291 Extensions_Allowed
:= True;
14292 Ada_Version
:= Ada_Version_Type
'Last;
14295 Extensions_Allowed
:= False;
14296 Ada_Version
:= Ada_Version_Explicit
;
14297 Ada_Version_Pragma
:= Empty
;
14300 ------------------------
14301 -- Extensions_Visible --
14302 ------------------------
14304 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14306 -- Characteristics:
14308 -- * Analysis - The annotation is fully analyzed immediately upon
14309 -- elaboration as its expression must be static.
14311 -- * Expansion - None.
14313 -- * Template - The annotation utilizes the generic template of the
14314 -- related subprogram [body] when it is:
14316 -- aspect on subprogram declaration
14317 -- aspect on stand alone subprogram body
14318 -- pragma on stand alone subprogram body
14320 -- The annotation must prepare its own template when it is:
14322 -- pragma on subprogram declaration
14324 -- * Globals - Capture of global references must occur after full
14327 -- * Instance - The annotation is instantiated automatically when
14328 -- the related generic subprogram [body] is instantiated except for
14329 -- the "pragma on subprogram declaration" case. In that scenario
14330 -- the annotation must instantiate itself.
14332 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
14333 Formal
: Entity_Id
;
14334 Has_OK_Formal
: Boolean := False;
14335 Spec_Id
: Entity_Id
;
14336 Subp_Decl
: Node_Id
;
14340 Check_No_Identifiers
;
14341 Check_At_Most_N_Arguments
(1);
14344 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
14346 -- Abstract subprogram declaration
14348 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
14351 -- Generic subprogram declaration
14353 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
14356 -- Body acts as spec
14358 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14359 and then No
(Corresponding_Spec
(Subp_Decl
))
14363 -- Body stub acts as spec
14365 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14366 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14370 -- Subprogram declaration
14372 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14375 -- Otherwise the pragma is associated with an illegal construct
14378 Error_Pragma
("pragma % must apply to a subprogram");
14382 -- Chain the pragma on the contract for completeness
14384 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14386 -- The legality checks of pragma Extension_Visible are affected
14387 -- by the SPARK mode in effect. Analyze all pragmas in specific
14390 Analyze_If_Present
(Pragma_SPARK_Mode
);
14392 -- Mark the pragma as Ghost if the related subprogram is also
14393 -- Ghost. This also ensures that any expansion performed further
14394 -- below will produce Ghost nodes.
14396 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
14397 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
14399 -- Examine the formals of the related subprogram
14401 Formal
:= First_Formal
(Spec_Id
);
14402 while Present
(Formal
) loop
14404 -- At least one of the formals is of a specific tagged type,
14405 -- the pragma is legal.
14407 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
14408 Has_OK_Formal
:= True;
14411 -- A generic subprogram with at least one formal of a private
14412 -- type ensures the legality of the pragma because the actual
14413 -- may be specifically tagged. Note that this is verified by
14414 -- the check above at instantiation time.
14416 elsif Is_Private_Type
(Etype
(Formal
))
14417 and then Is_Generic_Type
(Etype
(Formal
))
14419 Has_OK_Formal
:= True;
14423 Next_Formal
(Formal
);
14426 if not Has_OK_Formal
then
14427 Error_Msg_Name_1
:= Pname
;
14428 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
14430 ("\subprogram & lacks parameter of specific tagged or "
14431 & "generic private type", N
, Spec_Id
);
14436 -- Analyze the Boolean expression (if any)
14438 if Present
(Arg1
) then
14439 Check_Static_Boolean_Expression
14440 (Expression
(Get_Argument
(N
, Spec_Id
)));
14442 end Extensions_Visible
;
14448 -- pragma External (
14449 -- [ Convention =>] convention_IDENTIFIER,
14450 -- [ Entity =>] LOCAL_NAME
14451 -- [, [External_Name =>] static_string_EXPRESSION ]
14452 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14454 when Pragma_External
=> External
: declare
14457 pragma Warnings
(Off
, C
);
14464 Name_External_Name
,
14466 Check_At_Least_N_Arguments
(2);
14467 Check_At_Most_N_Arguments
(4);
14468 Process_Convention
(C
, E
);
14470 -- A pragma that applies to a Ghost entity becomes Ghost for the
14471 -- purposes of legality checks and removal of ignored Ghost code.
14473 Mark_Pragma_As_Ghost
(N
, E
);
14475 Note_Possible_Modification
14476 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14477 Process_Interface_Name
(E
, Arg3
, Arg4
);
14478 Set_Exported
(E
, Arg2
);
14481 --------------------------
14482 -- External_Name_Casing --
14483 --------------------------
14485 -- pragma External_Name_Casing (
14486 -- UPPERCASE | LOWERCASE
14487 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14489 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
14492 Check_No_Identifiers
;
14494 if Arg_Count
= 2 then
14495 Check_Arg_Is_One_Of
14496 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
14498 case Chars
(Get_Pragma_Arg
(Arg2
)) is
14500 Opt
.External_Name_Exp_Casing
:= As_Is
;
14502 when Name_Uppercase
=>
14503 Opt
.External_Name_Exp_Casing
:= Uppercase
;
14505 when Name_Lowercase
=>
14506 Opt
.External_Name_Exp_Casing
:= Lowercase
;
14513 Check_Arg_Count
(1);
14516 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
14518 case Chars
(Get_Pragma_Arg
(Arg1
)) is
14519 when Name_Uppercase
=>
14520 Opt
.External_Name_Imp_Casing
:= Uppercase
;
14522 when Name_Lowercase
=>
14523 Opt
.External_Name_Imp_Casing
:= Lowercase
;
14528 end External_Name_Casing
;
14534 -- pragma Fast_Math;
14536 when Pragma_Fast_Math
=>
14538 Check_No_Identifiers
;
14539 Check_Valid_Configuration_Pragma
;
14542 --------------------------
14543 -- Favor_Top_Level --
14544 --------------------------
14546 -- pragma Favor_Top_Level (type_NAME);
14548 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
14553 Check_No_Identifiers
;
14554 Check_Arg_Count
(1);
14555 Check_Arg_Is_Local_Name
(Arg1
);
14556 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
14558 -- A pragma that applies to a Ghost entity becomes Ghost for the
14559 -- purposes of legality checks and removal of ignored Ghost code.
14561 Mark_Pragma_As_Ghost
(N
, Typ
);
14563 -- If it's an access-to-subprogram type (in particular, not a
14564 -- subtype), set the flag on that type.
14566 if Is_Access_Subprogram_Type
(Typ
) then
14567 Set_Can_Use_Internal_Rep
(Typ
, False);
14569 -- Otherwise it's an error (name denotes the wrong sort of entity)
14573 ("access-to-subprogram type expected",
14574 Get_Pragma_Arg
(Arg1
));
14576 end Favor_Top_Level
;
14578 ---------------------------
14579 -- Finalize_Storage_Only --
14580 ---------------------------
14582 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14584 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14585 Assoc
: constant Node_Id
:= Arg1
;
14586 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14591 Check_No_Identifiers
;
14592 Check_Arg_Count
(1);
14593 Check_Arg_Is_Local_Name
(Arg1
);
14595 Find_Type
(Type_Id
);
14596 Typ
:= Entity
(Type_Id
);
14599 or else Rep_Item_Too_Early
(Typ
, N
)
14603 Typ
:= Underlying_Type
(Typ
);
14606 if not Is_Controlled
(Typ
) then
14607 Error_Pragma
("pragma% must specify controlled type");
14610 Check_First_Subtype
(Arg1
);
14612 if Finalize_Storage_Only
(Typ
) then
14613 Error_Pragma
("duplicate pragma%, only one allowed");
14615 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14616 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14618 end Finalize_Storage
;
14624 -- pragma Ghost [ (boolean_EXPRESSION) ];
14626 when Pragma_Ghost
=> Ghost
: declare
14630 Orig_Stmt
: Node_Id
;
14631 Prev_Id
: Entity_Id
;
14636 Check_No_Identifiers
;
14637 Check_At_Most_N_Arguments
(1);
14641 while Present
(Stmt
) loop
14643 -- Skip prior pragmas, but check for duplicates
14645 if Nkind
(Stmt
) = N_Pragma
then
14646 if Pragma_Name
(Stmt
) = Pname
then
14647 Error_Msg_Name_1
:= Pname
;
14648 Error_Msg_Sloc
:= Sloc
(Stmt
);
14649 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
14652 -- Task unit declared without a definition cannot be subject to
14653 -- pragma Ghost (SPARK RM 6.9(19)).
14655 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
14656 N_Task_Type_Declaration
)
14658 Error_Pragma
("pragma % cannot apply to a task type");
14661 -- Skip internally generated code
14663 elsif not Comes_From_Source
(Stmt
) then
14664 Orig_Stmt
:= Original_Node
(Stmt
);
14666 -- When pragma Ghost applies to an untagged derivation, the
14667 -- derivation is transformed into a [sub]type declaration.
14669 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
14670 N_Subtype_Declaration
)
14671 and then Comes_From_Source
(Orig_Stmt
)
14672 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
14673 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
14674 N_Derived_Type_Definition
14676 Id
:= Defining_Entity
(Stmt
);
14679 -- When pragma Ghost applies to an expression function, the
14680 -- expression function is transformed into a subprogram.
14682 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
14683 and then Comes_From_Source
(Orig_Stmt
)
14684 and then Nkind
(Orig_Stmt
) = N_Expression_Function
14686 Id
:= Defining_Entity
(Stmt
);
14690 -- The pragma applies to a legal construct, stop the traversal
14692 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
14693 N_Full_Type_Declaration
,
14694 N_Generic_Subprogram_Declaration
,
14695 N_Object_Declaration
,
14696 N_Private_Extension_Declaration
,
14697 N_Private_Type_Declaration
,
14698 N_Subprogram_Declaration
,
14699 N_Subtype_Declaration
)
14701 Id
:= Defining_Entity
(Stmt
);
14704 -- The pragma does not apply to a legal construct, issue an
14705 -- error and stop the analysis.
14709 ("pragma % must apply to an object, package, subprogram "
14714 Stmt
:= Prev
(Stmt
);
14717 Context
:= Parent
(N
);
14719 -- Handle compilation units
14721 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
14722 Context
:= Unit
(Parent
(Context
));
14725 -- Protected and task types cannot be subject to pragma Ghost
14726 -- (SPARK RM 6.9(19)).
14728 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
14730 Error_Pragma
("pragma % cannot apply to a protected type");
14733 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
14734 Error_Pragma
("pragma % cannot apply to a task type");
14740 -- When pragma Ghost is associated with a [generic] package, it
14741 -- appears in the visible declarations.
14743 if Nkind
(Context
) = N_Package_Specification
14744 and then Present
(Visible_Declarations
(Context
))
14745 and then List_Containing
(N
) = Visible_Declarations
(Context
)
14747 Id
:= Defining_Entity
(Context
);
14749 -- Pragma Ghost applies to a stand alone subprogram body
14751 elsif Nkind
(Context
) = N_Subprogram_Body
14752 and then No
(Corresponding_Spec
(Context
))
14754 Id
:= Defining_Entity
(Context
);
14760 ("pragma % must apply to an object, package, subprogram or "
14765 -- A derived type or type extension cannot be subject to pragma
14766 -- Ghost if either the parent type or one of the progenitor types
14767 -- is not Ghost (SPARK RM 6.9(9)).
14769 if Is_Derived_Type
(Id
) then
14770 Check_Ghost_Derivation
(Id
);
14773 -- Handle completions of types and constants that are subject to
14776 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
14777 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
14779 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
14780 Error_Msg_Name_1
:= Pname
;
14782 -- The full declaration of a deferred constant cannot be
14783 -- subject to pragma Ghost unless the deferred declaration
14784 -- is also Ghost (SPARK RM 6.9(10)).
14786 if Ekind
(Prev_Id
) = E_Constant
then
14787 Error_Msg_Name_1
:= Pname
;
14788 Error_Msg_NE
(Fix_Error
14789 ("pragma % must apply to declaration of deferred "
14790 & "constant &"), N
, Id
);
14793 -- Pragma Ghost may appear on the full view of an incomplete
14794 -- type because the incomplete declaration lacks aspects and
14795 -- cannot be subject to pragma Ghost.
14797 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
14800 -- The full declaration of a type cannot be subject to
14801 -- pragma Ghost unless the partial view is also Ghost
14802 -- (SPARK RM 6.9(10)).
14805 Error_Msg_NE
(Fix_Error
14806 ("pragma % must apply to partial view of type &"),
14812 -- A synchronized object cannot be subject to pragma Ghost
14813 -- (SPARK RM 6.9(19)).
14815 elsif Ekind
(Id
) = E_Variable
then
14816 if Is_Protected_Type
(Etype
(Id
)) then
14817 Error_Pragma
("pragma % cannot apply to a protected object");
14820 elsif Is_Task_Type
(Etype
(Id
)) then
14821 Error_Pragma
("pragma % cannot apply to a task object");
14826 -- Analyze the Boolean expression (if any)
14828 if Present
(Arg1
) then
14829 Expr
:= Get_Pragma_Arg
(Arg1
);
14831 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14833 if Is_OK_Static_Expression
(Expr
) then
14835 -- "Ghostness" cannot be turned off once enabled within a
14836 -- region (SPARK RM 6.9(7)).
14838 if Is_False
(Expr_Value
(Expr
))
14839 and then Ghost_Mode
> None
14842 ("pragma % with value False cannot appear in enabled "
14847 -- Otherwie the expression is not static
14851 ("expression of pragma % must be static", Expr
);
14856 Set_Is_Ghost_Entity
(Id
);
14863 -- pragma Global (GLOBAL_SPECIFICATION);
14865 -- GLOBAL_SPECIFICATION ::=
14868 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14870 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14872 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14873 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14874 -- GLOBAL_ITEM ::= NAME
14876 -- Characteristics:
14878 -- * Analysis - The annotation undergoes initial checks to verify
14879 -- the legal placement and context. Secondary checks fully analyze
14880 -- the dependency clauses in:
14882 -- Analyze_Global_In_Decl_Part
14884 -- * Expansion - None.
14886 -- * Template - The annotation utilizes the generic template of the
14887 -- related subprogram [body] when it is:
14889 -- aspect on subprogram declaration
14890 -- aspect on stand alone subprogram body
14891 -- pragma on stand alone subprogram body
14893 -- The annotation must prepare its own template when it is:
14895 -- pragma on subprogram declaration
14897 -- * Globals - Capture of global references must occur after full
14900 -- * Instance - The annotation is instantiated automatically when
14901 -- the related generic subprogram [body] is instantiated except for
14902 -- the "pragma on subprogram declaration" case. In that scenario
14903 -- the annotation must instantiate itself.
14905 when Pragma_Global
=> Global
: declare
14907 Spec_Id
: Entity_Id
;
14908 Subp_Decl
: Node_Id
;
14911 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
14915 -- Chain the pragma on the contract for further processing by
14916 -- Analyze_Global_In_Decl_Part.
14918 Add_Contract_Item
(N
, Spec_Id
);
14920 -- Fully analyze the pragma when it appears inside an entry
14921 -- or subprogram body because it cannot benefit from forward
14924 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14926 N_Subprogram_Body_Stub
)
14928 -- The legality checks of pragmas Depends and Global are
14929 -- affected by the SPARK mode in effect and the volatility
14930 -- of the context. In addition these two pragmas are subject
14931 -- to an inherent order:
14936 -- Analyze all these pragmas in the order outlined above
14938 Analyze_If_Present
(Pragma_SPARK_Mode
);
14939 Analyze_If_Present
(Pragma_Volatile_Function
);
14940 Analyze_Global_In_Decl_Part
(N
);
14941 Analyze_If_Present
(Pragma_Depends
);
14950 -- pragma Ident (static_string_EXPRESSION)
14952 -- Note: pragma Comment shares this processing. Pragma Ident is
14953 -- identical in effect to pragma Commment.
14955 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14960 Check_Arg_Count
(1);
14961 Check_No_Identifiers
;
14962 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
14965 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14972 GP
:= Parent
(Parent
(N
));
14974 if Nkind_In
(GP
, N_Package_Declaration
,
14975 N_Generic_Package_Declaration
)
14980 -- If we have a compilation unit, then record the ident value,
14981 -- checking for improper duplication.
14983 if Nkind
(GP
) = N_Compilation_Unit
then
14984 CS
:= Ident_String
(Current_Sem_Unit
);
14986 if Present
(CS
) then
14988 -- If we have multiple instances, concatenate them, but
14989 -- not in ASIS, where we want the original tree.
14991 if not ASIS_Mode
then
14992 Start_String
(Strval
(CS
));
14993 Store_String_Char
(' ');
14994 Store_String_Chars
(Strval
(Str
));
14995 Set_Strval
(CS
, End_String
);
14999 Set_Ident_String
(Current_Sem_Unit
, Str
);
15002 -- For subunits, we just ignore the Ident, since in GNAT these
15003 -- are not separate object files, and hence not separate units
15004 -- in the unit table.
15006 elsif Nkind
(GP
) = N_Subunit
then
15012 -------------------
15013 -- Ignore_Pragma --
15014 -------------------
15016 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15018 -- Entirely handled in the parser, nothing to do here
15020 when Pragma_Ignore_Pragma
=>
15023 ----------------------------
15024 -- Implementation_Defined --
15025 ----------------------------
15027 -- pragma Implementation_Defined (LOCAL_NAME);
15029 -- Marks previously declared entity as implementation defined. For
15030 -- an overloaded entity, applies to the most recent homonym.
15032 -- pragma Implementation_Defined;
15034 -- The form with no arguments appears anywhere within a scope, most
15035 -- typically a package spec, and indicates that all entities that are
15036 -- defined within the package spec are Implementation_Defined.
15038 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
15043 Check_No_Identifiers
;
15045 -- Form with no arguments
15047 if Arg_Count
= 0 then
15048 Set_Is_Implementation_Defined
(Current_Scope
);
15050 -- Form with one argument
15053 Check_Arg_Count
(1);
15054 Check_Arg_Is_Local_Name
(Arg1
);
15055 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
15056 Set_Is_Implementation_Defined
(Ent
);
15058 end Implementation_Defined
;
15064 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15066 -- IMPLEMENTATION_KIND ::=
15067 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15069 -- "By_Any" and "Optional" are treated as synonyms in order to
15070 -- support Ada 2012 aspect Synchronization.
15072 when Pragma_Implemented
=> Implemented
: declare
15073 Proc_Id
: Entity_Id
;
15078 Check_Arg_Count
(2);
15079 Check_No_Identifiers
;
15080 Check_Arg_Is_Identifier
(Arg1
);
15081 Check_Arg_Is_Local_Name
(Arg1
);
15082 Check_Arg_Is_One_Of
(Arg2
,
15085 Name_By_Protected_Procedure
,
15088 -- Extract the name of the local procedure
15090 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
15092 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15093 -- primitive procedure of a synchronized tagged type.
15095 if Ekind
(Proc_Id
) = E_Procedure
15096 and then Is_Primitive
(Proc_Id
)
15097 and then Present
(First_Formal
(Proc_Id
))
15099 Typ
:= Etype
(First_Formal
(Proc_Id
));
15101 if Is_Tagged_Type
(Typ
)
15104 -- Check for a protected, a synchronized or a task interface
15106 ((Is_Interface
(Typ
)
15107 and then Is_Synchronized_Interface
(Typ
))
15109 -- Check for a protected type or a task type that implements
15113 (Is_Concurrent_Record_Type
(Typ
)
15114 and then Present
(Interfaces
(Typ
)))
15116 -- In analysis-only mode, examine original protected type
15119 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
15120 and then Present
(Interface_List
(Parent
(Typ
))))
15122 -- Check for a private record extension with keyword
15126 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
15127 E_Record_Subtype_With_Private
)
15128 and then Synchronized_Present
(Parent
(Typ
))))
15133 ("controlling formal must be of synchronized tagged type",
15138 -- Procedures declared inside a protected type must be accepted
15140 elsif Ekind
(Proc_Id
) = E_Procedure
15141 and then Is_Protected_Type
(Scope
(Proc_Id
))
15145 -- The first argument is not a primitive procedure
15149 ("pragma % must be applied to a primitive procedure", Arg1
);
15153 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15154 -- By_Protected_Procedure to the primitive procedure of a task
15157 if Chars
(Arg2
) = Name_By_Protected_Procedure
15158 and then Is_Interface
(Typ
)
15159 and then Is_Task_Interface
(Typ
)
15162 ("implementation kind By_Protected_Procedure cannot be "
15163 & "applied to a task interface primitive", Arg2
);
15167 Record_Rep_Item
(Proc_Id
, N
);
15170 ----------------------
15171 -- Implicit_Packing --
15172 ----------------------
15174 -- pragma Implicit_Packing;
15176 when Pragma_Implicit_Packing
=>
15178 Check_Arg_Count
(0);
15179 Implicit_Packing
:= True;
15186 -- [Convention =>] convention_IDENTIFIER,
15187 -- [Entity =>] LOCAL_NAME
15188 -- [, [External_Name =>] static_string_EXPRESSION ]
15189 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15191 when Pragma_Import
=>
15192 Check_Ada_83_Warning
;
15196 Name_External_Name
,
15199 Check_At_Least_N_Arguments
(2);
15200 Check_At_Most_N_Arguments
(4);
15201 Process_Import_Or_Interface
;
15203 ---------------------
15204 -- Import_Function --
15205 ---------------------
15207 -- pragma Import_Function (
15208 -- [Internal =>] LOCAL_NAME,
15209 -- [, [External =>] EXTERNAL_SYMBOL]
15210 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15211 -- [, [Result_Type =>] SUBTYPE_MARK]
15212 -- [, [Mechanism =>] MECHANISM]
15213 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15215 -- EXTERNAL_SYMBOL ::=
15217 -- | static_string_EXPRESSION
15219 -- PARAMETER_TYPES ::=
15221 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15223 -- TYPE_DESIGNATOR ::=
15225 -- | subtype_Name ' Access
15229 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15231 -- MECHANISM_ASSOCIATION ::=
15232 -- [formal_parameter_NAME =>] MECHANISM_NAME
15234 -- MECHANISM_NAME ::=
15238 when Pragma_Import_Function
=> Import_Function
: declare
15239 Args
: Args_List
(1 .. 6);
15240 Names
: constant Name_List
(1 .. 6) := (
15243 Name_Parameter_Types
,
15246 Name_Result_Mechanism
);
15248 Internal
: Node_Id
renames Args
(1);
15249 External
: Node_Id
renames Args
(2);
15250 Parameter_Types
: Node_Id
renames Args
(3);
15251 Result_Type
: Node_Id
renames Args
(4);
15252 Mechanism
: Node_Id
renames Args
(5);
15253 Result_Mechanism
: Node_Id
renames Args
(6);
15257 Gather_Associations
(Names
, Args
);
15258 Process_Extended_Import_Export_Subprogram_Pragma
(
15259 Arg_Internal
=> Internal
,
15260 Arg_External
=> External
,
15261 Arg_Parameter_Types
=> Parameter_Types
,
15262 Arg_Result_Type
=> Result_Type
,
15263 Arg_Mechanism
=> Mechanism
,
15264 Arg_Result_Mechanism
=> Result_Mechanism
);
15265 end Import_Function
;
15267 -------------------
15268 -- Import_Object --
15269 -------------------
15271 -- pragma Import_Object (
15272 -- [Internal =>] LOCAL_NAME
15273 -- [, [External =>] EXTERNAL_SYMBOL]
15274 -- [, [Size =>] EXTERNAL_SYMBOL]);
15276 -- EXTERNAL_SYMBOL ::=
15278 -- | static_string_EXPRESSION
15280 when Pragma_Import_Object
=> Import_Object
: declare
15281 Args
: Args_List
(1 .. 3);
15282 Names
: constant Name_List
(1 .. 3) := (
15287 Internal
: Node_Id
renames Args
(1);
15288 External
: Node_Id
renames Args
(2);
15289 Size
: Node_Id
renames Args
(3);
15293 Gather_Associations
(Names
, Args
);
15294 Process_Extended_Import_Export_Object_Pragma
(
15295 Arg_Internal
=> Internal
,
15296 Arg_External
=> External
,
15300 ----------------------
15301 -- Import_Procedure --
15302 ----------------------
15304 -- pragma Import_Procedure (
15305 -- [Internal =>] LOCAL_NAME
15306 -- [, [External =>] EXTERNAL_SYMBOL]
15307 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15308 -- [, [Mechanism =>] MECHANISM]);
15310 -- EXTERNAL_SYMBOL ::=
15312 -- | static_string_EXPRESSION
15314 -- PARAMETER_TYPES ::=
15316 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15318 -- TYPE_DESIGNATOR ::=
15320 -- | subtype_Name ' Access
15324 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15326 -- MECHANISM_ASSOCIATION ::=
15327 -- [formal_parameter_NAME =>] MECHANISM_NAME
15329 -- MECHANISM_NAME ::=
15333 when Pragma_Import_Procedure
=> Import_Procedure
: declare
15334 Args
: Args_List
(1 .. 4);
15335 Names
: constant Name_List
(1 .. 4) := (
15338 Name_Parameter_Types
,
15341 Internal
: Node_Id
renames Args
(1);
15342 External
: Node_Id
renames Args
(2);
15343 Parameter_Types
: Node_Id
renames Args
(3);
15344 Mechanism
: Node_Id
renames Args
(4);
15348 Gather_Associations
(Names
, Args
);
15349 Process_Extended_Import_Export_Subprogram_Pragma
(
15350 Arg_Internal
=> Internal
,
15351 Arg_External
=> External
,
15352 Arg_Parameter_Types
=> Parameter_Types
,
15353 Arg_Mechanism
=> Mechanism
);
15354 end Import_Procedure
;
15356 -----------------------------
15357 -- Import_Valued_Procedure --
15358 -----------------------------
15360 -- pragma Import_Valued_Procedure (
15361 -- [Internal =>] LOCAL_NAME
15362 -- [, [External =>] EXTERNAL_SYMBOL]
15363 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15364 -- [, [Mechanism =>] MECHANISM]);
15366 -- EXTERNAL_SYMBOL ::=
15368 -- | static_string_EXPRESSION
15370 -- PARAMETER_TYPES ::=
15372 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15374 -- TYPE_DESIGNATOR ::=
15376 -- | subtype_Name ' Access
15380 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15382 -- MECHANISM_ASSOCIATION ::=
15383 -- [formal_parameter_NAME =>] MECHANISM_NAME
15385 -- MECHANISM_NAME ::=
15389 when Pragma_Import_Valued_Procedure
=>
15390 Import_Valued_Procedure
: declare
15391 Args
: Args_List
(1 .. 4);
15392 Names
: constant Name_List
(1 .. 4) := (
15395 Name_Parameter_Types
,
15398 Internal
: Node_Id
renames Args
(1);
15399 External
: Node_Id
renames Args
(2);
15400 Parameter_Types
: Node_Id
renames Args
(3);
15401 Mechanism
: Node_Id
renames Args
(4);
15405 Gather_Associations
(Names
, Args
);
15406 Process_Extended_Import_Export_Subprogram_Pragma
(
15407 Arg_Internal
=> Internal
,
15408 Arg_External
=> External
,
15409 Arg_Parameter_Types
=> Parameter_Types
,
15410 Arg_Mechanism
=> Mechanism
);
15411 end Import_Valued_Procedure
;
15417 -- pragma Independent (LOCAL_NAME);
15419 when Pragma_Independent
=>
15420 Process_Atomic_Independent_Shared_Volatile
;
15422 ----------------------------
15423 -- Independent_Components --
15424 ----------------------------
15426 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
15428 when Pragma_Independent_Components
=> Independent_Components
: declare
15436 Check_Ada_83_Warning
;
15438 Check_No_Identifiers
;
15439 Check_Arg_Count
(1);
15440 Check_Arg_Is_Local_Name
(Arg1
);
15441 E_Id
:= Get_Pragma_Arg
(Arg1
);
15443 if Etype
(E_Id
) = Any_Type
then
15447 E
:= Entity
(E_Id
);
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_Pragma_As_Ghost
(N
, E
);
15454 -- Check duplicate before we chain ourselves
15456 Check_Duplicate_Pragma
(E
);
15458 -- Check appropriate entity
15460 if Rep_Item_Too_Early
(E
, N
)
15462 Rep_Item_Too_Late
(E
, N
)
15467 D
:= Declaration_Node
(E
);
15470 -- The flag is set on the base type, or on the object
15472 if K
= N_Full_Type_Declaration
15473 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
15475 Set_Has_Independent_Components
(Base_Type
(E
));
15476 Record_Independence_Check
(N
, Base_Type
(E
));
15478 -- For record type, set all components independent
15480 if Is_Record_Type
(E
) then
15481 C
:= First_Component
(E
);
15482 while Present
(C
) loop
15483 Set_Is_Independent
(C
);
15484 Next_Component
(C
);
15488 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
15489 and then Nkind
(D
) = N_Object_Declaration
15490 and then Nkind
(Object_Definition
(D
)) =
15491 N_Constrained_Array_Definition
15493 Set_Has_Independent_Components
(E
);
15494 Record_Independence_Check
(N
, E
);
15497 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
15499 end Independent_Components
;
15501 -----------------------
15502 -- Initial_Condition --
15503 -----------------------
15505 -- pragma Initial_Condition (boolean_EXPRESSION);
15507 -- Characteristics:
15509 -- * Analysis - The annotation undergoes initial checks to verify
15510 -- the legal placement and context. Secondary checks preanalyze the
15513 -- Analyze_Initial_Condition_In_Decl_Part
15515 -- * Expansion - The annotation is expanded during the expansion of
15516 -- the package body whose declaration is subject to the annotation
15519 -- Expand_Pragma_Initial_Condition
15521 -- * Template - The annotation utilizes the generic template of the
15522 -- related package declaration.
15524 -- * Globals - Capture of global references must occur after full
15527 -- * Instance - The annotation is instantiated automatically when
15528 -- the related generic package is instantiated.
15530 when Pragma_Initial_Condition
=> Initial_Condition
: declare
15531 Pack_Decl
: Node_Id
;
15532 Pack_Id
: Entity_Id
;
15536 Check_No_Identifiers
;
15537 Check_Arg_Count
(1);
15539 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
15541 -- Ensure the proper placement of the pragma. Initial_Condition
15542 -- must be associated with a package declaration.
15544 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
15545 N_Package_Declaration
)
15549 -- Otherwise the pragma is associated with an illegal context
15556 Pack_Id
:= Defining_Entity
(Pack_Decl
);
15558 -- Chain the pragma on the contract for further processing by
15559 -- Analyze_Initial_Condition_In_Decl_Part.
15561 Add_Contract_Item
(N
, Pack_Id
);
15563 -- The legality checks of pragmas Abstract_State, Initializes, and
15564 -- Initial_Condition are affected by the SPARK mode in effect. In
15565 -- addition, these three pragmas are subject to an inherent order:
15567 -- 1) Abstract_State
15569 -- 3) Initial_Condition
15571 -- Analyze all these pragmas in the order outlined above
15573 Analyze_If_Present
(Pragma_SPARK_Mode
);
15574 Analyze_If_Present
(Pragma_Abstract_State
);
15575 Analyze_If_Present
(Pragma_Initializes
);
15577 -- A pragma that applies to a Ghost entity becomes Ghost for the
15578 -- purposes of legality checks and removal of ignored Ghost code.
15580 Mark_Pragma_As_Ghost
(N
, Pack_Id
);
15581 end Initial_Condition
;
15583 ------------------------
15584 -- Initialize_Scalars --
15585 ------------------------
15587 -- pragma Initialize_Scalars;
15589 when Pragma_Initialize_Scalars
=>
15591 Check_Arg_Count
(0);
15592 Check_Valid_Configuration_Pragma
;
15593 Check_Restriction
(No_Initialize_Scalars
, N
);
15595 -- Initialize_Scalars creates false positives in CodePeer, and
15596 -- incorrect negative results in GNATprove mode, so ignore this
15597 -- pragma in these modes.
15599 if not Restriction_Active
(No_Initialize_Scalars
)
15600 and then not (CodePeer_Mode
or GNATprove_Mode
)
15602 Init_Or_Norm_Scalars
:= True;
15603 Initialize_Scalars
:= True;
15610 -- pragma Initializes (INITIALIZATION_SPEC);
15612 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
15614 -- INITIALIZATION_LIST ::=
15615 -- INITIALIZATION_ITEM
15616 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15618 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15623 -- | (INPUT {, INPUT})
15627 -- Characteristics:
15629 -- * Analysis - The annotation undergoes initial checks to verify
15630 -- the legal placement and context. Secondary checks preanalyze the
15633 -- Analyze_Initializes_In_Decl_Part
15635 -- * Expansion - None.
15637 -- * Template - The annotation utilizes the generic template of the
15638 -- related package declaration.
15640 -- * Globals - Capture of global references must occur after full
15643 -- * Instance - The annotation is instantiated automatically when
15644 -- the related generic package is instantiated.
15646 when Pragma_Initializes
=> Initializes
: declare
15647 Pack_Decl
: Node_Id
;
15648 Pack_Id
: Entity_Id
;
15652 Check_No_Identifiers
;
15653 Check_Arg_Count
(1);
15655 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
15657 -- Ensure the proper placement of the pragma. Initializes must be
15658 -- associated with a package declaration.
15660 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
15661 N_Package_Declaration
)
15665 -- Otherwise the pragma is associated with an illegal construc
15672 Pack_Id
:= Defining_Entity
(Pack_Decl
);
15674 -- Chain the pragma on the contract for further processing by
15675 -- Analyze_Initializes_In_Decl_Part.
15677 Add_Contract_Item
(N
, Pack_Id
);
15679 -- The legality checks of pragmas Abstract_State, Initializes, and
15680 -- Initial_Condition are affected by the SPARK mode in effect. In
15681 -- addition, these three pragmas are subject to an inherent order:
15683 -- 1) Abstract_State
15685 -- 3) Initial_Condition
15687 -- Analyze all these pragmas in the order outlined above
15689 Analyze_If_Present
(Pragma_SPARK_Mode
);
15690 Analyze_If_Present
(Pragma_Abstract_State
);
15692 -- A pragma that applies to a Ghost entity becomes Ghost for the
15693 -- purposes of legality checks and removal of ignored Ghost code.
15695 Mark_Pragma_As_Ghost
(N
, Pack_Id
);
15696 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
15698 Analyze_If_Present
(Pragma_Initial_Condition
);
15705 -- pragma Inline ( NAME {, NAME} );
15707 when Pragma_Inline
=>
15709 -- Pragma always active unless in GNATprove mode. It is disabled
15710 -- in GNATprove mode because frontend inlining is applied
15711 -- independently of pragmas Inline and Inline_Always for
15712 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15715 if not GNATprove_Mode
then
15717 -- Inline status is Enabled if inlining option is active
15719 if Inline_Active
then
15720 Process_Inline
(Enabled
);
15722 Process_Inline
(Disabled
);
15726 -------------------
15727 -- Inline_Always --
15728 -------------------
15730 -- pragma Inline_Always ( NAME {, NAME} );
15732 when Pragma_Inline_Always
=>
15735 -- Pragma always active unless in CodePeer mode or GNATprove
15736 -- mode. It is disabled in CodePeer mode because inlining is
15737 -- not helpful, and enabling it caused walk order issues. It
15738 -- is disabled in GNATprove mode because frontend inlining is
15739 -- applied independently of pragmas Inline and Inline_Always for
15740 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15743 if not CodePeer_Mode
and not GNATprove_Mode
then
15744 Process_Inline
(Enabled
);
15747 --------------------
15748 -- Inline_Generic --
15749 --------------------
15751 -- pragma Inline_Generic (NAME {, NAME});
15753 when Pragma_Inline_Generic
=>
15755 Process_Generic_List
;
15757 ----------------------
15758 -- Inspection_Point --
15759 ----------------------
15761 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15763 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15770 if Arg_Count
> 0 then
15773 Exp
:= Get_Pragma_Arg
(Arg
);
15776 if not Is_Entity_Name
(Exp
)
15777 or else not Is_Object
(Entity
(Exp
))
15779 Error_Pragma_Arg
("object name required", Arg
);
15783 exit when No
(Arg
);
15786 end Inspection_Point
;
15792 -- pragma Interface (
15793 -- [ Convention =>] convention_IDENTIFIER,
15794 -- [ Entity =>] LOCAL_NAME
15795 -- [, [External_Name =>] static_string_EXPRESSION ]
15796 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15798 when Pragma_Interface
=>
15803 Name_External_Name
,
15805 Check_At_Least_N_Arguments
(2);
15806 Check_At_Most_N_Arguments
(4);
15807 Process_Import_Or_Interface
;
15809 -- In Ada 2005, the permission to use Interface (a reserved word)
15810 -- as a pragma name is considered an obsolescent feature, and this
15811 -- pragma was already obsolescent in Ada 95.
15813 if Ada_Version
>= Ada_95
then
15815 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15817 if Warn_On_Obsolescent_Feature
then
15819 ("pragma Interface is an obsolescent feature?j?", N
);
15821 ("|use pragma Import instead?j?", N
);
15825 --------------------
15826 -- Interface_Name --
15827 --------------------
15829 -- pragma Interface_Name (
15830 -- [ Entity =>] LOCAL_NAME
15831 -- [,[External_Name =>] static_string_EXPRESSION ]
15832 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15834 when Pragma_Interface_Name
=> Interface_Name
: declare
15836 Def_Id
: Entity_Id
;
15837 Hom_Id
: Entity_Id
;
15843 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15844 Check_At_Least_N_Arguments
(2);
15845 Check_At_Most_N_Arguments
(3);
15846 Id
:= Get_Pragma_Arg
(Arg1
);
15849 -- This is obsolete from Ada 95 on, but it is an implementation
15850 -- defined pragma, so we do not consider that it violates the
15851 -- restriction (No_Obsolescent_Features).
15853 if Ada_Version
>= Ada_95
then
15854 if Warn_On_Obsolescent_Feature
then
15856 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15858 ("|use pragma Import instead?j?", N
);
15862 if not Is_Entity_Name
(Id
) then
15864 ("first argument for pragma% must be entity name", Arg1
);
15865 elsif Etype
(Id
) = Any_Type
then
15868 Def_Id
:= Entity
(Id
);
15871 -- Special DEC-compatible processing for the object case, forces
15872 -- object to be imported.
15874 if Ekind
(Def_Id
) = E_Variable
then
15875 Kill_Size_Check_Code
(Def_Id
);
15876 Note_Possible_Modification
(Id
, Sure
=> False);
15878 -- Initialization is not allowed for imported variable
15880 if Present
(Expression
(Parent
(Def_Id
)))
15881 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15883 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15885 ("no initialization allowed for declaration of& #",
15889 -- For compatibility, support VADS usage of providing both
15890 -- pragmas Interface and Interface_Name to obtain the effect
15891 -- of a single Import pragma.
15893 if Is_Imported
(Def_Id
)
15894 and then Present
(First_Rep_Item
(Def_Id
))
15895 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15897 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15901 Set_Imported
(Def_Id
);
15904 Set_Is_Public
(Def_Id
);
15905 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15908 -- Otherwise must be subprogram
15910 elsif not Is_Subprogram
(Def_Id
) then
15912 ("argument of pragma% is not subprogram", Arg1
);
15915 Check_At_Most_N_Arguments
(3);
15919 -- Loop through homonyms
15922 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15924 if Is_Imported
(Def_Id
) then
15925 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15929 exit when From_Aspect_Specification
(N
);
15930 Hom_Id
:= Homonym
(Hom_Id
);
15932 exit when No
(Hom_Id
)
15933 or else Scope
(Hom_Id
) /= Current_Scope
;
15938 ("argument of pragma% is not imported subprogram",
15942 end Interface_Name
;
15944 -----------------------
15945 -- Interrupt_Handler --
15946 -----------------------
15948 -- pragma Interrupt_Handler (handler_NAME);
15950 when Pragma_Interrupt_Handler
=>
15951 Check_Ada_83_Warning
;
15952 Check_Arg_Count
(1);
15953 Check_No_Identifiers
;
15955 if No_Run_Time_Mode
then
15956 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15958 Check_Interrupt_Or_Attach_Handler
;
15959 Process_Interrupt_Or_Attach_Handler
;
15962 ------------------------
15963 -- Interrupt_Priority --
15964 ------------------------
15966 -- pragma Interrupt_Priority [(EXPRESSION)];
15968 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15969 P
: constant Node_Id
:= Parent
(N
);
15974 Check_Ada_83_Warning
;
15976 if Arg_Count
/= 0 then
15977 Arg
:= Get_Pragma_Arg
(Arg1
);
15978 Check_Arg_Count
(1);
15979 Check_No_Identifiers
;
15981 -- The expression must be analyzed in the special manner
15982 -- described in "Handling of Default and Per-Object
15983 -- Expressions" in sem.ads.
15985 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15988 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15993 Ent
:= Defining_Identifier
(Parent
(P
));
15995 -- Check duplicate pragma before we chain the pragma in the Rep
15996 -- Item chain of Ent.
15998 Check_Duplicate_Pragma
(Ent
);
15999 Record_Rep_Item
(Ent
, N
);
16001 -- Check the No_Task_At_Interrupt_Priority restriction
16003 if Nkind
(P
) = N_Task_Definition
then
16004 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
16007 end Interrupt_Priority
;
16009 ---------------------
16010 -- Interrupt_State --
16011 ---------------------
16013 -- pragma Interrupt_State (
16014 -- [Name =>] INTERRUPT_ID,
16015 -- [State =>] INTERRUPT_STATE);
16017 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16018 -- INTERRUPT_STATE => System | Runtime | User
16020 -- Note: if the interrupt id is given as an identifier, then it must
16021 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16022 -- given as a static integer expression which must be in the range of
16023 -- Ada.Interrupts.Interrupt_ID.
16025 when Pragma_Interrupt_State
=> Interrupt_State
: declare
16026 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
16027 -- This is the entity Ada.Interrupts.Interrupt_ID;
16029 State_Type
: Character;
16030 -- Set to 's'/'r'/'u' for System/Runtime/User
16033 -- Index to entry in Interrupt_States table
16036 -- Value of interrupt
16038 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
16039 -- The first argument to the pragma
16041 Int_Ent
: Entity_Id
;
16042 -- Interrupt entity in Ada.Interrupts.Names
16046 Check_Arg_Order
((Name_Name
, Name_State
));
16047 Check_Arg_Count
(2);
16049 Check_Optional_Identifier
(Arg1
, Name_Name
);
16050 Check_Optional_Identifier
(Arg2
, Name_State
);
16051 Check_Arg_Is_Identifier
(Arg2
);
16053 -- First argument is identifier
16055 if Nkind
(Arg1X
) = N_Identifier
then
16057 -- Search list of names in Ada.Interrupts.Names
16059 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
16061 if No
(Int_Ent
) then
16062 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
16064 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
16065 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
16069 Next_Entity
(Int_Ent
);
16072 -- First argument is not an identifier, so it must be a static
16073 -- expression of type Ada.Interrupts.Interrupt_ID.
16076 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
16077 Int_Val
:= Expr_Value
(Arg1X
);
16079 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
16081 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
16084 ("value not in range of type "
16085 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
16091 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16092 when Name_Runtime
=> State_Type
:= 'r';
16093 when Name_System
=> State_Type
:= 's';
16094 when Name_User
=> State_Type
:= 'u';
16097 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
16100 -- Check if entry is already stored
16102 IST_Num
:= Interrupt_States
.First
;
16104 -- If entry not found, add it
16106 if IST_Num
> Interrupt_States
.Last
then
16107 Interrupt_States
.Append
16108 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
16109 Interrupt_State
=> State_Type
,
16110 Pragma_Loc
=> Loc
));
16113 -- Case of entry for the same entry
16115 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
16118 -- If state matches, done, no need to make redundant entry
16121 State_Type
= Interrupt_States
.Table
(IST_Num
).
16124 -- Otherwise if state does not match, error
16127 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
16129 ("state conflicts with that given #", Arg2
);
16133 IST_Num
:= IST_Num
+ 1;
16135 end Interrupt_State
;
16141 -- pragma Invariant
16142 -- ([Entity =>] type_LOCAL_NAME,
16143 -- [Check =>] EXPRESSION
16144 -- [,[Message =>] String_Expression]);
16146 when Pragma_Invariant
=> Invariant
: declare
16153 Check_At_Least_N_Arguments
(2);
16154 Check_At_Most_N_Arguments
(3);
16155 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16156 Check_Optional_Identifier
(Arg2
, Name_Check
);
16158 if Arg_Count
= 3 then
16159 Check_Optional_Identifier
(Arg3
, Name_Message
);
16160 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
16163 Check_Arg_Is_Local_Name
(Arg1
);
16165 Type_Id
:= Get_Pragma_Arg
(Arg1
);
16166 Find_Type
(Type_Id
);
16167 Typ
:= Entity
(Type_Id
);
16169 if Typ
= Any_Type
then
16172 -- Invariants allowed in interface types (RM 7.3.2(3/3))
16174 elsif Is_Interface
(Typ
) then
16177 -- An invariant must apply to a private type, or appear in the
16178 -- private part of a package spec and apply to a completion.
16179 -- a class-wide invariant can only appear on a private declaration
16180 -- or private extension, not a completion.
16182 elsif Ekind_In
(Typ
, E_Private_Type
,
16183 E_Record_Type_With_Private
,
16184 E_Limited_Private_Type
)
16188 elsif In_Private_Part
(Current_Scope
)
16189 and then Has_Private_Declaration
(Typ
)
16190 and then not Class_Present
(N
)
16194 elsif In_Private_Part
(Current_Scope
) then
16196 ("pragma% only allowed for private type declared in "
16197 & "visible part", Arg1
);
16201 ("pragma% only allowed for private type", Arg1
);
16204 -- A pragma that applies to a Ghost entity becomes Ghost for the
16205 -- purposes of legality checks and removal of ignored Ghost code.
16207 Mark_Pragma_As_Ghost
(N
, Typ
);
16209 -- Not allowed for abstract type in the non-class case (it is
16210 -- allowed to use Invariant'Class for abstract types).
16212 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
16214 ("pragma% not allowed for abstract type", Arg1
);
16217 -- Link the pragma on to the rep item chain, for processing when
16218 -- the type is frozen.
16220 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
16222 -- Note that the type has at least one invariant, and also that
16223 -- it has inheritable invariants if we have Invariant'Class
16224 -- or Type_Invariant'Class. Build the corresponding invariant
16225 -- procedure declaration, so that calls to it can be generated
16226 -- before the body is built (e.g. within an expression function).
16228 -- Interface types have no invariant procedure; their invariants
16229 -- are propagated to the build invariant procedure of all the
16230 -- types covering the interface type.
16232 if not Is_Interface
(Typ
) then
16233 Insert_After_And_Analyze
16234 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
16237 if Class_Present
(N
) then
16238 Set_Has_Inheritable_Invariants
(Typ
);
16246 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16248 when Pragma_Keep_Names
=> Keep_Names
: declare
16253 Check_Arg_Count
(1);
16254 Check_Optional_Identifier
(Arg1
, Name_On
);
16255 Check_Arg_Is_Local_Name
(Arg1
);
16257 Arg
:= Get_Pragma_Arg
(Arg1
);
16260 if Etype
(Arg
) = Any_Type
then
16264 if not Is_Entity_Name
(Arg
)
16265 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16268 ("pragma% requires a local enumeration type", Arg1
);
16271 Set_Discard_Names
(Entity
(Arg
), False);
16278 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16280 when Pragma_License
=>
16283 -- Do not analyze pragma any further in CodePeer mode, to avoid
16284 -- extraneous errors in this implementation-dependent pragma,
16285 -- which has a different profile on other compilers.
16287 if CodePeer_Mode
then
16291 Check_Arg_Count
(1);
16292 Check_No_Identifiers
;
16293 Check_Valid_Configuration_Pragma
;
16294 Check_Arg_Is_Identifier
(Arg1
);
16297 Sind
: constant Source_File_Index
:=
16298 Source_Index
(Current_Sem_Unit
);
16301 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16303 Set_License
(Sind
, GPL
);
16305 when Name_Modified_GPL
=>
16306 Set_License
(Sind
, Modified_GPL
);
16308 when Name_Restricted
=>
16309 Set_License
(Sind
, Restricted
);
16311 when Name_Unrestricted
=>
16312 Set_License
(Sind
, Unrestricted
);
16315 Error_Pragma_Arg
("invalid license name", Arg1
);
16323 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16325 when Pragma_Link_With
=> Link_With
: declare
16331 if Operating_Mode
= Generate_Code
16332 and then In_Extended_Main_Source_Unit
(N
)
16334 Check_At_Least_N_Arguments
(1);
16335 Check_No_Identifiers
;
16336 Check_Is_In_Decl_Part_Or_Package_Spec
;
16337 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16341 while Present
(Arg
) loop
16342 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16344 -- Store argument, converting sequences of spaces to a
16345 -- single null character (this is one of the differences
16346 -- in processing between Link_With and Linker_Options).
16348 Arg_Store
: declare
16349 C
: constant Char_Code
:= Get_Char_Code
(' ');
16350 S
: constant String_Id
:=
16351 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16352 L
: constant Nat
:= String_Length
(S
);
16355 procedure Skip_Spaces
;
16356 -- Advance F past any spaces
16362 procedure Skip_Spaces
is
16364 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16369 -- Start of processing for Arg_Store
16372 Skip_Spaces
; -- skip leading spaces
16374 -- Loop through characters, changing any embedded
16375 -- sequence of spaces to a single null character (this
16376 -- is how Link_With/Linker_Options differ)
16379 if Get_String_Char
(S
, F
) = C
then
16382 Store_String_Char
(ASCII
.NUL
);
16385 Store_String_Char
(Get_String_Char
(S
, F
));
16393 if Present
(Arg
) then
16394 Store_String_Char
(ASCII
.NUL
);
16398 Store_Linker_Option_String
(End_String
);
16406 -- pragma Linker_Alias (
16407 -- [Entity =>] LOCAL_NAME
16408 -- [Target =>] static_string_EXPRESSION);
16410 when Pragma_Linker_Alias
=>
16412 Check_Arg_Order
((Name_Entity
, Name_Target
));
16413 Check_Arg_Count
(2);
16414 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16415 Check_Optional_Identifier
(Arg2
, Name_Target
);
16416 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16417 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16419 -- The only processing required is to link this item on to the
16420 -- list of rep items for the given entity. This is accomplished
16421 -- by the call to Rep_Item_Too_Late (when no error is detected
16422 -- and False is returned).
16424 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16427 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16430 ------------------------
16431 -- Linker_Constructor --
16432 ------------------------
16434 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16436 -- Code is shared with Linker_Destructor
16438 -----------------------
16439 -- Linker_Destructor --
16440 -----------------------
16442 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16444 when Pragma_Linker_Constructor |
16445 Pragma_Linker_Destructor
=>
16446 Linker_Constructor
: declare
16452 Check_Arg_Count
(1);
16453 Check_No_Identifiers
;
16454 Check_Arg_Is_Local_Name
(Arg1
);
16455 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16457 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16459 if not Is_Library_Level_Entity
(Proc
) then
16461 ("argument for pragma% must be library level entity", Arg1
);
16464 -- The only processing required is to link this item on to the
16465 -- list of rep items for the given entity. This is accomplished
16466 -- by the call to Rep_Item_Too_Late (when no error is detected
16467 -- and False is returned).
16469 if Rep_Item_Too_Late
(Proc
, N
) then
16472 Set_Has_Gigi_Rep_Item
(Proc
);
16474 end Linker_Constructor
;
16476 --------------------
16477 -- Linker_Options --
16478 --------------------
16480 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16482 when Pragma_Linker_Options
=> Linker_Options
: declare
16486 Check_Ada_83_Warning
;
16487 Check_No_Identifiers
;
16488 Check_Arg_Count
(1);
16489 Check_Is_In_Decl_Part_Or_Package_Spec
;
16490 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16491 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16494 while Present
(Arg
) loop
16495 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16496 Store_String_Char
(ASCII
.NUL
);
16498 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16502 if Operating_Mode
= Generate_Code
16503 and then In_Extended_Main_Source_Unit
(N
)
16505 Store_Linker_Option_String
(End_String
);
16507 end Linker_Options
;
16509 --------------------
16510 -- Linker_Section --
16511 --------------------
16513 -- pragma Linker_Section (
16514 -- [Entity =>] LOCAL_NAME
16515 -- [Section =>] static_string_EXPRESSION);
16517 when Pragma_Linker_Section
=> Linker_Section
: declare
16522 Ghost_Error_Posted
: Boolean := False;
16523 -- Flag set when an error concerning the illegal mix of Ghost and
16524 -- non-Ghost subprograms is emitted.
16526 Ghost_Id
: Entity_Id
:= Empty
;
16527 -- The entity of the first Ghost subprogram encountered while
16528 -- processing the arguments of the pragma.
16532 Check_Arg_Order
((Name_Entity
, Name_Section
));
16533 Check_Arg_Count
(2);
16534 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16535 Check_Optional_Identifier
(Arg2
, Name_Section
);
16536 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16537 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16539 -- Check kind of entity
16541 Arg
:= Get_Pragma_Arg
(Arg1
);
16542 Ent
:= Entity
(Arg
);
16544 case Ekind
(Ent
) is
16546 -- Objects (constants and variables) and types. For these cases
16547 -- all we need to do is to set the Linker_Section_pragma field,
16548 -- checking that we do not have a duplicate.
16550 when E_Constant | E_Variable | Type_Kind
=>
16551 LPE
:= Linker_Section_Pragma
(Ent
);
16553 if Present
(LPE
) then
16554 Error_Msg_Sloc
:= Sloc
(LPE
);
16556 ("Linker_Section already specified for &#", Arg1
, Ent
);
16559 Set_Linker_Section_Pragma
(Ent
, N
);
16561 -- A pragma that applies to a Ghost entity becomes Ghost for
16562 -- the purposes of legality checks and removal of ignored
16565 Mark_Pragma_As_Ghost
(N
, Ent
);
16569 when Subprogram_Kind
=>
16571 -- Aspect case, entity already set
16573 if From_Aspect_Specification
(N
) then
16574 Set_Linker_Section_Pragma
16575 (Entity
(Corresponding_Aspect
(N
)), N
);
16577 -- Pragma case, we must climb the homonym chain, but skip
16578 -- any for which the linker section is already set.
16582 if No
(Linker_Section_Pragma
(Ent
)) then
16583 Set_Linker_Section_Pragma
(Ent
, N
);
16585 -- A pragma that applies to a Ghost entity becomes
16586 -- Ghost for the purposes of legality checks and
16587 -- removal of ignored Ghost code.
16589 Mark_Pragma_As_Ghost
(N
, Ent
);
16591 -- Capture the entity of the first Ghost subprogram
16592 -- being processed for error detection purposes.
16594 if Is_Ghost_Entity
(Ent
) then
16595 if No
(Ghost_Id
) then
16599 -- Otherwise the subprogram is non-Ghost. It is
16600 -- illegal to mix references to Ghost and non-Ghost
16601 -- entities (SPARK RM 6.9).
16603 elsif Present
(Ghost_Id
)
16604 and then not Ghost_Error_Posted
16606 Ghost_Error_Posted
:= True;
16608 Error_Msg_Name_1
:= Pname
;
16610 ("pragma % cannot mention ghost and "
16611 & "non-ghost subprograms", N
);
16613 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
16615 ("\& # declared as ghost", N
, Ghost_Id
);
16617 Error_Msg_Sloc
:= Sloc
(Ent
);
16619 ("\& # declared as non-ghost", N
, Ent
);
16623 Ent
:= Homonym
(Ent
);
16625 or else Scope
(Ent
) /= Current_Scope
;
16629 -- All other cases are illegal
16633 ("pragma% applies only to objects, subprograms, and types",
16636 end Linker_Section
;
16642 -- pragma List (On | Off)
16644 -- There is nothing to do here, since we did all the processing for
16645 -- this pragma in Par.Prag (so that it works properly even in syntax
16648 when Pragma_List
=>
16655 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16657 when Pragma_Lock_Free
=> Lock_Free
: declare
16658 P
: constant Node_Id
:= Parent
(N
);
16664 Check_No_Identifiers
;
16665 Check_At_Most_N_Arguments
(1);
16667 -- Protected definition case
16669 if Nkind
(P
) = N_Protected_Definition
then
16670 Ent
:= Defining_Identifier
(Parent
(P
));
16674 if Arg_Count
= 1 then
16675 Arg
:= Get_Pragma_Arg
(Arg1
);
16676 Val
:= Is_True
(Static_Boolean
(Arg
));
16678 -- No arguments (expression is considered to be True)
16684 -- Check duplicate pragma before we chain the pragma in the Rep
16685 -- Item chain of Ent.
16687 Check_Duplicate_Pragma
(Ent
);
16688 Record_Rep_Item
(Ent
, N
);
16689 Set_Uses_Lock_Free
(Ent
, Val
);
16691 -- Anything else is incorrect placement
16698 --------------------
16699 -- Locking_Policy --
16700 --------------------
16702 -- pragma Locking_Policy (policy_IDENTIFIER);
16704 when Pragma_Locking_Policy
=> declare
16705 subtype LP_Range
is Name_Id
16706 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16711 Check_Ada_83_Warning
;
16712 Check_Arg_Count
(1);
16713 Check_No_Identifiers
;
16714 Check_Arg_Is_Locking_Policy
(Arg1
);
16715 Check_Valid_Configuration_Pragma
;
16716 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16719 when Name_Ceiling_Locking
=>
16721 when Name_Inheritance_Locking
=>
16723 when Name_Concurrent_Readers_Locking
=>
16727 if Locking_Policy
/= ' '
16728 and then Locking_Policy
/= LP
16730 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16731 Error_Pragma
("locking policy incompatible with policy#");
16733 -- Set new policy, but always preserve System_Location since we
16734 -- like the error message with the run time name.
16737 Locking_Policy
:= LP
;
16739 if Locking_Policy_Sloc
/= System_Location
then
16740 Locking_Policy_Sloc
:= Loc
;
16745 -------------------
16746 -- Loop_Optimize --
16747 -------------------
16749 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16751 -- OPTIMIZATION_HINT ::=
16752 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16754 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16759 Check_At_Least_N_Arguments
(1);
16760 Check_No_Identifiers
;
16762 Hint
:= First
(Pragma_Argument_Associations
(N
));
16763 while Present
(Hint
) loop
16764 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16772 Check_Loop_Pragma_Placement
;
16779 -- pragma Loop_Variant
16780 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16782 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16784 -- CHANGE_DIRECTION ::= Increases | Decreases
16786 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16791 Check_At_Least_N_Arguments
(1);
16792 Check_Loop_Pragma_Placement
;
16794 -- Process all increasing / decreasing expressions
16796 Variant
:= First
(Pragma_Argument_Associations
(N
));
16797 while Present
(Variant
) loop
16798 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16801 Error_Pragma_Arg
("wrong change modifier", Variant
);
16804 Preanalyze_Assert_Expression
16805 (Expression
(Variant
), Any_Discrete
);
16811 -----------------------
16812 -- Machine_Attribute --
16813 -----------------------
16815 -- pragma Machine_Attribute (
16816 -- [Entity =>] LOCAL_NAME,
16817 -- [Attribute_Name =>] static_string_EXPRESSION
16818 -- [, [Info =>] static_EXPRESSION] );
16820 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16821 Def_Id
: Entity_Id
;
16825 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16827 if Arg_Count
= 3 then
16828 Check_Optional_Identifier
(Arg3
, Name_Info
);
16829 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16831 Check_Arg_Count
(2);
16834 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16835 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16836 Check_Arg_Is_Local_Name
(Arg1
);
16837 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16838 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16840 if Is_Access_Type
(Def_Id
) then
16841 Def_Id
:= Designated_Type
(Def_Id
);
16844 if Rep_Item_Too_Early
(Def_Id
, N
) then
16848 Def_Id
:= Underlying_Type
(Def_Id
);
16850 -- The only processing required is to link this item on to the
16851 -- list of rep items for the given entity. This is accomplished
16852 -- by the call to Rep_Item_Too_Late (when no error is detected
16853 -- and False is returned).
16855 if Rep_Item_Too_Late
(Def_Id
, N
) then
16858 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16860 end Machine_Attribute
;
16867 -- (MAIN_OPTION [, MAIN_OPTION]);
16870 -- [STACK_SIZE =>] static_integer_EXPRESSION
16871 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16872 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16874 when Pragma_Main
=> Main
: declare
16875 Args
: Args_List
(1 .. 3);
16876 Names
: constant Name_List
(1 .. 3) := (
16878 Name_Task_Stack_Size_Default
,
16879 Name_Time_Slicing_Enabled
);
16885 Gather_Associations
(Names
, Args
);
16887 for J
in 1 .. 2 loop
16888 if Present
(Args
(J
)) then
16889 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16893 if Present
(Args
(3)) then
16894 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
16898 while Present
(Nod
) loop
16899 if Nkind
(Nod
) = N_Pragma
16900 and then Pragma_Name
(Nod
) = Name_Main
16902 Error_Msg_Name_1
:= Pname
;
16903 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16914 -- pragma Main_Storage
16915 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16917 -- MAIN_STORAGE_OPTION ::=
16918 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16919 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16921 when Pragma_Main_Storage
=> Main_Storage
: declare
16922 Args
: Args_List
(1 .. 2);
16923 Names
: constant Name_List
(1 .. 2) := (
16924 Name_Working_Storage
,
16931 Gather_Associations
(Names
, Args
);
16933 for J
in 1 .. 2 loop
16934 if Present
(Args
(J
)) then
16935 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16939 Check_In_Main_Program
;
16942 while Present
(Nod
) loop
16943 if Nkind
(Nod
) = N_Pragma
16944 and then Pragma_Name
(Nod
) = Name_Main_Storage
16946 Error_Msg_Name_1
:= Pname
;
16947 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16958 -- pragma Memory_Size (NUMERIC_LITERAL)
16960 when Pragma_Memory_Size
=>
16963 -- Memory size is simply ignored
16965 Check_No_Identifiers
;
16966 Check_Arg_Count
(1);
16967 Check_Arg_Is_Integer_Literal
(Arg1
);
16975 -- The only correct use of this pragma is on its own in a file, in
16976 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16977 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16978 -- check for a file containing nothing but a No_Body pragma). If we
16979 -- attempt to process it during normal semantics processing, it means
16980 -- it was misplaced.
16982 when Pragma_No_Body
=>
16986 -----------------------------
16987 -- No_Elaboration_Code_All --
16988 -----------------------------
16990 -- pragma No_Elaboration_Code_All;
16992 when Pragma_No_Elaboration_Code_All
=>
16994 Check_Valid_Library_Unit_Pragma
;
16996 if Nkind
(N
) = N_Null_Statement
then
17000 -- Must appear for a spec or generic spec
17002 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
17003 N_Generic_Package_Declaration
,
17004 N_Generic_Subprogram_Declaration
,
17005 N_Package_Declaration
,
17006 N_Subprogram_Declaration
)
17010 ("pragma% can only occur for package "
17011 & "or subprogram spec"));
17014 -- Set flag in unit table
17016 Set_No_Elab_Code_All
(Current_Sem_Unit
);
17018 -- Set restriction No_Elaboration_Code if this is the main unit
17020 if Current_Sem_Unit
= Main_Unit
then
17021 Set_Restriction
(No_Elaboration_Code
, N
);
17024 -- If we are in the main unit or in an extended main source unit,
17025 -- then we also add it to the configuration restrictions so that
17026 -- it will apply to all units in the extended main source.
17028 if Current_Sem_Unit
= Main_Unit
17029 or else In_Extended_Main_Source_Unit
(N
)
17031 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
17034 -- If in main extended unit, activate transitive with test
17036 if In_Extended_Main_Source_Unit
(N
) then
17037 Opt
.No_Elab_Code_All_Pragma
:= N
;
17044 -- pragma No_Inline ( NAME {, NAME} );
17046 when Pragma_No_Inline
=>
17048 Process_Inline
(Suppressed
);
17054 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17056 when Pragma_No_Return
=> No_Return
: declare
17062 Ghost_Error_Posted
: Boolean := False;
17063 -- Flag set when an error concerning the illegal mix of Ghost and
17064 -- non-Ghost subprograms is emitted.
17066 Ghost_Id
: Entity_Id
:= Empty
;
17067 -- The entity of the first Ghost procedure encountered while
17068 -- processing the arguments of the pragma.
17072 Check_At_Least_N_Arguments
(1);
17074 -- Loop through arguments of pragma
17077 while Present
(Arg
) loop
17078 Check_Arg_Is_Local_Name
(Arg
);
17079 Id
:= Get_Pragma_Arg
(Arg
);
17082 if not Is_Entity_Name
(Id
) then
17083 Error_Pragma_Arg
("entity name required", Arg
);
17086 if Etype
(Id
) = Any_Type
then
17090 -- Loop to find matching procedures
17096 and then Scope
(E
) = Current_Scope
17098 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
17101 -- A pragma that applies to a Ghost entity becomes Ghost
17102 -- for the purposes of legality checks and removal of
17103 -- ignored Ghost code.
17105 Mark_Pragma_As_Ghost
(N
, E
);
17107 -- Capture the entity of the first Ghost procedure being
17108 -- processed for error detection purposes.
17110 if Is_Ghost_Entity
(E
) then
17111 if No
(Ghost_Id
) then
17115 -- Otherwise the subprogram is non-Ghost. It is illegal
17116 -- to mix references to Ghost and non-Ghost entities
17119 elsif Present
(Ghost_Id
)
17120 and then not Ghost_Error_Posted
17122 Ghost_Error_Posted
:= True;
17124 Error_Msg_Name_1
:= Pname
;
17126 ("pragma % cannot mention ghost and non-ghost "
17127 & "procedures", N
);
17129 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
17130 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
17132 Error_Msg_Sloc
:= Sloc
(E
);
17133 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
17136 -- Set flag on any alias as well
17138 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
17139 Set_No_Return
(Alias
(E
));
17145 exit when From_Aspect_Specification
(N
);
17149 -- If entity in not in current scope it may be the enclosing
17150 -- suprogram body to which the aspect applies.
17153 if Entity
(Id
) = Current_Scope
17154 and then From_Aspect_Specification
(N
)
17156 Set_No_Return
(Entity
(Id
));
17158 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
17170 -- pragma No_Run_Time;
17172 -- Note: this pragma is retained for backwards compatibility. See
17173 -- body of Rtsfind for full details on its handling.
17175 when Pragma_No_Run_Time
=>
17177 Check_Valid_Configuration_Pragma
;
17178 Check_Arg_Count
(0);
17180 No_Run_Time_Mode
:= True;
17181 Configurable_Run_Time_Mode
:= True;
17183 -- Set Duration to 32 bits if word size is 32
17185 if Ttypes
.System_Word_Size
= 32 then
17186 Duration_32_Bits_On_Target
:= True;
17189 -- Set appropriate restrictions
17191 Set_Restriction
(No_Finalization
, N
);
17192 Set_Restriction
(No_Exception_Handlers
, N
);
17193 Set_Restriction
(Max_Tasks
, N
, 0);
17194 Set_Restriction
(No_Tasking
, N
);
17196 -----------------------
17197 -- No_Tagged_Streams --
17198 -----------------------
17200 -- pragma No_Tagged_Streams;
17201 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
17203 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
17209 Check_At_Most_N_Arguments
(1);
17211 -- One argument case
17213 if Arg_Count
= 1 then
17214 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17215 Check_Arg_Is_Local_Name
(Arg1
);
17216 E_Id
:= Get_Pragma_Arg
(Arg1
);
17218 if Etype
(E_Id
) = Any_Type
then
17222 E
:= Entity
(E_Id
);
17224 Check_Duplicate_Pragma
(E
);
17226 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
17228 ("argument for pragma% must be root tagged type", Arg1
);
17231 if Rep_Item_Too_Early
(E
, N
)
17233 Rep_Item_Too_Late
(E
, N
)
17237 Set_No_Tagged_Streams_Pragma
(E
, N
);
17240 -- Zero argument case
17243 Check_Is_In_Decl_Part_Or_Package_Spec
;
17244 No_Tagged_Streams
:= N
;
17246 end No_Tagged_Strms
;
17248 ------------------------
17249 -- No_Strict_Aliasing --
17250 ------------------------
17252 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17254 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
17259 Check_At_Most_N_Arguments
(1);
17261 if Arg_Count
= 0 then
17262 Check_Valid_Configuration_Pragma
;
17263 Opt
.No_Strict_Aliasing
:= True;
17266 Check_Optional_Identifier
(Arg2
, Name_Entity
);
17267 Check_Arg_Is_Local_Name
(Arg1
);
17268 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17270 if E_Id
= Any_Type
then
17272 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
17273 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
17276 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
17278 end No_Strict_Aliasing
;
17280 -----------------------
17281 -- Normalize_Scalars --
17282 -----------------------
17284 -- pragma Normalize_Scalars;
17286 when Pragma_Normalize_Scalars
=>
17287 Check_Ada_83_Warning
;
17288 Check_Arg_Count
(0);
17289 Check_Valid_Configuration_Pragma
;
17291 -- Normalize_Scalars creates false positives in CodePeer, and
17292 -- incorrect negative results in GNATprove mode, so ignore this
17293 -- pragma in these modes.
17295 if not (CodePeer_Mode
or GNATprove_Mode
) then
17296 Normalize_Scalars
:= True;
17297 Init_Or_Norm_Scalars
:= True;
17304 -- pragma Obsolescent;
17306 -- pragma Obsolescent (
17307 -- [Message =>] static_string_EXPRESSION
17308 -- [,[Version =>] Ada_05]]);
17310 -- pragma Obsolescent (
17311 -- [Entity =>] NAME
17312 -- [,[Message =>] static_string_EXPRESSION
17313 -- [,[Version =>] Ada_05]] );
17315 when Pragma_Obsolescent
=> Obsolescent
: declare
17319 procedure Set_Obsolescent
(E
: Entity_Id
);
17320 -- Given an entity Ent, mark it as obsolescent if appropriate
17322 ---------------------
17323 -- Set_Obsolescent --
17324 ---------------------
17326 procedure Set_Obsolescent
(E
: Entity_Id
) is
17335 -- A pragma that applies to a Ghost entity becomes Ghost for
17336 -- the purposes of legality checks and removal of ignored Ghost
17339 Mark_Pragma_As_Ghost
(N
, E
);
17341 -- Entity name was given
17343 if Present
(Ename
) then
17345 -- If entity name matches, we are fine. Save entity in
17346 -- pragma argument, for ASIS use.
17348 if Chars
(Ename
) = Chars
(Ent
) then
17349 Set_Entity
(Ename
, Ent
);
17350 Generate_Reference
(Ent
, Ename
);
17352 -- If entity name does not match, only possibility is an
17353 -- enumeration literal from an enumeration type declaration.
17355 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
17357 ("pragma % entity name does not match declaration");
17360 Ent
:= First_Literal
(E
);
17364 ("pragma % entity name does not match any "
17365 & "enumeration literal");
17367 elsif Chars
(Ent
) = Chars
(Ename
) then
17368 Set_Entity
(Ename
, Ent
);
17369 Generate_Reference
(Ent
, Ename
);
17373 Ent
:= Next_Literal
(Ent
);
17379 -- Ent points to entity to be marked
17381 if Arg_Count
>= 1 then
17383 -- Deal with static string argument
17385 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17386 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
17388 for J
in 1 .. String_Length
(S
) loop
17389 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
17391 ("pragma% argument does not allow wide characters",
17396 Obsolescent_Warnings
.Append
17397 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
17399 -- Check for Ada_05 parameter
17401 if Arg_Count
/= 1 then
17402 Check_Arg_Count
(2);
17405 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
17408 Check_Arg_Is_Identifier
(Argx
);
17410 if Chars
(Argx
) /= Name_Ada_05
then
17411 Error_Msg_Name_2
:= Name_Ada_05
;
17413 ("only allowed argument for pragma% is %", Argx
);
17416 if Ada_Version_Explicit
< Ada_2005
17417 or else not Warn_On_Ada_2005_Compatibility
17425 -- Set flag if pragma active
17428 Set_Is_Obsolescent
(Ent
);
17432 end Set_Obsolescent
;
17434 -- Start of processing for pragma Obsolescent
17439 Check_At_Most_N_Arguments
(3);
17441 -- See if first argument specifies an entity name
17445 (Chars
(Arg1
) = Name_Entity
17447 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
17449 N_Operator_Symbol
))
17451 Ename
:= Get_Pragma_Arg
(Arg1
);
17453 -- Eliminate first argument, so we can share processing
17457 Arg_Count
:= Arg_Count
- 1;
17459 -- No Entity name argument given
17465 if Arg_Count
>= 1 then
17466 Check_Optional_Identifier
(Arg1
, Name_Message
);
17468 if Arg_Count
= 2 then
17469 Check_Optional_Identifier
(Arg2
, Name_Version
);
17473 -- Get immediately preceding declaration
17476 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17480 -- Cases where we do not follow anything other than another pragma
17484 -- First case: library level compilation unit declaration with
17485 -- the pragma immediately following the declaration.
17487 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17489 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17492 -- Case 2: library unit placement for package
17496 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17498 if Is_Package_Or_Generic_Package
(Ent
) then
17499 Set_Obsolescent
(Ent
);
17505 -- Cases where we must follow a declaration, including an
17506 -- abstract subprogram declaration, which is not in the
17507 -- other node subtypes.
17510 if Nkind
(Decl
) not in N_Declaration
17511 and then Nkind
(Decl
) not in N_Later_Decl_Item
17512 and then Nkind
(Decl
) not in N_Generic_Declaration
17513 and then Nkind
(Decl
) not in N_Renaming_Declaration
17514 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
17517 ("pragma% misplaced, "
17518 & "must immediately follow a declaration");
17521 Set_Obsolescent
(Defining_Entity
(Decl
));
17531 -- pragma Optimize (Time | Space | Off);
17533 -- The actual check for optimize is done in Gigi. Note that this
17534 -- pragma does not actually change the optimization setting, it
17535 -- simply checks that it is consistent with the pragma.
17537 when Pragma_Optimize
=>
17538 Check_No_Identifiers
;
17539 Check_Arg_Count
(1);
17540 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17542 ------------------------
17543 -- Optimize_Alignment --
17544 ------------------------
17546 -- pragma Optimize_Alignment (Time | Space | Off);
17548 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17550 Check_No_Identifiers
;
17551 Check_Arg_Count
(1);
17552 Check_Valid_Configuration_Pragma
;
17555 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17559 Opt
.Optimize_Alignment
:= 'T';
17561 Opt
.Optimize_Alignment
:= 'S';
17563 Opt
.Optimize_Alignment
:= 'O';
17565 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17569 -- Set indication that mode is set locally. If we are in fact in a
17570 -- configuration pragma file, this setting is harmless since the
17571 -- switch will get reset anyway at the start of each unit.
17573 Optimize_Alignment_Local
:= True;
17574 end Optimize_Alignment
;
17580 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17582 when Pragma_Ordered
=> Ordered
: declare
17583 Assoc
: constant Node_Id
:= Arg1
;
17589 Check_No_Identifiers
;
17590 Check_Arg_Count
(1);
17591 Check_Arg_Is_Local_Name
(Arg1
);
17593 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17594 Find_Type
(Type_Id
);
17595 Typ
:= Entity
(Type_Id
);
17597 if Typ
= Any_Type
then
17600 Typ
:= Underlying_Type
(Typ
);
17603 if not Is_Enumeration_Type
(Typ
) then
17604 Error_Pragma
("pragma% must specify enumeration type");
17607 Check_First_Subtype
(Arg1
);
17608 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17611 -------------------
17612 -- Overflow_Mode --
17613 -------------------
17615 -- pragma Overflow_Mode
17616 -- ([General => ] MODE [, [Assertions => ] MODE]);
17618 -- MODE := STRICT | MINIMIZED | ELIMINATED
17620 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17621 -- since System.Bignums makes this assumption. This is true of nearly
17622 -- all (all?) targets.
17624 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17625 function Get_Overflow_Mode
17627 Arg
: Node_Id
) return Overflow_Mode_Type
;
17628 -- Function to process one pragma argument, Arg. If an identifier
17629 -- is present, it must be Name. Mode type is returned if a valid
17630 -- argument exists, otherwise an error is signalled.
17632 -----------------------
17633 -- Get_Overflow_Mode --
17634 -----------------------
17636 function Get_Overflow_Mode
17638 Arg
: Node_Id
) return Overflow_Mode_Type
17640 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17643 Check_Optional_Identifier
(Arg
, Name
);
17644 Check_Arg_Is_Identifier
(Argx
);
17646 if Chars
(Argx
) = Name_Strict
then
17649 elsif Chars
(Argx
) = Name_Minimized
then
17652 elsif Chars
(Argx
) = Name_Eliminated
then
17653 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17655 ("Eliminated not implemented on this target", Argx
);
17661 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17663 end Get_Overflow_Mode
;
17665 -- Start of processing for Overflow_Mode
17669 Check_At_Least_N_Arguments
(1);
17670 Check_At_Most_N_Arguments
(2);
17672 -- Process first argument
17674 Scope_Suppress
.Overflow_Mode_General
:=
17675 Get_Overflow_Mode
(Name_General
, Arg1
);
17677 -- Case of only one argument
17679 if Arg_Count
= 1 then
17680 Scope_Suppress
.Overflow_Mode_Assertions
:=
17681 Scope_Suppress
.Overflow_Mode_General
;
17683 -- Case of two arguments present
17686 Scope_Suppress
.Overflow_Mode_Assertions
:=
17687 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17691 --------------------------
17692 -- Overriding Renamings --
17693 --------------------------
17695 -- pragma Overriding_Renamings;
17697 when Pragma_Overriding_Renamings
=>
17699 Check_Arg_Count
(0);
17700 Check_Valid_Configuration_Pragma
;
17701 Overriding_Renamings
:= True;
17707 -- pragma Pack (first_subtype_LOCAL_NAME);
17709 when Pragma_Pack
=> Pack
: declare
17710 Assoc
: constant Node_Id
:= Arg1
;
17712 Ignore
: Boolean := False;
17717 Check_No_Identifiers
;
17718 Check_Arg_Count
(1);
17719 Check_Arg_Is_Local_Name
(Arg1
);
17720 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17722 if not Is_Entity_Name
(Type_Id
)
17723 or else not Is_Type
(Entity
(Type_Id
))
17726 ("argument for pragma% must be type or subtype", Arg1
);
17729 Find_Type
(Type_Id
);
17730 Typ
:= Entity
(Type_Id
);
17733 or else Rep_Item_Too_Early
(Typ
, N
)
17737 Typ
:= Underlying_Type
(Typ
);
17740 -- A pragma that applies to a Ghost entity becomes Ghost for the
17741 -- purposes of legality checks and removal of ignored Ghost code.
17743 Mark_Pragma_As_Ghost
(N
, Typ
);
17745 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17746 Error_Pragma
("pragma% must specify array or record type");
17749 Check_First_Subtype
(Arg1
);
17750 Check_Duplicate_Pragma
(Typ
);
17754 if Is_Array_Type
(Typ
) then
17755 Ctyp
:= Component_Type
(Typ
);
17757 -- Ignore pack that does nothing
17759 if Known_Static_Esize
(Ctyp
)
17760 and then Known_Static_RM_Size
(Ctyp
)
17761 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17762 and then Addressable
(Esize
(Ctyp
))
17767 -- Process OK pragma Pack. Note that if there is a separate
17768 -- component clause present, the Pack will be cancelled. This
17769 -- processing is in Freeze.
17771 if not Rep_Item_Too_Late
(Typ
, N
) then
17773 -- In CodePeer mode, we do not need complex front-end
17774 -- expansions related to pragma Pack, so disable handling
17777 if CodePeer_Mode
then
17780 -- Normal case where we do the pack action
17784 Set_Is_Packed
(Base_Type
(Typ
));
17785 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17788 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17792 -- For record types, the pack is always effective
17794 else pragma Assert
(Is_Record_Type
(Typ
));
17795 if not Rep_Item_Too_Late
(Typ
, N
) then
17796 Set_Is_Packed
(Base_Type
(Typ
));
17797 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17798 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17809 -- There is nothing to do here, since we did all the processing for
17810 -- this pragma in Par.Prag (so that it works properly even in syntax
17813 when Pragma_Page
=>
17820 -- pragma Part_Of (ABSTRACT_STATE);
17822 -- ABSTRACT_STATE ::= NAME
17824 when Pragma_Part_Of
=> Part_Of
: declare
17825 procedure Propagate_Part_Of
17826 (Pack_Id
: Entity_Id
;
17827 State_Id
: Entity_Id
;
17828 Instance
: Node_Id
);
17829 -- Propagate the Part_Of indicator to all abstract states and
17830 -- objects declared in the visible state space of a package
17831 -- denoted by Pack_Id. State_Id is the encapsulating state.
17832 -- Instance is the package instantiation node.
17834 -----------------------
17835 -- Propagate_Part_Of --
17836 -----------------------
17838 procedure Propagate_Part_Of
17839 (Pack_Id
: Entity_Id
;
17840 State_Id
: Entity_Id
;
17841 Instance
: Node_Id
)
17843 Has_Item
: Boolean := False;
17844 -- Flag set when the visible state space contains at least one
17845 -- abstract state or variable.
17847 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17848 -- Propagate the Part_Of indicator to all abstract states and
17849 -- objects declared in the visible state space of a package
17850 -- denoted by Pack_Id.
17852 -----------------------
17853 -- Propagate_Part_Of --
17854 -----------------------
17856 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17857 Item_Id
: Entity_Id
;
17860 -- Traverse the entity chain of the package and set relevant
17861 -- attributes of abstract states and objects declared in the
17862 -- visible state space of the package.
17864 Item_Id
:= First_Entity
(Pack_Id
);
17865 while Present
(Item_Id
)
17866 and then not In_Private_Part
(Item_Id
)
17868 -- Do not consider internally generated items
17870 if not Comes_From_Source
(Item_Id
) then
17873 -- The Part_Of indicator turns an abstract state or an
17874 -- object into a constituent of the encapsulating state.
17876 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17882 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17883 Set_Encapsulating_State
(Item_Id
, State_Id
);
17885 -- Recursively handle nested packages and instantiations
17887 elsif Ekind
(Item_Id
) = E_Package
then
17888 Propagate_Part_Of
(Item_Id
);
17891 Next_Entity
(Item_Id
);
17893 end Propagate_Part_Of
;
17895 -- Start of processing for Propagate_Part_Of
17898 Propagate_Part_Of
(Pack_Id
);
17900 -- Detect a package instantiation that is subject to a Part_Of
17901 -- indicator, but has no visible state.
17903 if not Has_Item
then
17905 ("package instantiation & has Part_Of indicator but "
17906 & "lacks visible state", Instance
, Pack_Id
);
17908 end Propagate_Part_Of
;
17913 Encap_Id
: Entity_Id
;
17914 Item_Id
: Entity_Id
;
17918 -- Start of processing for Part_Of
17922 Check_No_Identifiers
;
17923 Check_Arg_Count
(1);
17925 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
17927 -- Object declaration
17929 if Nkind
(Stmt
) = N_Object_Declaration
then
17932 -- Package instantiation
17934 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
17937 -- Single concurrent type declaration
17939 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
17942 -- Otherwise the pragma is associated with an illegal construct
17949 -- Extract the entity of the related object declaration or package
17950 -- instantiation. In the case of the instantiation, use the entity
17951 -- of the instance spec.
17953 if Nkind
(Stmt
) = N_Package_Instantiation
then
17954 Stmt
:= Instance_Spec
(Stmt
);
17957 Item_Id
:= Defining_Entity
(Stmt
);
17958 Encap
:= Get_Pragma_Arg
(Arg1
);
17960 -- A pragma that applies to a Ghost entity becomes Ghost for the
17961 -- purposes of legality checks and removal of ignored Ghost code.
17963 Mark_Pragma_As_Ghost
(N
, Item_Id
);
17965 -- Chain the pragma on the contract for further processing by
17966 -- Analyze_Part_Of_In_Decl_Part or for completeness.
17968 Add_Contract_Item
(N
, Item_Id
);
17970 -- A variable may act as consituent of a single concurrent type
17971 -- which in turn could be declared after the variable. Due to this
17972 -- discrepancy, the full analysis of indicator Part_Of is delayed
17973 -- until the end of the enclosing declarative region (see routine
17974 -- Analyze_Part_Of_In_Decl_Part).
17976 if Ekind
(Item_Id
) = E_Variable
then
17979 -- Otherwise indicator Part_Of applies to a constant or a package
17983 -- Detect any discrepancies between the placement of the
17984 -- constant or package instantiation with respect to state
17985 -- space and the encapsulating state.
17989 Item_Id
=> Item_Id
,
17991 Encap_Id
=> Encap_Id
,
17995 pragma Assert
(Present
(Encap_Id
));
17997 if Ekind
(Item_Id
) = E_Constant
then
17998 Append_Elmt
(Item_Id
, Part_Of_Constituents
(Encap_Id
));
17999 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
18001 -- Propagate the Part_Of indicator to the visible state
18002 -- space of the package instantiation.
18006 (Pack_Id
=> Item_Id
,
18007 State_Id
=> Encap_Id
,
18014 ----------------------------------
18015 -- Partition_Elaboration_Policy --
18016 ----------------------------------
18018 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18020 when Pragma_Partition_Elaboration_Policy
=> declare
18021 subtype PEP_Range
is Name_Id
18022 range First_Partition_Elaboration_Policy_Name
18023 .. Last_Partition_Elaboration_Policy_Name
;
18024 PEP_Val
: PEP_Range
;
18029 Check_Arg_Count
(1);
18030 Check_No_Identifiers
;
18031 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
18032 Check_Valid_Configuration_Pragma
;
18033 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
18036 when Name_Concurrent
=>
18038 when Name_Sequential
=>
18042 if Partition_Elaboration_Policy
/= ' '
18043 and then Partition_Elaboration_Policy
/= PEP
18045 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
18047 ("partition elaboration policy incompatible with policy#");
18049 -- Set new policy, but always preserve System_Location since we
18050 -- like the error message with the run time name.
18053 Partition_Elaboration_Policy
:= PEP
;
18055 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
18056 Partition_Elaboration_Policy_Sloc
:= Loc
;
18065 -- pragma Passive [(PASSIVE_FORM)];
18067 -- PASSIVE_FORM ::= Semaphore | No
18069 when Pragma_Passive
=>
18072 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
18073 Error_Pragma
("pragma% must be within task definition");
18076 if Arg_Count
/= 0 then
18077 Check_Arg_Count
(1);
18078 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
18081 ----------------------------------
18082 -- Preelaborable_Initialization --
18083 ----------------------------------
18085 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18087 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
18092 Check_Arg_Count
(1);
18093 Check_No_Identifiers
;
18094 Check_Arg_Is_Identifier
(Arg1
);
18095 Check_Arg_Is_Local_Name
(Arg1
);
18096 Check_First_Subtype
(Arg1
);
18097 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18099 -- A pragma that applies to a Ghost entity becomes Ghost for the
18100 -- purposes of legality checks and removal of ignored Ghost code.
18102 Mark_Pragma_As_Ghost
(N
, Ent
);
18104 -- The pragma may come from an aspect on a private declaration,
18105 -- even if the freeze point at which this is analyzed in the
18106 -- private part after the full view.
18108 if Has_Private_Declaration
(Ent
)
18109 and then From_Aspect_Specification
(N
)
18113 -- Check appropriate type argument
18115 elsif Is_Private_Type
(Ent
)
18116 or else Is_Protected_Type
(Ent
)
18117 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
18119 -- AI05-0028: The pragma applies to all composite types. Note
18120 -- that we apply this binding interpretation to earlier versions
18121 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18122 -- choice since there are other compilers that do the same.
18124 or else Is_Composite_Type
(Ent
)
18130 ("pragma % can only be applied to private, formal derived, "
18131 & "protected, or composite type", Arg1
);
18134 -- Give an error if the pragma is applied to a protected type that
18135 -- does not qualify (due to having entries, or due to components
18136 -- that do not qualify).
18138 if Is_Protected_Type
(Ent
)
18139 and then not Has_Preelaborable_Initialization
(Ent
)
18142 ("protected type & does not have preelaborable "
18143 & "initialization", Ent
);
18145 -- Otherwise mark the type as definitely having preelaborable
18149 Set_Known_To_Have_Preelab_Init
(Ent
);
18152 if Has_Pragma_Preelab_Init
(Ent
)
18153 and then Warn_On_Redundant_Constructs
18155 Error_Pragma
("?r?duplicate pragma%!");
18157 Set_Has_Pragma_Preelab_Init
(Ent
);
18161 --------------------
18162 -- Persistent_BSS --
18163 --------------------
18165 -- pragma Persistent_BSS [(object_NAME)];
18167 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
18174 Check_At_Most_N_Arguments
(1);
18176 -- Case of application to specific object (one argument)
18178 if Arg_Count
= 1 then
18179 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18181 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
18183 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
18186 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
18189 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18190 Decl
:= Parent
(Ent
);
18192 -- A pragma that applies to a Ghost entity becomes Ghost for
18193 -- the purposes of legality checks and removal of ignored Ghost
18196 Mark_Pragma_As_Ghost
(N
, Ent
);
18198 -- Check for duplication before inserting in list of
18199 -- representation items.
18201 Check_Duplicate_Pragma
(Ent
);
18203 if Rep_Item_Too_Late
(Ent
, N
) then
18207 if Present
(Expression
(Decl
)) then
18209 ("object for pragma% cannot have initialization", Arg1
);
18212 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
18214 ("object type for pragma% is not potentially persistent",
18219 Make_Linker_Section_Pragma
18220 (Ent
, Sloc
(N
), ".persistent.bss");
18221 Insert_After
(N
, Prag
);
18224 -- Case of use as configuration pragma with no arguments
18227 Check_Valid_Configuration_Pragma
;
18228 Persistent_BSS_Mode
:= True;
18230 end Persistent_BSS
;
18236 -- pragma Polling (ON | OFF);
18238 when Pragma_Polling
=>
18240 Check_Arg_Count
(1);
18241 Check_No_Identifiers
;
18242 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
18243 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
18245 -----------------------------------
18246 -- Post/Post_Class/Postcondition --
18247 -----------------------------------
18249 -- pragma Post (Boolean_EXPRESSION);
18250 -- pragma Post_Class (Boolean_EXPRESSION);
18251 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18252 -- [,[Message =>] String_EXPRESSION]);
18254 -- Characteristics:
18256 -- * Analysis - The annotation undergoes initial checks to verify
18257 -- the legal placement and context. Secondary checks preanalyze the
18260 -- Analyze_Pre_Post_Condition_In_Decl_Part
18262 -- * Expansion - The annotation is expanded during the expansion of
18263 -- the related subprogram [body] contract as performed in:
18265 -- Expand_Subprogram_Contract
18267 -- * Template - The annotation utilizes the generic template of the
18268 -- related subprogram [body] when it is:
18270 -- aspect on subprogram declaration
18271 -- aspect on stand alone subprogram body
18272 -- pragma on stand alone subprogram body
18274 -- The annotation must prepare its own template when it is:
18276 -- pragma on subprogram declaration
18278 -- * Globals - Capture of global references must occur after full
18281 -- * Instance - The annotation is instantiated automatically when
18282 -- the related generic subprogram [body] is instantiated except for
18283 -- the "pragma on subprogram declaration" case. In that scenario
18284 -- the annotation must instantiate itself.
18287 Pragma_Post_Class |
18288 Pragma_Postcondition
=>
18289 Analyze_Pre_Post_Condition
;
18291 --------------------------------
18292 -- Pre/Pre_Class/Precondition --
18293 --------------------------------
18295 -- pragma Pre (Boolean_EXPRESSION);
18296 -- pragma Pre_Class (Boolean_EXPRESSION);
18297 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18298 -- [,[Message =>] String_EXPRESSION]);
18300 -- Characteristics:
18302 -- * Analysis - The annotation undergoes initial checks to verify
18303 -- the legal placement and context. Secondary checks preanalyze the
18306 -- Analyze_Pre_Post_Condition_In_Decl_Part
18308 -- * Expansion - The annotation is expanded during the expansion of
18309 -- the related subprogram [body] contract as performed in:
18311 -- Expand_Subprogram_Contract
18313 -- * Template - The annotation utilizes the generic template of the
18314 -- related subprogram [body] when it is:
18316 -- aspect on subprogram declaration
18317 -- aspect on stand alone subprogram body
18318 -- pragma on stand alone subprogram body
18320 -- The annotation must prepare its own template when it is:
18322 -- pragma on subprogram declaration
18324 -- * Globals - Capture of global references must occur after full
18327 -- * Instance - The annotation is instantiated automatically when
18328 -- the related generic subprogram [body] is instantiated except for
18329 -- the "pragma on subprogram declaration" case. In that scenario
18330 -- the annotation must instantiate itself.
18334 Pragma_Precondition
=>
18335 Analyze_Pre_Post_Condition
;
18341 -- pragma Predicate
18342 -- ([Entity =>] type_LOCAL_NAME,
18343 -- [Check =>] boolean_EXPRESSION);
18345 when Pragma_Predicate
=> Predicate
: declare
18352 Check_Arg_Count
(2);
18353 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18354 Check_Optional_Identifier
(Arg2
, Name_Check
);
18356 Check_Arg_Is_Local_Name
(Arg1
);
18358 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18359 Find_Type
(Type_Id
);
18360 Typ
:= Entity
(Type_Id
);
18362 if Typ
= Any_Type
then
18366 -- A pragma that applies to a Ghost entity becomes Ghost for the
18367 -- purposes of legality checks and removal of ignored Ghost code.
18369 Mark_Pragma_As_Ghost
(N
, Typ
);
18371 -- The remaining processing is simply to link the pragma on to
18372 -- the rep item chain, for processing when the type is frozen.
18373 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18374 -- mark the type as having predicates.
18376 Set_Has_Predicates
(Typ
);
18377 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18380 -----------------------
18381 -- Predicate_Failure --
18382 -----------------------
18384 -- pragma Predicate_Failure
18385 -- ([Entity =>] type_LOCAL_NAME,
18386 -- [Message =>] string_EXPRESSION);
18388 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
18395 Check_Arg_Count
(2);
18396 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18397 Check_Optional_Identifier
(Arg2
, Name_Message
);
18399 Check_Arg_Is_Local_Name
(Arg1
);
18401 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18402 Find_Type
(Type_Id
);
18403 Typ
:= Entity
(Type_Id
);
18405 if Typ
= Any_Type
then
18409 -- A pragma that applies to a Ghost entity becomes Ghost for the
18410 -- purposes of legality checks and removal of ignored Ghost code.
18412 Mark_Pragma_As_Ghost
(N
, Typ
);
18414 -- The remaining processing is simply to link the pragma on to
18415 -- the rep item chain, for processing when the type is frozen.
18416 -- This is accomplished by a call to Rep_Item_Too_Late.
18418 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18419 end Predicate_Failure
;
18425 -- pragma Preelaborate [(library_unit_NAME)];
18427 -- Set the flag Is_Preelaborated of program unit name entity
18429 when Pragma_Preelaborate
=> Preelaborate
: declare
18430 Pa
: constant Node_Id
:= Parent
(N
);
18431 Pk
: constant Node_Kind
:= Nkind
(Pa
);
18435 Check_Ada_83_Warning
;
18436 Check_Valid_Library_Unit_Pragma
;
18438 if Nkind
(N
) = N_Null_Statement
then
18442 Ent
:= Find_Lib_Unit_Name
;
18444 -- A pragma that applies to a Ghost entity becomes Ghost for the
18445 -- purposes of legality checks and removal of ignored Ghost code.
18447 Mark_Pragma_As_Ghost
(N
, Ent
);
18448 Check_Duplicate_Pragma
(Ent
);
18450 -- This filters out pragmas inside generic parents that show up
18451 -- inside instantiations. Pragmas that come from aspects in the
18452 -- unit are not ignored.
18454 if Present
(Ent
) then
18455 if Pk
= N_Package_Specification
18456 and then Present
(Generic_Parent
(Pa
))
18457 and then not From_Aspect_Specification
(N
)
18462 if not Debug_Flag_U
then
18463 Set_Is_Preelaborated
(Ent
);
18464 Set_Suppress_Elaboration_Warnings
(Ent
);
18470 -------------------------------
18471 -- Prefix_Exception_Messages --
18472 -------------------------------
18474 -- pragma Prefix_Exception_Messages;
18476 when Pragma_Prefix_Exception_Messages
=>
18478 Check_Valid_Configuration_Pragma
;
18479 Check_Arg_Count
(0);
18480 Prefix_Exception_Messages
:= True;
18486 -- pragma Priority (EXPRESSION);
18488 when Pragma_Priority
=> Priority
: declare
18489 P
: constant Node_Id
:= Parent
(N
);
18494 Check_No_Identifiers
;
18495 Check_Arg_Count
(1);
18499 if Nkind
(P
) = N_Subprogram_Body
then
18500 Check_In_Main_Program
;
18502 Ent
:= Defining_Unit_Name
(Specification
(P
));
18504 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18505 Ent
:= Defining_Identifier
(Ent
);
18508 Arg
:= Get_Pragma_Arg
(Arg1
);
18509 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18513 if not Is_OK_Static_Expression
(Arg
) then
18514 Flag_Non_Static_Expr
18515 ("main subprogram priority is not static!", Arg
);
18518 -- If constraint error, then we already signalled an error
18520 elsif Raises_Constraint_Error
(Arg
) then
18523 -- Otherwise check in range except if Relaxed_RM_Semantics
18524 -- where we ignore the value if out of range.
18528 Val
: constant Uint
:= Expr_Value
(Arg
);
18530 if not Relaxed_RM_Semantics
18533 or else Val
> Expr_Value
(Expression
18534 (Parent
(RTE
(RE_Max_Priority
)))))
18537 ("main subprogram priority is out of range", Arg1
);
18540 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18545 -- Load an arbitrary entity from System.Tasking.Stages or
18546 -- System.Tasking.Restricted.Stages (depending on the
18547 -- supported profile) to make sure that one of these packages
18548 -- is implicitly with'ed, since we need to have the tasking
18549 -- run time active for the pragma Priority to have any effect.
18550 -- Previously we with'ed the package System.Tasking, but this
18551 -- package does not trigger the required initialization of the
18552 -- run-time library.
18555 Discard
: Entity_Id
;
18556 pragma Warnings
(Off
, Discard
);
18558 if Restricted_Profile
then
18559 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18561 Discard
:= RTE
(RE_Activate_Tasks
);
18565 -- Task or Protected, must be of type Integer
18567 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18568 Arg
:= Get_Pragma_Arg
(Arg1
);
18569 Ent
:= Defining_Identifier
(Parent
(P
));
18571 -- The expression must be analyzed in the special manner
18572 -- described in "Handling of Default and Per-Object
18573 -- Expressions" in sem.ads.
18575 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18577 if not Is_OK_Static_Expression
(Arg
) then
18578 Check_Restriction
(Static_Priorities
, Arg
);
18581 -- Anything else is incorrect
18587 -- Check duplicate pragma before we chain the pragma in the Rep
18588 -- Item chain of Ent.
18590 Check_Duplicate_Pragma
(Ent
);
18591 Record_Rep_Item
(Ent
, N
);
18594 -----------------------------------
18595 -- Priority_Specific_Dispatching --
18596 -----------------------------------
18598 -- pragma Priority_Specific_Dispatching (
18599 -- policy_IDENTIFIER,
18600 -- first_priority_EXPRESSION,
18601 -- last_priority_EXPRESSION);
18603 when Pragma_Priority_Specific_Dispatching
=>
18604 Priority_Specific_Dispatching
: declare
18605 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18606 -- This is the entity System.Any_Priority;
18609 Lower_Bound
: Node_Id
;
18610 Upper_Bound
: Node_Id
;
18616 Check_Arg_Count
(3);
18617 Check_No_Identifiers
;
18618 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18619 Check_Valid_Configuration_Pragma
;
18620 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18621 DP
:= Fold_Upper
(Name_Buffer
(1));
18623 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18624 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
18625 Lower_Val
:= Expr_Value
(Lower_Bound
);
18627 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18628 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
18629 Upper_Val
:= Expr_Value
(Upper_Bound
);
18631 -- It is not allowed to use Task_Dispatching_Policy and
18632 -- Priority_Specific_Dispatching in the same partition.
18634 if Task_Dispatching_Policy
/= ' ' then
18635 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18637 ("pragma% incompatible with Task_Dispatching_Policy#");
18639 -- Check lower bound in range
18641 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18643 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18646 ("first_priority is out of range", Arg2
);
18648 -- Check upper bound in range
18650 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18652 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18655 ("last_priority is out of range", Arg3
);
18657 -- Check that the priority range is valid
18659 elsif Lower_Val
> Upper_Val
then
18661 ("last_priority_expression must be greater than or equal to "
18662 & "first_priority_expression");
18664 -- Store the new policy, but always preserve System_Location since
18665 -- we like the error message with the run-time name.
18668 -- Check overlapping in the priority ranges specified in other
18669 -- Priority_Specific_Dispatching pragmas within the same
18670 -- partition. We can only check those we know about.
18673 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18675 if Specific_Dispatching
.Table
(J
).First_Priority
in
18676 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18677 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18678 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18681 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18683 ("priority range overlaps with "
18684 & "Priority_Specific_Dispatching#");
18688 -- The use of Priority_Specific_Dispatching is incompatible
18689 -- with Task_Dispatching_Policy.
18691 if Task_Dispatching_Policy
/= ' ' then
18692 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18694 ("Priority_Specific_Dispatching incompatible "
18695 & "with Task_Dispatching_Policy#");
18698 -- The use of Priority_Specific_Dispatching forces ceiling
18701 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18702 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18704 ("Priority_Specific_Dispatching incompatible "
18705 & "with Locking_Policy#");
18707 -- Set the Ceiling_Locking policy, but preserve System_Location
18708 -- since we like the error message with the run time name.
18711 Locking_Policy
:= 'C';
18713 if Locking_Policy_Sloc
/= System_Location
then
18714 Locking_Policy_Sloc
:= Loc
;
18718 -- Add entry in the table
18720 Specific_Dispatching
.Append
18721 ((Dispatching_Policy
=> DP
,
18722 First_Priority
=> UI_To_Int
(Lower_Val
),
18723 Last_Priority
=> UI_To_Int
(Upper_Val
),
18724 Pragma_Loc
=> Loc
));
18726 end Priority_Specific_Dispatching
;
18732 -- pragma Profile (profile_IDENTIFIER);
18734 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18736 when Pragma_Profile
=>
18738 Check_Arg_Count
(1);
18739 Check_Valid_Configuration_Pragma
;
18740 Check_No_Identifiers
;
18743 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18746 if Chars
(Argx
) = Name_Ravenscar
then
18747 Set_Ravenscar_Profile
(N
);
18749 elsif Chars
(Argx
) = Name_Restricted
then
18750 Set_Profile_Restrictions
18752 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18754 elsif Chars
(Argx
) = Name_Rational
then
18755 Set_Rational_Profile
;
18757 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18758 Set_Profile_Restrictions
18759 (No_Implementation_Extensions
,
18760 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18763 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18767 ----------------------
18768 -- Profile_Warnings --
18769 ----------------------
18771 -- pragma Profile_Warnings (profile_IDENTIFIER);
18773 -- profile_IDENTIFIER => Restricted | Ravenscar
18775 when Pragma_Profile_Warnings
=>
18777 Check_Arg_Count
(1);
18778 Check_Valid_Configuration_Pragma
;
18779 Check_No_Identifiers
;
18782 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18785 if Chars
(Argx
) = Name_Ravenscar
then
18786 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18788 elsif Chars
(Argx
) = Name_Restricted
then
18789 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18791 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18792 Set_Profile_Restrictions
18793 (No_Implementation_Extensions
, N
, Warn
=> True);
18796 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18800 --------------------------
18801 -- Propagate_Exceptions --
18802 --------------------------
18804 -- pragma Propagate_Exceptions;
18806 -- Note: this pragma is obsolete and has no effect
18808 when Pragma_Propagate_Exceptions
=>
18810 Check_Arg_Count
(0);
18812 if Warn_On_Obsolescent_Feature
then
18814 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18815 "and has no effect?j?", N
);
18818 -----------------------------
18819 -- Provide_Shift_Operators --
18820 -----------------------------
18822 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18824 when Pragma_Provide_Shift_Operators
=>
18825 Provide_Shift_Operators
: declare
18828 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18829 -- Insert declaration and pragma Instrinsic for named shift op
18831 ----------------------------
18832 -- Declare_Shift_Operator --
18833 ----------------------------
18835 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18841 Make_Subprogram_Declaration
(Loc
,
18842 Make_Function_Specification
(Loc
,
18843 Defining_Unit_Name
=>
18844 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18846 Result_Definition
=>
18847 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18849 Parameter_Specifications
=> New_List
(
18850 Make_Parameter_Specification
(Loc
,
18851 Defining_Identifier
=>
18852 Make_Defining_Identifier
(Loc
, Name_Value
),
18854 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18856 Make_Parameter_Specification
(Loc
,
18857 Defining_Identifier
=>
18858 Make_Defining_Identifier
(Loc
, Name_Amount
),
18860 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18864 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18865 Pragma_Argument_Associations
=> New_List
(
18866 Make_Pragma_Argument_Association
(Loc
,
18867 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18868 Make_Pragma_Argument_Association
(Loc
,
18869 Expression
=> Make_Identifier
(Loc
, Nam
))));
18871 Insert_After
(N
, Import
);
18872 Insert_After
(N
, Func
);
18873 end Declare_Shift_Operator
;
18875 -- Start of processing for Provide_Shift_Operators
18879 Check_Arg_Count
(1);
18880 Check_Arg_Is_Local_Name
(Arg1
);
18882 Arg1
:= Get_Pragma_Arg
(Arg1
);
18884 -- We must have an entity name
18886 if not Is_Entity_Name
(Arg1
) then
18888 ("pragma % must apply to integer first subtype", Arg1
);
18891 -- If no Entity, means there was a prior error so ignore
18893 if Present
(Entity
(Arg1
)) then
18894 Ent
:= Entity
(Arg1
);
18896 -- Apply error checks
18898 if not Is_First_Subtype
(Ent
) then
18900 ("cannot apply pragma %",
18901 "\& is not a first subtype",
18904 elsif not Is_Integer_Type
(Ent
) then
18906 ("cannot apply pragma %",
18907 "\& is not an integer type",
18910 elsif Has_Shift_Operator
(Ent
) then
18912 ("cannot apply pragma %",
18913 "\& already has declared shift operators",
18916 elsif Is_Frozen
(Ent
) then
18918 ("pragma % appears too late",
18919 "\& is already frozen",
18923 -- Now declare the operators. We do this during analysis rather
18924 -- than expansion, since we want the operators available if we
18925 -- are operating in -gnatc or ASIS mode.
18927 Declare_Shift_Operator
(Name_Rotate_Left
);
18928 Declare_Shift_Operator
(Name_Rotate_Right
);
18929 Declare_Shift_Operator
(Name_Shift_Left
);
18930 Declare_Shift_Operator
(Name_Shift_Right
);
18931 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18933 end Provide_Shift_Operators
;
18939 -- pragma Psect_Object (
18940 -- [Internal =>] LOCAL_NAME,
18941 -- [, [External =>] EXTERNAL_SYMBOL]
18942 -- [, [Size =>] EXTERNAL_SYMBOL]);
18944 when Pragma_Psect_Object | Pragma_Common_Object
=>
18945 Psect_Object
: declare
18946 Args
: Args_List
(1 .. 3);
18947 Names
: constant Name_List
(1 .. 3) := (
18952 Internal
: Node_Id
renames Args
(1);
18953 External
: Node_Id
renames Args
(2);
18954 Size
: Node_Id
renames Args
(3);
18956 Def_Id
: Entity_Id
;
18958 procedure Check_Arg
(Arg
: Node_Id
);
18959 -- Checks that argument is either a string literal or an
18960 -- identifier, and posts error message if not.
18966 procedure Check_Arg
(Arg
: Node_Id
) is
18968 if not Nkind_In
(Original_Node
(Arg
),
18973 ("inappropriate argument for pragma %", Arg
);
18977 -- Start of processing for Common_Object/Psect_Object
18981 Gather_Associations
(Names
, Args
);
18982 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18984 Def_Id
:= Entity
(Internal
);
18986 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18988 ("pragma% must designate an object", Internal
);
18991 Check_Arg
(Internal
);
18993 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18995 ("cannot use pragma% for imported/exported object",
18999 if Is_Concurrent_Type
(Etype
(Internal
)) then
19001 ("cannot specify pragma % for task/protected object",
19005 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
19007 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
19009 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
19012 if Ekind
(Def_Id
) = E_Constant
then
19014 ("cannot specify pragma % for a constant", Internal
);
19017 if Is_Record_Type
(Etype
(Internal
)) then
19023 Ent
:= First_Entity
(Etype
(Internal
));
19024 while Present
(Ent
) loop
19025 Decl
:= Declaration_Node
(Ent
);
19027 if Ekind
(Ent
) = E_Component
19028 and then Nkind
(Decl
) = N_Component_Declaration
19029 and then Present
(Expression
(Decl
))
19030 and then Warn_On_Export_Import
19033 ("?x?object for pragma % has defaults", Internal
);
19043 if Present
(Size
) then
19047 if Present
(External
) then
19048 Check_Arg_Is_External_Name
(External
);
19051 -- If all error tests pass, link pragma on to the rep item chain
19053 Record_Rep_Item
(Def_Id
, N
);
19060 -- pragma Pure [(library_unit_NAME)];
19062 when Pragma_Pure
=> Pure
: declare
19066 Check_Ada_83_Warning
;
19067 Check_Valid_Library_Unit_Pragma
;
19069 if Nkind
(N
) = N_Null_Statement
then
19073 Ent
:= Find_Lib_Unit_Name
;
19075 -- A pragma that applies to a Ghost entity becomes Ghost for the
19076 -- purposes of legality checks and removal of ignored Ghost code.
19078 Mark_Pragma_As_Ghost
(N
, Ent
);
19080 if not Debug_Flag_U
then
19082 Set_Has_Pragma_Pure
(Ent
);
19083 Set_Suppress_Elaboration_Warnings
(Ent
);
19087 -------------------
19088 -- Pure_Function --
19089 -------------------
19091 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19093 when Pragma_Pure_Function
=> Pure_Function
: declare
19094 Def_Id
: Entity_Id
;
19097 Effective
: Boolean := False;
19101 Check_Arg_Count
(1);
19102 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19103 Check_Arg_Is_Local_Name
(Arg1
);
19104 E_Id
:= Get_Pragma_Arg
(Arg1
);
19106 if Error_Posted
(E_Id
) then
19110 -- Loop through homonyms (overloadings) of referenced entity
19112 E
:= Entity
(E_Id
);
19114 -- A pragma that applies to a Ghost entity becomes Ghost for the
19115 -- purposes of legality checks and removal of ignored Ghost code.
19117 Mark_Pragma_As_Ghost
(N
, E
);
19119 if Present
(E
) then
19121 Def_Id
:= Get_Base_Subprogram
(E
);
19123 if not Ekind_In
(Def_Id
, E_Function
,
19124 E_Generic_Function
,
19128 ("pragma% requires a function name", Arg1
);
19131 Set_Is_Pure
(Def_Id
);
19133 if not Has_Pragma_Pure_Function
(Def_Id
) then
19134 Set_Has_Pragma_Pure_Function
(Def_Id
);
19138 exit when From_Aspect_Specification
(N
);
19140 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
19144 and then Warn_On_Redundant_Constructs
19147 ("pragma Pure_Function on& is redundant?r?",
19153 --------------------
19154 -- Queuing_Policy --
19155 --------------------
19157 -- pragma Queuing_Policy (policy_IDENTIFIER);
19159 when Pragma_Queuing_Policy
=> declare
19163 Check_Ada_83_Warning
;
19164 Check_Arg_Count
(1);
19165 Check_No_Identifiers
;
19166 Check_Arg_Is_Queuing_Policy
(Arg1
);
19167 Check_Valid_Configuration_Pragma
;
19168 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
19169 QP
:= Fold_Upper
(Name_Buffer
(1));
19171 if Queuing_Policy
/= ' '
19172 and then Queuing_Policy
/= QP
19174 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
19175 Error_Pragma
("queuing policy incompatible with policy#");
19177 -- Set new policy, but always preserve System_Location since we
19178 -- like the error message with the run time name.
19181 Queuing_Policy
:= QP
;
19183 if Queuing_Policy_Sloc
/= System_Location
then
19184 Queuing_Policy_Sloc
:= Loc
;
19193 -- pragma Rational, for compatibility with foreign compiler
19195 when Pragma_Rational
=>
19196 Set_Rational_Profile
;
19198 ---------------------
19199 -- Refined_Depends --
19200 ---------------------
19202 -- pragma Refined_Depends (DEPENDENCY_RELATION);
19204 -- DEPENDENCY_RELATION ::=
19206 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
19208 -- DEPENDENCY_CLAUSE ::=
19209 -- OUTPUT_LIST =>[+] INPUT_LIST
19210 -- | NULL_DEPENDENCY_CLAUSE
19212 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19214 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19216 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19218 -- OUTPUT ::= NAME | FUNCTION_RESULT
19221 -- where FUNCTION_RESULT is a function Result attribute_reference
19223 -- Characteristics:
19225 -- * Analysis - The annotation undergoes initial checks to verify
19226 -- the legal placement and context. Secondary checks fully analyze
19227 -- the dependency clauses/global list in:
19229 -- Analyze_Refined_Depends_In_Decl_Part
19231 -- * Expansion - None.
19233 -- * Template - The annotation utilizes the generic template of the
19234 -- related subprogram body.
19236 -- * Globals - Capture of global references must occur after full
19239 -- * Instance - The annotation is instantiated automatically when
19240 -- the related generic subprogram body is instantiated.
19242 when Pragma_Refined_Depends
=> Refined_Depends
: declare
19243 Body_Id
: Entity_Id
;
19245 Spec_Id
: Entity_Id
;
19248 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
19252 -- Chain the pragma on the contract for further processing by
19253 -- Analyze_Refined_Depends_In_Decl_Part.
19255 Add_Contract_Item
(N
, Body_Id
);
19257 -- The legality checks of pragmas Refined_Depends and
19258 -- Refined_Global are affected by the SPARK mode in effect and
19259 -- the volatility of the context. In addition these two pragmas
19260 -- are subject to an inherent order:
19262 -- 1) Refined_Global
19263 -- 2) Refined_Depends
19265 -- Analyze all these pragmas in the order outlined above
19267 Analyze_If_Present
(Pragma_SPARK_Mode
);
19268 Analyze_If_Present
(Pragma_Volatile_Function
);
19269 Analyze_If_Present
(Pragma_Refined_Global
);
19270 Analyze_Refined_Depends_In_Decl_Part
(N
);
19272 end Refined_Depends
;
19274 --------------------
19275 -- Refined_Global --
19276 --------------------
19278 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
19280 -- GLOBAL_SPECIFICATION ::=
19283 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
19285 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
19287 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
19288 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
19289 -- GLOBAL_ITEM ::= NAME
19291 -- Characteristics:
19293 -- * Analysis - The annotation undergoes initial checks to verify
19294 -- the legal placement and context. Secondary checks fully analyze
19295 -- the dependency clauses/global list in:
19297 -- Analyze_Refined_Global_In_Decl_Part
19299 -- * Expansion - None.
19301 -- * Template - The annotation utilizes the generic template of the
19302 -- related subprogram body.
19304 -- * Globals - Capture of global references must occur after full
19307 -- * Instance - The annotation is instantiated automatically when
19308 -- the related generic subprogram body is instantiated.
19310 when Pragma_Refined_Global
=> Refined_Global
: declare
19311 Body_Id
: Entity_Id
;
19313 Spec_Id
: Entity_Id
;
19316 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
19320 -- Chain the pragma on the contract for further processing by
19321 -- Analyze_Refined_Global_In_Decl_Part.
19323 Add_Contract_Item
(N
, Body_Id
);
19325 -- The legality checks of pragmas Refined_Depends and
19326 -- Refined_Global are affected by the SPARK mode in effect and
19327 -- the volatility of the context. In addition these two pragmas
19328 -- are subject to an inherent order:
19330 -- 1) Refined_Global
19331 -- 2) Refined_Depends
19333 -- Analyze all these pragmas in the order outlined above
19335 Analyze_If_Present
(Pragma_SPARK_Mode
);
19336 Analyze_If_Present
(Pragma_Volatile_Function
);
19337 Analyze_Refined_Global_In_Decl_Part
(N
);
19338 Analyze_If_Present
(Pragma_Refined_Depends
);
19340 end Refined_Global
;
19346 -- pragma Refined_Post (boolean_EXPRESSION);
19348 -- Characteristics:
19350 -- * Analysis - The annotation is fully analyzed immediately upon
19351 -- elaboration as it cannot forward reference entities.
19353 -- * Expansion - The annotation is expanded during the expansion of
19354 -- the related subprogram body contract as performed in:
19356 -- Expand_Subprogram_Contract
19358 -- * Template - The annotation utilizes the generic template of the
19359 -- related subprogram body.
19361 -- * Globals - Capture of global references must occur after full
19364 -- * Instance - The annotation is instantiated automatically when
19365 -- the related generic subprogram body is instantiated.
19367 when Pragma_Refined_Post
=> Refined_Post
: declare
19368 Body_Id
: Entity_Id
;
19370 Spec_Id
: Entity_Id
;
19373 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
19375 -- Fully analyze the pragma when it appears inside a subprogram
19376 -- body because it cannot benefit from forward references.
19380 -- Chain the pragma on the contract for completeness
19382 Add_Contract_Item
(N
, Body_Id
);
19384 -- The legality checks of pragma Refined_Post are affected by
19385 -- the SPARK mode in effect and the volatility of the context.
19386 -- Analyze all pragmas in a specific order.
19388 Analyze_If_Present
(Pragma_SPARK_Mode
);
19389 Analyze_If_Present
(Pragma_Volatile_Function
);
19390 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
19392 -- Currently it is not possible to inline pre/postconditions on
19393 -- a subprogram subject to pragma Inline_Always.
19395 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
19399 -------------------
19400 -- Refined_State --
19401 -------------------
19403 -- pragma Refined_State (REFINEMENT_LIST);
19405 -- REFINEMENT_LIST ::=
19406 -- REFINEMENT_CLAUSE
19407 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19409 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19411 -- CONSTITUENT_LIST ::=
19414 -- | (CONSTITUENT {, CONSTITUENT})
19416 -- CONSTITUENT ::= object_NAME | state_NAME
19418 -- Characteristics:
19420 -- * Analysis - The annotation undergoes initial checks to verify
19421 -- the legal placement and context. Secondary checks preanalyze the
19422 -- refinement clauses in:
19424 -- Analyze_Refined_State_In_Decl_Part
19426 -- * Expansion - None.
19428 -- * Template - The annotation utilizes the template of the related
19431 -- * Globals - Capture of global references must occur after full
19434 -- * Instance - The annotation is instantiated automatically when
19435 -- the related generic package body is instantiated.
19437 when Pragma_Refined_State
=> Refined_State
: declare
19438 Pack_Decl
: Node_Id
;
19439 Spec_Id
: Entity_Id
;
19443 Check_No_Identifiers
;
19444 Check_Arg_Count
(1);
19446 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
19448 -- Ensure the proper placement of the pragma. Refined states must
19449 -- be associated with a package body.
19451 if Nkind
(Pack_Decl
) = N_Package_Body
then
19454 -- Otherwise the pragma is associated with an illegal construct
19461 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
19463 -- Chain the pragma on the contract for further processing by
19464 -- Analyze_Refined_State_In_Decl_Part.
19466 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
19468 -- The legality checks of pragma Refined_State are affected by the
19469 -- SPARK mode in effect. Analyze all pragmas in a specific order.
19471 Analyze_If_Present
(Pragma_SPARK_Mode
);
19473 -- A pragma that applies to a Ghost entity becomes Ghost for the
19474 -- purposes of legality checks and removal of ignored Ghost code.
19476 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
19478 -- State refinement is allowed only when the corresponding package
19479 -- declaration has non-null pragma Abstract_State. Refinement not
19480 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19482 if SPARK_Mode
/= Off
19484 (No
(Abstract_States
(Spec_Id
))
19485 or else Has_Null_Abstract_State
(Spec_Id
))
19488 ("useless refinement, package & does not define abstract "
19489 & "states", N
, Spec_Id
);
19494 -----------------------
19495 -- Relative_Deadline --
19496 -----------------------
19498 -- pragma Relative_Deadline (time_span_EXPRESSION);
19500 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
19501 P
: constant Node_Id
:= Parent
(N
);
19506 Check_No_Identifiers
;
19507 Check_Arg_Count
(1);
19509 Arg
:= Get_Pragma_Arg
(Arg1
);
19511 -- The expression must be analyzed in the special manner described
19512 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19514 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
19518 if Nkind
(P
) = N_Subprogram_Body
then
19519 Check_In_Main_Program
;
19521 -- Only Task and subprogram cases allowed
19523 elsif Nkind
(P
) /= N_Task_Definition
then
19527 -- Check duplicate pragma before we set the corresponding flag
19529 if Has_Relative_Deadline_Pragma
(P
) then
19530 Error_Pragma
("duplicate pragma% not allowed");
19533 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19534 -- Relative_Deadline pragma node cannot be inserted in the Rep
19535 -- Item chain of Ent since it is rewritten by the expander as a
19536 -- procedure call statement that will break the chain.
19538 Set_Has_Relative_Deadline_Pragma
(P
);
19539 end Relative_Deadline
;
19541 ------------------------
19542 -- Remote_Access_Type --
19543 ------------------------
19545 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19547 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
19552 Check_Arg_Count
(1);
19553 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19554 Check_Arg_Is_Local_Name
(Arg1
);
19556 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
19558 -- A pragma that applies to a Ghost entity becomes Ghost for the
19559 -- purposes of legality checks and removal of ignored Ghost code.
19561 Mark_Pragma_As_Ghost
(N
, E
);
19563 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
19564 and then Ekind
(E
) = E_General_Access_Type
19565 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
19566 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
19568 and then Is_Valid_Remote_Object_Type
19569 (Root_Type
(Directly_Designated_Type
(E
)))
19571 Set_Is_Remote_Types
(E
);
19575 ("pragma% applies only to formal access to classwide types",
19578 end Remote_Access_Type
;
19580 ---------------------------
19581 -- Remote_Call_Interface --
19582 ---------------------------
19584 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19586 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19587 Cunit_Node
: Node_Id
;
19588 Cunit_Ent
: Entity_Id
;
19592 Check_Ada_83_Warning
;
19593 Check_Valid_Library_Unit_Pragma
;
19595 if Nkind
(N
) = N_Null_Statement
then
19599 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19600 K
:= Nkind
(Unit
(Cunit_Node
));
19601 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19603 -- A pragma that applies to a Ghost entity becomes Ghost for the
19604 -- purposes of legality checks and removal of ignored Ghost code.
19606 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
19608 if K
= N_Package_Declaration
19609 or else K
= N_Generic_Package_Declaration
19610 or else K
= N_Subprogram_Declaration
19611 or else K
= N_Generic_Subprogram_Declaration
19612 or else (K
= N_Subprogram_Body
19613 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19618 "pragma% must apply to package or subprogram declaration");
19621 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19622 end Remote_Call_Interface
;
19628 -- pragma Remote_Types [(library_unit_NAME)];
19630 when Pragma_Remote_Types
=> Remote_Types
: declare
19631 Cunit_Node
: Node_Id
;
19632 Cunit_Ent
: Entity_Id
;
19635 Check_Ada_83_Warning
;
19636 Check_Valid_Library_Unit_Pragma
;
19638 if Nkind
(N
) = N_Null_Statement
then
19642 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19643 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19645 -- A pragma that applies to a Ghost entity becomes Ghost for the
19646 -- purposes of legality checks and removal of ignored Ghost code.
19648 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
19650 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19651 N_Generic_Package_Declaration
)
19654 ("pragma% can only apply to a package declaration");
19657 Set_Is_Remote_Types
(Cunit_Ent
);
19664 -- pragma Ravenscar;
19666 when Pragma_Ravenscar
=>
19668 Check_Arg_Count
(0);
19669 Check_Valid_Configuration_Pragma
;
19670 Set_Ravenscar_Profile
(N
);
19672 if Warn_On_Obsolescent_Feature
then
19674 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19676 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19679 -------------------------
19680 -- Restricted_Run_Time --
19681 -------------------------
19683 -- pragma Restricted_Run_Time;
19685 when Pragma_Restricted_Run_Time
=>
19687 Check_Arg_Count
(0);
19688 Check_Valid_Configuration_Pragma
;
19689 Set_Profile_Restrictions
19690 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19692 if Warn_On_Obsolescent_Feature
then
19694 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19697 ("|use pragma Profile (Restricted) instead?j?", N
);
19704 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19707 -- restriction_IDENTIFIER
19708 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19710 when Pragma_Restrictions
=>
19711 Process_Restrictions_Or_Restriction_Warnings
19712 (Warn
=> Treat_Restrictions_As_Warnings
);
19714 --------------------------
19715 -- Restriction_Warnings --
19716 --------------------------
19718 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19721 -- restriction_IDENTIFIER
19722 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19724 when Pragma_Restriction_Warnings
=>
19726 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19732 -- pragma Reviewable;
19734 when Pragma_Reviewable
=>
19735 Check_Ada_83_Warning
;
19736 Check_Arg_Count
(0);
19738 -- Call dummy debugging function rv. This is done to assist front
19739 -- end debugging. By placing a Reviewable pragma in the source
19740 -- program, a breakpoint on rv catches this place in the source,
19741 -- allowing convenient stepping to the point of interest.
19745 --------------------------
19746 -- Short_Circuit_And_Or --
19747 --------------------------
19749 -- pragma Short_Circuit_And_Or;
19751 when Pragma_Short_Circuit_And_Or
=>
19753 Check_Arg_Count
(0);
19754 Check_Valid_Configuration_Pragma
;
19755 Short_Circuit_And_Or
:= True;
19757 -------------------
19758 -- Share_Generic --
19759 -------------------
19761 -- pragma Share_Generic (GNAME {, GNAME});
19763 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19765 when Pragma_Share_Generic
=>
19767 Process_Generic_List
;
19773 -- pragma Shared (LOCAL_NAME);
19775 when Pragma_Shared
=>
19777 Process_Atomic_Independent_Shared_Volatile
;
19779 --------------------
19780 -- Shared_Passive --
19781 --------------------
19783 -- pragma Shared_Passive [(library_unit_NAME)];
19785 -- Set the flag Is_Shared_Passive of program unit name entity
19787 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19788 Cunit_Node
: Node_Id
;
19789 Cunit_Ent
: Entity_Id
;
19792 Check_Ada_83_Warning
;
19793 Check_Valid_Library_Unit_Pragma
;
19795 if Nkind
(N
) = N_Null_Statement
then
19799 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19800 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19802 -- A pragma that applies to a Ghost entity becomes Ghost for the
19803 -- purposes of legality checks and removal of ignored Ghost code.
19805 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
19807 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19808 N_Generic_Package_Declaration
)
19811 ("pragma% can only apply to a package declaration");
19814 Set_Is_Shared_Passive
(Cunit_Ent
);
19815 end Shared_Passive
;
19817 -----------------------
19818 -- Short_Descriptors --
19819 -----------------------
19821 -- pragma Short_Descriptors;
19823 -- Recognize and validate, but otherwise ignore
19825 when Pragma_Short_Descriptors
=>
19827 Check_Arg_Count
(0);
19828 Check_Valid_Configuration_Pragma
;
19830 ------------------------------
19831 -- Simple_Storage_Pool_Type --
19832 ------------------------------
19834 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19836 when Pragma_Simple_Storage_Pool_Type
=>
19837 Simple_Storage_Pool_Type
: declare
19843 Check_Arg_Count
(1);
19844 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19846 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19847 Find_Type
(Type_Id
);
19848 Typ
:= Entity
(Type_Id
);
19850 if Typ
= Any_Type
then
19854 -- A pragma that applies to a Ghost entity becomes Ghost for the
19855 -- purposes of legality checks and removal of ignored Ghost code.
19857 Mark_Pragma_As_Ghost
(N
, Typ
);
19859 -- We require the pragma to apply to a type declared in a package
19860 -- declaration, but not (immediately) within a package body.
19862 if Ekind
(Current_Scope
) /= E_Package
19863 or else In_Package_Body
(Current_Scope
)
19866 ("pragma% can only apply to type declared immediately "
19867 & "within a package declaration");
19870 -- A simple storage pool type must be an immutably limited record
19871 -- or private type. If the pragma is given for a private type,
19872 -- the full type is similarly restricted (which is checked later
19873 -- in Freeze_Entity).
19875 if Is_Record_Type
(Typ
)
19876 and then not Is_Limited_View
(Typ
)
19879 ("pragma% can only apply to explicitly limited record type");
19881 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19883 ("pragma% can only apply to a private type that is limited");
19885 elsif not Is_Record_Type
(Typ
)
19886 and then not Is_Private_Type
(Typ
)
19889 ("pragma% can only apply to limited record or private type");
19892 Record_Rep_Item
(Typ
, N
);
19893 end Simple_Storage_Pool_Type
;
19895 ----------------------
19896 -- Source_File_Name --
19897 ----------------------
19899 -- There are five forms for this pragma:
19901 -- pragma Source_File_Name (
19902 -- [UNIT_NAME =>] unit_NAME,
19903 -- BODY_FILE_NAME => STRING_LITERAL
19904 -- [, [INDEX =>] INTEGER_LITERAL]);
19906 -- pragma Source_File_Name (
19907 -- [UNIT_NAME =>] unit_NAME,
19908 -- SPEC_FILE_NAME => STRING_LITERAL
19909 -- [, [INDEX =>] INTEGER_LITERAL]);
19911 -- pragma Source_File_Name (
19912 -- BODY_FILE_NAME => STRING_LITERAL
19913 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19914 -- [, CASING => CASING_SPEC]);
19916 -- pragma Source_File_Name (
19917 -- SPEC_FILE_NAME => STRING_LITERAL
19918 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19919 -- [, CASING => CASING_SPEC]);
19921 -- pragma Source_File_Name (
19922 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19923 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19924 -- [, CASING => CASING_SPEC]);
19926 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19928 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19929 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19930 -- only be used when no project file is used, while SFNP can only be
19931 -- used when a project file is used.
19933 -- No processing here. Processing was completed during parsing, since
19934 -- we need to have file names set as early as possible. Units are
19935 -- loaded well before semantic processing starts.
19937 -- The only processing we defer to this point is the check for
19938 -- correct placement.
19940 when Pragma_Source_File_Name
=>
19942 Check_Valid_Configuration_Pragma
;
19944 ------------------------------
19945 -- Source_File_Name_Project --
19946 ------------------------------
19948 -- See Source_File_Name for syntax
19950 -- No processing here. Processing was completed during parsing, since
19951 -- we need to have file names set as early as possible. Units are
19952 -- loaded well before semantic processing starts.
19954 -- The only processing we defer to this point is the check for
19955 -- correct placement.
19957 when Pragma_Source_File_Name_Project
=>
19959 Check_Valid_Configuration_Pragma
;
19961 -- Check that a pragma Source_File_Name_Project is used only in a
19962 -- configuration pragmas file.
19964 -- Pragmas Source_File_Name_Project should only be generated by
19965 -- the Project Manager in configuration pragmas files.
19967 -- This is really an ugly test. It seems to depend on some
19968 -- accidental and undocumented property. At the very least it
19969 -- needs to be documented, but it would be better to have a
19970 -- clean way of testing if we are in a configuration file???
19972 if Present
(Parent
(N
)) then
19974 ("pragma% can only appear in a configuration pragmas file");
19977 ----------------------
19978 -- Source_Reference --
19979 ----------------------
19981 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19983 -- Nothing to do, all processing completed in Par.Prag, since we need
19984 -- the information for possible parser messages that are output.
19986 when Pragma_Source_Reference
=>
19993 -- pragma SPARK_Mode [(On | Off)];
19995 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19996 Mode_Id
: SPARK_Mode_Type
;
19998 procedure Check_Pragma_Conformance
19999 (Context_Pragma
: Node_Id
;
20000 Entity
: Entity_Id
;
20001 Entity_Pragma
: Node_Id
);
20002 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20003 -- conformance of pragma N depending the following scenarios:
20005 -- If pragma Context_Pragma is not Empty, verify that pragma N is
20006 -- compatible with the pragma Context_Pragma that was inherited
20007 -- from the context:
20008 -- * If the mode of Context_Pragma is ON, then the new mode can
20010 -- * If the mode of Context_Pragma is OFF, then the only allowed
20011 -- new mode is also OFF. Emit error if this is not the case.
20013 -- If Entity is not Empty, verify that pragma N is compatible with
20014 -- pragma Entity_Pragma that belongs to Entity.
20015 -- * If Entity_Pragma is Empty, always issue an error as this
20016 -- corresponds to the case where a previous section of Entity
20017 -- has no SPARK_Mode set.
20018 -- * If the mode of Entity_Pragma is ON, then the new mode can
20020 -- * If the mode of Entity_Pragma is OFF, then the only allowed
20021 -- new mode is also OFF. Emit error if this is not the case.
20023 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
20024 -- Subsidiary to routines Process_xxx. Verify that the related
20025 -- entity E subject to pragma SPARK_Mode is library-level.
20027 procedure Process_Body
(Decl
: Node_Id
);
20028 -- Verify the legality of pragma SPARK_Mode when it appears as the
20029 -- top of the body declarations of entry, package, protected unit,
20030 -- subprogram or task unit body denoted by Decl.
20032 procedure Process_Overloadable
(Decl
: Node_Id
);
20033 -- Verify the legality of pragma SPARK_Mode when it applies to an
20034 -- entry or [generic] subprogram declaration denoted by Decl.
20036 procedure Process_Private_Part
(Decl
: Node_Id
);
20037 -- Verify the legality of pragma SPARK_Mode when it appears at the
20038 -- top of the private declarations of a package spec, protected or
20039 -- task unit declaration denoted by Decl.
20041 procedure Process_Statement_Part
(Decl
: Node_Id
);
20042 -- Verify the legality of pragma SPARK_Mode when it appears at the
20043 -- top of the statement sequence of a package body denoted by node
20046 procedure Process_Visible_Part
(Decl
: Node_Id
);
20047 -- Verify the legality of pragma SPARK_Mode when it appears at the
20048 -- top of the visible declarations of a package spec, protected or
20049 -- task unit declaration denoted by Decl. The routine is also used
20050 -- on protected or task units declared without a definition.
20052 procedure Set_SPARK_Context
;
20053 -- Subsidiary to routines Process_xxx. Set the global variables
20054 -- which represent the mode of the context from pragma N. Ensure
20055 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
20057 ------------------------------
20058 -- Check_Pragma_Conformance --
20059 ------------------------------
20061 procedure Check_Pragma_Conformance
20062 (Context_Pragma
: Node_Id
;
20063 Entity
: Entity_Id
;
20064 Entity_Pragma
: Node_Id
)
20066 Err_Id
: Entity_Id
;
20070 -- The current pragma may appear without an argument. If this
20071 -- is the case, associate all error messages with the pragma
20074 if Present
(Arg1
) then
20080 -- The mode of the current pragma is compared against that of
20081 -- an enclosing context.
20083 if Present
(Context_Pragma
) then
20084 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
20086 -- Issue an error if the new mode is less restrictive than
20087 -- that of the context.
20089 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
20090 and then Get_SPARK_Mode_From_Pragma
(N
) = On
20093 ("cannot change SPARK_Mode from Off to On", Err_N
);
20094 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
20095 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
20100 -- The mode of the current pragma is compared against that of
20101 -- an initial package, protected type, subprogram or task type
20104 if Present
(Entity
) then
20106 -- A simple protected or task type is transformed into an
20107 -- anonymous type whose name cannot be used to issue error
20108 -- messages. Recover the original entity of the type.
20110 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
20113 (Original_Node
(Unit_Declaration_Node
(Entity
)));
20118 -- Both the initial declaration and the completion carry
20119 -- SPARK_Mode pragmas.
20121 if Present
(Entity_Pragma
) then
20122 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
20124 -- Issue an error if the new mode is less restrictive
20125 -- than that of the initial declaration.
20127 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
20128 and then Get_SPARK_Mode_From_Pragma
(N
) = On
20130 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
20131 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
20133 ("\value Off was set for SPARK_Mode on&#",
20138 -- Otherwise the initial declaration lacks a SPARK_Mode
20139 -- pragma in which case the current pragma is illegal as
20140 -- it cannot "complete".
20143 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
20144 Error_Msg_Sloc
:= Sloc
(Err_Id
);
20146 ("\no value was set for SPARK_Mode on&#",
20151 end Check_Pragma_Conformance
;
20153 --------------------------------
20154 -- Check_Library_Level_Entity --
20155 --------------------------------
20157 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
20158 procedure Add_Entity_To_Name_Buffer
;
20159 -- Add the E_Kind of entity E to the name buffer
20161 -------------------------------
20162 -- Add_Entity_To_Name_Buffer --
20163 -------------------------------
20165 procedure Add_Entity_To_Name_Buffer
is
20167 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
20168 Add_Str_To_Name_Buffer
("entry");
20170 elsif Ekind_In
(E
, E_Generic_Package
,
20174 Add_Str_To_Name_Buffer
("package");
20176 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
20177 Add_Str_To_Name_Buffer
("protected type");
20179 elsif Ekind_In
(E
, E_Function
,
20180 E_Generic_Function
,
20181 E_Generic_Procedure
,
20185 Add_Str_To_Name_Buffer
("subprogram");
20188 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
20189 Add_Str_To_Name_Buffer
("task type");
20191 end Add_Entity_To_Name_Buffer
;
20195 Msg_1
: constant String := "incorrect placement of pragma%";
20198 -- Start of processing for Check_Library_Level_Entity
20201 if not Is_Library_Level_Entity
(E
) then
20202 Error_Msg_Name_1
:= Pname
;
20203 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
20206 Add_Str_To_Name_Buffer
("\& is not a library-level ");
20207 Add_Entity_To_Name_Buffer
;
20209 Msg_2
:= Name_Find
;
20210 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
20214 end Check_Library_Level_Entity
;
20220 procedure Process_Body
(Decl
: Node_Id
) is
20221 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20222 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
20225 -- Ignore pragma when applied to the special body created for
20226 -- inlining, recognized by its internal name _Parent.
20228 if Chars
(Body_Id
) = Name_uParent
then
20232 Check_Library_Level_Entity
(Body_Id
);
20234 -- For entry bodies, verify the legality against:
20235 -- * The mode of the context
20236 -- * The mode of the spec (if any)
20238 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
20240 -- A stand alone subprogram body
20242 if Body_Id
= Spec_Id
then
20243 Check_Pragma_Conformance
20244 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20246 Entity_Pragma
=> Empty
);
20248 -- An entry or subprogram body that completes a previous
20252 Check_Pragma_Conformance
20253 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20255 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
20259 Set_SPARK_Pragma
(Body_Id
, N
);
20260 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
20262 -- For package bodies, verify the legality against:
20263 -- * The mode of the context
20264 -- * The mode of the private part
20266 -- This case is separated from protected and task bodies
20267 -- because the statement part of the package body inherits
20268 -- the mode of the body declarations.
20270 elsif Nkind
(Decl
) = N_Package_Body
then
20271 Check_Pragma_Conformance
20272 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20274 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
20277 Set_SPARK_Pragma
(Body_Id
, N
);
20278 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
20279 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
20280 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
20282 -- For protected and task bodies, verify the legality against:
20283 -- * The mode of the context
20284 -- * The mode of the private part
20288 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
20290 Check_Pragma_Conformance
20291 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20293 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
20296 Set_SPARK_Pragma
(Body_Id
, N
);
20297 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
20301 --------------------------
20302 -- Process_Overloadable --
20303 --------------------------
20305 procedure Process_Overloadable
(Decl
: Node_Id
) is
20306 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20307 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
20310 Check_Library_Level_Entity
(Spec_Id
);
20312 -- Verify the legality against:
20313 -- * The mode of the context
20315 Check_Pragma_Conformance
20316 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
20318 Entity_Pragma
=> Empty
);
20320 Set_SPARK_Pragma
(Spec_Id
, N
);
20321 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
20323 -- When the pragma applies to the anonymous object created for
20324 -- a single task type, decorate the type as well. This scenario
20325 -- arises when the single task type lacks a task definition,
20326 -- therefore there is no issue with respect to a potential
20327 -- pragma SPARK_Mode in the private part.
20329 -- task type Anon_Task_Typ;
20330 -- Obj : Anon_Task_Typ;
20331 -- pragma SPARK_Mode ...;
20333 if Is_Single_Concurrent_Object
(Spec_Id
)
20334 and then Ekind
(Spec_Typ
) = E_Task_Type
20336 Set_SPARK_Pragma
(Spec_Typ
, N
);
20337 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
20338 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
20339 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
20341 end Process_Overloadable
;
20343 --------------------------
20344 -- Process_Private_Part --
20345 --------------------------
20347 procedure Process_Private_Part
(Decl
: Node_Id
) is
20348 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20351 Check_Library_Level_Entity
(Spec_Id
);
20353 -- Verify the legality against:
20354 -- * The mode of the visible declarations
20356 Check_Pragma_Conformance
20357 (Context_Pragma
=> Empty
,
20359 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
20362 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
20363 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
20364 end Process_Private_Part
;
20366 ----------------------------
20367 -- Process_Statement_Part --
20368 ----------------------------
20370 procedure Process_Statement_Part
(Decl
: Node_Id
) is
20371 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20374 Check_Library_Level_Entity
(Body_Id
);
20376 -- Verify the legality against:
20377 -- * The mode of the body declarations
20379 Check_Pragma_Conformance
20380 (Context_Pragma
=> Empty
,
20382 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
20385 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
20386 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
20387 end Process_Statement_Part
;
20389 --------------------------
20390 -- Process_Visible_Part --
20391 --------------------------
20393 procedure Process_Visible_Part
(Decl
: Node_Id
) is
20394 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20395 Obj_Id
: Entity_Id
;
20398 Check_Library_Level_Entity
(Spec_Id
);
20400 -- Verify the legality against:
20401 -- * The mode of the context
20403 Check_Pragma_Conformance
20404 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
20406 Entity_Pragma
=> Empty
);
20408 -- A task unit declared without a definition does not set the
20409 -- SPARK_Mode of the context because the task does not have any
20410 -- entries that could inherit the mode.
20412 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
20413 N_Task_Type_Declaration
)
20418 Set_SPARK_Pragma
(Spec_Id
, N
);
20419 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
20420 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
20421 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
20423 -- When the pragma applies to a single protected or task type,
20424 -- decorate the corresponding anonymous object as well.
20426 -- protected Anon_Prot_Typ is
20427 -- pragma SPARK_Mode ...;
20429 -- end Anon_Prot_Typ;
20431 -- Obj : Anon_Prot_Typ;
20433 if Is_Single_Concurrent_Type
(Spec_Id
) then
20434 Obj_Id
:= Anonymous_Object
(Spec_Id
);
20436 Set_SPARK_Pragma
(Obj_Id
, N
);
20437 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
20439 end Process_Visible_Part
;
20441 -----------------------
20442 -- Set_SPARK_Context --
20443 -----------------------
20445 procedure Set_SPARK_Context
is
20447 SPARK_Mode
:= Mode_Id
;
20448 SPARK_Mode_Pragma
:= N
;
20450 if SPARK_Mode
= On
then
20451 Dynamic_Elaboration_Checks
:= False;
20453 end Set_SPARK_Context
;
20461 -- Start of processing for Do_SPARK_Mode
20464 -- When a SPARK_Mode pragma appears inside an instantiation whose
20465 -- enclosing context has SPARK_Mode set to "off", the pragma has
20466 -- no semantic effect.
20468 if Ignore_Pragma_SPARK_Mode
then
20469 Rewrite
(N
, Make_Null_Statement
(Loc
));
20475 Check_No_Identifiers
;
20476 Check_At_Most_N_Arguments
(1);
20478 -- Check the legality of the mode (no argument = ON)
20480 if Arg_Count
= 1 then
20481 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20482 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
20487 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
20488 Context
:= Parent
(N
);
20490 -- The pragma appears in a configuration pragmas file
20492 if No
(Context
) then
20493 Check_Valid_Configuration_Pragma
;
20495 if Present
(SPARK_Mode_Pragma
) then
20496 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
20497 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
20503 -- The pragma acts as a configuration pragma in a compilation unit
20505 -- pragma SPARK_Mode ...;
20506 -- package Pack is ...;
20508 elsif Nkind
(Context
) = N_Compilation_Unit
20509 and then List_Containing
(N
) = Context_Items
(Context
)
20511 Check_Valid_Configuration_Pragma
;
20514 -- Otherwise the placement of the pragma within the tree dictates
20515 -- its associated construct. Inspect the declarative list where
20516 -- the pragma resides to find a potential construct.
20520 while Present
(Stmt
) loop
20522 -- Skip prior pragmas, but check for duplicates. Note that
20523 -- this also takes care of pragmas generated for aspects.
20525 if Nkind
(Stmt
) = N_Pragma
then
20526 if Pragma_Name
(Stmt
) = Pname
then
20527 Error_Msg_Name_1
:= Pname
;
20528 Error_Msg_Sloc
:= Sloc
(Stmt
);
20529 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
20533 -- The pragma applies to an expression function that has
20534 -- already been rewritten into a subprogram declaration.
20536 -- function Expr_Func return ... is (...);
20537 -- pragma SPARK_Mode ...;
20539 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
20540 and then Nkind
(Original_Node
(Stmt
)) =
20541 N_Expression_Function
20543 Process_Overloadable
(Stmt
);
20546 -- The pragma applies to the anonymous object created for a
20547 -- single concurrent type.
20549 -- protected type Anon_Prot_Typ ...;
20550 -- Obj : Anon_Prot_Typ;
20551 -- pragma SPARK_Mode ...;
20553 elsif Nkind
(Stmt
) = N_Object_Declaration
20554 and then Is_Single_Concurrent_Object
20555 (Defining_Entity
(Stmt
))
20557 Process_Overloadable
(Stmt
);
20560 -- Skip internally generated code
20562 elsif not Comes_From_Source
(Stmt
) then
20565 -- The pragma applies to an entry or [generic] subprogram
20569 -- pragma SPARK_Mode ...;
20572 -- procedure Proc ...;
20573 -- pragma SPARK_Mode ...;
20575 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
20576 N_Subprogram_Declaration
)
20577 or else (Nkind
(Stmt
) = N_Entry_Declaration
20578 and then Is_Protected_Type
20579 (Scope
(Defining_Entity
(Stmt
))))
20581 Process_Overloadable
(Stmt
);
20584 -- Otherwise the pragma does not apply to a legal construct
20585 -- or it does not appear at the top of a declarative or a
20586 -- statement list. Issue an error and stop the analysis.
20596 -- The pragma applies to a package or a subprogram that acts as
20597 -- a compilation unit.
20599 -- procedure Proc ...;
20600 -- pragma SPARK_Mode ...;
20602 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
20603 Context
:= Unit
(Parent
(Context
));
20606 -- The pragma appears at the top of entry, package, protected
20607 -- unit, subprogram or task unit body declarations.
20609 -- entry Ent when ... is
20610 -- pragma SPARK_Mode ...;
20612 -- package body Pack is
20613 -- pragma SPARK_Mode ...;
20615 -- procedure Proc ... is
20616 -- pragma SPARK_Mode;
20618 -- protected body Prot is
20619 -- pragma SPARK_Mode ...;
20621 if Nkind_In
(Context
, N_Entry_Body
,
20627 Process_Body
(Context
);
20629 -- The pragma appears at the top of the visible or private
20630 -- declaration of a package spec, protected or task unit.
20633 -- pragma SPARK_Mode ...;
20635 -- pragma SPARK_Mode ...;
20637 -- protected [type] Prot is
20638 -- pragma SPARK_Mode ...;
20640 -- pragma SPARK_Mode ...;
20642 elsif Nkind_In
(Context
, N_Package_Specification
,
20643 N_Protected_Definition
,
20646 if List_Containing
(N
) = Visible_Declarations
(Context
) then
20647 Process_Visible_Part
(Parent
(Context
));
20649 Process_Private_Part
(Parent
(Context
));
20652 -- The pragma appears at the top of package body statements
20654 -- package body Pack is
20656 -- pragma SPARK_Mode;
20658 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
20659 and then Nkind
(Parent
(Context
)) = N_Package_Body
20661 Process_Statement_Part
(Parent
(Context
));
20663 -- The pragma appeared as an aspect of a [generic] subprogram
20664 -- declaration that acts as a compilation unit.
20667 -- procedure Proc ...;
20668 -- pragma SPARK_Mode ...;
20670 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
20671 N_Subprogram_Declaration
)
20673 Process_Overloadable
(Context
);
20675 -- The pragma does not apply to a legal construct, issue error
20683 --------------------------------
20684 -- Static_Elaboration_Desired --
20685 --------------------------------
20687 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
20689 when Pragma_Static_Elaboration_Desired
=>
20691 Check_At_Most_N_Arguments
(1);
20693 if Is_Compilation_Unit
(Current_Scope
)
20694 and then Ekind
(Current_Scope
) = E_Package
20696 Set_Static_Elaboration_Desired
(Current_Scope
, True);
20698 Error_Pragma
("pragma% must apply to a library-level package");
20705 -- pragma Storage_Size (EXPRESSION);
20707 when Pragma_Storage_Size
=> Storage_Size
: declare
20708 P
: constant Node_Id
:= Parent
(N
);
20712 Check_No_Identifiers
;
20713 Check_Arg_Count
(1);
20715 -- The expression must be analyzed in the special manner described
20716 -- in "Handling of Default Expressions" in sem.ads.
20718 Arg
:= Get_Pragma_Arg
(Arg1
);
20719 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
20721 if not Is_OK_Static_Expression
(Arg
) then
20722 Check_Restriction
(Static_Storage_Size
, Arg
);
20725 if Nkind
(P
) /= N_Task_Definition
then
20730 if Has_Storage_Size_Pragma
(P
) then
20731 Error_Pragma
("duplicate pragma% not allowed");
20733 Set_Has_Storage_Size_Pragma
(P
, True);
20736 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
20744 -- pragma Storage_Unit (NUMERIC_LITERAL);
20746 -- Only permitted argument is System'Storage_Unit value
20748 when Pragma_Storage_Unit
=>
20749 Check_No_Identifiers
;
20750 Check_Arg_Count
(1);
20751 Check_Arg_Is_Integer_Literal
(Arg1
);
20753 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
20754 UI_From_Int
(Ttypes
.System_Storage_Unit
)
20756 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
20758 ("the only allowed argument for pragma% is ^", Arg1
);
20761 --------------------
20762 -- Stream_Convert --
20763 --------------------
20765 -- pragma Stream_Convert (
20766 -- [Entity =>] type_LOCAL_NAME,
20767 -- [Read =>] function_NAME,
20768 -- [Write =>] function NAME);
20770 when Pragma_Stream_Convert
=> Stream_Convert
: declare
20772 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
20773 -- Check that the given argument is the name of a local function
20774 -- of one argument that is not overloaded earlier in the current
20775 -- local scope. A check is also made that the argument is a
20776 -- function with one parameter.
20778 --------------------------------------
20779 -- Check_OK_Stream_Convert_Function --
20780 --------------------------------------
20782 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
20786 Check_Arg_Is_Local_Name
(Arg
);
20787 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
20789 if Has_Homonym
(Ent
) then
20791 ("argument for pragma% may not be overloaded", Arg
);
20794 if Ekind
(Ent
) /= E_Function
20795 or else No
(First_Formal
(Ent
))
20796 or else Present
(Next_Formal
(First_Formal
(Ent
)))
20799 ("argument for pragma% must be function of one argument",
20802 end Check_OK_Stream_Convert_Function
;
20804 -- Start of processing for Stream_Convert
20808 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
20809 Check_Arg_Count
(3);
20810 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20811 Check_Optional_Identifier
(Arg2
, Name_Read
);
20812 Check_Optional_Identifier
(Arg3
, Name_Write
);
20813 Check_Arg_Is_Local_Name
(Arg1
);
20814 Check_OK_Stream_Convert_Function
(Arg2
);
20815 Check_OK_Stream_Convert_Function
(Arg3
);
20818 Typ
: constant Entity_Id
:=
20819 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
20820 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
20821 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
20824 Check_First_Subtype
(Arg1
);
20826 -- Check for too early or too late. Note that we don't enforce
20827 -- the rule about primitive operations in this case, since, as
20828 -- is the case for explicit stream attributes themselves, these
20829 -- restrictions are not appropriate. Note that the chaining of
20830 -- the pragma by Rep_Item_Too_Late is actually the critical
20831 -- processing done for this pragma.
20833 if Rep_Item_Too_Early
(Typ
, N
)
20835 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
20840 -- Return if previous error
20842 if Etype
(Typ
) = Any_Type
20844 Etype
(Read
) = Any_Type
20846 Etype
(Write
) = Any_Type
20853 if Underlying_Type
(Etype
(Read
)) /= Typ
then
20855 ("incorrect return type for function&", Arg2
);
20858 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
20860 ("incorrect parameter type for function&", Arg3
);
20863 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
20864 Underlying_Type
(Etype
(Write
))
20867 ("result type of & does not match Read parameter type",
20871 end Stream_Convert
;
20877 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20879 -- This is processed by the parser since some of the style checks
20880 -- take place during source scanning and parsing. This means that
20881 -- we don't need to issue error messages here.
20883 when Pragma_Style_Checks
=> Style_Checks
: declare
20884 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20890 Check_No_Identifiers
;
20892 -- Two argument form
20894 if Arg_Count
= 2 then
20895 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20902 E_Id
:= Get_Pragma_Arg
(Arg2
);
20905 if not Is_Entity_Name
(E_Id
) then
20907 ("second argument of pragma% must be entity name",
20911 E
:= Entity
(E_Id
);
20913 if not Ignore_Style_Checks_Pragmas
then
20918 Set_Suppress_Style_Checks
20919 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
20920 exit when No
(Homonym
(E
));
20927 -- One argument form
20930 Check_Arg_Count
(1);
20932 if Nkind
(A
) = N_String_Literal
then
20936 Slen
: constant Natural := Natural (String_Length
(S
));
20937 Options
: String (1 .. Slen
);
20943 C
:= Get_String_Char
(S
, Int
(J
));
20944 exit when not In_Character_Range
(C
);
20945 Options
(J
) := Get_Character
(C
);
20947 -- If at end of string, set options. As per discussion
20948 -- above, no need to check for errors, since we issued
20949 -- them in the parser.
20952 if not Ignore_Style_Checks_Pragmas
then
20953 Set_Style_Check_Options
(Options
);
20963 elsif Nkind
(A
) = N_Identifier
then
20964 if Chars
(A
) = Name_All_Checks
then
20965 if not Ignore_Style_Checks_Pragmas
then
20967 Set_GNAT_Style_Check_Options
;
20969 Set_Default_Style_Check_Options
;
20973 elsif Chars
(A
) = Name_On
then
20974 if not Ignore_Style_Checks_Pragmas
then
20975 Style_Check
:= True;
20978 elsif Chars
(A
) = Name_Off
then
20979 if not Ignore_Style_Checks_Pragmas
then
20980 Style_Check
:= False;
20991 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20993 when Pragma_Subtitle
=>
20995 Check_Arg_Count
(1);
20996 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
20997 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
21004 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21006 when Pragma_Suppress
=>
21007 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
21013 -- pragma Suppress_All;
21015 -- The only check made here is that the pragma has no arguments.
21016 -- There are no placement rules, and the processing required (setting
21017 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
21018 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
21019 -- then creates and inserts a pragma Suppress (All_Checks).
21021 when Pragma_Suppress_All
=>
21023 Check_Arg_Count
(0);
21025 -------------------------
21026 -- Suppress_Debug_Info --
21027 -------------------------
21029 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21031 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
21032 Nam_Id
: Entity_Id
;
21036 Check_Arg_Count
(1);
21037 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21038 Check_Arg_Is_Local_Name
(Arg1
);
21040 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
21042 -- A pragma that applies to a Ghost entity becomes Ghost for the
21043 -- purposes of legality checks and removal of ignored Ghost code.
21045 Mark_Pragma_As_Ghost
(N
, Nam_Id
);
21046 Set_Debug_Info_Off
(Nam_Id
);
21047 end Suppress_Debug_Info
;
21049 ----------------------------------
21050 -- Suppress_Exception_Locations --
21051 ----------------------------------
21053 -- pragma Suppress_Exception_Locations;
21055 when Pragma_Suppress_Exception_Locations
=>
21057 Check_Arg_Count
(0);
21058 Check_Valid_Configuration_Pragma
;
21059 Exception_Locations_Suppressed
:= True;
21061 -----------------------------
21062 -- Suppress_Initialization --
21063 -----------------------------
21065 -- pragma Suppress_Initialization ([Entity =>] type_Name);
21067 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
21073 Check_Arg_Count
(1);
21074 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21075 Check_Arg_Is_Local_Name
(Arg1
);
21077 E_Id
:= Get_Pragma_Arg
(Arg1
);
21079 if Etype
(E_Id
) = Any_Type
then
21083 E
:= Entity
(E_Id
);
21085 -- A pragma that applies to a Ghost entity becomes Ghost for the
21086 -- purposes of legality checks and removal of ignored Ghost code.
21088 Mark_Pragma_As_Ghost
(N
, E
);
21090 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
21092 ("pragma% requires variable, type or subtype", Arg1
);
21095 if Rep_Item_Too_Early
(E
, N
)
21097 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
21102 -- For incomplete/private type, set flag on full view
21104 if Is_Incomplete_Or_Private_Type
(E
) then
21105 if No
(Full_View
(Base_Type
(E
))) then
21107 ("argument of pragma% cannot be an incomplete type", Arg1
);
21109 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
21112 -- For first subtype, set flag on base type
21114 elsif Is_First_Subtype
(E
) then
21115 Set_Suppress_Initialization
(Base_Type
(E
));
21117 -- For other than first subtype, set flag on subtype or variable
21120 Set_Suppress_Initialization
(E
);
21128 -- pragma System_Name (DIRECT_NAME);
21130 -- Syntax check: one argument, which must be the identifier GNAT or
21131 -- the identifier GCC, no other identifiers are acceptable.
21133 when Pragma_System_Name
=>
21135 Check_No_Identifiers
;
21136 Check_Arg_Count
(1);
21137 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
21139 -----------------------------
21140 -- Task_Dispatching_Policy --
21141 -----------------------------
21143 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
21145 when Pragma_Task_Dispatching_Policy
=> declare
21149 Check_Ada_83_Warning
;
21150 Check_Arg_Count
(1);
21151 Check_No_Identifiers
;
21152 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
21153 Check_Valid_Configuration_Pragma
;
21154 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21155 DP
:= Fold_Upper
(Name_Buffer
(1));
21157 if Task_Dispatching_Policy
/= ' '
21158 and then Task_Dispatching_Policy
/= DP
21160 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21162 ("task dispatching policy incompatible with policy#");
21164 -- Set new policy, but always preserve System_Location since we
21165 -- like the error message with the run time name.
21168 Task_Dispatching_Policy
:= DP
;
21170 if Task_Dispatching_Policy_Sloc
/= System_Location
then
21171 Task_Dispatching_Policy_Sloc
:= Loc
;
21180 -- pragma Task_Info (EXPRESSION);
21182 when Pragma_Task_Info
=> Task_Info
: declare
21183 P
: constant Node_Id
:= Parent
(N
);
21189 if Warn_On_Obsolescent_Feature
then
21191 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
21192 & "instead?j?", N
);
21195 if Nkind
(P
) /= N_Task_Definition
then
21196 Error_Pragma
("pragma% must appear in task definition");
21199 Check_No_Identifiers
;
21200 Check_Arg_Count
(1);
21202 Analyze_And_Resolve
21203 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
21205 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
21209 Ent
:= Defining_Identifier
(Parent
(P
));
21211 -- Check duplicate pragma before we chain the pragma in the Rep
21212 -- Item chain of Ent.
21215 (Ent
, Name_Task_Info
, Check_Parents
=> False)
21217 Error_Pragma
("duplicate pragma% not allowed");
21220 Record_Rep_Item
(Ent
, N
);
21227 -- pragma Task_Name (string_EXPRESSION);
21229 when Pragma_Task_Name
=> Task_Name
: declare
21230 P
: constant Node_Id
:= Parent
(N
);
21235 Check_No_Identifiers
;
21236 Check_Arg_Count
(1);
21238 Arg
:= Get_Pragma_Arg
(Arg1
);
21240 -- The expression is used in the call to Create_Task, and must be
21241 -- expanded there, not in the context of the current spec. It must
21242 -- however be analyzed to capture global references, in case it
21243 -- appears in a generic context.
21245 Preanalyze_And_Resolve
(Arg
, Standard_String
);
21247 if Nkind
(P
) /= N_Task_Definition
then
21251 Ent
:= Defining_Identifier
(Parent
(P
));
21253 -- Check duplicate pragma before we chain the pragma in the Rep
21254 -- Item chain of Ent.
21257 (Ent
, Name_Task_Name
, Check_Parents
=> False)
21259 Error_Pragma
("duplicate pragma% not allowed");
21262 Record_Rep_Item
(Ent
, N
);
21269 -- pragma Task_Storage (
21270 -- [Task_Type =>] LOCAL_NAME,
21271 -- [Top_Guard =>] static_integer_EXPRESSION);
21273 when Pragma_Task_Storage
=> Task_Storage
: declare
21274 Args
: Args_List
(1 .. 2);
21275 Names
: constant Name_List
(1 .. 2) := (
21279 Task_Type
: Node_Id
renames Args
(1);
21280 Top_Guard
: Node_Id
renames Args
(2);
21286 Gather_Associations
(Names
, Args
);
21288 if No
(Task_Type
) then
21290 ("missing task_type argument for pragma%");
21293 Check_Arg_Is_Local_Name
(Task_Type
);
21295 Ent
:= Entity
(Task_Type
);
21297 if not Is_Task_Type
(Ent
) then
21299 ("argument for pragma% must be task type", Task_Type
);
21302 if No
(Top_Guard
) then
21304 ("pragma% takes two arguments", Task_Type
);
21306 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
21309 Check_First_Subtype
(Task_Type
);
21311 if Rep_Item_Too_Late
(Ent
, N
) then
21320 -- pragma Test_Case
21321 -- ([Name =>] Static_String_EXPRESSION
21322 -- ,[Mode =>] MODE_TYPE
21323 -- [, Requires => Boolean_EXPRESSION]
21324 -- [, Ensures => Boolean_EXPRESSION]);
21326 -- MODE_TYPE ::= Nominal | Robustness
21328 -- Characteristics:
21330 -- * Analysis - The annotation undergoes initial checks to verify
21331 -- the legal placement and context. Secondary checks preanalyze the
21334 -- Analyze_Test_Case_In_Decl_Part
21336 -- * Expansion - None.
21338 -- * Template - The annotation utilizes the generic template of the
21339 -- related subprogram when it is:
21341 -- aspect on subprogram declaration
21343 -- The annotation must prepare its own template when it is:
21345 -- pragma on subprogram declaration
21347 -- * Globals - Capture of global references must occur after full
21350 -- * Instance - The annotation is instantiated automatically when
21351 -- the related generic subprogram is instantiated except for the
21352 -- "pragma on subprogram declaration" case. In that scenario the
21353 -- annotation must instantiate itself.
21355 when Pragma_Test_Case
=> Test_Case
: declare
21356 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
21357 -- Ensure that the contract of subprogram Subp_Id does not contain
21358 -- another Test_Case pragma with the same Name as the current one.
21360 -------------------------
21361 -- Check_Distinct_Name --
21362 -------------------------
21364 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
21365 Items
: constant Node_Id
:= Contract
(Subp_Id
);
21366 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
21370 -- Inspect all Test_Case pragma of the related subprogram
21371 -- looking for one with a duplicate "Name" argument.
21373 if Present
(Items
) then
21374 Prag
:= Contract_Test_Cases
(Items
);
21375 while Present
(Prag
) loop
21376 if Pragma_Name
(Prag
) = Name_Test_Case
21378 and then String_Equal
21379 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
21381 Error_Msg_Sloc
:= Sloc
(Prag
);
21382 Error_Pragma
("name for pragma % is already used #");
21385 Prag
:= Next_Pragma
(Prag
);
21388 end Check_Distinct_Name
;
21392 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
21395 Subp_Decl
: Node_Id
;
21396 Subp_Id
: Entity_Id
;
21398 -- Start of processing for Test_Case
21402 Check_At_Least_N_Arguments
(2);
21403 Check_At_Most_N_Arguments
(4);
21405 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
21409 Check_Optional_Identifier
(Arg1
, Name_Name
);
21410 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
21414 Check_Optional_Identifier
(Arg2
, Name_Mode
);
21415 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
21417 -- Arguments "Requires" and "Ensures"
21419 if Present
(Arg3
) then
21420 if Present
(Arg4
) then
21421 Check_Identifier
(Arg3
, Name_Requires
);
21422 Check_Identifier
(Arg4
, Name_Ensures
);
21424 Check_Identifier_Is_One_Of
21425 (Arg3
, Name_Requires
, Name_Ensures
);
21429 -- Pragma Test_Case must be associated with a subprogram declared
21430 -- in a library-level package. First determine whether the current
21431 -- compilation unit is a legal context.
21433 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
21434 N_Generic_Package_Declaration
)
21438 -- Otherwise the placement is illegal
21445 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
21447 -- Find the enclosing context
21449 Context
:= Parent
(Subp_Decl
);
21451 if Present
(Context
) then
21452 Context
:= Parent
(Context
);
21455 -- Verify the placement of the pragma
21457 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
21459 ("pragma % cannot be applied to abstract subprogram");
21462 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
21463 Error_Pragma
("pragma % cannot be applied to entry");
21466 -- The context is a [generic] subprogram declared at the top level
21467 -- of the [generic] package unit.
21469 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
21470 N_Subprogram_Declaration
)
21471 and then Present
(Context
)
21472 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
21473 N_Package_Declaration
)
21477 -- Otherwise the placement is illegal
21484 Subp_Id
:= Defining_Entity
(Subp_Decl
);
21486 -- Chain the pragma on the contract for further processing by
21487 -- Analyze_Test_Case_In_Decl_Part.
21489 Add_Contract_Item
(N
, Subp_Id
);
21491 -- A pragma that applies to a Ghost entity becomes Ghost for the
21492 -- purposes of legality checks and removal of ignored Ghost code.
21494 Mark_Pragma_As_Ghost
(N
, Subp_Id
);
21496 -- Preanalyze the original aspect argument "Name" for ASIS or for
21497 -- a generic subprogram to properly capture global references.
21499 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
21500 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
21502 if Present
(Asp_Arg
) then
21504 -- The argument appears with an identifier in association
21507 if Nkind
(Asp_Arg
) = N_Component_Association
then
21508 Asp_Arg
:= Expression
(Asp_Arg
);
21511 Check_Expr_Is_OK_Static_Expression
21512 (Asp_Arg
, Standard_String
);
21516 -- Ensure that the all Test_Case pragmas of the related subprogram
21517 -- have distinct names.
21519 Check_Distinct_Name
(Subp_Id
);
21521 -- Fully analyze the pragma when it appears inside an entry
21522 -- or subprogram body because it cannot benefit from forward
21525 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
21527 N_Subprogram_Body_Stub
)
21529 -- The legality checks of pragma Test_Case are affected by the
21530 -- SPARK mode in effect and the volatility of the context.
21531 -- Analyze all pragmas in a specific order.
21533 Analyze_If_Present
(Pragma_SPARK_Mode
);
21534 Analyze_If_Present
(Pragma_Volatile_Function
);
21535 Analyze_Test_Case_In_Decl_Part
(N
);
21539 --------------------------
21540 -- Thread_Local_Storage --
21541 --------------------------
21543 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
21545 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
21551 Check_Arg_Count
(1);
21552 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21553 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21555 Id
:= Get_Pragma_Arg
(Arg1
);
21558 if not Is_Entity_Name
(Id
)
21559 or else Ekind
(Entity
(Id
)) /= E_Variable
21561 Error_Pragma_Arg
("local variable name required", Arg1
);
21566 -- A pragma that applies to a Ghost entity becomes Ghost for the
21567 -- purposes of legality checks and removal of ignored Ghost code.
21569 Mark_Pragma_As_Ghost
(N
, E
);
21571 if Rep_Item_Too_Early
(E
, N
)
21573 Rep_Item_Too_Late
(E
, N
)
21578 Set_Has_Pragma_Thread_Local_Storage
(E
);
21579 Set_Has_Gigi_Rep_Item
(E
);
21580 end Thread_Local_Storage
;
21586 -- pragma Time_Slice (static_duration_EXPRESSION);
21588 when Pragma_Time_Slice
=> Time_Slice
: declare
21594 Check_Arg_Count
(1);
21595 Check_No_Identifiers
;
21596 Check_In_Main_Program
;
21597 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
21599 if not Error_Posted
(Arg1
) then
21601 while Present
(Nod
) loop
21602 if Nkind
(Nod
) = N_Pragma
21603 and then Pragma_Name
(Nod
) = Name_Time_Slice
21605 Error_Msg_Name_1
:= Pname
;
21606 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
21613 -- Process only if in main unit
21615 if Get_Source_Unit
(Loc
) = Main_Unit
then
21616 Opt
.Time_Slice_Set
:= True;
21617 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
21619 if Val
<= Ureal_0
then
21620 Opt
.Time_Slice_Value
:= 0;
21622 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
21623 Opt
.Time_Slice_Value
:= 1_000_000_000
;
21626 Opt
.Time_Slice_Value
:=
21627 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
21636 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
21638 -- TITLING_OPTION ::=
21639 -- [Title =>] STRING_LITERAL
21640 -- | [Subtitle =>] STRING_LITERAL
21642 when Pragma_Title
=> Title
: declare
21643 Args
: Args_List
(1 .. 2);
21644 Names
: constant Name_List
(1 .. 2) := (
21650 Gather_Associations
(Names
, Args
);
21653 for J
in 1 .. 2 loop
21654 if Present
(Args
(J
)) then
21655 Check_Arg_Is_OK_Static_Expression
21656 (Args
(J
), Standard_String
);
21661 ----------------------------
21662 -- Type_Invariant[_Class] --
21663 ----------------------------
21665 -- pragma Type_Invariant[_Class]
21666 -- ([Entity =>] type_LOCAL_NAME,
21667 -- [Check =>] EXPRESSION);
21669 when Pragma_Type_Invariant |
21670 Pragma_Type_Invariant_Class
=>
21671 Type_Invariant
: declare
21672 I_Pragma
: Node_Id
;
21675 Check_Arg_Count
(2);
21677 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
21678 -- setting Class_Present for the Type_Invariant_Class case.
21680 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
21681 I_Pragma
:= New_Copy
(N
);
21682 Set_Pragma_Identifier
21683 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
21684 Rewrite
(N
, I_Pragma
);
21685 Set_Analyzed
(N
, False);
21687 end Type_Invariant
;
21689 ---------------------
21690 -- Unchecked_Union --
21691 ---------------------
21693 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
21695 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
21696 Assoc
: constant Node_Id
:= Arg1
;
21697 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
21707 Check_No_Identifiers
;
21708 Check_Arg_Count
(1);
21709 Check_Arg_Is_Local_Name
(Arg1
);
21711 Find_Type
(Type_Id
);
21713 Typ
:= Entity
(Type_Id
);
21715 -- A pragma that applies to a Ghost entity becomes Ghost for the
21716 -- purposes of legality checks and removal of ignored Ghost code.
21718 Mark_Pragma_As_Ghost
(N
, Typ
);
21721 or else Rep_Item_Too_Early
(Typ
, N
)
21725 Typ
:= Underlying_Type
(Typ
);
21728 if Rep_Item_Too_Late
(Typ
, N
) then
21732 Check_First_Subtype
(Arg1
);
21734 -- Note remaining cases are references to a type in the current
21735 -- declarative part. If we find an error, we post the error on
21736 -- the relevant type declaration at an appropriate point.
21738 if not Is_Record_Type
(Typ
) then
21739 Error_Msg_N
("unchecked union must be record type", Typ
);
21742 elsif Is_Tagged_Type
(Typ
) then
21743 Error_Msg_N
("unchecked union must not be tagged", Typ
);
21746 elsif not Has_Discriminants
(Typ
) then
21748 ("unchecked union must have one discriminant", Typ
);
21751 -- Note: in previous versions of GNAT we used to check for limited
21752 -- types and give an error, but in fact the standard does allow
21753 -- Unchecked_Union on limited types, so this check was removed.
21755 -- Similarly, GNAT used to require that all discriminants have
21756 -- default values, but this is not mandated by the RM.
21758 -- Proceed with basic error checks completed
21761 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
21762 Clist
:= Component_List
(Tdef
);
21764 -- Check presence of component list and variant part
21766 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
21768 ("unchecked union must have variant part", Tdef
);
21772 -- Check components
21774 Comp
:= First
(Component_Items
(Clist
));
21775 while Present
(Comp
) loop
21776 Check_Component
(Comp
, Typ
);
21780 -- Check variant part
21782 Vpart
:= Variant_Part
(Clist
);
21784 Variant
:= First
(Variants
(Vpart
));
21785 while Present
(Variant
) loop
21786 Check_Variant
(Variant
, Typ
);
21791 Set_Is_Unchecked_Union
(Typ
);
21792 Set_Convention
(Typ
, Convention_C
);
21793 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
21794 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
21795 end Unchecked_Union
;
21797 ------------------------
21798 -- Unimplemented_Unit --
21799 ------------------------
21801 -- pragma Unimplemented_Unit;
21803 -- Note: this only gives an error if we are generating code, or if
21804 -- we are in a generic library unit (where the pragma appears in the
21805 -- body, not in the spec).
21807 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
21808 Cunitent
: constant Entity_Id
:=
21809 Cunit_Entity
(Get_Source_Unit
(Loc
));
21810 Ent_Kind
: constant Entity_Kind
:=
21815 Check_Arg_Count
(0);
21817 if Operating_Mode
= Generate_Code
21818 or else Ent_Kind
= E_Generic_Function
21819 or else Ent_Kind
= E_Generic_Procedure
21820 or else Ent_Kind
= E_Generic_Package
21822 Get_Name_String
(Chars
(Cunitent
));
21823 Set_Casing
(Mixed_Case
);
21824 Write_Str
(Name_Buffer
(1 .. Name_Len
));
21825 Write_Str
(" is not supported in this configuration");
21827 raise Unrecoverable_Error
;
21829 end Unimplemented_Unit
;
21831 ------------------------
21832 -- Universal_Aliasing --
21833 ------------------------
21835 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
21837 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
21842 Check_Arg_Count
(1);
21843 Check_Optional_Identifier
(Arg2
, Name_Entity
);
21844 Check_Arg_Is_Local_Name
(Arg1
);
21845 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
21847 if E_Id
= Any_Type
then
21849 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
21850 Error_Pragma_Arg
("pragma% requires type", Arg1
);
21853 -- A pragma that applies to a Ghost entity becomes Ghost for the
21854 -- purposes of legality checks and removal of ignored Ghost code.
21856 Mark_Pragma_As_Ghost
(N
, E_Id
);
21857 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
21858 Record_Rep_Item
(E_Id
, N
);
21859 end Universal_Alias
;
21861 --------------------
21862 -- Universal_Data --
21863 --------------------
21865 -- pragma Universal_Data [(library_unit_NAME)];
21867 when Pragma_Universal_Data
=>
21870 -- If this is a configuration pragma, then set the universal
21871 -- addressing option, otherwise confirm that the pragma satisfies
21872 -- the requirements of library unit pragma placement and leave it
21873 -- to the GNAAMP back end to detect the pragma (avoids transitive
21874 -- setting of the option due to withed units).
21876 if Is_Configuration_Pragma
then
21877 Universal_Addressing_On_AAMP
:= True;
21879 Check_Valid_Library_Unit_Pragma
;
21882 if not AAMP_On_Target
then
21883 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
21890 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
21892 when Pragma_Unmodified
=> Unmodified
: declare
21894 Arg_Expr
: Node_Id
;
21895 Arg_Id
: Entity_Id
;
21897 Ghost_Error_Posted
: Boolean := False;
21898 -- Flag set when an error concerning the illegal mix of Ghost and
21899 -- non-Ghost variables is emitted.
21901 Ghost_Id
: Entity_Id
:= Empty
;
21902 -- The entity of the first Ghost variable encountered while
21903 -- processing the arguments of the pragma.
21907 Check_At_Least_N_Arguments
(1);
21909 -- Loop through arguments
21912 while Present
(Arg
) loop
21913 Check_No_Identifier
(Arg
);
21915 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
21916 -- in fact generate reference, so that the entity will have a
21917 -- reference, which will inhibit any warnings about it not
21918 -- being referenced, and also properly show up in the ali file
21919 -- as a reference. But this reference is recorded before the
21920 -- Has_Pragma_Unreferenced flag is set, so that no warning is
21921 -- generated for this reference.
21923 Check_Arg_Is_Local_Name
(Arg
);
21924 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
21926 if Is_Entity_Name
(Arg_Expr
) then
21927 Arg_Id
:= Entity
(Arg_Expr
);
21929 if Is_Assignable
(Arg_Id
) then
21930 Set_Has_Pragma_Unmodified
(Arg_Id
);
21932 -- A pragma that applies to a Ghost entity becomes Ghost
21933 -- for the purposes of legality checks and removal of
21934 -- ignored Ghost code.
21936 Mark_Pragma_As_Ghost
(N
, Arg_Id
);
21938 -- Capture the entity of the first Ghost variable being
21939 -- processed for error detection purposes.
21941 if Is_Ghost_Entity
(Arg_Id
) then
21942 if No
(Ghost_Id
) then
21943 Ghost_Id
:= Arg_Id
;
21946 -- Otherwise the variable is non-Ghost. It is illegal
21947 -- to mix references to Ghost and non-Ghost entities
21950 elsif Present
(Ghost_Id
)
21951 and then not Ghost_Error_Posted
21953 Ghost_Error_Posted
:= True;
21955 Error_Msg_Name_1
:= Pname
;
21957 ("pragma % cannot mention ghost and non-ghost "
21960 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
21961 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
21963 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
21964 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
21967 -- Otherwise the pragma referenced an illegal entity
21971 ("pragma% can only be applied to a variable", Arg_Expr
);
21983 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
21985 -- or when used in a context clause:
21987 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21989 when Pragma_Unreferenced
=> Unreferenced
: declare
21991 Arg_Expr
: Node_Id
;
21992 Arg_Id
: Entity_Id
;
21995 Ghost_Error_Posted
: Boolean := False;
21996 -- Flag set when an error concerning the illegal mix of Ghost and
21997 -- non-Ghost names is emitted.
21999 Ghost_Id
: Entity_Id
:= Empty
;
22000 -- The entity of the first Ghost name encountered while processing
22001 -- the arguments of the pragma.
22005 Check_At_Least_N_Arguments
(1);
22007 -- Check case of appearing within context clause
22009 if Is_In_Context_Clause
then
22011 -- The arguments must all be units mentioned in a with clause
22012 -- in the same context clause. Note we already checked (in
22013 -- Par.Prag) that the arguments are either identifiers or
22014 -- selected components.
22017 while Present
(Arg
) loop
22018 Citem
:= First
(List_Containing
(N
));
22019 while Citem
/= N
loop
22020 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22022 if Nkind
(Citem
) = N_With_Clause
22023 and then Same_Name
(Name
(Citem
), Arg_Expr
)
22025 Set_Has_Pragma_Unreferenced
22028 (Library_Unit
(Citem
))));
22029 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
22038 ("argument of pragma% is not withed unit", Arg
);
22044 -- Case of not in list of context items
22048 while Present
(Arg
) loop
22049 Check_No_Identifier
(Arg
);
22051 -- Note: the analyze call done by Check_Arg_Is_Local_Name
22052 -- will in fact generate reference, so that the entity will
22053 -- have a reference, which will inhibit any warnings about
22054 -- it not being referenced, and also properly show up in the
22055 -- ali file as a reference. But this reference is recorded
22056 -- before the Has_Pragma_Unreferenced flag is set, so that
22057 -- no warning is generated for this reference.
22059 Check_Arg_Is_Local_Name
(Arg
);
22060 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22062 if Is_Entity_Name
(Arg_Expr
) then
22063 Arg_Id
:= Entity
(Arg_Expr
);
22065 -- If the entity is overloaded, the pragma applies to the
22066 -- most recent overloading, as documented. In this case,
22067 -- name resolution does not generate a reference, so it
22068 -- must be done here explicitly.
22070 if Is_Overloaded
(Arg_Expr
) then
22071 Generate_Reference
(Arg_Id
, N
);
22074 Set_Has_Pragma_Unreferenced
(Arg_Id
);
22076 -- A pragma that applies to a Ghost entity becomes Ghost
22077 -- for the purposes of legality checks and removal of
22078 -- ignored Ghost code.
22080 Mark_Pragma_As_Ghost
(N
, Arg_Id
);
22082 -- Capture the entity of the first Ghost name being
22083 -- processed for error detection purposes.
22085 if Is_Ghost_Entity
(Arg_Id
) then
22086 if No
(Ghost_Id
) then
22087 Ghost_Id
:= Arg_Id
;
22090 -- Otherwise the name is non-Ghost. It is illegal to mix
22091 -- references to Ghost and non-Ghost entities
22094 elsif Present
(Ghost_Id
)
22095 and then not Ghost_Error_Posted
22097 Ghost_Error_Posted
:= True;
22099 Error_Msg_Name_1
:= Pname
;
22101 ("pragma % cannot mention ghost and non-ghost names",
22104 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
22105 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
22107 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
22108 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
22117 --------------------------
22118 -- Unreferenced_Objects --
22119 --------------------------
22121 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22123 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
22125 Arg_Expr
: Node_Id
;
22126 Arg_Id
: Entity_Id
;
22128 Ghost_Error_Posted
: Boolean := False;
22129 -- Flag set when an error concerning the illegal mix of Ghost and
22130 -- non-Ghost types is emitted.
22132 Ghost_Id
: Entity_Id
:= Empty
;
22133 -- The entity of the first Ghost type encountered while processing
22134 -- the arguments of the pragma.
22138 Check_At_Least_N_Arguments
(1);
22141 while Present
(Arg
) loop
22142 Check_No_Identifier
(Arg
);
22143 Check_Arg_Is_Local_Name
(Arg
);
22144 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22146 if Is_Entity_Name
(Arg_Expr
) then
22147 Arg_Id
:= Entity
(Arg_Expr
);
22149 if Is_Type
(Arg_Id
) then
22150 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
22152 -- A pragma that applies to a Ghost entity becomes Ghost
22153 -- for the purposes of legality checks and removal of
22154 -- ignored Ghost code.
22156 Mark_Pragma_As_Ghost
(N
, Arg_Id
);
22158 -- Capture the entity of the first Ghost type being
22159 -- processed for error detection purposes.
22161 if Is_Ghost_Entity
(Arg_Id
) then
22162 if No
(Ghost_Id
) then
22163 Ghost_Id
:= Arg_Id
;
22166 -- Otherwise the type is non-Ghost. It is illegal to mix
22167 -- references to Ghost and non-Ghost entities
22170 elsif Present
(Ghost_Id
)
22171 and then not Ghost_Error_Posted
22173 Ghost_Error_Posted
:= True;
22175 Error_Msg_Name_1
:= Pname
;
22177 ("pragma % cannot mention ghost and non-ghost types",
22180 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
22181 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
22183 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
22184 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
22188 ("argument for pragma% must be type or subtype", Arg
);
22192 ("argument for pragma% must be type or subtype", Arg
);
22197 end Unreferenced_Objects
;
22199 ------------------------------
22200 -- Unreserve_All_Interrupts --
22201 ------------------------------
22203 -- pragma Unreserve_All_Interrupts;
22205 when Pragma_Unreserve_All_Interrupts
=>
22207 Check_Arg_Count
(0);
22209 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
22210 Unreserve_All_Interrupts
:= True;
22217 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22219 when Pragma_Unsuppress
=>
22221 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
22223 ----------------------------
22224 -- Unevaluated_Use_Of_Old --
22225 ----------------------------
22227 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22229 when Pragma_Unevaluated_Use_Of_Old
=>
22231 Check_Arg_Count
(1);
22232 Check_No_Identifiers
;
22233 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
22235 -- Suppress/Unsuppress can appear as a configuration pragma, or in
22236 -- a declarative part or a package spec.
22238 if not Is_Configuration_Pragma
then
22239 Check_Is_In_Decl_Part_Or_Package_Spec
;
22242 -- Store proper setting of Uneval_Old
22244 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22245 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
22247 -------------------
22248 -- Use_VADS_Size --
22249 -------------------
22251 -- pragma Use_VADS_Size;
22253 when Pragma_Use_VADS_Size
=>
22255 Check_Arg_Count
(0);
22256 Check_Valid_Configuration_Pragma
;
22257 Use_VADS_Size
:= True;
22259 ---------------------
22260 -- Validity_Checks --
22261 ---------------------
22263 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22265 when Pragma_Validity_Checks
=> Validity_Checks
: declare
22266 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22272 Check_Arg_Count
(1);
22273 Check_No_Identifiers
;
22275 -- Pragma always active unless in CodePeer or GNATprove modes,
22276 -- which use a fixed configuration of validity checks.
22278 if not (CodePeer_Mode
or GNATprove_Mode
) then
22279 if Nkind
(A
) = N_String_Literal
then
22283 Slen
: constant Natural := Natural (String_Length
(S
));
22284 Options
: String (1 .. Slen
);
22288 -- Couldn't we use a for loop here over Options'Range???
22292 C
:= Get_String_Char
(S
, Int
(J
));
22294 -- This is a weird test, it skips setting validity
22295 -- checks entirely if any element of S is out of
22296 -- range of Character, what is that about ???
22298 exit when not In_Character_Range
(C
);
22299 Options
(J
) := Get_Character
(C
);
22302 Set_Validity_Check_Options
(Options
);
22310 elsif Nkind
(A
) = N_Identifier
then
22311 if Chars
(A
) = Name_All_Checks
then
22312 Set_Validity_Check_Options
("a");
22313 elsif Chars
(A
) = Name_On
then
22314 Validity_Checks_On
:= True;
22315 elsif Chars
(A
) = Name_Off
then
22316 Validity_Checks_On
:= False;
22320 end Validity_Checks
;
22326 -- pragma Volatile (LOCAL_NAME);
22328 when Pragma_Volatile
=>
22329 Process_Atomic_Independent_Shared_Volatile
;
22331 -------------------------
22332 -- Volatile_Components --
22333 -------------------------
22335 -- pragma Volatile_Components (array_LOCAL_NAME);
22337 -- Volatile is handled by the same circuit as Atomic_Components
22339 --------------------------
22340 -- Volatile_Full_Access --
22341 --------------------------
22343 -- pragma Volatile_Full_Access (LOCAL_NAME);
22345 when Pragma_Volatile_Full_Access
=>
22347 Process_Atomic_Independent_Shared_Volatile
;
22349 -----------------------
22350 -- Volatile_Function --
22351 -----------------------
22353 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
22355 when Pragma_Volatile_Function
=> Volatile_Function
: declare
22356 Over_Id
: Entity_Id
;
22357 Spec_Id
: Entity_Id
;
22358 Subp_Decl
: Node_Id
;
22362 Check_No_Identifiers
;
22363 Check_At_Most_N_Arguments
(1);
22366 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
22368 -- Generic subprogram
22370 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
22373 -- Body acts as spec
22375 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
22376 and then No
(Corresponding_Spec
(Subp_Decl
))
22380 -- Body stub acts as spec
22382 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
22383 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
22389 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
22397 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
22399 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
22404 -- Chain the pragma on the contract for completeness
22406 Add_Contract_Item
(N
, Spec_Id
);
22408 -- The legality checks of pragma Volatile_Function are affected by
22409 -- the SPARK mode in effect. Analyze all pragmas in a specific
22412 Analyze_If_Present
(Pragma_SPARK_Mode
);
22414 -- A pragma that applies to a Ghost entity becomes Ghost for the
22415 -- purposes of legality checks and removal of ignored Ghost code.
22417 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
22419 -- A volatile function cannot override a non-volatile function
22420 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
22421 -- in New_Overloaded_Entity, however at that point the pragma has
22422 -- not been processed yet.
22424 Over_Id
:= Overridden_Operation
(Spec_Id
);
22426 if Present
(Over_Id
)
22427 and then not Is_Volatile_Function
(Over_Id
)
22430 ("incompatible volatile function values in effect", Spec_Id
);
22432 Error_Msg_Sloc
:= Sloc
(Over_Id
);
22434 ("\& declared # with Volatile_Function value `False`",
22437 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
22439 ("\overridden # with Volatile_Function value `True`",
22443 -- Analyze the Boolean expression (if any)
22445 if Present
(Arg1
) then
22446 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
22448 end Volatile_Function
;
22450 ----------------------
22451 -- Warning_As_Error --
22452 ----------------------
22454 -- pragma Warning_As_Error (static_string_EXPRESSION);
22456 when Pragma_Warning_As_Error
=>
22458 Check_Arg_Count
(1);
22459 Check_No_Identifiers
;
22460 Check_Valid_Configuration_Pragma
;
22462 if not Is_Static_String_Expression
(Arg1
) then
22464 ("argument of pragma% must be static string expression",
22467 -- OK static string expression
22470 Acquire_Warning_Match_String
(Arg1
);
22471 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
22472 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
22473 new String'(Name_Buffer (1 .. Name_Len));
22480 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
22482 -- DETAILS ::= On | Off
22483 -- DETAILS ::= On | Off, local_NAME
22484 -- DETAILS ::= static_string_EXPRESSION
22485 -- DETAILS ::= On | Off, static_string_EXPRESSION
22487 -- TOOL_NAME ::= GNAT | GNATProve
22489 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
22491 -- Note: If the first argument matches an allowed tool name, it is
22492 -- always considered to be a tool name, even if there is a string
22493 -- variable of that name.
22495 -- Note if the second argument of DETAILS is a local_NAME then the
22496 -- second form is always understood. If the intention is to use
22497 -- the fourth form, then you can write NAME & "" to force the
22498 -- intepretation as a static_string_EXPRESSION.
22500 when Pragma_Warnings => Warnings : declare
22501 Reason : String_Id;
22505 Check_At_Least_N_Arguments (1);
22507 -- See if last argument is labeled Reason. If so, make sure we
22508 -- have a string literal or a concatenation of string literals,
22509 -- and acquire the REASON string. Then remove the REASON argument
22510 -- by decreasing Num_Args by one; Remaining processing looks only
22511 -- at first Num_Args arguments).
22514 Last_Arg : constant Node_Id :=
22515 Last (Pragma_Argument_Associations (N));
22518 if Nkind (Last_Arg) = N_Pragma_Argument_Association
22519 and then Chars (Last_Arg) = Name_Reason
22522 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
22523 Reason := End_String;
22524 Arg_Count := Arg_Count - 1;
22526 -- Not allowed in compiler units (bootstrap issues)
22528 Check_Compiler_Unit ("Reason for pragma Warnings", N);
22530 -- No REASON string, set null string as reason
22533 Reason := Null_String_Id;
22537 -- Now proceed with REASON taken care of and eliminated
22539 Check_No_Identifiers;
22541 -- If debug flag -gnatd.i is set, pragma is ignored
22543 if Debug_Flag_Dot_I then
22547 -- Process various forms of the pragma
22550 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
22551 Shifted_Args : List_Id;
22554 -- See if first argument is a tool name, currently either
22555 -- GNAT or GNATprove. If so, either ignore the pragma if the
22556 -- tool used does not match, or continue as if no tool name
22557 -- was given otherwise, by shifting the arguments.
22559 if Nkind (Argx) = N_Identifier
22560 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
22562 if Chars (Argx) = Name_Gnat then
22563 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
22564 Rewrite (N, Make_Null_Statement (Loc));
22569 elsif Chars (Argx) = Name_Gnatprove then
22570 if not GNATprove_Mode then
22571 Rewrite (N, Make_Null_Statement (Loc));
22577 raise Program_Error;
22580 -- At this point, the pragma Warnings applies to the tool,
22581 -- so continue with shifted arguments.
22583 Arg_Count := Arg_Count - 1;
22585 if Arg_Count = 1 then
22586 Shifted_Args := New_List (New_Copy (Arg2));
22587 elsif Arg_Count = 2 then
22588 Shifted_Args := New_List (New_Copy (Arg2),
22590 elsif Arg_Count = 3 then
22591 Shifted_Args := New_List (New_Copy (Arg2),
22595 raise Program_Error;
22600 Chars => Name_Warnings,
22601 Pragma_Argument_Associations => Shifted_Args));
22606 -- One argument case
22608 if Arg_Count = 1 then
22610 -- On/Off one argument case was processed by parser
22612 if Nkind (Argx) = N_Identifier
22613 and then Nam_In (Chars (Argx), Name_On, Name_Off)
22617 -- One argument case must be ON/OFF or static string expr
22619 elsif not Is_Static_String_Expression (Arg1) then
22621 ("argument of pragma% must be On/Off or static string "
22622 & "expression", Arg1);
22624 -- One argument string expression case
22628 Lit : constant Node_Id := Expr_Value_S (Argx);
22629 Str : constant String_Id := Strval (Lit);
22630 Len : constant Nat := String_Length (Str);
22638 while J <= Len loop
22639 C := Get_String_Char (Str, J);
22640 OK := In_Character_Range (C);
22643 Chr := Get_Character (C);
22645 -- Dash case: only -Wxxx is accepted
22652 C := Get_String_Char (Str, J);
22653 Chr := Get_Character (C);
22654 exit when Chr = 'W
';
22659 elsif J < Len and then Chr = '.' then
22661 C := Get_String_Char (Str, J);
22662 Chr := Get_Character (C);
22664 if not Set_Dot_Warning_Switch (Chr) then
22666 ("invalid warning switch character "
22667 & '.' & Chr, Arg1);
22673 OK := Set_Warning_Switch (Chr);
22679 ("invalid warning switch character " & Chr,
22688 -- Two or more arguments (must be two)
22691 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
22692 Check_Arg_Count (2);
22700 E_Id := Get_Pragma_Arg (Arg2);
22703 -- In the expansion of an inlined body, a reference to
22704 -- the formal may be wrapped in a conversion if the
22705 -- actual is a conversion. Retrieve the real entity name.
22707 if (In_Instance_Body or In_Inlined_Body)
22708 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
22710 E_Id := Expression (E_Id);
22713 -- Entity name case
22715 if Is_Entity_Name (E_Id) then
22716 E := Entity (E_Id);
22723 (E, (Chars (Get_Pragma_Arg (Arg1)) =
22726 -- For OFF case, make entry in warnings off
22727 -- pragma table for later processing. But we do
22728 -- not do that within an instance, since these
22729 -- warnings are about what is needed in the
22730 -- template, not an instance of it.
22732 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
22733 and then Warn_On_Warnings_Off
22734 and then not In_Instance
22736 Warnings_Off_Pragmas.Append ((N, E, Reason));
22739 if Is_Enumeration_Type (E) then
22743 Lit := First_Literal (E);
22744 while Present (Lit) loop
22745 Set_Warnings_Off (Lit);
22746 Next_Literal (Lit);
22751 exit when No (Homonym (E));
22756 -- Error if not entity or static string expression case
22758 elsif not Is_Static_String_Expression (Arg2) then
22760 ("second argument of pragma% must be entity name "
22761 & "or static string expression", Arg2);
22763 -- Static string expression case
22766 Acquire_Warning_Match_String (Arg2);
22768 -- Note on configuration pragma case: If this is a
22769 -- configuration pragma, then for an OFF pragma, we
22770 -- just set Config True in the call, which is all
22771 -- that needs to be done. For the case of ON, this
22772 -- is normally an error, unless it is canceling the
22773 -- effect of a previous OFF pragma in the same file.
22774 -- In any other case, an error will be signalled (ON
22775 -- with no matching OFF).
22777 -- Note: We set Used if we are inside a generic to
22778 -- disable the test that the non-config case actually
22779 -- cancels a warning. That's because we can't be sure
22780 -- there isn't an instantiation in some other unit
22781 -- where a warning is suppressed.
22783 -- We could do a little better here by checking if the
22784 -- generic unit we are inside is public, but for now
22785 -- we don't bother with that refinement.
22787 if Chars (Argx) = Name_Off then
22788 Set_Specific_Warning_Off
22789 (Loc, Name_Buffer (1 .. Name_Len), Reason,
22790 Config => Is_Configuration_Pragma,
22791 Used => Inside_A_Generic or else In_Instance);
22793 elsif Chars (Argx) = Name_On then
22794 Set_Specific_Warning_On
22795 (Loc, Name_Buffer (1 .. Name_Len), Err);
22799 ("??pragma Warnings On with no matching "
22800 & "Warnings Off", Loc);
22809 -------------------
22810 -- Weak_External --
22811 -------------------
22813 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
22815 when Pragma_Weak_External => Weak_External : declare
22820 Check_Arg_Count (1);
22821 Check_Optional_Identifier (Arg1, Name_Entity);
22822 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22823 Ent := Entity (Get_Pragma_Arg (Arg1));
22825 if Rep_Item_Too_Early (Ent, N) then
22828 Ent := Underlying_Type (Ent);
22831 -- The only processing required is to link this item on to the
22832 -- list of rep items for the given entity. This is accomplished
22833 -- by the call to Rep_Item_Too_Late (when no error is detected
22834 -- and False is returned).
22836 if Rep_Item_Too_Late (Ent, N) then
22839 Set_Has_Gigi_Rep_Item (Ent);
22843 -----------------------------
22844 -- Wide_Character_Encoding --
22845 -----------------------------
22847 -- pragma Wide_Character_Encoding (IDENTIFIER);
22849 when Pragma_Wide_Character_Encoding =>
22852 -- Nothing to do, handled in parser. Note that we do not enforce
22853 -- configuration pragma placement, this pragma can appear at any
22854 -- place in the source, allowing mixed encodings within a single
22859 --------------------
22860 -- Unknown_Pragma --
22861 --------------------
22863 -- Should be impossible, since the case of an unknown pragma is
22864 -- separately processed before the case statement is entered.
22866 when Unknown_Pragma =>
22867 raise Program_Error;
22870 -- AI05-0144: detect dangerous order dependence. Disabled for now,
22871 -- until AI is formally approved.
22873 -- Check_Order_Dependence;
22876 when Pragma_Exit => null;
22877 end Analyze_Pragma;
22879 ---------------------------------------------
22880 -- Analyze_Pre_Post_Condition_In_Decl_Part --
22881 ---------------------------------------------
22883 procedure Analyze_Pre_Post_Condition_In_Decl_Part (N : Node_Id) is
22884 procedure Process_Class_Wide_Condition
22886 Spec_Id : Entity_Id;
22887 Subp_Decl : Node_Id);
22888 -- Replace the type of all references to the controlling formal of
22889 -- subprogram Spec_Id found in expression Expr with the corresponding
22890 -- class-wide type. Subp_Decl is the subprogram [body] declaration
22891 -- where the pragma resides.
22893 ----------------------------------
22894 -- Process_Class_Wide_Condition --
22895 ----------------------------------
22897 procedure Process_Class_Wide_Condition
22899 Spec_Id : Entity_Id;
22900 Subp_Decl : Node_Id)
22902 Disp_Typ : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
22904 ACW : Entity_Id := Empty;
22905 -- Access to Disp_Typ'Class, created if there is a controlling formal
22906 -- that is an access parameter.
22908 function Access_Class_Wide_Type return Entity_Id;
22909 -- If expression Expr contains a reference to a controlling access
22910 -- parameter, create an access to Disp_Typ'Class for the necessary
22911 -- conversions if one does not exist.
22913 function Replace_Type (N : Node_Id) return Traverse_Result;
22914 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
22915 -- aspect for a primitive subprogram of a tagged type Disp_Typ, a
22916 -- name that denotes a formal parameter of type Disp_Typ is treated
22917 -- as having type Disp_Typ'Class. Similarly, a name that denotes a
22918 -- formal access parameter of type access-to-Disp_Typ is interpreted
22919 -- as with type access-to-Disp_Typ'Class. This ensures the expression
22920 -- is well defined for a primitive subprogram of a type descended
22923 ----------------------------
22924 -- Access_Class_Wide_Type --
22925 ----------------------------
22927 function Access_Class_Wide_Type return Entity_Id is
22928 Loc : constant Source_Ptr := Sloc (N);
22932 ACW := Make_Temporary (Loc, 'T
');
22934 Insert_Before_And_Analyze (Subp_Decl,
22935 Make_Full_Type_Declaration (Loc,
22936 Defining_Identifier => ACW,
22938 Make_Access_To_Object_Definition (Loc,
22939 Subtype_Indication =>
22940 New_Occurrence_Of (Class_Wide_Type (Disp_Typ), Loc),
22941 All_Present => True)));
22943 Freeze_Before (Subp_Decl, ACW);
22947 end Access_Class_Wide_Type;
22953 function Replace_Type (N : Node_Id) return Traverse_Result is
22954 Context : constant Node_Id := Parent (N);
22955 Loc : constant Source_Ptr := Sloc (N);
22956 CW_Typ : Entity_Id := Empty;
22961 if Is_Entity_Name (N)
22962 and then Present (Entity (N))
22963 and then Is_Formal (Entity (N))
22966 Typ := Etype (Ent);
22968 -- Do not perform the type replacement for selector names in
22969 -- parameter associations. These carry an entity for reference
22970 -- purposes, but semantically they are just identifiers.
22972 if Nkind (Context) = N_Type_Conversion then
22975 elsif Nkind (Context) = N_Parameter_Association
22976 and then Selector_Name (Context) = N
22980 elsif Typ = Disp_Typ then
22981 CW_Typ := Class_Wide_Type (Typ);
22983 elsif Is_Access_Type (Typ)
22984 and then Designated_Type (Typ) = Disp_Typ
22986 CW_Typ := Access_Class_Wide_Type;
22989 if Present (CW_Typ) then
22991 Make_Type_Conversion (Loc,
22992 Subtype_Mark => New_Occurrence_Of (CW_Typ, Loc),
22993 Expression => New_Occurrence_Of (Ent, Loc)));
22994 Set_Etype (N, CW_Typ);
23001 procedure Replace_Types is new Traverse_Proc (Replace_Type);
23003 -- Start of processing for Process_Class_Wide_Condition
23006 -- The subprogram subject to Pre'Class/Post'Class does not have a
23007 -- dispatching type, therefore the aspect/pragma is illegal.
23009 if No (Disp_Typ) then
23010 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23012 if From_Aspect_Specification (N) then
23014 ("aspect % can only be specified for a primitive operation "
23015 & "of a tagged type", Corresponding_Aspect (N));
23017 -- The pragma is a source construct
23021 ("pragma % can only be specified for a primitive operation "
23022 & "of a tagged type", N);
23026 Replace_Types (Expr);
23027 end Process_Class_Wide_Condition;
23031 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23032 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23033 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
23035 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
23037 Restore_Scope : Boolean := False;
23039 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23042 -- Do not analyze the pragma multiple times
23044 if Is_Analyzed_Pragma (N) then
23048 -- Set the Ghost mode in effect from the pragma. Due to the delayed
23049 -- analysis of the pragma, the Ghost mode at point of declaration and
23050 -- point of analysis may not necessarely be the same. Use the mode in
23051 -- effect at the point of declaration.
23053 Set_Ghost_Mode (N);
23055 -- Ensure that the subprogram and its formals are visible when analyzing
23056 -- the expression of the pragma.
23058 if not In_Open_Scopes (Spec_Id) then
23059 Restore_Scope := True;
23060 Push_Scope (Spec_Id);
23062 if Is_Generic_Subprogram (Spec_Id) then
23063 Install_Generic_Formals (Spec_Id);
23065 Install_Formals (Spec_Id);
23069 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23071 -- For a class-wide condition, a reference to a controlling formal must
23072 -- be interpreted as having the class-wide type (or an access to such)
23073 -- so that the inherited condition can be properly applied to any
23074 -- overriding operation (see ARM12 6.6.1 (7)).
23076 if Class_Present (N) then
23077 Process_Class_Wide_Condition (Expr, Spec_Id, Subp_Decl);
23080 if Restore_Scope then
23084 -- Currently it is not possible to inline pre/postconditions on a
23085 -- subprogram subject to pragma Inline_Always.
23087 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23088 Ghost_Mode := Save_Ghost_Mode;
23090 Set_Is_Analyzed_Pragma (N);
23091 end Analyze_Pre_Post_Condition_In_Decl_Part;
23093 ------------------------------------------
23094 -- Analyze_Refined_Depends_In_Decl_Part --
23095 ------------------------------------------
23097 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23098 Body_Inputs : Elist_Id := No_Elist;
23099 Body_Outputs : Elist_Id := No_Elist;
23100 -- The inputs and outputs of the subprogram body synthesized from pragma
23101 -- Refined_Depends.
23103 Dependencies : List_Id := No_List;
23105 -- The corresponding Depends pragma along with its clauses
23107 Matched_Items : Elist_Id := No_Elist;
23108 -- A list containing the entities of all successfully matched items
23109 -- found in pragma Depends.
23111 Refinements : List_Id := No_List;
23112 -- The clauses of pragma Refined_Depends
23114 Spec_Id : Entity_Id;
23115 -- The entity of the subprogram subject to pragma Refined_Depends
23117 Spec_Inputs : Elist_Id := No_Elist;
23118 Spec_Outputs : Elist_Id := No_Elist;
23119 -- The inputs and outputs of the subprogram spec synthesized from pragma
23122 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
23123 -- Try to match a single dependency clause Dep_Clause against one or
23124 -- more refinement clauses found in list Refinements. Each successful
23125 -- match eliminates at least one refinement clause from Refinements.
23127 procedure Check_Output_States;
23128 -- Determine whether pragma Depends contains an output state with a
23129 -- visible refinement and if so, ensure that pragma Refined_Depends
23130 -- mentions all its constituents as outputs.
23132 procedure Normalize_Clauses (Clauses : List_Id);
23133 -- Given a list of dependence or refinement clauses Clauses, normalize
23134 -- each clause by creating multiple dependencies with exactly one input
23137 procedure Report_Extra_Clauses;
23138 -- Emit an error for each extra clause found in list Refinements
23140 -----------------------------
23141 -- Check_Dependency_Clause --
23142 -----------------------------
23144 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
23145 Dep_Input : constant Node_Id := Expression (Dep_Clause);
23146 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23148 function Is_In_Out_State_Clause return Boolean;
23149 -- Determine whether dependence clause Dep_Clause denotes an abstract
23150 -- state that depends on itself (State => State).
23152 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23153 -- Determine whether item Item denotes an abstract state with visible
23154 -- null refinement.
23156 procedure Match_Items
23157 (Dep_Item : Node_Id;
23158 Ref_Item : Node_Id;
23159 Matched : out Boolean);
23160 -- Try to match dependence item Dep_Item against refinement item
23161 -- Ref_Item. To match against a possible null refinement (see 2, 7),
23162 -- set Ref_Item to Empty. Flag Matched is set to True when one of
23163 -- the following conformance scenarios is in effect:
23164 -- 1) Both items denote null
23165 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
23166 -- 3) Both items denote attribute 'Result
23167 -- 4) Both items denote the same object
23168 -- 5) Both items denote the same formal parameter
23169 -- 6) Both items denote the same current instance of a type
23170 -- 7) Both items denote the same discriminant
23171 -- 8) Dep_Item is an abstract state with visible null refinement
23172 -- and Ref_Item denotes null.
23173 -- 9) Dep_Item is an abstract state with visible null refinement
23174 -- and Ref_Item is Empty (special case).
23175 -- 10) Dep_Item is an abstract state with visible non-null
23176 -- refinement and Ref_Item denotes one of its constituents.
23177 -- 11) Dep_Item is an abstract state without a visible refinement
23178 -- and Ref_Item denotes the same state.
23179 -- When scenario 10 is in effect, the entity of the abstract state
23180 -- denoted by Dep_Item is added to list Refined_States.
23182 procedure Record_Item
(Item_Id
: Entity_Id
);
23183 -- Store the entity of an item denoted by Item_Id in Matched_Items
23185 ----------------------------
23186 -- Is_In_Out_State_Clause --
23187 ----------------------------
23189 function Is_In_Out_State_Clause
return Boolean is
23190 Dep_Input_Id
: Entity_Id
;
23191 Dep_Output_Id
: Entity_Id
;
23194 -- Detect the following clause:
23197 if Is_Entity_Name
(Dep_Input
)
23198 and then Is_Entity_Name
(Dep_Output
)
23200 -- Handle abstract views generated for limited with clauses
23202 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
23203 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
23206 Ekind
(Dep_Input_Id
) = E_Abstract_State
23207 and then Dep_Input_Id
= Dep_Output_Id
;
23211 end Is_In_Out_State_Clause
;
23213 ---------------------------
23214 -- Is_Null_Refined_State --
23215 ---------------------------
23217 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
23218 Item_Id
: Entity_Id
;
23221 if Is_Entity_Name
(Item
) then
23223 -- Handle abstract views generated for limited with clauses
23225 Item_Id
:= Available_View
(Entity_Of
(Item
));
23228 Ekind
(Item_Id
) = E_Abstract_State
23229 and then Has_Null_Refinement
(Item_Id
);
23233 end Is_Null_Refined_State
;
23239 procedure Match_Items
23240 (Dep_Item
: Node_Id
;
23241 Ref_Item
: Node_Id
;
23242 Matched
: out Boolean)
23244 Dep_Item_Id
: Entity_Id
;
23245 Ref_Item_Id
: Entity_Id
;
23248 -- Assume that the two items do not match
23252 -- A null matches null or Empty (special case)
23254 if Nkind
(Dep_Item
) = N_Null
23255 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
23259 -- Attribute 'Result matches attribute 'Result
23261 elsif Is_Attribute_Result
(Dep_Item
)
23262 and then Is_Attribute_Result
(Dep_Item
)
23266 -- Abstract states, current instances of concurrent types,
23267 -- discriminants, formal parameters and objects.
23269 elsif Is_Entity_Name
(Dep_Item
) then
23271 -- Handle abstract views generated for limited with clauses
23273 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
23275 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
23277 -- An abstract state with visible null refinement matches
23278 -- null or Empty (special case).
23280 if Has_Null_Refinement
(Dep_Item_Id
)
23281 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
23283 Record_Item
(Dep_Item_Id
);
23286 -- An abstract state with visible non-null refinement
23287 -- matches one of its constituents.
23289 elsif Has_Non_Null_Refinement
(Dep_Item_Id
) then
23290 if Is_Entity_Name
(Ref_Item
) then
23291 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
23293 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
23296 and then Present
(Encapsulating_State
(Ref_Item_Id
))
23297 and then Encapsulating_State
(Ref_Item_Id
) =
23300 Record_Item
(Dep_Item_Id
);
23305 -- An abstract state without a visible refinement matches
23308 elsif Is_Entity_Name
(Ref_Item
)
23309 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
23311 Record_Item
(Dep_Item_Id
);
23315 -- A current instance of a concurrent type, discriminant,
23316 -- formal parameter or an object matches itself.
23318 elsif Is_Entity_Name
(Ref_Item
)
23319 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
23321 Record_Item
(Dep_Item_Id
);
23331 procedure Record_Item
(Item_Id
: Entity_Id
) is
23333 if not Contains
(Matched_Items
, Item_Id
) then
23334 Append_New_Elmt
(Item_Id
, Matched_Items
);
23340 Clause_Matched
: Boolean := False;
23341 Dummy
: Boolean := False;
23342 Inputs_Match
: Boolean;
23343 Next_Ref_Clause
: Node_Id
;
23344 Outputs_Match
: Boolean;
23345 Ref_Clause
: Node_Id
;
23346 Ref_Input
: Node_Id
;
23347 Ref_Output
: Node_Id
;
23349 -- Start of processing for Check_Dependency_Clause
23352 -- Do not perform this check in an instance because it was already
23353 -- performed successfully in the generic template.
23355 if Is_Generic_Instance
(Spec_Id
) then
23359 -- Examine all refinement clauses and compare them against the
23360 -- dependence clause.
23362 Ref_Clause
:= First
(Refinements
);
23363 while Present
(Ref_Clause
) loop
23364 Next_Ref_Clause
:= Next
(Ref_Clause
);
23366 -- Obtain the attributes of the current refinement clause
23368 Ref_Input
:= Expression
(Ref_Clause
);
23369 Ref_Output
:= First
(Choices
(Ref_Clause
));
23371 -- The current refinement clause matches the dependence clause
23372 -- when both outputs match and both inputs match. See routine
23373 -- Match_Items for all possible conformance scenarios.
23375 -- Depends Dep_Output => Dep_Input
23379 -- Refined_Depends Ref_Output => Ref_Input
23382 (Dep_Item
=> Dep_Input
,
23383 Ref_Item
=> Ref_Input
,
23384 Matched
=> Inputs_Match
);
23387 (Dep_Item
=> Dep_Output
,
23388 Ref_Item
=> Ref_Output
,
23389 Matched
=> Outputs_Match
);
23391 -- An In_Out state clause may be matched against a refinement with
23392 -- a null input or null output as long as the non-null side of the
23393 -- relation contains a valid constituent of the In_Out_State.
23395 if Is_In_Out_State_Clause
then
23397 -- Depends => (State => State)
23398 -- Refined_Depends => (null => Constit) -- OK
23401 and then not Outputs_Match
23402 and then Nkind
(Ref_Output
) = N_Null
23404 Outputs_Match
:= True;
23407 -- Depends => (State => State)
23408 -- Refined_Depends => (Constit => null) -- OK
23410 if not Inputs_Match
23411 and then Outputs_Match
23412 and then Nkind
(Ref_Input
) = N_Null
23414 Inputs_Match
:= True;
23418 -- The current refinement clause is legally constructed following
23419 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
23420 -- the pool of candidates. The seach continues because a single
23421 -- dependence clause may have multiple matching refinements.
23423 if Inputs_Match
and then Outputs_Match
then
23424 Clause_Matched
:= True;
23425 Remove
(Ref_Clause
);
23428 Ref_Clause
:= Next_Ref_Clause
;
23431 -- Depending on the order or composition of refinement clauses, an
23432 -- In_Out state clause may not be directly refinable.
23434 -- Depends => ((Output, State) => (Input, State))
23435 -- Refined_State => (State => (Constit_1, Constit_2))
23436 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
23438 -- Matching normalized clause (State => State) fails because there is
23439 -- no direct refinement capable of satisfying this relation. Another
23440 -- similar case arises when clauses (Constit_1 => Input) and (Output
23441 -- => Constit_2) are matched first, leaving no candidates for clause
23442 -- (State => State). Both scenarios are legal as long as one of the
23443 -- previous clauses mentioned a valid constituent of State.
23445 if not Clause_Matched
23446 and then Is_In_Out_State_Clause
23448 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
23450 Clause_Matched
:= True;
23453 -- A clause where the input is an abstract state with visible null
23454 -- refinement is implicitly matched when the output has already been
23455 -- matched in a previous clause.
23457 -- Depends => (Output => State) -- implicitly OK
23458 -- Refined_State => (State => null)
23459 -- Refined_Depends => (Output => ...)
23461 if not Clause_Matched
23462 and then Is_Null_Refined_State
(Dep_Input
)
23463 and then Is_Entity_Name
(Dep_Output
)
23465 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
23467 Clause_Matched
:= True;
23470 -- A clause where the output is an abstract state with visible null
23471 -- refinement is implicitly matched when the input has already been
23472 -- matched in a previous clause.
23474 -- Depends => (State => Input) -- implicitly OK
23475 -- Refined_State => (State => null)
23476 -- Refined_Depends => (... => Input)
23478 if not Clause_Matched
23479 and then Is_Null_Refined_State
(Dep_Output
)
23480 and then Is_Entity_Name
(Dep_Input
)
23482 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
23484 Clause_Matched
:= True;
23487 -- At this point either all refinement clauses have been examined or
23488 -- pragma Refined_Depends contains a solitary null. Only an abstract
23489 -- state with null refinement can possibly match these cases.
23491 -- Depends => (State => null)
23492 -- Refined_State => (State => null)
23493 -- Refined_Depends => null -- OK
23495 if not Clause_Matched
then
23497 (Dep_Item
=> Dep_Input
,
23499 Matched
=> Inputs_Match
);
23502 (Dep_Item
=> Dep_Output
,
23504 Matched
=> Outputs_Match
);
23506 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
23509 -- If the contents of Refined_Depends are legal, then the current
23510 -- dependence clause should be satisfied either by an explicit match
23511 -- or by one of the special cases.
23513 if not Clause_Matched
then
23515 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
23516 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
23518 end Check_Dependency_Clause
;
23520 -------------------------
23521 -- Check_Output_States --
23522 -------------------------
23524 procedure Check_Output_States
is
23525 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23526 -- Determine whether all constituents of state State_Id with visible
23527 -- refinement are used as outputs in pragma Refined_Depends. Emit an
23528 -- error if this is not the case.
23530 -----------------------------
23531 -- Check_Constituent_Usage --
23532 -----------------------------
23534 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23535 Constit_Elmt
: Elmt_Id
;
23536 Constit_Id
: Entity_Id
;
23537 Posted
: Boolean := False;
23540 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23541 while Present
(Constit_Elmt
) loop
23542 Constit_Id
:= Node
(Constit_Elmt
);
23544 -- The constituent acts as an input (SPARK RM 7.2.5(3))
23546 if Present
(Body_Inputs
)
23547 and then Appears_In
(Body_Inputs
, Constit_Id
)
23549 Error_Msg_Name_1
:= Chars
(State_Id
);
23551 ("constituent & of state % must act as output in "
23552 & "dependence refinement", N
, Constit_Id
);
23554 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23556 elsif No
(Body_Outputs
)
23557 or else not Appears_In
(Body_Outputs
, Constit_Id
)
23562 ("output state & must be replaced by all its "
23563 & "constituents in dependence refinement",
23568 ("\constituent & is missing in output list",
23572 Next_Elmt
(Constit_Elmt
);
23574 end Check_Constituent_Usage
;
23579 Item_Elmt
: Elmt_Id
;
23580 Item_Id
: Entity_Id
;
23582 -- Start of processing for Check_Output_States
23585 -- Do not perform this check in an instance because it was already
23586 -- performed successfully in the generic template.
23588 if Is_Generic_Instance
(Spec_Id
) then
23591 -- Inspect the outputs of pragma Depends looking for a state with a
23592 -- visible refinement.
23594 elsif Present
(Spec_Outputs
) then
23595 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
23596 while Present
(Item_Elmt
) loop
23597 Item
:= Node
(Item_Elmt
);
23599 -- Deal with the mixed nature of the input and output lists
23601 if Nkind
(Item
) = N_Defining_Identifier
then
23604 Item_Id
:= Available_View
(Entity_Of
(Item
));
23607 if Ekind
(Item_Id
) = E_Abstract_State
then
23609 -- The state acts as an input-output, skip it
23611 if Present
(Spec_Inputs
)
23612 and then Appears_In
(Spec_Inputs
, Item_Id
)
23616 -- Ensure that all of the constituents are utilized as
23617 -- outputs in pragma Refined_Depends.
23619 elsif Has_Non_Null_Refinement
(Item_Id
) then
23620 Check_Constituent_Usage
(Item_Id
);
23624 Next_Elmt
(Item_Elmt
);
23627 end Check_Output_States
;
23629 -----------------------
23630 -- Normalize_Clauses --
23631 -----------------------
23633 procedure Normalize_Clauses
(Clauses
: List_Id
) is
23634 procedure Normalize_Inputs
(Clause
: Node_Id
);
23635 -- Normalize clause Clause by creating multiple clauses for each
23636 -- input item of Clause. It is assumed that Clause has exactly one
23637 -- output. The transformation is as follows:
23639 -- Output => (Input_1, Input_2) -- original
23641 -- Output => Input_1 -- normalizations
23642 -- Output => Input_2
23644 procedure Normalize_Outputs
(Clause
: Node_Id
);
23645 -- Normalize clause Clause by creating multiple clause for each
23646 -- output item of Clause. The transformation is as follows:
23648 -- (Output_1, Output_2) => Input -- original
23650 -- Output_1 => Input -- normalization
23651 -- Output_2 => Input
23653 ----------------------
23654 -- Normalize_Inputs --
23655 ----------------------
23657 procedure Normalize_Inputs
(Clause
: Node_Id
) is
23658 Inputs
: constant Node_Id
:= Expression
(Clause
);
23659 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
23660 Output
: constant List_Id
:= Choices
(Clause
);
23661 Last_Input
: Node_Id
;
23663 New_Clause
: Node_Id
;
23664 Next_Input
: Node_Id
;
23667 -- Normalization is performed only when the original clause has
23668 -- more than one input. Multiple inputs appear as an aggregate.
23670 if Nkind
(Inputs
) = N_Aggregate
then
23671 Last_Input
:= Last
(Expressions
(Inputs
));
23673 -- Create a new clause for each input
23675 Input
:= First
(Expressions
(Inputs
));
23676 while Present
(Input
) loop
23677 Next_Input
:= Next
(Input
);
23679 -- Unhook the current input from the original input list
23680 -- because it will be relocated to a new clause.
23684 -- Special processing for the last input. At this point the
23685 -- original aggregate has been stripped down to one element.
23686 -- Replace the aggregate by the element itself.
23688 if Input
= Last_Input
then
23689 Rewrite
(Inputs
, Input
);
23691 -- Generate a clause of the form:
23696 Make_Component_Association
(Loc
,
23697 Choices
=> New_Copy_List_Tree
(Output
),
23698 Expression
=> Input
);
23700 -- The new clause contains replicated content that has
23701 -- already been analyzed, mark the clause as analyzed.
23703 Set_Analyzed
(New_Clause
);
23704 Insert_After
(Clause
, New_Clause
);
23707 Input
:= Next_Input
;
23710 end Normalize_Inputs
;
23712 -----------------------
23713 -- Normalize_Outputs --
23714 -----------------------
23716 procedure Normalize_Outputs
(Clause
: Node_Id
) is
23717 Inputs
: constant Node_Id
:= Expression
(Clause
);
23718 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
23719 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
23720 Last_Output
: Node_Id
;
23721 New_Clause
: Node_Id
;
23722 Next_Output
: Node_Id
;
23726 -- Multiple outputs appear as an aggregate. Nothing to do when
23727 -- the clause has exactly one output.
23729 if Nkind
(Outputs
) = N_Aggregate
then
23730 Last_Output
:= Last
(Expressions
(Outputs
));
23732 -- Create a clause for each output. Note that each time a new
23733 -- clause is created, the original output list slowly shrinks
23734 -- until there is one item left.
23736 Output
:= First
(Expressions
(Outputs
));
23737 while Present
(Output
) loop
23738 Next_Output
:= Next
(Output
);
23740 -- Unhook the output from the original output list as it
23741 -- will be relocated to a new clause.
23745 -- Special processing for the last output. At this point
23746 -- the original aggregate has been stripped down to one
23747 -- element. Replace the aggregate by the element itself.
23749 if Output
= Last_Output
then
23750 Rewrite
(Outputs
, Output
);
23753 -- Generate a clause of the form:
23754 -- (Output => Inputs)
23757 Make_Component_Association
(Loc
,
23758 Choices
=> New_List
(Output
),
23759 Expression
=> New_Copy_Tree
(Inputs
));
23761 -- The new clause contains replicated content that has
23762 -- already been analyzed. There is not need to reanalyze
23765 Set_Analyzed
(New_Clause
);
23766 Insert_After
(Clause
, New_Clause
);
23769 Output
:= Next_Output
;
23772 end Normalize_Outputs
;
23778 -- Start of processing for Normalize_Clauses
23781 Clause
:= First
(Clauses
);
23782 while Present
(Clause
) loop
23783 Normalize_Outputs
(Clause
);
23787 Clause
:= First
(Clauses
);
23788 while Present
(Clause
) loop
23789 Normalize_Inputs
(Clause
);
23792 end Normalize_Clauses
;
23794 --------------------------
23795 -- Report_Extra_Clauses --
23796 --------------------------
23798 procedure Report_Extra_Clauses
is
23802 -- Do not perform this check in an instance because it was already
23803 -- performed successfully in the generic template.
23805 if Is_Generic_Instance
(Spec_Id
) then
23808 elsif Present
(Refinements
) then
23809 Clause
:= First
(Refinements
);
23810 while Present
(Clause
) loop
23812 -- Do not complain about a null input refinement, since a null
23813 -- input legitimately matches anything.
23815 if Nkind
(Clause
) = N_Component_Association
23816 and then Nkind
(Expression
(Clause
)) = N_Null
23822 ("unmatched or extra clause in dependence refinement",
23829 end Report_Extra_Clauses
;
23833 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
23834 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
23835 Errors
: constant Nat
:= Serious_Errors_Detected
;
23841 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
23844 -- Do not analyze the pragma multiple times
23846 if Is_Analyzed_Pragma
(N
) then
23850 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
23852 -- Use the anonymous object as the proper spec when Refined_Depends
23853 -- applies to the body of a single task type. The object carries the
23854 -- proper Chars as well as all non-refined versions of pragmas.
23856 if Is_Single_Concurrent_Type
(Spec_Id
) then
23857 Spec_Id
:= Anonymous_Object
(Spec_Id
);
23860 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
23862 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
23863 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
23865 if No
(Depends
) then
23867 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
23868 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
23872 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
23874 -- A null dependency relation renders the refinement useless because it
23875 -- cannot possibly mention abstract states with visible refinement. Note
23876 -- that the inverse is not true as states may be refined to null
23877 -- (SPARK RM 7.2.5(2)).
23879 if Nkind
(Deps
) = N_Null
then
23881 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
23882 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
23886 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
23887 -- This ensures that the categorization of all refined dependency items
23888 -- is consistent with their role.
23890 Analyze_Depends_In_Decl_Part
(N
);
23892 -- Do not match dependencies against refinements if Refined_Depends is
23893 -- illegal to avoid emitting misleading error.
23895 if Serious_Errors_Detected
= Errors
then
23897 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
23898 -- the inputs and outputs of the subprogram spec and body to verify
23899 -- the use of states with visible refinement and their constituents.
23901 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
23902 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
23904 Collect_Subprogram_Inputs_Outputs
23905 (Subp_Id
=> Spec_Id
,
23906 Synthesize
=> True,
23907 Subp_Inputs
=> Spec_Inputs
,
23908 Subp_Outputs
=> Spec_Outputs
,
23909 Global_Seen
=> Dummy
);
23911 Collect_Subprogram_Inputs_Outputs
23912 (Subp_Id
=> Body_Id
,
23913 Synthesize
=> True,
23914 Subp_Inputs
=> Body_Inputs
,
23915 Subp_Outputs
=> Body_Outputs
,
23916 Global_Seen
=> Dummy
);
23918 -- For an output state with a visible refinement, ensure that all
23919 -- constituents appear as outputs in the dependency refinement.
23921 Check_Output_States
;
23924 -- Matching is disabled in ASIS because clauses are not normalized as
23925 -- this is a tree altering activity similar to expansion.
23931 -- Multiple dependency clauses appear as component associations of an
23932 -- aggregate. Note that the clauses are copied because the algorithm
23933 -- modifies them and this should not be visible in Depends.
23935 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
23936 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
23937 Normalize_Clauses
(Dependencies
);
23939 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
23941 if Nkind
(Refs
) = N_Null
then
23942 Refinements
:= No_List
;
23944 -- Multiple dependency clauses appear as component associations of an
23945 -- aggregate. Note that the clauses are copied because the algorithm
23946 -- modifies them and this should not be visible in Refined_Depends.
23948 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
23949 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
23950 Normalize_Clauses
(Refinements
);
23953 -- At this point the clauses of pragmas Depends and Refined_Depends
23954 -- have been normalized into simple dependencies between one output
23955 -- and one input. Examine all clauses of pragma Depends looking for
23956 -- matching clauses in pragma Refined_Depends.
23958 Clause
:= First
(Dependencies
);
23959 while Present
(Clause
) loop
23960 Check_Dependency_Clause
(Clause
);
23964 if Serious_Errors_Detected
= Errors
then
23965 Report_Extra_Clauses
;
23970 Set_Is_Analyzed_Pragma
(N
);
23971 end Analyze_Refined_Depends_In_Decl_Part
;
23973 -----------------------------------------
23974 -- Analyze_Refined_Global_In_Decl_Part --
23975 -----------------------------------------
23977 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
23979 -- The corresponding Global pragma
23981 Has_In_State
: Boolean := False;
23982 Has_In_Out_State
: Boolean := False;
23983 Has_Out_State
: Boolean := False;
23984 Has_Proof_In_State
: Boolean := False;
23985 -- These flags are set when the corresponding Global pragma has a state
23986 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
23989 Has_Null_State
: Boolean := False;
23990 -- This flag is set when the corresponding Global pragma has at least
23991 -- one state with a null refinement.
23993 In_Constits
: Elist_Id
:= No_Elist
;
23994 In_Out_Constits
: Elist_Id
:= No_Elist
;
23995 Out_Constits
: Elist_Id
:= No_Elist
;
23996 Proof_In_Constits
: Elist_Id
:= No_Elist
;
23997 -- These lists contain the entities of all Input, In_Out, Output and
23998 -- Proof_In constituents that appear in Refined_Global and participate
23999 -- in state refinement.
24001 In_Items
: Elist_Id
:= No_Elist
;
24002 In_Out_Items
: Elist_Id
:= No_Elist
;
24003 Out_Items
: Elist_Id
:= No_Elist
;
24004 Proof_In_Items
: Elist_Id
:= No_Elist
;
24005 -- These list contain the entities of all Input, In_Out, Output and
24006 -- Proof_In items defined in the corresponding Global pragma.
24008 Spec_Id
: Entity_Id
;
24009 -- The entity of the subprogram subject to pragma Refined_Global
24011 procedure Check_In_Out_States
;
24012 -- Determine whether the corresponding Global pragma mentions In_Out
24013 -- states with visible refinement and if so, ensure that one of the
24014 -- following completions apply to the constituents of the state:
24015 -- 1) there is at least one constituent of mode In_Out
24016 -- 2) there is at least one Input and one Output constituent
24017 -- 3) not all constituents are present and one of them is of mode
24019 -- This routine may remove elements from In_Constits, In_Out_Constits,
24020 -- Out_Constits and Proof_In_Constits.
24022 procedure Check_Input_States
;
24023 -- Determine whether the corresponding Global pragma mentions Input
24024 -- states with visible refinement and if so, ensure that at least one of
24025 -- its constituents appears as an Input item in Refined_Global.
24026 -- This routine may remove elements from In_Constits, In_Out_Constits,
24027 -- Out_Constits and Proof_In_Constits.
24029 procedure Check_Output_States
;
24030 -- Determine whether the corresponding Global pragma mentions Output
24031 -- states with visible refinement and if so, ensure that all of its
24032 -- constituents appear as Output items in Refined_Global.
24033 -- This routine may remove elements from In_Constits, In_Out_Constits,
24034 -- Out_Constits and Proof_In_Constits.
24036 procedure Check_Proof_In_States
;
24037 -- Determine whether the corresponding Global pragma mentions Proof_In
24038 -- states with visible refinement and if so, ensure that at least one of
24039 -- its constituents appears as a Proof_In item in Refined_Global.
24040 -- This routine may remove elements from In_Constits, In_Out_Constits,
24041 -- Out_Constits and Proof_In_Constits.
24043 procedure Check_Refined_Global_List
24045 Global_Mode
: Name_Id
:= Name_Input
);
24046 -- Verify the legality of a single global list declaration. Global_Mode
24047 -- denotes the current mode in effect.
24049 procedure Collect_Global_Items
24051 Mode
: Name_Id
:= Name_Input
);
24052 -- Gather all input, in out, output and Proof_In items from node List
24053 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
24054 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
24055 -- and Has_Proof_In_State are set when there is at least one abstract
24056 -- state with visible refinement available in the corresponding mode.
24057 -- Flag Has_Null_State is set when at least state has a null refinement.
24058 -- Mode enotes the current global mode in effect.
24060 function Present_Then_Remove
24062 Item
: Entity_Id
) return Boolean;
24063 -- Search List for a particular entity Item. If Item has been found,
24064 -- remove it from List. This routine is used to strip lists In_Constits,
24065 -- In_Out_Constits and Out_Constits of valid constituents.
24067 procedure Report_Extra_Constituents
;
24068 -- Emit an error for each constituent found in lists In_Constits,
24069 -- In_Out_Constits and Out_Constits.
24071 -------------------------
24072 -- Check_In_Out_States --
24073 -------------------------
24075 procedure Check_In_Out_States
is
24076 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24077 -- Determine whether one of the following coverage scenarios is in
24079 -- 1) there is at least one constituent of mode In_Out
24080 -- 2) there is at least one Input and one Output constituent
24081 -- 3) not all constituents are present and one of them is of mode
24083 -- If this is not the case, emit an error.
24085 -----------------------------
24086 -- Check_Constituent_Usage --
24087 -----------------------------
24089 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24090 Constit_Elmt
: Elmt_Id
;
24091 Constit_Id
: Entity_Id
;
24092 Has_Missing
: Boolean := False;
24093 In_Out_Seen
: Boolean := False;
24094 In_Seen
: Boolean := False;
24095 Out_Seen
: Boolean := False;
24098 -- Process all the constituents of the state and note their modes
24099 -- within the global refinement.
24101 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
24102 while Present
(Constit_Elmt
) loop
24103 Constit_Id
:= Node
(Constit_Elmt
);
24105 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
24108 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
24109 In_Out_Seen
:= True;
24111 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
24114 -- A Proof_In constituent cannot participate in the completion
24115 -- of an Output state (SPARK RM 7.2.4(5)).
24117 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
24118 Error_Msg_Name_1
:= Chars
(State_Id
);
24120 ("constituent & of state % must have mode Input, In_Out "
24121 & "or Output in global refinement", N
, Constit_Id
);
24124 Has_Missing
:= True;
24127 Next_Elmt
(Constit_Elmt
);
24130 -- A single In_Out constituent is a valid completion
24132 if In_Out_Seen
then
24135 -- A pair of one Input and one Output constituent is a valid
24138 elsif In_Seen
and then Out_Seen
then
24141 -- A single Output constituent is a valid completion only when
24142 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
24144 elsif Has_Missing
and then Out_Seen
then
24149 ("global refinement of state & redefines the mode of its "
24150 & "constituents", N
, State_Id
);
24152 end Check_Constituent_Usage
;
24156 Item_Elmt
: Elmt_Id
;
24157 Item_Id
: Entity_Id
;
24159 -- Start of processing for Check_In_Out_States
24162 -- Do not perform this check in an instance because it was already
24163 -- performed successfully in the generic template.
24165 if Is_Generic_Instance
(Spec_Id
) then
24168 -- Inspect the In_Out items of the corresponding Global pragma
24169 -- looking for a state with a visible refinement.
24171 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
24172 Item_Elmt
:= First_Elmt
(In_Out_Items
);
24173 while Present
(Item_Elmt
) loop
24174 Item_Id
:= Node
(Item_Elmt
);
24176 -- Ensure that one of the three coverage variants is satisfied
24178 if Ekind
(Item_Id
) = E_Abstract_State
24179 and then Has_Non_Null_Refinement
(Item_Id
)
24181 Check_Constituent_Usage
(Item_Id
);
24184 Next_Elmt
(Item_Elmt
);
24187 end Check_In_Out_States
;
24189 ------------------------
24190 -- Check_Input_States --
24191 ------------------------
24193 procedure Check_Input_States
is
24194 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24195 -- Determine whether at least one constituent of state State_Id with
24196 -- visible refinement is used and has mode Input. Ensure that the
24197 -- remaining constituents do not have In_Out, Output or Proof_In
24200 -----------------------------
24201 -- Check_Constituent_Usage --
24202 -----------------------------
24204 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24205 Constit_Elmt
: Elmt_Id
;
24206 Constit_Id
: Entity_Id
;
24207 In_Seen
: Boolean := False;
24210 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
24211 while Present
(Constit_Elmt
) loop
24212 Constit_Id
:= Node
(Constit_Elmt
);
24214 -- At least one of the constituents appears as an Input
24216 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
24219 -- The constituent appears in the global refinement, but has
24220 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
24222 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
24223 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
24224 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
24226 Error_Msg_Name_1
:= Chars
(State_Id
);
24228 ("constituent & of state % must have mode Input in global "
24229 & "refinement", N
, Constit_Id
);
24232 Next_Elmt
(Constit_Elmt
);
24235 -- Not one of the constituents appeared as Input
24237 if not In_Seen
then
24239 ("global refinement of state & must include at least one "
24240 & "constituent of mode Input", N
, State_Id
);
24242 end Check_Constituent_Usage
;
24246 Item_Elmt
: Elmt_Id
;
24247 Item_Id
: Entity_Id
;
24249 -- Start of processing for Check_Input_States
24252 -- Do not perform this check in an instance because it was already
24253 -- performed successfully in the generic template.
24255 if Is_Generic_Instance
(Spec_Id
) then
24258 -- Inspect the Input items of the corresponding Global pragma looking
24259 -- for a state with a visible refinement.
24261 elsif Has_In_State
and then Present
(In_Items
) then
24262 Item_Elmt
:= First_Elmt
(In_Items
);
24263 while Present
(Item_Elmt
) loop
24264 Item_Id
:= Node
(Item_Elmt
);
24266 -- Ensure that at least one of the constituents is utilized and
24267 -- is of mode Input.
24269 if Ekind
(Item_Id
) = E_Abstract_State
24270 and then Has_Non_Null_Refinement
(Item_Id
)
24272 Check_Constituent_Usage
(Item_Id
);
24275 Next_Elmt
(Item_Elmt
);
24278 end Check_Input_States
;
24280 -------------------------
24281 -- Check_Output_States --
24282 -------------------------
24284 procedure Check_Output_States
is
24285 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24286 -- Determine whether all constituents of state State_Id with visible
24287 -- refinement are used and have mode Output. Emit an error if this is
24290 -----------------------------
24291 -- Check_Constituent_Usage --
24292 -----------------------------
24294 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24295 Constit_Elmt
: Elmt_Id
;
24296 Constit_Id
: Entity_Id
;
24297 Posted
: Boolean := False;
24300 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
24301 while Present
(Constit_Elmt
) loop
24302 Constit_Id
:= Node
(Constit_Elmt
);
24304 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
24307 -- The constituent appears in the global refinement, but has
24308 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
24310 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
24311 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
24312 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
24314 Error_Msg_Name_1
:= Chars
(State_Id
);
24316 ("constituent & of state % must have mode Output in "
24317 & "global refinement", N
, Constit_Id
);
24319 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24325 ("output state & must be replaced by all its "
24326 & "constituents in global refinement", N
, State_Id
);
24330 ("\constituent & is missing in output list",
24334 Next_Elmt
(Constit_Elmt
);
24336 end Check_Constituent_Usage
;
24340 Item_Elmt
: Elmt_Id
;
24341 Item_Id
: Entity_Id
;
24343 -- Start of processing for Check_Output_States
24346 -- Do not perform this check in an instance because it was already
24347 -- performed successfully in the generic template.
24349 if Is_Generic_Instance
(Spec_Id
) then
24352 -- Inspect the Output items of the corresponding Global pragma
24353 -- looking for a state with a visible refinement.
24355 elsif Has_Out_State
and then Present
(Out_Items
) then
24356 Item_Elmt
:= First_Elmt
(Out_Items
);
24357 while Present
(Item_Elmt
) loop
24358 Item_Id
:= Node
(Item_Elmt
);
24360 -- Ensure that all of the constituents are utilized and they
24361 -- have mode Output.
24363 if Ekind
(Item_Id
) = E_Abstract_State
24364 and then Has_Non_Null_Refinement
(Item_Id
)
24366 Check_Constituent_Usage
(Item_Id
);
24369 Next_Elmt
(Item_Elmt
);
24372 end Check_Output_States
;
24374 ---------------------------
24375 -- Check_Proof_In_States --
24376 ---------------------------
24378 procedure Check_Proof_In_States
is
24379 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24380 -- Determine whether at least one constituent of state State_Id with
24381 -- visible refinement is used and has mode Proof_In. Ensure that the
24382 -- remaining constituents do not have Input, In_Out or Output modes.
24384 -----------------------------
24385 -- Check_Constituent_Usage --
24386 -----------------------------
24388 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24389 Constit_Elmt
: Elmt_Id
;
24390 Constit_Id
: Entity_Id
;
24391 Proof_In_Seen
: Boolean := False;
24394 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
24395 while Present
(Constit_Elmt
) loop
24396 Constit_Id
:= Node
(Constit_Elmt
);
24398 -- At least one of the constituents appears as Proof_In
24400 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
24401 Proof_In_Seen
:= True;
24403 -- The constituent appears in the global refinement, but has
24404 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
24406 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
24407 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
24408 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
24410 Error_Msg_Name_1
:= Chars
(State_Id
);
24412 ("constituent & of state % must have mode Proof_In in "
24413 & "global refinement", N
, Constit_Id
);
24416 Next_Elmt
(Constit_Elmt
);
24419 -- Not one of the constituents appeared as Proof_In
24421 if not Proof_In_Seen
then
24423 ("global refinement of state & must include at least one "
24424 & "constituent of mode Proof_In", N
, State_Id
);
24426 end Check_Constituent_Usage
;
24430 Item_Elmt
: Elmt_Id
;
24431 Item_Id
: Entity_Id
;
24433 -- Start of processing for Check_Proof_In_States
24436 -- Do not perform this check in an instance because it was already
24437 -- performed successfully in the generic template.
24439 if Is_Generic_Instance
(Spec_Id
) then
24442 -- Inspect the Proof_In items of the corresponding Global pragma
24443 -- looking for a state with a visible refinement.
24445 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
24446 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
24447 while Present
(Item_Elmt
) loop
24448 Item_Id
:= Node
(Item_Elmt
);
24450 -- Ensure that at least one of the constituents is utilized and
24451 -- is of mode Proof_In
24453 if Ekind
(Item_Id
) = E_Abstract_State
24454 and then Has_Non_Null_Refinement
(Item_Id
)
24456 Check_Constituent_Usage
(Item_Id
);
24459 Next_Elmt
(Item_Elmt
);
24462 end Check_Proof_In_States
;
24464 -------------------------------
24465 -- Check_Refined_Global_List --
24466 -------------------------------
24468 procedure Check_Refined_Global_List
24470 Global_Mode
: Name_Id
:= Name_Input
)
24472 procedure Check_Refined_Global_Item
24474 Global_Mode
: Name_Id
);
24475 -- Verify the legality of a single global item declaration. Parameter
24476 -- Global_Mode denotes the current mode in effect.
24478 -------------------------------
24479 -- Check_Refined_Global_Item --
24480 -------------------------------
24482 procedure Check_Refined_Global_Item
24484 Global_Mode
: Name_Id
)
24486 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
24488 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
24489 -- Issue a common error message for all mode mismatches. Expect
24490 -- denotes the expected mode.
24492 -----------------------------
24493 -- Inconsistent_Mode_Error --
24494 -----------------------------
24496 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
24499 ("global item & has inconsistent modes", Item
, Item_Id
);
24501 Error_Msg_Name_1
:= Global_Mode
;
24502 Error_Msg_Name_2
:= Expect
;
24503 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
24504 end Inconsistent_Mode_Error
;
24506 -- Start of processing for Check_Refined_Global_Item
24509 -- When the state or object acts as a constituent of another
24510 -- state with a visible refinement, collect it for the state
24511 -- completeness checks performed later on.
24513 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
24514 and then Present
(Encapsulating_State
(Item_Id
))
24515 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
24517 if Global_Mode
= Name_Input
then
24518 Append_New_Elmt
(Item_Id
, In_Constits
);
24520 elsif Global_Mode
= Name_In_Out
then
24521 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
24523 elsif Global_Mode
= Name_Output
then
24524 Append_New_Elmt
(Item_Id
, Out_Constits
);
24526 elsif Global_Mode
= Name_Proof_In
then
24527 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
24530 -- When not a constituent, ensure that both occurrences of the
24531 -- item in pragmas Global and Refined_Global match.
24533 elsif Contains
(In_Items
, Item_Id
) then
24534 if Global_Mode
/= Name_Input
then
24535 Inconsistent_Mode_Error
(Name_Input
);
24538 elsif Contains
(In_Out_Items
, Item_Id
) then
24539 if Global_Mode
/= Name_In_Out
then
24540 Inconsistent_Mode_Error
(Name_In_Out
);
24543 elsif Contains
(Out_Items
, Item_Id
) then
24544 if Global_Mode
/= Name_Output
then
24545 Inconsistent_Mode_Error
(Name_Output
);
24548 elsif Contains
(Proof_In_Items
, Item_Id
) then
24551 -- The item does not appear in the corresponding Global pragma,
24552 -- it must be an extra (SPARK RM 7.2.4(3)).
24555 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
24557 end Check_Refined_Global_Item
;
24563 -- Start of processing for Check_Refined_Global_List
24566 -- Do not perform this check in an instance because it was already
24567 -- performed successfully in the generic template.
24569 if Is_Generic_Instance
(Spec_Id
) then
24572 elsif Nkind
(List
) = N_Null
then
24575 -- Single global item declaration
24577 elsif Nkind_In
(List
, N_Expanded_Name
,
24579 N_Selected_Component
)
24581 Check_Refined_Global_Item
(List
, Global_Mode
);
24583 -- Simple global list or moded global list declaration
24585 elsif Nkind
(List
) = N_Aggregate
then
24587 -- The declaration of a simple global list appear as a collection
24590 if Present
(Expressions
(List
)) then
24591 Item
:= First
(Expressions
(List
));
24592 while Present
(Item
) loop
24593 Check_Refined_Global_Item
(Item
, Global_Mode
);
24597 -- The declaration of a moded global list appears as a collection
24598 -- of component associations where individual choices denote
24601 elsif Present
(Component_Associations
(List
)) then
24602 Item
:= First
(Component_Associations
(List
));
24603 while Present
(Item
) loop
24604 Check_Refined_Global_List
24605 (List
=> Expression
(Item
),
24606 Global_Mode
=> Chars
(First
(Choices
(Item
))));
24614 raise Program_Error
;
24620 raise Program_Error
;
24622 end Check_Refined_Global_List
;
24624 --------------------------
24625 -- Collect_Global_Items --
24626 --------------------------
24628 procedure Collect_Global_Items
24630 Mode
: Name_Id
:= Name_Input
)
24632 procedure Collect_Global_Item
24634 Item_Mode
: Name_Id
);
24635 -- Add a single item to the appropriate list. Item_Mode denotes the
24636 -- current mode in effect.
24638 -------------------------
24639 -- Collect_Global_Item --
24640 -------------------------
24642 procedure Collect_Global_Item
24644 Item_Mode
: Name_Id
)
24646 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
24647 -- The above handles abstract views of variables and states built
24648 -- for limited with clauses.
24651 -- Signal that the global list contains at least one abstract
24652 -- state with a visible refinement. Note that the refinement may
24653 -- be null in which case there are no constituents.
24655 if Ekind
(Item_Id
) = E_Abstract_State
then
24656 if Has_Null_Refinement
(Item_Id
) then
24657 Has_Null_State
:= True;
24659 elsif Has_Non_Null_Refinement
(Item_Id
) then
24660 if Item_Mode
= Name_Input
then
24661 Has_In_State
:= True;
24662 elsif Item_Mode
= Name_In_Out
then
24663 Has_In_Out_State
:= True;
24664 elsif Item_Mode
= Name_Output
then
24665 Has_Out_State
:= True;
24666 elsif Item_Mode
= Name_Proof_In
then
24667 Has_Proof_In_State
:= True;
24672 -- Add the item to the proper list
24674 if Item_Mode
= Name_Input
then
24675 Append_New_Elmt
(Item_Id
, In_Items
);
24676 elsif Item_Mode
= Name_In_Out
then
24677 Append_New_Elmt
(Item_Id
, In_Out_Items
);
24678 elsif Item_Mode
= Name_Output
then
24679 Append_New_Elmt
(Item_Id
, Out_Items
);
24680 elsif Item_Mode
= Name_Proof_In
then
24681 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
24683 end Collect_Global_Item
;
24689 -- Start of processing for Collect_Global_Items
24692 if Nkind
(List
) = N_Null
then
24695 -- Single global item declaration
24697 elsif Nkind_In
(List
, N_Expanded_Name
,
24699 N_Selected_Component
)
24701 Collect_Global_Item
(List
, Mode
);
24703 -- Single global list or moded global list declaration
24705 elsif Nkind
(List
) = N_Aggregate
then
24707 -- The declaration of a simple global list appear as a collection
24710 if Present
(Expressions
(List
)) then
24711 Item
:= First
(Expressions
(List
));
24712 while Present
(Item
) loop
24713 Collect_Global_Item
(Item
, Mode
);
24717 -- The declaration of a moded global list appears as a collection
24718 -- of component associations where individual choices denote mode.
24720 elsif Present
(Component_Associations
(List
)) then
24721 Item
:= First
(Component_Associations
(List
));
24722 while Present
(Item
) loop
24723 Collect_Global_Items
24724 (List
=> Expression
(Item
),
24725 Mode
=> Chars
(First
(Choices
(Item
))));
24733 raise Program_Error
;
24736 -- To accomodate partial decoration of disabled SPARK features, this
24737 -- routine may be called with illegal input. If this is the case, do
24738 -- not raise Program_Error.
24743 end Collect_Global_Items
;
24745 -------------------------
24746 -- Present_Then_Remove --
24747 -------------------------
24749 function Present_Then_Remove
24751 Item
: Entity_Id
) return Boolean
24756 if Present
(List
) then
24757 Elmt
:= First_Elmt
(List
);
24758 while Present
(Elmt
) loop
24759 if Node
(Elmt
) = Item
then
24760 Remove_Elmt
(List
, Elmt
);
24769 end Present_Then_Remove
;
24771 -------------------------------
24772 -- Report_Extra_Constituents --
24773 -------------------------------
24775 procedure Report_Extra_Constituents
is
24776 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
24777 -- Emit an error for every element of List
24779 ---------------------------------------
24780 -- Report_Extra_Constituents_In_List --
24781 ---------------------------------------
24783 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
24784 Constit_Elmt
: Elmt_Id
;
24787 if Present
(List
) then
24788 Constit_Elmt
:= First_Elmt
(List
);
24789 while Present
(Constit_Elmt
) loop
24790 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
24791 Next_Elmt
(Constit_Elmt
);
24794 end Report_Extra_Constituents_In_List
;
24796 -- Start of processing for Report_Extra_Constituents
24799 -- Do not perform this check in an instance because it was already
24800 -- performed successfully in the generic template.
24802 if Is_Generic_Instance
(Spec_Id
) then
24806 Report_Extra_Constituents_In_List
(In_Constits
);
24807 Report_Extra_Constituents_In_List
(In_Out_Constits
);
24808 Report_Extra_Constituents_In_List
(Out_Constits
);
24809 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
24811 end Report_Extra_Constituents
;
24815 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
24816 Errors
: constant Nat
:= Serious_Errors_Detected
;
24819 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
24822 -- Do not analyze the pragma multiple times
24824 if Is_Analyzed_Pragma
(N
) then
24828 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
24830 -- Use the anonymous object as the proper spec when Refined_Global
24831 -- applies to the body of a single task type. The object carries the
24832 -- proper Chars as well as all non-refined versions of pragmas.
24834 if Is_Single_Concurrent_Type
(Spec_Id
) then
24835 Spec_Id
:= Anonymous_Object
(Spec_Id
);
24838 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
24839 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
24841 -- The subprogram declaration lacks pragma Global. This renders
24842 -- Refined_Global useless as there is nothing to refine.
24844 if No
(Global
) then
24846 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
24847 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
24851 -- Extract all relevant items from the corresponding Global pragma
24853 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
24855 -- Package and subprogram bodies are instantiated individually in
24856 -- a separate compiler pass. Due to this mode of instantiation, the
24857 -- refinement of a state may no longer be visible when a subprogram
24858 -- body contract is instantiated. Since the generic template is legal,
24859 -- do not perform this check in the instance to circumvent this oddity.
24861 if Is_Generic_Instance
(Spec_Id
) then
24864 -- Non-instance case
24867 -- The corresponding Global pragma must mention at least one state
24868 -- witha visible refinement at the point Refined_Global is processed.
24869 -- States with null refinements need Refined_Global pragma
24870 -- (SPARK RM 7.2.4(2)).
24872 if not Has_In_State
24873 and then not Has_In_Out_State
24874 and then not Has_Out_State
24875 and then not Has_Proof_In_State
24876 and then not Has_Null_State
24879 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
24880 & "depend on abstract state with visible refinement"),
24884 -- The global refinement of inputs and outputs cannot be null when
24885 -- the corresponding Global pragma contains at least one item except
24886 -- in the case where we have states with null refinements.
24888 elsif Nkind
(Items
) = N_Null
24890 (Present
(In_Items
)
24891 or else Present
(In_Out_Items
)
24892 or else Present
(Out_Items
)
24893 or else Present
(Proof_In_Items
))
24894 and then not Has_Null_State
24897 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
24898 & "global items"), N
, Spec_Id
);
24903 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
24904 -- This ensures that the categorization of all refined global items is
24905 -- consistent with their role.
24907 Analyze_Global_In_Decl_Part
(N
);
24909 -- Perform all refinement checks with respect to completeness and mode
24912 if Serious_Errors_Detected
= Errors
then
24913 Check_Refined_Global_List
(Items
);
24916 -- For Input states with visible refinement, at least one constituent
24917 -- must be used as an Input in the global refinement.
24919 if Serious_Errors_Detected
= Errors
then
24920 Check_Input_States
;
24923 -- Verify all possible completion variants for In_Out states with
24924 -- visible refinement.
24926 if Serious_Errors_Detected
= Errors
then
24927 Check_In_Out_States
;
24930 -- For Output states with visible refinement, all constituents must be
24931 -- used as Outputs in the global refinement.
24933 if Serious_Errors_Detected
= Errors
then
24934 Check_Output_States
;
24937 -- For Proof_In states with visible refinement, at least one constituent
24938 -- must be used as Proof_In in the global refinement.
24940 if Serious_Errors_Detected
= Errors
then
24941 Check_Proof_In_States
;
24944 -- Emit errors for all constituents that belong to other states with
24945 -- visible refinement that do not appear in Global.
24947 if Serious_Errors_Detected
= Errors
then
24948 Report_Extra_Constituents
;
24952 Set_Is_Analyzed_Pragma
(N
);
24953 end Analyze_Refined_Global_In_Decl_Part
;
24955 ----------------------------------------
24956 -- Analyze_Refined_State_In_Decl_Part --
24957 ----------------------------------------
24959 procedure Analyze_Refined_State_In_Decl_Part
24961 Freeze_Id
: Entity_Id
:= Empty
)
24963 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
24964 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
24965 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
24967 Available_States
: Elist_Id
:= No_Elist
;
24968 -- A list of all abstract states defined in the package declaration that
24969 -- are available for refinement. The list is used to report unrefined
24972 Body_States
: Elist_Id
:= No_Elist
;
24973 -- A list of all hidden states that appear in the body of the related
24974 -- package. The list is used to report unused hidden states.
24976 Constituents_Seen
: Elist_Id
:= No_Elist
;
24977 -- A list that contains all constituents processed so far. The list is
24978 -- used to detect multiple uses of the same constituent.
24980 Freeze_Posted
: Boolean := False;
24981 -- A flag that controls the output of a freezing-related error (see use
24984 Refined_States_Seen
: Elist_Id
:= No_Elist
;
24985 -- A list that contains all refined states processed so far. The list is
24986 -- used to detect duplicate refinements.
24988 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
24989 -- Perform full analysis of a single refinement clause
24991 procedure Report_Unrefined_States
(States
: Elist_Id
);
24992 -- Emit errors for all unrefined abstract states found in list States
24994 -------------------------------
24995 -- Analyze_Refinement_Clause --
24996 -------------------------------
24998 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
24999 AR_Constit
: Entity_Id
:= Empty
;
25000 AW_Constit
: Entity_Id
:= Empty
;
25001 ER_Constit
: Entity_Id
:= Empty
;
25002 EW_Constit
: Entity_Id
:= Empty
;
25003 -- The entities of external constituents that contain one of the
25004 -- following enabled properties: Async_Readers, Async_Writers,
25005 -- Effective_Reads and Effective_Writes.
25007 External_Constit_Seen
: Boolean := False;
25008 -- Flag used to mark when at least one external constituent is part
25009 -- of the state refinement.
25011 Non_Null_Seen
: Boolean := False;
25012 Null_Seen
: Boolean := False;
25013 -- Flags used to detect multiple uses of null in a single clause or a
25014 -- mixture of null and non-null constituents.
25016 Part_Of_Constits
: Elist_Id
:= No_Elist
;
25017 -- A list of all candidate constituents subject to indicator Part_Of
25018 -- where the encapsulating state is the current state.
25021 State_Id
: Entity_Id
;
25022 -- The current state being refined
25024 procedure Analyze_Constituent
(Constit
: Node_Id
);
25025 -- Perform full analysis of a single constituent
25027 procedure Check_External_Property
25028 (Prop_Nam
: Name_Id
;
25030 Constit
: Entity_Id
);
25031 -- Determine whether a property denoted by name Prop_Nam is present
25032 -- in both the refined state and constituent Constit. Flag Enabled
25033 -- should be set when the property applies to the refined state. If
25034 -- this is not the case, emit an error message.
25036 procedure Match_State
;
25037 -- Determine whether the state being refined appears in list
25038 -- Available_States. Emit an error when attempting to re-refine the
25039 -- state or when the state is not defined in the package declaration,
25040 -- otherwise remove the state from Available_States.
25042 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
25043 -- Emit errors for all unused Part_Of constituents in list Constits
25045 -------------------------
25046 -- Analyze_Constituent --
25047 -------------------------
25049 procedure Analyze_Constituent
(Constit
: Node_Id
) is
25050 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
25051 -- Determine whether constituent Constit denoted by its entity
25052 -- Constit_Id appears in Body_States. Emit an error when the
25053 -- constituent is not a valid hidden state of the related package
25054 -- or when it is used more than once. Otherwise remove the
25055 -- constituent from Body_States.
25057 -----------------------
25058 -- Match_Constituent --
25059 -----------------------
25061 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
25062 procedure Collect_Constituent
;
25063 -- Verify the legality of constituent Constit_Id and add it to
25064 -- the refinements of State_Id.
25066 -------------------------
25067 -- Collect_Constituent --
25068 -------------------------
25070 procedure Collect_Constituent
is
25072 if Is_Ghost_Entity
(State_Id
) then
25073 if Is_Ghost_Entity
(Constit_Id
) then
25075 -- The Ghost policy in effect at the point of abstract
25076 -- state declaration and constituent must match
25077 -- (SPARK RM 6.9(16)).
25079 if Is_Checked_Ghost_Entity
(State_Id
)
25080 and then Is_Ignored_Ghost_Entity
(Constit_Id
)
25082 Error_Msg_Sloc
:= Sloc
(Constit
);
25085 ("incompatible ghost policies in effect", State
);
25087 ("\abstract state & declared with ghost policy "
25088 & "Check", State
, State_Id
);
25090 ("\constituent & declared # with ghost policy "
25091 & "Ignore", State
, Constit_Id
);
25093 elsif Is_Ignored_Ghost_Entity
(State_Id
)
25094 and then Is_Checked_Ghost_Entity
(Constit_Id
)
25096 Error_Msg_Sloc
:= Sloc
(Constit
);
25099 ("incompatible ghost policies in effect", State
);
25101 ("\abstract state & declared with ghost policy "
25102 & "Ignore", State
, State_Id
);
25104 ("\constituent & declared # with ghost policy "
25105 & "Check", State
, Constit_Id
);
25108 -- A constituent of a Ghost abstract state must be a
25109 -- Ghost entity (SPARK RM 7.2.2(12)).
25113 ("constituent of ghost state & must be ghost",
25114 Constit
, State_Id
);
25118 -- A synchronized state must be refined by a synchronized
25119 -- object or another synchronized state (SPARK RM 9.6).
25121 if Is_Synchronized_State
(State_Id
)
25122 and then not Is_Synchronized_Object
(Constit_Id
)
25123 and then not Is_Synchronized_State
(Constit_Id
)
25126 ("constituent of synchronized state & must be "
25127 & "synchronized", Constit
, State_Id
);
25130 -- Add the constituent to the list of processed items to aid
25131 -- with the detection of duplicates.
25133 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
25135 -- Collect the constituent in the list of refinement items
25136 -- and establish a relation between the refined state and
25139 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
25140 Set_Encapsulating_State
(Constit_Id
, State_Id
);
25142 -- The state has at least one legal constituent, mark the
25143 -- start of the refinement region. The region ends when the
25144 -- body declarations end (see routine Analyze_Declarations).
25146 Set_Has_Visible_Refinement
(State_Id
);
25148 -- When the constituent is external, save its relevant
25149 -- property for further checks.
25151 if Async_Readers_Enabled
(Constit_Id
) then
25152 AR_Constit
:= Constit_Id
;
25153 External_Constit_Seen
:= True;
25156 if Async_Writers_Enabled
(Constit_Id
) then
25157 AW_Constit
:= Constit_Id
;
25158 External_Constit_Seen
:= True;
25161 if Effective_Reads_Enabled
(Constit_Id
) then
25162 ER_Constit
:= Constit_Id
;
25163 External_Constit_Seen
:= True;
25166 if Effective_Writes_Enabled
(Constit_Id
) then
25167 EW_Constit
:= Constit_Id
;
25168 External_Constit_Seen
:= True;
25170 end Collect_Constituent
;
25174 State_Elmt
: Elmt_Id
;
25176 -- Start of processing for Match_Constituent
25179 -- Detect a duplicate use of a constituent
25181 if Contains
(Constituents_Seen
, Constit_Id
) then
25183 ("duplicate use of constituent &", Constit
, Constit_Id
);
25187 -- The constituent is subject to a Part_Of indicator
25189 if Present
(Encapsulating_State
(Constit_Id
)) then
25190 if Encapsulating_State
(Constit_Id
) = State_Id
then
25191 Remove
(Part_Of_Constits
, Constit_Id
);
25192 Collect_Constituent
;
25194 -- The constituent is part of another state and is used
25195 -- incorrectly in the refinement of the current state.
25198 Error_Msg_Name_1
:= Chars
(State_Id
);
25200 ("& cannot act as constituent of state %",
25201 Constit
, Constit_Id
);
25203 ("\Part_Of indicator specifies encapsulator &",
25204 Constit
, Encapsulating_State
(Constit_Id
));
25207 -- The only other source of legal constituents is the body
25208 -- state space of the related package.
25211 if Present
(Body_States
) then
25212 State_Elmt
:= First_Elmt
(Body_States
);
25213 while Present
(State_Elmt
) loop
25215 -- Consume a valid constituent to signal that it has
25216 -- been encountered.
25218 if Node
(State_Elmt
) = Constit_Id
then
25219 Remove_Elmt
(Body_States
, State_Elmt
);
25220 Collect_Constituent
;
25224 Next_Elmt
(State_Elmt
);
25228 -- Constants are part of the hidden state of a package, but
25229 -- the compiler cannot determine whether they have variable
25230 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
25231 -- hidden state. Accept the constant quietly even if it is
25232 -- a visible state or lacks a Part_Of indicator.
25234 if Ekind
(Constit_Id
) = E_Constant
then
25237 -- If we get here, then the constituent is not a hidden
25238 -- state of the related package and may not be used in a
25239 -- refinement (SPARK RM 7.2.2(9)).
25242 Error_Msg_Name_1
:= Chars
(Spec_Id
);
25244 ("cannot use & in refinement, constituent is not a "
25245 & "hidden state of package %", Constit
, Constit_Id
);
25248 end Match_Constituent
;
25252 Constit_Id
: Entity_Id
;
25254 -- Start of processing for Analyze_Constituent
25257 -- Detect multiple uses of null in a single refinement clause or a
25258 -- mixture of null and non-null constituents.
25260 if Nkind
(Constit
) = N_Null
then
25263 ("multiple null constituents not allowed", Constit
);
25265 elsif Non_Null_Seen
then
25267 ("cannot mix null and non-null constituents", Constit
);
25272 -- Collect the constituent in the list of refinement items
25274 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
25276 -- The state has at least one legal constituent, mark the
25277 -- start of the refinement region. The region ends when the
25278 -- body declarations end (see Analyze_Declarations).
25280 Set_Has_Visible_Refinement
(State_Id
);
25283 -- Non-null constituents
25286 Non_Null_Seen
:= True;
25290 ("cannot mix null and non-null constituents", Constit
);
25294 Resolve_State
(Constit
);
25296 -- Ensure that the constituent denotes a valid state or a
25297 -- whole object (SPARK RM 7.2.2(5)).
25299 if Is_Entity_Name
(Constit
) then
25300 Constit_Id
:= Entity_Of
(Constit
);
25302 -- When a constituent is declared after a subprogram body
25303 -- that caused "freezing" of the related contract where
25304 -- pragma Refined_State resides, the constituent appears
25305 -- undefined and carries Any_Id as its entity.
25307 -- package body Pack
25308 -- with Refined_State => (State => Constit)
25311 -- with Refined_Global => (Input => Constit)
25319 if Constit_Id
= Any_Id
then
25320 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
25322 -- Emit a specialized info message when the contract of
25323 -- the related package body was "frozen" by another body.
25324 -- Note that it is not possible to precisely identify why
25325 -- the constituent is undefined because it is not visible
25326 -- when pragma Refined_State is analyzed. This message is
25327 -- a reasonable approximation.
25329 if Present
(Freeze_Id
) and then not Freeze_Posted
then
25330 Freeze_Posted
:= True;
25332 Error_Msg_Name_1
:= Chars
(Body_Id
);
25333 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
25335 ("body & declared # freezes the contract of %",
25338 ("\all constituents must be declared before body #",
25342 -- The constituent is a valid state or object
25344 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
25348 Match_Constituent
(Constit_Id
);
25350 -- Otherwise the constituent is illegal
25354 ("constituent & must denote object or state",
25355 Constit
, Constit_Id
);
25358 -- The constituent is illegal
25361 SPARK_Msg_N
("malformed constituent", Constit
);
25364 end Analyze_Constituent
;
25366 -----------------------------
25367 -- Check_External_Property --
25368 -----------------------------
25370 procedure Check_External_Property
25371 (Prop_Nam
: Name_Id
;
25373 Constit
: Entity_Id
)
25376 Error_Msg_Name_1
:= Prop_Nam
;
25378 -- The property is enabled in the related Abstract_State pragma
25379 -- that defines the state (SPARK RM 7.2.8(3)).
25382 if No
(Constit
) then
25384 ("external state & requires at least one constituent with "
25385 & "property %", State
, State_Id
);
25388 -- The property is missing in the declaration of the state, but
25389 -- a constituent is introducing it in the state refinement
25390 -- (SPARK RM 7.2.8(3)).
25392 elsif Present
(Constit
) then
25393 Error_Msg_Name_2
:= Chars
(Constit
);
25395 ("external state & lacks property % set by constituent %",
25398 end Check_External_Property
;
25404 procedure Match_State
is
25405 State_Elmt
: Elmt_Id
;
25408 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
25410 if Contains
(Refined_States_Seen
, State_Id
) then
25412 ("duplicate refinement of state &", State
, State_Id
);
25416 -- Inspect the abstract states defined in the package declaration
25417 -- looking for a match.
25419 State_Elmt
:= First_Elmt
(Available_States
);
25420 while Present
(State_Elmt
) loop
25422 -- A valid abstract state is being refined in the body. Add
25423 -- the state to the list of processed refined states to aid
25424 -- with the detection of duplicate refinements. Remove the
25425 -- state from Available_States to signal that it has already
25428 if Node
(State_Elmt
) = State_Id
then
25429 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
25430 Remove_Elmt
(Available_States
, State_Elmt
);
25434 Next_Elmt
(State_Elmt
);
25437 -- If we get here, we are refining a state that is not defined in
25438 -- the package declaration.
25440 Error_Msg_Name_1
:= Chars
(Spec_Id
);
25442 ("cannot refine state, & is not defined in package %",
25446 --------------------------------
25447 -- Report_Unused_Constituents --
25448 --------------------------------
25450 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
25451 Constit_Elmt
: Elmt_Id
;
25452 Constit_Id
: Entity_Id
;
25453 Posted
: Boolean := False;
25456 if Present
(Constits
) then
25457 Constit_Elmt
:= First_Elmt
(Constits
);
25458 while Present
(Constit_Elmt
) loop
25459 Constit_Id
:= Node
(Constit_Elmt
);
25461 -- Generate an error message of the form:
25463 -- state ... has unused Part_Of constituents
25464 -- abstract state ... defined at ...
25465 -- constant ... defined at ...
25466 -- variable ... defined at ...
25471 ("state & has unused Part_Of constituents",
25475 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
25477 if Ekind
(Constit_Id
) = E_Abstract_State
then
25479 ("\abstract state & defined #", State
, Constit_Id
);
25481 elsif Ekind
(Constit_Id
) = E_Constant
then
25483 ("\constant & defined #", State
, Constit_Id
);
25486 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
25487 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
25490 Next_Elmt
(Constit_Elmt
);
25493 end Report_Unused_Constituents
;
25495 -- Local declarations
25497 Body_Ref
: Node_Id
;
25498 Body_Ref_Elmt
: Elmt_Id
;
25500 Extra_State
: Node_Id
;
25502 -- Start of processing for Analyze_Refinement_Clause
25505 -- A refinement clause appears as a component association where the
25506 -- sole choice is the state and the expressions are the constituents.
25507 -- This is a syntax error, always report.
25509 if Nkind
(Clause
) /= N_Component_Association
then
25510 Error_Msg_N
("malformed state refinement clause", Clause
);
25514 -- Analyze the state name of a refinement clause
25516 State
:= First
(Choices
(Clause
));
25519 Resolve_State
(State
);
25521 -- Ensure that the state name denotes a valid abstract state that is
25522 -- defined in the spec of the related package.
25524 if Is_Entity_Name
(State
) then
25525 State_Id
:= Entity_Of
(State
);
25527 -- When the abstract state is undefined, it appears as Any_Id. Do
25528 -- not continue with the analysis of the clause.
25530 if State_Id
= Any_Id
then
25533 -- Catch any attempts to re-refine a state or refine a state that
25534 -- is not defined in the package declaration.
25536 elsif Ekind
(State_Id
) = E_Abstract_State
then
25540 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
25544 -- References to a state with visible refinement are illegal.
25545 -- When nested packages are involved, detecting such references is
25546 -- tricky because pragma Refined_State is analyzed later than the
25547 -- offending pragma Depends or Global. References that occur in
25548 -- such nested context are stored in a list. Emit errors for all
25549 -- references found in Body_References (SPARK RM 6.1.4(8)).
25551 if Present
(Body_References
(State_Id
)) then
25552 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
25553 while Present
(Body_Ref_Elmt
) loop
25554 Body_Ref
:= Node
(Body_Ref_Elmt
);
25556 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
25557 Error_Msg_Sloc
:= Sloc
(State
);
25558 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
25560 Next_Elmt
(Body_Ref_Elmt
);
25564 -- The state name is illegal. This is a syntax error, always report.
25567 Error_Msg_N
("malformed state name in refinement clause", State
);
25571 -- A refinement clause may only refine one state at a time
25573 Extra_State
:= Next
(State
);
25575 if Present
(Extra_State
) then
25577 ("refinement clause cannot cover multiple states", Extra_State
);
25580 -- Replicate the Part_Of constituents of the refined state because
25581 -- the algorithm will consume items.
25583 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
25585 -- Analyze all constituents of the refinement. Multiple constituents
25586 -- appear as an aggregate.
25588 Constit
:= Expression
(Clause
);
25590 if Nkind
(Constit
) = N_Aggregate
then
25591 if Present
(Component_Associations
(Constit
)) then
25593 ("constituents of refinement clause must appear in "
25594 & "positional form", Constit
);
25596 else pragma Assert
(Present
(Expressions
(Constit
)));
25597 Constit
:= First
(Expressions
(Constit
));
25598 while Present
(Constit
) loop
25599 Analyze_Constituent
(Constit
);
25604 -- Various forms of a single constituent. Note that these may include
25605 -- malformed constituents.
25608 Analyze_Constituent
(Constit
);
25611 -- A refined external state is subject to special rules with respect
25612 -- to its properties and constituents.
25614 if Is_External_State
(State_Id
) then
25616 -- The set of properties that all external constituents yield must
25617 -- match that of the refined state. There are two cases to detect:
25618 -- the refined state lacks a property or has an extra property.
25620 if External_Constit_Seen
then
25621 Check_External_Property
25622 (Prop_Nam
=> Name_Async_Readers
,
25623 Enabled
=> Async_Readers_Enabled
(State_Id
),
25624 Constit
=> AR_Constit
);
25626 Check_External_Property
25627 (Prop_Nam
=> Name_Async_Writers
,
25628 Enabled
=> Async_Writers_Enabled
(State_Id
),
25629 Constit
=> AW_Constit
);
25631 Check_External_Property
25632 (Prop_Nam
=> Name_Effective_Reads
,
25633 Enabled
=> Effective_Reads_Enabled
(State_Id
),
25634 Constit
=> ER_Constit
);
25636 Check_External_Property
25637 (Prop_Nam
=> Name_Effective_Writes
,
25638 Enabled
=> Effective_Writes_Enabled
(State_Id
),
25639 Constit
=> EW_Constit
);
25641 -- An external state may be refined to null (SPARK RM 7.2.8(2))
25643 elsif Null_Seen
then
25646 -- The external state has constituents, but none of them are
25647 -- external (SPARK RM 7.2.8(2)).
25651 ("external state & requires at least one external "
25652 & "constituent or null refinement", State
, State_Id
);
25655 -- When a refined state is not external, it should not have external
25656 -- constituents (SPARK RM 7.2.8(1)).
25658 elsif External_Constit_Seen
then
25660 ("non-external state & cannot contain external constituents in "
25661 & "refinement", State
, State_Id
);
25664 -- Ensure that all Part_Of candidate constituents have been mentioned
25665 -- in the refinement clause.
25667 Report_Unused_Constituents
(Part_Of_Constits
);
25668 end Analyze_Refinement_Clause
;
25670 -----------------------------
25671 -- Report_Unrefined_States --
25672 -----------------------------
25674 procedure Report_Unrefined_States
(States
: Elist_Id
) is
25675 State_Elmt
: Elmt_Id
;
25678 if Present
(States
) then
25679 State_Elmt
:= First_Elmt
(States
);
25680 while Present
(State_Elmt
) loop
25682 ("abstract state & must be refined", Node
(State_Elmt
));
25684 Next_Elmt
(State_Elmt
);
25687 end Report_Unrefined_States
;
25689 -- Local declarations
25691 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
25694 -- Start of processing for Analyze_Refined_State_In_Decl_Part
25697 -- Do not analyze the pragma multiple times
25699 if Is_Analyzed_Pragma
(N
) then
25703 -- Replicate the abstract states declared by the package because the
25704 -- matching algorithm will consume states.
25706 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
25708 -- Gather all abstract states and objects declared in the visible
25709 -- state space of the package body. These items must be utilized as
25710 -- constituents in a state refinement.
25712 Body_States
:= Collect_Body_States
(Body_Id
);
25714 -- Multiple non-null state refinements appear as an aggregate
25716 if Nkind
(Clauses
) = N_Aggregate
then
25717 if Present
(Expressions
(Clauses
)) then
25719 ("state refinements must appear as component associations",
25722 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
25723 Clause
:= First
(Component_Associations
(Clauses
));
25724 while Present
(Clause
) loop
25725 Analyze_Refinement_Clause
(Clause
);
25730 -- Various forms of a single state refinement. Note that these may
25731 -- include malformed refinements.
25734 Analyze_Refinement_Clause
(Clauses
);
25737 -- List all abstract states that were left unrefined
25739 Report_Unrefined_States
(Available_States
);
25741 -- Ensure that all abstract states and objects declared in the body
25742 -- state space of the related package are utilized as constituents.
25744 Report_Unused_Body_States
(Body_Id
, Body_States
);
25746 Set_Is_Analyzed_Pragma
(N
);
25747 end Analyze_Refined_State_In_Decl_Part
;
25749 ------------------------------------
25750 -- Analyze_Test_Case_In_Decl_Part --
25751 ------------------------------------
25753 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
25754 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
25755 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
25757 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
25758 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
25759 -- denoted by Arg_Nam.
25761 ------------------------------
25762 -- Preanalyze_Test_Case_Arg --
25763 ------------------------------
25765 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
25769 -- Preanalyze the original aspect argument for ASIS or for a generic
25770 -- subprogram to properly capture global references.
25772 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
25776 Arg_Nam
=> Arg_Nam
,
25777 From_Aspect
=> True);
25779 if Present
(Arg
) then
25780 Preanalyze_Assert_Expression
25781 (Expression
(Arg
), Standard_Boolean
);
25785 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
25787 if Present
(Arg
) then
25788 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
25790 end Preanalyze_Test_Case_Arg
;
25794 Restore_Scope
: Boolean := False;
25796 -- Start of processing for Analyze_Test_Case_In_Decl_Part
25799 -- Do not analyze the pragma multiple times
25801 if Is_Analyzed_Pragma
(N
) then
25805 -- Ensure that the formal parameters are visible when analyzing all
25806 -- clauses. This falls out of the general rule of aspects pertaining
25807 -- to subprogram declarations.
25809 if not In_Open_Scopes
(Spec_Id
) then
25810 Restore_Scope
:= True;
25811 Push_Scope
(Spec_Id
);
25813 if Is_Generic_Subprogram
(Spec_Id
) then
25814 Install_Generic_Formals
(Spec_Id
);
25816 Install_Formals
(Spec_Id
);
25820 Preanalyze_Test_Case_Arg
(Name_Requires
);
25821 Preanalyze_Test_Case_Arg
(Name_Ensures
);
25823 if Restore_Scope
then
25827 -- Currently it is not possible to inline pre/postconditions on a
25828 -- subprogram subject to pragma Inline_Always.
25830 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
25832 Set_Is_Analyzed_Pragma
(N
);
25833 end Analyze_Test_Case_In_Decl_Part
;
25839 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
25844 if Present
(List
) then
25845 Elmt
:= First_Elmt
(List
);
25846 while Present
(Elmt
) loop
25847 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
25850 Id
:= Entity_Of
(Node
(Elmt
));
25853 if Id
= Item_Id
then
25864 -----------------------------
25865 -- Check_Applicable_Policy --
25866 -----------------------------
25868 procedure Check_Applicable_Policy
(N
: Node_Id
) is
25872 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
25875 -- No effect if not valid assertion kind name
25877 if not Is_Valid_Assertion_Kind
(Ename
) then
25881 -- Loop through entries in check policy list
25883 PP
:= Opt
.Check_Policy_List
;
25884 while Present
(PP
) loop
25886 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
25887 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
25891 or else Pnm
= Name_Assertion
25892 or else (Pnm
= Name_Statement_Assertions
25893 and then Nam_In
(Ename
, Name_Assert
,
25894 Name_Assert_And_Cut
,
25896 Name_Loop_Invariant
,
25897 Name_Loop_Variant
))
25899 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
25902 when Name_Off | Name_Ignore
=>
25903 Set_Is_Ignored
(N
, True);
25904 Set_Is_Checked
(N
, False);
25906 when Name_On | Name_Check
=>
25907 Set_Is_Checked
(N
, True);
25908 Set_Is_Ignored
(N
, False);
25910 when Name_Disable
=>
25911 Set_Is_Ignored
(N
, True);
25912 Set_Is_Checked
(N
, False);
25913 Set_Is_Disabled
(N
, True);
25915 -- That should be exhaustive, the null here is a defence
25916 -- against a malformed tree from previous errors.
25925 PP
:= Next_Pragma
(PP
);
25929 -- If there are no specific entries that matched, then we let the
25930 -- setting of assertions govern. Note that this provides the needed
25931 -- compatibility with the RM for the cases of assertion, invariant,
25932 -- precondition, predicate, and postcondition.
25934 if Assertions_Enabled
then
25935 Set_Is_Checked
(N
, True);
25936 Set_Is_Ignored
(N
, False);
25938 Set_Is_Checked
(N
, False);
25939 Set_Is_Ignored
(N
, True);
25941 end Check_Applicable_Policy
;
25943 -------------------------------
25944 -- Check_External_Properties --
25945 -------------------------------
25947 procedure Check_External_Properties
25955 -- All properties enabled
25957 if AR
and AW
and ER
and EW
then
25960 -- Async_Readers + Effective_Writes
25961 -- Async_Readers + Async_Writers + Effective_Writes
25963 elsif AR
and EW
and not ER
then
25966 -- Async_Writers + Effective_Reads
25967 -- Async_Readers + Async_Writers + Effective_Reads
25969 elsif AW
and ER
and not EW
then
25972 -- Async_Readers + Async_Writers
25974 elsif AR
and AW
and not ER
and not EW
then
25979 elsif AR
and not AW
and not ER
and not EW
then
25984 elsif AW
and not AR
and not ER
and not EW
then
25989 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
25992 end Check_External_Properties
;
25998 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
26002 -- Loop through entries in check policy list
26004 PP
:= Opt
.Check_Policy_List
;
26005 while Present
(PP
) loop
26007 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
26008 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
26012 or else (Pnm
= Name_Assertion
26013 and then Is_Valid_Assertion_Kind
(Nam
))
26014 or else (Pnm
= Name_Statement_Assertions
26015 and then Nam_In
(Nam
, Name_Assert
,
26016 Name_Assert_And_Cut
,
26018 Name_Loop_Invariant
,
26019 Name_Loop_Variant
))
26021 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
26022 when Name_On | Name_Check
=>
26024 when Name_Off | Name_Ignore
=>
26025 return Name_Ignore
;
26026 when Name_Disable
=>
26027 return Name_Disable
;
26029 raise Program_Error
;
26033 PP
:= Next_Pragma
(PP
);
26038 -- If there are no specific entries that matched, then we let the
26039 -- setting of assertions govern. Note that this provides the needed
26040 -- compatibility with the RM for the cases of assertion, invariant,
26041 -- precondition, predicate, and postcondition.
26043 if Assertions_Enabled
then
26046 return Name_Ignore
;
26050 ---------------------------
26051 -- Check_Missing_Part_Of --
26052 ---------------------------
26054 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
26055 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
26056 -- Determine whether a package denoted by Pack_Id declares at least one
26059 -----------------------
26060 -- Has_Visible_State --
26061 -----------------------
26063 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
26064 Item_Id
: Entity_Id
;
26067 -- Traverse the entity chain of the package trying to find at least
26068 -- one visible abstract state, variable or a package [instantiation]
26069 -- that declares a visible state.
26071 Item_Id
:= First_Entity
(Pack_Id
);
26072 while Present
(Item_Id
)
26073 and then not In_Private_Part
(Item_Id
)
26075 -- Do not consider internally generated items
26077 if not Comes_From_Source
(Item_Id
) then
26080 -- A visible state has been found
26082 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
26085 -- Recursively peek into nested packages and instantiations
26087 elsif Ekind
(Item_Id
) = E_Package
26088 and then Has_Visible_State
(Item_Id
)
26093 Next_Entity
(Item_Id
);
26097 end Has_Visible_State
;
26101 Pack_Id
: Entity_Id
;
26102 Placement
: State_Space_Kind
;
26104 -- Start of processing for Check_Missing_Part_Of
26107 -- Do not consider abstract states, variables or package instantiations
26108 -- coming from an instance as those always inherit the Part_Of indicator
26109 -- of the instance itself.
26111 if In_Instance
then
26114 -- Do not consider internally generated entities as these can never
26115 -- have a Part_Of indicator.
26117 elsif not Comes_From_Source
(Item_Id
) then
26120 -- Perform these checks only when SPARK_Mode is enabled as they will
26121 -- interfere with standard Ada rules and produce false positives.
26123 elsif SPARK_Mode
/= On
then
26126 -- Do not consider constants, because the compiler cannot accurately
26127 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
26128 -- act as a hidden state of a package.
26130 elsif Ekind
(Item_Id
) = E_Constant
then
26134 -- Find where the abstract state, variable or package instantiation
26135 -- lives with respect to the state space.
26137 Find_Placement_In_State_Space
26138 (Item_Id
=> Item_Id
,
26139 Placement
=> Placement
,
26140 Pack_Id
=> Pack_Id
);
26142 -- Items that appear in a non-package construct (subprogram, block, etc)
26143 -- do not require a Part_Of indicator because they can never act as a
26146 if Placement
= Not_In_Package
then
26149 -- An item declared in the body state space of a package always act as a
26150 -- constituent and does not need explicit Part_Of indicator.
26152 elsif Placement
= Body_State_Space
then
26155 -- In general an item declared in the visible state space of a package
26156 -- does not require a Part_Of indicator. The only exception is when the
26157 -- related package is a private child unit in which case Part_Of must
26158 -- denote a state in the parent unit or in one of its descendants.
26160 elsif Placement
= Visible_State_Space
then
26161 if Is_Child_Unit
(Pack_Id
)
26162 and then Is_Private_Descendant
(Pack_Id
)
26164 -- A package instantiation does not need a Part_Of indicator when
26165 -- the related generic template has no visible state.
26167 if Ekind
(Item_Id
) = E_Package
26168 and then Is_Generic_Instance
(Item_Id
)
26169 and then not Has_Visible_State
(Item_Id
)
26173 -- All other cases require Part_Of
26177 ("indicator Part_Of is required in this context "
26178 & "(SPARK RM 7.2.6(3))", Item_Id
);
26179 Error_Msg_Name_1
:= Chars
(Pack_Id
);
26181 ("\& is declared in the visible part of private child "
26182 & "unit %", Item_Id
);
26186 -- When the item appears in the private state space of a packge, it must
26187 -- be a part of some state declared by the said package.
26189 else pragma Assert
(Placement
= Private_State_Space
);
26191 -- The related package does not declare a state, the item cannot act
26192 -- as a Part_Of constituent.
26194 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
26197 -- A package instantiation does not need a Part_Of indicator when the
26198 -- related generic template has no visible state.
26200 elsif Ekind
(Pack_Id
) = E_Package
26201 and then Is_Generic_Instance
(Pack_Id
)
26202 and then not Has_Visible_State
(Pack_Id
)
26206 -- All other cases require Part_Of
26210 ("indicator Part_Of is required in this context "
26211 & "(SPARK RM 7.2.6(2))", Item_Id
);
26212 Error_Msg_Name_1
:= Chars
(Pack_Id
);
26214 ("\& is declared in the private part of package %", Item_Id
);
26217 end Check_Missing_Part_Of
;
26219 ---------------------------------------------------
26220 -- Check_Postcondition_Use_In_Inlined_Subprogram --
26221 ---------------------------------------------------
26223 procedure Check_Postcondition_Use_In_Inlined_Subprogram
26225 Spec_Id
: Entity_Id
)
26228 if Warn_On_Redundant_Constructs
26229 and then Has_Pragma_Inline_Always
(Spec_Id
)
26231 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
26233 if From_Aspect_Specification
(Prag
) then
26235 ("aspect % not enforced on inlined subprogram &?r?",
26236 Corresponding_Aspect
(Prag
), Spec_Id
);
26239 ("pragma % not enforced on inlined subprogram &?r?",
26243 end Check_Postcondition_Use_In_Inlined_Subprogram
;
26245 -------------------------------------
26246 -- Check_State_And_Constituent_Use --
26247 -------------------------------------
26249 procedure Check_State_And_Constituent_Use
26250 (States
: Elist_Id
;
26251 Constits
: Elist_Id
;
26254 function Find_Encapsulating_State
26255 (Constit_Id
: Entity_Id
) return Entity_Id
;
26256 -- Given the entity of a constituent, try to find a corresponding
26257 -- encapsulating state that appears in the same context. The routine
26258 -- returns Empty is no such state is found.
26260 ------------------------------
26261 -- Find_Encapsulating_State --
26262 ------------------------------
26264 function Find_Encapsulating_State
26265 (Constit_Id
: Entity_Id
) return Entity_Id
26267 State_Id
: Entity_Id
;
26270 -- Since a constituent may be part of a larger constituent set, climb
26271 -- the encapsulating state chain looking for a state that appears in
26272 -- the same context.
26274 State_Id
:= Encapsulating_State
(Constit_Id
);
26275 while Present
(State_Id
) loop
26276 if Contains
(States
, State_Id
) then
26280 State_Id
:= Encapsulating_State
(State_Id
);
26284 end Find_Encapsulating_State
;
26288 Constit_Elmt
: Elmt_Id
;
26289 Constit_Id
: Entity_Id
;
26290 State_Id
: Entity_Id
;
26292 -- Start of processing for Check_State_And_Constituent_Use
26295 -- Nothing to do if there are no states or constituents
26297 if No
(States
) or else No
(Constits
) then
26301 -- Inspect the list of constituents and try to determine whether its
26302 -- encapsulating state is in list States.
26304 Constit_Elmt
:= First_Elmt
(Constits
);
26305 while Present
(Constit_Elmt
) loop
26306 Constit_Id
:= Node
(Constit_Elmt
);
26308 -- Determine whether the constituent is part of an encapsulating
26309 -- state that appears in the same context and if this is the case,
26310 -- emit an error (SPARK RM 7.2.6(7)).
26312 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
26314 if Present
(State_Id
) then
26315 Error_Msg_Name_1
:= Chars
(Constit_Id
);
26317 ("cannot mention state & and its constituent % in the same "
26318 & "context", Context
, State_Id
);
26322 Next_Elmt
(Constit_Elmt
);
26324 end Check_State_And_Constituent_Use
;
26326 ---------------------------------------
26327 -- Collect_Subprogram_Inputs_Outputs --
26328 ---------------------------------------
26330 procedure Collect_Subprogram_Inputs_Outputs
26331 (Subp_Id
: Entity_Id
;
26332 Synthesize
: Boolean := False;
26333 Subp_Inputs
: in out Elist_Id
;
26334 Subp_Outputs
: in out Elist_Id
;
26335 Global_Seen
: out Boolean)
26337 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
26338 -- Collect all relevant items from a dependency clause
26340 procedure Collect_Global_List
26342 Mode
: Name_Id
:= Name_Input
);
26343 -- Collect all relevant items from a global list
26345 -------------------------------
26346 -- Collect_Dependency_Clause --
26347 -------------------------------
26349 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
26350 procedure Collect_Dependency_Item
26352 Is_Input
: Boolean);
26353 -- Add an item to the proper subprogram input or output collection
26355 -----------------------------
26356 -- Collect_Dependency_Item --
26357 -----------------------------
26359 procedure Collect_Dependency_Item
26361 Is_Input
: Boolean)
26366 -- Nothing to collect when the item is null
26368 if Nkind
(Item
) = N_Null
then
26371 -- Ditto for attribute 'Result
26373 elsif Is_Attribute_Result
(Item
) then
26376 -- Multiple items appear as an aggregate
26378 elsif Nkind
(Item
) = N_Aggregate
then
26379 Extra
:= First
(Expressions
(Item
));
26380 while Present
(Extra
) loop
26381 Collect_Dependency_Item
(Extra
, Is_Input
);
26385 -- Otherwise this is a solitary item
26389 Append_New_Elmt
(Item
, Subp_Inputs
);
26391 Append_New_Elmt
(Item
, Subp_Outputs
);
26394 end Collect_Dependency_Item
;
26396 -- Start of processing for Collect_Dependency_Clause
26399 if Nkind
(Clause
) = N_Null
then
26402 -- A dependency cause appears as component association
26404 elsif Nkind
(Clause
) = N_Component_Association
then
26405 Collect_Dependency_Item
26406 (Item
=> Expression
(Clause
),
26409 Collect_Dependency_Item
26410 (Item
=> First
(Choices
(Clause
)),
26411 Is_Input
=> False);
26413 -- To accomodate partial decoration of disabled SPARK features, this
26414 -- routine may be called with illegal input. If this is the case, do
26415 -- not raise Program_Error.
26420 end Collect_Dependency_Clause
;
26422 -------------------------
26423 -- Collect_Global_List --
26424 -------------------------
26426 procedure Collect_Global_List
26428 Mode
: Name_Id
:= Name_Input
)
26430 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
26431 -- Add an item to the proper subprogram input or output collection
26433 -------------------------
26434 -- Collect_Global_Item --
26435 -------------------------
26437 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
26439 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
26440 Append_New_Elmt
(Item
, Subp_Inputs
);
26443 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
26444 Append_New_Elmt
(Item
, Subp_Outputs
);
26446 end Collect_Global_Item
;
26453 -- Start of processing for Collect_Global_List
26456 if Nkind
(List
) = N_Null
then
26459 -- Single global item declaration
26461 elsif Nkind_In
(List
, N_Expanded_Name
,
26463 N_Selected_Component
)
26465 Collect_Global_Item
(List
, Mode
);
26467 -- Simple global list or moded global list declaration
26469 elsif Nkind
(List
) = N_Aggregate
then
26470 if Present
(Expressions
(List
)) then
26471 Item
:= First
(Expressions
(List
));
26472 while Present
(Item
) loop
26473 Collect_Global_Item
(Item
, Mode
);
26478 Assoc
:= First
(Component_Associations
(List
));
26479 while Present
(Assoc
) loop
26480 Collect_Global_List
26481 (List
=> Expression
(Assoc
),
26482 Mode
=> Chars
(First
(Choices
(Assoc
))));
26487 -- To accomodate partial decoration of disabled SPARK features, this
26488 -- routine may be called with illegal input. If this is the case, do
26489 -- not raise Program_Error.
26494 end Collect_Global_List
;
26498 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
26499 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
26503 Formal
: Entity_Id
;
26507 -- Start of processing for Collect_Subprogram_Inputs_Outputs
26510 Global_Seen
:= False;
26512 -- Process all [generic] formal parameters
26514 Formal
:= First_Entity
(Spec_Id
);
26515 while Present
(Formal
) loop
26516 if Ekind_In
(Formal
, E_Generic_In_Parameter
,
26517 E_In_Out_Parameter
,
26520 Append_New_Elmt
(Formal
, Subp_Inputs
);
26523 if Ekind_In
(Formal
, E_Generic_In_Out_Parameter
,
26524 E_In_Out_Parameter
,
26527 Append_New_Elmt
(Formal
, Subp_Outputs
);
26529 -- Out parameters can act as inputs when the related type is
26530 -- tagged, unconstrained array, unconstrained record or record
26531 -- with unconstrained components.
26533 if Ekind
(Formal
) = E_Out_Parameter
26534 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
26536 Append_New_Elmt
(Formal
, Subp_Inputs
);
26540 Next_Entity
(Formal
);
26543 -- When processing an entry, subprogram or task body, look for pragmas
26544 -- Refined_Depends and Refined_Global as they specify the inputs and
26547 if Is_Entry_Body
(Subp_Id
)
26548 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
26550 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
26551 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
26553 -- Subprogram declaration or stand alone body case, look for pragmas
26554 -- Depends and Global
26557 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
26558 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
26561 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
26562 -- because it provides finer granularity of inputs and outputs.
26564 if Present
(Global
) then
26565 Global_Seen
:= True;
26566 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
26568 -- When the related subprogram lacks pragma [Refined_]Global, fall back
26569 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
26570 -- the inputs and outputs from [Refined_]Depends.
26572 elsif Synthesize
and then Present
(Depends
) then
26573 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
26575 -- Multiple dependency clauses appear as an aggregate
26577 if Nkind
(Clauses
) = N_Aggregate
then
26578 Clause
:= First
(Component_Associations
(Clauses
));
26579 while Present
(Clause
) loop
26580 Collect_Dependency_Clause
(Clause
);
26584 -- Otherwise this is a single dependency clause
26587 Collect_Dependency_Clause
(Clauses
);
26591 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
26592 Typ
:= Scope
(Spec_Id
);
26594 -- A single protected type declaration does not have a current
26595 -- instance because the type is technically an object.
26597 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
26600 -- Otherwise the current instance of the protected type acts as a
26601 -- formal parameter of mode IN for functions and IN OUT for entries
26602 -- and procedures (SPARK RM 6.1.4).
26605 Append_New_Elmt
(Typ
, Subp_Inputs
);
26607 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
26608 Append_New_Elmt
(Typ
, Subp_Outputs
);
26612 elsif Ekind
(Spec_Id
) = E_Task_Type
then
26615 -- A single task type declaration does not have a current instance
26616 -- because the type is technically an object.
26618 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
26621 -- Otherwise the current instance of the task type acts as a formal
26622 -- parameter of mode IN OUT (SPARK RM 6.1.4).
26625 Append_New_Elmt
(Typ
, Subp_Inputs
);
26626 Append_New_Elmt
(Typ
, Subp_Outputs
);
26629 end Collect_Subprogram_Inputs_Outputs
;
26631 ---------------------------------
26632 -- Delay_Config_Pragma_Analyze --
26633 ---------------------------------
26635 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
26637 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
26638 Name_Priority_Specific_Dispatching
);
26639 end Delay_Config_Pragma_Analyze
;
26641 -----------------------
26642 -- Duplication_Error --
26643 -----------------------
26645 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
26646 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
26647 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
26650 Error_Msg_Sloc
:= Sloc
(Prev
);
26651 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
26653 -- Emit a precise message to distinguish between source pragmas and
26654 -- pragmas generated from aspects. The ordering of the two pragmas is
26658 -- Prag -- duplicate
26660 -- No error is emitted when both pragmas come from aspects because this
26661 -- is already detected by the general aspect analysis mechanism.
26663 if Prag_From_Asp
and Prev_From_Asp
then
26665 elsif Prag_From_Asp
then
26666 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
26667 elsif Prev_From_Asp
then
26668 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
26670 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
26672 end Duplication_Error
;
26674 --------------------------
26675 -- Find_Related_Context --
26676 --------------------------
26678 function Find_Related_Context
26680 Do_Checks
: Boolean := False) return Node_Id
26685 Stmt
:= Prev
(Prag
);
26686 while Present
(Stmt
) loop
26688 -- Skip prior pragmas, but check for duplicates
26690 if Nkind
(Stmt
) = N_Pragma
then
26691 if Do_Checks
and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
) then
26697 -- Skip internally generated code
26699 elsif not Comes_From_Source
(Stmt
) then
26701 -- The anonymous object created for a single concurrent type is a
26702 -- suitable context.
26704 if Nkind
(Stmt
) = N_Object_Declaration
26705 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
26710 -- Return the current source construct
26720 end Find_Related_Context
;
26722 --------------------------------------
26723 -- Find_Related_Declaration_Or_Body --
26724 --------------------------------------
26726 function Find_Related_Declaration_Or_Body
26728 Do_Checks
: Boolean := False) return Node_Id
26730 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
26732 procedure Expression_Function_Error
;
26733 -- Emit an error concerning pragma Prag that illegaly applies to an
26734 -- expression function.
26736 -------------------------------
26737 -- Expression_Function_Error --
26738 -------------------------------
26740 procedure Expression_Function_Error
is
26742 Error_Msg_Name_1
:= Prag_Nam
;
26744 -- Emit a precise message to distinguish between source pragmas and
26745 -- pragmas generated from aspects.
26747 if From_Aspect_Specification
(Prag
) then
26749 ("aspect % cannot apply to a stand alone expression function",
26753 ("pragma % cannot apply to a stand alone expression function",
26756 end Expression_Function_Error
;
26760 Context
: constant Node_Id
:= Parent
(Prag
);
26763 Look_For_Body
: constant Boolean :=
26764 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
26765 Name_Refined_Global
,
26766 Name_Refined_Post
);
26767 -- Refinement pragmas must be associated with a subprogram body [stub]
26769 -- Start of processing for Find_Related_Declaration_Or_Body
26772 Stmt
:= Prev
(Prag
);
26773 while Present
(Stmt
) loop
26775 -- Skip prior pragmas, but check for duplicates. Pragmas produced
26776 -- by splitting a complex pre/postcondition are not considered to
26779 if Nkind
(Stmt
) = N_Pragma
then
26781 and then not Split_PPC
(Stmt
)
26782 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
26789 -- Emit an error when a refinement pragma appears on an expression
26790 -- function without a completion.
26793 and then Look_For_Body
26794 and then Nkind
(Stmt
) = N_Subprogram_Declaration
26795 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
26796 and then not Has_Completion
(Defining_Entity
(Stmt
))
26798 Expression_Function_Error
;
26801 -- The refinement pragma applies to a subprogram body stub
26803 elsif Look_For_Body
26804 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
26808 -- Skip internally generated code
26810 elsif not Comes_From_Source
(Stmt
) then
26812 -- The anonymous object created for a single concurrent type is a
26813 -- suitable context.
26815 if Nkind
(Stmt
) = N_Object_Declaration
26816 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
26820 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
26822 -- The subprogram declaration is an internally generated spec
26823 -- for an expression function.
26825 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
26828 -- The subprogram is actually an instance housed within an
26829 -- anonymous wrapper package.
26831 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
26836 -- Return the current construct which is either a subprogram body,
26837 -- a subprogram declaration or is illegal.
26846 -- If we fall through, then the pragma was either the first declaration
26847 -- or it was preceded by other pragmas and no source constructs.
26849 -- The pragma is associated with a library-level subprogram
26851 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
26852 return Unit
(Parent
(Context
));
26854 -- The pragma appears inside the declarations of an entry body
26856 elsif Nkind
(Context
) = N_Entry_Body
then
26859 -- The pragma appears inside the statements of a subprogram body. This
26860 -- placement is the result of subprogram contract expansion.
26862 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
26863 return Parent
(Context
);
26865 -- The pragma appears inside the declarative part of a subprogram body
26867 elsif Nkind
(Context
) = N_Subprogram_Body
then
26870 -- The pragma appears inside the declarative part of a task body
26872 elsif Nkind
(Context
) = N_Task_Body
then
26875 -- The pragma is a byproduct of aspect expansion, return the related
26876 -- context of the original aspect. This case has a lower priority as
26877 -- the above circuitry pinpoints precisely the related context.
26879 elsif Present
(Corresponding_Aspect
(Prag
)) then
26880 return Parent
(Corresponding_Aspect
(Prag
));
26882 -- No candidate subprogram [body] found
26887 end Find_Related_Declaration_Or_Body
;
26889 ----------------------------------
26890 -- Find_Related_Package_Or_Body --
26891 ----------------------------------
26893 function Find_Related_Package_Or_Body
26895 Do_Checks
: Boolean := False) return Node_Id
26897 Context
: constant Node_Id
:= Parent
(Prag
);
26898 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
26902 Stmt
:= Prev
(Prag
);
26903 while Present
(Stmt
) loop
26905 -- Skip prior pragmas, but check for duplicates
26907 if Nkind
(Stmt
) = N_Pragma
then
26908 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
26914 -- Skip internally generated code
26916 elsif not Comes_From_Source
(Stmt
) then
26917 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
26919 -- The subprogram declaration is an internally generated spec
26920 -- for an expression function.
26922 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
26925 -- The subprogram is actually an instance housed within an
26926 -- anonymous wrapper package.
26928 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
26933 -- Return the current source construct which is illegal
26942 -- If we fall through, then the pragma was either the first declaration
26943 -- or it was preceded by other pragmas and no source constructs.
26945 -- The pragma is associated with a package. The immediate context in
26946 -- this case is the specification of the package.
26948 if Nkind
(Context
) = N_Package_Specification
then
26949 return Parent
(Context
);
26951 -- The pragma appears in the declarations of a package body
26953 elsif Nkind
(Context
) = N_Package_Body
then
26956 -- The pragma appears in the statements of a package body
26958 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
26959 and then Nkind
(Parent
(Context
)) = N_Package_Body
26961 return Parent
(Context
);
26963 -- The pragma is a byproduct of aspect expansion, return the related
26964 -- context of the original aspect. This case has a lower priority as
26965 -- the above circuitry pinpoints precisely the related context.
26967 elsif Present
(Corresponding_Aspect
(Prag
)) then
26968 return Parent
(Corresponding_Aspect
(Prag
));
26970 -- No candidate packge [body] found
26975 end Find_Related_Package_Or_Body
;
26981 function Get_Argument
26983 Context_Id
: Entity_Id
:= Empty
) return Node_Id
26985 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
26988 -- Use the expression of the original aspect when compiling for ASIS or
26989 -- when analyzing the template of a generic unit. In both cases the
26990 -- aspect's tree must be decorated to allow for ASIS queries or to save
26991 -- the global references in the generic context.
26993 if From_Aspect_Specification
(Prag
)
26994 and then (ASIS_Mode
or else (Present
(Context_Id
)
26995 and then Is_Generic_Unit
(Context_Id
)))
26997 return Corresponding_Aspect
(Prag
);
26999 -- Otherwise use the expression of the pragma
27001 elsif Present
(Args
) then
27002 return First
(Args
);
27009 -------------------------
27010 -- Get_Base_Subprogram --
27011 -------------------------
27013 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
27014 Result
: Entity_Id
;
27017 -- Follow subprogram renaming chain
27021 if Is_Subprogram
(Result
)
27023 Nkind
(Parent
(Declaration_Node
(Result
))) =
27024 N_Subprogram_Renaming_Declaration
27025 and then Present
(Alias
(Result
))
27027 Result
:= Alias
(Result
);
27031 end Get_Base_Subprogram
;
27033 -----------------------
27034 -- Get_SPARK_Mode_Type --
27035 -----------------------
27037 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
27039 if N
= Name_On
then
27041 elsif N
= Name_Off
then
27044 -- Any other argument is illegal
27047 raise Program_Error
;
27049 end Get_SPARK_Mode_Type
;
27051 --------------------------------
27052 -- Get_SPARK_Mode_From_Pragma --
27053 --------------------------------
27055 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
27060 pragma Assert
(Nkind
(N
) = N_Pragma
);
27061 Args
:= Pragma_Argument_Associations
(N
);
27063 -- Extract the mode from the argument list
27065 if Present
(Args
) then
27066 Mode
:= First
(Pragma_Argument_Associations
(N
));
27067 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
27069 -- If SPARK_Mode pragma has no argument, default is ON
27074 end Get_SPARK_Mode_From_Pragma
;
27076 ---------------------------
27077 -- Has_Extra_Parentheses --
27078 ---------------------------
27080 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
27084 -- The aggregate should not have an expression list because a clause
27085 -- is always interpreted as a component association. The only way an
27086 -- expression list can sneak in is by adding extra parentheses around
27087 -- the individual clauses:
27089 -- Depends (Output => Input) -- proper form
27090 -- Depends ((Output => Input)) -- extra parentheses
27092 -- Since the extra parentheses are not allowed by the syntax of the
27093 -- pragma, flag them now to avoid emitting misleading errors down the
27096 if Nkind
(Clause
) = N_Aggregate
27097 and then Present
(Expressions
(Clause
))
27099 Expr
:= First
(Expressions
(Clause
));
27100 while Present
(Expr
) loop
27102 -- A dependency clause surrounded by extra parentheses appears
27103 -- as an aggregate of component associations with an optional
27104 -- Paren_Count set.
27106 if Nkind
(Expr
) = N_Aggregate
27107 and then Present
(Component_Associations
(Expr
))
27110 ("dependency clause contains extra parentheses", Expr
);
27112 -- Otherwise the expression is a malformed construct
27115 SPARK_Msg_N
("malformed dependency clause", Expr
);
27125 end Has_Extra_Parentheses
;
27131 procedure Initialize
is
27142 Dummy
:= Dummy
+ 1;
27145 -----------------------------
27146 -- Is_Config_Static_String --
27147 -----------------------------
27149 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
27151 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
27152 -- This is an internal recursive function that is just like the outer
27153 -- function except that it adds the string to the name buffer rather
27154 -- than placing the string in the name buffer.
27156 ------------------------------
27157 -- Add_Config_Static_String --
27158 ------------------------------
27160 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
27167 if Nkind
(N
) = N_Op_Concat
then
27168 if Add_Config_Static_String
(Left_Opnd
(N
)) then
27169 N
:= Right_Opnd
(N
);
27175 if Nkind
(N
) /= N_String_Literal
then
27176 Error_Msg_N
("string literal expected for pragma argument", N
);
27180 for J
in 1 .. String_Length
(Strval
(N
)) loop
27181 C
:= Get_String_Char
(Strval
(N
), J
);
27183 if not In_Character_Range
(C
) then
27185 ("string literal contains invalid wide character",
27186 Sloc
(N
) + 1 + Source_Ptr
(J
));
27190 Add_Char_To_Name_Buffer
(Get_Character
(C
));
27195 end Add_Config_Static_String
;
27197 -- Start of processing for Is_Config_Static_String
27202 return Add_Config_Static_String
(Arg
);
27203 end Is_Config_Static_String
;
27205 ---------------------
27206 -- Is_CCT_Instance --
27207 ---------------------
27209 function Is_CCT_Instance
(Ref
: Node_Id
) return Boolean is
27210 Ref_Id
: constant Entity_Id
:= Entity
(Ref
);
27214 -- Climb the scope chain looking for an enclosing concurrent type that
27215 -- matches the referenced entity.
27217 S
:= Current_Scope
;
27218 while Present
(S
) and then S
/= Standard_Standard
loop
27219 if Ekind_In
(S
, E_Protected_Type
, E_Task_Type
) and then S
= Ref_Id
27228 end Is_CCT_Instance
;
27230 -------------------------------
27231 -- Is_Elaboration_SPARK_Mode --
27232 -------------------------------
27234 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
27237 (Nkind
(N
) = N_Pragma
27238 and then Pragma_Name
(N
) = Name_SPARK_Mode
27239 and then Is_List_Member
(N
));
27241 -- Pragma SPARK_Mode affects the elaboration of a package body when it
27242 -- appears in the statement part of the body.
27245 Present
(Parent
(N
))
27246 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
27247 and then List_Containing
(N
) = Statements
(Parent
(N
))
27248 and then Present
(Parent
(Parent
(N
)))
27249 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
27250 end Is_Elaboration_SPARK_Mode
;
27252 -----------------------
27253 -- Is_Enabled_Pragma --
27254 -----------------------
27256 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
27260 if Present
(Prag
) then
27261 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
27263 if Present
(Arg
) then
27264 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
27266 -- The lack of a Boolean argument automatically enables the pragma
27272 -- The pragma is missing, therefore it is not enabled
27277 end Is_Enabled_Pragma
;
27279 -----------------------------------------
27280 -- Is_Non_Significant_Pragma_Reference --
27281 -----------------------------------------
27283 -- This function makes use of the following static table which indicates
27284 -- whether appearance of some name in a given pragma is to be considered
27285 -- as a reference for the purposes of warnings about unreferenced objects.
27287 -- -1 indicates that appearence in any argument is significant
27288 -- 0 indicates that appearance in any argument is not significant
27289 -- +n indicates that appearance as argument n is significant, but all
27290 -- other arguments are not significant
27291 -- 9n arguments from n on are significant, before n insignificant
27293 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
27294 (Pragma_Abort_Defer
=> -1,
27295 Pragma_Abstract_State
=> -1,
27296 Pragma_Ada_83
=> -1,
27297 Pragma_Ada_95
=> -1,
27298 Pragma_Ada_05
=> -1,
27299 Pragma_Ada_2005
=> -1,
27300 Pragma_Ada_12
=> -1,
27301 Pragma_Ada_2012
=> -1,
27302 Pragma_All_Calls_Remote
=> -1,
27303 Pragma_Allow_Integer_Address
=> -1,
27304 Pragma_Annotate
=> 93,
27305 Pragma_Assert
=> -1,
27306 Pragma_Assert_And_Cut
=> -1,
27307 Pragma_Assertion_Policy
=> 0,
27308 Pragma_Assume
=> -1,
27309 Pragma_Assume_No_Invalid_Values
=> 0,
27310 Pragma_Async_Readers
=> 0,
27311 Pragma_Async_Writers
=> 0,
27312 Pragma_Asynchronous
=> 0,
27313 Pragma_Atomic
=> 0,
27314 Pragma_Atomic_Components
=> 0,
27315 Pragma_Attach_Handler
=> -1,
27316 Pragma_Attribute_Definition
=> 92,
27317 Pragma_Check
=> -1,
27318 Pragma_Check_Float_Overflow
=> 0,
27319 Pragma_Check_Name
=> 0,
27320 Pragma_Check_Policy
=> 0,
27321 Pragma_CPP_Class
=> 0,
27322 Pragma_CPP_Constructor
=> 0,
27323 Pragma_CPP_Virtual
=> 0,
27324 Pragma_CPP_Vtable
=> 0,
27326 Pragma_C_Pass_By_Copy
=> 0,
27327 Pragma_Comment
=> -1,
27328 Pragma_Common_Object
=> 0,
27329 Pragma_Compile_Time_Error
=> -1,
27330 Pragma_Compile_Time_Warning
=> -1,
27331 Pragma_Compiler_Unit
=> -1,
27332 Pragma_Compiler_Unit_Warning
=> -1,
27333 Pragma_Complete_Representation
=> 0,
27334 Pragma_Complex_Representation
=> 0,
27335 Pragma_Component_Alignment
=> 0,
27336 Pragma_Constant_After_Elaboration
=> 0,
27337 Pragma_Contract_Cases
=> -1,
27338 Pragma_Controlled
=> 0,
27339 Pragma_Convention
=> 0,
27340 Pragma_Convention_Identifier
=> 0,
27341 Pragma_Debug
=> -1,
27342 Pragma_Debug_Policy
=> 0,
27343 Pragma_Detect_Blocking
=> 0,
27344 Pragma_Default_Initial_Condition
=> -1,
27345 Pragma_Default_Scalar_Storage_Order
=> 0,
27346 Pragma_Default_Storage_Pool
=> 0,
27347 Pragma_Depends
=> -1,
27348 Pragma_Disable_Atomic_Synchronization
=> 0,
27349 Pragma_Discard_Names
=> 0,
27350 Pragma_Dispatching_Domain
=> -1,
27351 Pragma_Effective_Reads
=> 0,
27352 Pragma_Effective_Writes
=> 0,
27353 Pragma_Elaborate
=> 0,
27354 Pragma_Elaborate_All
=> 0,
27355 Pragma_Elaborate_Body
=> 0,
27356 Pragma_Elaboration_Checks
=> 0,
27357 Pragma_Eliminate
=> 0,
27358 Pragma_Enable_Atomic_Synchronization
=> 0,
27359 Pragma_Export
=> -1,
27360 Pragma_Export_Function
=> -1,
27361 Pragma_Export_Object
=> -1,
27362 Pragma_Export_Procedure
=> -1,
27363 Pragma_Export_Value
=> -1,
27364 Pragma_Export_Valued_Procedure
=> -1,
27365 Pragma_Extend_System
=> -1,
27366 Pragma_Extensions_Allowed
=> 0,
27367 Pragma_Extensions_Visible
=> 0,
27368 Pragma_External
=> -1,
27369 Pragma_Favor_Top_Level
=> 0,
27370 Pragma_External_Name_Casing
=> 0,
27371 Pragma_Fast_Math
=> 0,
27372 Pragma_Finalize_Storage_Only
=> 0,
27374 Pragma_Global
=> -1,
27375 Pragma_Ident
=> -1,
27376 Pragma_Ignore_Pragma
=> 0,
27377 Pragma_Implementation_Defined
=> -1,
27378 Pragma_Implemented
=> -1,
27379 Pragma_Implicit_Packing
=> 0,
27380 Pragma_Import
=> 93,
27381 Pragma_Import_Function
=> 0,
27382 Pragma_Import_Object
=> 0,
27383 Pragma_Import_Procedure
=> 0,
27384 Pragma_Import_Valued_Procedure
=> 0,
27385 Pragma_Independent
=> 0,
27386 Pragma_Independent_Components
=> 0,
27387 Pragma_Initial_Condition
=> -1,
27388 Pragma_Initialize_Scalars
=> 0,
27389 Pragma_Initializes
=> -1,
27390 Pragma_Inline
=> 0,
27391 Pragma_Inline_Always
=> 0,
27392 Pragma_Inline_Generic
=> 0,
27393 Pragma_Inspection_Point
=> -1,
27394 Pragma_Interface
=> 92,
27395 Pragma_Interface_Name
=> 0,
27396 Pragma_Interrupt_Handler
=> -1,
27397 Pragma_Interrupt_Priority
=> -1,
27398 Pragma_Interrupt_State
=> -1,
27399 Pragma_Invariant
=> -1,
27400 Pragma_Keep_Names
=> 0,
27401 Pragma_License
=> 0,
27402 Pragma_Link_With
=> -1,
27403 Pragma_Linker_Alias
=> -1,
27404 Pragma_Linker_Constructor
=> -1,
27405 Pragma_Linker_Destructor
=> -1,
27406 Pragma_Linker_Options
=> -1,
27407 Pragma_Linker_Section
=> 0,
27409 Pragma_Lock_Free
=> 0,
27410 Pragma_Locking_Policy
=> 0,
27411 Pragma_Loop_Invariant
=> -1,
27412 Pragma_Loop_Optimize
=> 0,
27413 Pragma_Loop_Variant
=> -1,
27414 Pragma_Machine_Attribute
=> -1,
27416 Pragma_Main_Storage
=> -1,
27417 Pragma_Memory_Size
=> 0,
27418 Pragma_No_Return
=> 0,
27419 Pragma_No_Body
=> 0,
27420 Pragma_No_Elaboration_Code_All
=> 0,
27421 Pragma_No_Inline
=> 0,
27422 Pragma_No_Run_Time
=> -1,
27423 Pragma_No_Strict_Aliasing
=> -1,
27424 Pragma_No_Tagged_Streams
=> 0,
27425 Pragma_Normalize_Scalars
=> 0,
27426 Pragma_Obsolescent
=> 0,
27427 Pragma_Optimize
=> 0,
27428 Pragma_Optimize_Alignment
=> 0,
27429 Pragma_Overflow_Mode
=> 0,
27430 Pragma_Overriding_Renamings
=> 0,
27431 Pragma_Ordered
=> 0,
27434 Pragma_Part_Of
=> 0,
27435 Pragma_Partition_Elaboration_Policy
=> 0,
27436 Pragma_Passive
=> 0,
27437 Pragma_Persistent_BSS
=> 0,
27438 Pragma_Polling
=> 0,
27439 Pragma_Prefix_Exception_Messages
=> 0,
27441 Pragma_Postcondition
=> -1,
27442 Pragma_Post_Class
=> -1,
27444 Pragma_Precondition
=> -1,
27445 Pragma_Predicate
=> -1,
27446 Pragma_Predicate_Failure
=> -1,
27447 Pragma_Preelaborable_Initialization
=> -1,
27448 Pragma_Preelaborate
=> 0,
27449 Pragma_Pre_Class
=> -1,
27450 Pragma_Priority
=> -1,
27451 Pragma_Priority_Specific_Dispatching
=> 0,
27452 Pragma_Profile
=> 0,
27453 Pragma_Profile_Warnings
=> 0,
27454 Pragma_Propagate_Exceptions
=> 0,
27455 Pragma_Provide_Shift_Operators
=> 0,
27456 Pragma_Psect_Object
=> 0,
27458 Pragma_Pure_Function
=> 0,
27459 Pragma_Queuing_Policy
=> 0,
27460 Pragma_Rational
=> 0,
27461 Pragma_Ravenscar
=> 0,
27462 Pragma_Refined_Depends
=> -1,
27463 Pragma_Refined_Global
=> -1,
27464 Pragma_Refined_Post
=> -1,
27465 Pragma_Refined_State
=> -1,
27466 Pragma_Relative_Deadline
=> 0,
27467 Pragma_Remote_Access_Type
=> -1,
27468 Pragma_Remote_Call_Interface
=> -1,
27469 Pragma_Remote_Types
=> -1,
27470 Pragma_Restricted_Run_Time
=> 0,
27471 Pragma_Restriction_Warnings
=> 0,
27472 Pragma_Restrictions
=> 0,
27473 Pragma_Reviewable
=> -1,
27474 Pragma_Short_Circuit_And_Or
=> 0,
27475 Pragma_Share_Generic
=> 0,
27476 Pragma_Shared
=> 0,
27477 Pragma_Shared_Passive
=> 0,
27478 Pragma_Short_Descriptors
=> 0,
27479 Pragma_Simple_Storage_Pool_Type
=> 0,
27480 Pragma_Source_File_Name
=> 0,
27481 Pragma_Source_File_Name_Project
=> 0,
27482 Pragma_Source_Reference
=> 0,
27483 Pragma_SPARK_Mode
=> 0,
27484 Pragma_Storage_Size
=> -1,
27485 Pragma_Storage_Unit
=> 0,
27486 Pragma_Static_Elaboration_Desired
=> 0,
27487 Pragma_Stream_Convert
=> 0,
27488 Pragma_Style_Checks
=> 0,
27489 Pragma_Subtitle
=> 0,
27490 Pragma_Suppress
=> 0,
27491 Pragma_Suppress_Exception_Locations
=> 0,
27492 Pragma_Suppress_All
=> 0,
27493 Pragma_Suppress_Debug_Info
=> 0,
27494 Pragma_Suppress_Initialization
=> 0,
27495 Pragma_System_Name
=> 0,
27496 Pragma_Task_Dispatching_Policy
=> 0,
27497 Pragma_Task_Info
=> -1,
27498 Pragma_Task_Name
=> -1,
27499 Pragma_Task_Storage
=> -1,
27500 Pragma_Test_Case
=> -1,
27501 Pragma_Thread_Local_Storage
=> -1,
27502 Pragma_Time_Slice
=> -1,
27504 Pragma_Type_Invariant
=> -1,
27505 Pragma_Type_Invariant_Class
=> -1,
27506 Pragma_Unchecked_Union
=> 0,
27507 Pragma_Unimplemented_Unit
=> 0,
27508 Pragma_Universal_Aliasing
=> 0,
27509 Pragma_Universal_Data
=> 0,
27510 Pragma_Unmodified
=> 0,
27511 Pragma_Unreferenced
=> 0,
27512 Pragma_Unreferenced_Objects
=> 0,
27513 Pragma_Unreserve_All_Interrupts
=> 0,
27514 Pragma_Unsuppress
=> 0,
27515 Pragma_Unevaluated_Use_Of_Old
=> 0,
27516 Pragma_Use_VADS_Size
=> 0,
27517 Pragma_Validity_Checks
=> 0,
27518 Pragma_Volatile
=> 0,
27519 Pragma_Volatile_Components
=> 0,
27520 Pragma_Volatile_Full_Access
=> 0,
27521 Pragma_Volatile_Function
=> 0,
27522 Pragma_Warning_As_Error
=> 0,
27523 Pragma_Warnings
=> 0,
27524 Pragma_Weak_External
=> 0,
27525 Pragma_Wide_Character_Encoding
=> 0,
27526 Unknown_Pragma
=> 0);
27528 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
27534 function Arg_No
return Nat
;
27535 -- Returns an integer showing what argument we are in. A value of
27536 -- zero means we are not in any of the arguments.
27542 function Arg_No
return Nat
is
27547 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
27561 -- Start of processing for Non_Significant_Pragma_Reference
27566 if Nkind
(P
) /= N_Pragma_Argument_Association
then
27570 Id
:= Get_Pragma_Id
(Parent
(P
));
27571 C
:= Sig_Flags
(Id
);
27586 return AN
< (C
- 90);
27592 end Is_Non_Significant_Pragma_Reference
;
27594 ------------------------------
27595 -- Is_Pragma_String_Literal --
27596 ------------------------------
27598 -- This function returns true if the corresponding pragma argument is a
27599 -- static string expression. These are the only cases in which string
27600 -- literals can appear as pragma arguments. We also allow a string literal
27601 -- as the first argument to pragma Assert (although it will of course
27602 -- always generate a type error).
27604 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
27605 Pragn
: constant Node_Id
:= Parent
(Par
);
27606 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
27607 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
27613 N
:= First
(Assoc
);
27620 if Pname
= Name_Assert
then
27623 elsif Pname
= Name_Export
then
27626 elsif Pname
= Name_Ident
then
27629 elsif Pname
= Name_Import
then
27632 elsif Pname
= Name_Interface_Name
then
27635 elsif Pname
= Name_Linker_Alias
then
27638 elsif Pname
= Name_Linker_Section
then
27641 elsif Pname
= Name_Machine_Attribute
then
27644 elsif Pname
= Name_Source_File_Name
then
27647 elsif Pname
= Name_Source_Reference
then
27650 elsif Pname
= Name_Title
then
27653 elsif Pname
= Name_Subtitle
then
27659 end Is_Pragma_String_Literal
;
27661 ---------------------------
27662 -- Is_Private_SPARK_Mode --
27663 ---------------------------
27665 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
27668 (Nkind
(N
) = N_Pragma
27669 and then Pragma_Name
(N
) = Name_SPARK_Mode
27670 and then Is_List_Member
(N
));
27672 -- For pragma SPARK_Mode to be private, it has to appear in the private
27673 -- declarations of a package.
27676 Present
(Parent
(N
))
27677 and then Nkind
(Parent
(N
)) = N_Package_Specification
27678 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
27679 end Is_Private_SPARK_Mode
;
27681 -------------------------------------
27682 -- Is_Unconstrained_Or_Tagged_Item --
27683 -------------------------------------
27685 function Is_Unconstrained_Or_Tagged_Item
27686 (Item
: Entity_Id
) return Boolean
27688 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
27689 -- Determine whether record type Typ has at least one unconstrained
27692 ---------------------------------
27693 -- Has_Unconstrained_Component --
27694 ---------------------------------
27696 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
27700 Comp
:= First_Component
(Typ
);
27701 while Present
(Comp
) loop
27702 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
27706 Next_Component
(Comp
);
27710 end Has_Unconstrained_Component
;
27714 Typ
: constant Entity_Id
:= Etype
(Item
);
27716 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
27719 if Is_Tagged_Type
(Typ
) then
27722 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
27725 elsif Is_Record_Type
(Typ
) then
27726 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
27729 return Has_Unconstrained_Component
(Typ
);
27732 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
27738 end Is_Unconstrained_Or_Tagged_Item
;
27740 -----------------------------
27741 -- Is_Valid_Assertion_Kind --
27742 -----------------------------
27744 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
27751 Name_Static_Predicate |
27752 Name_Dynamic_Predicate |
27757 Name_Type_Invariant |
27758 Name_uType_Invariant |
27762 Name_Assert_And_Cut |
27764 Name_Contract_Cases |
27766 Name_Default_Initial_Condition |
27768 Name_Initial_Condition |
27771 Name_Loop_Invariant |
27772 Name_Loop_Variant |
27773 Name_Postcondition |
27774 Name_Precondition |
27776 Name_Refined_Post |
27777 Name_Statement_Assertions
=> return True;
27779 when others => return False;
27781 end Is_Valid_Assertion_Kind
;
27783 --------------------------------------
27784 -- Process_Compilation_Unit_Pragmas --
27785 --------------------------------------
27787 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
27789 -- A special check for pragma Suppress_All, a very strange DEC pragma,
27790 -- strange because it comes at the end of the unit. Rational has the
27791 -- same name for a pragma, but treats it as a program unit pragma, In
27792 -- GNAT we just decide to allow it anywhere at all. If it appeared then
27793 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
27794 -- node, and we insert a pragma Suppress (All_Checks) at the start of
27795 -- the context clause to ensure the correct processing.
27797 if Has_Pragma_Suppress_All
(N
) then
27798 Prepend_To
(Context_Items
(N
),
27799 Make_Pragma
(Sloc
(N
),
27800 Chars
=> Name_Suppress
,
27801 Pragma_Argument_Associations
=> New_List
(
27802 Make_Pragma_Argument_Association
(Sloc
(N
),
27803 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
27806 -- Nothing else to do at the current time
27808 end Process_Compilation_Unit_Pragmas
;
27810 ------------------------------------
27811 -- Record_Possible_Body_Reference --
27812 ------------------------------------
27814 procedure Record_Possible_Body_Reference
27815 (State_Id
: Entity_Id
;
27819 Spec_Id
: Entity_Id
;
27822 -- Ensure that we are dealing with a reference to a state
27824 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
27826 -- Climb the tree starting from the reference looking for a package body
27827 -- whose spec declares the referenced state. This criteria automatically
27828 -- excludes references in package specs which are legal. Note that it is
27829 -- not wise to emit an error now as the package body may lack pragma
27830 -- Refined_State or the referenced state may not be mentioned in the
27831 -- refinement. This approach avoids the generation of misleading errors.
27834 while Present
(Context
) loop
27835 if Nkind
(Context
) = N_Package_Body
then
27836 Spec_Id
:= Corresponding_Spec
(Context
);
27838 if Present
(Abstract_States
(Spec_Id
))
27839 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
27841 if No
(Body_References
(State_Id
)) then
27842 Set_Body_References
(State_Id
, New_Elmt_List
);
27845 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
27850 Context
:= Parent
(Context
);
27852 end Record_Possible_Body_Reference
;
27854 ------------------------------------------
27855 -- Relocate_Pragmas_To_Anonymous_Object --
27856 ------------------------------------------
27858 procedure Relocate_Pragmas_To_Anonymous_Object
27859 (Typ_Decl
: Node_Id
;
27860 Obj_Decl
: Node_Id
)
27864 Next_Decl
: Node_Id
;
27867 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
27868 Def
:= Protected_Definition
(Typ_Decl
);
27870 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
27871 Def
:= Task_Definition
(Typ_Decl
);
27874 -- The concurrent definition has a visible declaration list. Inspect it
27875 -- and relocate all canidate pragmas.
27877 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
27878 Decl
:= First
(Visible_Declarations
(Def
));
27879 while Present
(Decl
) loop
27881 -- Preserve the following declaration for iteration purposes due
27882 -- to possible relocation of a pragma.
27884 Next_Decl
:= Next
(Decl
);
27886 if Nkind
(Decl
) = N_Pragma
27887 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
27890 Insert_After
(Obj_Decl
, Decl
);
27892 -- Skip internally generated code
27894 elsif not Comes_From_Source
(Decl
) then
27897 -- No candidate pragmas are available for relocation
27906 end Relocate_Pragmas_To_Anonymous_Object
;
27908 ------------------------------
27909 -- Relocate_Pragmas_To_Body --
27910 ------------------------------
27912 procedure Relocate_Pragmas_To_Body
27913 (Subp_Body
: Node_Id
;
27914 Target_Body
: Node_Id
:= Empty
)
27916 procedure Relocate_Pragma
(Prag
: Node_Id
);
27917 -- Remove a single pragma from its current list and add it to the
27918 -- declarations of the proper body (either Subp_Body or Target_Body).
27920 ---------------------
27921 -- Relocate_Pragma --
27922 ---------------------
27924 procedure Relocate_Pragma
(Prag
: Node_Id
) is
27929 -- When subprogram stubs or expression functions are involves, the
27930 -- destination declaration list belongs to the proper body.
27932 if Present
(Target_Body
) then
27933 Target
:= Target_Body
;
27935 Target
:= Subp_Body
;
27938 Decls
:= Declarations
(Target
);
27942 Set_Declarations
(Target
, Decls
);
27945 -- Unhook the pragma from its current list
27948 Prepend
(Prag
, Decls
);
27949 end Relocate_Pragma
;
27953 Body_Id
: constant Entity_Id
:=
27954 Defining_Unit_Name
(Specification
(Subp_Body
));
27955 Next_Stmt
: Node_Id
;
27958 -- Start of processing for Relocate_Pragmas_To_Body
27961 -- Do not process a body that comes from a separate unit as no construct
27962 -- can possibly follow it.
27964 if not Is_List_Member
(Subp_Body
) then
27967 -- Do not relocate pragmas that follow a stub if the stub does not have
27970 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
27971 and then No
(Target_Body
)
27975 -- Do not process internally generated routine _Postconditions
27977 elsif Ekind
(Body_Id
) = E_Procedure
27978 and then Chars
(Body_Id
) = Name_uPostconditions
27983 -- Look at what is following the body. We are interested in certain kind
27984 -- of pragmas (either from source or byproducts of expansion) that can
27985 -- apply to a body [stub].
27987 Stmt
:= Next
(Subp_Body
);
27988 while Present
(Stmt
) loop
27990 -- Preserve the following statement for iteration purposes due to a
27991 -- possible relocation of a pragma.
27993 Next_Stmt
:= Next
(Stmt
);
27995 -- Move a candidate pragma following the body to the declarations of
27998 if Nkind
(Stmt
) = N_Pragma
27999 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
28001 Relocate_Pragma
(Stmt
);
28003 -- Skip internally generated code
28005 elsif not Comes_From_Source
(Stmt
) then
28008 -- No candidate pragmas are available for relocation
28016 end Relocate_Pragmas_To_Body
;
28018 -------------------
28019 -- Resolve_State --
28020 -------------------
28022 procedure Resolve_State
(N
: Node_Id
) is
28027 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
28028 Func
:= Entity
(N
);
28030 -- Handle overloading of state names by functions. Traverse the
28031 -- homonym chain looking for an abstract state.
28033 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
28034 State
:= Homonym
(Func
);
28035 while Present
(State
) loop
28037 -- Resolve the overloading by setting the proper entity of the
28038 -- reference to that of the state.
28040 if Ekind
(State
) = E_Abstract_State
then
28041 Set_Etype
(N
, Standard_Void_Type
);
28042 Set_Entity
(N
, State
);
28043 Set_Associated_Node
(N
, State
);
28047 State
:= Homonym
(State
);
28050 -- A function can never act as a state. If the homonym chain does
28051 -- not contain a corresponding state, then something went wrong in
28052 -- the overloading mechanism.
28054 raise Program_Error
;
28059 ----------------------------
28060 -- Rewrite_Assertion_Kind --
28061 ----------------------------
28063 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
28067 if Nkind
(N
) = N_Attribute_Reference
28068 and then Attribute_Name
(N
) = Name_Class
28069 and then Nkind
(Prefix
(N
)) = N_Identifier
28071 case Chars
(Prefix
(N
)) is
28076 when Name_Type_Invariant
=>
28077 Nam
:= Name_uType_Invariant
;
28078 when Name_Invariant
=>
28079 Nam
:= Name_uInvariant
;
28084 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
28086 end Rewrite_Assertion_Kind
;
28094 Dummy
:= Dummy
+ 1;
28097 --------------------------------
28098 -- Set_Encoded_Interface_Name --
28099 --------------------------------
28101 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
28102 Str
: constant String_Id
:= Strval
(S
);
28103 Len
: constant Int
:= String_Length
(Str
);
28108 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
28111 -- Stores encoded value of character code CC. The encoding we use an
28112 -- underscore followed by four lower case hex digits.
28118 procedure Encode
is
28120 Store_String_Char
(Get_Char_Code
('_'));
28122 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
28124 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
28126 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
28128 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
28131 -- Start of processing for Set_Encoded_Interface_Name
28134 -- If first character is asterisk, this is a link name, and we leave it
28135 -- completely unmodified. We also ignore null strings (the latter case
28136 -- happens only in error cases) and no encoding should occur for AAMP
28137 -- interface names.
28140 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
28141 or else AAMP_On_Target
28143 Set_Interface_Name
(E
, S
);
28148 CC
:= Get_String_Char
(Str
, J
);
28150 exit when not In_Character_Range
(CC
);
28152 C
:= Get_Character
(CC
);
28154 exit when C
/= '_' and then C
/= '$'
28155 and then C
not in '0' .. '9'
28156 and then C
not in 'a' .. 'z'
28157 and then C
not in 'A' .. 'Z';
28160 Set_Interface_Name
(E
, S
);
28168 -- Here we need to encode. The encoding we use as follows:
28169 -- three underscores + four hex digits (lower case)
28173 for J
in 1 .. String_Length
(Str
) loop
28174 CC
:= Get_String_Char
(Str
, J
);
28176 if not In_Character_Range
(CC
) then
28179 C
:= Get_Character
(CC
);
28181 if C
= '_' or else C
= '$'
28182 or else C
in '0' .. '9'
28183 or else C
in 'a' .. 'z'
28184 or else C
in 'A' .. 'Z'
28186 Store_String_Char
(CC
);
28193 Set_Interface_Name
(E
,
28194 Make_String_Literal
(Sloc
(S
),
28195 Strval
=> End_String
));
28197 end Set_Encoded_Interface_Name
;
28199 ------------------------
28200 -- Set_Elab_Unit_Name --
28201 ------------------------
28203 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
28208 if Nkind
(N
) = N_Identifier
28209 and then Nkind
(With_Item
) = N_Identifier
28211 Set_Entity
(N
, Entity
(With_Item
));
28213 elsif Nkind
(N
) = N_Selected_Component
then
28214 Change_Selected_Component_To_Expanded_Name
(N
);
28215 Set_Entity
(N
, Entity
(With_Item
));
28216 Set_Entity
(Selector_Name
(N
), Entity
(N
));
28218 Pref
:= Prefix
(N
);
28219 Scop
:= Scope
(Entity
(N
));
28220 while Nkind
(Pref
) = N_Selected_Component
loop
28221 Change_Selected_Component_To_Expanded_Name
(Pref
);
28222 Set_Entity
(Selector_Name
(Pref
), Scop
);
28223 Set_Entity
(Pref
, Scop
);
28224 Pref
:= Prefix
(Pref
);
28225 Scop
:= Scope
(Scop
);
28228 Set_Entity
(Pref
, Scop
);
28231 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
28232 end Set_Elab_Unit_Name
;
28234 -------------------
28235 -- Test_Case_Arg --
28236 -------------------
28238 function Test_Case_Arg
28241 From_Aspect
: Boolean := False) return Node_Id
28243 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
28248 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
28253 -- The caller requests the aspect argument
28255 if From_Aspect
then
28256 if Present
(Aspect
)
28257 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
28259 Args
:= Expression
(Aspect
);
28261 -- "Name" and "Mode" may appear without an identifier as a
28262 -- positional association.
28264 if Present
(Expressions
(Args
)) then
28265 Arg
:= First
(Expressions
(Args
));
28267 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
28275 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
28280 -- Some or all arguments may appear as component associatons
28282 if Present
(Component_Associations
(Args
)) then
28283 Arg
:= First
(Component_Associations
(Args
));
28284 while Present
(Arg
) loop
28285 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
28294 -- Otherwise retrieve the argument directly from the pragma
28297 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
28299 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
28303 -- Skip argument "Name"
28307 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
28311 -- Skip argument "Mode"
28315 -- Arguments "Requires" and "Ensures" are optional and may not be
28318 while Present
(Arg
) loop
28319 if Chars
(Arg
) = Arg_Nam
then