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 Contract_Freeze_Error
212 (Contract_Id
: Entity_Id
;
213 Freeze_Id
: Entity_Id
);
214 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
215 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
216 -- of a body which caused contract "freezing" and Contract_Id denotes the
217 -- entity of the affected contstruct.
219 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
220 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
221 -- Prag that duplicates previous pragma Prev.
223 function Find_Related_Context
225 Do_Checks
: Boolean := False) return Node_Id
;
226 -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers,
227 -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and
228 -- Part_Of. Find the first source declaration or statement found while
229 -- traversing the previous node chain starting from pragma Prag. If flag
230 -- Do_Checks is set, the routine reports duplicate pragmas. The routine
231 -- returns Empty when reaching the start of the node chain.
233 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
234 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
235 -- original one, following the renaming chain) is returned. Otherwise the
236 -- entity is returned unchanged. Should be in Einfo???
238 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
239 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
240 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
243 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
244 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
245 -- Determine whether dependency clause Clause is surrounded by extra
246 -- parentheses. If this is the case, issue an error message.
248 function Is_CCT_Instance
(Ref
: Node_Id
) return Boolean;
249 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
250 -- Global. Determine whether reference Ref denotes the current instance of
251 -- a concurrent type.
253 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
254 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
255 -- pragma Depends. Determine whether the type of dependency item Item is
256 -- tagged, unconstrained array, unconstrained record or a record with at
257 -- least one unconstrained component.
259 procedure Record_Possible_Body_Reference
260 (State_Id
: Entity_Id
;
262 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
263 -- Global. Given an abstract state denoted by State_Id and a reference Ref
264 -- to it, determine whether the reference appears in a package body that
265 -- will eventually refine the state. If this is the case, record the
266 -- reference for future checks (see Analyze_Refined_State_In_Decls).
268 procedure Resolve_State
(N
: Node_Id
);
269 -- Handle the overloading of state names by functions. When N denotes a
270 -- function, this routine finds the corresponding state and sets the entity
271 -- of N to that of the state.
273 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
274 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
275 -- then it is rewritten as an identifier with the corresponding special
276 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
279 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
280 -- Place semantic information on the argument of an Elaborate/Elaborate_All
281 -- pragma. Entity name for unit and its parents is taken from item in
282 -- previous with_clause that mentions the unit.
284 Dummy
: Integer := 0;
285 pragma Volatile
(Dummy
);
286 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
289 pragma No_Inline
(ip
);
290 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
291 -- is just to help debugging the front end. If a pragma Inspection_Point
292 -- is added to a source program, then breaking on ip will get you to that
293 -- point in the program.
296 pragma No_Inline
(rv
);
297 -- This is a dummy function called by the processing for pragma Reviewable.
298 -- It is there for assisting front end debugging. By placing a Reviewable
299 -- pragma in the source program, a breakpoint on rv catches this place in
300 -- the source, allowing convenient stepping to the point of interest.
302 -------------------------------
303 -- Adjust_External_Name_Case --
304 -------------------------------
306 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
310 -- Adjust case of literal if required
312 if Opt
.External_Name_Exp_Casing
= As_Is
then
316 -- Copy existing string
322 for J
in 1 .. String_Length
(Strval
(N
)) loop
323 CC
:= Get_String_Char
(Strval
(N
), J
);
325 if Opt
.External_Name_Exp_Casing
= Uppercase
326 and then CC
>= Get_Char_Code
('a')
327 and then CC
<= Get_Char_Code
('z')
329 Store_String_Char
(CC
- 32);
331 elsif Opt
.External_Name_Exp_Casing
= Lowercase
332 and then CC
>= Get_Char_Code
('A')
333 and then CC
<= Get_Char_Code
('Z')
335 Store_String_Char
(CC
+ 32);
338 Store_String_Char
(CC
);
343 Make_String_Literal
(Sloc
(N
),
344 Strval
=> End_String
);
346 end Adjust_External_Name_Case
;
348 -----------------------------------------
349 -- Analyze_Contract_Cases_In_Decl_Part --
350 -----------------------------------------
352 procedure Analyze_Contract_Cases_In_Decl_Part
354 Freeze_Id
: Entity_Id
:= Empty
)
356 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
357 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
359 Others_Seen
: Boolean := False;
360 -- This flag is set when an "others" choice is encountered. It is used
361 -- to detect multiple illegal occurrences of "others".
363 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
364 -- Verify the legality of a single contract case
366 ---------------------------
367 -- Analyze_Contract_Case --
368 ---------------------------
370 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
371 Case_Guard
: Node_Id
;
374 Extra_Guard
: Node_Id
;
377 if Nkind
(CCase
) = N_Component_Association
then
378 Case_Guard
:= First
(Choices
(CCase
));
379 Conseq
:= Expression
(CCase
);
381 -- Each contract case must have exactly one case guard
383 Extra_Guard
:= Next
(Case_Guard
);
385 if Present
(Extra_Guard
) then
387 ("contract case must have exactly one case guard",
391 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
393 if Nkind
(Case_Guard
) = N_Others_Choice
then
396 ("only one others choice allowed in contract cases",
402 elsif Others_Seen
then
404 ("others must be the last choice in contract cases", N
);
407 -- Preanalyze the case guard and consequence
409 if Nkind
(Case_Guard
) /= N_Others_Choice
then
410 Errors
:= Serious_Errors_Detected
;
411 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
413 -- Emit a clarification message when the case guard contains
414 -- at least one undefined reference, possibly due to contract
417 if Errors
/= Serious_Errors_Detected
418 and then Present
(Freeze_Id
)
419 and then Has_Undefined_Reference
(Case_Guard
)
421 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
425 Errors
:= Serious_Errors_Detected
;
426 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
428 -- Emit a clarification message when the consequence contains
429 -- at least one undefined reference, possibly due to contract
432 if Errors
/= Serious_Errors_Detected
433 and then Present
(Freeze_Id
)
434 and then Has_Undefined_Reference
(Conseq
)
436 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
439 -- The contract case is malformed
442 Error_Msg_N
("wrong syntax in contract case", CCase
);
444 end Analyze_Contract_Case
;
448 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
450 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
453 Restore_Scope
: Boolean := False;
455 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
458 -- Do not analyze the pragma multiple times
460 if Is_Analyzed_Pragma
(N
) then
464 -- Set the Ghost mode in effect from the pragma. Due to the delayed
465 -- analysis of the pragma, the Ghost mode at point of declaration and
466 -- point of analysis may not necessarely be the same. Use the mode in
467 -- effect at the point of declaration.
471 -- Single and multiple contract cases must appear in aggregate form. If
472 -- this is not the case, then either the parser of the analysis of the
473 -- pragma failed to produce an aggregate.
475 pragma Assert
(Nkind
(CCases
) = N_Aggregate
);
477 if Present
(Component_Associations
(CCases
)) then
479 -- Ensure that the formal parameters are visible when analyzing all
480 -- clauses. This falls out of the general rule of aspects pertaining
481 -- to subprogram declarations.
483 if not In_Open_Scopes
(Spec_Id
) then
484 Restore_Scope
:= True;
485 Push_Scope
(Spec_Id
);
487 if Is_Generic_Subprogram
(Spec_Id
) then
488 Install_Generic_Formals
(Spec_Id
);
490 Install_Formals
(Spec_Id
);
494 CCase
:= First
(Component_Associations
(CCases
));
495 while Present
(CCase
) loop
496 Analyze_Contract_Case
(CCase
);
500 if Restore_Scope
then
504 -- Currently it is not possible to inline pre/postconditions on a
505 -- subprogram subject to pragma Inline_Always.
507 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
509 -- Otherwise the pragma is illegal
512 Error_Msg_N
("wrong syntax for constract cases", N
);
515 Ghost_Mode
:= Save_Ghost_Mode
;
516 Set_Is_Analyzed_Pragma
(N
);
517 end Analyze_Contract_Cases_In_Decl_Part
;
519 ----------------------------------
520 -- Analyze_Depends_In_Decl_Part --
521 ----------------------------------
523 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
524 Loc
: constant Source_Ptr
:= Sloc
(N
);
525 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
526 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
528 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
529 -- A list containing the entities of all the inputs processed so far.
530 -- The list is populated with unique entities because the same input
531 -- may appear in multiple input lists.
533 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
534 -- A list containing the entities of all the outputs processed so far.
535 -- The list is populated with unique entities because output items are
536 -- unique in a dependence relation.
538 Constits_Seen
: Elist_Id
:= No_Elist
;
539 -- A list containing the entities of all constituents processed so far.
540 -- It aids in detecting illegal usage of a state and a corresponding
541 -- constituent in pragma [Refinde_]Depends.
543 Global_Seen
: Boolean := False;
544 -- A flag set when pragma Global has been processed
546 Null_Output_Seen
: Boolean := False;
547 -- A flag used to track the legality of a null output
549 Result_Seen
: Boolean := False;
550 -- A flag set when Spec_Id'Result is processed
552 States_Seen
: Elist_Id
:= No_Elist
;
553 -- A list containing the entities of all states processed so far. It
554 -- helps in detecting illegal usage of a state and a corresponding
555 -- constituent in pragma [Refined_]Depends.
557 Subp_Inputs
: Elist_Id
:= No_Elist
;
558 Subp_Outputs
: Elist_Id
:= No_Elist
;
559 -- Two lists containing the full set of inputs and output of the related
560 -- subprograms. Note that these lists contain both nodes and entities.
562 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
563 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
564 -- to the name buffer. The individual kinds are as follows:
565 -- E_Abstract_State - "state"
566 -- E_Constant - "constant"
567 -- E_Discriminant - "discriminant"
568 -- E_Generic_In_Out_Parameter - "generic parameter"
569 -- E_Generic_In_Parameter - "generic parameter"
570 -- E_In_Parameter - "parameter"
571 -- E_In_Out_Parameter - "parameter"
572 -- E_Loop_Parameter - "loop parameter"
573 -- E_Out_Parameter - "parameter"
574 -- E_Protected_Type - "current instance of protected type"
575 -- E_Task_Type - "current instance of task type"
576 -- E_Variable - "global"
578 procedure Analyze_Dependency_Clause
581 -- Verify the legality of a single dependency clause. Flag Is_Last
582 -- denotes whether Clause is the last clause in the relation.
584 procedure Check_Function_Return
;
585 -- Verify that Funtion'Result appears as one of the outputs
586 -- (SPARK RM 6.1.5(10)).
593 -- Ensure that an item fulfils its designated input and/or output role
594 -- as specified by pragma Global (if any) or the enclosing context. If
595 -- this is not the case, emit an error. Item and Item_Id denote the
596 -- attributes of an item. Flag Is_Input should be set when item comes
597 -- from an input list. Flag Self_Ref should be set when the item is an
598 -- output and the dependency clause has operator "+".
600 procedure Check_Usage
601 (Subp_Items
: Elist_Id
;
602 Used_Items
: Elist_Id
;
604 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
605 -- error if this is not the case.
607 procedure Normalize_Clause
(Clause
: Node_Id
);
608 -- Remove a self-dependency "+" from the input list of a clause
610 -----------------------------
611 -- Add_Item_To_Name_Buffer --
612 -----------------------------
614 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
616 if Ekind
(Item_Id
) = E_Abstract_State
then
617 Add_Str_To_Name_Buffer
("state");
619 elsif Ekind
(Item_Id
) = E_Constant
then
620 Add_Str_To_Name_Buffer
("constant");
622 elsif Ekind
(Item_Id
) = E_Discriminant
then
623 Add_Str_To_Name_Buffer
("discriminant");
625 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
626 E_Generic_In_Parameter
)
628 Add_Str_To_Name_Buffer
("generic parameter");
630 elsif Is_Formal
(Item_Id
) then
631 Add_Str_To_Name_Buffer
("parameter");
633 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
634 Add_Str_To_Name_Buffer
("loop parameter");
636 elsif Ekind
(Item_Id
) = E_Protected_Type
637 or else Is_Single_Protected_Object
(Item_Id
)
639 Add_Str_To_Name_Buffer
("current instance of protected type");
641 elsif Ekind
(Item_Id
) = E_Task_Type
642 or else Is_Single_Task_Object
(Item_Id
)
644 Add_Str_To_Name_Buffer
("current instance of task type");
646 elsif Ekind
(Item_Id
) = E_Variable
then
647 Add_Str_To_Name_Buffer
("global");
649 -- The routine should not be called with non-SPARK items
654 end Add_Item_To_Name_Buffer
;
656 -------------------------------
657 -- Analyze_Dependency_Clause --
658 -------------------------------
660 procedure Analyze_Dependency_Clause
664 procedure Analyze_Input_List
(Inputs
: Node_Id
);
665 -- Verify the legality of a single input list
667 procedure Analyze_Input_Output
672 Seen
: in out Elist_Id
;
673 Null_Seen
: in out Boolean;
674 Non_Null_Seen
: in out Boolean);
675 -- Verify the legality of a single input or output item. Flag
676 -- Is_Input should be set whenever Item is an input, False when it
677 -- denotes an output. Flag Self_Ref should be set when the item is an
678 -- output and the dependency clause has a "+". Flag Top_Level should
679 -- be set whenever Item appears immediately within an input or output
680 -- list. Seen is a collection of all abstract states, objects and
681 -- formals processed so far. Flag Null_Seen denotes whether a null
682 -- input or output has been encountered. Flag Non_Null_Seen denotes
683 -- whether a non-null input or output has been encountered.
685 ------------------------
686 -- Analyze_Input_List --
687 ------------------------
689 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
690 Inputs_Seen
: Elist_Id
:= No_Elist
;
691 -- A list containing the entities of all inputs that appear in the
692 -- current input list.
694 Non_Null_Input_Seen
: Boolean := False;
695 Null_Input_Seen
: Boolean := False;
696 -- Flags used to check the legality of an input list
701 -- Multiple inputs appear as an aggregate
703 if Nkind
(Inputs
) = N_Aggregate
then
704 if Present
(Component_Associations
(Inputs
)) then
706 ("nested dependency relations not allowed", Inputs
);
708 elsif Present
(Expressions
(Inputs
)) then
709 Input
:= First
(Expressions
(Inputs
));
710 while Present
(Input
) loop
717 Null_Seen
=> Null_Input_Seen
,
718 Non_Null_Seen
=> Non_Null_Input_Seen
);
723 -- Syntax error, always report
726 Error_Msg_N
("malformed input dependency list", Inputs
);
729 -- Process a solitary input
738 Null_Seen
=> Null_Input_Seen
,
739 Non_Null_Seen
=> Non_Null_Input_Seen
);
742 -- Detect an illegal dependency clause of the form
746 if Null_Output_Seen
and then Null_Input_Seen
then
748 ("null dependency clause cannot have a null input list",
751 end Analyze_Input_List
;
753 --------------------------
754 -- Analyze_Input_Output --
755 --------------------------
757 procedure Analyze_Input_Output
762 Seen
: in out Elist_Id
;
763 Null_Seen
: in out Boolean;
764 Non_Null_Seen
: in out Boolean)
766 Is_Output
: constant Boolean := not Is_Input
;
771 -- Multiple input or output items appear as an aggregate
773 if Nkind
(Item
) = N_Aggregate
then
774 if not Top_Level
then
775 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
777 elsif Present
(Component_Associations
(Item
)) then
779 ("nested dependency relations not allowed", Item
);
781 -- Recursively analyze the grouped items
783 elsif Present
(Expressions
(Item
)) then
784 Grouped
:= First
(Expressions
(Item
));
785 while Present
(Grouped
) loop
788 Is_Input
=> Is_Input
,
789 Self_Ref
=> Self_Ref
,
792 Null_Seen
=> Null_Seen
,
793 Non_Null_Seen
=> Non_Null_Seen
);
798 -- Syntax error, always report
801 Error_Msg_N
("malformed dependency list", Item
);
804 -- Process attribute 'Result in the context of a dependency clause
806 elsif Is_Attribute_Result
(Item
) then
807 Non_Null_Seen
:= True;
811 -- Attribute 'Result is allowed to appear on the output side of
812 -- a dependency clause (SPARK RM 6.1.5(6)).
815 SPARK_Msg_N
("function result cannot act as input", Item
);
819 ("cannot mix null and non-null dependency items", Item
);
825 -- Detect multiple uses of null in a single dependency list or
826 -- throughout the whole relation. Verify the placement of a null
827 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
829 elsif Nkind
(Item
) = N_Null
then
832 ("multiple null dependency relations not allowed", Item
);
834 elsif Non_Null_Seen
then
836 ("cannot mix null and non-null dependency items", Item
);
844 ("null output list must be the last clause in a "
845 & "dependency relation", Item
);
847 -- Catch a useless dependence of the form:
852 ("useless dependence, null depends on itself", Item
);
860 Non_Null_Seen
:= True;
863 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
867 Resolve_State
(Item
);
869 -- Find the entity of the item. If this is a renaming, climb
870 -- the renaming chain to reach the root object. Renamings of
871 -- non-entire objects do not yield an entity (Empty).
873 Item_Id
:= Entity_Of
(Item
);
875 if Present
(Item_Id
) then
879 if Ekind_In
(Item_Id
, E_Constant
,
884 -- Current instances of concurrent types
886 Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
891 Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
892 E_Generic_In_Parameter
,
900 Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
902 -- The item denotes a concurrent type, but it is not the
903 -- current instance of an enclosing concurrent type.
905 if Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
906 and then not Is_CCT_Instance
(Item
)
909 ("invalid use of subtype mark in dependency "
913 -- Ensure that the item fulfils its role as input and/or
914 -- output as specified by pragma Global or the enclosing
917 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
919 -- Detect multiple uses of the same state, variable or
920 -- formal parameter. If this is not the case, add the
921 -- item to the list of processed relations.
923 if Contains
(Seen
, Item_Id
) then
925 ("duplicate use of item &", Item
, Item_Id
);
927 Append_New_Elmt
(Item_Id
, Seen
);
930 -- Detect illegal use of an input related to a null
931 -- output. Such input items cannot appear in other
932 -- input lists (SPARK RM 6.1.5(13)).
935 and then Null_Output_Seen
936 and then Contains
(All_Inputs_Seen
, Item_Id
)
939 ("input of a null output list cannot appear in "
940 & "multiple input lists", Item
);
943 -- Add an input or a self-referential output to the list
944 -- of all processed inputs.
946 if Is_Input
or else Self_Ref
then
947 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
950 -- State related checks (SPARK RM 6.1.5(3))
952 if Ekind
(Item_Id
) = E_Abstract_State
then
954 -- Package and subprogram bodies are instantiated
955 -- individually in a separate compiler pass. Due to
956 -- this mode of instantiation, the refinement of a
957 -- state may no longer be visible when a subprogram
958 -- body contract is instantiated. Since the generic
959 -- template is legal, do not perform this check in
960 -- the instance to circumvent this oddity.
962 if Is_Generic_Instance
(Spec_Id
) then
965 -- An abstract state with visible refinement cannot
966 -- appear in pragma [Refined_]Depends as its place
967 -- must be taken by some of its constituents
968 -- (SPARK RM 6.1.4(7)).
970 elsif Has_Visible_Refinement
(Item_Id
) then
972 ("cannot mention state & in dependence relation",
974 SPARK_Msg_N
("\use its constituents instead", Item
);
977 -- If the reference to the abstract state appears in
978 -- an enclosing package body that will eventually
979 -- refine the state, record the reference for future
983 Record_Possible_Body_Reference
984 (State_Id
=> Item_Id
,
989 -- When the item renames an entire object, replace the
990 -- item with a reference to the object.
992 if Entity
(Item
) /= Item_Id
then
994 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
998 -- Add the entity of the current item to the list of
1001 if Ekind
(Item_Id
) = E_Abstract_State
then
1002 Append_New_Elmt
(Item_Id
, States_Seen
);
1004 -- The variable may eventually become a constituent of a
1005 -- single protected/task type. Record the reference now
1006 -- and verify its legality when analyzing the contract of
1007 -- the variable (SPARK RM 9.3).
1009 elsif Ekind
(Item_Id
) = E_Variable
then
1010 Record_Possible_Part_Of_Reference
1015 if Ekind_In
(Item_Id
, E_Abstract_State
,
1018 and then Present
(Encapsulating_State
(Item_Id
))
1020 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1023 -- All other input/output items are illegal
1024 -- (SPARK RM 6.1.5(1)).
1028 ("item must denote parameter, variable, state or "
1029 & "current instance of concurren type", Item
);
1032 -- All other input/output items are illegal
1033 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1037 ("item must denote parameter, variable, state or current "
1038 & "instance of concurrent type", Item
);
1041 end Analyze_Input_Output
;
1049 Non_Null_Output_Seen
: Boolean := False;
1050 -- Flag used to check the legality of an output list
1052 -- Start of processing for Analyze_Dependency_Clause
1055 Inputs
:= Expression
(Clause
);
1058 -- An input list with a self-dependency appears as operator "+" where
1059 -- the actuals inputs are the right operand.
1061 if Nkind
(Inputs
) = N_Op_Plus
then
1062 Inputs
:= Right_Opnd
(Inputs
);
1066 -- Process the output_list of a dependency_clause
1068 Output
:= First
(Choices
(Clause
));
1069 while Present
(Output
) loop
1070 Analyze_Input_Output
1073 Self_Ref
=> Self_Ref
,
1075 Seen
=> All_Outputs_Seen
,
1076 Null_Seen
=> Null_Output_Seen
,
1077 Non_Null_Seen
=> Non_Null_Output_Seen
);
1082 -- Process the input_list of a dependency_clause
1084 Analyze_Input_List
(Inputs
);
1085 end Analyze_Dependency_Clause
;
1087 ---------------------------
1088 -- Check_Function_Return --
1089 ---------------------------
1091 procedure Check_Function_Return
is
1093 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
1094 and then not Result_Seen
1097 ("result of & must appear in exactly one output list",
1100 end Check_Function_Return
;
1106 procedure Check_Role
1108 Item_Id
: Entity_Id
;
1113 (Item_Is_Input
: out Boolean;
1114 Item_Is_Output
: out Boolean);
1115 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1116 -- Item_Is_Output are set depending on the role.
1118 procedure Role_Error
1119 (Item_Is_Input
: Boolean;
1120 Item_Is_Output
: Boolean);
1121 -- Emit an error message concerning the incorrect use of Item in
1122 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1123 -- denote whether the item is an input and/or an output.
1130 (Item_Is_Input
: out Boolean;
1131 Item_Is_Output
: out Boolean)
1134 Item_Is_Input
:= False;
1135 Item_Is_Output
:= False;
1139 if Ekind
(Item_Id
) = E_Abstract_State
then
1141 -- When pragma Global is present, the mode of the state may be
1142 -- further constrained by setting a more restrictive mode.
1145 if Appears_In
(Subp_Inputs
, Item_Id
) then
1146 Item_Is_Input
:= True;
1149 if Appears_In
(Subp_Outputs
, Item_Id
) then
1150 Item_Is_Output
:= True;
1153 -- Otherwise the state has a default IN OUT mode
1156 Item_Is_Input
:= True;
1157 Item_Is_Output
:= True;
1162 elsif Ekind_In
(Item_Id
, E_Constant
,
1166 Item_Is_Input
:= True;
1170 elsif Ekind_In
(Item_Id
, E_Generic_In_Parameter
,
1173 Item_Is_Input
:= True;
1175 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
1178 Item_Is_Input
:= True;
1179 Item_Is_Output
:= True;
1181 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1182 if Scope
(Item_Id
) = Spec_Id
then
1184 -- An OUT parameter of the related subprogram has mode IN
1185 -- if its type is unconstrained or tagged because array
1186 -- bounds, discriminants or tags can be read.
1188 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1189 Item_Is_Input
:= True;
1192 Item_Is_Output
:= True;
1194 -- An OUT parameter of an enclosing subprogram behaves as a
1195 -- read-write variable in which case the mode is IN OUT.
1198 Item_Is_Input
:= True;
1199 Item_Is_Output
:= True;
1204 elsif Ekind
(Item_Id
) = E_Protected_Type
then
1206 -- A protected type acts as a formal parameter of mode IN when
1207 -- it applies to a protected function.
1209 if Ekind
(Spec_Id
) = E_Function
then
1210 Item_Is_Input
:= True;
1212 -- Otherwise the protected type acts as a formal of mode IN OUT
1215 Item_Is_Input
:= True;
1216 Item_Is_Output
:= True;
1221 elsif Ekind
(Item_Id
) = E_Task_Type
then
1222 Item_Is_Input
:= True;
1223 Item_Is_Output
:= True;
1227 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1229 -- When pragma Global is present, the mode of the variable may
1230 -- be further constrained by setting a more restrictive mode.
1234 -- A variable has mode IN when its type is unconstrained or
1235 -- tagged because array bounds, discriminants or tags can be
1238 if Appears_In
(Subp_Inputs
, Item_Id
)
1239 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1241 Item_Is_Input
:= True;
1244 if Appears_In
(Subp_Outputs
, Item_Id
) then
1245 Item_Is_Output
:= True;
1248 -- Otherwise the variable has a default IN OUT mode
1251 Item_Is_Input
:= True;
1252 Item_Is_Output
:= True;
1261 procedure Role_Error
1262 (Item_Is_Input
: Boolean;
1263 Item_Is_Output
: Boolean)
1265 Error_Msg
: Name_Id
;
1270 -- When the item is not part of the input and the output set of
1271 -- the related subprogram, then it appears as extra in pragma
1272 -- [Refined_]Depends.
1274 if not Item_Is_Input
and then not Item_Is_Output
then
1275 Add_Item_To_Name_Buffer
(Item_Id
);
1276 Add_Str_To_Name_Buffer
1277 (" & cannot appear in dependence relation");
1279 Error_Msg
:= Name_Find
;
1280 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1282 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1284 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1285 & "set of subprogram %"), Item
, Item_Id
);
1287 -- The mode of the item and its role in pragma [Refined_]Depends
1288 -- are in conflict. Construct a detailed message explaining the
1289 -- illegality (SPARK RM 6.1.5(5-6)).
1292 if Item_Is_Input
then
1293 Add_Str_To_Name_Buffer
("read-only");
1295 Add_Str_To_Name_Buffer
("write-only");
1298 Add_Char_To_Name_Buffer
(' ');
1299 Add_Item_To_Name_Buffer
(Item_Id
);
1300 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1302 if Item_Is_Input
then
1303 Add_Str_To_Name_Buffer
("output");
1305 Add_Str_To_Name_Buffer
("input");
1308 Add_Str_To_Name_Buffer
(" in dependence relation");
1309 Error_Msg
:= Name_Find
;
1310 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1316 Item_Is_Input
: Boolean;
1317 Item_Is_Output
: Boolean;
1319 -- Start of processing for Check_Role
1322 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1327 if not Item_Is_Input
then
1328 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1331 -- Self-referential item
1334 if not Item_Is_Input
or else not Item_Is_Output
then
1335 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1340 elsif not Item_Is_Output
then
1341 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1349 procedure Check_Usage
1350 (Subp_Items
: Elist_Id
;
1351 Used_Items
: Elist_Id
;
1354 procedure Usage_Error
(Item_Id
: Entity_Id
);
1355 -- Emit an error concerning the illegal usage of an item
1361 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1362 Error_Msg
: Name_Id
;
1369 -- Unconstrained and tagged items are not part of the explicit
1370 -- input set of the related subprogram, they do not have to be
1371 -- present in a dependence relation and should not be flagged
1372 -- (SPARK RM 6.1.5(8)).
1374 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1377 Add_Item_To_Name_Buffer
(Item_Id
);
1378 Add_Str_To_Name_Buffer
1379 (" & is missing from input dependence list");
1381 Error_Msg
:= Name_Find
;
1382 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1385 -- Output case (SPARK RM 6.1.5(10))
1390 Add_Item_To_Name_Buffer
(Item_Id
);
1391 Add_Str_To_Name_Buffer
1392 (" & is missing from output dependence list");
1394 Error_Msg
:= Name_Find
;
1395 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1403 Item_Id
: Entity_Id
;
1405 -- Start of processing for Check_Usage
1408 if No
(Subp_Items
) then
1412 -- Each input or output of the subprogram must appear in a dependency
1415 Elmt
:= First_Elmt
(Subp_Items
);
1416 while Present
(Elmt
) loop
1417 Item
:= Node
(Elmt
);
1419 if Nkind
(Item
) = N_Defining_Identifier
then
1422 Item_Id
:= Entity_Of
(Item
);
1425 -- The item does not appear in a dependency
1427 if Present
(Item_Id
)
1428 and then not Contains
(Used_Items
, Item_Id
)
1430 -- The current instance of a concurrent type behaves as a
1431 -- formal parameter (SPARK RM 6.1.4).
1433 if Is_Formal
(Item_Id
)
1434 or else Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
1436 Usage_Error
(Item_Id
);
1438 -- States and global objects are not used properly only when
1439 -- the subprogram is subject to pragma Global.
1441 elsif Global_Seen
then
1442 Usage_Error
(Item_Id
);
1450 ----------------------
1451 -- Normalize_Clause --
1452 ----------------------
1454 procedure Normalize_Clause
(Clause
: Node_Id
) is
1455 procedure Create_Or_Modify_Clause
1461 Multiple
: Boolean);
1462 -- Create a brand new clause to represent the self-reference or
1463 -- modify the input and/or output lists of an existing clause. Output
1464 -- denotes a self-referencial output. Outputs is the output list of a
1465 -- clause. Inputs is the input list of a clause. After denotes the
1466 -- clause after which the new clause is to be inserted. Flag In_Place
1467 -- should be set when normalizing the last output of an output list.
1468 -- Flag Multiple should be set when Output comes from a list with
1471 -----------------------------
1472 -- Create_Or_Modify_Clause --
1473 -----------------------------
1475 procedure Create_Or_Modify_Clause
1483 procedure Propagate_Output
1486 -- Handle the various cases of output propagation to the input
1487 -- list. Output denotes a self-referencial output item. Inputs
1488 -- is the input list of a clause.
1490 ----------------------
1491 -- Propagate_Output --
1492 ----------------------
1494 procedure Propagate_Output
1498 function In_Input_List
1500 Inputs
: List_Id
) return Boolean;
1501 -- Determine whether a particulat item appears in the input
1502 -- list of a clause.
1508 function In_Input_List
1510 Inputs
: List_Id
) return Boolean
1515 Elmt
:= First
(Inputs
);
1516 while Present
(Elmt
) loop
1517 if Entity_Of
(Elmt
) = Item
then
1529 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1532 -- Start of processing for Propagate_Output
1535 -- The clause is of the form:
1537 -- (Output =>+ null)
1539 -- Remove null input and replace it with a copy of the output:
1541 -- (Output => Output)
1543 if Nkind
(Inputs
) = N_Null
then
1544 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1546 -- The clause is of the form:
1548 -- (Output =>+ (Input1, ..., InputN))
1550 -- Determine whether the output is not already mentioned in the
1551 -- input list and if not, add it to the list of inputs:
1553 -- (Output => (Output, Input1, ..., InputN))
1555 elsif Nkind
(Inputs
) = N_Aggregate
then
1556 Grouped
:= Expressions
(Inputs
);
1558 if not In_Input_List
1562 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1565 -- The clause is of the form:
1567 -- (Output =>+ Input)
1569 -- If the input does not mention the output, group the two
1572 -- (Output => (Output, Input))
1574 elsif Entity_Of
(Inputs
) /= Output_Id
then
1576 Make_Aggregate
(Loc
,
1577 Expressions
=> New_List
(
1578 New_Copy_Tree
(Output
),
1579 New_Copy_Tree
(Inputs
))));
1581 end Propagate_Output
;
1585 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1586 New_Clause
: Node_Id
;
1588 -- Start of processing for Create_Or_Modify_Clause
1591 -- A null output depending on itself does not require any
1594 if Nkind
(Output
) = N_Null
then
1597 -- A function result cannot depend on itself because it cannot
1598 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1600 elsif Is_Attribute_Result
(Output
) then
1601 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1605 -- When performing the transformation in place, simply add the
1606 -- output to the list of inputs (if not already there). This
1607 -- case arises when dealing with the last output of an output
1608 -- list. Perform the normalization in place to avoid generating
1609 -- a malformed tree.
1612 Propagate_Output
(Output
, Inputs
);
1614 -- A list with multiple outputs is slowly trimmed until only
1615 -- one element remains. When this happens, replace aggregate
1616 -- with the element itself.
1620 Rewrite
(Outputs
, Output
);
1626 -- Unchain the output from its output list as it will appear in
1627 -- a new clause. Note that we cannot simply rewrite the output
1628 -- as null because this will violate the semantics of pragma
1633 -- Generate a new clause of the form:
1634 -- (Output => Inputs)
1637 Make_Component_Association
(Loc
,
1638 Choices
=> New_List
(Output
),
1639 Expression
=> New_Copy_Tree
(Inputs
));
1641 -- The new clause contains replicated content that has already
1642 -- been analyzed. There is not need to reanalyze or renormalize
1645 Set_Analyzed
(New_Clause
);
1648 (Output
=> First
(Choices
(New_Clause
)),
1649 Inputs
=> Expression
(New_Clause
));
1651 Insert_After
(After
, New_Clause
);
1653 end Create_Or_Modify_Clause
;
1657 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1659 Last_Output
: Node_Id
;
1660 Next_Output
: Node_Id
;
1663 -- Start of processing for Normalize_Clause
1666 -- A self-dependency appears as operator "+". Remove the "+" from the
1667 -- tree by moving the real inputs to their proper place.
1669 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1670 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1671 Inputs
:= Expression
(Clause
);
1673 -- Multiple outputs appear as an aggregate
1675 if Nkind
(Outputs
) = N_Aggregate
then
1676 Last_Output
:= Last
(Expressions
(Outputs
));
1678 Output
:= First
(Expressions
(Outputs
));
1679 while Present
(Output
) loop
1681 -- Normalization may remove an output from its list,
1682 -- preserve the subsequent output now.
1684 Next_Output
:= Next
(Output
);
1686 Create_Or_Modify_Clause
1691 In_Place
=> Output
= Last_Output
,
1694 Output
:= Next_Output
;
1700 Create_Or_Modify_Clause
1709 end Normalize_Clause
;
1713 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1714 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1718 Last_Clause
: Node_Id
;
1719 Restore_Scope
: Boolean := False;
1721 -- Start of processing for Analyze_Depends_In_Decl_Part
1724 -- Do not analyze the pragma multiple times
1726 if Is_Analyzed_Pragma
(N
) then
1730 -- Empty dependency list
1732 if Nkind
(Deps
) = N_Null
then
1734 -- Gather all states, objects and formal parameters that the
1735 -- subprogram may depend on. These items are obtained from the
1736 -- parameter profile or pragma [Refined_]Global (if available).
1738 Collect_Subprogram_Inputs_Outputs
1739 (Subp_Id
=> Subp_Id
,
1740 Subp_Inputs
=> Subp_Inputs
,
1741 Subp_Outputs
=> Subp_Outputs
,
1742 Global_Seen
=> Global_Seen
);
1744 -- Verify that every input or output of the subprogram appear in a
1747 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1748 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1749 Check_Function_Return
;
1751 -- Dependency clauses appear as component associations of an aggregate
1753 elsif Nkind
(Deps
) = N_Aggregate
then
1755 -- Do not attempt to perform analysis of a syntactically illegal
1756 -- clause as this will lead to misleading errors.
1758 if Has_Extra_Parentheses
(Deps
) then
1762 if Present
(Component_Associations
(Deps
)) then
1763 Last_Clause
:= Last
(Component_Associations
(Deps
));
1765 -- Gather all states, objects and formal parameters that the
1766 -- subprogram may depend on. These items are obtained from the
1767 -- parameter profile or pragma [Refined_]Global (if available).
1769 Collect_Subprogram_Inputs_Outputs
1770 (Subp_Id
=> Subp_Id
,
1771 Subp_Inputs
=> Subp_Inputs
,
1772 Subp_Outputs
=> Subp_Outputs
,
1773 Global_Seen
=> Global_Seen
);
1775 -- When pragma [Refined_]Depends appears on a single concurrent
1776 -- type, it is relocated to the anonymous object.
1778 if Is_Single_Concurrent_Object
(Spec_Id
) then
1781 -- Ensure that the formal parameters are visible when analyzing
1782 -- all clauses. This falls out of the general rule of aspects
1783 -- pertaining to subprogram declarations.
1785 elsif not In_Open_Scopes
(Spec_Id
) then
1786 Restore_Scope
:= True;
1787 Push_Scope
(Spec_Id
);
1789 if Ekind
(Spec_Id
) = E_Task_Type
then
1790 if Has_Discriminants
(Spec_Id
) then
1791 Install_Discriminants
(Spec_Id
);
1794 elsif Is_Generic_Subprogram
(Spec_Id
) then
1795 Install_Generic_Formals
(Spec_Id
);
1798 Install_Formals
(Spec_Id
);
1802 Clause
:= First
(Component_Associations
(Deps
));
1803 while Present
(Clause
) loop
1804 Errors
:= Serious_Errors_Detected
;
1806 -- The normalization mechanism may create extra clauses that
1807 -- contain replicated input and output names. There is no need
1808 -- to reanalyze them.
1810 if not Analyzed
(Clause
) then
1811 Set_Analyzed
(Clause
);
1813 Analyze_Dependency_Clause
1815 Is_Last
=> Clause
= Last_Clause
);
1818 -- Do not normalize a clause if errors were detected (count
1819 -- of Serious_Errors has increased) because the inputs and/or
1820 -- outputs may denote illegal items. Normalization is disabled
1821 -- in ASIS mode as it alters the tree by introducing new nodes
1822 -- similar to expansion.
1824 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1825 Normalize_Clause
(Clause
);
1831 if Restore_Scope
then
1835 -- Verify that every input or output of the subprogram appear in a
1838 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1839 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1840 Check_Function_Return
;
1842 -- The dependency list is malformed. This is a syntax error, always
1846 Error_Msg_N
("malformed dependency relation", Deps
);
1850 -- The top level dependency relation is malformed. This is a syntax
1851 -- error, always report.
1854 Error_Msg_N
("malformed dependency relation", Deps
);
1858 -- Ensure that a state and a corresponding constituent do not appear
1859 -- together in pragma [Refined_]Depends.
1861 Check_State_And_Constituent_Use
1862 (States
=> States_Seen
,
1863 Constits
=> Constits_Seen
,
1867 Set_Is_Analyzed_Pragma
(N
);
1868 end Analyze_Depends_In_Decl_Part
;
1870 --------------------------------------------
1871 -- Analyze_External_Property_In_Decl_Part --
1872 --------------------------------------------
1874 procedure Analyze_External_Property_In_Decl_Part
1876 Expr_Val
: out Boolean)
1878 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1879 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
1880 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
1886 -- Do not analyze the pragma multiple times
1888 if Is_Analyzed_Pragma
(N
) then
1892 Error_Msg_Name_1
:= Pragma_Name
(N
);
1894 -- An external property pragma must apply to an effectively volatile
1895 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1896 -- The check is performed at the end of the declarative region due to a
1897 -- possible out-of-order arrangement of pragmas:
1900 -- pragma Async_Readers (Obj);
1901 -- pragma Volatile (Obj);
1903 if not Is_Effectively_Volatile
(Obj_Id
) then
1905 ("external property % must apply to a volatile object", N
);
1908 -- Ensure that the Boolean expression (if present) is static. A missing
1909 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1913 if Present
(Arg1
) then
1914 Expr
:= Get_Pragma_Arg
(Arg1
);
1916 if Is_OK_Static_Expression
(Expr
) then
1917 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
1921 Set_Is_Analyzed_Pragma
(N
);
1922 end Analyze_External_Property_In_Decl_Part
;
1924 ---------------------------------
1925 -- Analyze_Global_In_Decl_Part --
1926 ---------------------------------
1928 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
1929 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
1930 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
1931 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1933 Constits_Seen
: Elist_Id
:= No_Elist
;
1934 -- A list containing the entities of all constituents processed so far.
1935 -- It aids in detecting illegal usage of a state and a corresponding
1936 -- constituent in pragma [Refinde_]Global.
1938 Seen
: Elist_Id
:= No_Elist
;
1939 -- A list containing the entities of all the items processed so far. It
1940 -- plays a role in detecting distinct entities.
1942 States_Seen
: Elist_Id
:= No_Elist
;
1943 -- A list containing the entities of all states processed so far. It
1944 -- helps in detecting illegal usage of a state and a corresponding
1945 -- constituent in pragma [Refined_]Global.
1947 In_Out_Seen
: Boolean := False;
1948 Input_Seen
: Boolean := False;
1949 Output_Seen
: Boolean := False;
1950 Proof_Seen
: Boolean := False;
1951 -- Flags used to verify the consistency of modes
1953 procedure Analyze_Global_List
1955 Global_Mode
: Name_Id
:= Name_Input
);
1956 -- Verify the legality of a single global list declaration. Global_Mode
1957 -- denotes the current mode in effect.
1959 -------------------------
1960 -- Analyze_Global_List --
1961 -------------------------
1963 procedure Analyze_Global_List
1965 Global_Mode
: Name_Id
:= Name_Input
)
1967 procedure Analyze_Global_Item
1969 Global_Mode
: Name_Id
);
1970 -- Verify the legality of a single global item declaration denoted by
1971 -- Item. Global_Mode denotes the current mode in effect.
1973 procedure Check_Duplicate_Mode
1975 Status
: in out Boolean);
1976 -- Flag Status denotes whether a particular mode has been seen while
1977 -- processing a global list. This routine verifies that Mode is not a
1978 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1980 procedure Check_Mode_Restriction_In_Enclosing_Context
1982 Item_Id
: Entity_Id
);
1983 -- Verify that an item of mode In_Out or Output does not appear as an
1984 -- input in the Global aspect of an enclosing subprogram. If this is
1985 -- the case, emit an error. Item and Item_Id are respectively the
1986 -- item and its entity.
1988 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
1989 -- Mode denotes either In_Out or Output. Depending on the kind of the
1990 -- related subprogram, emit an error if those two modes apply to a
1991 -- function (SPARK RM 6.1.4(10)).
1993 -------------------------
1994 -- Analyze_Global_Item --
1995 -------------------------
1997 procedure Analyze_Global_Item
1999 Global_Mode
: Name_Id
)
2001 Item_Id
: Entity_Id
;
2004 -- Detect one of the following cases
2006 -- with Global => (null, Name)
2007 -- with Global => (Name_1, null, Name_2)
2008 -- with Global => (Name, null)
2010 if Nkind
(Item
) = N_Null
then
2011 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2016 Resolve_State
(Item
);
2018 -- Find the entity of the item. If this is a renaming, climb the
2019 -- renaming chain to reach the root object. Renamings of non-
2020 -- entire objects do not yield an entity (Empty).
2022 Item_Id
:= Entity_Of
(Item
);
2024 if Present
(Item_Id
) then
2026 -- A global item may denote a formal parameter of an enclosing
2027 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2028 -- provide a better error diagnostic.
2030 if Is_Formal
(Item_Id
) then
2031 if Scope
(Item_Id
) = Spec_Id
then
2033 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2034 & "parameter of subprogram &"), Item
, Spec_Id
);
2038 -- A global item may denote a concurrent type as long as it is
2039 -- the current instance of an enclosing concurrent type
2040 -- (SPARK RM 6.1.4).
2042 elsif Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
2043 if Is_CCT_Instance
(Item
) then
2045 -- Pragma [Refined_]Global associated with a protected
2046 -- subprogram cannot mention the current instance of a
2047 -- protected type because the instance behaves as a
2048 -- formal parameter.
2050 if Ekind
(Item_Id
) = E_Protected_Type
2051 and then Scope
(Spec_Id
) = Item_Id
2053 Error_Msg_Name_1
:= Chars
(Item_Id
);
2055 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2056 & "cannot reference current instance of protected "
2057 & "type %"), Item
, Spec_Id
);
2060 -- Pragma [Refined_]Global associated with a task type
2061 -- cannot mention the current instance of a task type
2062 -- because the instance behaves as a formal parameter.
2064 elsif Ekind
(Item_Id
) = E_Task_Type
2065 and then Spec_Id
= Item_Id
2067 Error_Msg_Name_1
:= Chars
(Item_Id
);
2069 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2070 & "cannot reference current instance of task type "
2071 & "%"), Item
, Spec_Id
);
2075 -- Otherwise the global item denotes a subtype mark that is
2076 -- not a current instance.
2080 ("invalid use of subtype mark in global list", Item
);
2084 -- A formal object may act as a global item inside a generic
2086 elsif Is_Formal_Object
(Item_Id
) then
2089 -- The only legal references are those to abstract states,
2090 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2092 elsif not Ekind_In
(Item_Id
, E_Abstract_State
,
2099 ("global item must denote object, state or current "
2100 & "instance of concurrent type", Item
);
2104 -- State related checks
2106 if Ekind
(Item_Id
) = E_Abstract_State
then
2108 -- Package and subprogram bodies are instantiated
2109 -- individually in a separate compiler pass. Due to this
2110 -- mode of instantiation, the refinement of a state may
2111 -- no longer be visible when a subprogram body contract
2112 -- is instantiated. Since the generic template is legal,
2113 -- do not perform this check in the instance to circumvent
2116 if Is_Generic_Instance
(Spec_Id
) then
2119 -- An abstract state with visible refinement cannot appear
2120 -- in pragma [Refined_]Global as its place must be taken by
2121 -- some of its constituents (SPARK RM 6.1.4(7)).
2123 elsif Has_Visible_Refinement
(Item_Id
) then
2125 ("cannot mention state & in global refinement",
2127 SPARK_Msg_N
("\use its constituents instead", Item
);
2130 -- An external state cannot appear as a global item of a
2131 -- nonvolatile function (SPARK RM 7.1.3(8)).
2133 elsif Is_External_State
(Item_Id
)
2134 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2135 and then not Is_Volatile_Function
(Spec_Id
)
2138 ("external state & cannot act as global item of "
2139 & "nonvolatile function", Item
, Item_Id
);
2142 -- If the reference to the abstract state appears in an
2143 -- enclosing package body that will eventually refine the
2144 -- state, record the reference for future checks.
2147 Record_Possible_Body_Reference
2148 (State_Id
=> Item_Id
,
2152 -- Constant related checks
2154 elsif Ekind
(Item_Id
) = E_Constant
then
2156 -- A constant is a read-only item, therefore it cannot act
2159 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2161 ("constant & cannot act as output", Item
, Item_Id
);
2165 -- Discriminant related checks
2167 elsif Ekind
(Item_Id
) = E_Discriminant
then
2169 -- A discriminant is a read-only item, therefore it cannot
2170 -- act as an output.
2172 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2174 ("discriminant & cannot act as output", Item
, Item_Id
);
2178 -- Loop parameter related checks
2180 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2182 -- A loop parameter is a read-only item, therefore it cannot
2183 -- act as an output.
2185 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2187 ("loop parameter & cannot act as output",
2192 -- Variable related checks. These are only relevant when
2193 -- SPARK_Mode is on as they are not standard Ada legality
2196 elsif SPARK_Mode
= On
2197 and then Ekind
(Item_Id
) = E_Variable
2198 and then Is_Effectively_Volatile
(Item_Id
)
2200 -- An effectively volatile object cannot appear as a global
2201 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2203 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2204 and then not Is_Volatile_Function
(Spec_Id
)
2207 ("volatile object & cannot act as global item of a "
2208 & "function", Item
, Item_Id
);
2211 -- An effectively volatile object with external property
2212 -- Effective_Reads set to True must have mode Output or
2213 -- In_Out (SPARK RM 7.1.3(11)).
2215 elsif Effective_Reads_Enabled
(Item_Id
)
2216 and then Global_Mode
= Name_Input
2219 ("volatile object & with property Effective_Reads must "
2220 & "have mode In_Out or Output", Item
, Item_Id
);
2225 -- When the item renames an entire object, replace the item
2226 -- with a reference to the object.
2228 if Entity
(Item
) /= Item_Id
then
2229 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2233 -- Some form of illegal construct masquerading as a name
2234 -- (SPARK RM 6.1.4(4)).
2238 ("global item must denote object, state or current instance "
2239 & "of concurrent type", Item
);
2243 -- Verify that an output does not appear as an input in an
2244 -- enclosing subprogram.
2246 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2247 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2250 -- The same entity might be referenced through various way.
2251 -- Check the entity of the item rather than the item itself
2252 -- (SPARK RM 6.1.4(10)).
2254 if Contains
(Seen
, Item_Id
) then
2255 SPARK_Msg_N
("duplicate global item", Item
);
2257 -- Add the entity of the current item to the list of processed
2261 Append_New_Elmt
(Item_Id
, Seen
);
2263 if Ekind
(Item_Id
) = E_Abstract_State
then
2264 Append_New_Elmt
(Item_Id
, States_Seen
);
2266 -- The variable may eventually become a constituent of a single
2267 -- protected/task type. Record the reference now and verify its
2268 -- legality when analyzing the contract of the variable
2271 elsif Ekind
(Item_Id
) = E_Variable
then
2272 Record_Possible_Part_Of_Reference
2277 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
2278 and then Present
(Encapsulating_State
(Item_Id
))
2280 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2283 end Analyze_Global_Item
;
2285 --------------------------
2286 -- Check_Duplicate_Mode --
2287 --------------------------
2289 procedure Check_Duplicate_Mode
2291 Status
: in out Boolean)
2295 SPARK_Msg_N
("duplicate global mode", Mode
);
2299 end Check_Duplicate_Mode
;
2301 -------------------------------------------------
2302 -- Check_Mode_Restriction_In_Enclosing_Context --
2303 -------------------------------------------------
2305 procedure Check_Mode_Restriction_In_Enclosing_Context
2307 Item_Id
: Entity_Id
)
2309 Context
: Entity_Id
;
2311 Inputs
: Elist_Id
:= No_Elist
;
2312 Outputs
: Elist_Id
:= No_Elist
;
2315 -- Traverse the scope stack looking for enclosing subprograms
2316 -- subject to pragma [Refined_]Global.
2318 Context
:= Scope
(Subp_Id
);
2319 while Present
(Context
) and then Context
/= Standard_Standard
loop
2320 if Is_Subprogram
(Context
)
2322 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2324 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2326 Collect_Subprogram_Inputs_Outputs
2327 (Subp_Id
=> Context
,
2328 Subp_Inputs
=> Inputs
,
2329 Subp_Outputs
=> Outputs
,
2330 Global_Seen
=> Dummy
);
2332 -- The item is classified as In_Out or Output but appears as
2333 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2335 if Appears_In
(Inputs
, Item_Id
)
2336 and then not Appears_In
(Outputs
, Item_Id
)
2339 ("global item & cannot have mode In_Out or Output",
2343 (Fix_Msg
(Subp_Id
, "\item already appears as input of "
2344 & "subprogram &"), Item
, Context
);
2346 -- Stop the traversal once an error has been detected
2352 Context
:= Scope
(Context
);
2354 end Check_Mode_Restriction_In_Enclosing_Context
;
2356 ----------------------------------------
2357 -- Check_Mode_Restriction_In_Function --
2358 ----------------------------------------
2360 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2362 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2364 ("global mode & is not applicable to functions", Mode
);
2366 end Check_Mode_Restriction_In_Function
;
2374 -- Start of processing for Analyze_Global_List
2377 if Nkind
(List
) = N_Null
then
2378 Set_Analyzed
(List
);
2380 -- Single global item declaration
2382 elsif Nkind_In
(List
, N_Expanded_Name
,
2384 N_Selected_Component
)
2386 Analyze_Global_Item
(List
, Global_Mode
);
2388 -- Simple global list or moded global list declaration
2390 elsif Nkind
(List
) = N_Aggregate
then
2391 Set_Analyzed
(List
);
2393 -- The declaration of a simple global list appear as a collection
2396 if Present
(Expressions
(List
)) then
2397 if Present
(Component_Associations
(List
)) then
2399 ("cannot mix moded and non-moded global lists", List
);
2402 Item
:= First
(Expressions
(List
));
2403 while Present
(Item
) loop
2404 Analyze_Global_Item
(Item
, Global_Mode
);
2408 -- The declaration of a moded global list appears as a collection
2409 -- of component associations where individual choices denote
2412 elsif Present
(Component_Associations
(List
)) then
2413 if Present
(Expressions
(List
)) then
2415 ("cannot mix moded and non-moded global lists", List
);
2418 Assoc
:= First
(Component_Associations
(List
));
2419 while Present
(Assoc
) loop
2420 Mode
:= First
(Choices
(Assoc
));
2422 if Nkind
(Mode
) = N_Identifier
then
2423 if Chars
(Mode
) = Name_In_Out
then
2424 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2425 Check_Mode_Restriction_In_Function
(Mode
);
2427 elsif Chars
(Mode
) = Name_Input
then
2428 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2430 elsif Chars
(Mode
) = Name_Output
then
2431 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2432 Check_Mode_Restriction_In_Function
(Mode
);
2434 elsif Chars
(Mode
) = Name_Proof_In
then
2435 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2438 SPARK_Msg_N
("invalid mode selector", Mode
);
2442 SPARK_Msg_N
("invalid mode selector", Mode
);
2445 -- Items in a moded list appear as a collection of
2446 -- expressions. Reuse the existing machinery to analyze
2450 (List
=> Expression
(Assoc
),
2451 Global_Mode
=> Chars
(Mode
));
2459 raise Program_Error
;
2462 -- Any other attempt to declare a global item is illegal. This is a
2463 -- syntax error, always report.
2466 Error_Msg_N
("malformed global list", List
);
2468 end Analyze_Global_List
;
2472 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2474 Restore_Scope
: Boolean := False;
2476 -- Start of processing for Analyze_Global_In_Decl_Part
2479 -- Do not analyze the pragma multiple times
2481 if Is_Analyzed_Pragma
(N
) then
2485 -- There is nothing to be done for a null global list
2487 if Nkind
(Items
) = N_Null
then
2488 Set_Analyzed
(Items
);
2490 -- Analyze the various forms of global lists and items. Note that some
2491 -- of these may be malformed in which case the analysis emits error
2495 -- When pragma [Refined_]Global appears on a single concurrent type,
2496 -- it is relocated to the anonymous object.
2498 if Is_Single_Concurrent_Object
(Spec_Id
) then
2501 -- Ensure that the formal parameters are visible when processing an
2502 -- item. This falls out of the general rule of aspects pertaining to
2503 -- subprogram declarations.
2505 elsif not In_Open_Scopes
(Spec_Id
) then
2506 Restore_Scope
:= True;
2507 Push_Scope
(Spec_Id
);
2509 if Ekind
(Spec_Id
) = E_Task_Type
then
2510 if Has_Discriminants
(Spec_Id
) then
2511 Install_Discriminants
(Spec_Id
);
2514 elsif Is_Generic_Subprogram
(Spec_Id
) then
2515 Install_Generic_Formals
(Spec_Id
);
2518 Install_Formals
(Spec_Id
);
2522 Analyze_Global_List
(Items
);
2524 if Restore_Scope
then
2529 -- Ensure that a state and a corresponding constituent do not appear
2530 -- together in pragma [Refined_]Global.
2532 Check_State_And_Constituent_Use
2533 (States
=> States_Seen
,
2534 Constits
=> Constits_Seen
,
2537 Set_Is_Analyzed_Pragma
(N
);
2538 end Analyze_Global_In_Decl_Part
;
2540 --------------------------------------------
2541 -- Analyze_Initial_Condition_In_Decl_Part --
2542 --------------------------------------------
2544 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2545 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2546 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2547 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2549 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2552 -- Do not analyze the pragma multiple times
2554 if Is_Analyzed_Pragma
(N
) then
2558 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2559 -- analysis of the pragma, the Ghost mode at point of declaration and
2560 -- point of analysis may not necessarely be the same. Use the mode in
2561 -- effect at the point of declaration.
2565 -- The expression is preanalyzed because it has not been moved to its
2566 -- final place yet. A direct analysis may generate side effects and this
2567 -- is not desired at this point.
2569 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2570 Ghost_Mode
:= Save_Ghost_Mode
;
2572 Set_Is_Analyzed_Pragma
(N
);
2573 end Analyze_Initial_Condition_In_Decl_Part
;
2575 --------------------------------------
2576 -- Analyze_Initializes_In_Decl_Part --
2577 --------------------------------------
2579 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2580 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2581 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2583 Constits_Seen
: Elist_Id
:= No_Elist
;
2584 -- A list containing the entities of all constituents processed so far.
2585 -- It aids in detecting illegal usage of a state and a corresponding
2586 -- constituent in pragma Initializes.
2588 Items_Seen
: Elist_Id
:= No_Elist
;
2589 -- A list of all initialization items processed so far. This list is
2590 -- used to detect duplicate items.
2592 Non_Null_Seen
: Boolean := False;
2593 Null_Seen
: Boolean := False;
2594 -- Flags used to check the legality of a null initialization list
2596 States_And_Objs
: Elist_Id
:= No_Elist
;
2597 -- A list of all abstract states and objects declared in the visible
2598 -- declarations of the related package. This list is used to detect the
2599 -- legality of initialization items.
2601 States_Seen
: Elist_Id
:= No_Elist
;
2602 -- A list containing the entities of all states processed so far. It
2603 -- helps in detecting illegal usage of a state and a corresponding
2604 -- constituent in pragma Initializes.
2606 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2607 -- Verify the legality of a single initialization item
2609 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2610 -- Verify the legality of a single initialization item followed by a
2611 -- list of input items.
2613 procedure Collect_States_And_Objects
;
2614 -- Inspect the visible declarations of the related package and gather
2615 -- the entities of all abstract states and objects in States_And_Objs.
2617 ---------------------------------
2618 -- Analyze_Initialization_Item --
2619 ---------------------------------
2621 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2622 Item_Id
: Entity_Id
;
2625 -- Null initialization list
2627 if Nkind
(Item
) = N_Null
then
2629 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2631 elsif Non_Null_Seen
then
2633 ("cannot mix null and non-null initialization items", Item
);
2638 -- Initialization item
2641 Non_Null_Seen
:= True;
2645 ("cannot mix null and non-null initialization items", Item
);
2649 Resolve_State
(Item
);
2651 if Is_Entity_Name
(Item
) then
2652 Item_Id
:= Entity_Of
(Item
);
2654 if Ekind_In
(Item_Id
, E_Abstract_State
,
2658 -- The state or variable must be declared in the visible
2659 -- declarations of the package (SPARK RM 7.1.5(7)).
2661 if not Contains
(States_And_Objs
, Item_Id
) then
2662 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2664 ("initialization item & must appear in the visible "
2665 & "declarations of package %", Item
, Item_Id
);
2667 -- Detect a duplicate use of the same initialization item
2668 -- (SPARK RM 7.1.5(5)).
2670 elsif Contains
(Items_Seen
, Item_Id
) then
2671 SPARK_Msg_N
("duplicate initialization item", Item
);
2673 -- The item is legal, add it to the list of processed states
2677 Append_New_Elmt
(Item_Id
, Items_Seen
);
2679 if Ekind
(Item_Id
) = E_Abstract_State
then
2680 Append_New_Elmt
(Item_Id
, States_Seen
);
2683 if Present
(Encapsulating_State
(Item_Id
)) then
2684 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2688 -- The item references something that is not a state or object
2689 -- (SPARK RM 7.1.5(3)).
2693 ("initialization item must denote object or state", Item
);
2696 -- Some form of illegal construct masquerading as a name
2697 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2701 ("initialization item must denote object or state", Item
);
2704 end Analyze_Initialization_Item
;
2706 ---------------------------------------------
2707 -- Analyze_Initialization_Item_With_Inputs --
2708 ---------------------------------------------
2710 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2711 Inputs_Seen
: Elist_Id
:= No_Elist
;
2712 -- A list of all inputs processed so far. This list is used to detect
2713 -- duplicate uses of an input.
2715 Non_Null_Seen
: Boolean := False;
2716 Null_Seen
: Boolean := False;
2717 -- Flags used to check the legality of an input list
2719 procedure Analyze_Input_Item
(Input
: Node_Id
);
2720 -- Verify the legality of a single input item
2722 ------------------------
2723 -- Analyze_Input_Item --
2724 ------------------------
2726 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2727 Input_Id
: Entity_Id
;
2732 if Nkind
(Input
) = N_Null
then
2735 ("multiple null initializations not allowed", Item
);
2737 elsif Non_Null_Seen
then
2739 ("cannot mix null and non-null initialization item", Item
);
2747 Non_Null_Seen
:= True;
2751 ("cannot mix null and non-null initialization item", Item
);
2755 Resolve_State
(Input
);
2757 if Is_Entity_Name
(Input
) then
2758 Input_Id
:= Entity_Of
(Input
);
2760 if Ekind_In
(Input_Id
, E_Abstract_State
,
2767 -- The input cannot denote states or objects declared
2768 -- within the related package (SPARK RM 7.1.5(4)).
2770 if Within_Scope
(Input_Id
, Current_Scope
) then
2771 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2773 ("input item & cannot denote a visible object or "
2774 & "state of package %", Input
, Input_Id
);
2776 -- Detect a duplicate use of the same input item
2777 -- (SPARK RM 7.1.5(5)).
2779 elsif Contains
(Inputs_Seen
, Input_Id
) then
2780 SPARK_Msg_N
("duplicate input item", Input
);
2782 -- Input is legal, add it to the list of processed inputs
2785 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2787 if Ekind
(Input_Id
) = E_Abstract_State
then
2788 Append_New_Elmt
(Input_Id
, States_Seen
);
2791 if Ekind_In
(Input_Id
, E_Abstract_State
,
2794 and then Present
(Encapsulating_State
(Input_Id
))
2796 Append_New_Elmt
(Input_Id
, Constits_Seen
);
2800 -- The input references something that is not a state or an
2801 -- object (SPARK RM 7.1.5(3)).
2805 ("input item must denote object or state", Input
);
2808 -- Some form of illegal construct masquerading as a name
2809 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2813 ("input item must denote object or state", Input
);
2816 end Analyze_Input_Item
;
2820 Inputs
: constant Node_Id
:= Expression
(Item
);
2824 Name_Seen
: Boolean := False;
2825 -- A flag used to detect multiple item names
2827 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2830 -- Inspect the name of an item with inputs
2832 Elmt
:= First
(Choices
(Item
));
2833 while Present
(Elmt
) loop
2835 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
2838 Analyze_Initialization_Item
(Elmt
);
2844 -- Multiple input items appear as an aggregate
2846 if Nkind
(Inputs
) = N_Aggregate
then
2847 if Present
(Expressions
(Inputs
)) then
2848 Input
:= First
(Expressions
(Inputs
));
2849 while Present
(Input
) loop
2850 Analyze_Input_Item
(Input
);
2855 if Present
(Component_Associations
(Inputs
)) then
2857 ("inputs must appear in named association form", Inputs
);
2860 -- Single input item
2863 Analyze_Input_Item
(Inputs
);
2865 end Analyze_Initialization_Item_With_Inputs
;
2867 --------------------------------
2868 -- Collect_States_And_Objects --
2869 --------------------------------
2871 procedure Collect_States_And_Objects
is
2872 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
2876 -- Collect the abstract states defined in the package (if any)
2878 if Present
(Abstract_States
(Pack_Id
)) then
2879 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
2882 -- Collect all objects the appear in the visible declarations of the
2885 if Present
(Visible_Declarations
(Pack_Spec
)) then
2886 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
2887 while Present
(Decl
) loop
2888 if Comes_From_Source
(Decl
)
2889 and then Nkind
(Decl
) = N_Object_Declaration
2891 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
2897 end Collect_States_And_Objects
;
2901 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2904 -- Start of processing for Analyze_Initializes_In_Decl_Part
2907 -- Do not analyze the pragma multiple times
2909 if Is_Analyzed_Pragma
(N
) then
2913 -- Nothing to do when the initialization list is empty
2915 if Nkind
(Inits
) = N_Null
then
2919 -- Single and multiple initialization clauses appear as an aggregate. If
2920 -- this is not the case, then either the parser or the analysis of the
2921 -- pragma failed to produce an aggregate.
2923 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
2925 -- Initialize the various lists used during analysis
2927 Collect_States_And_Objects
;
2929 if Present
(Expressions
(Inits
)) then
2930 Init
:= First
(Expressions
(Inits
));
2931 while Present
(Init
) loop
2932 Analyze_Initialization_Item
(Init
);
2937 if Present
(Component_Associations
(Inits
)) then
2938 Init
:= First
(Component_Associations
(Inits
));
2939 while Present
(Init
) loop
2940 Analyze_Initialization_Item_With_Inputs
(Init
);
2945 -- Ensure that a state and a corresponding constituent do not appear
2946 -- together in pragma Initializes.
2948 Check_State_And_Constituent_Use
2949 (States
=> States_Seen
,
2950 Constits
=> Constits_Seen
,
2953 Set_Is_Analyzed_Pragma
(N
);
2954 end Analyze_Initializes_In_Decl_Part
;
2956 ---------------------
2957 -- Analyze_Part_Of --
2958 ---------------------
2960 procedure Analyze_Part_Of
2962 Item_Id
: Entity_Id
;
2964 Encap_Id
: out Entity_Id
;
2965 Legal
: out Boolean)
2967 Encap_Typ
: Entity_Id
;
2968 Item_Decl
: Node_Id
;
2969 Pack_Id
: Entity_Id
;
2970 Placement
: State_Space_Kind
;
2971 Parent_Unit
: Entity_Id
;
2974 -- Assume that the indicator is illegal
2979 if Nkind_In
(Encap
, N_Expanded_Name
,
2981 N_Selected_Component
)
2984 Resolve_State
(Encap
);
2986 Encap_Id
:= Entity
(Encap
);
2988 -- The encapsulator is an abstract state
2990 if Ekind
(Encap_Id
) = E_Abstract_State
then
2993 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
2995 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
2998 -- Otherwise the encapsulator is not a legal choice
3002 ("indicator Part_Of must denote abstract state, single "
3003 & "protected type or single task type", Encap
);
3007 -- This is a syntax error, always report
3011 ("indicator Part_Of must denote abstract state, single protected "
3012 & "type or single task type", Encap
);
3016 -- Catch a case where indicator Part_Of denotes the abstract view of a
3017 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3019 if From_Limited_With
(Encap_Id
)
3020 and then Present
(Non_Limited_View
(Encap_Id
))
3021 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3023 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3024 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3028 -- The encapsulator is an abstract state
3030 if Ekind
(Encap_Id
) = E_Abstract_State
then
3032 -- Determine where the object, package instantiation or state lives
3033 -- with respect to the enclosing packages or package bodies.
3035 Find_Placement_In_State_Space
3036 (Item_Id
=> Item_Id
,
3037 Placement
=> Placement
,
3038 Pack_Id
=> Pack_Id
);
3040 -- The item appears in a non-package construct with a declarative
3041 -- part (subprogram, block, etc). As such, the item is not allowed
3042 -- to be a part of an encapsulating state because the item is not
3045 if Placement
= Not_In_Package
then
3047 ("indicator Part_Of cannot appear in this context "
3048 & "(SPARK RM 7.2.6(5))", Indic
);
3049 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3051 ("\& is not part of the hidden state of package %",
3054 -- The item appears in the visible state space of some package. In
3055 -- general this scenario does not warrant Part_Of except when the
3056 -- package is a private child unit and the encapsulating state is
3057 -- declared in a parent unit or a public descendant of that parent
3060 elsif Placement
= Visible_State_Space
then
3061 if Is_Child_Unit
(Pack_Id
)
3062 and then Is_Private_Descendant
(Pack_Id
)
3064 -- A variable or state abstraction which is part of the visible
3065 -- state of a private child unit (or one of its public
3066 -- descendants) must have its Part_Of indicator specified. The
3067 -- Part_Of indicator must denote a state abstraction declared
3068 -- by either the parent unit of the private unit or by a public
3069 -- descendant of that parent unit.
3071 -- Find nearest private ancestor (which can be the current unit
3074 Parent_Unit
:= Pack_Id
;
3075 while Present
(Parent_Unit
) loop
3078 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3079 Parent_Unit
:= Scope
(Parent_Unit
);
3082 Parent_Unit
:= Scope
(Parent_Unit
);
3084 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3086 ("indicator Part_Of must denote abstract state or public "
3087 & "descendant of & (SPARK RM 7.2.6(3))",
3088 Indic
, Parent_Unit
);
3090 elsif Scope
(Encap_Id
) = Parent_Unit
3092 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3093 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3099 ("indicator Part_Of must denote abstract state or public "
3100 & "descendant of & (SPARK RM 7.2.6(3))",
3101 Indic
, Parent_Unit
);
3104 -- Indicator Part_Of is not needed when the related package is not
3105 -- a private child unit or a public descendant thereof.
3109 ("indicator Part_Of cannot appear in this context "
3110 & "(SPARK RM 7.2.6(5))", Indic
);
3111 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3113 ("\& is declared in the visible part of package %",
3117 -- When the item appears in the private state space of a package, the
3118 -- encapsulating state must be declared in the same package.
3120 elsif Placement
= Private_State_Space
then
3121 if Scope
(Encap_Id
) /= Pack_Id
then
3123 ("indicator Part_Of must designate an abstract state of "
3124 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3125 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3127 ("\& is declared in the private part of package %",
3131 -- Items declared in the body state space of a package do not need
3132 -- Part_Of indicators as the refinement has already been seen.
3136 ("indicator Part_Of cannot appear in this context "
3137 & "(SPARK RM 7.2.6(5))", Indic
);
3139 if Scope
(Encap_Id
) = Pack_Id
then
3140 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3142 ("\& is declared in the body of package %", Indic
, Item_Id
);
3146 -- The encapsulator is a single concurrent type
3149 Encap_Typ
:= Etype
(Encap_Id
);
3151 -- Only abstract states and variables can act as constituents of an
3152 -- encapsulating single concurrent type.
3154 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3157 -- The constituent is a constant
3159 elsif Ekind
(Item_Id
) = E_Constant
then
3160 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3162 (Fix_Msg
(Encap_Typ
, "consant & cannot act as constituent of "
3163 & "single protected type %"), Indic
, Item_Id
);
3165 -- The constituent is a package instantiation
3168 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3170 (Fix_Msg
(Encap_Typ
, "package instantiation & cannot act as "
3171 & "constituent of single protected type %"), Indic
, Item_Id
);
3174 -- When the item denotes an abstract state of a nested package, use
3175 -- the declaration of the package to detect proper placement.
3180 -- with Abstract_State => (State with Part_Of => T)
3182 if Ekind
(Item_Id
) = E_Abstract_State
then
3183 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3185 Item_Decl
:= Declaration_Node
(Item_Id
);
3188 -- Both the item and its encapsulating single concurrent type must
3189 -- appear in the same declarative region (SPARK RM 9.3). Note that
3190 -- privacy is ignored.
3192 if Parent
(Item_Decl
) /= Parent
(Declaration_Node
(Encap_Id
)) then
3193 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3195 (Fix_Msg
(Encap_Typ
, "constituent & must be declared "
3196 & "immediately within the same region as single protected "
3197 & "type %"), Indic
, Item_Id
);
3202 end Analyze_Part_Of
;
3204 ----------------------------------
3205 -- Analyze_Part_Of_In_Decl_Part --
3206 ----------------------------------
3208 procedure Analyze_Part_Of_In_Decl_Part
3210 Freeze_Id
: Entity_Id
:= Empty
)
3212 Encap
: constant Node_Id
:=
3213 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3214 Errors
: constant Nat
:= Serious_Errors_Detected
;
3215 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3216 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3217 Encap_Id
: Entity_Id
;
3221 -- Detect any discrepancies between the placement of the variable with
3222 -- respect to general state space and the encapsulating state or single
3229 Encap_Id
=> Encap_Id
,
3232 -- The Part_Of indicator turns the variable into a constituent of the
3233 -- encapsulating state or single concurrent type.
3236 pragma Assert
(Present
(Encap_Id
));
3238 Append_Elmt
(Var_Id
, Part_Of_Constituents
(Encap_Id
));
3239 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3242 -- Emit a clarification message when the encapsulator is undefined,
3243 -- possibly due to contract "freezing".
3245 if Errors
/= Serious_Errors_Detected
3246 and then Present
(Freeze_Id
)
3247 and then Has_Undefined_Reference
(Encap
)
3249 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3251 end Analyze_Part_Of_In_Decl_Part
;
3253 --------------------
3254 -- Analyze_Pragma --
3255 --------------------
3257 procedure Analyze_Pragma
(N
: Node_Id
) is
3258 Loc
: constant Source_Ptr
:= Sloc
(N
);
3259 Prag_Id
: Pragma_Id
;
3262 -- Name of the source pragma, or name of the corresponding aspect for
3263 -- pragmas which originate in a source aspect. In the latter case, the
3264 -- name may be different from the pragma name.
3266 Pragma_Exit
: exception;
3267 -- This exception is used to exit pragma processing completely. It
3268 -- is used when an error is detected, and no further processing is
3269 -- required. It is also used if an earlier error has left the tree in
3270 -- a state where the pragma should not be processed.
3273 -- Number of pragma argument associations
3279 -- First four pragma arguments (pragma argument association nodes, or
3280 -- Empty if the corresponding argument does not exist).
3282 type Name_List
is array (Natural range <>) of Name_Id
;
3283 type Args_List
is array (Natural range <>) of Node_Id
;
3284 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3286 -----------------------
3287 -- Local Subprograms --
3288 -----------------------
3290 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3291 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3292 -- get the given string argument, and place it in Name_Buffer, adding
3293 -- leading and trailing asterisks if they are not already present. The
3294 -- caller has already checked that Arg is a static string expression.
3296 procedure Ada_2005_Pragma
;
3297 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3298 -- Ada 95 mode, these are implementation defined pragmas, so should be
3299 -- caught by the No_Implementation_Pragmas restriction.
3301 procedure Ada_2012_Pragma
;
3302 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3303 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3304 -- should be caught by the No_Implementation_Pragmas restriction.
3306 procedure Analyze_Depends_Global
3307 (Spec_Id
: out Entity_Id
;
3308 Subp_Decl
: out Node_Id
;
3309 Legal
: out Boolean);
3310 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3311 -- legality of the placement and related context of the pragma. Spec_Id
3312 -- is the entity of the related subprogram. Subp_Decl is the declaration
3313 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3315 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3316 -- Inspect the remainder of the list containing pragma N and look for
3317 -- a pragma that matches Id. If found, analyze the pragma.
3319 procedure Analyze_Pre_Post_Condition
;
3320 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3322 procedure Analyze_Refined_Depends_Global_Post
3323 (Spec_Id
: out Entity_Id
;
3324 Body_Id
: out Entity_Id
;
3325 Legal
: out Boolean);
3326 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3327 -- Refined_Global and Refined_Post. Verify the legality of the placement
3328 -- and related context of the pragma. Spec_Id is the entity of the
3329 -- related subprogram. Body_Id is the entity of the subprogram body.
3330 -- Flag Legal is set when the pragma is legal.
3332 procedure Check_Ada_83_Warning
;
3333 -- Issues a warning message for the current pragma if operating in Ada
3334 -- 83 mode (used for language pragmas that are not a standard part of
3335 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3338 procedure Check_Arg_Count
(Required
: Nat
);
3339 -- Check argument count for pragma is equal to given parameter. If not,
3340 -- then issue an error message and raise Pragma_Exit.
3342 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3343 -- Arg which can either be a pragma argument association, in which case
3344 -- the check is applied to the expression of the association or an
3345 -- expression directly.
3347 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3348 -- Check that an argument has the right form for an EXTERNAL_NAME
3349 -- parameter of an extended import/export pragma. The rule is that the
3350 -- name must be an identifier or string literal (in Ada 83 mode) or a
3351 -- static string expression (in Ada 95 mode).
3353 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3354 -- Check the specified argument Arg to make sure that it is an
3355 -- identifier. If not give error and raise Pragma_Exit.
3357 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3358 -- Check the specified argument Arg to make sure that it is an integer
3359 -- literal. If not give error and raise Pragma_Exit.
3361 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3362 -- Check the specified argument Arg to make sure that it has the proper
3363 -- syntactic form for a local name and meets the semantic requirements
3364 -- for a local name. The local name is analyzed as part of the
3365 -- processing for this call. In addition, the local name is required
3366 -- to represent an entity at the library level.
3368 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
3369 -- Check the specified argument Arg to make sure that it has the proper
3370 -- syntactic form for a local name and meets the semantic requirements
3371 -- for a local name. The local name is analyzed as part of the
3372 -- processing for this call.
3374 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3375 -- Check the specified argument Arg to make sure that it is a valid
3376 -- locking policy name. If not give error and raise Pragma_Exit.
3378 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3379 -- Check the specified argument Arg to make sure that it is a valid
3380 -- elaboration policy name. If not give error and raise Pragma_Exit.
3382 procedure Check_Arg_Is_One_Of
3385 procedure Check_Arg_Is_One_Of
3387 N1
, N2
, N3
: Name_Id
);
3388 procedure Check_Arg_Is_One_Of
3390 N1
, N2
, N3
, N4
: Name_Id
);
3391 procedure Check_Arg_Is_One_Of
3393 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3394 -- Check the specified argument Arg to make sure that it is an
3395 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3396 -- present). If not then give error and raise Pragma_Exit.
3398 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3399 -- Check the specified argument Arg to make sure that it is a valid
3400 -- queuing policy name. If not give error and raise Pragma_Exit.
3402 procedure Check_Arg_Is_OK_Static_Expression
3404 Typ
: Entity_Id
:= Empty
);
3405 -- Check the specified argument Arg to make sure that it is a static
3406 -- expression of the given type (i.e. it will be analyzed and resolved
3407 -- using this type, which can be any valid argument to Resolve, e.g.
3408 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3409 -- Typ is left Empty, then any static expression is allowed. Includes
3410 -- checking that the argument does not raise Constraint_Error.
3412 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3413 -- Check the specified argument Arg to make sure that it is a valid task
3414 -- dispatching policy name. If not give error and raise Pragma_Exit.
3416 procedure Check_Arg_Order
(Names
: Name_List
);
3417 -- Checks for an instance of two arguments with identifiers for the
3418 -- current pragma which are not in the sequence indicated by Names,
3419 -- and if so, generates a fatal message about bad order of arguments.
3421 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3422 -- Check there are at least N arguments present
3424 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3425 -- Check there are no more than N arguments present
3427 procedure Check_Component
3430 In_Variant_Part
: Boolean := False);
3431 -- Examine an Unchecked_Union component for correct use of per-object
3432 -- constrained subtypes, and for restrictions on finalizable components.
3433 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3434 -- should be set when Comp comes from a record variant.
3436 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3437 -- Check if a rep item of the same name as the current pragma is already
3438 -- chained as a rep pragma to the given entity. If so give a message
3439 -- about the duplicate, and then raise Pragma_Exit so does not return.
3440 -- Note that if E is a type, then this routine avoids flagging a pragma
3441 -- which applies to a parent type from which E is derived.
3443 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3444 -- Nam is an N_String_Literal node containing the external name set by
3445 -- an Import or Export pragma (or extended Import or Export pragma).
3446 -- This procedure checks for possible duplications if this is the export
3447 -- case, and if found, issues an appropriate error message.
3449 procedure Check_Expr_Is_OK_Static_Expression
3451 Typ
: Entity_Id
:= Empty
);
3452 -- Check the specified expression Expr to make sure that it is a static
3453 -- expression of the given type (i.e. it will be analyzed and resolved
3454 -- using this type, which can be any valid argument to Resolve, e.g.
3455 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3456 -- Typ is left Empty, then any static expression is allowed. Includes
3457 -- checking that the expression does not raise Constraint_Error.
3459 procedure Check_First_Subtype
(Arg
: Node_Id
);
3460 -- Checks that Arg, whose expression is an entity name, references a
3463 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3464 -- Checks that the given argument has an identifier, and if so, requires
3465 -- it to match the given identifier name. If there is no identifier, or
3466 -- a non-matching identifier, then an error message is given and
3467 -- Pragma_Exit is raised.
3469 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3470 -- Checks that the given argument has an identifier, and if so, requires
3471 -- it to match one of the given identifier names. If there is no
3472 -- identifier, or a non-matching identifier, then an error message is
3473 -- given and Pragma_Exit is raised.
3475 procedure Check_In_Main_Program
;
3476 -- Common checks for pragmas that appear within a main program
3477 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3479 procedure Check_Interrupt_Or_Attach_Handler
;
3480 -- Common processing for first argument of pragma Interrupt_Handler or
3481 -- pragma Attach_Handler.
3483 procedure Check_Loop_Pragma_Placement
;
3484 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3485 -- appear immediately within a construct restricted to loops, and that
3486 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3488 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3489 -- Check that pragma appears in a declarative part, or in a package
3490 -- specification, i.e. that it does not occur in a statement sequence
3493 procedure Check_No_Identifier
(Arg
: Node_Id
);
3494 -- Checks that the given argument does not have an identifier. If
3495 -- an identifier is present, then an error message is issued, and
3496 -- Pragma_Exit is raised.
3498 procedure Check_No_Identifiers
;
3499 -- Checks that none of the arguments to the pragma has an identifier.
3500 -- If any argument has an identifier, then an error message is issued,
3501 -- and Pragma_Exit is raised.
3503 procedure Check_No_Link_Name
;
3504 -- Checks that no link name is specified
3506 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3507 -- Checks if the given argument has an identifier, and if so, requires
3508 -- it to match the given identifier name. If there is a non-matching
3509 -- identifier, then an error message is given and Pragma_Exit is raised.
3511 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3512 -- Checks if the given argument has an identifier, and if so, requires
3513 -- it to match the given identifier name. If there is a non-matching
3514 -- identifier, then an error message is given and Pragma_Exit is raised.
3515 -- In this version of the procedure, the identifier name is given as
3516 -- a string with lower case letters.
3518 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3519 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3520 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3521 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3522 -- is an OK static boolean expression. Emit an error if this is not the
3525 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3526 -- Constr is a constraint from an N_Subtype_Indication node from a
3527 -- component constraint in an Unchecked_Union type. This routine checks
3528 -- that the constraint is static as required by the restrictions for
3531 procedure Check_Valid_Configuration_Pragma
;
3532 -- Legality checks for placement of a configuration pragma
3534 procedure Check_Valid_Library_Unit_Pragma
;
3535 -- Legality checks for library unit pragmas. A special case arises for
3536 -- pragmas in generic instances that come from copies of the original
3537 -- library unit pragmas in the generic templates. In the case of other
3538 -- than library level instantiations these can appear in contexts which
3539 -- would normally be invalid (they only apply to the original template
3540 -- and to library level instantiations), and they are simply ignored,
3541 -- which is implemented by rewriting them as null statements.
3543 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3544 -- Check an Unchecked_Union variant for lack of nested variants and
3545 -- presence of at least one component. UU_Typ is the related Unchecked_
3548 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3549 -- Subsidiary routine to the processing of pragmas Abstract_State,
3550 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3551 -- Refined_Global and Refined_State. Transform argument Arg into
3552 -- an aggregate if not one already. N_Null is never transformed.
3553 -- Arg may denote an aspect specification or a pragma argument
3556 procedure Error_Pragma
(Msg
: String);
3557 pragma No_Return
(Error_Pragma
);
3558 -- Outputs error message for current pragma. The message contains a %
3559 -- that will be replaced with the pragma name, and the flag is placed
3560 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3561 -- calls Fix_Error (see spec of that procedure for details).
3563 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3564 pragma No_Return
(Error_Pragma_Arg
);
3565 -- Outputs error message for current pragma. The message may contain
3566 -- a % that will be replaced with the pragma name. The parameter Arg
3567 -- may either be a pragma argument association, in which case the flag
3568 -- is placed on the expression of this association, or an expression,
3569 -- in which case the flag is placed directly on the expression. The
3570 -- message is placed using Error_Msg_N, so the message may also contain
3571 -- an & insertion character which will reference the given Arg value.
3572 -- After placing the message, Pragma_Exit is raised. Note: this routine
3573 -- calls Fix_Error (see spec of that procedure for details).
3575 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3576 pragma No_Return
(Error_Pragma_Arg
);
3577 -- Similar to above form of Error_Pragma_Arg except that two messages
3578 -- are provided, the second is a continuation comment starting with \.
3580 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3581 pragma No_Return
(Error_Pragma_Arg_Ident
);
3582 -- Outputs error message for current pragma. The message may contain a %
3583 -- that will be replaced with the pragma name. The parameter Arg must be
3584 -- a pragma argument association with a non-empty identifier (i.e. its
3585 -- Chars field must be set), and the error message is placed on the
3586 -- identifier. The message is placed using Error_Msg_N so the message
3587 -- may also contain an & insertion character which will reference
3588 -- the identifier. After placing the message, Pragma_Exit is raised.
3589 -- Note: this routine calls Fix_Error (see spec of that procedure for
3592 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3593 pragma No_Return
(Error_Pragma_Ref
);
3594 -- Outputs error message for current pragma. The message may contain
3595 -- a % that will be replaced with the pragma name. The parameter Ref
3596 -- must be an entity whose name can be referenced by & and sloc by #.
3597 -- After placing the message, Pragma_Exit is raised. Note: this routine
3598 -- calls Fix_Error (see spec of that procedure for details).
3600 function Find_Lib_Unit_Name
return Entity_Id
;
3601 -- Used for a library unit pragma to find the entity to which the
3602 -- library unit pragma applies, returns the entity found.
3604 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3605 -- If the pragma is a compilation unit pragma, the id must denote the
3606 -- compilation unit in the same compilation, and the pragma must appear
3607 -- in the list of preceding or trailing pragmas. If it is a program
3608 -- unit pragma that is not a compilation unit pragma, then the
3609 -- identifier must be visible.
3611 function Find_Unique_Parameterless_Procedure
3613 Arg
: Node_Id
) return Entity_Id
;
3614 -- Used for a procedure pragma to find the unique parameterless
3615 -- procedure identified by Name, returns it if it exists, otherwise
3616 -- errors out and uses Arg as the pragma argument for the message.
3618 function Fix_Error
(Msg
: String) return String;
3619 -- This is called prior to issuing an error message. Msg is the normal
3620 -- error message issued in the pragma case. This routine checks for the
3621 -- case of a pragma coming from an aspect in the source, and returns a
3622 -- message suitable for the aspect case as follows:
3624 -- Each substring "pragma" is replaced by "aspect"
3626 -- If "argument of" is at the start of the error message text, it is
3627 -- replaced by "entity for".
3629 -- If "argument" is at the start of the error message text, it is
3630 -- replaced by "entity".
3632 -- So for example, "argument of pragma X must be discrete type"
3633 -- returns "entity for aspect X must be a discrete type".
3635 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3636 -- be different from the pragma name). If the current pragma results
3637 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3638 -- original pragma name.
3640 procedure Gather_Associations
3642 Args
: out Args_List
);
3643 -- This procedure is used to gather the arguments for a pragma that
3644 -- permits arbitrary ordering of parameters using the normal rules
3645 -- for named and positional parameters. The Names argument is a list
3646 -- of Name_Id values that corresponds to the allowed pragma argument
3647 -- association identifiers in order. The result returned in Args is
3648 -- a list of corresponding expressions that are the pragma arguments.
3649 -- Note that this is a list of expressions, not of pragma argument
3650 -- associations (Gather_Associations has completely checked all the
3651 -- optional identifiers when it returns). An entry in Args is Empty
3652 -- on return if the corresponding argument is not present.
3654 procedure GNAT_Pragma
;
3655 -- Called for all GNAT defined pragmas to check the relevant restriction
3656 -- (No_Implementation_Pragmas).
3658 function Is_Before_First_Decl
3659 (Pragma_Node
: Node_Id
;
3660 Decls
: List_Id
) return Boolean;
3661 -- Return True if Pragma_Node is before the first declarative item in
3662 -- Decls where Decls is the list of declarative items.
3664 function Is_Configuration_Pragma
return Boolean;
3665 -- Determines if the placement of the current pragma is appropriate
3666 -- for a configuration pragma.
3668 function Is_In_Context_Clause
return Boolean;
3669 -- Returns True if pragma appears within the context clause of a unit,
3670 -- and False for any other placement (does not generate any messages).
3672 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3673 -- Analyzes the argument, and determines if it is a static string
3674 -- expression, returns True if so, False if non-static or not String.
3675 -- A special case is that a string literal returns True in Ada 83 mode
3676 -- (which has no such thing as static string expressions). Note that
3677 -- the call analyzes its argument, so this cannot be used for the case
3678 -- where an identifier might not be declared.
3680 procedure Pragma_Misplaced
;
3681 pragma No_Return
(Pragma_Misplaced
);
3682 -- Issue fatal error message for misplaced pragma
3684 procedure Process_Atomic_Independent_Shared_Volatile
;
3685 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3686 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3687 -- and treated as being identical in effect to pragma Atomic.
3689 procedure Process_Compile_Time_Warning_Or_Error
;
3690 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3692 procedure Process_Convention
3693 (C
: out Convention_Id
;
3694 Ent
: out Entity_Id
);
3695 -- Common processing for Convention, Interface, Import and Export.
3696 -- Checks first two arguments of pragma, and sets the appropriate
3697 -- convention value in the specified entity or entities. On return
3698 -- C is the convention, Ent is the referenced entity.
3700 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3701 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3702 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3704 procedure Process_Extended_Import_Export_Object_Pragma
3705 (Arg_Internal
: Node_Id
;
3706 Arg_External
: Node_Id
;
3707 Arg_Size
: Node_Id
);
3708 -- Common processing for the pragmas Import/Export_Object. The three
3709 -- arguments correspond to the three named parameters of the pragmas. An
3710 -- argument is empty if the corresponding parameter is not present in
3713 procedure Process_Extended_Import_Export_Internal_Arg
3714 (Arg_Internal
: Node_Id
:= Empty
);
3715 -- Common processing for all extended Import and Export pragmas. The
3716 -- argument is the pragma parameter for the Internal argument. If
3717 -- Arg_Internal is empty or inappropriate, an error message is posted.
3718 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3719 -- set to identify the referenced entity.
3721 procedure Process_Extended_Import_Export_Subprogram_Pragma
3722 (Arg_Internal
: Node_Id
;
3723 Arg_External
: Node_Id
;
3724 Arg_Parameter_Types
: Node_Id
;
3725 Arg_Result_Type
: Node_Id
:= Empty
;
3726 Arg_Mechanism
: Node_Id
;
3727 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3728 -- Common processing for all extended Import and Export pragmas applying
3729 -- to subprograms. The caller omits any arguments that do not apply to
3730 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3731 -- only in the Import_Function and Export_Function cases). The argument
3732 -- names correspond to the allowed pragma association identifiers.
3734 procedure Process_Generic_List
;
3735 -- Common processing for Share_Generic and Inline_Generic
3737 procedure Process_Import_Or_Interface
;
3738 -- Common processing for Import or Interface
3740 procedure Process_Import_Predefined_Type
;
3741 -- Processing for completing a type with pragma Import. This is used
3742 -- to declare types that match predefined C types, especially for cases
3743 -- without corresponding Ada predefined type.
3745 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3746 -- Inline status of a subprogram, indicated as follows:
3747 -- Suppressed: inlining is suppressed for the subprogram
3748 -- Disabled: no inlining is requested for the subprogram
3749 -- Enabled: inlining is requested/required for the subprogram
3751 procedure Process_Inline
(Status
: Inline_Status
);
3752 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3753 -- indicates the inline status specified by the pragma.
3755 procedure Process_Interface_Name
3756 (Subprogram_Def
: Entity_Id
;
3758 Link_Arg
: Node_Id
);
3759 -- Given the last two arguments of pragma Import, pragma Export, or
3760 -- pragma Interface_Name, performs validity checks and sets the
3761 -- Interface_Name field of the given subprogram entity to the
3762 -- appropriate external or link name, depending on the arguments given.
3763 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3764 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3765 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3766 -- nor Link_Arg is present, the interface name is set to the default
3767 -- from the subprogram name.
3769 procedure Process_Interrupt_Or_Attach_Handler
;
3770 -- Common processing for Interrupt and Attach_Handler pragmas
3772 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3773 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3774 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3775 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3776 -- is not set in the Restrictions case.
3778 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3779 -- Common processing for Suppress and Unsuppress. The boolean parameter
3780 -- Suppress_Case is True for the Suppress case, and False for the
3783 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
3784 -- Subsidiary to the analysis of pragmas Independent[_Components].
3785 -- Record such a pragma N applied to entity E for future checks.
3787 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3788 -- This procedure sets the Is_Exported flag for the given entity,
3789 -- checking that the entity was not previously imported. Arg is
3790 -- the argument that specified the entity. A check is also made
3791 -- for exporting inappropriate entities.
3793 procedure Set_Extended_Import_Export_External_Name
3794 (Internal_Ent
: Entity_Id
;
3795 Arg_External
: Node_Id
);
3796 -- Common processing for all extended import export pragmas. The first
3797 -- argument, Internal_Ent, is the internal entity, which has already
3798 -- been checked for validity by the caller. Arg_External is from the
3799 -- Import or Export pragma, and may be null if no External parameter
3800 -- was present. If Arg_External is present and is a non-null string
3801 -- (a null string is treated as the default), then the Interface_Name
3802 -- field of Internal_Ent is set appropriately.
3804 procedure Set_Imported
(E
: Entity_Id
);
3805 -- This procedure sets the Is_Imported flag for the given entity,
3806 -- checking that it is not previously exported or imported.
3808 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3809 -- Mech is a parameter passing mechanism (see Import_Function syntax
3810 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3811 -- has the right form, and if not issues an error message. If the
3812 -- argument has the right form then the Mechanism field of Ent is
3813 -- set appropriately.
3815 procedure Set_Rational_Profile
;
3816 -- Activate the set of configuration pragmas and permissions that make
3817 -- up the Rational profile.
3819 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
3820 -- Activate the set of configuration pragmas and restrictions that make
3821 -- up the Profile. Profile must be either GNAT_Extended_Ravencar or
3822 -- Ravenscar. N is the corresponding pragma node, which is used for
3823 -- error messages on any constructs violating the profile.
3825 ----------------------------------
3826 -- Acquire_Warning_Match_String --
3827 ----------------------------------
3829 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3831 String_To_Name_Buffer
3832 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3834 -- Add asterisk at start if not already there
3836 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3837 Name_Buffer
(2 .. Name_Len
+ 1) :=
3838 Name_Buffer
(1 .. Name_Len
);
3839 Name_Buffer
(1) := '*';
3840 Name_Len
:= Name_Len
+ 1;
3843 -- Add asterisk at end if not already there
3845 if Name_Buffer
(Name_Len
) /= '*' then
3846 Name_Len
:= Name_Len
+ 1;
3847 Name_Buffer
(Name_Len
) := '*';
3849 end Acquire_Warning_Match_String
;
3851 ---------------------
3852 -- Ada_2005_Pragma --
3853 ---------------------
3855 procedure Ada_2005_Pragma
is
3857 if Ada_Version
<= Ada_95
then
3858 Check_Restriction
(No_Implementation_Pragmas
, N
);
3860 end Ada_2005_Pragma
;
3862 ---------------------
3863 -- Ada_2012_Pragma --
3864 ---------------------
3866 procedure Ada_2012_Pragma
is
3868 if Ada_Version
<= Ada_2005
then
3869 Check_Restriction
(No_Implementation_Pragmas
, N
);
3871 end Ada_2012_Pragma
;
3873 ----------------------------
3874 -- Analyze_Depends_Global --
3875 ----------------------------
3877 procedure Analyze_Depends_Global
3878 (Spec_Id
: out Entity_Id
;
3879 Subp_Decl
: out Node_Id
;
3880 Legal
: out Boolean)
3883 -- Assume that the pragma is illegal
3890 Check_Arg_Count
(1);
3892 -- Ensure the proper placement of the pragma. Depends/Global must be
3893 -- associated with a subprogram declaration or a body that acts as a
3896 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
3900 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
3903 -- Generic subprogram
3905 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
3908 -- Object declaration of a single concurrent type
3910 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
then
3915 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
3918 -- Subprogram body acts as spec
3920 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
3921 and then No
(Corresponding_Spec
(Subp_Decl
))
3925 -- Subprogram body stub acts as spec
3927 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
3928 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
3932 -- Subprogram declaration
3934 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
3939 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
3947 -- If we get here, then the pragma is legal
3950 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
3952 -- When the related context is an entry, the entry must belong to a
3953 -- protected unit (SPARK RM 6.1.4(6)).
3955 if Is_Entry_Declaration
(Spec_Id
)
3956 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
3961 -- When the related context is an anonymous object created for a
3962 -- simple concurrent type, the type must be a task
3963 -- (SPARK RM 6.1.4(6)).
3965 elsif Is_Single_Concurrent_Object
(Spec_Id
)
3966 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
3972 -- A pragma that applies to a Ghost entity becomes Ghost for the
3973 -- purposes of legality checks and removal of ignored Ghost code.
3975 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
3976 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
3977 end Analyze_Depends_Global
;
3979 ------------------------
3980 -- Analyze_If_Present --
3981 ------------------------
3983 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
3987 pragma Assert
(Is_List_Member
(N
));
3989 -- Inspect the declarations or statements following pragma N looking
3990 -- for another pragma whose Id matches the caller's request. If it is
3991 -- available, analyze it.
3994 while Present
(Stmt
) loop
3995 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
3996 Analyze_Pragma
(Stmt
);
3999 -- The first source declaration or statement immediately following
4000 -- N ends the region where a pragma may appear.
4002 elsif Comes_From_Source
(Stmt
) then
4008 end Analyze_If_Present
;
4010 --------------------------------
4011 -- Analyze_Pre_Post_Condition --
4012 --------------------------------
4014 procedure Analyze_Pre_Post_Condition
is
4015 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4016 Subp_Decl
: Node_Id
;
4017 Subp_Id
: Entity_Id
;
4019 Duplicates_OK
: Boolean := False;
4020 -- Flag set when a pre/postcondition allows multiple pragmas of the
4023 In_Body_OK
: Boolean := False;
4024 -- Flag set when a pre/postcondition is allowed to appear on a body
4025 -- even though the subprogram may have a spec.
4027 Is_Pre_Post
: Boolean := False;
4028 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4032 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4033 -- offer uniformity among the various kinds of pre/postconditions by
4034 -- rewriting the pragma identifier. This allows the retrieval of the
4035 -- original pragma name by routine Original_Aspect_Pragma_Name.
4037 if Comes_From_Source
(N
) then
4038 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4039 Is_Pre_Post
:= True;
4040 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4041 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4043 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4044 Is_Pre_Post
:= True;
4045 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4046 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4050 -- Determine the semantics with respect to duplicates and placement
4051 -- in a body. Pragmas Precondition and Postcondition were introduced
4052 -- before aspects and are not subject to the same aspect-like rules.
4054 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4055 Duplicates_OK
:= True;
4061 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4062 -- argument without an identifier.
4065 Check_Arg_Count
(1);
4066 Check_No_Identifiers
;
4068 -- Pragmas Precondition and Postcondition have complex argument
4072 Check_At_Least_N_Arguments
(1);
4073 Check_At_Most_N_Arguments
(2);
4074 Check_Optional_Identifier
(Arg1
, Name_Check
);
4076 if Present
(Arg2
) then
4077 Check_Optional_Identifier
(Arg2
, Name_Message
);
4078 Preanalyze_Spec_Expression
4079 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4083 -- For a pragma PPC in the extended main source unit, record enabled
4085 -- ??? nothing checks that the pragma is in the main source unit
4087 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4088 Set_SCO_Pragma_Enabled
(Loc
);
4091 -- Ensure the proper placement of the pragma
4094 Find_Related_Declaration_Or_Body
4095 (N
, Do_Checks
=> not Duplicates_OK
);
4097 -- When a pre/postcondition pragma applies to an abstract subprogram,
4098 -- its original form must be an aspect with 'Class.
4100 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4101 if not From_Aspect_Specification
(N
) then
4103 ("pragma % cannot be applied to abstract subprogram");
4105 elsif not Class_Present
(N
) then
4107 ("aspect % requires ''Class for abstract subprogram");
4110 -- Entry declaration
4112 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4115 -- Generic subprogram declaration
4117 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4122 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4123 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4127 -- Subprogram body stub
4129 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4130 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4134 -- Subprogram declaration
4136 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4138 -- AI05-0230: When a pre/postcondition pragma applies to a null
4139 -- procedure, its original form must be an aspect with 'Class.
4141 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4142 and then Null_Present
(Specification
(Subp_Decl
))
4143 and then From_Aspect_Specification
(N
)
4144 and then not Class_Present
(N
)
4146 Error_Pragma
("aspect % requires ''Class for null procedure");
4149 -- Otherwise the placement is illegal
4156 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4158 -- Chain the pragma on the contract for further processing by
4159 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4161 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4163 -- A pragma that applies to a Ghost entity becomes Ghost for the
4164 -- purposes of legality checks and removal of ignored Ghost code.
4166 Mark_Pragma_As_Ghost
(N
, Subp_Id
);
4168 -- Fully analyze the pragma when it appears inside an entry or
4169 -- subprogram body because it cannot benefit from forward references.
4171 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4173 N_Subprogram_Body_Stub
)
4175 -- The legality checks of pragmas Precondition and Postcondition
4176 -- are affected by the SPARK mode in effect and the volatility of
4177 -- the context. Analyze all pragmas in a specific order.
4179 Analyze_If_Present
(Pragma_SPARK_Mode
);
4180 Analyze_If_Present
(Pragma_Volatile_Function
);
4181 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4183 end Analyze_Pre_Post_Condition
;
4185 -----------------------------------------
4186 -- Analyze_Refined_Depends_Global_Post --
4187 -----------------------------------------
4189 procedure Analyze_Refined_Depends_Global_Post
4190 (Spec_Id
: out Entity_Id
;
4191 Body_Id
: out Entity_Id
;
4192 Legal
: out Boolean)
4194 Body_Decl
: Node_Id
;
4195 Spec_Decl
: Node_Id
;
4198 -- Assume that the pragma is illegal
4205 Check_Arg_Count
(1);
4206 Check_No_Identifiers
;
4208 -- Verify the placement of the pragma and check for duplicates. The
4209 -- pragma must apply to a subprogram body [stub].
4211 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4215 if Nkind
(Body_Decl
) = N_Entry_Body
then
4220 elsif Nkind
(Body_Decl
) = N_Subprogram_Body
then
4223 -- Subprogram body stub
4225 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
4230 elsif Nkind
(Body_Decl
) = N_Task_Body
then
4238 Body_Id
:= Defining_Entity
(Body_Decl
);
4239 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4241 -- The pragma must apply to the second declaration of a subprogram.
4242 -- In other words, the body [stub] cannot acts as a spec.
4244 if No
(Spec_Id
) then
4245 Error_Pragma
("pragma % cannot apply to a stand alone body");
4248 -- Catch the case where the subprogram body is a subunit and acts as
4249 -- the third declaration of the subprogram.
4251 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4252 Error_Pragma
("pragma % cannot apply to a subunit");
4256 -- A refined pragma can only apply to the body [stub] of a subprogram
4257 -- declared in the visible part of a package. Retrieve the context of
4258 -- the subprogram declaration.
4260 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4262 -- When dealing with protected entries or protected subprograms, use
4263 -- the enclosing protected type as the proper context.
4265 if Ekind_In
(Spec_Id
, E_Entry
,
4269 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4271 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4274 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4276 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4277 & "subprogram declared in a package specification"));
4281 -- If we get here, then the pragma is legal
4285 -- A pragma that applies to a Ghost entity becomes Ghost for the
4286 -- purposes of legality checks and removal of ignored Ghost code.
4288 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
4290 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4291 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4293 end Analyze_Refined_Depends_Global_Post
;
4295 --------------------------
4296 -- Check_Ada_83_Warning --
4297 --------------------------
4299 procedure Check_Ada_83_Warning
is
4301 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
4302 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
4304 end Check_Ada_83_Warning
;
4306 ---------------------
4307 -- Check_Arg_Count --
4308 ---------------------
4310 procedure Check_Arg_Count
(Required
: Nat
) is
4312 if Arg_Count
/= Required
then
4313 Error_Pragma
("wrong number of arguments for pragma%");
4315 end Check_Arg_Count
;
4317 --------------------------------
4318 -- Check_Arg_Is_External_Name --
4319 --------------------------------
4321 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
4322 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4325 if Nkind
(Argx
) = N_Identifier
then
4329 Analyze_And_Resolve
(Argx
, Standard_String
);
4331 if Is_OK_Static_Expression
(Argx
) then
4334 elsif Etype
(Argx
) = Any_Type
then
4337 -- An interesting special case, if we have a string literal and
4338 -- we are in Ada 83 mode, then we allow it even though it will
4339 -- not be flagged as static. This allows expected Ada 83 mode
4340 -- use of external names which are string literals, even though
4341 -- technically these are not static in Ada 83.
4343 elsif Ada_Version
= Ada_83
4344 and then Nkind
(Argx
) = N_String_Literal
4348 -- Static expression that raises Constraint_Error. This has
4349 -- already been flagged, so just exit from pragma processing.
4351 elsif Is_OK_Static_Expression
(Argx
) then
4354 -- Here we have a real error (non-static expression)
4357 Error_Msg_Name_1
:= Pname
;
4360 Msg
: constant String :=
4361 "argument for pragma% must be a identifier or "
4362 & "static string expression!";
4364 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
4369 end Check_Arg_Is_External_Name
;
4371 -----------------------------
4372 -- Check_Arg_Is_Identifier --
4373 -----------------------------
4375 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
4376 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4378 if Nkind
(Argx
) /= N_Identifier
then
4380 ("argument for pragma% must be identifier", Argx
);
4382 end Check_Arg_Is_Identifier
;
4384 ----------------------------------
4385 -- Check_Arg_Is_Integer_Literal --
4386 ----------------------------------
4388 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
4389 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4391 if Nkind
(Argx
) /= N_Integer_Literal
then
4393 ("argument for pragma% must be integer literal", Argx
);
4395 end Check_Arg_Is_Integer_Literal
;
4397 -------------------------------------------
4398 -- Check_Arg_Is_Library_Level_Local_Name --
4399 -------------------------------------------
4403 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4404 -- | library_unit_NAME
4406 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
4408 Check_Arg_Is_Local_Name
(Arg
);
4410 -- If it came from an aspect, we want to give the error just as if it
4411 -- came from source.
4413 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
4414 and then (Comes_From_Source
(N
)
4415 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
4418 ("argument for pragma% must be library level entity", Arg
);
4420 end Check_Arg_Is_Library_Level_Local_Name
;
4422 -----------------------------
4423 -- Check_Arg_Is_Local_Name --
4424 -----------------------------
4428 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4429 -- | library_unit_NAME
4431 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
4432 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4437 if Nkind
(Argx
) not in N_Direct_Name
4438 and then (Nkind
(Argx
) /= N_Attribute_Reference
4439 or else Present
(Expressions
(Argx
))
4440 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
4441 and then (not Is_Entity_Name
(Argx
)
4442 or else not Is_Compilation_Unit
(Entity
(Argx
)))
4444 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
4447 -- No further check required if not an entity name
4449 if not Is_Entity_Name
(Argx
) then
4455 Ent
: constant Entity_Id
:= Entity
(Argx
);
4456 Scop
: constant Entity_Id
:= Scope
(Ent
);
4459 -- Case of a pragma applied to a compilation unit: pragma must
4460 -- occur immediately after the program unit in the compilation.
4462 if Is_Compilation_Unit
(Ent
) then
4464 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
4467 -- Case of pragma placed immediately after spec
4469 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
4472 -- Case of pragma placed immediately after body
4474 elsif Nkind
(Decl
) = N_Subprogram_Declaration
4475 and then Present
(Corresponding_Body
(Decl
))
4479 (Parent
(Unit_Declaration_Node
4480 (Corresponding_Body
(Decl
))));
4482 -- All other cases are illegal
4489 -- Special restricted placement rule from 10.2.1(11.8/2)
4491 elsif Is_Generic_Formal
(Ent
)
4492 and then Prag_Id
= Pragma_Preelaborable_Initialization
4494 OK
:= List_Containing
(N
) =
4495 Generic_Formal_Declarations
4496 (Unit_Declaration_Node
(Scop
));
4498 -- If this is an aspect applied to a subprogram body, the
4499 -- pragma is inserted in its declarative part.
4501 elsif From_Aspect_Specification
(N
)
4502 and then Ent
= Current_Scope
4504 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
4508 -- If the aspect is a predicate (possibly others ???) and the
4509 -- context is a record type, this is a discriminant expression
4510 -- within a type declaration, that freezes the predicated
4513 elsif From_Aspect_Specification
(N
)
4514 and then Prag_Id
= Pragma_Predicate
4515 and then Ekind
(Current_Scope
) = E_Record_Type
4516 and then Scop
= Scope
(Current_Scope
)
4520 -- Default case, just check that the pragma occurs in the scope
4521 -- of the entity denoted by the name.
4524 OK
:= Current_Scope
= Scop
;
4529 ("pragma% argument must be in same declarative part", Arg
);
4533 end Check_Arg_Is_Local_Name
;
4535 ---------------------------------
4536 -- Check_Arg_Is_Locking_Policy --
4537 ---------------------------------
4539 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
4540 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4543 Check_Arg_Is_Identifier
(Argx
);
4545 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
4546 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
4548 end Check_Arg_Is_Locking_Policy
;
4550 -----------------------------------------------
4551 -- Check_Arg_Is_Partition_Elaboration_Policy --
4552 -----------------------------------------------
4554 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
4555 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4558 Check_Arg_Is_Identifier
(Argx
);
4560 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
4562 ("& is not a valid partition elaboration policy name", Argx
);
4564 end Check_Arg_Is_Partition_Elaboration_Policy
;
4566 -------------------------
4567 -- Check_Arg_Is_One_Of --
4568 -------------------------
4570 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4571 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4574 Check_Arg_Is_Identifier
(Argx
);
4576 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
4577 Error_Msg_Name_2
:= N1
;
4578 Error_Msg_Name_3
:= N2
;
4579 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
4581 end Check_Arg_Is_One_Of
;
4583 procedure Check_Arg_Is_One_Of
4585 N1
, N2
, N3
: Name_Id
)
4587 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4590 Check_Arg_Is_Identifier
(Argx
);
4592 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
4593 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
4595 end Check_Arg_Is_One_Of
;
4597 procedure Check_Arg_Is_One_Of
4599 N1
, N2
, N3
, N4
: Name_Id
)
4601 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4604 Check_Arg_Is_Identifier
(Argx
);
4606 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
4607 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
4609 end Check_Arg_Is_One_Of
;
4611 procedure Check_Arg_Is_One_Of
4613 N1
, N2
, N3
, N4
, N5
: Name_Id
)
4615 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4618 Check_Arg_Is_Identifier
(Argx
);
4620 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
4621 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
4623 end Check_Arg_Is_One_Of
;
4625 ---------------------------------
4626 -- Check_Arg_Is_Queuing_Policy --
4627 ---------------------------------
4629 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
4630 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4633 Check_Arg_Is_Identifier
(Argx
);
4635 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
4636 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
4638 end Check_Arg_Is_Queuing_Policy
;
4640 ---------------------------------------
4641 -- Check_Arg_Is_OK_Static_Expression --
4642 ---------------------------------------
4644 procedure Check_Arg_Is_OK_Static_Expression
4646 Typ
: Entity_Id
:= Empty
)
4649 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
4650 end Check_Arg_Is_OK_Static_Expression
;
4652 ------------------------------------------
4653 -- Check_Arg_Is_Task_Dispatching_Policy --
4654 ------------------------------------------
4656 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
4657 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4660 Check_Arg_Is_Identifier
(Argx
);
4662 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
4664 ("& is not an allowed task dispatching policy name", Argx
);
4666 end Check_Arg_Is_Task_Dispatching_Policy
;
4668 ---------------------
4669 -- Check_Arg_Order --
4670 ---------------------
4672 procedure Check_Arg_Order
(Names
: Name_List
) is
4675 Highest_So_Far
: Natural := 0;
4676 -- Highest index in Names seen do far
4680 for J
in 1 .. Arg_Count
loop
4681 if Chars
(Arg
) /= No_Name
then
4682 for K
in Names
'Range loop
4683 if Chars
(Arg
) = Names
(K
) then
4684 if K
< Highest_So_Far
then
4685 Error_Msg_Name_1
:= Pname
;
4687 ("parameters out of order for pragma%", Arg
);
4688 Error_Msg_Name_1
:= Names
(K
);
4689 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
4690 Error_Msg_N
("\% must appear before %", Arg
);
4694 Highest_So_Far
:= K
;
4702 end Check_Arg_Order
;
4704 --------------------------------
4705 -- Check_At_Least_N_Arguments --
4706 --------------------------------
4708 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
4710 if Arg_Count
< N
then
4711 Error_Pragma
("too few arguments for pragma%");
4713 end Check_At_Least_N_Arguments
;
4715 -------------------------------
4716 -- Check_At_Most_N_Arguments --
4717 -------------------------------
4719 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
4722 if Arg_Count
> N
then
4724 for J
in 1 .. N
loop
4726 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
4729 end Check_At_Most_N_Arguments
;
4731 ---------------------
4732 -- Check_Component --
4733 ---------------------
4735 procedure Check_Component
4738 In_Variant_Part
: Boolean := False)
4740 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
4741 Sindic
: constant Node_Id
:=
4742 Subtype_Indication
(Component_Definition
(Comp
));
4743 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
4746 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4747 -- object constraint, then the component type shall be an Unchecked_
4750 if Nkind
(Sindic
) = N_Subtype_Indication
4751 and then Has_Per_Object_Constraint
(Comp_Id
)
4752 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4755 ("component subtype subject to per-object constraint "
4756 & "must be an Unchecked_Union", Comp
);
4758 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4759 -- the body of a generic unit, or within the body of any of its
4760 -- descendant library units, no part of the type of a component
4761 -- declared in a variant_part of the unchecked union type shall be of
4762 -- a formal private type or formal private extension declared within
4763 -- the formal part of the generic unit.
4765 elsif Ada_Version
>= Ada_2012
4766 and then In_Generic_Body
(UU_Typ
)
4767 and then In_Variant_Part
4768 and then Is_Private_Type
(Typ
)
4769 and then Is_Generic_Type
(Typ
)
4772 ("component of unchecked union cannot be of generic type", Comp
);
4774 elsif Needs_Finalization
(Typ
) then
4776 ("component of unchecked union cannot be controlled", Comp
);
4778 elsif Has_Task
(Typ
) then
4780 ("component of unchecked union cannot have tasks", Comp
);
4782 end Check_Component
;
4784 ----------------------------
4785 -- Check_Duplicate_Pragma --
4786 ----------------------------
4788 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4789 Id
: Entity_Id
:= E
;
4793 -- Nothing to do if this pragma comes from an aspect specification,
4794 -- since we could not be duplicating a pragma, and we dealt with the
4795 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4797 if From_Aspect_Specification
(N
) then
4801 -- Otherwise current pragma may duplicate previous pragma or a
4802 -- previously given aspect specification or attribute definition
4803 -- clause for the same pragma.
4805 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4809 -- If the entity is a type, then we have to make sure that the
4810 -- ostensible duplicate is not for a parent type from which this
4814 if Nkind
(P
) = N_Pragma
then
4816 Args
: constant List_Id
:=
4817 Pragma_Argument_Associations
(P
);
4820 and then Is_Entity_Name
(Expression
(First
(Args
)))
4821 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4822 and then Entity
(Expression
(First
(Args
))) /= E
4828 elsif Nkind
(P
) = N_Aspect_Specification
4829 and then Is_Type
(Entity
(P
))
4830 and then Entity
(P
) /= E
4836 -- Here we have a definite duplicate
4838 Error_Msg_Name_1
:= Pragma_Name
(N
);
4839 Error_Msg_Sloc
:= Sloc
(P
);
4841 -- For a single protected or a single task object, the error is
4842 -- issued on the original entity.
4844 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4845 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4848 if Nkind
(P
) = N_Aspect_Specification
4849 or else From_Aspect_Specification
(P
)
4851 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4853 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4858 end Check_Duplicate_Pragma
;
4860 ----------------------------------
4861 -- Check_Duplicated_Export_Name --
4862 ----------------------------------
4864 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4865 String_Val
: constant String_Id
:= Strval
(Nam
);
4868 -- We are only interested in the export case, and in the case of
4869 -- generics, it is the instance, not the template, that is the
4870 -- problem (the template will generate a warning in any case).
4872 if not Inside_A_Generic
4873 and then (Prag_Id
= Pragma_Export
4875 Prag_Id
= Pragma_Export_Procedure
4877 Prag_Id
= Pragma_Export_Valued_Procedure
4879 Prag_Id
= Pragma_Export_Function
)
4881 for J
in Externals
.First
.. Externals
.Last
loop
4882 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4883 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4884 Error_Msg_N
("external name duplicates name given#", Nam
);
4889 Externals
.Append
(Nam
);
4891 end Check_Duplicated_Export_Name
;
4893 ----------------------------------------
4894 -- Check_Expr_Is_OK_Static_Expression --
4895 ----------------------------------------
4897 procedure Check_Expr_Is_OK_Static_Expression
4899 Typ
: Entity_Id
:= Empty
)
4902 if Present
(Typ
) then
4903 Analyze_And_Resolve
(Expr
, Typ
);
4905 Analyze_And_Resolve
(Expr
);
4908 if Is_OK_Static_Expression
(Expr
) then
4911 elsif Etype
(Expr
) = Any_Type
then
4914 -- An interesting special case, if we have a string literal and we
4915 -- are in Ada 83 mode, then we allow it even though it will not be
4916 -- flagged as static. This allows the use of Ada 95 pragmas like
4917 -- Import in Ada 83 mode. They will of course be flagged with
4918 -- warnings as usual, but will not cause errors.
4920 elsif Ada_Version
= Ada_83
4921 and then Nkind
(Expr
) = N_String_Literal
4925 -- Static expression that raises Constraint_Error. This has already
4926 -- been flagged, so just exit from pragma processing.
4928 elsif Is_OK_Static_Expression
(Expr
) then
4931 -- Finally, we have a real error
4934 Error_Msg_Name_1
:= Pname
;
4935 Flag_Non_Static_Expr
4936 (Fix_Error
("argument for pragma% must be a static expression!"),
4940 end Check_Expr_Is_OK_Static_Expression
;
4942 -------------------------
4943 -- Check_First_Subtype --
4944 -------------------------
4946 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4947 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4948 Ent
: constant Entity_Id
:= Entity
(Argx
);
4951 if Is_First_Subtype
(Ent
) then
4954 elsif Is_Type
(Ent
) then
4956 ("pragma% cannot apply to subtype", Argx
);
4958 elsif Is_Object
(Ent
) then
4960 ("pragma% cannot apply to object, requires a type", Argx
);
4964 ("pragma% cannot apply to&, requires a type", Argx
);
4966 end Check_First_Subtype
;
4968 ----------------------
4969 -- Check_Identifier --
4970 ----------------------
4972 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4975 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4977 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4978 Error_Msg_Name_1
:= Pname
;
4979 Error_Msg_Name_2
:= Id
;
4980 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4984 end Check_Identifier
;
4986 --------------------------------
4987 -- Check_Identifier_Is_One_Of --
4988 --------------------------------
4990 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4993 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4995 if Chars
(Arg
) = No_Name
then
4996 Error_Msg_Name_1
:= Pname
;
4997 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5000 elsif Chars
(Arg
) /= N1
5001 and then Chars
(Arg
) /= N2
5003 Error_Msg_Name_1
:= Pname
;
5004 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5008 end Check_Identifier_Is_One_Of
;
5010 ---------------------------
5011 -- Check_In_Main_Program --
5012 ---------------------------
5014 procedure Check_In_Main_Program
is
5015 P
: constant Node_Id
:= Parent
(N
);
5018 -- Must be in subprogram body
5020 if Nkind
(P
) /= N_Subprogram_Body
then
5021 Error_Pragma
("% pragma allowed only in subprogram");
5023 -- Otherwise warn if obviously not main program
5025 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5026 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5028 Error_Msg_Name_1
:= Pname
;
5030 ("??pragma% is only effective in main program", N
);
5032 end Check_In_Main_Program
;
5034 ---------------------------------------
5035 -- Check_Interrupt_Or_Attach_Handler --
5036 ---------------------------------------
5038 procedure Check_Interrupt_Or_Attach_Handler
is
5039 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5040 Handler_Proc
, Proc_Scope
: Entity_Id
;
5045 if Prag_Id
= Pragma_Interrupt_Handler
then
5046 Check_Restriction
(No_Dynamic_Attachment
, N
);
5049 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5050 Proc_Scope
:= Scope
(Handler_Proc
);
5052 -- On AAMP only, a pragma Interrupt_Handler is supported for
5053 -- nonprotected parameterless procedures.
5055 if not AAMP_On_Target
5056 or else Prag_Id
= Pragma_Attach_Handler
5058 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5060 ("argument of pragma% must be protected procedure", Arg1
);
5063 -- For pragma case (as opposed to access case), check placement.
5064 -- We don't need to do that for aspects, because we have the
5065 -- check that they aspect applies an appropriate procedure.
5067 if not From_Aspect_Specification
(N
)
5068 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5070 Error_Pragma
("pragma% must be in protected definition");
5074 if not Is_Library_Level_Entity
(Proc_Scope
)
5075 or else (AAMP_On_Target
5076 and then not Is_Library_Level_Entity
(Handler_Proc
))
5079 ("argument for pragma% must be library level entity", Arg1
);
5082 -- AI05-0033: A pragma cannot appear within a generic body, because
5083 -- instance can be in a nested scope. The check that protected type
5084 -- is itself a library-level declaration is done elsewhere.
5086 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5087 -- handle code prior to AI-0033. Analysis tools typically are not
5088 -- interested in this pragma in any case, so no need to worry too
5089 -- much about its placement.
5091 if Inside_A_Generic
then
5092 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5093 and then In_Package_Body
(Scope
(Current_Scope
))
5094 and then not Relaxed_RM_Semantics
5096 Error_Pragma
("pragma% cannot be used inside a generic");
5099 end Check_Interrupt_Or_Attach_Handler
;
5101 ---------------------------------
5102 -- Check_Loop_Pragma_Placement --
5103 ---------------------------------
5105 procedure Check_Loop_Pragma_Placement
is
5106 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5107 -- Verify whether the current pragma is properly grouped with other
5108 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5109 -- related loop where the pragma appears.
5111 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5112 -- Determine whether an arbitrary statement Stmt denotes pragma
5113 -- Loop_Invariant or Loop_Variant.
5115 procedure Placement_Error
(Constr
: Node_Id
);
5116 pragma No_Return
(Placement_Error
);
5117 -- Node Constr denotes the last loop restricted construct before we
5118 -- encountered an illegal relation between enclosing constructs. Emit
5119 -- an error depending on what Constr was.
5121 --------------------------------
5122 -- Check_Loop_Pragma_Grouping --
5123 --------------------------------
5125 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
5126 Stop_Search
: exception;
5127 -- This exception is used to terminate the recursive descent of
5128 -- routine Check_Grouping.
5130 procedure Check_Grouping
(L
: List_Id
);
5131 -- Find the first group of pragmas in list L and if successful,
5132 -- ensure that the current pragma is part of that group. The
5133 -- routine raises Stop_Search once such a check is performed to
5134 -- halt the recursive descent.
5136 procedure Grouping_Error
(Prag
: Node_Id
);
5137 pragma No_Return
(Grouping_Error
);
5138 -- Emit an error concerning the current pragma indicating that it
5139 -- should be placed after pragma Prag.
5141 --------------------
5142 -- Check_Grouping --
5143 --------------------
5145 procedure Check_Grouping
(L
: List_Id
) is
5151 -- Inspect the list of declarations or statements looking for
5152 -- the first grouping of pragmas:
5155 -- pragma Loop_Invariant ...;
5156 -- pragma Loop_Variant ...;
5158 -- pragma Loop_Variant ...; -- current pragma
5160 -- If the current pragma is not in the grouping, then it must
5161 -- either appear in a different declarative or statement list
5162 -- or the construct at (1) is separating the pragma from the
5166 while Present
(Stmt
) loop
5168 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5169 -- inside a loop or a block housed inside a loop. Inspect
5170 -- the declarations and statements of the block as they may
5171 -- contain the first grouping.
5173 if Nkind
(Stmt
) = N_Block_Statement
then
5174 HSS
:= Handled_Statement_Sequence
(Stmt
);
5176 Check_Grouping
(Declarations
(Stmt
));
5178 if Present
(HSS
) then
5179 Check_Grouping
(Statements
(HSS
));
5182 -- First pragma of the first topmost grouping has been found
5184 elsif Is_Loop_Pragma
(Stmt
) then
5186 -- The group and the current pragma are not in the same
5187 -- declarative or statement list.
5189 if List_Containing
(Stmt
) /= List_Containing
(N
) then
5190 Grouping_Error
(Stmt
);
5192 -- Try to reach the current pragma from the first pragma
5193 -- of the grouping while skipping other members:
5195 -- pragma Loop_Invariant ...; -- first pragma
5196 -- pragma Loop_Variant ...; -- member
5198 -- pragma Loop_Variant ...; -- current pragma
5201 while Present
(Stmt
) loop
5203 -- The current pragma is either the first pragma
5204 -- of the group or is a member of the group. Stop
5205 -- the search as the placement is legal.
5210 -- Skip group members, but keep track of the last
5211 -- pragma in the group.
5213 elsif Is_Loop_Pragma
(Stmt
) then
5216 -- Skip declarations and statements generated by
5217 -- the compiler during expansion.
5219 elsif not Comes_From_Source
(Stmt
) then
5222 -- A non-pragma is separating the group from the
5223 -- current pragma, the placement is illegal.
5226 Grouping_Error
(Prag
);
5232 -- If the traversal did not reach the current pragma,
5233 -- then the list must be malformed.
5235 raise Program_Error
;
5243 --------------------
5244 -- Grouping_Error --
5245 --------------------
5247 procedure Grouping_Error
(Prag
: Node_Id
) is
5249 Error_Msg_Sloc
:= Sloc
(Prag
);
5250 Error_Pragma
("pragma% must appear next to pragma#");
5253 -- Start of processing for Check_Loop_Pragma_Grouping
5256 -- Inspect the statements of the loop or nested blocks housed
5257 -- within to determine whether the current pragma is part of the
5258 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5260 Check_Grouping
(Statements
(Loop_Stmt
));
5263 when Stop_Search
=> null;
5264 end Check_Loop_Pragma_Grouping
;
5266 --------------------
5267 -- Is_Loop_Pragma --
5268 --------------------
5270 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
5272 -- Inspect the original node as Loop_Invariant and Loop_Variant
5273 -- pragmas are rewritten to null when assertions are disabled.
5275 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
5277 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
5278 Name_Loop_Invariant
,
5285 ---------------------
5286 -- Placement_Error --
5287 ---------------------
5289 procedure Placement_Error
(Constr
: Node_Id
) is
5290 LA
: constant String := " with Loop_Entry";
5293 if Prag_Id
= Pragma_Assert
then
5294 Error_Msg_String
(1 .. LA
'Length) := LA
;
5295 Error_Msg_Strlen
:= LA
'Length;
5297 Error_Msg_Strlen
:= 0;
5300 if Nkind
(Constr
) = N_Pragma
then
5302 ("pragma %~ must appear immediately within the statements "
5306 ("block containing pragma %~ must appear immediately within "
5307 & "the statements of a loop", Constr
);
5309 end Placement_Error
;
5311 -- Local declarations
5316 -- Start of processing for Check_Loop_Pragma_Placement
5319 -- Check that pragma appears immediately within a loop statement,
5320 -- ignoring intervening block statements.
5324 while Present
(Stmt
) loop
5326 -- The pragma or previous block must appear immediately within the
5327 -- current block's declarative or statement part.
5329 if Nkind
(Stmt
) = N_Block_Statement
then
5330 if (No
(Declarations
(Stmt
))
5331 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
5333 List_Containing
(Prev
) /=
5334 Statements
(Handled_Statement_Sequence
(Stmt
))
5336 Placement_Error
(Prev
);
5339 -- Keep inspecting the parents because we are now within a
5340 -- chain of nested blocks.
5344 Stmt
:= Parent
(Stmt
);
5347 -- The pragma or previous block must appear immediately within the
5348 -- statements of the loop.
5350 elsif Nkind
(Stmt
) = N_Loop_Statement
then
5351 if List_Containing
(Prev
) /= Statements
(Stmt
) then
5352 Placement_Error
(Prev
);
5355 -- Stop the traversal because we reached the innermost loop
5356 -- regardless of whether we encountered an error or not.
5360 -- Ignore a handled statement sequence. Note that this node may
5361 -- be related to a subprogram body in which case we will emit an
5362 -- error on the next iteration of the search.
5364 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
5365 Stmt
:= Parent
(Stmt
);
5367 -- Any other statement breaks the chain from the pragma to the
5371 Placement_Error
(Prev
);
5376 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5377 -- grouped together with other such pragmas.
5379 if Is_Loop_Pragma
(N
) then
5381 -- The previous check should have located the related loop
5383 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
5384 Check_Loop_Pragma_Grouping
(Stmt
);
5386 end Check_Loop_Pragma_Placement
;
5388 -------------------------------------------
5389 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5390 -------------------------------------------
5392 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
5401 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
5404 elsif Nkind_In
(P
, N_Package_Specification
,
5409 -- Note: the following tests seem a little peculiar, because
5410 -- they test for bodies, but if we were in the statement part
5411 -- of the body, we would already have hit the handled statement
5412 -- sequence, so the only way we get here is by being in the
5413 -- declarative part of the body.
5415 elsif Nkind_In
(P
, N_Subprogram_Body
,
5426 Error_Pragma
("pragma% is not in declarative part or package spec");
5427 end Check_Is_In_Decl_Part_Or_Package_Spec
;
5429 -------------------------
5430 -- Check_No_Identifier --
5431 -------------------------
5433 procedure Check_No_Identifier
(Arg
: Node_Id
) is
5435 if Nkind
(Arg
) = N_Pragma_Argument_Association
5436 and then Chars
(Arg
) /= No_Name
5438 Error_Pragma_Arg_Ident
5439 ("pragma% does not permit identifier& here", Arg
);
5441 end Check_No_Identifier
;
5443 --------------------------
5444 -- Check_No_Identifiers --
5445 --------------------------
5447 procedure Check_No_Identifiers
is
5451 for J
in 1 .. Arg_Count
loop
5452 Check_No_Identifier
(Arg_Node
);
5455 end Check_No_Identifiers
;
5457 ------------------------
5458 -- Check_No_Link_Name --
5459 ------------------------
5461 procedure Check_No_Link_Name
is
5463 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
5467 if Present
(Arg4
) then
5469 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
5471 end Check_No_Link_Name
;
5473 -------------------------------
5474 -- Check_Optional_Identifier --
5475 -------------------------------
5477 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5480 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5481 and then Chars
(Arg
) /= No_Name
5483 if Chars
(Arg
) /= Id
then
5484 Error_Msg_Name_1
:= Pname
;
5485 Error_Msg_Name_2
:= Id
;
5486 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5490 end Check_Optional_Identifier
;
5492 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
5494 Name_Buffer
(1 .. Id
'Length) := Id
;
5495 Name_Len
:= Id
'Length;
5496 Check_Optional_Identifier
(Arg
, Name_Find
);
5497 end Check_Optional_Identifier
;
5499 -------------------------------------
5500 -- Check_Static_Boolean_Expression --
5501 -------------------------------------
5503 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
5505 if Present
(Expr
) then
5506 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
5508 if not Is_OK_Static_Expression
(Expr
) then
5510 ("expression of pragma % must be static", Expr
);
5513 end Check_Static_Boolean_Expression
;
5515 -----------------------------
5516 -- Check_Static_Constraint --
5517 -----------------------------
5519 -- Note: for convenience in writing this procedure, in addition to
5520 -- the officially (i.e. by spec) allowed argument which is always a
5521 -- constraint, it also allows ranges and discriminant associations.
5522 -- Above is not clear ???
5524 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5526 procedure Require_Static
(E
: Node_Id
);
5527 -- Require given expression to be static expression
5529 --------------------
5530 -- Require_Static --
5531 --------------------
5533 procedure Require_Static
(E
: Node_Id
) is
5535 if not Is_OK_Static_Expression
(E
) then
5536 Flag_Non_Static_Expr
5537 ("non-static constraint not allowed in Unchecked_Union!", E
);
5542 -- Start of processing for Check_Static_Constraint
5545 case Nkind
(Constr
) is
5546 when N_Discriminant_Association
=>
5547 Require_Static
(Expression
(Constr
));
5550 Require_Static
(Low_Bound
(Constr
));
5551 Require_Static
(High_Bound
(Constr
));
5553 when N_Attribute_Reference
=>
5554 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5555 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5557 when N_Range_Constraint
=>
5558 Check_Static_Constraint
(Range_Expression
(Constr
));
5560 when N_Index_Or_Discriminant_Constraint
=>
5564 IDC
:= First
(Constraints
(Constr
));
5565 while Present
(IDC
) loop
5566 Check_Static_Constraint
(IDC
);
5574 end Check_Static_Constraint
;
5576 --------------------------------------
5577 -- Check_Valid_Configuration_Pragma --
5578 --------------------------------------
5580 -- A configuration pragma must appear in the context clause of a
5581 -- compilation unit, and only other pragmas may precede it. Note that
5582 -- the test also allows use in a configuration pragma file.
5584 procedure Check_Valid_Configuration_Pragma
is
5586 if not Is_Configuration_Pragma
then
5587 Error_Pragma
("incorrect placement for configuration pragma%");
5589 end Check_Valid_Configuration_Pragma
;
5591 -------------------------------------
5592 -- Check_Valid_Library_Unit_Pragma --
5593 -------------------------------------
5595 procedure Check_Valid_Library_Unit_Pragma
is
5597 Parent_Node
: Node_Id
;
5598 Unit_Name
: Entity_Id
;
5599 Unit_Kind
: Node_Kind
;
5600 Unit_Node
: Node_Id
;
5601 Sindex
: Source_File_Index
;
5604 if not Is_List_Member
(N
) then
5608 Plist
:= List_Containing
(N
);
5609 Parent_Node
:= Parent
(Plist
);
5611 if Parent_Node
= Empty
then
5614 -- Case of pragma appearing after a compilation unit. In this case
5615 -- it must have an argument with the corresponding name and must
5616 -- be part of the following pragmas of its parent.
5618 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5619 if Plist
/= Pragmas_After
(Parent_Node
) then
5622 elsif Arg_Count
= 0 then
5624 ("argument required if outside compilation unit");
5627 Check_No_Identifiers
;
5628 Check_Arg_Count
(1);
5629 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5630 Unit_Kind
:= Nkind
(Unit_Node
);
5632 Analyze
(Get_Pragma_Arg
(Arg1
));
5634 if Unit_Kind
= N_Generic_Subprogram_Declaration
5635 or else Unit_Kind
= N_Subprogram_Declaration
5637 Unit_Name
:= Defining_Entity
(Unit_Node
);
5639 elsif Unit_Kind
in N_Generic_Instantiation
then
5640 Unit_Name
:= Defining_Entity
(Unit_Node
);
5643 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5646 if Chars
(Unit_Name
) /=
5647 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5650 ("pragma% argument is not current unit name", Arg1
);
5653 if Ekind
(Unit_Name
) = E_Package
5654 and then Present
(Renamed_Entity
(Unit_Name
))
5656 Error_Pragma
("pragma% not allowed for renamed package");
5660 -- Pragma appears other than after a compilation unit
5663 -- Here we check for the generic instantiation case and also
5664 -- for the case of processing a generic formal package. We
5665 -- detect these cases by noting that the Sloc on the node
5666 -- does not belong to the current compilation unit.
5668 Sindex
:= Source_Index
(Current_Sem_Unit
);
5670 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5671 Rewrite
(N
, Make_Null_Statement
(Loc
));
5674 -- If before first declaration, the pragma applies to the
5675 -- enclosing unit, and the name if present must be this name.
5677 elsif Is_Before_First_Decl
(N
, Plist
) then
5678 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5679 Unit_Kind
:= Nkind
(Unit_Node
);
5681 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5684 elsif Unit_Kind
= N_Subprogram_Body
5685 and then not Acts_As_Spec
(Unit_Node
)
5689 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5692 elsif Nkind
(Parent_Node
) = N_Package_Specification
5693 and then Plist
= Private_Declarations
(Parent_Node
)
5697 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5698 or else Nkind
(Parent_Node
) =
5699 N_Generic_Subprogram_Declaration
)
5700 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5704 elsif Arg_Count
> 0 then
5705 Analyze
(Get_Pragma_Arg
(Arg1
));
5707 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5709 ("name in pragma% must be enclosing unit", Arg1
);
5712 -- It is legal to have no argument in this context
5718 -- Error if not before first declaration. This is because a
5719 -- library unit pragma argument must be the name of a library
5720 -- unit (RM 10.1.5(7)), but the only names permitted in this
5721 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5722 -- generic subprogram declarations or generic instantiations.
5726 ("pragma% misplaced, must be before first declaration");
5730 end Check_Valid_Library_Unit_Pragma
;
5736 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5737 Clist
: constant Node_Id
:= Component_List
(Variant
);
5741 Comp
:= First
(Component_Items
(Clist
));
5742 while Present
(Comp
) loop
5743 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5748 ---------------------------
5749 -- Ensure_Aggregate_Form --
5750 ---------------------------
5752 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5753 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
5754 Expr
: constant Node_Id
:= Expression
(Arg
);
5755 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
5756 Comps
: List_Id
:= No_List
;
5757 Exprs
: List_Id
:= No_List
;
5758 Nam
: Name_Id
:= No_Name
;
5759 Nam_Loc
: Source_Ptr
;
5762 -- The pragma argument is in positional form:
5764 -- pragma Depends (Nam => ...)
5768 -- Note that the Sloc of the Chars field is the Sloc of the pragma
5769 -- argument association.
5771 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5773 Nam_Loc
:= Sloc
(Arg
);
5775 -- Remove the pragma argument name as this will be captured in the
5778 Set_Chars
(Arg
, No_Name
);
5781 -- The argument is already in aggregate form, but the presence of a
5782 -- name causes this to be interpreted as named association which in
5783 -- turn must be converted into an aggregate.
5785 -- pragma Global (In_Out => (A, B, C))
5789 -- pragma Global ((In_Out => (A, B, C)))
5791 -- aggregate aggregate
5793 if Nkind
(Expr
) = N_Aggregate
then
5794 if Nam
= No_Name
then
5798 -- Do not transform a null argument into an aggregate as N_Null has
5799 -- special meaning in formal verification pragmas.
5801 elsif Nkind
(Expr
) = N_Null
then
5805 -- Everything comes from source if the original comes from source
5807 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
5809 -- Positional argument is transformed into an aggregate with an
5810 -- Expressions list.
5812 if Nam
= No_Name
then
5813 Exprs
:= New_List
(Relocate_Node
(Expr
));
5815 -- An associative argument is transformed into an aggregate with
5816 -- Component_Associations.
5820 Make_Component_Association
(Loc
,
5821 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
5822 Expression
=> Relocate_Node
(Expr
)));
5825 Set_Expression
(Arg
,
5826 Make_Aggregate
(Loc
,
5827 Component_Associations
=> Comps
,
5828 Expressions
=> Exprs
));
5830 -- Restore Comes_From_Source default
5832 Set_Comes_From_Source_Default
(CFSD
);
5833 end Ensure_Aggregate_Form
;
5839 procedure Error_Pragma
(Msg
: String) is
5841 Error_Msg_Name_1
:= Pname
;
5842 Error_Msg_N
(Fix_Error
(Msg
), N
);
5846 ----------------------
5847 -- Error_Pragma_Arg --
5848 ----------------------
5850 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5852 Error_Msg_Name_1
:= Pname
;
5853 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
5855 end Error_Pragma_Arg
;
5857 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5859 Error_Msg_Name_1
:= Pname
;
5860 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
5861 Error_Pragma_Arg
(Msg2
, Arg
);
5862 end Error_Pragma_Arg
;
5864 ----------------------------
5865 -- Error_Pragma_Arg_Ident --
5866 ----------------------------
5868 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5870 Error_Msg_Name_1
:= Pname
;
5871 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
5873 end Error_Pragma_Arg_Ident
;
5875 ----------------------
5876 -- Error_Pragma_Ref --
5877 ----------------------
5879 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5881 Error_Msg_Name_1
:= Pname
;
5882 Error_Msg_Sloc
:= Sloc
(Ref
);
5883 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
5885 end Error_Pragma_Ref
;
5887 ------------------------
5888 -- Find_Lib_Unit_Name --
5889 ------------------------
5891 function Find_Lib_Unit_Name
return Entity_Id
is
5893 -- Return inner compilation unit entity, for case of nested
5894 -- categorization pragmas. This happens in generic unit.
5896 if Nkind
(Parent
(N
)) = N_Package_Specification
5897 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5899 return Defining_Entity
(Parent
(N
));
5901 return Current_Scope
;
5903 end Find_Lib_Unit_Name
;
5905 ----------------------------
5906 -- Find_Program_Unit_Name --
5907 ----------------------------
5909 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5910 Unit_Name
: Entity_Id
;
5911 Unit_Kind
: Node_Kind
;
5912 P
: constant Node_Id
:= Parent
(N
);
5915 if Nkind
(P
) = N_Compilation_Unit
then
5916 Unit_Kind
:= Nkind
(Unit
(P
));
5918 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
5919 N_Package_Declaration
)
5920 or else Unit_Kind
in N_Generic_Declaration
5922 Unit_Name
:= Defining_Entity
(Unit
(P
));
5924 if Chars
(Id
) = Chars
(Unit_Name
) then
5925 Set_Entity
(Id
, Unit_Name
);
5926 Set_Etype
(Id
, Etype
(Unit_Name
));
5928 Set_Etype
(Id
, Any_Type
);
5930 ("cannot find program unit referenced by pragma%");
5934 Set_Etype
(Id
, Any_Type
);
5935 Error_Pragma
("pragma% inapplicable to this unit");
5941 end Find_Program_Unit_Name
;
5943 -----------------------------------------
5944 -- Find_Unique_Parameterless_Procedure --
5945 -----------------------------------------
5947 function Find_Unique_Parameterless_Procedure
5949 Arg
: Node_Id
) return Entity_Id
5951 Proc
: Entity_Id
:= Empty
;
5954 -- The body of this procedure needs some comments ???
5956 if not Is_Entity_Name
(Name
) then
5958 ("argument of pragma% must be entity name", Arg
);
5960 elsif not Is_Overloaded
(Name
) then
5961 Proc
:= Entity
(Name
);
5963 if Ekind
(Proc
) /= E_Procedure
5964 or else Present
(First_Formal
(Proc
))
5967 ("argument of pragma% must be parameterless procedure", Arg
);
5972 Found
: Boolean := False;
5974 Index
: Interp_Index
;
5977 Get_First_Interp
(Name
, Index
, It
);
5978 while Present
(It
.Nam
) loop
5981 if Ekind
(Proc
) = E_Procedure
5982 and then No
(First_Formal
(Proc
))
5986 Set_Entity
(Name
, Proc
);
5987 Set_Is_Overloaded
(Name
, False);
5990 ("ambiguous handler name for pragma% ", Arg
);
5994 Get_Next_Interp
(Index
, It
);
5999 ("argument of pragma% must be parameterless procedure",
6002 Proc
:= Entity
(Name
);
6008 end Find_Unique_Parameterless_Procedure
;
6014 function Fix_Error
(Msg
: String) return String is
6015 Res
: String (Msg
'Range) := Msg
;
6016 Res_Last
: Natural := Msg
'Last;
6020 -- If we have a rewriting of another pragma, go to that pragma
6022 if Is_Rewrite_Substitution
(N
)
6023 and then Nkind
(Original_Node
(N
)) = N_Pragma
6025 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6028 -- Case where pragma comes from an aspect specification
6030 if From_Aspect_Specification
(N
) then
6032 -- Change appearence of "pragma" in message to "aspect"
6035 while J
<= Res_Last
- 5 loop
6036 if Res
(J
.. J
+ 5) = "pragma" then
6037 Res
(J
.. J
+ 5) := "aspect";
6045 -- Change "argument of" at start of message to "entity for"
6048 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6050 Res
(Res
'First .. Res
'First + 9) := "entity for";
6051 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6052 Res
(Res
'First + 11 .. Res_Last
);
6053 Res_Last
:= Res_Last
- 1;
6056 -- Change "argument" at start of message to "entity"
6059 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6061 Res
(Res
'First .. Res
'First + 5) := "entity";
6062 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6063 Res
(Res
'First + 8 .. Res_Last
);
6064 Res_Last
:= Res_Last
- 2;
6067 -- Get name from corresponding aspect
6069 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6072 -- Return possibly modified message
6074 return Res
(Res
'First .. Res_Last
);
6077 -------------------------
6078 -- Gather_Associations --
6079 -------------------------
6081 procedure Gather_Associations
6083 Args
: out Args_List
)
6088 -- Initialize all parameters to Empty
6090 for J
in Args
'Range loop
6094 -- That's all we have to do if there are no argument associations
6096 if No
(Pragma_Argument_Associations
(N
)) then
6100 -- Otherwise first deal with any positional parameters present
6102 Arg
:= First
(Pragma_Argument_Associations
(N
));
6103 for Index
in Args
'Range loop
6104 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6105 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6109 -- Positional parameters all processed, if any left, then we
6110 -- have too many positional parameters.
6112 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6114 ("too many positional associations for pragma%", Arg
);
6117 -- Process named parameters if any are present
6119 while Present
(Arg
) loop
6120 if Chars
(Arg
) = No_Name
then
6122 ("positional association cannot follow named association",
6126 for Index
in Names
'Range loop
6127 if Names
(Index
) = Chars
(Arg
) then
6128 if Present
(Args
(Index
)) then
6130 ("duplicate argument association for pragma%", Arg
);
6132 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6137 if Index
= Names
'Last then
6138 Error_Msg_Name_1
:= Pname
;
6139 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6141 -- Check for possible misspelling
6143 for Index1
in Names
'Range loop
6144 if Is_Bad_Spelling_Of
6145 (Chars
(Arg
), Names
(Index1
))
6147 Error_Msg_Name_1
:= Names
(Index1
);
6148 Error_Msg_N
-- CODEFIX
6149 ("\possible misspelling of%", Arg
);
6161 end Gather_Associations
;
6167 procedure GNAT_Pragma
is
6169 -- We need to check the No_Implementation_Pragmas restriction for
6170 -- the case of a pragma from source. Note that the case of aspects
6171 -- generating corresponding pragmas marks these pragmas as not being
6172 -- from source, so this test also catches that case.
6174 if Comes_From_Source
(N
) then
6175 Check_Restriction
(No_Implementation_Pragmas
, N
);
6179 --------------------------
6180 -- Is_Before_First_Decl --
6181 --------------------------
6183 function Is_Before_First_Decl
6184 (Pragma_Node
: Node_Id
;
6185 Decls
: List_Id
) return Boolean
6187 Item
: Node_Id
:= First
(Decls
);
6190 -- Only other pragmas can come before this pragma
6193 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6196 elsif Item
= Pragma_Node
then
6202 end Is_Before_First_Decl
;
6204 -----------------------------
6205 -- Is_Configuration_Pragma --
6206 -----------------------------
6208 -- A configuration pragma must appear in the context clause of a
6209 -- compilation unit, and only other pragmas may precede it. Note that
6210 -- the test below also permits use in a configuration pragma file.
6212 function Is_Configuration_Pragma
return Boolean is
6213 Lis
: constant List_Id
:= List_Containing
(N
);
6214 Par
: constant Node_Id
:= Parent
(N
);
6218 -- If no parent, then we are in the configuration pragma file,
6219 -- so the placement is definitely appropriate.
6224 -- Otherwise we must be in the context clause of a compilation unit
6225 -- and the only thing allowed before us in the context list is more
6226 -- configuration pragmas.
6228 elsif Nkind
(Par
) = N_Compilation_Unit
6229 and then Context_Items
(Par
) = Lis
6236 elsif Nkind
(Prg
) /= N_Pragma
then
6246 end Is_Configuration_Pragma
;
6248 --------------------------
6249 -- Is_In_Context_Clause --
6250 --------------------------
6252 function Is_In_Context_Clause
return Boolean is
6254 Parent_Node
: Node_Id
;
6257 if not Is_List_Member
(N
) then
6261 Plist
:= List_Containing
(N
);
6262 Parent_Node
:= Parent
(Plist
);
6264 if Parent_Node
= Empty
6265 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6266 or else Context_Items
(Parent_Node
) /= Plist
6273 end Is_In_Context_Clause
;
6275 ---------------------------------
6276 -- Is_Static_String_Expression --
6277 ---------------------------------
6279 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6280 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6281 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6284 Analyze_And_Resolve
(Argx
);
6286 -- Special case Ada 83, where the expression will never be static,
6287 -- but we will return true if we had a string literal to start with.
6289 if Ada_Version
= Ada_83
then
6292 -- Normal case, true only if we end up with a string literal that
6293 -- is marked as being the result of evaluating a static expression.
6296 return Is_OK_Static_Expression
(Argx
)
6297 and then Nkind
(Argx
) = N_String_Literal
;
6300 end Is_Static_String_Expression
;
6302 ----------------------
6303 -- Pragma_Misplaced --
6304 ----------------------
6306 procedure Pragma_Misplaced
is
6308 Error_Pragma
("incorrect placement of pragma%");
6309 end Pragma_Misplaced
;
6311 ------------------------------------------------
6312 -- Process_Atomic_Independent_Shared_Volatile --
6313 ------------------------------------------------
6315 procedure Process_Atomic_Independent_Shared_Volatile
is
6321 procedure Set_Atomic_VFA
(E
: Entity_Id
);
6322 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6323 -- no explicit alignment was given, set alignment to unknown, since
6324 -- back end knows what the alignment requirements are for atomic and
6325 -- full access arrays. Note: this is necessary for derived types.
6327 --------------------
6328 -- Set_Atomic_VFA --
6329 --------------------
6331 procedure Set_Atomic_VFA
(E
: Entity_Id
) is
6333 if Prag_Id
= Pragma_Volatile_Full_Access
then
6334 Set_Is_Volatile_Full_Access
(E
);
6339 if not Has_Alignment_Clause
(E
) then
6340 Set_Alignment
(E
, Uint_0
);
6344 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6347 Check_Ada_83_Warning
;
6348 Check_No_Identifiers
;
6349 Check_Arg_Count
(1);
6350 Check_Arg_Is_Local_Name
(Arg1
);
6351 E_Id
:= Get_Pragma_Arg
(Arg1
);
6353 if Etype
(E_Id
) = Any_Type
then
6358 D
:= Declaration_Node
(E
);
6361 -- A pragma that applies to a Ghost entity becomes Ghost for the
6362 -- purposes of legality checks and removal of ignored Ghost code.
6364 Mark_Pragma_As_Ghost
(N
, E
);
6366 -- Check duplicate before we chain ourselves
6368 Check_Duplicate_Pragma
(E
);
6370 -- Check Atomic and VFA used together
6372 if (Is_Atomic
(E
) and then Prag_Id
= Pragma_Volatile_Full_Access
)
6373 or else (Is_Volatile_Full_Access
(E
)
6374 and then (Prag_Id
= Pragma_Atomic
6376 Prag_Id
= Pragma_Shared
))
6379 ("cannot have Volatile_Full_Access and Atomic for same entity");
6382 -- Check for applying VFA to an entity which has aliased component
6384 if Prag_Id
= Pragma_Volatile_Full_Access
then
6387 Aliased_Comp
: Boolean := False;
6388 -- Set True if aliased component present
6391 if Is_Array_Type
(Etype
(E
)) then
6392 Aliased_Comp
:= Has_Aliased_Components
(Etype
(E
));
6394 -- Record case, too bad Has_Aliased_Components is not also
6395 -- set for records, should it be ???
6397 elsif Is_Record_Type
(Etype
(E
)) then
6398 Comp
:= First_Component_Or_Discriminant
(Etype
(E
));
6399 while Present
(Comp
) loop
6400 if Is_Aliased
(Comp
)
6401 or else Is_Aliased
(Etype
(Comp
))
6403 Aliased_Comp
:= True;
6407 Next_Component_Or_Discriminant
(Comp
);
6411 if Aliased_Comp
then
6413 ("cannot apply Volatile_Full_Access (aliased component "
6419 -- Now check appropriateness of the entity
6422 if Rep_Item_Too_Early
(E
, N
)
6424 Rep_Item_Too_Late
(E
, N
)
6428 Check_First_Subtype
(Arg1
);
6431 -- Attribute belongs on the base type. If the view of the type is
6432 -- currently private, it also belongs on the underlying type.
6434 if Prag_Id
= Pragma_Atomic
6436 Prag_Id
= Pragma_Shared
6438 Prag_Id
= Pragma_Volatile_Full_Access
6441 Set_Atomic_VFA
(Base_Type
(E
));
6442 Set_Atomic_VFA
(Underlying_Type
(E
));
6445 -- Atomic/Shared/Volatile_Full_Access imply Independent
6447 if Prag_Id
/= Pragma_Volatile
then
6448 Set_Is_Independent
(E
);
6449 Set_Is_Independent
(Base_Type
(E
));
6450 Set_Is_Independent
(Underlying_Type
(E
));
6452 if Prag_Id
= Pragma_Independent
then
6453 Record_Independence_Check
(N
, Base_Type
(E
));
6457 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6459 if Prag_Id
/= Pragma_Independent
then
6460 Set_Is_Volatile
(E
);
6461 Set_Is_Volatile
(Base_Type
(E
));
6462 Set_Is_Volatile
(Underlying_Type
(E
));
6464 Set_Treat_As_Volatile
(E
);
6465 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6468 elsif K
= N_Object_Declaration
6469 or else (K
= N_Component_Declaration
6470 and then Original_Record_Component
(E
) = E
)
6472 if Rep_Item_Too_Late
(E
, N
) then
6476 if Prag_Id
= Pragma_Atomic
6478 Prag_Id
= Pragma_Shared
6480 Prag_Id
= Pragma_Volatile_Full_Access
6482 if Prag_Id
= Pragma_Volatile_Full_Access
then
6483 Set_Is_Volatile_Full_Access
(E
);
6488 -- If the object declaration has an explicit initialization, a
6489 -- temporary may have to be created to hold the expression, to
6490 -- ensure that access to the object remain atomic.
6492 if Nkind
(Parent
(E
)) = N_Object_Declaration
6493 and then Present
(Expression
(Parent
(E
)))
6495 Set_Has_Delayed_Freeze
(E
);
6499 -- Atomic/Shared/Volatile_Full_Access imply Independent
6501 if Prag_Id
/= Pragma_Volatile
then
6502 Set_Is_Independent
(E
);
6504 if Prag_Id
= Pragma_Independent
then
6505 Record_Independence_Check
(N
, E
);
6509 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6511 if Prag_Id
/= Pragma_Independent
then
6512 Set_Is_Volatile
(E
);
6513 Set_Treat_As_Volatile
(E
);
6517 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6520 -- The following check is only relevant when SPARK_Mode is on as
6521 -- this is not a standard Ada legality rule. Pragma Volatile can
6522 -- only apply to a full type declaration or an object declaration
6523 -- (SPARK RM C.6(1)).
6526 and then Prag_Id
= Pragma_Volatile
6527 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6528 N_Object_Declaration
)
6531 ("argument of pragma % must denote a full type or object "
6532 & "declaration", Arg1
);
6534 end Process_Atomic_Independent_Shared_Volatile
;
6536 -------------------------------------------
6537 -- Process_Compile_Time_Warning_Or_Error --
6538 -------------------------------------------
6540 procedure Process_Compile_Time_Warning_Or_Error
is
6541 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6544 Check_Arg_Count
(2);
6545 Check_No_Identifiers
;
6546 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6547 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6549 if Compile_Time_Known_Value
(Arg1x
) then
6550 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6552 Str
: constant String_Id
:=
6553 Strval
(Get_Pragma_Arg
(Arg2
));
6554 Len
: constant Int
:= String_Length
(Str
);
6559 Cent
: constant Entity_Id
:=
6560 Cunit_Entity
(Current_Sem_Unit
);
6562 Force
: constant Boolean :=
6563 Prag_Id
= Pragma_Compile_Time_Warning
6565 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6566 and then (Ekind
(Cent
) /= E_Package
6567 or else not In_Private_Part
(Cent
));
6568 -- Set True if this is the warning case, and we are in the
6569 -- visible part of a package spec, or in a subprogram spec,
6570 -- in which case we want to force the client to see the
6571 -- warning, even though it is not in the main unit.
6574 -- Loop through segments of message separated by line feeds.
6575 -- We output these segments as separate messages with
6576 -- continuation marks for all but the first.
6581 Error_Msg_Strlen
:= 0;
6583 -- Loop to copy characters from argument to error message
6587 exit when Ptr
> Len
;
6588 CC
:= Get_String_Char
(Str
, Ptr
);
6591 -- Ignore wide chars ??? else store character
6593 if In_Character_Range
(CC
) then
6594 C
:= Get_Character
(CC
);
6595 exit when C
= ASCII
.LF
;
6596 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6597 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6601 -- Here with one line ready to go
6603 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6605 -- If this is a warning in a spec, then we want clients
6606 -- to see the warning, so mark the message with the
6607 -- special sequence !! to force the warning. In the case
6608 -- of a package spec, we do not force this if we are in
6609 -- the private part of the spec.
6612 if Cont
= False then
6613 Error_Msg_N
("<<~!!", Arg1
);
6616 Error_Msg_N
("\<<~!!", Arg1
);
6619 -- Error, rather than warning, or in a body, so we do not
6620 -- need to force visibility for client (error will be
6621 -- output in any case, and this is the situation in which
6622 -- we do not want a client to get a warning, since the
6623 -- warning is in the body or the spec private part).
6626 if Cont
= False then
6627 Error_Msg_N
("<<~", Arg1
);
6630 Error_Msg_N
("\<<~", Arg1
);
6634 exit when Ptr
> Len
;
6639 end Process_Compile_Time_Warning_Or_Error
;
6641 ------------------------
6642 -- Process_Convention --
6643 ------------------------
6645 procedure Process_Convention
6646 (C
: out Convention_Id
;
6647 Ent
: out Entity_Id
)
6651 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6652 -- Called if we have more than one Export/Import/Convention pragma.
6653 -- This is generally illegal, but we have a special case of allowing
6654 -- Import and Interface to coexist if they specify the convention in
6655 -- a consistent manner. We are allowed to do this, since Interface is
6656 -- an implementation defined pragma, and we choose to do it since we
6657 -- know Rational allows this combination. S is the entity id of the
6658 -- subprogram in question. This procedure also sets the special flag
6659 -- Import_Interface_Present in both pragmas in the case where we do
6660 -- have matching Import and Interface pragmas.
6662 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6663 -- Set convention in entity E, and also flag that the entity has a
6664 -- convention pragma. If entity is for a private or incomplete type,
6665 -- also set convention and flag on underlying type. This procedure
6666 -- also deals with the special case of C_Pass_By_Copy convention,
6667 -- and error checks for inappropriate convention specification.
6669 -------------------------------
6670 -- Diagnose_Multiple_Pragmas --
6671 -------------------------------
6673 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6674 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6678 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6679 -- Decl is a pragma node. This function returns True if this
6680 -- pragma has a first argument that is an identifier with a
6681 -- Chars field corresponding to the Convention_Id C.
6683 function Same_Name
(Decl
: Node_Id
) return Boolean;
6684 -- Decl is a pragma node. This function returns True if this
6685 -- pragma has a second argument that is an identifier with a
6686 -- Chars field that matches the Chars of the current subprogram.
6688 ---------------------
6689 -- Same_Convention --
6690 ---------------------
6692 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6693 Arg1
: constant Node_Id
:=
6694 First
(Pragma_Argument_Associations
(Decl
));
6697 if Present
(Arg1
) then
6699 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6701 if Nkind
(Arg
) = N_Identifier
6702 and then Is_Convention_Name
(Chars
(Arg
))
6703 and then Get_Convention_Id
(Chars
(Arg
)) = C
6711 end Same_Convention
;
6717 function Same_Name
(Decl
: Node_Id
) return Boolean is
6718 Arg1
: constant Node_Id
:=
6719 First
(Pragma_Argument_Associations
(Decl
));
6727 Arg2
:= Next
(Arg1
);
6734 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6736 if Nkind
(Arg
) = N_Identifier
6737 and then Chars
(Arg
) = Chars
(S
)
6746 -- Start of processing for Diagnose_Multiple_Pragmas
6751 -- Definitely give message if we have Convention/Export here
6753 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6756 -- If we have an Import or Export, scan back from pragma to
6757 -- find any previous pragma applying to the same procedure.
6758 -- The scan will be terminated by the start of the list, or
6759 -- hitting the subprogram declaration. This won't allow one
6760 -- pragma to appear in the public part and one in the private
6761 -- part, but that seems very unlikely in practice.
6765 while Present
(Decl
) and then Decl
/= Pdec
loop
6767 -- Look for pragma with same name as us
6769 if Nkind
(Decl
) = N_Pragma
6770 and then Same_Name
(Decl
)
6772 -- Give error if same as our pragma or Export/Convention
6774 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6780 -- Case of Import/Interface or the other way round
6782 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6785 -- Here we know that we have Import and Interface. It
6786 -- doesn't matter which way round they are. See if
6787 -- they specify the same convention. If so, all OK,
6788 -- and set special flags to stop other messages
6790 if Same_Convention
(Decl
) then
6791 Set_Import_Interface_Present
(N
);
6792 Set_Import_Interface_Present
(Decl
);
6795 -- If different conventions, special message
6798 Error_Msg_Sloc
:= Sloc
(Decl
);
6800 ("convention differs from that given#", Arg1
);
6810 -- Give message if needed if we fall through those tests
6811 -- except on Relaxed_RM_Semantics where we let go: either this
6812 -- is a case accepted/ignored by other Ada compilers (e.g.
6813 -- a mix of Convention and Import), or another error will be
6814 -- generated later (e.g. using both Import and Export).
6816 if Err
and not Relaxed_RM_Semantics
then
6818 ("at most one Convention/Export/Import pragma is allowed",
6821 end Diagnose_Multiple_Pragmas
;
6823 --------------------------------
6824 -- Set_Convention_From_Pragma --
6825 --------------------------------
6827 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6829 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6830 -- for an overridden dispatching operation. Technically this is
6831 -- an amendment and should only be done in Ada 2005 mode. However,
6832 -- this is clearly a mistake, since the problem that is addressed
6833 -- by this AI is that there is a clear gap in the RM.
6835 if Is_Dispatching_Operation
(E
)
6836 and then Present
(Overridden_Operation
(E
))
6837 and then C
/= Convention
(Overridden_Operation
(E
))
6840 ("cannot change convention for overridden dispatching "
6841 & "operation", Arg1
);
6844 -- Special checks for Convention_Stdcall
6846 if C
= Convention_Stdcall
then
6848 -- A dispatching call is not allowed. A dispatching subprogram
6849 -- cannot be used to interface to the Win32 API, so in fact
6850 -- this check does not impose any effective restriction.
6852 if Is_Dispatching_Operation
(E
) then
6853 Error_Msg_Sloc
:= Sloc
(E
);
6855 -- Note: make this unconditional so that if there is more
6856 -- than one call to which the pragma applies, we get a
6857 -- message for each call. Also don't use Error_Pragma,
6858 -- so that we get multiple messages.
6861 ("dispatching subprogram# cannot use Stdcall convention!",
6864 -- Subprograms are not allowed
6866 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6870 and then Ekind
(E
) /= E_Variable
6872 -- An access to subprogram is also allowed
6876 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6878 -- Allow internal call to set convention of subprogram type
6880 and then not (Ekind
(E
) = E_Subprogram_Type
)
6883 ("second argument of pragma% must be subprogram (type)",
6888 -- Set the convention
6890 Set_Convention
(E
, C
);
6891 Set_Has_Convention_Pragma
(E
);
6893 -- For the case of a record base type, also set the convention of
6894 -- any anonymous access types declared in the record which do not
6895 -- currently have a specified convention.
6897 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6902 Comp
:= First_Component
(E
);
6903 while Present
(Comp
) loop
6904 if Present
(Etype
(Comp
))
6905 and then Ekind_In
(Etype
(Comp
),
6906 E_Anonymous_Access_Type
,
6907 E_Anonymous_Access_Subprogram_Type
)
6908 and then not Has_Convention_Pragma
(Comp
)
6910 Set_Convention
(Comp
, C
);
6913 Next_Component
(Comp
);
6918 -- Deal with incomplete/private type case, where underlying type
6919 -- is available, so set convention of that underlying type.
6921 if Is_Incomplete_Or_Private_Type
(E
)
6922 and then Present
(Underlying_Type
(E
))
6924 Set_Convention
(Underlying_Type
(E
), C
);
6925 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6928 -- A class-wide type should inherit the convention of the specific
6929 -- root type (although this isn't specified clearly by the RM).
6931 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6932 Set_Convention
(Class_Wide_Type
(E
), C
);
6935 -- If the entity is a record type, then check for special case of
6936 -- C_Pass_By_Copy, which is treated the same as C except that the
6937 -- special record flag is set. This convention is only permitted
6938 -- on record types (see AI95-00131).
6940 if Cname
= Name_C_Pass_By_Copy
then
6941 if Is_Record_Type
(E
) then
6942 Set_C_Pass_By_Copy
(Base_Type
(E
));
6943 elsif Is_Incomplete_Or_Private_Type
(E
)
6944 and then Is_Record_Type
(Underlying_Type
(E
))
6946 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6949 ("C_Pass_By_Copy convention allowed only for record type",
6954 -- If the entity is a derived boolean type, check for the special
6955 -- case of convention C, C++, or Fortran, where we consider any
6956 -- nonzero value to represent true.
6958 if Is_Discrete_Type
(E
)
6959 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6965 C
= Convention_Fortran
)
6967 Set_Nonzero_Is_True
(Base_Type
(E
));
6969 end Set_Convention_From_Pragma
;
6973 Comp_Unit
: Unit_Number_Type
;
6978 -- Start of processing for Process_Convention
6981 Check_At_Least_N_Arguments
(2);
6982 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6983 Check_Arg_Is_Identifier
(Arg1
);
6984 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6986 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6987 -- tested again below to set the critical flag).
6989 if Cname
= Name_C_Pass_By_Copy
then
6992 -- Otherwise we must have something in the standard convention list
6994 elsif Is_Convention_Name
(Cname
) then
6995 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6997 -- Otherwise warn on unrecognized convention
7000 if Warn_On_Export_Import
then
7002 ("??unrecognized convention name, C assumed",
7003 Get_Pragma_Arg
(Arg1
));
7009 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7010 Check_Arg_Is_Local_Name
(Arg2
);
7012 Id
:= Get_Pragma_Arg
(Arg2
);
7015 if not Is_Entity_Name
(Id
) then
7016 Error_Pragma_Arg
("entity name required", Arg2
);
7021 -- Set entity to return
7025 -- Ada_Pass_By_Copy special checking
7027 if C
= Convention_Ada_Pass_By_Copy
then
7028 if not Is_First_Subtype
(E
) then
7030 ("convention `Ada_Pass_By_Copy` only allowed for types",
7034 if Is_By_Reference_Type
(E
) then
7036 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7040 -- Ada_Pass_By_Reference special checking
7042 elsif C
= Convention_Ada_Pass_By_Reference
then
7043 if not Is_First_Subtype
(E
) then
7045 ("convention `Ada_Pass_By_Reference` only allowed for types",
7049 if Is_By_Copy_Type
(E
) then
7051 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7056 -- Go to renamed subprogram if present, since convention applies to
7057 -- the actual renamed entity, not to the renaming entity. If the
7058 -- subprogram is inherited, go to parent subprogram.
7060 if Is_Subprogram
(E
)
7061 and then Present
(Alias
(E
))
7063 if Nkind
(Parent
(Declaration_Node
(E
))) =
7064 N_Subprogram_Renaming_Declaration
7066 if Scope
(E
) /= Scope
(Alias
(E
)) then
7068 ("cannot apply pragma% to non-local entity&#", E
);
7073 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
7074 N_Private_Extension_Declaration
)
7075 and then Scope
(E
) = Scope
(Alias
(E
))
7079 -- Return the parent subprogram the entity was inherited from
7085 -- Check that we are not applying this to a specless body. Relax this
7086 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
7088 if Is_Subprogram
(E
)
7089 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
7090 and then not Relaxed_RM_Semantics
7093 ("pragma% requires separate spec and must come before body");
7096 -- Check that we are not applying this to a named constant
7098 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
7099 Error_Msg_Name_1
:= Pname
;
7101 ("cannot apply pragma% to named constant!",
7102 Get_Pragma_Arg
(Arg2
));
7104 ("\supply appropriate type for&!", Arg2
);
7107 if Ekind
(E
) = E_Enumeration_Literal
then
7108 Error_Pragma
("enumeration literal not allowed for pragma%");
7111 -- Check for rep item appearing too early or too late
7113 if Etype
(E
) = Any_Type
7114 or else Rep_Item_Too_Early
(E
, N
)
7118 elsif Present
(Underlying_Type
(E
)) then
7119 E
:= Underlying_Type
(E
);
7122 if Rep_Item_Too_Late
(E
, N
) then
7126 if Has_Convention_Pragma
(E
) then
7127 Diagnose_Multiple_Pragmas
(E
);
7129 elsif Convention
(E
) = Convention_Protected
7130 or else Ekind
(Scope
(E
)) = E_Protected_Type
7133 ("a protected operation cannot be given a different convention",
7137 -- For Intrinsic, a subprogram is required
7139 if C
= Convention_Intrinsic
7140 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7142 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7144 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
7146 ("second argument of pragma% must be a subprogram", Arg2
);
7150 -- Deal with non-subprogram cases
7152 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
7153 Set_Convention_From_Pragma
(E
);
7157 -- The pragma must apply to a first subtype, but it can also
7158 -- apply to a generic type in a generic formal part, in which
7159 -- case it will also appear in the corresponding instance.
7161 if Is_Generic_Type
(E
) or else In_Instance
then
7164 Check_First_Subtype
(Arg2
);
7167 Set_Convention_From_Pragma
(Base_Type
(E
));
7169 -- For access subprograms, we must set the convention on the
7170 -- internally generated directly designated type as well.
7172 if Ekind
(E
) = E_Access_Subprogram_Type
then
7173 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7177 -- For the subprogram case, set proper convention for all homonyms
7178 -- in same scope and the same declarative part, i.e. the same
7179 -- compilation unit.
7182 Comp_Unit
:= Get_Source_Unit
(E
);
7183 Set_Convention_From_Pragma
(E
);
7185 -- Treat a pragma Import as an implicit body, and pragma import
7186 -- as implicit reference (for navigation in GPS).
7188 if Prag_Id
= Pragma_Import
then
7189 Generate_Reference
(E
, Id
, 'b');
7191 -- For exported entities we restrict the generation of references
7192 -- to entities exported to foreign languages since entities
7193 -- exported to Ada do not provide further information to GPS and
7194 -- add undesired references to the output of the gnatxref tool.
7196 elsif Prag_Id
= Pragma_Export
7197 and then Convention
(E
) /= Convention_Ada
7199 Generate_Reference
(E
, Id
, 'i');
7202 -- If the pragma comes from an aspect, it only applies to the
7203 -- given entity, not its homonyms.
7205 if From_Aspect_Specification
(N
) then
7209 -- Otherwise Loop through the homonyms of the pragma argument's
7210 -- entity, an apply convention to those in the current scope.
7216 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7218 -- Ignore entry for which convention is already set
7220 if Has_Convention_Pragma
(E1
) then
7224 -- Do not set the pragma on inherited operations or on formal
7227 if Comes_From_Source
(E1
)
7228 and then Comp_Unit
= Get_Source_Unit
(E1
)
7229 and then not Is_Formal_Subprogram
(E1
)
7230 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7231 N_Full_Type_Declaration
7233 if Present
(Alias
(E1
))
7234 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7237 ("cannot apply pragma% to non-local entity& declared#",
7241 Set_Convention_From_Pragma
(E1
);
7243 if Prag_Id
= Pragma_Import
then
7244 Generate_Reference
(E1
, Id
, 'b');
7252 end Process_Convention
;
7254 ----------------------------------------
7255 -- Process_Disable_Enable_Atomic_Sync --
7256 ----------------------------------------
7258 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7260 Check_No_Identifiers
;
7261 Check_At_Most_N_Arguments
(1);
7263 -- Modeled internally as
7264 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7268 Pragma_Identifier
=>
7269 Make_Identifier
(Loc
, Nam
),
7270 Pragma_Argument_Associations
=> New_List
(
7271 Make_Pragma_Argument_Association
(Loc
,
7273 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7275 if Present
(Arg1
) then
7276 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7280 end Process_Disable_Enable_Atomic_Sync
;
7282 -------------------------------------------------
7283 -- Process_Extended_Import_Export_Internal_Arg --
7284 -------------------------------------------------
7286 procedure Process_Extended_Import_Export_Internal_Arg
7287 (Arg_Internal
: Node_Id
:= Empty
)
7290 if No
(Arg_Internal
) then
7291 Error_Pragma
("Internal parameter required for pragma%");
7294 if Nkind
(Arg_Internal
) = N_Identifier
then
7297 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7298 and then (Prag_Id
= Pragma_Import_Function
7300 Prag_Id
= Pragma_Export_Function
)
7306 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7309 Check_Arg_Is_Local_Name
(Arg_Internal
);
7310 end Process_Extended_Import_Export_Internal_Arg
;
7312 --------------------------------------------------
7313 -- Process_Extended_Import_Export_Object_Pragma --
7314 --------------------------------------------------
7316 procedure Process_Extended_Import_Export_Object_Pragma
7317 (Arg_Internal
: Node_Id
;
7318 Arg_External
: Node_Id
;
7324 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7325 Def_Id
:= Entity
(Arg_Internal
);
7327 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7329 ("pragma% must designate an object", Arg_Internal
);
7332 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7334 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7337 ("previous Common/Psect_Object applies, pragma % not permitted",
7341 if Rep_Item_Too_Late
(Def_Id
, N
) then
7345 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7347 if Present
(Arg_Size
) then
7348 Check_Arg_Is_External_Name
(Arg_Size
);
7351 -- Export_Object case
7353 if Prag_Id
= Pragma_Export_Object
then
7354 if not Is_Library_Level_Entity
(Def_Id
) then
7356 ("argument for pragma% must be library level entity",
7360 if Ekind
(Current_Scope
) = E_Generic_Package
then
7361 Error_Pragma
("pragma& cannot appear in a generic unit");
7364 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7366 ("exported object must have compile time known size",
7370 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7371 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7373 Set_Exported
(Def_Id
, Arg_Internal
);
7376 -- Import_Object case
7379 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7381 ("cannot use pragma% for task/protected object",
7385 if Ekind
(Def_Id
) = E_Constant
then
7387 ("cannot import a constant", Arg_Internal
);
7390 if Warn_On_Export_Import
7391 and then Has_Discriminants
(Etype
(Def_Id
))
7394 ("imported value must be initialized??", Arg_Internal
);
7397 if Warn_On_Export_Import
7398 and then Is_Access_Type
(Etype
(Def_Id
))
7401 ("cannot import object of an access type??", Arg_Internal
);
7404 if Warn_On_Export_Import
7405 and then Is_Imported
(Def_Id
)
7407 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7409 -- Check for explicit initialization present. Note that an
7410 -- initialization generated by the code generator, e.g. for an
7411 -- access type, does not count here.
7413 elsif Present
(Expression
(Parent
(Def_Id
)))
7416 (Original_Node
(Expression
(Parent
(Def_Id
))))
7418 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7420 ("imported entities cannot be initialized (RM B.1(24))",
7421 "\no initialization allowed for & declared#", Arg1
);
7423 Set_Imported
(Def_Id
);
7424 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7427 end Process_Extended_Import_Export_Object_Pragma
;
7429 ------------------------------------------------------
7430 -- Process_Extended_Import_Export_Subprogram_Pragma --
7431 ------------------------------------------------------
7433 procedure Process_Extended_Import_Export_Subprogram_Pragma
7434 (Arg_Internal
: Node_Id
;
7435 Arg_External
: Node_Id
;
7436 Arg_Parameter_Types
: Node_Id
;
7437 Arg_Result_Type
: Node_Id
:= Empty
;
7438 Arg_Mechanism
: Node_Id
;
7439 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7445 Ambiguous
: Boolean;
7448 function Same_Base_Type
7450 Formal
: Entity_Id
) return Boolean;
7451 -- Determines if Ptype references the type of Formal. Note that only
7452 -- the base types need to match according to the spec. Ptype here is
7453 -- the argument from the pragma, which is either a type name, or an
7454 -- access attribute.
7456 --------------------
7457 -- Same_Base_Type --
7458 --------------------
7460 function Same_Base_Type
7462 Formal
: Entity_Id
) return Boolean
7464 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7468 -- Case where pragma argument is typ'Access
7470 if Nkind
(Ptype
) = N_Attribute_Reference
7471 and then Attribute_Name
(Ptype
) = Name_Access
7473 Pref
:= Prefix
(Ptype
);
7476 if not Is_Entity_Name
(Pref
)
7477 or else Entity
(Pref
) = Any_Type
7482 -- We have a match if the corresponding argument is of an
7483 -- anonymous access type, and its designated type matches the
7484 -- type of the prefix of the access attribute
7486 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7487 and then Base_Type
(Entity
(Pref
)) =
7488 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7490 -- Case where pragma argument is a type name
7495 if not Is_Entity_Name
(Ptype
)
7496 or else Entity
(Ptype
) = Any_Type
7501 -- We have a match if the corresponding argument is of the type
7502 -- given in the pragma (comparing base types)
7504 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7508 -- Start of processing for
7509 -- Process_Extended_Import_Export_Subprogram_Pragma
7512 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7516 -- Loop through homonyms (overloadings) of the entity
7518 Hom_Id
:= Entity
(Arg_Internal
);
7519 while Present
(Hom_Id
) loop
7520 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7522 -- We need a subprogram in the current scope
7524 if not Is_Subprogram
(Def_Id
)
7525 or else Scope
(Def_Id
) /= Current_Scope
7532 -- Pragma cannot apply to subprogram body
7534 if Is_Subprogram
(Def_Id
)
7535 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7539 ("pragma% requires separate spec"
7540 & " and must come before body");
7543 -- Test result type if given, note that the result type
7544 -- parameter can only be present for the function cases.
7546 if Present
(Arg_Result_Type
)
7547 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7551 elsif Etype
(Def_Id
) /= Standard_Void_Type
7553 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7557 -- Test parameter types if given. Note that this parameter
7558 -- has not been analyzed (and must not be, since it is
7559 -- semantic nonsense), so we get it as the parser left it.
7561 elsif Present
(Arg_Parameter_Types
) then
7562 Check_Matching_Types
: declare
7567 Formal
:= First_Formal
(Def_Id
);
7569 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7570 if Present
(Formal
) then
7574 -- A list of one type, e.g. (List) is parsed as
7575 -- a parenthesized expression.
7577 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7578 and then Paren_Count
(Arg_Parameter_Types
) = 1
7581 or else Present
(Next_Formal
(Formal
))
7586 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7589 -- A list of more than one type is parsed as a aggregate
7591 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7592 and then Paren_Count
(Arg_Parameter_Types
) = 0
7594 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7595 while Present
(Ptype
) or else Present
(Formal
) loop
7598 or else not Same_Base_Type
(Ptype
, Formal
)
7603 Next_Formal
(Formal
);
7608 -- Anything else is of the wrong form
7612 ("wrong form for Parameter_Types parameter",
7613 Arg_Parameter_Types
);
7615 end Check_Matching_Types
;
7618 -- Match is now False if the entry we found did not match
7619 -- either a supplied Parameter_Types or Result_Types argument
7625 -- Ambiguous case, the flag Ambiguous shows if we already
7626 -- detected this and output the initial messages.
7629 if not Ambiguous
then
7631 Error_Msg_Name_1
:= Pname
;
7633 ("pragma% does not uniquely identify subprogram!",
7635 Error_Msg_Sloc
:= Sloc
(Ent
);
7636 Error_Msg_N
("matching subprogram #!", N
);
7640 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7641 Error_Msg_N
("matching subprogram #!", N
);
7646 Hom_Id
:= Homonym
(Hom_Id
);
7649 -- See if we found an entry
7652 if not Ambiguous
then
7653 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7655 ("pragma% cannot be given for generic subprogram");
7658 ("pragma% does not identify local subprogram");
7665 -- Import pragmas must be for imported entities
7667 if Prag_Id
= Pragma_Import_Function
7669 Prag_Id
= Pragma_Import_Procedure
7671 Prag_Id
= Pragma_Import_Valued_Procedure
7673 if not Is_Imported
(Ent
) then
7675 ("pragma Import or Interface must precede pragma%");
7678 -- Here we have the Export case which can set the entity as exported
7680 -- But does not do so if the specified external name is null, since
7681 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7682 -- compatible) to request no external name.
7684 elsif Nkind
(Arg_External
) = N_String_Literal
7685 and then String_Length
(Strval
(Arg_External
)) = 0
7689 -- In all other cases, set entity as exported
7692 Set_Exported
(Ent
, Arg_Internal
);
7695 -- Special processing for Valued_Procedure cases
7697 if Prag_Id
= Pragma_Import_Valued_Procedure
7699 Prag_Id
= Pragma_Export_Valued_Procedure
7701 Formal
:= First_Formal
(Ent
);
7704 Error_Pragma
("at least one parameter required for pragma%");
7706 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7707 Error_Pragma
("first parameter must have mode out for pragma%");
7710 Set_Is_Valued_Procedure
(Ent
);
7714 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7716 -- Process Result_Mechanism argument if present. We have already
7717 -- checked that this is only allowed for the function case.
7719 if Present
(Arg_Result_Mechanism
) then
7720 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7723 -- Process Mechanism parameter if present. Note that this parameter
7724 -- is not analyzed, and must not be analyzed since it is semantic
7725 -- nonsense, so we get it in exactly as the parser left it.
7727 if Present
(Arg_Mechanism
) then
7735 -- A single mechanism association without a formal parameter
7736 -- name is parsed as a parenthesized expression. All other
7737 -- cases are parsed as aggregates, so we rewrite the single
7738 -- parameter case as an aggregate for consistency.
7740 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7741 and then Paren_Count
(Arg_Mechanism
) = 1
7743 Rewrite
(Arg_Mechanism
,
7744 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7745 Expressions
=> New_List
(
7746 Relocate_Node
(Arg_Mechanism
))));
7749 -- Case of only mechanism name given, applies to all formals
7751 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7752 Formal
:= First_Formal
(Ent
);
7753 while Present
(Formal
) loop
7754 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7755 Next_Formal
(Formal
);
7758 -- Case of list of mechanism associations given
7761 if Null_Record_Present
(Arg_Mechanism
) then
7763 ("inappropriate form for Mechanism parameter",
7767 -- Deal with positional ones first
7769 Formal
:= First_Formal
(Ent
);
7771 if Present
(Expressions
(Arg_Mechanism
)) then
7772 Mname
:= First
(Expressions
(Arg_Mechanism
));
7773 while Present
(Mname
) loop
7776 ("too many mechanism associations", Mname
);
7779 Set_Mechanism_Value
(Formal
, Mname
);
7780 Next_Formal
(Formal
);
7785 -- Deal with named entries
7787 if Present
(Component_Associations
(Arg_Mechanism
)) then
7788 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7789 while Present
(Massoc
) loop
7790 Choice
:= First
(Choices
(Massoc
));
7792 if Nkind
(Choice
) /= N_Identifier
7793 or else Present
(Next
(Choice
))
7796 ("incorrect form for mechanism association",
7800 Formal
:= First_Formal
(Ent
);
7804 ("parameter name & not present", Choice
);
7807 if Chars
(Choice
) = Chars
(Formal
) then
7809 (Formal
, Expression
(Massoc
));
7811 -- Set entity on identifier (needed by ASIS)
7813 Set_Entity
(Choice
, Formal
);
7818 Next_Formal
(Formal
);
7827 end Process_Extended_Import_Export_Subprogram_Pragma
;
7829 --------------------------
7830 -- Process_Generic_List --
7831 --------------------------
7833 procedure Process_Generic_List
is
7838 Check_No_Identifiers
;
7839 Check_At_Least_N_Arguments
(1);
7841 -- Check all arguments are names of generic units or instances
7844 while Present
(Arg
) loop
7845 Exp
:= Get_Pragma_Arg
(Arg
);
7848 if not Is_Entity_Name
(Exp
)
7850 (not Is_Generic_Instance
(Entity
(Exp
))
7852 not Is_Generic_Unit
(Entity
(Exp
)))
7855 ("pragma% argument must be name of generic unit/instance",
7861 end Process_Generic_List
;
7863 ------------------------------------
7864 -- Process_Import_Predefined_Type --
7865 ------------------------------------
7867 procedure Process_Import_Predefined_Type
is
7868 Loc
: constant Source_Ptr
:= Sloc
(N
);
7870 Ftyp
: Node_Id
:= Empty
;
7876 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7879 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7880 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7884 Ftyp
:= Node
(Elmt
);
7886 if Present
(Ftyp
) then
7888 -- Don't build a derived type declaration, because predefined C
7889 -- types have no declaration anywhere, so cannot really be named.
7890 -- Instead build a full type declaration, starting with an
7891 -- appropriate type definition is built
7893 if Is_Floating_Point_Type
(Ftyp
) then
7894 Def
:= Make_Floating_Point_Definition
(Loc
,
7895 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7896 Make_Real_Range_Specification
(Loc
,
7897 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7898 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7900 -- Should never have a predefined type we cannot handle
7903 raise Program_Error
;
7906 -- Build and insert a Full_Type_Declaration, which will be
7907 -- analyzed as soon as this list entry has been analyzed.
7909 Decl
:= Make_Full_Type_Declaration
(Loc
,
7910 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7911 Type_Definition
=> Def
);
7913 Insert_After
(N
, Decl
);
7914 Mark_Rewrite_Insertion
(Decl
);
7917 Error_Pragma_Arg
("no matching type found for pragma%",
7920 end Process_Import_Predefined_Type
;
7922 ---------------------------------
7923 -- Process_Import_Or_Interface --
7924 ---------------------------------
7926 procedure Process_Import_Or_Interface
is
7932 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7933 -- pragma Import (Entity, "external name");
7935 if Relaxed_RM_Semantics
7936 and then Arg_Count
= 2
7937 and then Prag_Id
= Pragma_Import
7938 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7941 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7944 if not Is_Entity_Name
(Def_Id
) then
7945 Error_Pragma_Arg
("entity name required", Arg1
);
7948 Def_Id
:= Entity
(Def_Id
);
7949 Kill_Size_Check_Code
(Def_Id
);
7950 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7953 Process_Convention
(C
, Def_Id
);
7955 -- A pragma that applies to a Ghost entity becomes Ghost for the
7956 -- purposes of legality checks and removal of ignored Ghost code.
7958 Mark_Pragma_As_Ghost
(N
, Def_Id
);
7959 Kill_Size_Check_Code
(Def_Id
);
7960 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7963 -- Various error checks
7965 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7967 -- We do not permit Import to apply to a renaming declaration
7969 if Present
(Renamed_Object
(Def_Id
)) then
7971 ("pragma% not allowed for object renaming", Arg2
);
7973 -- User initialization is not allowed for imported object, but
7974 -- the object declaration may contain a default initialization,
7975 -- that will be discarded. Note that an explicit initialization
7976 -- only counts if it comes from source, otherwise it is simply
7977 -- the code generator making an implicit initialization explicit.
7979 elsif Present
(Expression
(Parent
(Def_Id
)))
7980 and then Comes_From_Source
7981 (Original_Node
(Expression
(Parent
(Def_Id
))))
7983 -- Set imported flag to prevent cascaded errors
7985 Set_Is_Imported
(Def_Id
);
7987 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7989 ("no initialization allowed for declaration of& #",
7990 "\imported entities cannot be initialized (RM B.1(24))",
7994 -- If the pragma comes from an aspect specification the
7995 -- Is_Imported flag has already been set.
7997 if not From_Aspect_Specification
(N
) then
7998 Set_Imported
(Def_Id
);
8001 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8003 -- Note that we do not set Is_Public here. That's because we
8004 -- only want to set it if there is no address clause, and we
8005 -- don't know that yet, so we delay that processing till
8008 -- pragma Import completes deferred constants
8010 if Ekind
(Def_Id
) = E_Constant
then
8011 Set_Has_Completion
(Def_Id
);
8014 -- It is not possible to import a constant of an unconstrained
8015 -- array type (e.g. string) because there is no simple way to
8016 -- write a meaningful subtype for it.
8018 if Is_Array_Type
(Etype
(Def_Id
))
8019 and then not Is_Constrained
(Etype
(Def_Id
))
8022 ("imported constant& must have a constrained subtype",
8027 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8029 -- If the name is overloaded, pragma applies to all of the denoted
8030 -- entities in the same declarative part, unless the pragma comes
8031 -- from an aspect specification or was generated by the compiler
8032 -- (such as for pragma Provide_Shift_Operators).
8035 while Present
(Hom_Id
) loop
8037 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8039 -- Ignore inherited subprograms because the pragma will apply
8040 -- to the parent operation, which is the one called.
8042 if Is_Overloadable
(Def_Id
)
8043 and then Present
(Alias
(Def_Id
))
8047 -- If it is not a subprogram, it must be in an outer scope and
8048 -- pragma does not apply.
8050 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8053 -- The pragma does not apply to primitives of interfaces
8055 elsif Is_Dispatching_Operation
(Def_Id
)
8056 and then Present
(Find_Dispatching_Type
(Def_Id
))
8057 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
8061 -- Verify that the homonym is in the same declarative part (not
8062 -- just the same scope). If the pragma comes from an aspect
8063 -- specification we know that it is part of the declaration.
8065 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
8066 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
8067 and then not From_Aspect_Specification
(N
)
8072 -- If the pragma comes from an aspect specification the
8073 -- Is_Imported flag has already been set.
8075 if not From_Aspect_Specification
(N
) then
8076 Set_Imported
(Def_Id
);
8079 -- Reject an Import applied to an abstract subprogram
8081 if Is_Subprogram
(Def_Id
)
8082 and then Is_Abstract_Subprogram
(Def_Id
)
8084 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8086 ("cannot import abstract subprogram& declared#",
8090 -- Special processing for Convention_Intrinsic
8092 if C
= Convention_Intrinsic
then
8094 -- Link_Name argument not allowed for intrinsic
8098 Set_Is_Intrinsic_Subprogram
(Def_Id
);
8100 -- If no external name is present, then check that this
8101 -- is a valid intrinsic subprogram. If an external name
8102 -- is present, then this is handled by the back end.
8105 Check_Intrinsic_Subprogram
8106 (Def_Id
, Get_Pragma_Arg
(Arg2
));
8110 -- Verify that the subprogram does not have a completion
8111 -- through a renaming declaration. For other completions the
8112 -- pragma appears as a too late representation.
8115 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
8119 and then Nkind
(Decl
) = N_Subprogram_Declaration
8120 and then Present
(Corresponding_Body
(Decl
))
8121 and then Nkind
(Unit_Declaration_Node
8122 (Corresponding_Body
(Decl
))) =
8123 N_Subprogram_Renaming_Declaration
8125 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8127 ("cannot import&, renaming already provided for "
8128 & "declaration #", N
, Def_Id
);
8132 -- If the pragma comes from an aspect specification, there
8133 -- must be an Import aspect specified as well. In the rare
8134 -- case where Import is set to False, the suprogram needs to
8135 -- have a local completion.
8138 Imp_Aspect
: constant Node_Id
:=
8139 Find_Aspect
(Def_Id
, Aspect_Import
);
8143 if Present
(Imp_Aspect
)
8144 and then Present
(Expression
(Imp_Aspect
))
8146 Expr
:= Expression
(Imp_Aspect
);
8147 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
8149 if Is_Entity_Name
(Expr
)
8150 and then Entity
(Expr
) = Standard_True
8152 Set_Has_Completion
(Def_Id
);
8155 -- If there is no expression, the default is True, as for
8156 -- all boolean aspects. Same for the older pragma.
8159 Set_Has_Completion
(Def_Id
);
8163 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8166 if Is_Compilation_Unit
(Hom_Id
) then
8168 -- Its possible homonyms are not affected by the pragma.
8169 -- Such homonyms might be present in the context of other
8170 -- units being compiled.
8174 elsif From_Aspect_Specification
(N
) then
8177 -- If the pragma was created by the compiler, then we don't
8178 -- want it to apply to other homonyms. This kind of case can
8179 -- occur when using pragma Provide_Shift_Operators, which
8180 -- generates implicit shift and rotate operators with Import
8181 -- pragmas that might apply to earlier explicit or implicit
8182 -- declarations marked with Import (for example, coming from
8183 -- an earlier pragma Provide_Shift_Operators for another type),
8184 -- and we don't generally want other homonyms being treated
8185 -- as imported or the pragma flagged as an illegal duplicate.
8187 elsif not Comes_From_Source
(N
) then
8191 Hom_Id
:= Homonym
(Hom_Id
);
8195 -- Import a CPP class
8197 elsif C
= Convention_CPP
8198 and then (Is_Record_Type
(Def_Id
)
8199 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8201 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8202 if Present
(Full_View
(Def_Id
)) then
8203 Def_Id
:= Full_View
(Def_Id
);
8207 ("cannot import 'C'P'P type before full declaration seen",
8208 Get_Pragma_Arg
(Arg2
));
8210 -- Although we have reported the error we decorate it as
8211 -- CPP_Class to avoid reporting spurious errors
8213 Set_Is_CPP_Class
(Def_Id
);
8218 -- Types treated as CPP classes must be declared limited (note:
8219 -- this used to be a warning but there is no real benefit to it
8220 -- since we did effectively intend to treat the type as limited
8223 if not Is_Limited_Type
(Def_Id
) then
8225 ("imported 'C'P'P type must be limited",
8226 Get_Pragma_Arg
(Arg2
));
8229 if Etype
(Def_Id
) /= Def_Id
8230 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8232 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8235 Set_Is_CPP_Class
(Def_Id
);
8237 -- Imported CPP types must not have discriminants (because C++
8238 -- classes do not have discriminants).
8240 if Has_Discriminants
(Def_Id
) then
8242 ("imported 'C'P'P type cannot have discriminants",
8243 First
(Discriminant_Specifications
8244 (Declaration_Node
(Def_Id
))));
8247 -- Check that components of imported CPP types do not have default
8248 -- expressions. For private types this check is performed when the
8249 -- full view is analyzed (see Process_Full_View).
8251 if not Is_Private_Type
(Def_Id
) then
8252 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8255 -- Import a CPP exception
8257 elsif C
= Convention_CPP
8258 and then Ekind
(Def_Id
) = E_Exception
8262 ("'External_'Name arguments is required for 'Cpp exception",
8265 -- As only a string is allowed, Check_Arg_Is_External_Name
8268 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8271 if Present
(Arg4
) then
8273 ("Link_Name argument not allowed for imported Cpp exception",
8277 -- Do not call Set_Interface_Name as the name of the exception
8278 -- shouldn't be modified (and in particular it shouldn't be
8279 -- the External_Name). For exceptions, the External_Name is the
8280 -- name of the RTTI structure.
8282 -- ??? Emit an error if pragma Import/Export_Exception is present
8284 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8286 Check_Arg_Count
(3);
8287 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8289 Process_Import_Predefined_Type
;
8293 ("second argument of pragma% must be object, subprogram "
8294 & "or incomplete type",
8298 -- If this pragma applies to a compilation unit, then the unit, which
8299 -- is a subprogram, does not require (or allow) a body. We also do
8300 -- not need to elaborate imported procedures.
8302 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8304 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8306 Set_Body_Required
(Cunit
, False);
8309 end Process_Import_Or_Interface
;
8311 --------------------
8312 -- Process_Inline --
8313 --------------------
8315 procedure Process_Inline
(Status
: Inline_Status
) is
8322 Ghost_Error_Posted
: Boolean := False;
8323 -- Flag set when an error concerning the illegal mix of Ghost and
8324 -- non-Ghost subprograms is emitted.
8326 Ghost_Id
: Entity_Id
:= Empty
;
8327 -- The entity of the first Ghost subprogram encountered while
8328 -- processing the arguments of the pragma.
8330 procedure Make_Inline
(Subp
: Entity_Id
);
8331 -- Subp is the defining unit name of the subprogram declaration. Set
8332 -- the flag, as well as the flag in the corresponding body, if there
8335 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8336 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8337 -- Has_Pragma_Inline_Always for the Inline_Always case.
8339 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8340 -- Returns True if it can be determined at this stage that inlining
8341 -- is not possible, for example if the body is available and contains
8342 -- exception handlers, we prevent inlining, since otherwise we can
8343 -- get undefined symbols at link time. This function also emits a
8344 -- warning if front-end inlining is enabled and the pragma appears
8347 -- ??? is business with link symbols still valid, or does it relate
8348 -- to front end ZCX which is being phased out ???
8350 ---------------------------
8351 -- Inlining_Not_Possible --
8352 ---------------------------
8354 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8355 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8359 if Nkind
(Decl
) = N_Subprogram_Body
then
8360 Stats
:= Handled_Statement_Sequence
(Decl
);
8361 return Present
(Exception_Handlers
(Stats
))
8362 or else Present
(At_End_Proc
(Stats
));
8364 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8365 and then Present
(Corresponding_Body
(Decl
))
8367 if Front_End_Inlining
8368 and then Analyzed
(Corresponding_Body
(Decl
))
8370 Error_Msg_N
("pragma appears too late, ignored??", N
);
8373 -- If the subprogram is a renaming as body, the body is just a
8374 -- call to the renamed subprogram, and inlining is trivially
8378 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8379 N_Subprogram_Renaming_Declaration
8385 Handled_Statement_Sequence
8386 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8389 Present
(Exception_Handlers
(Stats
))
8390 or else Present
(At_End_Proc
(Stats
));
8394 -- If body is not available, assume the best, the check is
8395 -- performed again when compiling enclosing package bodies.
8399 end Inlining_Not_Possible
;
8405 procedure Make_Inline
(Subp
: Entity_Id
) is
8406 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8407 Inner_Subp
: Entity_Id
:= Subp
;
8410 -- Ignore if bad type, avoid cascaded error
8412 if Etype
(Subp
) = Any_Type
then
8416 -- If inlining is not possible, for now do not treat as an error
8418 elsif Status
/= Suppressed
8419 and then Inlining_Not_Possible
(Subp
)
8424 -- Here we have a candidate for inlining, but we must exclude
8425 -- derived operations. Otherwise we would end up trying to inline
8426 -- a phantom declaration, and the result would be to drag in a
8427 -- body which has no direct inlining associated with it. That
8428 -- would not only be inefficient but would also result in the
8429 -- backend doing cross-unit inlining in cases where it was
8430 -- definitely inappropriate to do so.
8432 -- However, a simple Comes_From_Source test is insufficient, since
8433 -- we do want to allow inlining of generic instances which also do
8434 -- not come from source. We also need to recognize specs generated
8435 -- by the front-end for bodies that carry the pragma. Finally,
8436 -- predefined operators do not come from source but are not
8437 -- inlineable either.
8439 elsif Is_Generic_Instance
(Subp
)
8440 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8444 elsif not Comes_From_Source
(Subp
)
8445 and then Scope
(Subp
) /= Standard_Standard
8451 -- The referenced entity must either be the enclosing entity, or
8452 -- an entity declared within the current open scope.
8454 if Present
(Scope
(Subp
))
8455 and then Scope
(Subp
) /= Current_Scope
8456 and then Subp
/= Current_Scope
8459 ("argument of% must be entity in current scope", Assoc
);
8463 -- Processing for procedure, operator or function. If subprogram
8464 -- is aliased (as for an instance) indicate that the renamed
8465 -- entity (if declared in the same unit) is inlined.
8467 if Is_Subprogram
(Subp
) then
8468 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8470 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8471 Set_Inline_Flags
(Inner_Subp
);
8473 Decl
:= Parent
(Parent
(Inner_Subp
));
8475 if Nkind
(Decl
) = N_Subprogram_Declaration
8476 and then Present
(Corresponding_Body
(Decl
))
8478 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8480 elsif Is_Generic_Instance
(Subp
) then
8482 -- Indicate that the body needs to be created for
8483 -- inlining subsequent calls. The instantiation node
8484 -- follows the declaration of the wrapper package
8487 if Scope
(Subp
) /= Standard_Standard
8489 Need_Subprogram_Instance_Body
8490 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8496 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8497 -- appear in a formal part to apply to a formal subprogram.
8498 -- Do not apply check within an instance or a formal package
8499 -- the test will have been applied to the original generic.
8501 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8502 and then List_Containing
(Decl
) = List_Containing
(N
)
8503 and then not In_Instance
8506 ("Inline cannot apply to a formal subprogram", N
);
8508 -- If Subp is a renaming, it is the renamed entity that
8509 -- will appear in any call, and be inlined. However, for
8510 -- ASIS uses it is convenient to indicate that the renaming
8511 -- itself is an inlined subprogram, so that some gnatcheck
8512 -- rules can be applied in the absence of expansion.
8514 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8515 Set_Inline_Flags
(Subp
);
8521 -- For a generic subprogram set flag as well, for use at the point
8522 -- of instantiation, to determine whether the body should be
8525 elsif Is_Generic_Subprogram
(Subp
) then
8526 Set_Inline_Flags
(Subp
);
8529 -- Literals are by definition inlined
8531 elsif Kind
= E_Enumeration_Literal
then
8534 -- Anything else is an error
8538 ("expect subprogram name for pragma%", Assoc
);
8542 ----------------------
8543 -- Set_Inline_Flags --
8544 ----------------------
8546 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8548 -- First set the Has_Pragma_XXX flags and issue the appropriate
8549 -- errors and warnings for suspicious combinations.
8551 if Prag_Id
= Pragma_No_Inline
then
8552 if Has_Pragma_Inline_Always
(Subp
) then
8554 ("Inline_Always and No_Inline are mutually exclusive", N
);
8555 elsif Has_Pragma_Inline
(Subp
) then
8557 ("Inline and No_Inline both specified for& ??",
8558 N
, Entity
(Subp_Id
));
8561 Set_Has_Pragma_No_Inline
(Subp
);
8563 if Prag_Id
= Pragma_Inline_Always
then
8564 if Has_Pragma_No_Inline
(Subp
) then
8566 ("Inline_Always and No_Inline are mutually exclusive",
8570 Set_Has_Pragma_Inline_Always
(Subp
);
8572 if Has_Pragma_No_Inline
(Subp
) then
8574 ("Inline and No_Inline both specified for& ??",
8575 N
, Entity
(Subp_Id
));
8579 if not Has_Pragma_Inline
(Subp
) then
8580 Set_Has_Pragma_Inline
(Subp
);
8584 -- Then adjust the Is_Inlined flag. It can never be set if the
8585 -- subprogram is subject to pragma No_Inline.
8589 Set_Is_Inlined
(Subp
, False);
8593 if not Has_Pragma_No_Inline
(Subp
) then
8594 Set_Is_Inlined
(Subp
, True);
8598 -- A pragma that applies to a Ghost entity becomes Ghost for the
8599 -- purposes of legality checks and removal of ignored Ghost code.
8601 Mark_Pragma_As_Ghost
(N
, Subp
);
8603 -- Capture the entity of the first Ghost subprogram being
8604 -- processed for error detection purposes.
8606 if Is_Ghost_Entity
(Subp
) then
8607 if No
(Ghost_Id
) then
8611 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
8612 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
8614 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
8615 Ghost_Error_Posted
:= True;
8617 Error_Msg_Name_1
:= Pname
;
8619 ("pragma % cannot mention ghost and non-ghost subprograms",
8622 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
8623 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
8625 Error_Msg_Sloc
:= Sloc
(Subp
);
8626 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
8628 end Set_Inline_Flags
;
8630 -- Start of processing for Process_Inline
8633 Check_No_Identifiers
;
8634 Check_At_Least_N_Arguments
(1);
8636 if Status
= Enabled
then
8637 Inline_Processing_Required
:= True;
8641 while Present
(Assoc
) loop
8642 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8646 if Is_Entity_Name
(Subp_Id
) then
8647 Subp
:= Entity
(Subp_Id
);
8649 if Subp
= Any_Id
then
8651 -- If previous error, avoid cascaded errors
8653 Check_Error_Detected
;
8659 -- For the pragma case, climb homonym chain. This is
8660 -- what implements allowing the pragma in the renaming
8661 -- case, with the result applying to the ancestors, and
8662 -- also allows Inline to apply to all previous homonyms.
8664 if not From_Aspect_Specification
(N
) then
8665 while Present
(Homonym
(Subp
))
8666 and then Scope
(Homonym
(Subp
)) = Current_Scope
8668 Make_Inline
(Homonym
(Subp
));
8669 Subp
:= Homonym
(Subp
);
8676 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
8683 ----------------------------
8684 -- Process_Interface_Name --
8685 ----------------------------
8687 procedure Process_Interface_Name
8688 (Subprogram_Def
: Entity_Id
;
8694 String_Val
: String_Id
;
8696 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
8697 -- SN is a string literal node for an interface name. This routine
8698 -- performs some minimal checks that the name is reasonable. In
8699 -- particular that no spaces or other obviously incorrect characters
8700 -- appear. This is only a warning, since any characters are allowed.
8702 ----------------------------------
8703 -- Check_Form_Of_Interface_Name --
8704 ----------------------------------
8706 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
8707 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8708 SL
: constant Nat
:= String_Length
(S
);
8713 Error_Msg_N
("interface name cannot be null string", SN
);
8716 for J
in 1 .. SL
loop
8717 C
:= Get_String_Char
(S
, J
);
8719 -- Look for dubious character and issue unconditional warning.
8720 -- Definitely dubious if not in character range.
8722 if not In_Character_Range
(C
)
8724 -- Commas, spaces and (back)slashes are dubious
8726 or else Get_Character
(C
) = ','
8727 or else Get_Character
(C
) = '\'
8728 or else Get_Character
(C
) = ' '
8729 or else Get_Character
(C
) = '/'
8732 ("??interface name contains illegal character",
8733 Sloc
(SN
) + Source_Ptr
(J
));
8736 end Check_Form_Of_Interface_Name
;
8738 -- Start of processing for Process_Interface_Name
8741 if No
(Link_Arg
) then
8742 if No
(Ext_Arg
) then
8745 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8747 Link_Nam
:= Expression
(Ext_Arg
);
8750 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8751 Ext_Nam
:= Expression
(Ext_Arg
);
8756 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8757 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8758 Ext_Nam
:= Expression
(Ext_Arg
);
8759 Link_Nam
:= Expression
(Link_Arg
);
8762 -- Check expressions for external name and link name are static
8764 if Present
(Ext_Nam
) then
8765 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8766 Check_Form_Of_Interface_Name
(Ext_Nam
);
8768 -- Verify that external name is not the name of a local entity,
8769 -- which would hide the imported one and could lead to run-time
8770 -- surprises. The problem can only arise for entities declared in
8771 -- a package body (otherwise the external name is fully qualified
8772 -- and will not conflict).
8780 if Prag_Id
= Pragma_Import
then
8781 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8783 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
8785 if Nam
/= Chars
(Subprogram_Def
)
8786 and then Present
(E
)
8787 and then not Is_Overloadable
(E
)
8788 and then Is_Immediately_Visible
(E
)
8789 and then not Is_Imported
(E
)
8790 and then Ekind
(Scope
(E
)) = E_Package
8793 while Present
(Par
) loop
8794 if Nkind
(Par
) = N_Package_Body
then
8795 Error_Msg_Sloc
:= Sloc
(E
);
8797 ("imported entity is hidden by & declared#",
8802 Par
:= Parent
(Par
);
8809 if Present
(Link_Nam
) then
8810 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8811 Check_Form_Of_Interface_Name
(Link_Nam
);
8814 -- If there is no link name, just set the external name
8816 if No
(Link_Nam
) then
8817 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8819 -- For the Link_Name case, the given literal is preceded by an
8820 -- asterisk, which indicates to GCC that the given name should be
8821 -- taken literally, and in particular that no prepending of
8822 -- underlines should occur, even in systems where this is the
8827 Store_String_Char
(Get_Char_Code
('*'));
8828 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8829 Store_String_Chars
(String_Val
);
8831 Make_String_Literal
(Sloc
(Link_Nam
),
8832 Strval
=> End_String
);
8835 -- Set the interface name. If the entity is a generic instance, use
8836 -- its alias, which is the callable entity.
8838 if Is_Generic_Instance
(Subprogram_Def
) then
8839 Set_Encoded_Interface_Name
8840 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8842 Set_Encoded_Interface_Name
8843 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8846 Check_Duplicated_Export_Name
(Link_Nam
);
8847 end Process_Interface_Name
;
8849 -----------------------------------------
8850 -- Process_Interrupt_Or_Attach_Handler --
8851 -----------------------------------------
8853 procedure Process_Interrupt_Or_Attach_Handler
is
8854 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
8855 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
8858 -- A pragma that applies to a Ghost entity becomes Ghost for the
8859 -- purposes of legality checks and removal of ignored Ghost code.
8861 Mark_Pragma_As_Ghost
(N
, Handler
);
8862 Set_Is_Interrupt_Handler
(Handler
);
8864 -- If the pragma is not associated with a handler procedure within a
8865 -- protected type, then it must be for a nonprotected procedure for
8866 -- the AAMP target, in which case we don't associate a representation
8867 -- item with the procedure's scope.
8869 if Ekind
(Prot_Typ
) = E_Protected_Type
then
8870 Record_Rep_Item
(Prot_Typ
, N
);
8873 -- Chain the pragma on the contract for completeness
8875 Add_Contract_Item
(N
, Handler
);
8876 end Process_Interrupt_Or_Attach_Handler
;
8878 --------------------------------------------------
8879 -- Process_Restrictions_Or_Restriction_Warnings --
8880 --------------------------------------------------
8882 -- Note: some of the simple identifier cases were handled in par-prag,
8883 -- but it is harmless (and more straightforward) to simply handle all
8884 -- cases here, even if it means we repeat a bit of work in some cases.
8886 procedure Process_Restrictions_Or_Restriction_Warnings
8890 R_Id
: Restriction_Id
;
8896 -- Ignore all Restrictions pragmas in CodePeer mode
8898 if CodePeer_Mode
then
8902 Check_Ada_83_Warning
;
8903 Check_At_Least_N_Arguments
(1);
8904 Check_Valid_Configuration_Pragma
;
8907 while Present
(Arg
) loop
8909 Expr
:= Get_Pragma_Arg
(Arg
);
8911 -- Case of no restriction identifier present
8913 if Id
= No_Name
then
8914 if Nkind
(Expr
) /= N_Identifier
then
8916 ("invalid form for restriction", Arg
);
8921 (Process_Restriction_Synonyms
(Expr
));
8923 if R_Id
not in All_Boolean_Restrictions
then
8924 Error_Msg_Name_1
:= Pname
;
8926 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8928 -- Check for possible misspelling
8930 for J
in Restriction_Id
loop
8932 Rnm
: constant String := Restriction_Id
'Image (J
);
8935 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8936 Name_Len
:= Rnm
'Length;
8937 Set_Casing
(All_Lower_Case
);
8939 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8941 (Identifier_Casing
(Current_Source_File
));
8942 Error_Msg_String
(1 .. Rnm
'Length) :=
8943 Name_Buffer
(1 .. Name_Len
);
8944 Error_Msg_Strlen
:= Rnm
'Length;
8945 Error_Msg_N
-- CODEFIX
8946 ("\possible misspelling of ""~""",
8947 Get_Pragma_Arg
(Arg
));
8956 if Implementation_Restriction
(R_Id
) then
8957 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8960 -- Special processing for No_Elaboration_Code restriction
8962 if R_Id
= No_Elaboration_Code
then
8964 -- Restriction is only recognized within a configuration
8965 -- pragma file, or within a unit of the main extended
8966 -- program. Note: the test for Main_Unit is needed to
8967 -- properly include the case of configuration pragma files.
8969 if not (Current_Sem_Unit
= Main_Unit
8970 or else In_Extended_Main_Source_Unit
(N
))
8974 -- Don't allow in a subunit unless already specified in
8977 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8978 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8979 and then not Restriction_Active
(No_Elaboration_Code
)
8982 ("invalid specification of ""No_Elaboration_Code""",
8985 ("\restriction cannot be specified in a subunit", N
);
8987 ("\unless also specified in body or spec", N
);
8990 -- If we accept a No_Elaboration_Code restriction, then it
8991 -- needs to be added to the configuration restriction set so
8992 -- that we get proper application to other units in the main
8993 -- extended source as required.
8996 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
9000 -- If this is a warning, then set the warning unless we already
9001 -- have a real restriction active (we never want a warning to
9002 -- override a real restriction).
9005 if not Restriction_Active
(R_Id
) then
9006 Set_Restriction
(R_Id
, N
);
9007 Restriction_Warnings
(R_Id
) := True;
9010 -- If real restriction case, then set it and make sure that the
9011 -- restriction warning flag is off, since a real restriction
9012 -- always overrides a warning.
9015 Set_Restriction
(R_Id
, N
);
9016 Restriction_Warnings
(R_Id
) := False;
9019 -- Check for obsolescent restrictions in Ada 2005 mode
9022 and then Ada_Version
>= Ada_2005
9023 and then (R_Id
= No_Asynchronous_Control
9025 R_Id
= No_Unchecked_Deallocation
9027 R_Id
= No_Unchecked_Conversion
)
9029 Check_Restriction
(No_Obsolescent_Features
, N
);
9032 -- A very special case that must be processed here: pragma
9033 -- Restrictions (No_Exceptions) turns off all run-time
9034 -- checking. This is a bit dubious in terms of the formal
9035 -- language definition, but it is what is intended by RM
9036 -- H.4(12). Restriction_Warnings never affects generated code
9037 -- so this is done only in the real restriction case.
9039 -- Atomic_Synchronization is not a real check, so it is not
9040 -- affected by this processing).
9042 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9043 -- run-time checks in CodePeer and GNATprove modes: we want to
9044 -- generate checks for analysis purposes, as set respectively
9045 -- by -gnatC and -gnatd.F
9048 and then not (CodePeer_Mode
or GNATprove_Mode
)
9049 and then R_Id
= No_Exceptions
9051 for J
in Scope_Suppress
.Suppress
'Range loop
9052 if J
/= Atomic_Synchronization
then
9053 Scope_Suppress
.Suppress
(J
) := True;
9058 -- Case of No_Dependence => unit-name. Note that the parser
9059 -- already made the necessary entry in the No_Dependence table.
9061 elsif Id
= Name_No_Dependence
then
9062 if not OK_No_Dependence_Unit_Name
(Expr
) then
9066 -- Case of No_Specification_Of_Aspect => aspect-identifier
9068 elsif Id
= Name_No_Specification_Of_Aspect
then
9073 if Nkind
(Expr
) /= N_Identifier
then
9076 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
9079 if A_Id
= No_Aspect
then
9080 Error_Pragma_Arg
("invalid restriction name", Arg
);
9082 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
9086 -- Case of No_Use_Of_Attribute => attribute-identifier
9088 elsif Id
= Name_No_Use_Of_Attribute
then
9089 if Nkind
(Expr
) /= N_Identifier
9090 or else not Is_Attribute_Name
(Chars
(Expr
))
9092 Error_Msg_N
("unknown attribute name??", Expr
);
9095 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
9098 -- Case of No_Use_Of_Entity => fully-qualified-name
9100 elsif Id
= Name_No_Use_Of_Entity
then
9102 -- Restriction is only recognized within a configuration
9103 -- pragma file, or within a unit of the main extended
9104 -- program. Note: the test for Main_Unit is needed to
9105 -- properly include the case of configuration pragma files.
9107 if Current_Sem_Unit
= Main_Unit
9108 or else In_Extended_Main_Source_Unit
(N
)
9110 if not OK_No_Dependence_Unit_Name
(Expr
) then
9111 Error_Msg_N
("wrong form for entity name", Expr
);
9113 Set_Restriction_No_Use_Of_Entity
9114 (Expr
, Warn
, No_Profile
);
9118 -- Case of No_Use_Of_Pragma => pragma-identifier
9120 elsif Id
= Name_No_Use_Of_Pragma
then
9121 if Nkind
(Expr
) /= N_Identifier
9122 or else not Is_Pragma_Name
(Chars
(Expr
))
9124 Error_Msg_N
("unknown pragma name??", Expr
);
9126 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
9129 -- All other cases of restriction identifier present
9132 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
9133 Analyze_And_Resolve
(Expr
, Any_Integer
);
9135 if R_Id
not in All_Parameter_Restrictions
then
9137 ("invalid restriction parameter identifier", Arg
);
9139 elsif not Is_OK_Static_Expression
(Expr
) then
9140 Flag_Non_Static_Expr
9141 ("value must be static expression!", Expr
);
9144 elsif not Is_Integer_Type
(Etype
(Expr
))
9145 or else Expr_Value
(Expr
) < 0
9148 ("value must be non-negative integer", Arg
);
9151 -- Restriction pragma is active
9153 Val
:= Expr_Value
(Expr
);
9155 if not UI_Is_In_Int_Range
(Val
) then
9157 ("pragma ignored, value too large??", Arg
);
9160 -- Warning case. If the real restriction is active, then we
9161 -- ignore the request, since warning never overrides a real
9162 -- restriction. Otherwise we set the proper warning. Note that
9163 -- this circuit sets the warning again if it is already set,
9164 -- which is what we want, since the constant may have changed.
9167 if not Restriction_Active
(R_Id
) then
9169 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
9170 Restriction_Warnings
(R_Id
) := True;
9173 -- Real restriction case, set restriction and make sure warning
9174 -- flag is off since real restriction always overrides warning.
9177 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
9178 Restriction_Warnings
(R_Id
) := False;
9184 end Process_Restrictions_Or_Restriction_Warnings
;
9186 ---------------------------------
9187 -- Process_Suppress_Unsuppress --
9188 ---------------------------------
9190 -- Note: this procedure makes entries in the check suppress data
9191 -- structures managed by Sem. See spec of package Sem for full
9192 -- details on how we handle recording of check suppression.
9194 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9199 In_Package_Spec
: constant Boolean :=
9200 Is_Package_Or_Generic_Package
(Current_Scope
)
9201 and then not In_Package_Body
(Current_Scope
);
9203 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9204 -- Used to suppress a single check on the given entity
9206 --------------------------------
9207 -- Suppress_Unsuppress_Echeck --
9208 --------------------------------
9210 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9212 -- Check for error of trying to set atomic synchronization for
9213 -- a non-atomic variable.
9215 if C
= Atomic_Synchronization
9216 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9219 ("pragma & requires atomic type or variable",
9220 Pragma_Identifier
(Original_Node
(N
)));
9223 Set_Checks_May_Be_Suppressed
(E
);
9225 if In_Package_Spec
then
9226 Push_Global_Suppress_Stack_Entry
9229 Suppress
=> Suppress_Case
);
9231 Push_Local_Suppress_Stack_Entry
9234 Suppress
=> Suppress_Case
);
9237 -- If this is a first subtype, and the base type is distinct,
9238 -- then also set the suppress flags on the base type.
9240 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9241 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9243 end Suppress_Unsuppress_Echeck
;
9245 -- Start of processing for Process_Suppress_Unsuppress
9248 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9249 -- on user code: we want to generate checks for analysis purposes, as
9250 -- set respectively by -gnatC and -gnatd.F
9252 if Comes_From_Source
(N
)
9253 and then (CodePeer_Mode
or GNATprove_Mode
)
9258 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9259 -- declarative part or a package spec (RM 11.5(5)).
9261 if not Is_Configuration_Pragma
then
9262 Check_Is_In_Decl_Part_Or_Package_Spec
;
9265 Check_At_Least_N_Arguments
(1);
9266 Check_At_Most_N_Arguments
(2);
9267 Check_No_Identifier
(Arg1
);
9268 Check_Arg_Is_Identifier
(Arg1
);
9270 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9272 if C
= No_Check_Id
then
9274 ("argument of pragma% is not valid check name", Arg1
);
9277 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9279 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
9281 ("Suppress of Elaboration_Check ignored in SPARK??",
9282 "\elaboration checking rules are statically enforced "
9283 & "(SPARK RM 7.7)", Arg1
);
9286 -- One-argument case
9288 if Arg_Count
= 1 then
9290 -- Make an entry in the local scope suppress table. This is the
9291 -- table that directly shows the current value of the scope
9292 -- suppress check for any check id value.
9294 if C
= All_Checks
then
9296 -- For All_Checks, we set all specific predefined checks with
9297 -- the exception of Elaboration_Check, which is handled
9298 -- specially because of not wanting All_Checks to have the
9299 -- effect of deactivating static elaboration order processing.
9300 -- Atomic_Synchronization is also not affected, since this is
9301 -- not a real check.
9303 for J
in Scope_Suppress
.Suppress
'Range loop
9304 if J
/= Elaboration_Check
9306 J
/= Atomic_Synchronization
9308 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9312 -- If not All_Checks, and predefined check, then set appropriate
9313 -- scope entry. Note that we will set Elaboration_Check if this
9314 -- is explicitly specified. Atomic_Synchronization is allowed
9315 -- only if internally generated and entity is atomic.
9317 elsif C
in Predefined_Check_Id
9318 and then (not Comes_From_Source
(N
)
9319 or else C
/= Atomic_Synchronization
)
9321 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9324 -- Also make an entry in the Local_Entity_Suppress table
9326 Push_Local_Suppress_Stack_Entry
9329 Suppress
=> Suppress_Case
);
9331 -- Case of two arguments present, where the check is suppressed for
9332 -- a specified entity (given as the second argument of the pragma)
9335 -- This is obsolescent in Ada 2005 mode
9337 if Ada_Version
>= Ada_2005
then
9338 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9341 Check_Optional_Identifier
(Arg2
, Name_On
);
9342 E_Id
:= Get_Pragma_Arg
(Arg2
);
9345 if not Is_Entity_Name
(E_Id
) then
9347 ("second argument of pragma% must be entity name", Arg2
);
9356 -- A pragma that applies to a Ghost entity becomes Ghost for the
9357 -- purposes of legality checks and removal of ignored Ghost code.
9359 Mark_Pragma_As_Ghost
(N
, E
);
9361 -- Enforce RM 11.5(7) which requires that for a pragma that
9362 -- appears within a package spec, the named entity must be
9363 -- within the package spec. We allow the package name itself
9364 -- to be mentioned since that makes sense, although it is not
9365 -- strictly allowed by 11.5(7).
9368 and then E
/= Current_Scope
9369 and then Scope
(E
) /= Current_Scope
9372 ("entity in pragma% is not in package spec (RM 11.5(7))",
9376 -- Loop through homonyms. As noted below, in the case of a package
9377 -- spec, only homonyms within the package spec are considered.
9380 Suppress_Unsuppress_Echeck
(E
, C
);
9382 if Is_Generic_Instance
(E
)
9383 and then Is_Subprogram
(E
)
9384 and then Present
(Alias
(E
))
9386 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9389 -- Move to next homonym if not aspect spec case
9391 exit when From_Aspect_Specification
(N
);
9395 -- If we are within a package specification, the pragma only
9396 -- applies to homonyms in the same scope.
9398 exit when In_Package_Spec
9399 and then Scope
(E
) /= Current_Scope
;
9402 end Process_Suppress_Unsuppress
;
9404 -------------------------------
9405 -- Record_Independence_Check --
9406 -------------------------------
9408 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
9410 -- For GCC back ends the validation is done a priori
9412 if not AAMP_On_Target
then
9416 Independence_Checks
.Append
((N
, E
));
9417 end Record_Independence_Check
;
9423 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9425 if Is_Imported
(E
) then
9427 ("cannot export entity& that was previously imported", Arg
);
9429 elsif Present
(Address_Clause
(E
))
9430 and then not Relaxed_RM_Semantics
9433 ("cannot export entity& that has an address clause", Arg
);
9436 Set_Is_Exported
(E
);
9438 -- Generate a reference for entity explicitly, because the
9439 -- identifier may be overloaded and name resolution will not
9442 Generate_Reference
(E
, Arg
);
9444 -- Deal with exporting non-library level entity
9446 if not Is_Library_Level_Entity
(E
) then
9448 -- Not allowed at all for subprograms
9450 if Is_Subprogram
(E
) then
9451 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9453 -- Otherwise set public and statically allocated
9457 Set_Is_Statically_Allocated
(E
);
9459 -- Warn if the corresponding W flag is set
9461 if Warn_On_Export_Import
9463 -- Only do this for something that was in the source. Not
9464 -- clear if this can be False now (there used for sure to be
9465 -- cases on some systems where it was False), but anyway the
9466 -- test is harmless if not needed, so it is retained.
9468 and then Comes_From_Source
(Arg
)
9471 ("?x?& has been made static as a result of Export",
9474 ("\?x?this usage is non-standard and non-portable",
9480 if Warn_On_Export_Import
and then Is_Type
(E
) then
9481 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9484 if Warn_On_Export_Import
and Inside_A_Generic
then
9486 ("all instances of& will have the same external name?x?",
9491 ----------------------------------------------
9492 -- Set_Extended_Import_Export_External_Name --
9493 ----------------------------------------------
9495 procedure Set_Extended_Import_Export_External_Name
9496 (Internal_Ent
: Entity_Id
;
9497 Arg_External
: Node_Id
)
9499 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9503 if No
(Arg_External
) then
9507 Check_Arg_Is_External_Name
(Arg_External
);
9509 if Nkind
(Arg_External
) = N_String_Literal
then
9510 if String_Length
(Strval
(Arg_External
)) = 0 then
9513 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9516 elsif Nkind
(Arg_External
) = N_Identifier
then
9517 New_Name
:= Get_Default_External_Name
(Arg_External
);
9519 -- Check_Arg_Is_External_Name should let through only identifiers and
9520 -- string literals or static string expressions (which are folded to
9521 -- string literals).
9524 raise Program_Error
;
9527 -- If we already have an external name set (by a prior normal Import
9528 -- or Export pragma), then the external names must match
9530 if Present
(Interface_Name
(Internal_Ent
)) then
9532 -- Ignore mismatching names in CodePeer mode, to support some
9533 -- old compilers which would export the same procedure under
9534 -- different names, e.g:
9536 -- pragma Export_Procedure (P, "a");
9537 -- pragma Export_Procedure (P, "b");
9539 if CodePeer_Mode
then
9543 Check_Matching_Internal_Names
: declare
9544 S1
: constant String_Id
:= Strval
(Old_Name
);
9545 S2
: constant String_Id
:= Strval
(New_Name
);
9548 pragma No_Return
(Mismatch
);
9549 -- Called if names do not match
9555 procedure Mismatch
is
9557 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9559 ("external name does not match that given #",
9563 -- Start of processing for Check_Matching_Internal_Names
9566 if String_Length
(S1
) /= String_Length
(S2
) then
9570 for J
in 1 .. String_Length
(S1
) loop
9571 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9576 end Check_Matching_Internal_Names
;
9578 -- Otherwise set the given name
9581 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9582 Check_Duplicated_Export_Name
(New_Name
);
9584 end Set_Extended_Import_Export_External_Name
;
9590 procedure Set_Imported
(E
: Entity_Id
) is
9592 -- Error message if already imported or exported
9594 if Is_Exported
(E
) or else Is_Imported
(E
) then
9596 -- Error if being set Exported twice
9598 if Is_Exported
(E
) then
9599 Error_Msg_NE
("entity& was previously exported", N
, E
);
9601 -- Ignore error in CodePeer mode where we treat all imported
9602 -- subprograms as unknown.
9604 elsif CodePeer_Mode
then
9607 -- OK if Import/Interface case
9609 elsif Import_Interface_Present
(N
) then
9612 -- Error if being set Imported twice
9615 Error_Msg_NE
("entity& was previously imported", N
, E
);
9618 Error_Msg_Name_1
:= Pname
;
9620 ("\(pragma% applies to all previous entities)", N
);
9622 Error_Msg_Sloc
:= Sloc
(E
);
9623 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9625 -- Here if not previously imported or exported, OK to import
9628 Set_Is_Imported
(E
);
9630 -- For subprogram, set Import_Pragma field
9632 if Is_Subprogram
(E
) then
9633 Set_Import_Pragma
(E
, N
);
9636 -- If the entity is an object that is not at the library level,
9637 -- then it is statically allocated. We do not worry about objects
9638 -- with address clauses in this context since they are not really
9639 -- imported in the linker sense.
9642 and then not Is_Library_Level_Entity
(E
)
9643 and then No
(Address_Clause
(E
))
9645 Set_Is_Statically_Allocated
(E
);
9652 -------------------------
9653 -- Set_Mechanism_Value --
9654 -------------------------
9656 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9657 -- analyzed, since it is semantic nonsense), so we get it in the exact
9658 -- form created by the parser.
9660 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9661 procedure Bad_Mechanism
;
9662 pragma No_Return
(Bad_Mechanism
);
9663 -- Signal bad mechanism name
9665 -------------------------
9666 -- Bad_Mechanism_Value --
9667 -------------------------
9669 procedure Bad_Mechanism
is
9671 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9674 -- Start of processing for Set_Mechanism_Value
9677 if Mechanism
(Ent
) /= Default_Mechanism
then
9679 ("mechanism for & has already been set", Mech_Name
, Ent
);
9682 -- MECHANISM_NAME ::= value | reference
9684 if Nkind
(Mech_Name
) = N_Identifier
then
9685 if Chars
(Mech_Name
) = Name_Value
then
9686 Set_Mechanism
(Ent
, By_Copy
);
9689 elsif Chars
(Mech_Name
) = Name_Reference
then
9690 Set_Mechanism
(Ent
, By_Reference
);
9693 elsif Chars
(Mech_Name
) = Name_Copy
then
9695 ("bad mechanism name, Value assumed", Mech_Name
);
9704 end Set_Mechanism_Value
;
9706 --------------------------
9707 -- Set_Rational_Profile --
9708 --------------------------
9710 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9711 -- extension to the semantics of renaming declarations.
9713 procedure Set_Rational_Profile
is
9715 Implicit_Packing
:= True;
9716 Overriding_Renamings
:= True;
9717 Use_VADS_Size
:= True;
9718 end Set_Rational_Profile
;
9720 ---------------------------
9721 -- Set_Ravenscar_Profile --
9722 ---------------------------
9724 -- The tasks to be done here are
9726 -- Set required policies
9728 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9729 -- pragma Locking_Policy (Ceiling_Locking)
9731 -- Set Detect_Blocking mode
9733 -- Set required restrictions (see System.Rident for detailed list)
9735 -- Set the No_Dependence rules
9736 -- No_Dependence => Ada.Asynchronous_Task_Control
9737 -- No_Dependence => Ada.Calendar
9738 -- No_Dependence => Ada.Execution_Time.Group_Budget
9739 -- No_Dependence => Ada.Execution_Time.Timers
9740 -- No_Dependence => Ada.Task_Attributes
9741 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9743 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
9744 procedure Set_Error_Msg_To_Profile_Name
;
9745 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
9748 -----------------------------------
9749 -- Set_Error_Msg_To_Profile_Name --
9750 -----------------------------------
9752 procedure Set_Error_Msg_To_Profile_Name
is
9753 Prof_Nam
: constant Node_Id
:=
9755 (First
(Pragma_Argument_Associations
(N
)));
9758 Get_Name_String
(Chars
(Prof_Nam
));
9759 Adjust_Name_Case
(Sloc
(Prof_Nam
));
9760 Error_Msg_Strlen
:= Name_Len
;
9761 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
9762 end Set_Error_Msg_To_Profile_Name
;
9771 -- Start of processing for Set_Ravenscar_Profile
9774 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9776 if Task_Dispatching_Policy
/= ' '
9777 and then Task_Dispatching_Policy
/= 'F'
9779 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9780 Set_Error_Msg_To_Profile_Name
;
9781 Error_Pragma
("Profile (~) incompatible with policy#");
9783 -- Set the FIFO_Within_Priorities policy, but always preserve
9784 -- System_Location since we like the error message with the run time
9788 Task_Dispatching_Policy
:= 'F';
9790 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9791 Task_Dispatching_Policy_Sloc
:= Loc
;
9795 -- pragma Locking_Policy (Ceiling_Locking)
9797 if Locking_Policy
/= ' '
9798 and then Locking_Policy
/= 'C'
9800 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9801 Set_Error_Msg_To_Profile_Name
;
9802 Error_Pragma
("Profile (~) incompatible with policy#");
9804 -- Set the Ceiling_Locking policy, but preserve System_Location since
9805 -- we like the error message with the run time name.
9808 Locking_Policy
:= 'C';
9810 if Locking_Policy_Sloc
/= System_Location
then
9811 Locking_Policy_Sloc
:= Loc
;
9815 -- pragma Detect_Blocking
9817 Detect_Blocking
:= True;
9819 -- Set the corresponding restrictions
9821 Set_Profile_Restrictions
9822 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9824 -- Set the No_Dependence restrictions
9826 -- The following No_Dependence restrictions:
9827 -- No_Dependence => Ada.Asynchronous_Task_Control
9828 -- No_Dependence => Ada.Calendar
9829 -- No_Dependence => Ada.Task_Attributes
9830 -- are already set by previous call to Set_Profile_Restrictions.
9832 -- Set the following restrictions which were added to Ada 2005:
9833 -- No_Dependence => Ada.Execution_Time.Group_Budget
9834 -- No_Dependence => Ada.Execution_Time.Timers
9836 -- ??? The use of Name_Buffer here is suspicious. The names should
9837 -- be registered in snames.ads-tmpl and used to build the qualified
9840 if Ada_Version
>= Ada_2005
then
9841 Name_Buffer
(1 .. 3) := "ada";
9844 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
);
9846 Name_Buffer
(1 .. 14) := "execution_time";
9849 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
9852 Make_Selected_Component
9855 Selector_Name
=> Sel_Id
);
9857 Name_Buffer
(1 .. 13) := "group_budgets";
9860 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
9863 Make_Selected_Component
9866 Selector_Name
=> Sel_Id
);
9868 Set_Restriction_No_Dependence
9870 Warn
=> Treat_Restrictions_As_Warnings
,
9871 Profile
=> Ravenscar
);
9873 Name_Buffer
(1 .. 6) := "timers";
9876 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
9879 Make_Selected_Component
9882 Selector_Name
=> Sel_Id
);
9884 Set_Restriction_No_Dependence
9886 Warn
=> Treat_Restrictions_As_Warnings
,
9887 Profile
=> Ravenscar
);
9890 -- Set the following restriction which was added to Ada 2012 (see
9892 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9894 if Ada_Version
>= Ada_2012
then
9895 Name_Buffer
(1 .. 6) := "system";
9898 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
);
9900 Name_Buffer
(1 .. 15) := "multiprocessors";
9903 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
9906 Make_Selected_Component
9909 Selector_Name
=> Sel_Id
);
9911 Name_Buffer
(1 .. 19) := "dispatching_domains";
9914 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
9917 Make_Selected_Component
9920 Selector_Name
=> Sel_Id
);
9922 Set_Restriction_No_Dependence
9924 Warn
=> Treat_Restrictions_As_Warnings
,
9925 Profile
=> Ravenscar
);
9927 end Set_Ravenscar_Profile
;
9929 -- Start of processing for Analyze_Pragma
9932 -- The following code is a defense against recursion. Not clear that
9933 -- this can happen legitimately, but perhaps some error situations can
9934 -- cause it, and we did see this recursion during testing.
9936 if Analyzed
(N
) then
9942 -- Deal with unrecognized pragma
9944 Pname
:= Pragma_Name
(N
);
9946 if not Is_Pragma_Name
(Pname
) then
9947 if Warn_On_Unrecognized_Pragma
then
9948 Error_Msg_Name_1
:= Pname
;
9949 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9951 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9952 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9953 Error_Msg_Name_1
:= PN
;
9954 Error_Msg_N
-- CODEFIX
9955 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9964 -- Ignore pragma if Ignore_Pragma applies
9966 if Get_Name_Table_Boolean3
(Pname
) then
9970 -- Here to start processing for recognized pragma
9972 Prag_Id
:= Get_Pragma_Id
(Pname
);
9973 Pname
:= Original_Aspect_Pragma_Name
(N
);
9975 -- Capture setting of Opt.Uneval_Old
9977 case Opt
.Uneval_Old
is
9979 Set_Uneval_Old_Accept
(N
);
9983 Set_Uneval_Old_Warn
(N
);
9985 raise Program_Error
;
9988 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9989 -- is already set, indicating that we have already checked the policy
9990 -- at the right point. This happens for example in the case of a pragma
9991 -- that is derived from an Aspect.
9993 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9996 -- For a pragma that is a rewriting of another pragma, copy the
9997 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9999 elsif Is_Rewrite_Substitution
(N
)
10000 and then Nkind
(Original_Node
(N
)) = N_Pragma
10001 and then Original_Node
(N
) /= N
10003 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
10004 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
10006 -- Otherwise query the applicable policy at this point
10009 Check_Applicable_Policy
(N
);
10011 -- If pragma is disabled, rewrite as NULL and skip analysis
10013 if Is_Disabled
(N
) then
10014 Rewrite
(N
, Make_Null_Statement
(Loc
));
10020 -- Preset arguments
10028 if Present
(Pragma_Argument_Associations
(N
)) then
10029 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
10030 Arg1
:= First
(Pragma_Argument_Associations
(N
));
10032 if Present
(Arg1
) then
10033 Arg2
:= Next
(Arg1
);
10035 if Present
(Arg2
) then
10036 Arg3
:= Next
(Arg2
);
10038 if Present
(Arg3
) then
10039 Arg4
:= Next
(Arg3
);
10045 Check_Restriction_No_Use_Of_Pragma
(N
);
10047 -- An enumeration type defines the pragmas that are supported by the
10048 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10049 -- into the corresponding enumeration value for the following case.
10057 -- pragma Abort_Defer;
10059 when Pragma_Abort_Defer
=>
10061 Check_Arg_Count
(0);
10063 -- The only required semantic processing is to check the
10064 -- placement. This pragma must appear at the start of the
10065 -- statement sequence of a handled sequence of statements.
10067 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
10068 or else N
/= First
(Statements
(Parent
(N
)))
10073 --------------------
10074 -- Abstract_State --
10075 --------------------
10077 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10079 -- ABSTRACT_STATE_LIST ::=
10081 -- | STATE_NAME_WITH_OPTIONS
10082 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10084 -- STATE_NAME_WITH_OPTIONS ::=
10086 -- | (STATE_NAME with OPTION_LIST)
10088 -- OPTION_LIST ::= OPTION {, OPTION}
10092 -- | NAME_VALUE_OPTION
10094 -- SIMPLE_OPTION ::= Ghost | Synchronous
10096 -- NAME_VALUE_OPTION ::=
10097 -- Part_Of => ABSTRACT_STATE
10098 -- | External [=> EXTERNAL_PROPERTY_LIST]
10100 -- EXTERNAL_PROPERTY_LIST ::=
10101 -- EXTERNAL_PROPERTY
10102 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10104 -- EXTERNAL_PROPERTY ::=
10105 -- Async_Readers [=> boolean_EXPRESSION]
10106 -- | Async_Writers [=> boolean_EXPRESSION]
10107 -- | Effective_Reads [=> boolean_EXPRESSION]
10108 -- | Effective_Writes [=> boolean_EXPRESSION]
10109 -- others => boolean_EXPRESSION
10111 -- STATE_NAME ::= defining_identifier
10113 -- ABSTRACT_STATE ::= name
10115 -- Characteristics:
10117 -- * Analysis - The annotation is fully analyzed immediately upon
10118 -- elaboration as it cannot forward reference entities.
10120 -- * Expansion - None.
10122 -- * Template - The annotation utilizes the generic template of the
10123 -- related package declaration.
10125 -- * Globals - The annotation cannot reference global entities.
10127 -- * Instance - The annotation is instantiated automatically when
10128 -- the related generic package is instantiated.
10130 when Pragma_Abstract_State
=> Abstract_State
: declare
10131 Missing_Parentheses
: Boolean := False;
10132 -- Flag set when a state declaration with options is not properly
10135 -- Flags used to verify the consistency of states
10137 Non_Null_Seen
: Boolean := False;
10138 Null_Seen
: Boolean := False;
10140 procedure Analyze_Abstract_State
10142 Pack_Id
: Entity_Id
);
10143 -- Verify the legality of a single state declaration. Create and
10144 -- decorate a state abstraction entity and introduce it into the
10145 -- visibility chain. Pack_Id denotes the entity or the related
10146 -- package where pragma Abstract_State appears.
10148 procedure Malformed_State_Error
(State
: Node_Id
);
10149 -- Emit an error concerning the illegal declaration of abstract
10150 -- state State. This routine diagnoses syntax errors that lead to
10151 -- a different parse tree. The error is issued regardless of the
10152 -- SPARK mode in effect.
10154 ----------------------------
10155 -- Analyze_Abstract_State --
10156 ----------------------------
10158 procedure Analyze_Abstract_State
10160 Pack_Id
: Entity_Id
)
10162 -- Flags used to verify the consistency of options
10164 AR_Seen
: Boolean := False;
10165 AW_Seen
: Boolean := False;
10166 ER_Seen
: Boolean := False;
10167 EW_Seen
: Boolean := False;
10168 External_Seen
: Boolean := False;
10169 Ghost_Seen
: Boolean := False;
10170 Others_Seen
: Boolean := False;
10171 Part_Of_Seen
: Boolean := False;
10172 Synchronous_Seen
: Boolean := False;
10174 -- Flags used to store the static value of all external states'
10177 AR_Val
: Boolean := False;
10178 AW_Val
: Boolean := False;
10179 ER_Val
: Boolean := False;
10180 EW_Val
: Boolean := False;
10182 State_Id
: Entity_Id
:= Empty
;
10183 -- The entity to be generated for the current state declaration
10185 procedure Analyze_External_Option
(Opt
: Node_Id
);
10186 -- Verify the legality of option External
10188 procedure Analyze_External_Property
10190 Expr
: Node_Id
:= Empty
);
10191 -- Verify the legailty of a single external property. Prop
10192 -- denotes the external property. Expr is the expression used
10193 -- to set the property.
10195 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
10196 -- Verify the legality of option Part_Of
10198 procedure Check_Duplicate_Option
10200 Status
: in out Boolean);
10201 -- Flag Status denotes whether a particular option has been
10202 -- seen while processing a state. This routine verifies that
10203 -- Opt is not a duplicate option and sets the flag Status
10204 -- (SPARK RM 7.1.4(1)).
10206 procedure Check_Duplicate_Property
10208 Status
: in out Boolean);
10209 -- Flag Status denotes whether a particular property has been
10210 -- seen while processing option External. This routine verifies
10211 -- that Prop is not a duplicate property and sets flag Status.
10212 -- Opt is not a duplicate property and sets the flag Status.
10213 -- (SPARK RM 7.1.4(2))
10215 procedure Check_Ghost_Synchronous
;
10216 -- Ensure that the abstract state is not subject to both Ghost
10217 -- and Synchronous simple options. Emit an error if this is the
10220 procedure Create_Abstract_State
10224 Is_Null
: Boolean);
10225 -- Generate an abstract state entity with name Nam and enter it
10226 -- into visibility. Decl is the "declaration" of the state as
10227 -- it appears in pragma Abstract_State. Loc is the location of
10228 -- the related state "declaration". Flag Is_Null should be set
10229 -- when the associated Abstract_State pragma defines a null
10232 -----------------------------
10233 -- Analyze_External_Option --
10234 -----------------------------
10236 procedure Analyze_External_Option
(Opt
: Node_Id
) is
10237 Errors
: constant Nat
:= Serious_Errors_Detected
;
10239 Props
: Node_Id
:= Empty
;
10242 if Nkind
(Opt
) = N_Component_Association
then
10243 Props
:= Expression
(Opt
);
10246 -- External state with properties
10248 if Present
(Props
) then
10250 -- Multiple properties appear as an aggregate
10252 if Nkind
(Props
) = N_Aggregate
then
10254 -- Simple property form
10256 Prop
:= First
(Expressions
(Props
));
10257 while Present
(Prop
) loop
10258 Analyze_External_Property
(Prop
);
10262 -- Property with expression form
10264 Prop
:= First
(Component_Associations
(Props
));
10265 while Present
(Prop
) loop
10266 Analyze_External_Property
10267 (Prop
=> First
(Choices
(Prop
)),
10268 Expr
=> Expression
(Prop
));
10276 Analyze_External_Property
(Props
);
10279 -- An external state defined without any properties defaults
10280 -- all properties to True.
10289 -- Once all external properties have been processed, verify
10290 -- their mutual interaction. Do not perform the check when
10291 -- at least one of the properties is illegal as this will
10292 -- produce a bogus error.
10294 if Errors
= Serious_Errors_Detected
then
10295 Check_External_Properties
10296 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10298 end Analyze_External_Option
;
10300 -------------------------------
10301 -- Analyze_External_Property --
10302 -------------------------------
10304 procedure Analyze_External_Property
10306 Expr
: Node_Id
:= Empty
)
10308 Expr_Val
: Boolean;
10311 -- Check the placement of "others" (if available)
10313 if Nkind
(Prop
) = N_Others_Choice
then
10314 if Others_Seen
then
10316 ("only one others choice allowed in option External",
10319 Others_Seen
:= True;
10322 elsif Others_Seen
then
10324 ("others must be the last property in option External",
10327 -- The only remaining legal options are the four predefined
10328 -- external properties.
10330 elsif Nkind
(Prop
) = N_Identifier
10331 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10332 Name_Async_Writers
,
10333 Name_Effective_Reads
,
10334 Name_Effective_Writes
)
10338 -- Otherwise the construct is not a valid property
10341 SPARK_Msg_N
("invalid external state property", Prop
);
10345 -- Ensure that the expression of the external state property
10346 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10348 if Present
(Expr
) then
10349 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10351 if Is_OK_Static_Expression
(Expr
) then
10352 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10355 ("expression of external state property must be "
10359 -- The lack of expression defaults the property to True
10365 -- Named properties
10367 if Nkind
(Prop
) = N_Identifier
then
10368 if Chars
(Prop
) = Name_Async_Readers
then
10369 Check_Duplicate_Property
(Prop
, AR_Seen
);
10370 AR_Val
:= Expr_Val
;
10372 elsif Chars
(Prop
) = Name_Async_Writers
then
10373 Check_Duplicate_Property
(Prop
, AW_Seen
);
10374 AW_Val
:= Expr_Val
;
10376 elsif Chars
(Prop
) = Name_Effective_Reads
then
10377 Check_Duplicate_Property
(Prop
, ER_Seen
);
10378 ER_Val
:= Expr_Val
;
10381 Check_Duplicate_Property
(Prop
, EW_Seen
);
10382 EW_Val
:= Expr_Val
;
10385 -- The handling of property "others" must take into account
10386 -- all other named properties that have been encountered so
10387 -- far. Only those that have not been seen are affected by
10391 if not AR_Seen
then
10392 AR_Val
:= Expr_Val
;
10395 if not AW_Seen
then
10396 AW_Val
:= Expr_Val
;
10399 if not ER_Seen
then
10400 ER_Val
:= Expr_Val
;
10403 if not EW_Seen
then
10404 EW_Val
:= Expr_Val
;
10407 end Analyze_External_Property
;
10409 ----------------------------
10410 -- Analyze_Part_Of_Option --
10411 ----------------------------
10413 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10414 Encap
: constant Node_Id
:= Expression
(Opt
);
10415 Encap_Id
: Entity_Id
;
10419 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10422 (Indic
=> First
(Choices
(Opt
)),
10423 Item_Id
=> State_Id
,
10425 Encap_Id
=> Encap_Id
,
10428 -- The Part_Of indicator transforms the abstract state into
10429 -- a constituent of the encapsulating state or single
10430 -- concurrent type.
10433 pragma Assert
(Present
(Encap_Id
));
10435 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encap_Id
));
10436 Set_Encapsulating_State
(State_Id
, Encap_Id
);
10438 end Analyze_Part_Of_Option
;
10440 ----------------------------
10441 -- Check_Duplicate_Option --
10442 ----------------------------
10444 procedure Check_Duplicate_Option
10446 Status
: in out Boolean)
10450 SPARK_Msg_N
("duplicate state option", Opt
);
10454 end Check_Duplicate_Option
;
10456 ------------------------------
10457 -- Check_Duplicate_Property --
10458 ------------------------------
10460 procedure Check_Duplicate_Property
10462 Status
: in out Boolean)
10466 SPARK_Msg_N
("duplicate external property", Prop
);
10470 end Check_Duplicate_Property
;
10472 -----------------------------
10473 -- Check_Ghost_Synchronous --
10474 -----------------------------
10476 procedure Check_Ghost_Synchronous
is
10478 -- A synchronized abstract state cannot be Ghost and vice
10479 -- versa (SPARK RM 6.9(19)).
10481 if Ghost_Seen
and Synchronous_Seen
then
10482 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
10484 end Check_Ghost_Synchronous
;
10486 ---------------------------
10487 -- Create_Abstract_State --
10488 ---------------------------
10490 procedure Create_Abstract_State
10497 -- The abstract state may be semi-declared when the related
10498 -- package was withed through a limited with clause. In that
10499 -- case reuse the entity to fully declare the state.
10501 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10502 State_Id
:= Entity
(Decl
);
10504 -- Otherwise the elaboration of pragma Abstract_State
10505 -- declares the state.
10508 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10510 if Present
(Decl
) then
10511 Set_Entity
(Decl
, State_Id
);
10515 -- Null states never come from source
10517 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10518 Set_Parent
(State_Id
, State
);
10519 Set_Ekind
(State_Id
, E_Abstract_State
);
10520 Set_Etype
(State_Id
, Standard_Void_Type
);
10521 Set_Encapsulating_State
(State_Id
, Empty
);
10522 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
10523 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
10525 -- An abstract state declared within a Ghost region becomes
10526 -- Ghost (SPARK RM 6.9(2)).
10528 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
10529 Set_Is_Ghost_Entity
(State_Id
);
10532 -- Establish a link between the state declaration and the
10533 -- abstract state entity. Note that a null state remains as
10534 -- N_Null and does not carry any linkages.
10536 if not Is_Null
then
10537 if Present
(Decl
) then
10538 Set_Entity
(Decl
, State_Id
);
10539 Set_Etype
(Decl
, Standard_Void_Type
);
10542 -- Every non-null state must be defined, nameable and
10545 Push_Scope
(Pack_Id
);
10546 Generate_Definition
(State_Id
);
10547 Enter_Name
(State_Id
);
10550 end Create_Abstract_State
;
10557 -- Start of processing for Analyze_Abstract_State
10560 -- A package with a null abstract state is not allowed to
10561 -- declare additional states.
10565 ("package & has null abstract state", State
, Pack_Id
);
10567 -- Null states appear as internally generated entities
10569 elsif Nkind
(State
) = N_Null
then
10570 Create_Abstract_State
10571 (Nam
=> New_Internal_Name
('S'),
10573 Loc
=> Sloc
(State
),
10577 -- Catch a case where a null state appears in a list of
10578 -- non-null states.
10580 if Non_Null_Seen
then
10582 ("package & has non-null abstract state",
10586 -- Simple state declaration
10588 elsif Nkind
(State
) = N_Identifier
then
10589 Create_Abstract_State
10590 (Nam
=> Chars
(State
),
10592 Loc
=> Sloc
(State
),
10594 Non_Null_Seen
:= True;
10596 -- State declaration with various options. This construct
10597 -- appears as an extension aggregate in the tree.
10599 elsif Nkind
(State
) = N_Extension_Aggregate
then
10600 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10601 Create_Abstract_State
10602 (Nam
=> Chars
(Ancestor_Part
(State
)),
10603 Decl
=> Ancestor_Part
(State
),
10604 Loc
=> Sloc
(Ancestor_Part
(State
)),
10606 Non_Null_Seen
:= True;
10609 ("state name must be an identifier",
10610 Ancestor_Part
(State
));
10613 -- Options External, Ghost and Synchronous appear as
10616 Opt
:= First
(Expressions
(State
));
10617 while Present
(Opt
) loop
10618 if Nkind
(Opt
) = N_Identifier
then
10622 if Chars
(Opt
) = Name_External
then
10623 Check_Duplicate_Option
(Opt
, External_Seen
);
10624 Analyze_External_Option
(Opt
);
10628 elsif Chars
(Opt
) = Name_Ghost
then
10629 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
10630 Check_Ghost_Synchronous
;
10632 if Present
(State_Id
) then
10633 Set_Is_Ghost_Entity
(State_Id
);
10638 elsif Chars
(Opt
) = Name_Synchronous
then
10639 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
10640 Check_Ghost_Synchronous
;
10642 -- Option Part_Of without an encapsulating state is
10643 -- illegal (SPARK RM 7.1.4(9)).
10645 elsif Chars
(Opt
) = Name_Part_Of
then
10647 ("indicator Part_Of must denote abstract state, "
10648 & "single protected type or single task type",
10651 -- Do not emit an error message when a previous state
10652 -- declaration with options was not parenthesized as
10653 -- the option is actually another state declaration.
10655 -- with Abstract_State
10656 -- (State_1 with ..., -- missing parentheses
10657 -- (State_2 with ...),
10658 -- State_3) -- ok state declaration
10660 elsif Missing_Parentheses
then
10663 -- Otherwise the option is not allowed. Note that it
10664 -- is not possible to distinguish between an option
10665 -- and a state declaration when a previous state with
10666 -- options not properly parentheses.
10668 -- with Abstract_State
10669 -- (State_1 with ..., -- missing parentheses
10670 -- State_2); -- could be an option
10674 ("simple option not allowed in state declaration",
10678 -- Catch a case where missing parentheses around a state
10679 -- declaration with options cause a subsequent state
10680 -- declaration with options to be treated as an option.
10682 -- with Abstract_State
10683 -- (State_1 with ..., -- missing parentheses
10684 -- (State_2 with ...))
10686 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10687 Missing_Parentheses
:= True;
10689 ("state declaration must be parenthesized",
10690 Ancestor_Part
(State
));
10692 -- Otherwise the option is malformed
10695 SPARK_Msg_N
("malformed option", Opt
);
10701 -- Options External and Part_Of appear as component
10704 Opt
:= First
(Component_Associations
(State
));
10705 while Present
(Opt
) loop
10706 Opt_Nam
:= First
(Choices
(Opt
));
10708 if Nkind
(Opt_Nam
) = N_Identifier
then
10709 if Chars
(Opt_Nam
) = Name_External
then
10710 Analyze_External_Option
(Opt
);
10712 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10713 Analyze_Part_Of_Option
(Opt
);
10716 SPARK_Msg_N
("invalid state option", Opt
);
10719 SPARK_Msg_N
("invalid state option", Opt
);
10725 -- Any other attempt to declare a state is illegal
10728 Malformed_State_Error
(State
);
10732 -- Guard against a junk state. In such cases no entity is
10733 -- generated and the subsequent checks cannot be applied.
10735 if Present
(State_Id
) then
10737 -- Verify whether the state does not introduce an illegal
10738 -- hidden state within a package subject to a null abstract
10741 Check_No_Hidden_State
(State_Id
);
10743 -- Check whether the lack of option Part_Of agrees with the
10744 -- placement of the abstract state with respect to the state
10747 if not Part_Of_Seen
then
10748 Check_Missing_Part_Of
(State_Id
);
10751 -- Associate the state with its related package
10753 if No
(Abstract_States
(Pack_Id
)) then
10754 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10757 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10759 end Analyze_Abstract_State
;
10761 ---------------------------
10762 -- Malformed_State_Error --
10763 ---------------------------
10765 procedure Malformed_State_Error
(State
: Node_Id
) is
10767 Error_Msg_N
("malformed abstract state declaration", State
);
10769 -- An abstract state with a simple option is being declared
10770 -- with "=>" rather than the legal "with". The state appears
10771 -- as a component association.
10773 if Nkind
(State
) = N_Component_Association
then
10774 Error_Msg_N
("\use WITH to specify simple option", State
);
10776 end Malformed_State_Error
;
10780 Pack_Decl
: Node_Id
;
10781 Pack_Id
: Entity_Id
;
10785 -- Start of processing for Abstract_State
10789 Check_No_Identifiers
;
10790 Check_Arg_Count
(1);
10792 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
10794 -- Ensure the proper placement of the pragma. Abstract states must
10795 -- be associated with a package declaration.
10797 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
10798 N_Package_Declaration
)
10802 -- Otherwise the pragma is associated with an illegal construct
10809 Pack_Id
:= Defining_Entity
(Pack_Decl
);
10811 -- Chain the pragma on the contract for completeness
10813 Add_Contract_Item
(N
, Pack_Id
);
10815 -- The legality checks of pragmas Abstract_State, Initializes, and
10816 -- Initial_Condition are affected by the SPARK mode in effect. In
10817 -- addition, these three pragmas are subject to an inherent order:
10819 -- 1) Abstract_State
10821 -- 3) Initial_Condition
10823 -- Analyze all these pragmas in the order outlined above
10825 Analyze_If_Present
(Pragma_SPARK_Mode
);
10827 -- A pragma that applies to a Ghost entity becomes Ghost for the
10828 -- purposes of legality checks and removal of ignored Ghost code.
10830 Mark_Pragma_As_Ghost
(N
, Pack_Id
);
10831 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
10833 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
10835 -- Multiple non-null abstract states appear as an aggregate
10837 if Nkind
(States
) = N_Aggregate
then
10838 State
:= First
(Expressions
(States
));
10839 while Present
(State
) loop
10840 Analyze_Abstract_State
(State
, Pack_Id
);
10844 -- An abstract state with a simple option is being illegaly
10845 -- declared with "=>" rather than "with". In this case the
10846 -- state declaration appears as a component association.
10848 if Present
(Component_Associations
(States
)) then
10849 State
:= First
(Component_Associations
(States
));
10850 while Present
(State
) loop
10851 Malformed_State_Error
(State
);
10856 -- Various forms of a single abstract state. Note that these may
10857 -- include malformed state declarations.
10860 Analyze_Abstract_State
(States
, Pack_Id
);
10863 Analyze_If_Present
(Pragma_Initializes
);
10864 Analyze_If_Present
(Pragma_Initial_Condition
);
10865 end Abstract_State
;
10873 -- Note: this pragma also has some specific processing in Par.Prag
10874 -- because we want to set the Ada version mode during parsing.
10876 when Pragma_Ada_83
=>
10878 Check_Arg_Count
(0);
10880 -- We really should check unconditionally for proper configuration
10881 -- pragma placement, since we really don't want mixed Ada modes
10882 -- within a single unit, and the GNAT reference manual has always
10883 -- said this was a configuration pragma, but we did not check and
10884 -- are hesitant to add the check now.
10886 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10887 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10888 -- or Ada 2012 mode.
10890 if Ada_Version
>= Ada_2005
then
10891 Check_Valid_Configuration_Pragma
;
10894 -- Now set Ada 83 mode
10896 Ada_Version
:= Ada_83
;
10897 Ada_Version_Explicit
:= Ada_83
;
10898 Ada_Version_Pragma
:= N
;
10906 -- Note: this pragma also has some specific processing in Par.Prag
10907 -- because we want to set the Ada 83 version mode during parsing.
10909 when Pragma_Ada_95
=>
10911 Check_Arg_Count
(0);
10913 -- We really should check unconditionally for proper configuration
10914 -- pragma placement, since we really don't want mixed Ada modes
10915 -- within a single unit, and the GNAT reference manual has always
10916 -- said this was a configuration pragma, but we did not check and
10917 -- are hesitant to add the check now.
10919 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10920 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10922 if Ada_Version
>= Ada_2005
then
10923 Check_Valid_Configuration_Pragma
;
10926 -- Now set Ada 95 mode
10928 Ada_Version
:= Ada_95
;
10929 Ada_Version_Explicit
:= Ada_95
;
10930 Ada_Version_Pragma
:= N
;
10932 ---------------------
10933 -- Ada_05/Ada_2005 --
10934 ---------------------
10937 -- pragma Ada_05 (LOCAL_NAME);
10939 -- pragma Ada_2005;
10940 -- pragma Ada_2005 (LOCAL_NAME):
10942 -- Note: these pragmas also have some specific processing in Par.Prag
10943 -- because we want to set the Ada 2005 version mode during parsing.
10945 -- The one argument form is used for managing the transition from
10946 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10947 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10948 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10949 -- mode, a preference rule is established which does not choose
10950 -- such an entity unless it is unambiguously specified. This avoids
10951 -- extra subprograms marked this way from generating ambiguities in
10952 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10953 -- intended for exclusive use in the GNAT run-time library.
10955 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10961 if Arg_Count
= 1 then
10962 Check_Arg_Is_Local_Name
(Arg1
);
10963 E_Id
:= Get_Pragma_Arg
(Arg1
);
10965 if Etype
(E_Id
) = Any_Type
then
10969 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10970 Record_Rep_Item
(Entity
(E_Id
), N
);
10973 Check_Arg_Count
(0);
10975 -- For Ada_2005 we unconditionally enforce the documented
10976 -- configuration pragma placement, since we do not want to
10977 -- tolerate mixed modes in a unit involving Ada 2005. That
10978 -- would cause real difficulties for those cases where there
10979 -- are incompatibilities between Ada 95 and Ada 2005.
10981 Check_Valid_Configuration_Pragma
;
10983 -- Now set appropriate Ada mode
10985 Ada_Version
:= Ada_2005
;
10986 Ada_Version_Explicit
:= Ada_2005
;
10987 Ada_Version_Pragma
:= N
;
10991 ---------------------
10992 -- Ada_12/Ada_2012 --
10993 ---------------------
10996 -- pragma Ada_12 (LOCAL_NAME);
10998 -- pragma Ada_2012;
10999 -- pragma Ada_2012 (LOCAL_NAME):
11001 -- Note: these pragmas also have some specific processing in Par.Prag
11002 -- because we want to set the Ada 2012 version mode during parsing.
11004 -- The one argument form is used for managing the transition from Ada
11005 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11006 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11007 -- mode will generate a warning. In addition, in any pre-Ada_2012
11008 -- mode, a preference rule is established which does not choose
11009 -- such an entity unless it is unambiguously specified. This avoids
11010 -- extra subprograms marked this way from generating ambiguities in
11011 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11012 -- intended for exclusive use in the GNAT run-time library.
11014 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
11020 if Arg_Count
= 1 then
11021 Check_Arg_Is_Local_Name
(Arg1
);
11022 E_Id
:= Get_Pragma_Arg
(Arg1
);
11024 if Etype
(E_Id
) = Any_Type
then
11028 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
11029 Record_Rep_Item
(Entity
(E_Id
), N
);
11032 Check_Arg_Count
(0);
11034 -- For Ada_2012 we unconditionally enforce the documented
11035 -- configuration pragma placement, since we do not want to
11036 -- tolerate mixed modes in a unit involving Ada 2012. That
11037 -- would cause real difficulties for those cases where there
11038 -- are incompatibilities between Ada 95 and Ada 2012. We could
11039 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11041 Check_Valid_Configuration_Pragma
;
11043 -- Now set appropriate Ada mode
11045 Ada_Version
:= Ada_2012
;
11046 Ada_Version_Explicit
:= Ada_2012
;
11047 Ada_Version_Pragma
:= N
;
11051 ----------------------
11052 -- All_Calls_Remote --
11053 ----------------------
11055 -- pragma All_Calls_Remote [(library_package_NAME)];
11057 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
11058 Lib_Entity
: Entity_Id
;
11061 Check_Ada_83_Warning
;
11062 Check_Valid_Library_Unit_Pragma
;
11064 if Nkind
(N
) = N_Null_Statement
then
11068 Lib_Entity
:= Find_Lib_Unit_Name
;
11070 -- A pragma that applies to a Ghost entity becomes Ghost for the
11071 -- purposes of legality checks and removal of ignored Ghost code.
11073 Mark_Pragma_As_Ghost
(N
, Lib_Entity
);
11075 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11077 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
11078 if not Is_Remote_Call_Interface
(Lib_Entity
) then
11079 Error_Pragma
("pragma% only apply to rci unit");
11081 -- Set flag for entity of the library unit
11084 Set_Has_All_Calls_Remote
(Lib_Entity
);
11087 end All_Calls_Remote
;
11089 ---------------------------
11090 -- Allow_Integer_Address --
11091 ---------------------------
11093 -- pragma Allow_Integer_Address;
11095 when Pragma_Allow_Integer_Address
=>
11097 Check_Valid_Configuration_Pragma
;
11098 Check_Arg_Count
(0);
11100 -- If Address is a private type, then set the flag to allow
11101 -- integer address values. If Address is not private, then this
11102 -- pragma has no purpose, so it is simply ignored. Not clear if
11103 -- there are any such targets now.
11105 if Opt
.Address_Is_Private
then
11106 Opt
.Allow_Integer_Address
:= True;
11114 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11115 -- ARG ::= NAME | EXPRESSION
11117 -- The first two arguments are by convention intended to refer to an
11118 -- external tool and a tool-specific function. These arguments are
11121 when Pragma_Annotate
=> Annotate
: declare
11128 Check_At_Least_N_Arguments
(1);
11130 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
11132 -- Determine whether the last argument is "Entity => local_NAME"
11133 -- and if it is, perform the required semantic checks. Remove the
11134 -- argument from further processing.
11136 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
11137 and then Chars
(Nam_Arg
) = Name_Entity
11139 Check_Arg_Is_Local_Name
(Nam_Arg
);
11140 Arg_Count
:= Arg_Count
- 1;
11142 -- A pragma that applies to a Ghost entity becomes Ghost for
11143 -- the purposes of legality checks and removal of ignored Ghost
11146 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
11147 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
11149 Mark_Pragma_As_Ghost
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
11152 -- Not allowed in compiler units (bootstrap issues)
11154 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
11157 -- Continue the processing with last argument removed for now
11159 Check_Arg_Is_Identifier
(Arg1
);
11160 Check_No_Identifiers
;
11163 -- The second parameter is optional, it is never analyzed
11168 -- Otherwise there is a second parameter
11171 -- The second parameter must be an identifier
11173 Check_Arg_Is_Identifier
(Arg2
);
11175 -- Process the remaining parameters (if any)
11177 Arg
:= Next
(Arg2
);
11178 while Present
(Arg
) loop
11179 Expr
:= Get_Pragma_Arg
(Arg
);
11182 if Is_Entity_Name
(Expr
) then
11185 -- For string literals, we assume Standard_String as the
11186 -- type, unless the string contains wide or wide_wide
11189 elsif Nkind
(Expr
) = N_String_Literal
then
11190 if Has_Wide_Wide_Character
(Expr
) then
11191 Resolve
(Expr
, Standard_Wide_Wide_String
);
11192 elsif Has_Wide_Character
(Expr
) then
11193 Resolve
(Expr
, Standard_Wide_String
);
11195 Resolve
(Expr
, Standard_String
);
11198 elsif Is_Overloaded
(Expr
) then
11199 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
11210 -------------------------------------------------
11211 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11212 -------------------------------------------------
11215 -- ( [Check => ] Boolean_EXPRESSION
11216 -- [, [Message =>] Static_String_EXPRESSION]);
11218 -- pragma Assert_And_Cut
11219 -- ( [Check => ] Boolean_EXPRESSION
11220 -- [, [Message =>] Static_String_EXPRESSION]);
11223 -- ( [Check => ] Boolean_EXPRESSION
11224 -- [, [Message =>] Static_String_EXPRESSION]);
11226 -- pragma Loop_Invariant
11227 -- ( [Check => ] Boolean_EXPRESSION
11228 -- [, [Message =>] Static_String_EXPRESSION]);
11230 when Pragma_Assert |
11231 Pragma_Assert_And_Cut |
11233 Pragma_Loop_Invariant
=>
11235 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
11236 -- Determine whether expression Expr contains a Loop_Entry
11237 -- attribute reference.
11239 -------------------------
11240 -- Contains_Loop_Entry --
11241 -------------------------
11243 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
11244 Has_Loop_Entry
: Boolean := False;
11246 function Process
(N
: Node_Id
) return Traverse_Result
;
11247 -- Process function for traversal to look for Loop_Entry
11253 function Process
(N
: Node_Id
) return Traverse_Result
is
11255 if Nkind
(N
) = N_Attribute_Reference
11256 and then Attribute_Name
(N
) = Name_Loop_Entry
11258 Has_Loop_Entry
:= True;
11265 procedure Traverse
is new Traverse_Proc
(Process
);
11267 -- Start of processing for Contains_Loop_Entry
11271 return Has_Loop_Entry
;
11272 end Contains_Loop_Entry
;
11277 New_Args
: List_Id
;
11279 -- Start of processing for Assert
11282 -- Assert is an Ada 2005 RM-defined pragma
11284 if Prag_Id
= Pragma_Assert
then
11287 -- The remaining ones are GNAT pragmas
11293 Check_At_Least_N_Arguments
(1);
11294 Check_At_Most_N_Arguments
(2);
11295 Check_Arg_Order
((Name_Check
, Name_Message
));
11296 Check_Optional_Identifier
(Arg1
, Name_Check
);
11297 Expr
:= Get_Pragma_Arg
(Arg1
);
11299 -- Special processing for Loop_Invariant, Loop_Variant or for
11300 -- other cases where a Loop_Entry attribute is present. If the
11301 -- assertion pragma contains attribute Loop_Entry, ensure that
11302 -- the related pragma is within a loop.
11304 if Prag_Id
= Pragma_Loop_Invariant
11305 or else Prag_Id
= Pragma_Loop_Variant
11306 or else Contains_Loop_Entry
(Expr
)
11308 Check_Loop_Pragma_Placement
;
11310 -- Perform preanalysis to deal with embedded Loop_Entry
11313 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
11316 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11317 -- a corresponding Check pragma:
11319 -- pragma Check (name, condition [, msg]);
11321 -- Where name is the identifier matching the pragma name. So
11322 -- rewrite pragma in this manner, transfer the message argument
11323 -- if present, and analyze the result
11325 -- Note: When dealing with a semantically analyzed tree, the
11326 -- information that a Check node N corresponds to a source Assert,
11327 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11328 -- pragma kind of Original_Node(N).
11330 New_Args
:= New_List
(
11331 Make_Pragma_Argument_Association
(Loc
,
11332 Expression
=> Make_Identifier
(Loc
, Pname
)),
11333 Make_Pragma_Argument_Association
(Sloc
(Expr
),
11334 Expression
=> Expr
));
11336 if Arg_Count
> 1 then
11337 Check_Optional_Identifier
(Arg2
, Name_Message
);
11339 -- Provide semantic annnotations for optional argument, for
11340 -- ASIS use, before rewriting.
11342 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
11343 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
11346 -- Rewrite as Check pragma
11350 Chars
=> Name_Check
,
11351 Pragma_Argument_Associations
=> New_Args
));
11356 ----------------------
11357 -- Assertion_Policy --
11358 ----------------------
11360 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11362 -- The following form is Ada 2012 only, but we allow it in all modes
11364 -- Pragma Assertion_Policy (
11365 -- ASSERTION_KIND => POLICY_IDENTIFIER
11366 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11368 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11370 -- RM_ASSERTION_KIND ::= Assert |
11371 -- Static_Predicate |
11372 -- Dynamic_Predicate |
11377 -- Type_Invariant |
11378 -- Type_Invariant'Class
11380 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11382 -- Contract_Cases |
11384 -- Default_Initial_Condition |
11386 -- Initial_Condition |
11387 -- Loop_Invariant |
11393 -- Statement_Assertions
11395 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11396 -- ID_ASSERTION_KIND list contains implementation-defined additions
11397 -- recognized by GNAT. The effect is to control the behavior of
11398 -- identically named aspects and pragmas, depending on the specified
11399 -- policy identifier:
11401 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11403 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11404 -- implementation-defined addition that results in totally ignoring
11405 -- the corresponding assertion. If Disable is specified, then the
11406 -- argument of the assertion is not even analyzed. This is useful
11407 -- when the aspect/pragma argument references entities in a with'ed
11408 -- package that is replaced by a dummy package in the final build.
11410 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11411 -- and Type_Invariant'Class were recognized by the parser and
11412 -- transformed into references to the special internal identifiers
11413 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11414 -- processing is required here.
11416 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11425 -- This can always appear as a configuration pragma
11427 if Is_Configuration_Pragma
then
11430 -- It can also appear in a declarative part or package spec in Ada
11431 -- 2012 mode. We allow this in other modes, but in that case we
11432 -- consider that we have an Ada 2012 pragma on our hands.
11435 Check_Is_In_Decl_Part_Or_Package_Spec
;
11439 -- One argument case with no identifier (first form above)
11442 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11443 or else Chars
(Arg1
) = No_Name
)
11445 Check_Arg_Is_One_Of
11446 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11448 -- Treat one argument Assertion_Policy as equivalent to:
11450 -- pragma Check_Policy (Assertion, policy)
11452 -- So rewrite pragma in that manner and link on to the chain
11453 -- of Check_Policy pragmas, marking the pragma as analyzed.
11455 Policy
:= Get_Pragma_Arg
(Arg1
);
11459 Chars
=> Name_Check_Policy
,
11460 Pragma_Argument_Associations
=> New_List
(
11461 Make_Pragma_Argument_Association
(Loc
,
11462 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11464 Make_Pragma_Argument_Association
(Loc
,
11466 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11469 -- Here if we have two or more arguments
11472 Check_At_Least_N_Arguments
(1);
11475 -- Loop through arguments
11478 while Present
(Arg
) loop
11479 LocP
:= Sloc
(Arg
);
11481 -- Kind must be specified
11483 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11484 or else Chars
(Arg
) = No_Name
11487 ("missing assertion kind for pragma%", Arg
);
11490 -- Check Kind and Policy have allowed forms
11492 Kind
:= Chars
(Arg
);
11494 if not Is_Valid_Assertion_Kind
(Kind
) then
11496 ("invalid assertion kind for pragma%", Arg
);
11499 Check_Arg_Is_One_Of
11500 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11502 -- Rewrite the Assertion_Policy pragma as a series of
11503 -- Check_Policy pragmas of the form:
11505 -- Check_Policy (Kind, Policy);
11507 -- Note: the insertion of the pragmas cannot be done with
11508 -- Insert_Action because in the configuration case, there
11509 -- are no scopes on the scope stack and the mechanism will
11512 Insert_Before_And_Analyze
(N
,
11514 Chars
=> Name_Check_Policy
,
11515 Pragma_Argument_Associations
=> New_List
(
11516 Make_Pragma_Argument_Association
(LocP
,
11517 Expression
=> Make_Identifier
(LocP
, Kind
)),
11518 Make_Pragma_Argument_Association
(LocP
,
11519 Expression
=> Get_Pragma_Arg
(Arg
)))));
11524 -- Rewrite the Assertion_Policy pragma as null since we have
11525 -- now inserted all the equivalent Check pragmas.
11527 Rewrite
(N
, Make_Null_Statement
(Loc
));
11530 end Assertion_Policy
;
11532 ------------------------------
11533 -- Assume_No_Invalid_Values --
11534 ------------------------------
11536 -- pragma Assume_No_Invalid_Values (On | Off);
11538 when Pragma_Assume_No_Invalid_Values
=>
11540 Check_Valid_Configuration_Pragma
;
11541 Check_Arg_Count
(1);
11542 Check_No_Identifiers
;
11543 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11545 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11546 Assume_No_Invalid_Values
:= True;
11548 Assume_No_Invalid_Values
:= False;
11551 --------------------------
11552 -- Attribute_Definition --
11553 --------------------------
11555 -- pragma Attribute_Definition
11556 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11557 -- [Entity =>] LOCAL_NAME,
11558 -- [Expression =>] EXPRESSION | NAME);
11560 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11561 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11566 Check_Arg_Count
(3);
11567 Check_Optional_Identifier
(Arg1
, "attribute");
11568 Check_Optional_Identifier
(Arg2
, "entity");
11569 Check_Optional_Identifier
(Arg3
, "expression");
11571 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11572 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11576 Check_Arg_Is_Local_Name
(Arg2
);
11578 -- If the attribute is not recognized, then issue a warning (not
11579 -- an error), and ignore the pragma.
11581 Aname
:= Chars
(Attribute_Designator
);
11583 if not Is_Attribute_Name
(Aname
) then
11584 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11588 -- Otherwise, rewrite the pragma as an attribute definition clause
11591 Make_Attribute_Definition_Clause
(Loc
,
11592 Name
=> Get_Pragma_Arg
(Arg2
),
11594 Expression
=> Get_Pragma_Arg
(Arg3
)));
11596 end Attribute_Definition
;
11598 ------------------------------------------------------------------
11599 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11600 ------------------------------------------------------------------
11602 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
11603 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
11604 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
11605 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
11607 when Pragma_Async_Readers |
11608 Pragma_Async_Writers |
11609 Pragma_Effective_Reads |
11610 Pragma_Effective_Writes
=>
11611 Async_Effective
: declare
11612 Obj_Decl
: Node_Id
;
11613 Obj_Id
: Entity_Id
;
11617 Check_No_Identifiers
;
11618 Check_At_Most_N_Arguments
(1);
11620 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
11622 -- Object declaration
11624 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
11627 -- Otherwise the pragma is associated with an illegal construact
11634 Obj_Id
:= Defining_Entity
(Obj_Decl
);
11636 -- Perform minimal verification to ensure that the argument is at
11637 -- least a variable. Subsequent finer grained checks will be done
11638 -- at the end of the declarative region the contains the pragma.
11640 if Ekind
(Obj_Id
) = E_Variable
then
11642 -- Chain the pragma on the contract for further processing by
11643 -- Analyze_External_Property_In_Decl_Part.
11645 Add_Contract_Item
(N
, Obj_Id
);
11647 -- A pragma that applies to a Ghost entity becomes Ghost for
11648 -- the purposes of legality checks and removal of ignored Ghost
11651 Mark_Pragma_As_Ghost
(N
, Obj_Id
);
11653 -- Analyze the Boolean expression (if any)
11655 if Present
(Arg1
) then
11656 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
11659 -- Otherwise the external property applies to a constant
11662 Error_Pragma
("pragma % must apply to a volatile object");
11664 end Async_Effective
;
11670 -- pragma Asynchronous (LOCAL_NAME);
11672 when Pragma_Asynchronous
=> Asynchronous
: declare
11675 Formal
: Entity_Id
;
11680 procedure Process_Async_Pragma
;
11681 -- Common processing for procedure and access-to-procedure case
11683 --------------------------
11684 -- Process_Async_Pragma --
11685 --------------------------
11687 procedure Process_Async_Pragma
is
11690 Set_Is_Asynchronous
(Nm
);
11694 -- The formals should be of mode IN (RM E.4.1(6))
11697 while Present
(S
) loop
11698 Formal
:= Defining_Identifier
(S
);
11700 if Nkind
(Formal
) = N_Defining_Identifier
11701 and then Ekind
(Formal
) /= E_In_Parameter
11704 ("pragma% procedure can only have IN parameter",
11711 Set_Is_Asynchronous
(Nm
);
11712 end Process_Async_Pragma
;
11714 -- Start of processing for pragma Asynchronous
11717 Check_Ada_83_Warning
;
11718 Check_No_Identifiers
;
11719 Check_Arg_Count
(1);
11720 Check_Arg_Is_Local_Name
(Arg1
);
11722 if Debug_Flag_U
then
11726 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11727 Analyze
(Get_Pragma_Arg
(Arg1
));
11728 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11730 -- A pragma that applies to a Ghost entity becomes Ghost for the
11731 -- purposes of legality checks and removal of ignored Ghost code.
11733 Mark_Pragma_As_Ghost
(N
, Nm
);
11735 if not Is_Remote_Call_Interface
(C_Ent
)
11736 and then not Is_Remote_Types
(C_Ent
)
11738 -- This pragma should only appear in an RCI or Remote Types
11739 -- unit (RM E.4.1(4)).
11742 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11745 if Ekind
(Nm
) = E_Procedure
11746 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11748 if not Is_Remote_Call_Interface
(Nm
) then
11750 ("pragma% cannot be applied on non-remote procedure",
11754 L
:= Parameter_Specifications
(Parent
(Nm
));
11755 Process_Async_Pragma
;
11758 elsif Ekind
(Nm
) = E_Function
then
11760 ("pragma% cannot be applied to function", Arg1
);
11762 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11763 if Is_Record_Type
(Nm
) then
11765 -- A record type that is the Equivalent_Type for a remote
11766 -- access-to-subprogram type.
11768 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11771 -- A non-expanded RAS type (distribution is not enabled)
11773 Decl
:= Declaration_Node
(Nm
);
11776 if Nkind
(Decl
) = N_Full_Type_Declaration
11777 and then Nkind
(Type_Definition
(Decl
)) =
11778 N_Access_Procedure_Definition
11780 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
11781 Process_Async_Pragma
;
11783 if Is_Asynchronous
(Nm
)
11784 and then Expander_Active
11785 and then Get_PCS_Name
/= Name_No_DSA
11787 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11792 ("pragma% cannot reference access-to-function type",
11796 -- Only other possibility is Access-to-class-wide type
11798 elsif Is_Access_Type
(Nm
)
11799 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11801 Check_First_Subtype
(Arg1
);
11802 Set_Is_Asynchronous
(Nm
);
11803 if Expander_Active
then
11804 RACW_Type_Is_Asynchronous
(Nm
);
11808 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11816 -- pragma Atomic (LOCAL_NAME);
11818 when Pragma_Atomic
=>
11819 Process_Atomic_Independent_Shared_Volatile
;
11821 -----------------------
11822 -- Atomic_Components --
11823 -----------------------
11825 -- pragma Atomic_Components (array_LOCAL_NAME);
11827 -- This processing is shared by Volatile_Components
11829 when Pragma_Atomic_Components |
11830 Pragma_Volatile_Components
=>
11831 Atomic_Components
: declare
11838 Check_Ada_83_Warning
;
11839 Check_No_Identifiers
;
11840 Check_Arg_Count
(1);
11841 Check_Arg_Is_Local_Name
(Arg1
);
11842 E_Id
:= Get_Pragma_Arg
(Arg1
);
11844 if Etype
(E_Id
) = Any_Type
then
11848 E
:= Entity
(E_Id
);
11850 -- A pragma that applies to a Ghost entity becomes Ghost for the
11851 -- purposes of legality checks and removal of ignored Ghost code.
11853 Mark_Pragma_As_Ghost
(N
, E
);
11854 Check_Duplicate_Pragma
(E
);
11856 if Rep_Item_Too_Early
(E
, N
)
11858 Rep_Item_Too_Late
(E
, N
)
11863 D
:= Declaration_Node
(E
);
11866 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11868 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11869 and then Nkind
(D
) = N_Object_Declaration
11870 and then Nkind
(Object_Definition
(D
)) =
11871 N_Constrained_Array_Definition
)
11873 -- The flag is set on the object, or on the base type
11875 if Nkind
(D
) /= N_Object_Declaration
then
11876 E
:= Base_Type
(E
);
11879 -- Atomic implies both Independent and Volatile
11881 if Prag_Id
= Pragma_Atomic_Components
then
11882 Set_Has_Atomic_Components
(E
);
11883 Set_Has_Independent_Components
(E
);
11886 Set_Has_Volatile_Components
(E
);
11889 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11891 end Atomic_Components
;
11893 --------------------
11894 -- Attach_Handler --
11895 --------------------
11897 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11899 when Pragma_Attach_Handler
=>
11900 Check_Ada_83_Warning
;
11901 Check_No_Identifiers
;
11902 Check_Arg_Count
(2);
11904 if No_Run_Time_Mode
then
11905 Error_Msg_CRT
("Attach_Handler pragma", N
);
11907 Check_Interrupt_Or_Attach_Handler
;
11909 -- The expression that designates the attribute may depend on a
11910 -- discriminant, and is therefore a per-object expression, to
11911 -- be expanded in the init proc. If expansion is enabled, then
11912 -- perform semantic checks on a copy only.
11917 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11920 -- In Relaxed_RM_Semantics mode, we allow any static
11921 -- integer value, for compatibility with other compilers.
11923 if Relaxed_RM_Semantics
11924 and then Nkind
(Parg2
) = N_Integer_Literal
11926 Typ
:= Standard_Integer
;
11928 Typ
:= RTE
(RE_Interrupt_ID
);
11931 if Expander_Active
then
11932 Temp
:= New_Copy_Tree
(Parg2
);
11933 Set_Parent
(Temp
, N
);
11934 Preanalyze_And_Resolve
(Temp
, Typ
);
11937 Resolve
(Parg2
, Typ
);
11941 Process_Interrupt_Or_Attach_Handler
;
11944 --------------------
11945 -- C_Pass_By_Copy --
11946 --------------------
11948 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11950 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11956 Check_Valid_Configuration_Pragma
;
11957 Check_Arg_Count
(1);
11958 Check_Optional_Identifier
(Arg1
, "max_size");
11960 Arg
:= Get_Pragma_Arg
(Arg1
);
11961 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11963 Val
:= Expr_Value
(Arg
);
11967 ("maximum size for pragma% must be positive", Arg1
);
11969 elsif UI_Is_In_Int_Range
(Val
) then
11970 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11972 -- If a giant value is given, Int'Last will do well enough.
11973 -- If sometime someone complains that a record larger than
11974 -- two gigabytes is not copied, we will worry about it then.
11977 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11979 end C_Pass_By_Copy
;
11985 -- pragma Check ([Name =>] CHECK_KIND,
11986 -- [Check =>] Boolean_EXPRESSION
11987 -- [,[Message =>] String_EXPRESSION]);
11989 -- CHECK_KIND ::= IDENTIFIER |
11992 -- Invariant'Class |
11993 -- Type_Invariant'Class
11995 -- The identifiers Assertions and Statement_Assertions are not
11996 -- allowed, since they have special meaning for Check_Policy.
11998 when Pragma_Check
=> Check
: declare
12004 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
12007 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12008 -- the mode now to ensure that any nodes generated during analysis
12009 -- and expansion are marked as Ghost.
12011 Set_Ghost_Mode
(N
);
12014 Check_At_Least_N_Arguments
(2);
12015 Check_At_Most_N_Arguments
(3);
12016 Check_Optional_Identifier
(Arg1
, Name_Name
);
12017 Check_Optional_Identifier
(Arg2
, Name_Check
);
12019 if Arg_Count
= 3 then
12020 Check_Optional_Identifier
(Arg3
, Name_Message
);
12021 Str
:= Get_Pragma_Arg
(Arg3
);
12024 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
12025 Check_Arg_Is_Identifier
(Arg1
);
12026 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
12028 -- Check forbidden name Assertions or Statement_Assertions
12031 when Name_Assertions
=>
12033 ("""Assertions"" is not allowed as a check kind for "
12034 & "pragma%", Arg1
);
12036 when Name_Statement_Assertions
=>
12038 ("""Statement_Assertions"" is not allowed as a check kind "
12039 & "for pragma%", Arg1
);
12045 -- Check applicable policy. We skip this if Checked/Ignored status
12046 -- is already set (e.g. in the case of a pragma from an aspect).
12048 if Is_Checked
(N
) or else Is_Ignored
(N
) then
12051 -- For a non-source pragma that is a rewriting of another pragma,
12052 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12054 elsif Is_Rewrite_Substitution
(N
)
12055 and then Nkind
(Original_Node
(N
)) = N_Pragma
12056 and then Original_Node
(N
) /= N
12058 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
12059 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
12061 -- Otherwise query the applicable policy at this point
12064 case Check_Kind
(Cname
) is
12065 when Name_Ignore
=>
12066 Set_Is_Ignored
(N
, True);
12067 Set_Is_Checked
(N
, False);
12070 Set_Is_Ignored
(N
, False);
12071 Set_Is_Checked
(N
, True);
12073 -- For disable, rewrite pragma as null statement and skip
12074 -- rest of the analysis of the pragma.
12076 when Name_Disable
=>
12077 Rewrite
(N
, Make_Null_Statement
(Loc
));
12081 -- No other possibilities
12084 raise Program_Error
;
12088 -- If check kind was not Disable, then continue pragma analysis
12090 Expr
:= Get_Pragma_Arg
(Arg2
);
12092 -- Deal with SCO generation
12096 -- Nothing to do for invariants and predicates as the checks
12097 -- occur in the client units. The SCO for the aspect in the
12098 -- declaration unit is conservatively always enabled.
12100 when Name_Invariant | Name_Predicate
=>
12103 -- Otherwise mark aspect/pragma SCO as enabled
12106 if Is_Checked
(N
) and then not Split_PPC
(N
) then
12107 Set_SCO_Pragma_Enabled
(Loc
);
12111 -- Deal with analyzing the string argument
12113 if Arg_Count
= 3 then
12115 -- If checks are not on we don't want any expansion (since
12116 -- such expansion would not get properly deleted) but
12117 -- we do want to analyze (to get proper references).
12118 -- The Preanalyze_And_Resolve routine does just what we want
12120 if Is_Ignored
(N
) then
12121 Preanalyze_And_Resolve
(Str
, Standard_String
);
12123 -- Otherwise we need a proper analysis and expansion
12126 Analyze_And_Resolve
(Str
, Standard_String
);
12130 -- Now you might think we could just do the same with the Boolean
12131 -- expression if checks are off (and expansion is on) and then
12132 -- rewrite the check as a null statement. This would work but we
12133 -- would lose the useful warnings about an assertion being bound
12134 -- to fail even if assertions are turned off.
12136 -- So instead we wrap the boolean expression in an if statement
12137 -- that looks like:
12139 -- if False and then condition then
12143 -- The reason we do this rewriting during semantic analysis rather
12144 -- than as part of normal expansion is that we cannot analyze and
12145 -- expand the code for the boolean expression directly, or it may
12146 -- cause insertion of actions that would escape the attempt to
12147 -- suppress the check code.
12149 -- Note that the Sloc for the if statement corresponds to the
12150 -- argument condition, not the pragma itself. The reason for
12151 -- this is that we may generate a warning if the condition is
12152 -- False at compile time, and we do not want to delete this
12153 -- warning when we delete the if statement.
12155 if Expander_Active
and Is_Ignored
(N
) then
12156 Eloc
:= Sloc
(Expr
);
12159 Make_If_Statement
(Eloc
,
12161 Make_And_Then
(Eloc
,
12162 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
12163 Right_Opnd
=> Expr
),
12164 Then_Statements
=> New_List
(
12165 Make_Null_Statement
(Eloc
))));
12167 -- Now go ahead and analyze the if statement
12169 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12171 -- One rather special treatment. If we are now in Eliminated
12172 -- overflow mode, then suppress overflow checking since we do
12173 -- not want to drag in the bignum stuff if we are in Ignore
12174 -- mode anyway. This is particularly important if we are using
12175 -- a configurable run time that does not support bignum ops.
12177 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
12179 Svo
: constant Boolean :=
12180 Scope_Suppress
.Suppress
(Overflow_Check
);
12182 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
12183 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
12185 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
12186 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
12189 -- Not that special case
12195 -- All done with this check
12197 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12199 -- Check is active or expansion not active. In these cases we can
12200 -- just go ahead and analyze the boolean with no worries.
12203 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12204 Analyze_And_Resolve
(Expr
, Any_Boolean
);
12205 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12208 Ghost_Mode
:= Save_Ghost_Mode
;
12211 --------------------------
12212 -- Check_Float_Overflow --
12213 --------------------------
12215 -- pragma Check_Float_Overflow;
12217 when Pragma_Check_Float_Overflow
=>
12219 Check_Valid_Configuration_Pragma
;
12220 Check_Arg_Count
(0);
12221 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
12227 -- pragma Check_Name (check_IDENTIFIER);
12229 when Pragma_Check_Name
=>
12231 Check_No_Identifiers
;
12232 Check_Valid_Configuration_Pragma
;
12233 Check_Arg_Count
(1);
12234 Check_Arg_Is_Identifier
(Arg1
);
12237 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
12240 for J
in Check_Names
.First
.. Check_Names
.Last
loop
12241 if Check_Names
.Table
(J
) = Nam
then
12246 Check_Names
.Append
(Nam
);
12253 -- This is the old style syntax, which is still allowed in all modes:
12255 -- pragma Check_Policy ([Name =>] CHECK_KIND
12256 -- [Policy =>] POLICY_IDENTIFIER);
12258 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12260 -- CHECK_KIND ::= IDENTIFIER |
12263 -- Type_Invariant'Class |
12266 -- This is the new style syntax, compatible with Assertion_Policy
12267 -- and also allowed in all modes.
12269 -- Pragma Check_Policy (
12270 -- CHECK_KIND => POLICY_IDENTIFIER
12271 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12273 -- Note: the identifiers Name and Policy are not allowed as
12274 -- Check_Kind values. This avoids ambiguities between the old and
12275 -- new form syntax.
12277 when Pragma_Check_Policy
=> Check_Policy
: declare
12283 Check_At_Least_N_Arguments
(1);
12285 -- A Check_Policy pragma can appear either as a configuration
12286 -- pragma, or in a declarative part or a package spec (see RM
12287 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12288 -- followed for Check_Policy).
12290 if not Is_Configuration_Pragma
then
12291 Check_Is_In_Decl_Part_Or_Package_Spec
;
12294 -- Figure out if we have the old or new syntax. We have the
12295 -- old syntax if the first argument has no identifier, or the
12296 -- identifier is Name.
12298 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
12299 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
12303 Check_Arg_Count
(2);
12304 Check_Optional_Identifier
(Arg1
, Name_Name
);
12305 Kind
:= Get_Pragma_Arg
(Arg1
);
12306 Rewrite_Assertion_Kind
(Kind
);
12307 Check_Arg_Is_Identifier
(Arg1
);
12309 -- Check forbidden check kind
12311 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
12312 Error_Msg_Name_2
:= Chars
(Kind
);
12314 ("pragma% does not allow% as check name", Arg1
);
12319 Check_Optional_Identifier
(Arg2
, Name_Policy
);
12320 Check_Arg_Is_One_Of
12322 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
12323 Ident
:= Get_Pragma_Arg
(Arg2
);
12325 if Chars
(Kind
) = Name_Ghost
then
12327 -- Pragma Check_Policy specifying a Ghost policy cannot
12328 -- occur within a ghost subprogram or package.
12330 if Ghost_Mode
> None
then
12332 ("pragma % cannot appear within ghost subprogram or "
12335 -- The policy identifier of pragma Ghost must be either
12336 -- Check or Ignore (SPARK RM 6.9(7)).
12338 elsif not Nam_In
(Chars
(Ident
), Name_Check
,
12342 ("argument of pragma % Ghost must be Check or Ignore",
12347 -- And chain pragma on the Check_Policy_List for search
12349 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
12350 Opt
.Check_Policy_List
:= N
;
12352 -- For the new syntax, what we do is to convert each argument to
12353 -- an old syntax equivalent. We do that because we want to chain
12354 -- old style Check_Policy pragmas for the search (we don't want
12355 -- to have to deal with multiple arguments in the search).
12365 while Present
(Arg
) loop
12366 LocP
:= Sloc
(Arg
);
12367 Argx
:= Get_Pragma_Arg
(Arg
);
12369 -- Kind must be specified
12371 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12372 or else Chars
(Arg
) = No_Name
12375 ("missing assertion kind for pragma%", Arg
);
12378 -- Construct equivalent old form syntax Check_Policy
12379 -- pragma and insert it to get remaining checks.
12383 Chars
=> Name_Check_Policy
,
12384 Pragma_Argument_Associations
=> New_List
(
12385 Make_Pragma_Argument_Association
(LocP
,
12387 Make_Identifier
(LocP
, Chars
(Arg
))),
12388 Make_Pragma_Argument_Association
(Sloc
(Argx
),
12389 Expression
=> Argx
))));
12394 -- Rewrite original Check_Policy pragma to null, since we
12395 -- have converted it into a series of old syntax pragmas.
12397 Rewrite
(N
, Make_Null_Statement
(Loc
));
12407 -- pragma Comment (static_string_EXPRESSION)
12409 -- Processing for pragma Comment shares the circuitry for pragma
12410 -- Ident. The only differences are that Ident enforces a limit of 31
12411 -- characters on its argument, and also enforces limitations on
12412 -- placement for DEC compatibility. Pragma Comment shares neither of
12413 -- these restrictions.
12415 -------------------
12416 -- Common_Object --
12417 -------------------
12419 -- pragma Common_Object (
12420 -- [Internal =>] LOCAL_NAME
12421 -- [, [External =>] EXTERNAL_SYMBOL]
12422 -- [, [Size =>] EXTERNAL_SYMBOL]);
12424 -- Processing for this pragma is shared with Psect_Object
12426 ------------------------
12427 -- Compile_Time_Error --
12428 ------------------------
12430 -- pragma Compile_Time_Error
12431 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12433 when Pragma_Compile_Time_Error
=>
12435 Process_Compile_Time_Warning_Or_Error
;
12437 --------------------------
12438 -- Compile_Time_Warning --
12439 --------------------------
12441 -- pragma Compile_Time_Warning
12442 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12444 when Pragma_Compile_Time_Warning
=>
12446 Process_Compile_Time_Warning_Or_Error
;
12448 ---------------------------
12449 -- Compiler_Unit_Warning --
12450 ---------------------------
12452 -- pragma Compiler_Unit_Warning;
12456 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12457 -- errors not warnings. This means that we had introduced a big extra
12458 -- inertia to compiler changes, since even if we implemented a new
12459 -- feature, and even if all versions to be used for bootstrapping
12460 -- implemented this new feature, we could not use it, since old
12461 -- compilers would give errors for using this feature in units
12462 -- having Compiler_Unit pragmas.
12464 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12465 -- problem. We no longer have any units mentioning Compiler_Unit,
12466 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12467 -- and thus generates a warning which can be ignored. So that deals
12468 -- with the problem of old compilers not implementing the newer form
12471 -- Newer compilers recognize the new pragma, but generate warning
12472 -- messages instead of errors, which again can be ignored in the
12473 -- case of an old compiler which implements a wanted new feature
12474 -- but at the time felt like warning about it for older compilers.
12476 -- We retain Compiler_Unit so that new compilers can be used to build
12477 -- older run-times that use this pragma. That's an unusual case, but
12478 -- it's easy enough to handle, so why not?
12480 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12482 Check_Arg_Count
(0);
12484 -- Only recognized in main unit
12486 if Current_Sem_Unit
= Main_Unit
then
12487 Compiler_Unit
:= True;
12490 -----------------------------
12491 -- Complete_Representation --
12492 -----------------------------
12494 -- pragma Complete_Representation;
12496 when Pragma_Complete_Representation
=>
12498 Check_Arg_Count
(0);
12500 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12502 ("pragma & must appear within record representation clause");
12505 ----------------------------
12506 -- Complex_Representation --
12507 ----------------------------
12509 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12511 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12518 Check_Arg_Count
(1);
12519 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12520 Check_Arg_Is_Local_Name
(Arg1
);
12521 E_Id
:= Get_Pragma_Arg
(Arg1
);
12523 if Etype
(E_Id
) = Any_Type
then
12527 E
:= Entity
(E_Id
);
12529 if not Is_Record_Type
(E
) then
12531 ("argument for pragma% must be record type", Arg1
);
12534 Ent
:= First_Entity
(E
);
12537 or else No
(Next_Entity
(Ent
))
12538 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12539 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12540 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12543 ("record for pragma% must have two fields of the same "
12544 & "floating-point type", Arg1
);
12547 Set_Has_Complex_Representation
(Base_Type
(E
));
12549 -- We need to treat the type has having a non-standard
12550 -- representation, for back-end purposes, even though in
12551 -- general a complex will have the default representation
12552 -- of a record with two real components.
12554 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12556 end Complex_Representation
;
12558 -------------------------
12559 -- Component_Alignment --
12560 -------------------------
12562 -- pragma Component_Alignment (
12563 -- [Form =>] ALIGNMENT_CHOICE
12564 -- [, [Name =>] type_LOCAL_NAME]);
12566 -- ALIGNMENT_CHOICE ::=
12568 -- | Component_Size_4
12572 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12573 Args
: Args_List
(1 .. 2);
12574 Names
: constant Name_List
(1 .. 2) := (
12578 Form
: Node_Id
renames Args
(1);
12579 Name
: Node_Id
renames Args
(2);
12581 Atype
: Component_Alignment_Kind
;
12586 Gather_Associations
(Names
, Args
);
12589 Error_Pragma
("missing Form argument for pragma%");
12592 Check_Arg_Is_Identifier
(Form
);
12594 -- Get proper alignment, note that Default = Component_Size on all
12595 -- machines we have so far, and we want to set this value rather
12596 -- than the default value to indicate that it has been explicitly
12597 -- set (and thus will not get overridden by the default component
12598 -- alignment for the current scope)
12600 if Chars
(Form
) = Name_Component_Size
then
12601 Atype
:= Calign_Component_Size
;
12603 elsif Chars
(Form
) = Name_Component_Size_4
then
12604 Atype
:= Calign_Component_Size_4
;
12606 elsif Chars
(Form
) = Name_Default
then
12607 Atype
:= Calign_Component_Size
;
12609 elsif Chars
(Form
) = Name_Storage_Unit
then
12610 Atype
:= Calign_Storage_Unit
;
12614 ("invalid Form parameter for pragma%", Form
);
12617 -- Case with no name, supplied, affects scope table entry
12621 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12623 -- Case of name supplied
12626 Check_Arg_Is_Local_Name
(Name
);
12628 Typ
:= Entity
(Name
);
12631 or else Rep_Item_Too_Early
(Typ
, N
)
12635 Typ
:= Underlying_Type
(Typ
);
12638 if not Is_Record_Type
(Typ
)
12639 and then not Is_Array_Type
(Typ
)
12642 ("Name parameter of pragma% must identify record or "
12643 & "array type", Name
);
12646 -- An explicit Component_Alignment pragma overrides an
12647 -- implicit pragma Pack, but not an explicit one.
12649 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12650 Set_Is_Packed
(Base_Type
(Typ
), False);
12651 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12654 end Component_AlignmentP
;
12656 --------------------------------
12657 -- Constant_After_Elaboration --
12658 --------------------------------
12660 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
12662 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
12664 Obj_Decl
: Node_Id
;
12665 Obj_Id
: Entity_Id
;
12669 Check_No_Identifiers
;
12670 Check_At_Most_N_Arguments
(1);
12672 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
12674 -- Object declaration
12676 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
12679 -- Otherwise the pragma is associated with an illegal construct
12686 Obj_Id
:= Defining_Entity
(Obj_Decl
);
12688 -- The object declaration must be a library-level variable which
12689 -- is either explicitly initialized or obtains a value during the
12690 -- elaboration of a package body (SPARK RM 3.3.1).
12692 if Ekind
(Obj_Id
) = E_Variable
then
12693 if not Is_Library_Level_Entity
(Obj_Id
) then
12695 ("pragma % must apply to a library level variable");
12699 -- Otherwise the pragma applies to a constant, which is illegal
12702 Error_Pragma
("pragma % must apply to a variable declaration");
12706 -- Chain the pragma on the contract for completeness
12708 Add_Contract_Item
(N
, Obj_Id
);
12710 -- A pragma that applies to a Ghost entity becomes Ghost for the
12711 -- purposes of legality checks and removal of ignored Ghost code.
12713 Mark_Pragma_As_Ghost
(N
, Obj_Id
);
12715 -- Analyze the Boolean expression (if any)
12717 if Present
(Arg1
) then
12718 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
12720 end Constant_After_Elaboration
;
12722 --------------------
12723 -- Contract_Cases --
12724 --------------------
12726 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12728 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12730 -- CASE_GUARD ::= boolean_EXPRESSION | others
12732 -- CONSEQUENCE ::= boolean_EXPRESSION
12734 -- Characteristics:
12736 -- * Analysis - The annotation undergoes initial checks to verify
12737 -- the legal placement and context. Secondary checks preanalyze the
12740 -- Analyze_Contract_Cases_In_Decl_Part
12742 -- * Expansion - The annotation is expanded during the expansion of
12743 -- the related subprogram [body] contract as performed in:
12745 -- Expand_Subprogram_Contract
12747 -- * Template - The annotation utilizes the generic template of the
12748 -- related subprogram [body] when it is:
12750 -- aspect on subprogram declaration
12751 -- aspect on stand alone subprogram body
12752 -- pragma on stand alone subprogram body
12754 -- The annotation must prepare its own template when it is:
12756 -- pragma on subprogram declaration
12758 -- * Globals - Capture of global references must occur after full
12761 -- * Instance - The annotation is instantiated automatically when
12762 -- the related generic subprogram [body] is instantiated except for
12763 -- the "pragma on subprogram declaration" case. In that scenario
12764 -- the annotation must instantiate itself.
12766 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12767 Spec_Id
: Entity_Id
;
12768 Subp_Decl
: Node_Id
;
12772 Check_No_Identifiers
;
12773 Check_Arg_Count
(1);
12775 -- Ensure the proper placement of the pragma. Contract_Cases must
12776 -- be associated with a subprogram declaration or a body that acts
12780 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
12784 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
12787 -- Generic subprogram
12789 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
12792 -- Body acts as spec
12794 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12795 and then No
(Corresponding_Spec
(Subp_Decl
))
12799 -- Body stub acts as spec
12801 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12802 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12808 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12816 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
12818 -- Chain the pragma on the contract for further processing by
12819 -- Analyze_Contract_Cases_In_Decl_Part.
12821 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12823 -- A pragma that applies to a Ghost entity becomes Ghost for the
12824 -- purposes of legality checks and removal of ignored Ghost code.
12826 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
12827 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
12829 -- Fully analyze the pragma when it appears inside an entry
12830 -- or subprogram body because it cannot benefit from forward
12833 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
12835 N_Subprogram_Body_Stub
)
12837 -- The legality checks of pragma Contract_Cases are affected by
12838 -- the SPARK mode in effect and the volatility of the context.
12839 -- Analyze all pragmas in a specific order.
12841 Analyze_If_Present
(Pragma_SPARK_Mode
);
12842 Analyze_If_Present
(Pragma_Volatile_Function
);
12843 Analyze_Contract_Cases_In_Decl_Part
(N
);
12845 end Contract_Cases
;
12851 -- pragma Controlled (first_subtype_LOCAL_NAME);
12853 when Pragma_Controlled
=> Controlled
: declare
12857 Check_No_Identifiers
;
12858 Check_Arg_Count
(1);
12859 Check_Arg_Is_Local_Name
(Arg1
);
12860 Arg
:= Get_Pragma_Arg
(Arg1
);
12862 if not Is_Entity_Name
(Arg
)
12863 or else not Is_Access_Type
(Entity
(Arg
))
12865 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12867 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12875 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12876 -- [Entity =>] LOCAL_NAME);
12878 when Pragma_Convention
=> Convention
: declare
12881 pragma Warnings
(Off
, C
);
12882 pragma Warnings
(Off
, E
);
12884 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12885 Check_Ada_83_Warning
;
12886 Check_Arg_Count
(2);
12887 Process_Convention
(C
, E
);
12889 -- A pragma that applies to a Ghost entity becomes Ghost for the
12890 -- purposes of legality checks and removal of ignored Ghost code.
12892 Mark_Pragma_As_Ghost
(N
, E
);
12895 ---------------------------
12896 -- Convention_Identifier --
12897 ---------------------------
12899 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12900 -- [Convention =>] convention_IDENTIFIER);
12902 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12908 Check_Arg_Order
((Name_Name
, Name_Convention
));
12909 Check_Arg_Count
(2);
12910 Check_Optional_Identifier
(Arg1
, Name_Name
);
12911 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12912 Check_Arg_Is_Identifier
(Arg1
);
12913 Check_Arg_Is_Identifier
(Arg2
);
12914 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12915 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12917 if Is_Convention_Name
(Cname
) then
12918 Record_Convention_Identifier
12919 (Idnam
, Get_Convention_Id
(Cname
));
12922 ("second arg for % pragma must be convention", Arg2
);
12924 end Convention_Identifier
;
12930 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12932 when Pragma_CPP_Class
=> CPP_Class
: declare
12936 if Warn_On_Obsolescent_Feature
then
12938 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12939 & "effect; replace it by pragma import?j?", N
);
12942 Check_Arg_Count
(1);
12946 Chars
=> Name_Import
,
12947 Pragma_Argument_Associations
=> New_List
(
12948 Make_Pragma_Argument_Association
(Loc
,
12949 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12950 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12954 ---------------------
12955 -- CPP_Constructor --
12956 ---------------------
12958 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12959 -- [, [External_Name =>] static_string_EXPRESSION ]
12960 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12962 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12965 Def_Id
: Entity_Id
;
12966 Tag_Typ
: Entity_Id
;
12970 Check_At_Least_N_Arguments
(1);
12971 Check_At_Most_N_Arguments
(3);
12972 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12973 Check_Arg_Is_Local_Name
(Arg1
);
12975 Id
:= Get_Pragma_Arg
(Arg1
);
12976 Find_Program_Unit_Name
(Id
);
12978 -- If we did not find the name, we are done
12980 if Etype
(Id
) = Any_Type
then
12984 Def_Id
:= Entity
(Id
);
12986 -- Check if already defined as constructor
12988 if Is_Constructor
(Def_Id
) then
12990 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12994 if Ekind
(Def_Id
) = E_Function
12995 and then (Is_CPP_Class
(Etype
(Def_Id
))
12996 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12998 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
13000 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
13002 ("'C'P'P constructor must be defined in the scope of "
13003 & "its returned type", Arg1
);
13006 if Arg_Count
>= 2 then
13007 Set_Imported
(Def_Id
);
13008 Set_Is_Public
(Def_Id
);
13009 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
13012 Set_Has_Completion
(Def_Id
);
13013 Set_Is_Constructor
(Def_Id
);
13014 Set_Convention
(Def_Id
, Convention_CPP
);
13016 -- Imported C++ constructors are not dispatching primitives
13017 -- because in C++ they don't have a dispatch table slot.
13018 -- However, in Ada the constructor has the profile of a
13019 -- function that returns a tagged type and therefore it has
13020 -- been treated as a primitive operation during semantic
13021 -- analysis. We now remove it from the list of primitive
13022 -- operations of the type.
13024 if Is_Tagged_Type
(Etype
(Def_Id
))
13025 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
13026 and then Is_Dispatching_Operation
(Def_Id
)
13028 Tag_Typ
:= Etype
(Def_Id
);
13030 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
13031 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
13035 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
13036 Set_Is_Dispatching_Operation
(Def_Id
, False);
13039 -- For backward compatibility, if the constructor returns a
13040 -- class wide type, and we internally change the return type to
13041 -- the corresponding root type.
13043 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
13044 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
13048 ("pragma% requires function returning a 'C'P'P_Class type",
13051 end CPP_Constructor
;
13057 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
13061 if Warn_On_Obsolescent_Feature
then
13063 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13072 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
13076 if Warn_On_Obsolescent_Feature
then
13078 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13087 -- pragma CPU (EXPRESSION);
13089 when Pragma_CPU
=> CPU
: declare
13090 P
: constant Node_Id
:= Parent
(N
);
13096 Check_No_Identifiers
;
13097 Check_Arg_Count
(1);
13101 if Nkind
(P
) = N_Subprogram_Body
then
13102 Check_In_Main_Program
;
13104 Arg
:= Get_Pragma_Arg
(Arg1
);
13105 Analyze_And_Resolve
(Arg
, Any_Integer
);
13107 Ent
:= Defining_Unit_Name
(Specification
(P
));
13109 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
13110 Ent
:= Defining_Identifier
(Ent
);
13115 if not Is_OK_Static_Expression
(Arg
) then
13116 Flag_Non_Static_Expr
13117 ("main subprogram affinity is not static!", Arg
);
13120 -- If constraint error, then we already signalled an error
13122 elsif Raises_Constraint_Error
(Arg
) then
13125 -- Otherwise check in range
13129 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
13130 -- This is the entity System.Multiprocessors.CPU_Range;
13132 Val
: constant Uint
:= Expr_Value
(Arg
);
13135 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
13137 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
13140 ("main subprogram CPU is out of range", Arg1
);
13146 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
13150 elsif Nkind
(P
) = N_Task_Definition
then
13151 Arg
:= Get_Pragma_Arg
(Arg1
);
13152 Ent
:= Defining_Identifier
(Parent
(P
));
13154 -- The expression must be analyzed in the special manner
13155 -- described in "Handling of Default and Per-Object
13156 -- Expressions" in sem.ads.
13158 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
13160 -- Anything else is incorrect
13166 -- Check duplicate pragma before we chain the pragma in the Rep
13167 -- Item chain of Ent.
13169 Check_Duplicate_Pragma
(Ent
);
13170 Record_Rep_Item
(Ent
, N
);
13177 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13179 when Pragma_Debug
=> Debug
: declare
13186 -- The condition for executing the call is that the expander
13187 -- is active and that we are not ignoring this debug pragma.
13192 (Expander_Active
and then not Is_Ignored
(N
)),
13195 if not Is_Ignored
(N
) then
13196 Set_SCO_Pragma_Enabled
(Loc
);
13199 if Arg_Count
= 2 then
13201 Make_And_Then
(Loc
,
13202 Left_Opnd
=> Relocate_Node
(Cond
),
13203 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
13204 Call
:= Get_Pragma_Arg
(Arg2
);
13206 Call
:= Get_Pragma_Arg
(Arg1
);
13210 N_Indexed_Component
,
13214 N_Selected_Component
)
13216 -- If this pragma Debug comes from source, its argument was
13217 -- parsed as a name form (which is syntactically identical).
13218 -- In a generic context a parameterless call will be left as
13219 -- an expanded name (if global) or selected_component if local.
13220 -- Change it to a procedure call statement now.
13222 Change_Name_To_Procedure_Call_Statement
(Call
);
13224 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
13226 -- Already in the form of a procedure call statement: nothing
13227 -- to do (could happen in case of an internally generated
13233 -- All other cases: diagnose error
13236 ("argument of pragma ""Debug"" is not procedure call",
13241 -- Rewrite into a conditional with an appropriate condition. We
13242 -- wrap the procedure call in a block so that overhead from e.g.
13243 -- use of the secondary stack does not generate execution overhead
13244 -- for suppressed conditions.
13246 -- Normally the analysis that follows will freeze the subprogram
13247 -- being called. However, if the call is to a null procedure,
13248 -- we want to freeze it before creating the block, because the
13249 -- analysis that follows may be done with expansion disabled, in
13250 -- which case the body will not be generated, leading to spurious
13253 if Nkind
(Call
) = N_Procedure_Call_Statement
13254 and then Is_Entity_Name
(Name
(Call
))
13256 Analyze
(Name
(Call
));
13257 Freeze_Before
(N
, Entity
(Name
(Call
)));
13261 Make_Implicit_If_Statement
(N
,
13263 Then_Statements
=> New_List
(
13264 Make_Block_Statement
(Loc
,
13265 Handled_Statement_Sequence
=>
13266 Make_Handled_Sequence_Of_Statements
(Loc
,
13267 Statements
=> New_List
(Relocate_Node
(Call
)))))));
13270 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13271 -- after analysis of the normally rewritten node, to capture all
13272 -- references to entities, which avoids issuing wrong warnings
13273 -- about unused entities.
13275 if GNATprove_Mode
then
13276 Rewrite
(N
, Make_Null_Statement
(Loc
));
13284 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13286 when Pragma_Debug_Policy
=>
13288 Check_Arg_Count
(1);
13289 Check_No_Identifiers
;
13290 Check_Arg_Is_Identifier
(Arg1
);
13292 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13293 -- rewrite it that way, and let the rest of the checking come
13294 -- from analyzing the rewritten pragma.
13298 Chars
=> Name_Check_Policy
,
13299 Pragma_Argument_Associations
=> New_List
(
13300 Make_Pragma_Argument_Association
(Loc
,
13301 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
13303 Make_Pragma_Argument_Association
(Loc
,
13304 Expression
=> Get_Pragma_Arg
(Arg1
)))));
13307 -------------------------------
13308 -- Default_Initial_Condition --
13309 -------------------------------
13311 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
13313 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
13320 Check_No_Identifiers
;
13321 Check_At_Most_N_Arguments
(1);
13324 while Present
(Stmt
) loop
13326 -- Skip prior pragmas, but check for duplicates
13328 if Nkind
(Stmt
) = N_Pragma
then
13329 if Pragma_Name
(Stmt
) = Pname
then
13330 Error_Msg_Name_1
:= Pname
;
13331 Error_Msg_Sloc
:= Sloc
(Stmt
);
13332 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
13335 -- Skip internally generated code
13337 elsif not Comes_From_Source
(Stmt
) then
13340 -- The associated private type [extension] has been found, stop
13343 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
13344 N_Private_Type_Declaration
)
13346 Typ
:= Defining_Entity
(Stmt
);
13349 -- The pragma does not apply to a legal construct, issue an
13350 -- error and stop the analysis.
13357 Stmt
:= Prev
(Stmt
);
13360 -- A pragma that applies to a Ghost entity becomes Ghost for the
13361 -- purposes of legality checks and removal of ignored Ghost code.
13363 Mark_Pragma_As_Ghost
(N
, Typ
);
13364 Set_Has_Default_Init_Cond
(Typ
);
13365 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
13367 -- Chain the pragma on the rep item chain for further processing
13369 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
13370 end Default_Init_Cond
;
13372 ----------------------------------
13373 -- Default_Scalar_Storage_Order --
13374 ----------------------------------
13376 -- pragma Default_Scalar_Storage_Order
13377 -- (High_Order_First | Low_Order_First);
13379 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
13380 Default
: Character;
13384 Check_Arg_Count
(1);
13386 -- Default_Scalar_Storage_Order can appear as a configuration
13387 -- pragma, or in a declarative part of a package spec.
13389 if not Is_Configuration_Pragma
then
13390 Check_Is_In_Decl_Part_Or_Package_Spec
;
13393 Check_No_Identifiers
;
13394 Check_Arg_Is_One_Of
13395 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
13396 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13397 Default
:= Fold_Upper
(Name_Buffer
(1));
13399 if not Support_Nondefault_SSO_On_Target
13400 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
13402 if Warn_On_Unrecognized_Pragma
then
13404 ("non-default Scalar_Storage_Order not supported "
13405 & "on target?g?", N
);
13407 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
13410 -- Here set the specified default
13413 Opt
.Default_SSO
:= Default
;
13417 --------------------------
13418 -- Default_Storage_Pool --
13419 --------------------------
13421 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13423 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
13428 Check_Arg_Count
(1);
13430 -- Default_Storage_Pool can appear as a configuration pragma, or
13431 -- in a declarative part of a package spec.
13433 if not Is_Configuration_Pragma
then
13434 Check_Is_In_Decl_Part_Or_Package_Spec
;
13437 if Present
(Arg1
) then
13438 Pool
:= Get_Pragma_Arg
(Arg1
);
13440 -- Case of Default_Storage_Pool (null);
13442 if Nkind
(Pool
) = N_Null
then
13445 -- This is an odd case, this is not really an expression,
13446 -- so we don't have a type for it. So just set the type to
13449 Set_Etype
(Pool
, Empty
);
13451 -- Case of Default_Storage_Pool (storage_pool_NAME);
13454 -- If it's a configuration pragma, then the only allowed
13455 -- argument is "null".
13457 if Is_Configuration_Pragma
then
13458 Error_Pragma_Arg
("NULL expected", Arg1
);
13461 -- The expected type for a non-"null" argument is
13462 -- Root_Storage_Pool'Class, and the pool must be a variable.
13464 Analyze_And_Resolve
13465 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
13467 if Is_Variable
(Pool
) then
13469 -- A pragma that applies to a Ghost entity becomes Ghost
13470 -- for the purposes of legality checks and removal of
13471 -- ignored Ghost code.
13473 Mark_Pragma_As_Ghost
(N
, Entity
(Pool
));
13477 ("default storage pool must be a variable", Arg1
);
13481 -- Record the pool name (or null). Freeze.Freeze_Entity for an
13482 -- access type will use this information to set the appropriate
13483 -- attributes of the access type.
13485 Default_Pool
:= Pool
;
13487 end Default_Storage_Pool
;
13493 -- pragma Depends (DEPENDENCY_RELATION);
13495 -- DEPENDENCY_RELATION ::=
13497 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
13499 -- DEPENDENCY_CLAUSE ::=
13500 -- OUTPUT_LIST =>[+] INPUT_LIST
13501 -- | NULL_DEPENDENCY_CLAUSE
13503 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13505 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13507 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13509 -- OUTPUT ::= NAME | FUNCTION_RESULT
13512 -- where FUNCTION_RESULT is a function Result attribute_reference
13514 -- Characteristics:
13516 -- * Analysis - The annotation undergoes initial checks to verify
13517 -- the legal placement and context. Secondary checks fully analyze
13518 -- the dependency clauses in:
13520 -- Analyze_Depends_In_Decl_Part
13522 -- * Expansion - None.
13524 -- * Template - The annotation utilizes the generic template of the
13525 -- related subprogram [body] when it is:
13527 -- aspect on subprogram declaration
13528 -- aspect on stand alone subprogram body
13529 -- pragma on stand alone subprogram body
13531 -- The annotation must prepare its own template when it is:
13533 -- pragma on subprogram declaration
13535 -- * Globals - Capture of global references must occur after full
13538 -- * Instance - The annotation is instantiated automatically when
13539 -- the related generic subprogram [body] is instantiated except for
13540 -- the "pragma on subprogram declaration" case. In that scenario
13541 -- the annotation must instantiate itself.
13543 when Pragma_Depends
=> Depends
: declare
13545 Spec_Id
: Entity_Id
;
13546 Subp_Decl
: Node_Id
;
13549 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
13553 -- Chain the pragma on the contract for further processing by
13554 -- Analyze_Depends_In_Decl_Part.
13556 Add_Contract_Item
(N
, Spec_Id
);
13558 -- Fully analyze the pragma when it appears inside an entry
13559 -- or subprogram body because it cannot benefit from forward
13562 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
13564 N_Subprogram_Body_Stub
)
13566 -- The legality checks of pragmas Depends and Global are
13567 -- affected by the SPARK mode in effect and the volatility
13568 -- of the context. In addition these two pragmas are subject
13569 -- to an inherent order:
13574 -- Analyze all these pragmas in the order outlined above
13576 Analyze_If_Present
(Pragma_SPARK_Mode
);
13577 Analyze_If_Present
(Pragma_Volatile_Function
);
13578 Analyze_If_Present
(Pragma_Global
);
13579 Analyze_Depends_In_Decl_Part
(N
);
13584 ---------------------
13585 -- Detect_Blocking --
13586 ---------------------
13588 -- pragma Detect_Blocking;
13590 when Pragma_Detect_Blocking
=>
13592 Check_Arg_Count
(0);
13593 Check_Valid_Configuration_Pragma
;
13594 Detect_Blocking
:= True;
13596 ------------------------------------
13597 -- Disable_Atomic_Synchronization --
13598 ------------------------------------
13600 -- pragma Disable_Atomic_Synchronization [(Entity)];
13602 when Pragma_Disable_Atomic_Synchronization
=>
13604 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
13606 -------------------
13607 -- Discard_Names --
13608 -------------------
13610 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13612 when Pragma_Discard_Names
=> Discard_Names
: declare
13617 Check_Ada_83_Warning
;
13619 -- Deal with configuration pragma case
13621 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
13622 Global_Discard_Names
:= True;
13625 -- Otherwise, check correct appropriate context
13628 Check_Is_In_Decl_Part_Or_Package_Spec
;
13630 if Arg_Count
= 0 then
13632 -- If there is no parameter, then from now on this pragma
13633 -- applies to any enumeration, exception or tagged type
13634 -- defined in the current declarative part, and recursively
13635 -- to any nested scope.
13637 Set_Discard_Names
(Current_Scope
);
13641 Check_Arg_Count
(1);
13642 Check_Optional_Identifier
(Arg1
, Name_On
);
13643 Check_Arg_Is_Local_Name
(Arg1
);
13645 E_Id
:= Get_Pragma_Arg
(Arg1
);
13647 if Etype
(E_Id
) = Any_Type
then
13650 E
:= Entity
(E_Id
);
13653 -- A pragma that applies to a Ghost entity becomes Ghost for
13654 -- the purposes of legality checks and removal of ignored
13657 Mark_Pragma_As_Ghost
(N
, E
);
13659 if (Is_First_Subtype
(E
)
13661 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
13662 or else Ekind
(E
) = E_Exception
13664 Set_Discard_Names
(E
);
13665 Record_Rep_Item
(E
, N
);
13669 ("inappropriate entity for pragma%", Arg1
);
13675 ------------------------
13676 -- Dispatching_Domain --
13677 ------------------------
13679 -- pragma Dispatching_Domain (EXPRESSION);
13681 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13682 P
: constant Node_Id
:= Parent
(N
);
13688 Check_No_Identifiers
;
13689 Check_Arg_Count
(1);
13691 -- This pragma is born obsolete, but not the aspect
13693 if not From_Aspect_Specification
(N
) then
13695 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13698 if Nkind
(P
) = N_Task_Definition
then
13699 Arg
:= Get_Pragma_Arg
(Arg1
);
13700 Ent
:= Defining_Identifier
(Parent
(P
));
13702 -- A pragma that applies to a Ghost entity becomes Ghost for
13703 -- the purposes of legality checks and removal of ignored Ghost
13706 Mark_Pragma_As_Ghost
(N
, Ent
);
13708 -- The expression must be analyzed in the special manner
13709 -- described in "Handling of Default and Per-Object
13710 -- Expressions" in sem.ads.
13712 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13714 -- Check duplicate pragma before we chain the pragma in the Rep
13715 -- Item chain of Ent.
13717 Check_Duplicate_Pragma
(Ent
);
13718 Record_Rep_Item
(Ent
, N
);
13720 -- Anything else is incorrect
13725 end Dispatching_Domain
;
13731 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13733 when Pragma_Elaborate
=> Elaborate
: declare
13738 -- Pragma must be in context items list of a compilation unit
13740 if not Is_In_Context_Clause
then
13744 -- Must be at least one argument
13746 if Arg_Count
= 0 then
13747 Error_Pragma
("pragma% requires at least one argument");
13750 -- In Ada 83 mode, there can be no items following it in the
13751 -- context list except other pragmas and implicit with clauses
13752 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13753 -- placement rule does not apply.
13755 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13757 while Present
(Citem
) loop
13758 if Nkind
(Citem
) = N_Pragma
13759 or else (Nkind
(Citem
) = N_With_Clause
13760 and then Implicit_With
(Citem
))
13765 ("(Ada 83) pragma% must be at end of context clause");
13772 -- Finally, the arguments must all be units mentioned in a with
13773 -- clause in the same context clause. Note we already checked (in
13774 -- Par.Prag) that the arguments are all identifiers or selected
13778 Outer
: while Present
(Arg
) loop
13779 Citem
:= First
(List_Containing
(N
));
13780 Inner
: while Citem
/= N
loop
13781 if Nkind
(Citem
) = N_With_Clause
13782 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13784 Set_Elaborate_Present
(Citem
, True);
13785 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13787 -- With the pragma present, elaboration calls on
13788 -- subprograms from the named unit need no further
13789 -- checks, as long as the pragma appears in the current
13790 -- compilation unit. If the pragma appears in some unit
13791 -- in the context, there might still be a need for an
13792 -- Elaborate_All_Desirable from the current compilation
13793 -- to the named unit, so we keep the check enabled.
13795 if In_Extended_Main_Source_Unit
(N
) then
13797 -- This does not apply in SPARK mode, where we allow
13798 -- pragma Elaborate, but we don't trust it to be right
13799 -- so we will still insist on the Elaborate_All.
13801 if SPARK_Mode
/= On
then
13802 Set_Suppress_Elaboration_Warnings
13803 (Entity
(Name
(Citem
)));
13815 ("argument of pragma% is not withed unit", Arg
);
13821 -- Give a warning if operating in static mode with one of the
13822 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13825 and not Dynamic_Elaboration_Checks
13827 -- pragma Elaborate not allowed in SPARK mode anyway. We
13828 -- already complained about it, no point in generating any
13829 -- further complaint.
13831 and SPARK_Mode
/= On
13834 ("?l?use of pragma Elaborate may not be safe", N
);
13836 ("?l?use pragma Elaborate_All instead if possible", N
);
13840 -------------------
13841 -- Elaborate_All --
13842 -------------------
13844 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13846 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13851 Check_Ada_83_Warning
;
13853 -- Pragma must be in context items list of a compilation unit
13855 if not Is_In_Context_Clause
then
13859 -- Must be at least one argument
13861 if Arg_Count
= 0 then
13862 Error_Pragma
("pragma% requires at least one argument");
13865 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13866 -- have to appear at the end of the context clause, but may
13867 -- appear mixed in with other items, even in Ada 83 mode.
13869 -- Final check: the arguments must all be units mentioned in
13870 -- a with clause in the same context clause. Note that we
13871 -- already checked (in Par.Prag) that all the arguments are
13872 -- either identifiers or selected components.
13875 Outr
: while Present
(Arg
) loop
13876 Citem
:= First
(List_Containing
(N
));
13877 Innr
: while Citem
/= N
loop
13878 if Nkind
(Citem
) = N_With_Clause
13879 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13881 Set_Elaborate_All_Present
(Citem
, True);
13882 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13884 -- Suppress warnings and elaboration checks on the named
13885 -- unit if the pragma is in the current compilation, as
13886 -- for pragma Elaborate.
13888 if In_Extended_Main_Source_Unit
(N
) then
13889 Set_Suppress_Elaboration_Warnings
13890 (Entity
(Name
(Citem
)));
13899 Set_Error_Posted
(N
);
13901 ("argument of pragma% is not withed unit", Arg
);
13908 --------------------
13909 -- Elaborate_Body --
13910 --------------------
13912 -- pragma Elaborate_Body [( library_unit_NAME )];
13914 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13915 Cunit_Node
: Node_Id
;
13916 Cunit_Ent
: Entity_Id
;
13919 Check_Ada_83_Warning
;
13920 Check_Valid_Library_Unit_Pragma
;
13922 if Nkind
(N
) = N_Null_Statement
then
13926 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13927 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13929 -- A pragma that applies to a Ghost entity becomes Ghost for the
13930 -- purposes of legality checks and removal of ignored Ghost code.
13932 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
13934 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13937 Error_Pragma
("pragma% must refer to a spec, not a body");
13939 Set_Body_Required
(Cunit_Node
, True);
13940 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13942 -- If we are in dynamic elaboration mode, then we suppress
13943 -- elaboration warnings for the unit, since it is definitely
13944 -- fine NOT to do dynamic checks at the first level (and such
13945 -- checks will be suppressed because no elaboration boolean
13946 -- is created for Elaborate_Body packages).
13948 -- But in the static model of elaboration, Elaborate_Body is
13949 -- definitely NOT good enough to ensure elaboration safety on
13950 -- its own, since the body may WITH other units that are not
13951 -- safe from an elaboration point of view, so a client must
13952 -- still do an Elaborate_All on such units.
13954 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13955 -- Elaborate_Body always suppressed elab warnings.
13957 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13958 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13961 end Elaborate_Body
;
13963 ------------------------
13964 -- Elaboration_Checks --
13965 ------------------------
13967 -- pragma Elaboration_Checks (Static | Dynamic);
13969 when Pragma_Elaboration_Checks
=>
13971 Check_Arg_Count
(1);
13972 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13974 -- Set flag accordingly (ignore attempt at dynamic elaboration
13975 -- checks in SPARK mode).
13977 Dynamic_Elaboration_Checks
:=
13978 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
)
13979 and then SPARK_Mode
/= On
;
13985 -- pragma Eliminate (
13986 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13987 -- [,[Entity =>] IDENTIFIER |
13988 -- SELECTED_COMPONENT |
13990 -- [, OVERLOADING_RESOLUTION]);
13992 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13995 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13996 -- FUNCTION_PROFILE
13998 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14000 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14001 -- Result_Type => result_SUBTYPE_NAME]
14003 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14004 -- SUBTYPE_NAME ::= STRING_LITERAL
14006 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14007 -- SOURCE_TRACE ::= STRING_LITERAL
14009 when Pragma_Eliminate
=> Eliminate
: declare
14010 Args
: Args_List
(1 .. 5);
14011 Names
: constant Name_List
(1 .. 5) := (
14014 Name_Parameter_Types
,
14016 Name_Source_Location
);
14018 Unit_Name
: Node_Id
renames Args
(1);
14019 Entity
: Node_Id
renames Args
(2);
14020 Parameter_Types
: Node_Id
renames Args
(3);
14021 Result_Type
: Node_Id
renames Args
(4);
14022 Source_Location
: Node_Id
renames Args
(5);
14026 Check_Valid_Configuration_Pragma
;
14027 Gather_Associations
(Names
, Args
);
14029 if No
(Unit_Name
) then
14030 Error_Pragma
("missing Unit_Name argument for pragma%");
14034 and then (Present
(Parameter_Types
)
14036 Present
(Result_Type
)
14038 Present
(Source_Location
))
14040 Error_Pragma
("missing Entity argument for pragma%");
14043 if (Present
(Parameter_Types
)
14045 Present
(Result_Type
))
14047 Present
(Source_Location
)
14050 ("parameter profile and source location cannot be used "
14051 & "together in pragma%");
14054 Process_Eliminate_Pragma
14063 -----------------------------------
14064 -- Enable_Atomic_Synchronization --
14065 -----------------------------------
14067 -- pragma Enable_Atomic_Synchronization [(Entity)];
14069 when Pragma_Enable_Atomic_Synchronization
=>
14071 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
14078 -- [ Convention =>] convention_IDENTIFIER,
14079 -- [ Entity =>] LOCAL_NAME
14080 -- [, [External_Name =>] static_string_EXPRESSION ]
14081 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14083 when Pragma_Export
=> Export
: declare
14085 Def_Id
: Entity_Id
;
14087 pragma Warnings
(Off
, C
);
14090 Check_Ada_83_Warning
;
14094 Name_External_Name
,
14097 Check_At_Least_N_Arguments
(2);
14098 Check_At_Most_N_Arguments
(4);
14100 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14101 -- pragma Export (Entity, "external name");
14103 if Relaxed_RM_Semantics
14104 and then Arg_Count
= 2
14105 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
14108 Def_Id
:= Get_Pragma_Arg
(Arg1
);
14111 if not Is_Entity_Name
(Def_Id
) then
14112 Error_Pragma_Arg
("entity name required", Arg1
);
14115 Def_Id
:= Entity
(Def_Id
);
14116 Set_Exported
(Def_Id
, Arg1
);
14119 Process_Convention
(C
, Def_Id
);
14121 -- A pragma that applies to a Ghost entity becomes Ghost for
14122 -- the purposes of legality checks and removal of ignored Ghost
14125 Mark_Pragma_As_Ghost
(N
, Def_Id
);
14127 if Ekind
(Def_Id
) /= E_Constant
then
14128 Note_Possible_Modification
14129 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14132 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14133 Set_Exported
(Def_Id
, Arg2
);
14136 -- If the entity is a deferred constant, propagate the information
14137 -- to the full view, because gigi elaborates the full view only.
14139 if Ekind
(Def_Id
) = E_Constant
14140 and then Present
(Full_View
(Def_Id
))
14143 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
14145 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
14146 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
14147 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
14152 ---------------------
14153 -- Export_Function --
14154 ---------------------
14156 -- pragma Export_Function (
14157 -- [Internal =>] LOCAL_NAME
14158 -- [, [External =>] EXTERNAL_SYMBOL]
14159 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14160 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14161 -- [, [Mechanism =>] MECHANISM]
14162 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14164 -- EXTERNAL_SYMBOL ::=
14166 -- | static_string_EXPRESSION
14168 -- PARAMETER_TYPES ::=
14170 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14172 -- TYPE_DESIGNATOR ::=
14174 -- | subtype_Name ' Access
14178 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14180 -- MECHANISM_ASSOCIATION ::=
14181 -- [formal_parameter_NAME =>] MECHANISM_NAME
14183 -- MECHANISM_NAME ::=
14187 when Pragma_Export_Function
=> Export_Function
: declare
14188 Args
: Args_List
(1 .. 6);
14189 Names
: constant Name_List
(1 .. 6) := (
14192 Name_Parameter_Types
,
14195 Name_Result_Mechanism
);
14197 Internal
: Node_Id
renames Args
(1);
14198 External
: Node_Id
renames Args
(2);
14199 Parameter_Types
: Node_Id
renames Args
(3);
14200 Result_Type
: Node_Id
renames Args
(4);
14201 Mechanism
: Node_Id
renames Args
(5);
14202 Result_Mechanism
: Node_Id
renames Args
(6);
14206 Gather_Associations
(Names
, Args
);
14207 Process_Extended_Import_Export_Subprogram_Pragma
(
14208 Arg_Internal
=> Internal
,
14209 Arg_External
=> External
,
14210 Arg_Parameter_Types
=> Parameter_Types
,
14211 Arg_Result_Type
=> Result_Type
,
14212 Arg_Mechanism
=> Mechanism
,
14213 Arg_Result_Mechanism
=> Result_Mechanism
);
14214 end Export_Function
;
14216 -------------------
14217 -- Export_Object --
14218 -------------------
14220 -- pragma Export_Object (
14221 -- [Internal =>] LOCAL_NAME
14222 -- [, [External =>] EXTERNAL_SYMBOL]
14223 -- [, [Size =>] EXTERNAL_SYMBOL]);
14225 -- EXTERNAL_SYMBOL ::=
14227 -- | static_string_EXPRESSION
14229 -- PARAMETER_TYPES ::=
14231 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14233 -- TYPE_DESIGNATOR ::=
14235 -- | subtype_Name ' Access
14239 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14241 -- MECHANISM_ASSOCIATION ::=
14242 -- [formal_parameter_NAME =>] MECHANISM_NAME
14244 -- MECHANISM_NAME ::=
14248 when Pragma_Export_Object
=> Export_Object
: declare
14249 Args
: Args_List
(1 .. 3);
14250 Names
: constant Name_List
(1 .. 3) := (
14255 Internal
: Node_Id
renames Args
(1);
14256 External
: Node_Id
renames Args
(2);
14257 Size
: Node_Id
renames Args
(3);
14261 Gather_Associations
(Names
, Args
);
14262 Process_Extended_Import_Export_Object_Pragma
(
14263 Arg_Internal
=> Internal
,
14264 Arg_External
=> External
,
14268 ----------------------
14269 -- Export_Procedure --
14270 ----------------------
14272 -- pragma Export_Procedure (
14273 -- [Internal =>] LOCAL_NAME
14274 -- [, [External =>] EXTERNAL_SYMBOL]
14275 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14276 -- [, [Mechanism =>] MECHANISM]);
14278 -- EXTERNAL_SYMBOL ::=
14280 -- | static_string_EXPRESSION
14282 -- PARAMETER_TYPES ::=
14284 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14286 -- TYPE_DESIGNATOR ::=
14288 -- | subtype_Name ' Access
14292 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14294 -- MECHANISM_ASSOCIATION ::=
14295 -- [formal_parameter_NAME =>] MECHANISM_NAME
14297 -- MECHANISM_NAME ::=
14301 when Pragma_Export_Procedure
=> Export_Procedure
: declare
14302 Args
: Args_List
(1 .. 4);
14303 Names
: constant Name_List
(1 .. 4) := (
14306 Name_Parameter_Types
,
14309 Internal
: Node_Id
renames Args
(1);
14310 External
: Node_Id
renames Args
(2);
14311 Parameter_Types
: Node_Id
renames Args
(3);
14312 Mechanism
: Node_Id
renames Args
(4);
14316 Gather_Associations
(Names
, Args
);
14317 Process_Extended_Import_Export_Subprogram_Pragma
(
14318 Arg_Internal
=> Internal
,
14319 Arg_External
=> External
,
14320 Arg_Parameter_Types
=> Parameter_Types
,
14321 Arg_Mechanism
=> Mechanism
);
14322 end Export_Procedure
;
14328 -- pragma Export_Value (
14329 -- [Value =>] static_integer_EXPRESSION,
14330 -- [Link_Name =>] static_string_EXPRESSION);
14332 when Pragma_Export_Value
=>
14334 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
14335 Check_Arg_Count
(2);
14337 Check_Optional_Identifier
(Arg1
, Name_Value
);
14338 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
14340 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
14341 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
14343 -----------------------------
14344 -- Export_Valued_Procedure --
14345 -----------------------------
14347 -- pragma Export_Valued_Procedure (
14348 -- [Internal =>] LOCAL_NAME
14349 -- [, [External =>] EXTERNAL_SYMBOL,]
14350 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14351 -- [, [Mechanism =>] MECHANISM]);
14353 -- EXTERNAL_SYMBOL ::=
14355 -- | static_string_EXPRESSION
14357 -- PARAMETER_TYPES ::=
14359 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14361 -- TYPE_DESIGNATOR ::=
14363 -- | subtype_Name ' Access
14367 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14369 -- MECHANISM_ASSOCIATION ::=
14370 -- [formal_parameter_NAME =>] MECHANISM_NAME
14372 -- MECHANISM_NAME ::=
14376 when Pragma_Export_Valued_Procedure
=>
14377 Export_Valued_Procedure
: declare
14378 Args
: Args_List
(1 .. 4);
14379 Names
: constant Name_List
(1 .. 4) := (
14382 Name_Parameter_Types
,
14385 Internal
: Node_Id
renames Args
(1);
14386 External
: Node_Id
renames Args
(2);
14387 Parameter_Types
: Node_Id
renames Args
(3);
14388 Mechanism
: Node_Id
renames Args
(4);
14392 Gather_Associations
(Names
, Args
);
14393 Process_Extended_Import_Export_Subprogram_Pragma
(
14394 Arg_Internal
=> Internal
,
14395 Arg_External
=> External
,
14396 Arg_Parameter_Types
=> Parameter_Types
,
14397 Arg_Mechanism
=> Mechanism
);
14398 end Export_Valued_Procedure
;
14400 -------------------
14401 -- Extend_System --
14402 -------------------
14404 -- pragma Extend_System ([Name =>] Identifier);
14406 when Pragma_Extend_System
=> Extend_System
: declare
14409 Check_Valid_Configuration_Pragma
;
14410 Check_Arg_Count
(1);
14411 Check_Optional_Identifier
(Arg1
, Name_Name
);
14412 Check_Arg_Is_Identifier
(Arg1
);
14414 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14417 and then Name_Buffer
(1 .. 4) = "aux_"
14419 if Present
(System_Extend_Pragma_Arg
) then
14420 if Chars
(Get_Pragma_Arg
(Arg1
)) =
14421 Chars
(Expression
(System_Extend_Pragma_Arg
))
14425 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
14426 Error_Pragma
("pragma% conflicts with that #");
14430 System_Extend_Pragma_Arg
:= Arg1
;
14432 if not GNAT_Mode
then
14433 System_Extend_Unit
:= Arg1
;
14437 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
14441 ------------------------
14442 -- Extensions_Allowed --
14443 ------------------------
14445 -- pragma Extensions_Allowed (ON | OFF);
14447 when Pragma_Extensions_Allowed
=>
14449 Check_Arg_Count
(1);
14450 Check_No_Identifiers
;
14451 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
14453 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
14454 Extensions_Allowed
:= True;
14455 Ada_Version
:= Ada_Version_Type
'Last;
14458 Extensions_Allowed
:= False;
14459 Ada_Version
:= Ada_Version_Explicit
;
14460 Ada_Version_Pragma
:= Empty
;
14463 ------------------------
14464 -- Extensions_Visible --
14465 ------------------------
14467 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14469 -- Characteristics:
14471 -- * Analysis - The annotation is fully analyzed immediately upon
14472 -- elaboration as its expression must be static.
14474 -- * Expansion - None.
14476 -- * Template - The annotation utilizes the generic template of the
14477 -- related subprogram [body] when it is:
14479 -- aspect on subprogram declaration
14480 -- aspect on stand alone subprogram body
14481 -- pragma on stand alone subprogram body
14483 -- The annotation must prepare its own template when it is:
14485 -- pragma on subprogram declaration
14487 -- * Globals - Capture of global references must occur after full
14490 -- * Instance - The annotation is instantiated automatically when
14491 -- the related generic subprogram [body] is instantiated except for
14492 -- the "pragma on subprogram declaration" case. In that scenario
14493 -- the annotation must instantiate itself.
14495 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
14496 Formal
: Entity_Id
;
14497 Has_OK_Formal
: Boolean := False;
14498 Spec_Id
: Entity_Id
;
14499 Subp_Decl
: Node_Id
;
14503 Check_No_Identifiers
;
14504 Check_At_Most_N_Arguments
(1);
14507 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
14509 -- Abstract subprogram declaration
14511 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
14514 -- Generic subprogram declaration
14516 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
14519 -- Body acts as spec
14521 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14522 and then No
(Corresponding_Spec
(Subp_Decl
))
14526 -- Body stub acts as spec
14528 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14529 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14533 -- Subprogram declaration
14535 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14538 -- Otherwise the pragma is associated with an illegal construct
14541 Error_Pragma
("pragma % must apply to a subprogram");
14545 -- Chain the pragma on the contract for completeness
14547 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14549 -- The legality checks of pragma Extension_Visible are affected
14550 -- by the SPARK mode in effect. Analyze all pragmas in specific
14553 Analyze_If_Present
(Pragma_SPARK_Mode
);
14555 -- Mark the pragma as Ghost if the related subprogram is also
14556 -- Ghost. This also ensures that any expansion performed further
14557 -- below will produce Ghost nodes.
14559 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
14560 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
14562 -- Examine the formals of the related subprogram
14564 Formal
:= First_Formal
(Spec_Id
);
14565 while Present
(Formal
) loop
14567 -- At least one of the formals is of a specific tagged type,
14568 -- the pragma is legal.
14570 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
14571 Has_OK_Formal
:= True;
14574 -- A generic subprogram with at least one formal of a private
14575 -- type ensures the legality of the pragma because the actual
14576 -- may be specifically tagged. Note that this is verified by
14577 -- the check above at instantiation time.
14579 elsif Is_Private_Type
(Etype
(Formal
))
14580 and then Is_Generic_Type
(Etype
(Formal
))
14582 Has_OK_Formal
:= True;
14586 Next_Formal
(Formal
);
14589 if not Has_OK_Formal
then
14590 Error_Msg_Name_1
:= Pname
;
14591 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
14593 ("\subprogram & lacks parameter of specific tagged or "
14594 & "generic private type", N
, Spec_Id
);
14599 -- Analyze the Boolean expression (if any)
14601 if Present
(Arg1
) then
14602 Check_Static_Boolean_Expression
14603 (Expression
(Get_Argument
(N
, Spec_Id
)));
14605 end Extensions_Visible
;
14611 -- pragma External (
14612 -- [ Convention =>] convention_IDENTIFIER,
14613 -- [ Entity =>] LOCAL_NAME
14614 -- [, [External_Name =>] static_string_EXPRESSION ]
14615 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14617 when Pragma_External
=> External
: declare
14620 pragma Warnings
(Off
, C
);
14627 Name_External_Name
,
14629 Check_At_Least_N_Arguments
(2);
14630 Check_At_Most_N_Arguments
(4);
14631 Process_Convention
(C
, E
);
14633 -- A pragma that applies to a Ghost entity becomes Ghost for the
14634 -- purposes of legality checks and removal of ignored Ghost code.
14636 Mark_Pragma_As_Ghost
(N
, E
);
14638 Note_Possible_Modification
14639 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14640 Process_Interface_Name
(E
, Arg3
, Arg4
);
14641 Set_Exported
(E
, Arg2
);
14644 --------------------------
14645 -- External_Name_Casing --
14646 --------------------------
14648 -- pragma External_Name_Casing (
14649 -- UPPERCASE | LOWERCASE
14650 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14652 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
14655 Check_No_Identifiers
;
14657 if Arg_Count
= 2 then
14658 Check_Arg_Is_One_Of
14659 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
14661 case Chars
(Get_Pragma_Arg
(Arg2
)) is
14663 Opt
.External_Name_Exp_Casing
:= As_Is
;
14665 when Name_Uppercase
=>
14666 Opt
.External_Name_Exp_Casing
:= Uppercase
;
14668 when Name_Lowercase
=>
14669 Opt
.External_Name_Exp_Casing
:= Lowercase
;
14676 Check_Arg_Count
(1);
14679 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
14681 case Chars
(Get_Pragma_Arg
(Arg1
)) is
14682 when Name_Uppercase
=>
14683 Opt
.External_Name_Imp_Casing
:= Uppercase
;
14685 when Name_Lowercase
=>
14686 Opt
.External_Name_Imp_Casing
:= Lowercase
;
14691 end External_Name_Casing
;
14697 -- pragma Fast_Math;
14699 when Pragma_Fast_Math
=>
14701 Check_No_Identifiers
;
14702 Check_Valid_Configuration_Pragma
;
14705 --------------------------
14706 -- Favor_Top_Level --
14707 --------------------------
14709 -- pragma Favor_Top_Level (type_NAME);
14711 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
14716 Check_No_Identifiers
;
14717 Check_Arg_Count
(1);
14718 Check_Arg_Is_Local_Name
(Arg1
);
14719 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
14721 -- A pragma that applies to a Ghost entity becomes Ghost for the
14722 -- purposes of legality checks and removal of ignored Ghost code.
14724 Mark_Pragma_As_Ghost
(N
, Typ
);
14726 -- If it's an access-to-subprogram type (in particular, not a
14727 -- subtype), set the flag on that type.
14729 if Is_Access_Subprogram_Type
(Typ
) then
14730 Set_Can_Use_Internal_Rep
(Typ
, False);
14732 -- Otherwise it's an error (name denotes the wrong sort of entity)
14736 ("access-to-subprogram type expected",
14737 Get_Pragma_Arg
(Arg1
));
14739 end Favor_Top_Level
;
14741 ---------------------------
14742 -- Finalize_Storage_Only --
14743 ---------------------------
14745 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14747 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14748 Assoc
: constant Node_Id
:= Arg1
;
14749 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14754 Check_No_Identifiers
;
14755 Check_Arg_Count
(1);
14756 Check_Arg_Is_Local_Name
(Arg1
);
14758 Find_Type
(Type_Id
);
14759 Typ
:= Entity
(Type_Id
);
14762 or else Rep_Item_Too_Early
(Typ
, N
)
14766 Typ
:= Underlying_Type
(Typ
);
14769 if not Is_Controlled
(Typ
) then
14770 Error_Pragma
("pragma% must specify controlled type");
14773 Check_First_Subtype
(Arg1
);
14775 if Finalize_Storage_Only
(Typ
) then
14776 Error_Pragma
("duplicate pragma%, only one allowed");
14778 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14779 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14781 end Finalize_Storage
;
14787 -- pragma Ghost [ (boolean_EXPRESSION) ];
14789 when Pragma_Ghost
=> Ghost
: declare
14793 Orig_Stmt
: Node_Id
;
14794 Prev_Id
: Entity_Id
;
14799 Check_No_Identifiers
;
14800 Check_At_Most_N_Arguments
(1);
14804 while Present
(Stmt
) loop
14806 -- Skip prior pragmas, but check for duplicates
14808 if Nkind
(Stmt
) = N_Pragma
then
14809 if Pragma_Name
(Stmt
) = Pname
then
14810 Error_Msg_Name_1
:= Pname
;
14811 Error_Msg_Sloc
:= Sloc
(Stmt
);
14812 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
14815 -- Task unit declared without a definition cannot be subject to
14816 -- pragma Ghost (SPARK RM 6.9(19)).
14818 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
14819 N_Task_Type_Declaration
)
14821 Error_Pragma
("pragma % cannot apply to a task type");
14824 -- Skip internally generated code
14826 elsif not Comes_From_Source
(Stmt
) then
14827 Orig_Stmt
:= Original_Node
(Stmt
);
14829 -- When pragma Ghost applies to an untagged derivation, the
14830 -- derivation is transformed into a [sub]type declaration.
14832 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
14833 N_Subtype_Declaration
)
14834 and then Comes_From_Source
(Orig_Stmt
)
14835 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
14836 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
14837 N_Derived_Type_Definition
14839 Id
:= Defining_Entity
(Stmt
);
14842 -- When pragma Ghost applies to an expression function, the
14843 -- expression function is transformed into a subprogram.
14845 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
14846 and then Comes_From_Source
(Orig_Stmt
)
14847 and then Nkind
(Orig_Stmt
) = N_Expression_Function
14849 Id
:= Defining_Entity
(Stmt
);
14853 -- The pragma applies to a legal construct, stop the traversal
14855 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
14856 N_Full_Type_Declaration
,
14857 N_Generic_Subprogram_Declaration
,
14858 N_Object_Declaration
,
14859 N_Private_Extension_Declaration
,
14860 N_Private_Type_Declaration
,
14861 N_Subprogram_Declaration
,
14862 N_Subtype_Declaration
)
14864 Id
:= Defining_Entity
(Stmt
);
14867 -- The pragma does not apply to a legal construct, issue an
14868 -- error and stop the analysis.
14872 ("pragma % must apply to an object, package, subprogram "
14877 Stmt
:= Prev
(Stmt
);
14880 Context
:= Parent
(N
);
14882 -- Handle compilation units
14884 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
14885 Context
:= Unit
(Parent
(Context
));
14888 -- Protected and task types cannot be subject to pragma Ghost
14889 -- (SPARK RM 6.9(19)).
14891 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
14893 Error_Pragma
("pragma % cannot apply to a protected type");
14896 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
14897 Error_Pragma
("pragma % cannot apply to a task type");
14903 -- When pragma Ghost is associated with a [generic] package, it
14904 -- appears in the visible declarations.
14906 if Nkind
(Context
) = N_Package_Specification
14907 and then Present
(Visible_Declarations
(Context
))
14908 and then List_Containing
(N
) = Visible_Declarations
(Context
)
14910 Id
:= Defining_Entity
(Context
);
14912 -- Pragma Ghost applies to a stand alone subprogram body
14914 elsif Nkind
(Context
) = N_Subprogram_Body
14915 and then No
(Corresponding_Spec
(Context
))
14917 Id
:= Defining_Entity
(Context
);
14923 ("pragma % must apply to an object, package, subprogram or "
14928 -- A derived type or type extension cannot be subject to pragma
14929 -- Ghost if either the parent type or one of the progenitor types
14930 -- is not Ghost (SPARK RM 6.9(9)).
14932 if Is_Derived_Type
(Id
) then
14933 Check_Ghost_Derivation
(Id
);
14936 -- Handle completions of types and constants that are subject to
14939 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
14940 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
14942 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
14943 Error_Msg_Name_1
:= Pname
;
14945 -- The full declaration of a deferred constant cannot be
14946 -- subject to pragma Ghost unless the deferred declaration
14947 -- is also Ghost (SPARK RM 6.9(10)).
14949 if Ekind
(Prev_Id
) = E_Constant
then
14950 Error_Msg_Name_1
:= Pname
;
14951 Error_Msg_NE
(Fix_Error
14952 ("pragma % must apply to declaration of deferred "
14953 & "constant &"), N
, Id
);
14956 -- Pragma Ghost may appear on the full view of an incomplete
14957 -- type because the incomplete declaration lacks aspects and
14958 -- cannot be subject to pragma Ghost.
14960 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
14963 -- The full declaration of a type cannot be subject to
14964 -- pragma Ghost unless the partial view is also Ghost
14965 -- (SPARK RM 6.9(10)).
14968 Error_Msg_NE
(Fix_Error
14969 ("pragma % must apply to partial view of type &"),
14975 -- A synchronized object cannot be subject to pragma Ghost
14976 -- (SPARK RM 6.9(19)).
14978 elsif Ekind
(Id
) = E_Variable
then
14979 if Is_Protected_Type
(Etype
(Id
)) then
14980 Error_Pragma
("pragma % cannot apply to a protected object");
14983 elsif Is_Task_Type
(Etype
(Id
)) then
14984 Error_Pragma
("pragma % cannot apply to a task object");
14989 -- Analyze the Boolean expression (if any)
14991 if Present
(Arg1
) then
14992 Expr
:= Get_Pragma_Arg
(Arg1
);
14994 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14996 if Is_OK_Static_Expression
(Expr
) then
14998 -- "Ghostness" cannot be turned off once enabled within a
14999 -- region (SPARK RM 6.9(7)).
15001 if Is_False
(Expr_Value
(Expr
))
15002 and then Ghost_Mode
> None
15005 ("pragma % with value False cannot appear in enabled "
15010 -- Otherwie the expression is not static
15014 ("expression of pragma % must be static", Expr
);
15019 Set_Is_Ghost_Entity
(Id
);
15026 -- pragma Global (GLOBAL_SPECIFICATION);
15028 -- GLOBAL_SPECIFICATION ::=
15031 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15033 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15035 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15036 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15037 -- GLOBAL_ITEM ::= NAME
15039 -- Characteristics:
15041 -- * Analysis - The annotation undergoes initial checks to verify
15042 -- the legal placement and context. Secondary checks fully analyze
15043 -- the dependency clauses in:
15045 -- Analyze_Global_In_Decl_Part
15047 -- * Expansion - None.
15049 -- * Template - The annotation utilizes the generic template of the
15050 -- related subprogram [body] when it is:
15052 -- aspect on subprogram declaration
15053 -- aspect on stand alone subprogram body
15054 -- pragma on stand alone subprogram body
15056 -- The annotation must prepare its own template when it is:
15058 -- pragma on subprogram declaration
15060 -- * Globals - Capture of global references must occur after full
15063 -- * Instance - The annotation is instantiated automatically when
15064 -- the related generic subprogram [body] is instantiated except for
15065 -- the "pragma on subprogram declaration" case. In that scenario
15066 -- the annotation must instantiate itself.
15068 when Pragma_Global
=> Global
: declare
15070 Spec_Id
: Entity_Id
;
15071 Subp_Decl
: Node_Id
;
15074 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
15078 -- Chain the pragma on the contract for further processing by
15079 -- Analyze_Global_In_Decl_Part.
15081 Add_Contract_Item
(N
, Spec_Id
);
15083 -- Fully analyze the pragma when it appears inside an entry
15084 -- or subprogram body because it cannot benefit from forward
15087 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
15089 N_Subprogram_Body_Stub
)
15091 -- The legality checks of pragmas Depends and Global are
15092 -- affected by the SPARK mode in effect and the volatility
15093 -- of the context. In addition these two pragmas are subject
15094 -- to an inherent order:
15099 -- Analyze all these pragmas in the order outlined above
15101 Analyze_If_Present
(Pragma_SPARK_Mode
);
15102 Analyze_If_Present
(Pragma_Volatile_Function
);
15103 Analyze_Global_In_Decl_Part
(N
);
15104 Analyze_If_Present
(Pragma_Depends
);
15113 -- pragma Ident (static_string_EXPRESSION)
15115 -- Note: pragma Comment shares this processing. Pragma Ident is
15116 -- identical in effect to pragma Commment.
15118 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
15123 Check_Arg_Count
(1);
15124 Check_No_Identifiers
;
15125 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15128 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
15135 GP
:= Parent
(Parent
(N
));
15137 if Nkind_In
(GP
, N_Package_Declaration
,
15138 N_Generic_Package_Declaration
)
15143 -- If we have a compilation unit, then record the ident value,
15144 -- checking for improper duplication.
15146 if Nkind
(GP
) = N_Compilation_Unit
then
15147 CS
:= Ident_String
(Current_Sem_Unit
);
15149 if Present
(CS
) then
15151 -- If we have multiple instances, concatenate them, but
15152 -- not in ASIS, where we want the original tree.
15154 if not ASIS_Mode
then
15155 Start_String
(Strval
(CS
));
15156 Store_String_Char
(' ');
15157 Store_String_Chars
(Strval
(Str
));
15158 Set_Strval
(CS
, End_String
);
15162 Set_Ident_String
(Current_Sem_Unit
, Str
);
15165 -- For subunits, we just ignore the Ident, since in GNAT these
15166 -- are not separate object files, and hence not separate units
15167 -- in the unit table.
15169 elsif Nkind
(GP
) = N_Subunit
then
15175 -------------------
15176 -- Ignore_Pragma --
15177 -------------------
15179 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15181 -- Entirely handled in the parser, nothing to do here
15183 when Pragma_Ignore_Pragma
=>
15186 ----------------------------
15187 -- Implementation_Defined --
15188 ----------------------------
15190 -- pragma Implementation_Defined (LOCAL_NAME);
15192 -- Marks previously declared entity as implementation defined. For
15193 -- an overloaded entity, applies to the most recent homonym.
15195 -- pragma Implementation_Defined;
15197 -- The form with no arguments appears anywhere within a scope, most
15198 -- typically a package spec, and indicates that all entities that are
15199 -- defined within the package spec are Implementation_Defined.
15201 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
15206 Check_No_Identifiers
;
15208 -- Form with no arguments
15210 if Arg_Count
= 0 then
15211 Set_Is_Implementation_Defined
(Current_Scope
);
15213 -- Form with one argument
15216 Check_Arg_Count
(1);
15217 Check_Arg_Is_Local_Name
(Arg1
);
15218 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
15219 Set_Is_Implementation_Defined
(Ent
);
15221 end Implementation_Defined
;
15227 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15229 -- IMPLEMENTATION_KIND ::=
15230 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15232 -- "By_Any" and "Optional" are treated as synonyms in order to
15233 -- support Ada 2012 aspect Synchronization.
15235 when Pragma_Implemented
=> Implemented
: declare
15236 Proc_Id
: Entity_Id
;
15241 Check_Arg_Count
(2);
15242 Check_No_Identifiers
;
15243 Check_Arg_Is_Identifier
(Arg1
);
15244 Check_Arg_Is_Local_Name
(Arg1
);
15245 Check_Arg_Is_One_Of
(Arg2
,
15248 Name_By_Protected_Procedure
,
15251 -- Extract the name of the local procedure
15253 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
15255 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15256 -- primitive procedure of a synchronized tagged type.
15258 if Ekind
(Proc_Id
) = E_Procedure
15259 and then Is_Primitive
(Proc_Id
)
15260 and then Present
(First_Formal
(Proc_Id
))
15262 Typ
:= Etype
(First_Formal
(Proc_Id
));
15264 if Is_Tagged_Type
(Typ
)
15267 -- Check for a protected, a synchronized or a task interface
15269 ((Is_Interface
(Typ
)
15270 and then Is_Synchronized_Interface
(Typ
))
15272 -- Check for a protected type or a task type that implements
15276 (Is_Concurrent_Record_Type
(Typ
)
15277 and then Present
(Interfaces
(Typ
)))
15279 -- In analysis-only mode, examine original protected type
15282 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
15283 and then Present
(Interface_List
(Parent
(Typ
))))
15285 -- Check for a private record extension with keyword
15289 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
15290 E_Record_Subtype_With_Private
)
15291 and then Synchronized_Present
(Parent
(Typ
))))
15296 ("controlling formal must be of synchronized tagged type",
15301 -- Procedures declared inside a protected type must be accepted
15303 elsif Ekind
(Proc_Id
) = E_Procedure
15304 and then Is_Protected_Type
(Scope
(Proc_Id
))
15308 -- The first argument is not a primitive procedure
15312 ("pragma % must be applied to a primitive procedure", Arg1
);
15316 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15317 -- By_Protected_Procedure to the primitive procedure of a task
15320 if Chars
(Arg2
) = Name_By_Protected_Procedure
15321 and then Is_Interface
(Typ
)
15322 and then Is_Task_Interface
(Typ
)
15325 ("implementation kind By_Protected_Procedure cannot be "
15326 & "applied to a task interface primitive", Arg2
);
15330 Record_Rep_Item
(Proc_Id
, N
);
15333 ----------------------
15334 -- Implicit_Packing --
15335 ----------------------
15337 -- pragma Implicit_Packing;
15339 when Pragma_Implicit_Packing
=>
15341 Check_Arg_Count
(0);
15342 Implicit_Packing
:= True;
15349 -- [Convention =>] convention_IDENTIFIER,
15350 -- [Entity =>] LOCAL_NAME
15351 -- [, [External_Name =>] static_string_EXPRESSION ]
15352 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15354 when Pragma_Import
=>
15355 Check_Ada_83_Warning
;
15359 Name_External_Name
,
15362 Check_At_Least_N_Arguments
(2);
15363 Check_At_Most_N_Arguments
(4);
15364 Process_Import_Or_Interface
;
15366 ---------------------
15367 -- Import_Function --
15368 ---------------------
15370 -- pragma Import_Function (
15371 -- [Internal =>] LOCAL_NAME,
15372 -- [, [External =>] EXTERNAL_SYMBOL]
15373 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15374 -- [, [Result_Type =>] SUBTYPE_MARK]
15375 -- [, [Mechanism =>] MECHANISM]
15376 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15378 -- EXTERNAL_SYMBOL ::=
15380 -- | static_string_EXPRESSION
15382 -- PARAMETER_TYPES ::=
15384 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15386 -- TYPE_DESIGNATOR ::=
15388 -- | subtype_Name ' Access
15392 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15394 -- MECHANISM_ASSOCIATION ::=
15395 -- [formal_parameter_NAME =>] MECHANISM_NAME
15397 -- MECHANISM_NAME ::=
15401 when Pragma_Import_Function
=> Import_Function
: declare
15402 Args
: Args_List
(1 .. 6);
15403 Names
: constant Name_List
(1 .. 6) := (
15406 Name_Parameter_Types
,
15409 Name_Result_Mechanism
);
15411 Internal
: Node_Id
renames Args
(1);
15412 External
: Node_Id
renames Args
(2);
15413 Parameter_Types
: Node_Id
renames Args
(3);
15414 Result_Type
: Node_Id
renames Args
(4);
15415 Mechanism
: Node_Id
renames Args
(5);
15416 Result_Mechanism
: Node_Id
renames Args
(6);
15420 Gather_Associations
(Names
, Args
);
15421 Process_Extended_Import_Export_Subprogram_Pragma
(
15422 Arg_Internal
=> Internal
,
15423 Arg_External
=> External
,
15424 Arg_Parameter_Types
=> Parameter_Types
,
15425 Arg_Result_Type
=> Result_Type
,
15426 Arg_Mechanism
=> Mechanism
,
15427 Arg_Result_Mechanism
=> Result_Mechanism
);
15428 end Import_Function
;
15430 -------------------
15431 -- Import_Object --
15432 -------------------
15434 -- pragma Import_Object (
15435 -- [Internal =>] LOCAL_NAME
15436 -- [, [External =>] EXTERNAL_SYMBOL]
15437 -- [, [Size =>] EXTERNAL_SYMBOL]);
15439 -- EXTERNAL_SYMBOL ::=
15441 -- | static_string_EXPRESSION
15443 when Pragma_Import_Object
=> Import_Object
: declare
15444 Args
: Args_List
(1 .. 3);
15445 Names
: constant Name_List
(1 .. 3) := (
15450 Internal
: Node_Id
renames Args
(1);
15451 External
: Node_Id
renames Args
(2);
15452 Size
: Node_Id
renames Args
(3);
15456 Gather_Associations
(Names
, Args
);
15457 Process_Extended_Import_Export_Object_Pragma
(
15458 Arg_Internal
=> Internal
,
15459 Arg_External
=> External
,
15463 ----------------------
15464 -- Import_Procedure --
15465 ----------------------
15467 -- pragma Import_Procedure (
15468 -- [Internal =>] LOCAL_NAME
15469 -- [, [External =>] EXTERNAL_SYMBOL]
15470 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15471 -- [, [Mechanism =>] MECHANISM]);
15473 -- EXTERNAL_SYMBOL ::=
15475 -- | static_string_EXPRESSION
15477 -- PARAMETER_TYPES ::=
15479 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15481 -- TYPE_DESIGNATOR ::=
15483 -- | subtype_Name ' Access
15487 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15489 -- MECHANISM_ASSOCIATION ::=
15490 -- [formal_parameter_NAME =>] MECHANISM_NAME
15492 -- MECHANISM_NAME ::=
15496 when Pragma_Import_Procedure
=> Import_Procedure
: declare
15497 Args
: Args_List
(1 .. 4);
15498 Names
: constant Name_List
(1 .. 4) := (
15501 Name_Parameter_Types
,
15504 Internal
: Node_Id
renames Args
(1);
15505 External
: Node_Id
renames Args
(2);
15506 Parameter_Types
: Node_Id
renames Args
(3);
15507 Mechanism
: Node_Id
renames Args
(4);
15511 Gather_Associations
(Names
, Args
);
15512 Process_Extended_Import_Export_Subprogram_Pragma
(
15513 Arg_Internal
=> Internal
,
15514 Arg_External
=> External
,
15515 Arg_Parameter_Types
=> Parameter_Types
,
15516 Arg_Mechanism
=> Mechanism
);
15517 end Import_Procedure
;
15519 -----------------------------
15520 -- Import_Valued_Procedure --
15521 -----------------------------
15523 -- pragma Import_Valued_Procedure (
15524 -- [Internal =>] LOCAL_NAME
15525 -- [, [External =>] EXTERNAL_SYMBOL]
15526 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15527 -- [, [Mechanism =>] MECHANISM]);
15529 -- EXTERNAL_SYMBOL ::=
15531 -- | static_string_EXPRESSION
15533 -- PARAMETER_TYPES ::=
15535 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15537 -- TYPE_DESIGNATOR ::=
15539 -- | subtype_Name ' Access
15543 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15545 -- MECHANISM_ASSOCIATION ::=
15546 -- [formal_parameter_NAME =>] MECHANISM_NAME
15548 -- MECHANISM_NAME ::=
15552 when Pragma_Import_Valued_Procedure
=>
15553 Import_Valued_Procedure
: declare
15554 Args
: Args_List
(1 .. 4);
15555 Names
: constant Name_List
(1 .. 4) := (
15558 Name_Parameter_Types
,
15561 Internal
: Node_Id
renames Args
(1);
15562 External
: Node_Id
renames Args
(2);
15563 Parameter_Types
: Node_Id
renames Args
(3);
15564 Mechanism
: Node_Id
renames Args
(4);
15568 Gather_Associations
(Names
, Args
);
15569 Process_Extended_Import_Export_Subprogram_Pragma
(
15570 Arg_Internal
=> Internal
,
15571 Arg_External
=> External
,
15572 Arg_Parameter_Types
=> Parameter_Types
,
15573 Arg_Mechanism
=> Mechanism
);
15574 end Import_Valued_Procedure
;
15580 -- pragma Independent (LOCAL_NAME);
15582 when Pragma_Independent
=>
15583 Process_Atomic_Independent_Shared_Volatile
;
15585 ----------------------------
15586 -- Independent_Components --
15587 ----------------------------
15589 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
15591 when Pragma_Independent_Components
=> Independent_Components
: declare
15599 Check_Ada_83_Warning
;
15601 Check_No_Identifiers
;
15602 Check_Arg_Count
(1);
15603 Check_Arg_Is_Local_Name
(Arg1
);
15604 E_Id
:= Get_Pragma_Arg
(Arg1
);
15606 if Etype
(E_Id
) = Any_Type
then
15610 E
:= Entity
(E_Id
);
15612 -- A pragma that applies to a Ghost entity becomes Ghost for the
15613 -- purposes of legality checks and removal of ignored Ghost code.
15615 Mark_Pragma_As_Ghost
(N
, E
);
15617 -- Check duplicate before we chain ourselves
15619 Check_Duplicate_Pragma
(E
);
15621 -- Check appropriate entity
15623 if Rep_Item_Too_Early
(E
, N
)
15625 Rep_Item_Too_Late
(E
, N
)
15630 D
:= Declaration_Node
(E
);
15633 -- The flag is set on the base type, or on the object
15635 if K
= N_Full_Type_Declaration
15636 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
15638 Set_Has_Independent_Components
(Base_Type
(E
));
15639 Record_Independence_Check
(N
, Base_Type
(E
));
15641 -- For record type, set all components independent
15643 if Is_Record_Type
(E
) then
15644 C
:= First_Component
(E
);
15645 while Present
(C
) loop
15646 Set_Is_Independent
(C
);
15647 Next_Component
(C
);
15651 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
15652 and then Nkind
(D
) = N_Object_Declaration
15653 and then Nkind
(Object_Definition
(D
)) =
15654 N_Constrained_Array_Definition
15656 Set_Has_Independent_Components
(E
);
15657 Record_Independence_Check
(N
, E
);
15660 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
15662 end Independent_Components
;
15664 -----------------------
15665 -- Initial_Condition --
15666 -----------------------
15668 -- pragma Initial_Condition (boolean_EXPRESSION);
15670 -- Characteristics:
15672 -- * Analysis - The annotation undergoes initial checks to verify
15673 -- the legal placement and context. Secondary checks preanalyze the
15676 -- Analyze_Initial_Condition_In_Decl_Part
15678 -- * Expansion - The annotation is expanded during the expansion of
15679 -- the package body whose declaration is subject to the annotation
15682 -- Expand_Pragma_Initial_Condition
15684 -- * Template - The annotation utilizes the generic template of the
15685 -- related package declaration.
15687 -- * Globals - Capture of global references must occur after full
15690 -- * Instance - The annotation is instantiated automatically when
15691 -- the related generic package is instantiated.
15693 when Pragma_Initial_Condition
=> Initial_Condition
: declare
15694 Pack_Decl
: Node_Id
;
15695 Pack_Id
: Entity_Id
;
15699 Check_No_Identifiers
;
15700 Check_Arg_Count
(1);
15702 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
15704 -- Ensure the proper placement of the pragma. Initial_Condition
15705 -- must be associated with a package declaration.
15707 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
15708 N_Package_Declaration
)
15712 -- Otherwise the pragma is associated with an illegal context
15719 Pack_Id
:= Defining_Entity
(Pack_Decl
);
15721 -- Chain the pragma on the contract for further processing by
15722 -- Analyze_Initial_Condition_In_Decl_Part.
15724 Add_Contract_Item
(N
, Pack_Id
);
15726 -- The legality checks of pragmas Abstract_State, Initializes, and
15727 -- Initial_Condition are affected by the SPARK mode in effect. In
15728 -- addition, these three pragmas are subject to an inherent order:
15730 -- 1) Abstract_State
15732 -- 3) Initial_Condition
15734 -- Analyze all these pragmas in the order outlined above
15736 Analyze_If_Present
(Pragma_SPARK_Mode
);
15737 Analyze_If_Present
(Pragma_Abstract_State
);
15738 Analyze_If_Present
(Pragma_Initializes
);
15740 -- A pragma that applies to a Ghost entity becomes Ghost for the
15741 -- purposes of legality checks and removal of ignored Ghost code.
15743 Mark_Pragma_As_Ghost
(N
, Pack_Id
);
15744 end Initial_Condition
;
15746 ------------------------
15747 -- Initialize_Scalars --
15748 ------------------------
15750 -- pragma Initialize_Scalars;
15752 when Pragma_Initialize_Scalars
=>
15754 Check_Arg_Count
(0);
15755 Check_Valid_Configuration_Pragma
;
15756 Check_Restriction
(No_Initialize_Scalars
, N
);
15758 -- Initialize_Scalars creates false positives in CodePeer, and
15759 -- incorrect negative results in GNATprove mode, so ignore this
15760 -- pragma in these modes.
15762 if not Restriction_Active
(No_Initialize_Scalars
)
15763 and then not (CodePeer_Mode
or GNATprove_Mode
)
15765 Init_Or_Norm_Scalars
:= True;
15766 Initialize_Scalars
:= True;
15773 -- pragma Initializes (INITIALIZATION_LIST);
15775 -- INITIALIZATION_LIST ::=
15777 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15779 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15784 -- | (INPUT {, INPUT})
15788 -- Characteristics:
15790 -- * Analysis - The annotation undergoes initial checks to verify
15791 -- the legal placement and context. Secondary checks preanalyze the
15794 -- Analyze_Initializes_In_Decl_Part
15796 -- * Expansion - None.
15798 -- * Template - The annotation utilizes the generic template of the
15799 -- related package declaration.
15801 -- * Globals - Capture of global references must occur after full
15804 -- * Instance - The annotation is instantiated automatically when
15805 -- the related generic package is instantiated.
15807 when Pragma_Initializes
=> Initializes
: declare
15808 Pack_Decl
: Node_Id
;
15809 Pack_Id
: Entity_Id
;
15813 Check_No_Identifiers
;
15814 Check_Arg_Count
(1);
15816 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
15818 -- Ensure the proper placement of the pragma. Initializes must be
15819 -- associated with a package declaration.
15821 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
15822 N_Package_Declaration
)
15826 -- Otherwise the pragma is associated with an illegal construc
15833 Pack_Id
:= Defining_Entity
(Pack_Decl
);
15835 -- Chain the pragma on the contract for further processing by
15836 -- Analyze_Initializes_In_Decl_Part.
15838 Add_Contract_Item
(N
, Pack_Id
);
15840 -- The legality checks of pragmas Abstract_State, Initializes, and
15841 -- Initial_Condition are affected by the SPARK mode in effect. In
15842 -- addition, these three pragmas are subject to an inherent order:
15844 -- 1) Abstract_State
15846 -- 3) Initial_Condition
15848 -- Analyze all these pragmas in the order outlined above
15850 Analyze_If_Present
(Pragma_SPARK_Mode
);
15851 Analyze_If_Present
(Pragma_Abstract_State
);
15853 -- A pragma that applies to a Ghost entity becomes Ghost for the
15854 -- purposes of legality checks and removal of ignored Ghost code.
15856 Mark_Pragma_As_Ghost
(N
, Pack_Id
);
15857 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
15859 Analyze_If_Present
(Pragma_Initial_Condition
);
15866 -- pragma Inline ( NAME {, NAME} );
15868 when Pragma_Inline
=>
15870 -- Pragma always active unless in GNATprove mode. It is disabled
15871 -- in GNATprove mode because frontend inlining is applied
15872 -- independently of pragmas Inline and Inline_Always for
15873 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15876 if not GNATprove_Mode
then
15878 -- Inline status is Enabled if inlining option is active
15880 if Inline_Active
then
15881 Process_Inline
(Enabled
);
15883 Process_Inline
(Disabled
);
15887 -------------------
15888 -- Inline_Always --
15889 -------------------
15891 -- pragma Inline_Always ( NAME {, NAME} );
15893 when Pragma_Inline_Always
=>
15896 -- Pragma always active unless in CodePeer mode or GNATprove
15897 -- mode. It is disabled in CodePeer mode because inlining is
15898 -- not helpful, and enabling it caused walk order issues. It
15899 -- is disabled in GNATprove mode because frontend inlining is
15900 -- applied independently of pragmas Inline and Inline_Always for
15901 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15904 if not CodePeer_Mode
and not GNATprove_Mode
then
15905 Process_Inline
(Enabled
);
15908 --------------------
15909 -- Inline_Generic --
15910 --------------------
15912 -- pragma Inline_Generic (NAME {, NAME});
15914 when Pragma_Inline_Generic
=>
15916 Process_Generic_List
;
15918 ----------------------
15919 -- Inspection_Point --
15920 ----------------------
15922 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15924 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15931 if Arg_Count
> 0 then
15934 Exp
:= Get_Pragma_Arg
(Arg
);
15937 if not Is_Entity_Name
(Exp
)
15938 or else not Is_Object
(Entity
(Exp
))
15940 Error_Pragma_Arg
("object name required", Arg
);
15944 exit when No
(Arg
);
15947 end Inspection_Point
;
15953 -- pragma Interface (
15954 -- [ Convention =>] convention_IDENTIFIER,
15955 -- [ Entity =>] LOCAL_NAME
15956 -- [, [External_Name =>] static_string_EXPRESSION ]
15957 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15959 when Pragma_Interface
=>
15964 Name_External_Name
,
15966 Check_At_Least_N_Arguments
(2);
15967 Check_At_Most_N_Arguments
(4);
15968 Process_Import_Or_Interface
;
15970 -- In Ada 2005, the permission to use Interface (a reserved word)
15971 -- as a pragma name is considered an obsolescent feature, and this
15972 -- pragma was already obsolescent in Ada 95.
15974 if Ada_Version
>= Ada_95
then
15976 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15978 if Warn_On_Obsolescent_Feature
then
15980 ("pragma Interface is an obsolescent feature?j?", N
);
15982 ("|use pragma Import instead?j?", N
);
15986 --------------------
15987 -- Interface_Name --
15988 --------------------
15990 -- pragma Interface_Name (
15991 -- [ Entity =>] LOCAL_NAME
15992 -- [,[External_Name =>] static_string_EXPRESSION ]
15993 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15995 when Pragma_Interface_Name
=> Interface_Name
: declare
15997 Def_Id
: Entity_Id
;
15998 Hom_Id
: Entity_Id
;
16004 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
16005 Check_At_Least_N_Arguments
(2);
16006 Check_At_Most_N_Arguments
(3);
16007 Id
:= Get_Pragma_Arg
(Arg1
);
16010 -- This is obsolete from Ada 95 on, but it is an implementation
16011 -- defined pragma, so we do not consider that it violates the
16012 -- restriction (No_Obsolescent_Features).
16014 if Ada_Version
>= Ada_95
then
16015 if Warn_On_Obsolescent_Feature
then
16017 ("pragma Interface_Name is an obsolescent feature?j?", N
);
16019 ("|use pragma Import instead?j?", N
);
16023 if not Is_Entity_Name
(Id
) then
16025 ("first argument for pragma% must be entity name", Arg1
);
16026 elsif Etype
(Id
) = Any_Type
then
16029 Def_Id
:= Entity
(Id
);
16032 -- Special DEC-compatible processing for the object case, forces
16033 -- object to be imported.
16035 if Ekind
(Def_Id
) = E_Variable
then
16036 Kill_Size_Check_Code
(Def_Id
);
16037 Note_Possible_Modification
(Id
, Sure
=> False);
16039 -- Initialization is not allowed for imported variable
16041 if Present
(Expression
(Parent
(Def_Id
)))
16042 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
16044 Error_Msg_Sloc
:= Sloc
(Def_Id
);
16046 ("no initialization allowed for declaration of& #",
16050 -- For compatibility, support VADS usage of providing both
16051 -- pragmas Interface and Interface_Name to obtain the effect
16052 -- of a single Import pragma.
16054 if Is_Imported
(Def_Id
)
16055 and then Present
(First_Rep_Item
(Def_Id
))
16056 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
16058 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
16062 Set_Imported
(Def_Id
);
16065 Set_Is_Public
(Def_Id
);
16066 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
16069 -- Otherwise must be subprogram
16071 elsif not Is_Subprogram
(Def_Id
) then
16073 ("argument of pragma% is not subprogram", Arg1
);
16076 Check_At_Most_N_Arguments
(3);
16080 -- Loop through homonyms
16083 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
16085 if Is_Imported
(Def_Id
) then
16086 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
16090 exit when From_Aspect_Specification
(N
);
16091 Hom_Id
:= Homonym
(Hom_Id
);
16093 exit when No
(Hom_Id
)
16094 or else Scope
(Hom_Id
) /= Current_Scope
;
16099 ("argument of pragma% is not imported subprogram",
16103 end Interface_Name
;
16105 -----------------------
16106 -- Interrupt_Handler --
16107 -----------------------
16109 -- pragma Interrupt_Handler (handler_NAME);
16111 when Pragma_Interrupt_Handler
=>
16112 Check_Ada_83_Warning
;
16113 Check_Arg_Count
(1);
16114 Check_No_Identifiers
;
16116 if No_Run_Time_Mode
then
16117 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
16119 Check_Interrupt_Or_Attach_Handler
;
16120 Process_Interrupt_Or_Attach_Handler
;
16123 ------------------------
16124 -- Interrupt_Priority --
16125 ------------------------
16127 -- pragma Interrupt_Priority [(EXPRESSION)];
16129 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
16130 P
: constant Node_Id
:= Parent
(N
);
16135 Check_Ada_83_Warning
;
16137 if Arg_Count
/= 0 then
16138 Arg
:= Get_Pragma_Arg
(Arg1
);
16139 Check_Arg_Count
(1);
16140 Check_No_Identifiers
;
16142 -- The expression must be analyzed in the special manner
16143 -- described in "Handling of Default and Per-Object
16144 -- Expressions" in sem.ads.
16146 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
16149 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
16154 Ent
:= Defining_Identifier
(Parent
(P
));
16156 -- Check duplicate pragma before we chain the pragma in the Rep
16157 -- Item chain of Ent.
16159 Check_Duplicate_Pragma
(Ent
);
16160 Record_Rep_Item
(Ent
, N
);
16162 -- Check the No_Task_At_Interrupt_Priority restriction
16164 if Nkind
(P
) = N_Task_Definition
then
16165 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
16168 end Interrupt_Priority
;
16170 ---------------------
16171 -- Interrupt_State --
16172 ---------------------
16174 -- pragma Interrupt_State (
16175 -- [Name =>] INTERRUPT_ID,
16176 -- [State =>] INTERRUPT_STATE);
16178 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16179 -- INTERRUPT_STATE => System | Runtime | User
16181 -- Note: if the interrupt id is given as an identifier, then it must
16182 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16183 -- given as a static integer expression which must be in the range of
16184 -- Ada.Interrupts.Interrupt_ID.
16186 when Pragma_Interrupt_State
=> Interrupt_State
: declare
16187 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
16188 -- This is the entity Ada.Interrupts.Interrupt_ID;
16190 State_Type
: Character;
16191 -- Set to 's'/'r'/'u' for System/Runtime/User
16194 -- Index to entry in Interrupt_States table
16197 -- Value of interrupt
16199 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
16200 -- The first argument to the pragma
16202 Int_Ent
: Entity_Id
;
16203 -- Interrupt entity in Ada.Interrupts.Names
16207 Check_Arg_Order
((Name_Name
, Name_State
));
16208 Check_Arg_Count
(2);
16210 Check_Optional_Identifier
(Arg1
, Name_Name
);
16211 Check_Optional_Identifier
(Arg2
, Name_State
);
16212 Check_Arg_Is_Identifier
(Arg2
);
16214 -- First argument is identifier
16216 if Nkind
(Arg1X
) = N_Identifier
then
16218 -- Search list of names in Ada.Interrupts.Names
16220 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
16222 if No
(Int_Ent
) then
16223 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
16225 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
16226 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
16230 Next_Entity
(Int_Ent
);
16233 -- First argument is not an identifier, so it must be a static
16234 -- expression of type Ada.Interrupts.Interrupt_ID.
16237 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
16238 Int_Val
:= Expr_Value
(Arg1X
);
16240 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
16242 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
16245 ("value not in range of type "
16246 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
16252 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16253 when Name_Runtime
=> State_Type
:= 'r';
16254 when Name_System
=> State_Type
:= 's';
16255 when Name_User
=> State_Type
:= 'u';
16258 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
16261 -- Check if entry is already stored
16263 IST_Num
:= Interrupt_States
.First
;
16265 -- If entry not found, add it
16267 if IST_Num
> Interrupt_States
.Last
then
16268 Interrupt_States
.Append
16269 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
16270 Interrupt_State
=> State_Type
,
16271 Pragma_Loc
=> Loc
));
16274 -- Case of entry for the same entry
16276 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
16279 -- If state matches, done, no need to make redundant entry
16282 State_Type
= Interrupt_States
.Table
(IST_Num
).
16285 -- Otherwise if state does not match, error
16288 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
16290 ("state conflicts with that given #", Arg2
);
16294 IST_Num
:= IST_Num
+ 1;
16296 end Interrupt_State
;
16302 -- pragma Invariant
16303 -- ([Entity =>] type_LOCAL_NAME,
16304 -- [Check =>] EXPRESSION
16305 -- [,[Message =>] String_Expression]);
16307 when Pragma_Invariant
=> Invariant
: declare
16314 Check_At_Least_N_Arguments
(2);
16315 Check_At_Most_N_Arguments
(3);
16316 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16317 Check_Optional_Identifier
(Arg2
, Name_Check
);
16319 if Arg_Count
= 3 then
16320 Check_Optional_Identifier
(Arg3
, Name_Message
);
16321 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
16324 Check_Arg_Is_Local_Name
(Arg1
);
16326 Type_Id
:= Get_Pragma_Arg
(Arg1
);
16327 Find_Type
(Type_Id
);
16328 Typ
:= Entity
(Type_Id
);
16330 if Typ
= Any_Type
then
16333 -- Invariants allowed in interface types (RM 7.3.2(3/3))
16335 elsif Is_Interface
(Typ
) then
16338 -- An invariant must apply to a private type, or appear in the
16339 -- private part of a package spec and apply to a completion.
16340 -- a class-wide invariant can only appear on a private declaration
16341 -- or private extension, not a completion.
16343 elsif Ekind_In
(Typ
, E_Private_Type
,
16344 E_Record_Type_With_Private
,
16345 E_Limited_Private_Type
)
16349 elsif In_Private_Part
(Current_Scope
)
16350 and then Has_Private_Declaration
(Typ
)
16351 and then not Class_Present
(N
)
16355 elsif In_Private_Part
(Current_Scope
) then
16357 ("pragma% only allowed for private type declared in "
16358 & "visible part", Arg1
);
16362 ("pragma% only allowed for private type", Arg1
);
16365 -- A pragma that applies to a Ghost entity becomes Ghost for the
16366 -- purposes of legality checks and removal of ignored Ghost code.
16368 Mark_Pragma_As_Ghost
(N
, Typ
);
16370 -- Not allowed for abstract type in the non-class case (it is
16371 -- allowed to use Invariant'Class for abstract types).
16373 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
16375 ("pragma% not allowed for abstract type", Arg1
);
16378 -- Link the pragma on to the rep item chain, for processing when
16379 -- the type is frozen.
16381 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
16383 -- Note that the type has at least one invariant, and also that
16384 -- it has inheritable invariants if we have Invariant'Class
16385 -- or Type_Invariant'Class. Build the corresponding invariant
16386 -- procedure declaration, so that calls to it can be generated
16387 -- before the body is built (e.g. within an expression function).
16389 -- Interface types have no invariant procedure; their invariants
16390 -- are propagated to the build invariant procedure of all the
16391 -- types covering the interface type.
16393 if not Is_Interface
(Typ
) then
16394 Insert_After_And_Analyze
16395 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
16398 if Class_Present
(N
) then
16399 Set_Has_Inheritable_Invariants
(Typ
);
16407 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16409 when Pragma_Keep_Names
=> Keep_Names
: declare
16414 Check_Arg_Count
(1);
16415 Check_Optional_Identifier
(Arg1
, Name_On
);
16416 Check_Arg_Is_Local_Name
(Arg1
);
16418 Arg
:= Get_Pragma_Arg
(Arg1
);
16421 if Etype
(Arg
) = Any_Type
then
16425 if not Is_Entity_Name
(Arg
)
16426 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16429 ("pragma% requires a local enumeration type", Arg1
);
16432 Set_Discard_Names
(Entity
(Arg
), False);
16439 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16441 when Pragma_License
=>
16444 -- Do not analyze pragma any further in CodePeer mode, to avoid
16445 -- extraneous errors in this implementation-dependent pragma,
16446 -- which has a different profile on other compilers.
16448 if CodePeer_Mode
then
16452 Check_Arg_Count
(1);
16453 Check_No_Identifiers
;
16454 Check_Valid_Configuration_Pragma
;
16455 Check_Arg_Is_Identifier
(Arg1
);
16458 Sind
: constant Source_File_Index
:=
16459 Source_Index
(Current_Sem_Unit
);
16462 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16464 Set_License
(Sind
, GPL
);
16466 when Name_Modified_GPL
=>
16467 Set_License
(Sind
, Modified_GPL
);
16469 when Name_Restricted
=>
16470 Set_License
(Sind
, Restricted
);
16472 when Name_Unrestricted
=>
16473 Set_License
(Sind
, Unrestricted
);
16476 Error_Pragma_Arg
("invalid license name", Arg1
);
16484 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16486 when Pragma_Link_With
=> Link_With
: declare
16492 if Operating_Mode
= Generate_Code
16493 and then In_Extended_Main_Source_Unit
(N
)
16495 Check_At_Least_N_Arguments
(1);
16496 Check_No_Identifiers
;
16497 Check_Is_In_Decl_Part_Or_Package_Spec
;
16498 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16502 while Present
(Arg
) loop
16503 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16505 -- Store argument, converting sequences of spaces to a
16506 -- single null character (this is one of the differences
16507 -- in processing between Link_With and Linker_Options).
16509 Arg_Store
: declare
16510 C
: constant Char_Code
:= Get_Char_Code
(' ');
16511 S
: constant String_Id
:=
16512 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16513 L
: constant Nat
:= String_Length
(S
);
16516 procedure Skip_Spaces
;
16517 -- Advance F past any spaces
16523 procedure Skip_Spaces
is
16525 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16530 -- Start of processing for Arg_Store
16533 Skip_Spaces
; -- skip leading spaces
16535 -- Loop through characters, changing any embedded
16536 -- sequence of spaces to a single null character (this
16537 -- is how Link_With/Linker_Options differ)
16540 if Get_String_Char
(S
, F
) = C
then
16543 Store_String_Char
(ASCII
.NUL
);
16546 Store_String_Char
(Get_String_Char
(S
, F
));
16554 if Present
(Arg
) then
16555 Store_String_Char
(ASCII
.NUL
);
16559 Store_Linker_Option_String
(End_String
);
16567 -- pragma Linker_Alias (
16568 -- [Entity =>] LOCAL_NAME
16569 -- [Target =>] static_string_EXPRESSION);
16571 when Pragma_Linker_Alias
=>
16573 Check_Arg_Order
((Name_Entity
, Name_Target
));
16574 Check_Arg_Count
(2);
16575 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16576 Check_Optional_Identifier
(Arg2
, Name_Target
);
16577 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16578 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16580 -- The only processing required is to link this item on to the
16581 -- list of rep items for the given entity. This is accomplished
16582 -- by the call to Rep_Item_Too_Late (when no error is detected
16583 -- and False is returned).
16585 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16588 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16591 ------------------------
16592 -- Linker_Constructor --
16593 ------------------------
16595 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16597 -- Code is shared with Linker_Destructor
16599 -----------------------
16600 -- Linker_Destructor --
16601 -----------------------
16603 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16605 when Pragma_Linker_Constructor |
16606 Pragma_Linker_Destructor
=>
16607 Linker_Constructor
: declare
16613 Check_Arg_Count
(1);
16614 Check_No_Identifiers
;
16615 Check_Arg_Is_Local_Name
(Arg1
);
16616 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16618 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16620 if not Is_Library_Level_Entity
(Proc
) then
16622 ("argument for pragma% must be library level entity", Arg1
);
16625 -- The only processing required is to link this item on to the
16626 -- list of rep items for the given entity. This is accomplished
16627 -- by the call to Rep_Item_Too_Late (when no error is detected
16628 -- and False is returned).
16630 if Rep_Item_Too_Late
(Proc
, N
) then
16633 Set_Has_Gigi_Rep_Item
(Proc
);
16635 end Linker_Constructor
;
16637 --------------------
16638 -- Linker_Options --
16639 --------------------
16641 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16643 when Pragma_Linker_Options
=> Linker_Options
: declare
16647 Check_Ada_83_Warning
;
16648 Check_No_Identifiers
;
16649 Check_Arg_Count
(1);
16650 Check_Is_In_Decl_Part_Or_Package_Spec
;
16651 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16652 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16655 while Present
(Arg
) loop
16656 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16657 Store_String_Char
(ASCII
.NUL
);
16659 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16663 if Operating_Mode
= Generate_Code
16664 and then In_Extended_Main_Source_Unit
(N
)
16666 Store_Linker_Option_String
(End_String
);
16668 end Linker_Options
;
16670 --------------------
16671 -- Linker_Section --
16672 --------------------
16674 -- pragma Linker_Section (
16675 -- [Entity =>] LOCAL_NAME
16676 -- [Section =>] static_string_EXPRESSION);
16678 when Pragma_Linker_Section
=> Linker_Section
: declare
16683 Ghost_Error_Posted
: Boolean := False;
16684 -- Flag set when an error concerning the illegal mix of Ghost and
16685 -- non-Ghost subprograms is emitted.
16687 Ghost_Id
: Entity_Id
:= Empty
;
16688 -- The entity of the first Ghost subprogram encountered while
16689 -- processing the arguments of the pragma.
16693 Check_Arg_Order
((Name_Entity
, Name_Section
));
16694 Check_Arg_Count
(2);
16695 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16696 Check_Optional_Identifier
(Arg2
, Name_Section
);
16697 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16698 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16700 -- Check kind of entity
16702 Arg
:= Get_Pragma_Arg
(Arg1
);
16703 Ent
:= Entity
(Arg
);
16705 case Ekind
(Ent
) is
16707 -- Objects (constants and variables) and types. For these cases
16708 -- all we need to do is to set the Linker_Section_pragma field,
16709 -- checking that we do not have a duplicate.
16711 when E_Constant | E_Variable | Type_Kind
=>
16712 LPE
:= Linker_Section_Pragma
(Ent
);
16714 if Present
(LPE
) then
16715 Error_Msg_Sloc
:= Sloc
(LPE
);
16717 ("Linker_Section already specified for &#", Arg1
, Ent
);
16720 Set_Linker_Section_Pragma
(Ent
, N
);
16722 -- A pragma that applies to a Ghost entity becomes Ghost for
16723 -- the purposes of legality checks and removal of ignored
16726 Mark_Pragma_As_Ghost
(N
, Ent
);
16730 when Subprogram_Kind
=>
16732 -- Aspect case, entity already set
16734 if From_Aspect_Specification
(N
) then
16735 Set_Linker_Section_Pragma
16736 (Entity
(Corresponding_Aspect
(N
)), N
);
16738 -- Pragma case, we must climb the homonym chain, but skip
16739 -- any for which the linker section is already set.
16743 if No
(Linker_Section_Pragma
(Ent
)) then
16744 Set_Linker_Section_Pragma
(Ent
, N
);
16746 -- A pragma that applies to a Ghost entity becomes
16747 -- Ghost for the purposes of legality checks and
16748 -- removal of ignored Ghost code.
16750 Mark_Pragma_As_Ghost
(N
, Ent
);
16752 -- Capture the entity of the first Ghost subprogram
16753 -- being processed for error detection purposes.
16755 if Is_Ghost_Entity
(Ent
) then
16756 if No
(Ghost_Id
) then
16760 -- Otherwise the subprogram is non-Ghost. It is
16761 -- illegal to mix references to Ghost and non-Ghost
16762 -- entities (SPARK RM 6.9).
16764 elsif Present
(Ghost_Id
)
16765 and then not Ghost_Error_Posted
16767 Ghost_Error_Posted
:= True;
16769 Error_Msg_Name_1
:= Pname
;
16771 ("pragma % cannot mention ghost and "
16772 & "non-ghost subprograms", N
);
16774 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
16776 ("\& # declared as ghost", N
, Ghost_Id
);
16778 Error_Msg_Sloc
:= Sloc
(Ent
);
16780 ("\& # declared as non-ghost", N
, Ent
);
16784 Ent
:= Homonym
(Ent
);
16786 or else Scope
(Ent
) /= Current_Scope
;
16790 -- All other cases are illegal
16794 ("pragma% applies only to objects, subprograms, and types",
16797 end Linker_Section
;
16803 -- pragma List (On | Off)
16805 -- There is nothing to do here, since we did all the processing for
16806 -- this pragma in Par.Prag (so that it works properly even in syntax
16809 when Pragma_List
=>
16816 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16818 when Pragma_Lock_Free
=> Lock_Free
: declare
16819 P
: constant Node_Id
:= Parent
(N
);
16825 Check_No_Identifiers
;
16826 Check_At_Most_N_Arguments
(1);
16828 -- Protected definition case
16830 if Nkind
(P
) = N_Protected_Definition
then
16831 Ent
:= Defining_Identifier
(Parent
(P
));
16835 if Arg_Count
= 1 then
16836 Arg
:= Get_Pragma_Arg
(Arg1
);
16837 Val
:= Is_True
(Static_Boolean
(Arg
));
16839 -- No arguments (expression is considered to be True)
16845 -- Check duplicate pragma before we chain the pragma in the Rep
16846 -- Item chain of Ent.
16848 Check_Duplicate_Pragma
(Ent
);
16849 Record_Rep_Item
(Ent
, N
);
16850 Set_Uses_Lock_Free
(Ent
, Val
);
16852 -- Anything else is incorrect placement
16859 --------------------
16860 -- Locking_Policy --
16861 --------------------
16863 -- pragma Locking_Policy (policy_IDENTIFIER);
16865 when Pragma_Locking_Policy
=> declare
16866 subtype LP_Range
is Name_Id
16867 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16872 Check_Ada_83_Warning
;
16873 Check_Arg_Count
(1);
16874 Check_No_Identifiers
;
16875 Check_Arg_Is_Locking_Policy
(Arg1
);
16876 Check_Valid_Configuration_Pragma
;
16877 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16880 when Name_Ceiling_Locking
=>
16882 when Name_Inheritance_Locking
=>
16884 when Name_Concurrent_Readers_Locking
=>
16888 if Locking_Policy
/= ' '
16889 and then Locking_Policy
/= LP
16891 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16892 Error_Pragma
("locking policy incompatible with policy#");
16894 -- Set new policy, but always preserve System_Location since we
16895 -- like the error message with the run time name.
16898 Locking_Policy
:= LP
;
16900 if Locking_Policy_Sloc
/= System_Location
then
16901 Locking_Policy_Sloc
:= Loc
;
16906 -------------------
16907 -- Loop_Optimize --
16908 -------------------
16910 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16912 -- OPTIMIZATION_HINT ::=
16913 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16915 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16920 Check_At_Least_N_Arguments
(1);
16921 Check_No_Identifiers
;
16923 Hint
:= First
(Pragma_Argument_Associations
(N
));
16924 while Present
(Hint
) loop
16925 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16933 Check_Loop_Pragma_Placement
;
16940 -- pragma Loop_Variant
16941 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16943 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16945 -- CHANGE_DIRECTION ::= Increases | Decreases
16947 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16952 Check_At_Least_N_Arguments
(1);
16953 Check_Loop_Pragma_Placement
;
16955 -- Process all increasing / decreasing expressions
16957 Variant
:= First
(Pragma_Argument_Associations
(N
));
16958 while Present
(Variant
) loop
16959 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16962 Error_Pragma_Arg
("wrong change modifier", Variant
);
16965 Preanalyze_Assert_Expression
16966 (Expression
(Variant
), Any_Discrete
);
16972 -----------------------
16973 -- Machine_Attribute --
16974 -----------------------
16976 -- pragma Machine_Attribute (
16977 -- [Entity =>] LOCAL_NAME,
16978 -- [Attribute_Name =>] static_string_EXPRESSION
16979 -- [, [Info =>] static_EXPRESSION] );
16981 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16982 Def_Id
: Entity_Id
;
16986 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16988 if Arg_Count
= 3 then
16989 Check_Optional_Identifier
(Arg3
, Name_Info
);
16990 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16992 Check_Arg_Count
(2);
16995 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16996 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16997 Check_Arg_Is_Local_Name
(Arg1
);
16998 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16999 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17001 if Is_Access_Type
(Def_Id
) then
17002 Def_Id
:= Designated_Type
(Def_Id
);
17005 if Rep_Item_Too_Early
(Def_Id
, N
) then
17009 Def_Id
:= Underlying_Type
(Def_Id
);
17011 -- The only processing required is to link this item on to the
17012 -- list of rep items for the given entity. This is accomplished
17013 -- by the call to Rep_Item_Too_Late (when no error is detected
17014 -- and False is returned).
17016 if Rep_Item_Too_Late
(Def_Id
, N
) then
17019 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17021 end Machine_Attribute
;
17028 -- (MAIN_OPTION [, MAIN_OPTION]);
17031 -- [STACK_SIZE =>] static_integer_EXPRESSION
17032 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17033 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17035 when Pragma_Main
=> Main
: declare
17036 Args
: Args_List
(1 .. 3);
17037 Names
: constant Name_List
(1 .. 3) := (
17039 Name_Task_Stack_Size_Default
,
17040 Name_Time_Slicing_Enabled
);
17046 Gather_Associations
(Names
, Args
);
17048 for J
in 1 .. 2 loop
17049 if Present
(Args
(J
)) then
17050 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
17054 if Present
(Args
(3)) then
17055 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
17059 while Present
(Nod
) loop
17060 if Nkind
(Nod
) = N_Pragma
17061 and then Pragma_Name
(Nod
) = Name_Main
17063 Error_Msg_Name_1
:= Pname
;
17064 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17075 -- pragma Main_Storage
17076 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17078 -- MAIN_STORAGE_OPTION ::=
17079 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17080 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17082 when Pragma_Main_Storage
=> Main_Storage
: declare
17083 Args
: Args_List
(1 .. 2);
17084 Names
: constant Name_List
(1 .. 2) := (
17085 Name_Working_Storage
,
17092 Gather_Associations
(Names
, Args
);
17094 for J
in 1 .. 2 loop
17095 if Present
(Args
(J
)) then
17096 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
17100 Check_In_Main_Program
;
17103 while Present
(Nod
) loop
17104 if Nkind
(Nod
) = N_Pragma
17105 and then Pragma_Name
(Nod
) = Name_Main_Storage
17107 Error_Msg_Name_1
:= Pname
;
17108 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17119 -- pragma Memory_Size (NUMERIC_LITERAL)
17121 when Pragma_Memory_Size
=>
17124 -- Memory size is simply ignored
17126 Check_No_Identifiers
;
17127 Check_Arg_Count
(1);
17128 Check_Arg_Is_Integer_Literal
(Arg1
);
17136 -- The only correct use of this pragma is on its own in a file, in
17137 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17138 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17139 -- check for a file containing nothing but a No_Body pragma). If we
17140 -- attempt to process it during normal semantics processing, it means
17141 -- it was misplaced.
17143 when Pragma_No_Body
=>
17147 -----------------------------
17148 -- No_Elaboration_Code_All --
17149 -----------------------------
17151 -- pragma No_Elaboration_Code_All;
17153 when Pragma_No_Elaboration_Code_All
=>
17155 Check_Valid_Library_Unit_Pragma
;
17157 if Nkind
(N
) = N_Null_Statement
then
17161 -- Must appear for a spec or generic spec
17163 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
17164 N_Generic_Package_Declaration
,
17165 N_Generic_Subprogram_Declaration
,
17166 N_Package_Declaration
,
17167 N_Subprogram_Declaration
)
17171 ("pragma% can only occur for package "
17172 & "or subprogram spec"));
17175 -- Set flag in unit table
17177 Set_No_Elab_Code_All
(Current_Sem_Unit
);
17179 -- Set restriction No_Elaboration_Code if this is the main unit
17181 if Current_Sem_Unit
= Main_Unit
then
17182 Set_Restriction
(No_Elaboration_Code
, N
);
17185 -- If we are in the main unit or in an extended main source unit,
17186 -- then we also add it to the configuration restrictions so that
17187 -- it will apply to all units in the extended main source.
17189 if Current_Sem_Unit
= Main_Unit
17190 or else In_Extended_Main_Source_Unit
(N
)
17192 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
17195 -- If in main extended unit, activate transitive with test
17197 if In_Extended_Main_Source_Unit
(N
) then
17198 Opt
.No_Elab_Code_All_Pragma
:= N
;
17205 -- pragma No_Inline ( NAME {, NAME} );
17207 when Pragma_No_Inline
=>
17209 Process_Inline
(Suppressed
);
17215 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17217 when Pragma_No_Return
=> No_Return
: declare
17223 Ghost_Error_Posted
: Boolean := False;
17224 -- Flag set when an error concerning the illegal mix of Ghost and
17225 -- non-Ghost subprograms is emitted.
17227 Ghost_Id
: Entity_Id
:= Empty
;
17228 -- The entity of the first Ghost procedure encountered while
17229 -- processing the arguments of the pragma.
17233 Check_At_Least_N_Arguments
(1);
17235 -- Loop through arguments of pragma
17238 while Present
(Arg
) loop
17239 Check_Arg_Is_Local_Name
(Arg
);
17240 Id
:= Get_Pragma_Arg
(Arg
);
17243 if not Is_Entity_Name
(Id
) then
17244 Error_Pragma_Arg
("entity name required", Arg
);
17247 if Etype
(Id
) = Any_Type
then
17251 -- Loop to find matching procedures
17257 and then Scope
(E
) = Current_Scope
17259 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
17262 -- A pragma that applies to a Ghost entity becomes Ghost
17263 -- for the purposes of legality checks and removal of
17264 -- ignored Ghost code.
17266 Mark_Pragma_As_Ghost
(N
, E
);
17268 -- Capture the entity of the first Ghost procedure being
17269 -- processed for error detection purposes.
17271 if Is_Ghost_Entity
(E
) then
17272 if No
(Ghost_Id
) then
17276 -- Otherwise the subprogram is non-Ghost. It is illegal
17277 -- to mix references to Ghost and non-Ghost entities
17280 elsif Present
(Ghost_Id
)
17281 and then not Ghost_Error_Posted
17283 Ghost_Error_Posted
:= True;
17285 Error_Msg_Name_1
:= Pname
;
17287 ("pragma % cannot mention ghost and non-ghost "
17288 & "procedures", N
);
17290 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
17291 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
17293 Error_Msg_Sloc
:= Sloc
(E
);
17294 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
17297 -- Set flag on any alias as well
17299 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
17300 Set_No_Return
(Alias
(E
));
17306 exit when From_Aspect_Specification
(N
);
17310 -- If entity in not in current scope it may be the enclosing
17311 -- suprogram body to which the aspect applies.
17314 if Entity
(Id
) = Current_Scope
17315 and then From_Aspect_Specification
(N
)
17317 Set_No_Return
(Entity
(Id
));
17319 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
17331 -- pragma No_Run_Time;
17333 -- Note: this pragma is retained for backwards compatibility. See
17334 -- body of Rtsfind for full details on its handling.
17336 when Pragma_No_Run_Time
=>
17338 Check_Valid_Configuration_Pragma
;
17339 Check_Arg_Count
(0);
17341 No_Run_Time_Mode
:= True;
17342 Configurable_Run_Time_Mode
:= True;
17344 -- Set Duration to 32 bits if word size is 32
17346 if Ttypes
.System_Word_Size
= 32 then
17347 Duration_32_Bits_On_Target
:= True;
17350 -- Set appropriate restrictions
17352 Set_Restriction
(No_Finalization
, N
);
17353 Set_Restriction
(No_Exception_Handlers
, N
);
17354 Set_Restriction
(Max_Tasks
, N
, 0);
17355 Set_Restriction
(No_Tasking
, N
);
17357 -----------------------
17358 -- No_Tagged_Streams --
17359 -----------------------
17361 -- pragma No_Tagged_Streams;
17362 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
17364 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
17370 Check_At_Most_N_Arguments
(1);
17372 -- One argument case
17374 if Arg_Count
= 1 then
17375 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17376 Check_Arg_Is_Local_Name
(Arg1
);
17377 E_Id
:= Get_Pragma_Arg
(Arg1
);
17379 if Etype
(E_Id
) = Any_Type
then
17383 E
:= Entity
(E_Id
);
17385 Check_Duplicate_Pragma
(E
);
17387 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
17389 ("argument for pragma% must be root tagged type", Arg1
);
17392 if Rep_Item_Too_Early
(E
, N
)
17394 Rep_Item_Too_Late
(E
, N
)
17398 Set_No_Tagged_Streams_Pragma
(E
, N
);
17401 -- Zero argument case
17404 Check_Is_In_Decl_Part_Or_Package_Spec
;
17405 No_Tagged_Streams
:= N
;
17407 end No_Tagged_Strms
;
17409 ------------------------
17410 -- No_Strict_Aliasing --
17411 ------------------------
17413 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17415 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
17420 Check_At_Most_N_Arguments
(1);
17422 if Arg_Count
= 0 then
17423 Check_Valid_Configuration_Pragma
;
17424 Opt
.No_Strict_Aliasing
:= True;
17427 Check_Optional_Identifier
(Arg2
, Name_Entity
);
17428 Check_Arg_Is_Local_Name
(Arg1
);
17429 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17431 if E_Id
= Any_Type
then
17433 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
17434 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
17437 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
17439 end No_Strict_Aliasing
;
17441 -----------------------
17442 -- Normalize_Scalars --
17443 -----------------------
17445 -- pragma Normalize_Scalars;
17447 when Pragma_Normalize_Scalars
=>
17448 Check_Ada_83_Warning
;
17449 Check_Arg_Count
(0);
17450 Check_Valid_Configuration_Pragma
;
17452 -- Normalize_Scalars creates false positives in CodePeer, and
17453 -- incorrect negative results in GNATprove mode, so ignore this
17454 -- pragma in these modes.
17456 if not (CodePeer_Mode
or GNATprove_Mode
) then
17457 Normalize_Scalars
:= True;
17458 Init_Or_Norm_Scalars
:= True;
17465 -- pragma Obsolescent;
17467 -- pragma Obsolescent (
17468 -- [Message =>] static_string_EXPRESSION
17469 -- [,[Version =>] Ada_05]]);
17471 -- pragma Obsolescent (
17472 -- [Entity =>] NAME
17473 -- [,[Message =>] static_string_EXPRESSION
17474 -- [,[Version =>] Ada_05]] );
17476 when Pragma_Obsolescent
=> Obsolescent
: declare
17480 procedure Set_Obsolescent
(E
: Entity_Id
);
17481 -- Given an entity Ent, mark it as obsolescent if appropriate
17483 ---------------------
17484 -- Set_Obsolescent --
17485 ---------------------
17487 procedure Set_Obsolescent
(E
: Entity_Id
) is
17496 -- A pragma that applies to a Ghost entity becomes Ghost for
17497 -- the purposes of legality checks and removal of ignored Ghost
17500 Mark_Pragma_As_Ghost
(N
, E
);
17502 -- Entity name was given
17504 if Present
(Ename
) then
17506 -- If entity name matches, we are fine. Save entity in
17507 -- pragma argument, for ASIS use.
17509 if Chars
(Ename
) = Chars
(Ent
) then
17510 Set_Entity
(Ename
, Ent
);
17511 Generate_Reference
(Ent
, Ename
);
17513 -- If entity name does not match, only possibility is an
17514 -- enumeration literal from an enumeration type declaration.
17516 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
17518 ("pragma % entity name does not match declaration");
17521 Ent
:= First_Literal
(E
);
17525 ("pragma % entity name does not match any "
17526 & "enumeration literal");
17528 elsif Chars
(Ent
) = Chars
(Ename
) then
17529 Set_Entity
(Ename
, Ent
);
17530 Generate_Reference
(Ent
, Ename
);
17534 Ent
:= Next_Literal
(Ent
);
17540 -- Ent points to entity to be marked
17542 if Arg_Count
>= 1 then
17544 -- Deal with static string argument
17546 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17547 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
17549 for J
in 1 .. String_Length
(S
) loop
17550 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
17552 ("pragma% argument does not allow wide characters",
17557 Obsolescent_Warnings
.Append
17558 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
17560 -- Check for Ada_05 parameter
17562 if Arg_Count
/= 1 then
17563 Check_Arg_Count
(2);
17566 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
17569 Check_Arg_Is_Identifier
(Argx
);
17571 if Chars
(Argx
) /= Name_Ada_05
then
17572 Error_Msg_Name_2
:= Name_Ada_05
;
17574 ("only allowed argument for pragma% is %", Argx
);
17577 if Ada_Version_Explicit
< Ada_2005
17578 or else not Warn_On_Ada_2005_Compatibility
17586 -- Set flag if pragma active
17589 Set_Is_Obsolescent
(Ent
);
17593 end Set_Obsolescent
;
17595 -- Start of processing for pragma Obsolescent
17600 Check_At_Most_N_Arguments
(3);
17602 -- See if first argument specifies an entity name
17606 (Chars
(Arg1
) = Name_Entity
17608 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
17610 N_Operator_Symbol
))
17612 Ename
:= Get_Pragma_Arg
(Arg1
);
17614 -- Eliminate first argument, so we can share processing
17618 Arg_Count
:= Arg_Count
- 1;
17620 -- No Entity name argument given
17626 if Arg_Count
>= 1 then
17627 Check_Optional_Identifier
(Arg1
, Name_Message
);
17629 if Arg_Count
= 2 then
17630 Check_Optional_Identifier
(Arg2
, Name_Version
);
17634 -- Get immediately preceding declaration
17637 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17641 -- Cases where we do not follow anything other than another pragma
17645 -- First case: library level compilation unit declaration with
17646 -- the pragma immediately following the declaration.
17648 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17650 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17653 -- Case 2: library unit placement for package
17657 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17659 if Is_Package_Or_Generic_Package
(Ent
) then
17660 Set_Obsolescent
(Ent
);
17666 -- Cases where we must follow a declaration, including an
17667 -- abstract subprogram declaration, which is not in the
17668 -- other node subtypes.
17671 if Nkind
(Decl
) not in N_Declaration
17672 and then Nkind
(Decl
) not in N_Later_Decl_Item
17673 and then Nkind
(Decl
) not in N_Generic_Declaration
17674 and then Nkind
(Decl
) not in N_Renaming_Declaration
17675 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
17678 ("pragma% misplaced, "
17679 & "must immediately follow a declaration");
17682 Set_Obsolescent
(Defining_Entity
(Decl
));
17692 -- pragma Optimize (Time | Space | Off);
17694 -- The actual check for optimize is done in Gigi. Note that this
17695 -- pragma does not actually change the optimization setting, it
17696 -- simply checks that it is consistent with the pragma.
17698 when Pragma_Optimize
=>
17699 Check_No_Identifiers
;
17700 Check_Arg_Count
(1);
17701 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17703 ------------------------
17704 -- Optimize_Alignment --
17705 ------------------------
17707 -- pragma Optimize_Alignment (Time | Space | Off);
17709 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17711 Check_No_Identifiers
;
17712 Check_Arg_Count
(1);
17713 Check_Valid_Configuration_Pragma
;
17716 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17720 Opt
.Optimize_Alignment
:= 'T';
17722 Opt
.Optimize_Alignment
:= 'S';
17724 Opt
.Optimize_Alignment
:= 'O';
17726 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17730 -- Set indication that mode is set locally. If we are in fact in a
17731 -- configuration pragma file, this setting is harmless since the
17732 -- switch will get reset anyway at the start of each unit.
17734 Optimize_Alignment_Local
:= True;
17735 end Optimize_Alignment
;
17741 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17743 when Pragma_Ordered
=> Ordered
: declare
17744 Assoc
: constant Node_Id
:= Arg1
;
17750 Check_No_Identifiers
;
17751 Check_Arg_Count
(1);
17752 Check_Arg_Is_Local_Name
(Arg1
);
17754 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17755 Find_Type
(Type_Id
);
17756 Typ
:= Entity
(Type_Id
);
17758 if Typ
= Any_Type
then
17761 Typ
:= Underlying_Type
(Typ
);
17764 if not Is_Enumeration_Type
(Typ
) then
17765 Error_Pragma
("pragma% must specify enumeration type");
17768 Check_First_Subtype
(Arg1
);
17769 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17772 -------------------
17773 -- Overflow_Mode --
17774 -------------------
17776 -- pragma Overflow_Mode
17777 -- ([General => ] MODE [, [Assertions => ] MODE]);
17779 -- MODE := STRICT | MINIMIZED | ELIMINATED
17781 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17782 -- since System.Bignums makes this assumption. This is true of nearly
17783 -- all (all?) targets.
17785 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17786 function Get_Overflow_Mode
17788 Arg
: Node_Id
) return Overflow_Mode_Type
;
17789 -- Function to process one pragma argument, Arg. If an identifier
17790 -- is present, it must be Name. Mode type is returned if a valid
17791 -- argument exists, otherwise an error is signalled.
17793 -----------------------
17794 -- Get_Overflow_Mode --
17795 -----------------------
17797 function Get_Overflow_Mode
17799 Arg
: Node_Id
) return Overflow_Mode_Type
17801 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17804 Check_Optional_Identifier
(Arg
, Name
);
17805 Check_Arg_Is_Identifier
(Argx
);
17807 if Chars
(Argx
) = Name_Strict
then
17810 elsif Chars
(Argx
) = Name_Minimized
then
17813 elsif Chars
(Argx
) = Name_Eliminated
then
17814 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17816 ("Eliminated not implemented on this target", Argx
);
17822 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17824 end Get_Overflow_Mode
;
17826 -- Start of processing for Overflow_Mode
17830 Check_At_Least_N_Arguments
(1);
17831 Check_At_Most_N_Arguments
(2);
17833 -- Process first argument
17835 Scope_Suppress
.Overflow_Mode_General
:=
17836 Get_Overflow_Mode
(Name_General
, Arg1
);
17838 -- Case of only one argument
17840 if Arg_Count
= 1 then
17841 Scope_Suppress
.Overflow_Mode_Assertions
:=
17842 Scope_Suppress
.Overflow_Mode_General
;
17844 -- Case of two arguments present
17847 Scope_Suppress
.Overflow_Mode_Assertions
:=
17848 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17852 --------------------------
17853 -- Overriding Renamings --
17854 --------------------------
17856 -- pragma Overriding_Renamings;
17858 when Pragma_Overriding_Renamings
=>
17860 Check_Arg_Count
(0);
17861 Check_Valid_Configuration_Pragma
;
17862 Overriding_Renamings
:= True;
17868 -- pragma Pack (first_subtype_LOCAL_NAME);
17870 when Pragma_Pack
=> Pack
: declare
17871 Assoc
: constant Node_Id
:= Arg1
;
17873 Ignore
: Boolean := False;
17878 Check_No_Identifiers
;
17879 Check_Arg_Count
(1);
17880 Check_Arg_Is_Local_Name
(Arg1
);
17881 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17883 if not Is_Entity_Name
(Type_Id
)
17884 or else not Is_Type
(Entity
(Type_Id
))
17887 ("argument for pragma% must be type or subtype", Arg1
);
17890 Find_Type
(Type_Id
);
17891 Typ
:= Entity
(Type_Id
);
17894 or else Rep_Item_Too_Early
(Typ
, N
)
17898 Typ
:= Underlying_Type
(Typ
);
17901 -- A pragma that applies to a Ghost entity becomes Ghost for the
17902 -- purposes of legality checks and removal of ignored Ghost code.
17904 Mark_Pragma_As_Ghost
(N
, Typ
);
17906 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17907 Error_Pragma
("pragma% must specify array or record type");
17910 Check_First_Subtype
(Arg1
);
17911 Check_Duplicate_Pragma
(Typ
);
17915 if Is_Array_Type
(Typ
) then
17916 Ctyp
:= Component_Type
(Typ
);
17918 -- Ignore pack that does nothing
17920 if Known_Static_Esize
(Ctyp
)
17921 and then Known_Static_RM_Size
(Ctyp
)
17922 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17923 and then Addressable
(Esize
(Ctyp
))
17928 -- Process OK pragma Pack. Note that if there is a separate
17929 -- component clause present, the Pack will be cancelled. This
17930 -- processing is in Freeze.
17932 if not Rep_Item_Too_Late
(Typ
, N
) then
17934 -- In CodePeer mode, we do not need complex front-end
17935 -- expansions related to pragma Pack, so disable handling
17938 if CodePeer_Mode
then
17941 -- Normal case where we do the pack action
17945 Set_Is_Packed
(Base_Type
(Typ
));
17946 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17949 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17953 -- For record types, the pack is always effective
17955 else pragma Assert
(Is_Record_Type
(Typ
));
17956 if not Rep_Item_Too_Late
(Typ
, N
) then
17957 Set_Is_Packed
(Base_Type
(Typ
));
17958 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17959 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17970 -- There is nothing to do here, since we did all the processing for
17971 -- this pragma in Par.Prag (so that it works properly even in syntax
17974 when Pragma_Page
=>
17981 -- pragma Part_Of (ABSTRACT_STATE);
17983 -- ABSTRACT_STATE ::= NAME
17985 when Pragma_Part_Of
=> Part_Of
: declare
17986 procedure Propagate_Part_Of
17987 (Pack_Id
: Entity_Id
;
17988 State_Id
: Entity_Id
;
17989 Instance
: Node_Id
);
17990 -- Propagate the Part_Of indicator to all abstract states and
17991 -- objects declared in the visible state space of a package
17992 -- denoted by Pack_Id. State_Id is the encapsulating state.
17993 -- Instance is the package instantiation node.
17995 -----------------------
17996 -- Propagate_Part_Of --
17997 -----------------------
17999 procedure Propagate_Part_Of
18000 (Pack_Id
: Entity_Id
;
18001 State_Id
: Entity_Id
;
18002 Instance
: Node_Id
)
18004 Has_Item
: Boolean := False;
18005 -- Flag set when the visible state space contains at least one
18006 -- abstract state or variable.
18008 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
18009 -- Propagate the Part_Of indicator to all abstract states and
18010 -- objects declared in the visible state space of a package
18011 -- denoted by Pack_Id.
18013 -----------------------
18014 -- Propagate_Part_Of --
18015 -----------------------
18017 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
18018 Item_Id
: Entity_Id
;
18021 -- Traverse the entity chain of the package and set relevant
18022 -- attributes of abstract states and objects declared in the
18023 -- visible state space of the package.
18025 Item_Id
:= First_Entity
(Pack_Id
);
18026 while Present
(Item_Id
)
18027 and then not In_Private_Part
(Item_Id
)
18029 -- Do not consider internally generated items
18031 if not Comes_From_Source
(Item_Id
) then
18034 -- The Part_Of indicator turns an abstract state or an
18035 -- object into a constituent of the encapsulating state.
18037 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
18043 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
18044 Set_Encapsulating_State
(Item_Id
, State_Id
);
18046 -- Recursively handle nested packages and instantiations
18048 elsif Ekind
(Item_Id
) = E_Package
then
18049 Propagate_Part_Of
(Item_Id
);
18052 Next_Entity
(Item_Id
);
18054 end Propagate_Part_Of
;
18056 -- Start of processing for Propagate_Part_Of
18059 Propagate_Part_Of
(Pack_Id
);
18061 -- Detect a package instantiation that is subject to a Part_Of
18062 -- indicator, but has no visible state.
18064 if not Has_Item
then
18066 ("package instantiation & has Part_Of indicator but "
18067 & "lacks visible state", Instance
, Pack_Id
);
18069 end Propagate_Part_Of
;
18074 Encap_Id
: Entity_Id
;
18075 Item_Id
: Entity_Id
;
18079 -- Start of processing for Part_Of
18083 Check_No_Identifiers
;
18084 Check_Arg_Count
(1);
18086 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
18088 -- Object declaration
18090 if Nkind
(Stmt
) = N_Object_Declaration
then
18093 -- Package instantiation
18095 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
18098 -- Single concurrent type declaration
18100 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
18103 -- Otherwise the pragma is associated with an illegal construct
18110 -- Extract the entity of the related object declaration or package
18111 -- instantiation. In the case of the instantiation, use the entity
18112 -- of the instance spec.
18114 if Nkind
(Stmt
) = N_Package_Instantiation
then
18115 Stmt
:= Instance_Spec
(Stmt
);
18118 Item_Id
:= Defining_Entity
(Stmt
);
18119 Encap
:= Get_Pragma_Arg
(Arg1
);
18121 -- A pragma that applies to a Ghost entity becomes Ghost for the
18122 -- purposes of legality checks and removal of ignored Ghost code.
18124 Mark_Pragma_As_Ghost
(N
, Item_Id
);
18126 -- Chain the pragma on the contract for further processing by
18127 -- Analyze_Part_Of_In_Decl_Part or for completeness.
18129 Add_Contract_Item
(N
, Item_Id
);
18131 -- A variable may act as consituent of a single concurrent type
18132 -- which in turn could be declared after the variable. Due to this
18133 -- discrepancy, the full analysis of indicator Part_Of is delayed
18134 -- until the end of the enclosing declarative region (see routine
18135 -- Analyze_Part_Of_In_Decl_Part).
18137 if Ekind
(Item_Id
) = E_Variable
then
18140 -- Otherwise indicator Part_Of applies to a constant or a package
18144 -- Detect any discrepancies between the placement of the
18145 -- constant or package instantiation with respect to state
18146 -- space and the encapsulating state.
18150 Item_Id
=> Item_Id
,
18152 Encap_Id
=> Encap_Id
,
18156 pragma Assert
(Present
(Encap_Id
));
18158 if Ekind
(Item_Id
) = E_Constant
then
18159 Append_Elmt
(Item_Id
, Part_Of_Constituents
(Encap_Id
));
18160 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
18162 -- Propagate the Part_Of indicator to the visible state
18163 -- space of the package instantiation.
18167 (Pack_Id
=> Item_Id
,
18168 State_Id
=> Encap_Id
,
18175 ----------------------------------
18176 -- Partition_Elaboration_Policy --
18177 ----------------------------------
18179 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18181 when Pragma_Partition_Elaboration_Policy
=> declare
18182 subtype PEP_Range
is Name_Id
18183 range First_Partition_Elaboration_Policy_Name
18184 .. Last_Partition_Elaboration_Policy_Name
;
18185 PEP_Val
: PEP_Range
;
18190 Check_Arg_Count
(1);
18191 Check_No_Identifiers
;
18192 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
18193 Check_Valid_Configuration_Pragma
;
18194 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
18197 when Name_Concurrent
=>
18199 when Name_Sequential
=>
18203 if Partition_Elaboration_Policy
/= ' '
18204 and then Partition_Elaboration_Policy
/= PEP
18206 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
18208 ("partition elaboration policy incompatible with policy#");
18210 -- Set new policy, but always preserve System_Location since we
18211 -- like the error message with the run time name.
18214 Partition_Elaboration_Policy
:= PEP
;
18216 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
18217 Partition_Elaboration_Policy_Sloc
:= Loc
;
18226 -- pragma Passive [(PASSIVE_FORM)];
18228 -- PASSIVE_FORM ::= Semaphore | No
18230 when Pragma_Passive
=>
18233 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
18234 Error_Pragma
("pragma% must be within task definition");
18237 if Arg_Count
/= 0 then
18238 Check_Arg_Count
(1);
18239 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
18242 ----------------------------------
18243 -- Preelaborable_Initialization --
18244 ----------------------------------
18246 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18248 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
18253 Check_Arg_Count
(1);
18254 Check_No_Identifiers
;
18255 Check_Arg_Is_Identifier
(Arg1
);
18256 Check_Arg_Is_Local_Name
(Arg1
);
18257 Check_First_Subtype
(Arg1
);
18258 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18260 -- A pragma that applies to a Ghost entity becomes Ghost for the
18261 -- purposes of legality checks and removal of ignored Ghost code.
18263 Mark_Pragma_As_Ghost
(N
, Ent
);
18265 -- The pragma may come from an aspect on a private declaration,
18266 -- even if the freeze point at which this is analyzed in the
18267 -- private part after the full view.
18269 if Has_Private_Declaration
(Ent
)
18270 and then From_Aspect_Specification
(N
)
18274 -- Check appropriate type argument
18276 elsif Is_Private_Type
(Ent
)
18277 or else Is_Protected_Type
(Ent
)
18278 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
18280 -- AI05-0028: The pragma applies to all composite types. Note
18281 -- that we apply this binding interpretation to earlier versions
18282 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18283 -- choice since there are other compilers that do the same.
18285 or else Is_Composite_Type
(Ent
)
18291 ("pragma % can only be applied to private, formal derived, "
18292 & "protected, or composite type", Arg1
);
18295 -- Give an error if the pragma is applied to a protected type that
18296 -- does not qualify (due to having entries, or due to components
18297 -- that do not qualify).
18299 if Is_Protected_Type
(Ent
)
18300 and then not Has_Preelaborable_Initialization
(Ent
)
18303 ("protected type & does not have preelaborable "
18304 & "initialization", Ent
);
18306 -- Otherwise mark the type as definitely having preelaborable
18310 Set_Known_To_Have_Preelab_Init
(Ent
);
18313 if Has_Pragma_Preelab_Init
(Ent
)
18314 and then Warn_On_Redundant_Constructs
18316 Error_Pragma
("?r?duplicate pragma%!");
18318 Set_Has_Pragma_Preelab_Init
(Ent
);
18322 --------------------
18323 -- Persistent_BSS --
18324 --------------------
18326 -- pragma Persistent_BSS [(object_NAME)];
18328 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
18335 Check_At_Most_N_Arguments
(1);
18337 -- Case of application to specific object (one argument)
18339 if Arg_Count
= 1 then
18340 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18342 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
18344 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
18347 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
18350 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18351 Decl
:= Parent
(Ent
);
18353 -- A pragma that applies to a Ghost entity becomes Ghost for
18354 -- the purposes of legality checks and removal of ignored Ghost
18357 Mark_Pragma_As_Ghost
(N
, Ent
);
18359 -- Check for duplication before inserting in list of
18360 -- representation items.
18362 Check_Duplicate_Pragma
(Ent
);
18364 if Rep_Item_Too_Late
(Ent
, N
) then
18368 if Present
(Expression
(Decl
)) then
18370 ("object for pragma% cannot have initialization", Arg1
);
18373 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
18375 ("object type for pragma% is not potentially persistent",
18380 Make_Linker_Section_Pragma
18381 (Ent
, Sloc
(N
), ".persistent.bss");
18382 Insert_After
(N
, Prag
);
18385 -- Case of use as configuration pragma with no arguments
18388 Check_Valid_Configuration_Pragma
;
18389 Persistent_BSS_Mode
:= True;
18391 end Persistent_BSS
;
18397 -- pragma Polling (ON | OFF);
18399 when Pragma_Polling
=>
18401 Check_Arg_Count
(1);
18402 Check_No_Identifiers
;
18403 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
18404 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
18406 -----------------------------------
18407 -- Post/Post_Class/Postcondition --
18408 -----------------------------------
18410 -- pragma Post (Boolean_EXPRESSION);
18411 -- pragma Post_Class (Boolean_EXPRESSION);
18412 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18413 -- [,[Message =>] String_EXPRESSION]);
18415 -- Characteristics:
18417 -- * Analysis - The annotation undergoes initial checks to verify
18418 -- the legal placement and context. Secondary checks preanalyze the
18421 -- Analyze_Pre_Post_Condition_In_Decl_Part
18423 -- * Expansion - The annotation is expanded during the expansion of
18424 -- the related subprogram [body] contract as performed in:
18426 -- Expand_Subprogram_Contract
18428 -- * Template - The annotation utilizes the generic template of the
18429 -- related subprogram [body] when it is:
18431 -- aspect on subprogram declaration
18432 -- aspect on stand alone subprogram body
18433 -- pragma on stand alone subprogram body
18435 -- The annotation must prepare its own template when it is:
18437 -- pragma on subprogram declaration
18439 -- * Globals - Capture of global references must occur after full
18442 -- * Instance - The annotation is instantiated automatically when
18443 -- the related generic subprogram [body] is instantiated except for
18444 -- the "pragma on subprogram declaration" case. In that scenario
18445 -- the annotation must instantiate itself.
18448 Pragma_Post_Class |
18449 Pragma_Postcondition
=>
18450 Analyze_Pre_Post_Condition
;
18452 --------------------------------
18453 -- Pre/Pre_Class/Precondition --
18454 --------------------------------
18456 -- pragma Pre (Boolean_EXPRESSION);
18457 -- pragma Pre_Class (Boolean_EXPRESSION);
18458 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18459 -- [,[Message =>] String_EXPRESSION]);
18461 -- Characteristics:
18463 -- * Analysis - The annotation undergoes initial checks to verify
18464 -- the legal placement and context. Secondary checks preanalyze the
18467 -- Analyze_Pre_Post_Condition_In_Decl_Part
18469 -- * Expansion - The annotation is expanded during the expansion of
18470 -- the related subprogram [body] contract as performed in:
18472 -- Expand_Subprogram_Contract
18474 -- * Template - The annotation utilizes the generic template of the
18475 -- related subprogram [body] when it is:
18477 -- aspect on subprogram declaration
18478 -- aspect on stand alone subprogram body
18479 -- pragma on stand alone subprogram body
18481 -- The annotation must prepare its own template when it is:
18483 -- pragma on subprogram declaration
18485 -- * Globals - Capture of global references must occur after full
18488 -- * Instance - The annotation is instantiated automatically when
18489 -- the related generic subprogram [body] is instantiated except for
18490 -- the "pragma on subprogram declaration" case. In that scenario
18491 -- the annotation must instantiate itself.
18495 Pragma_Precondition
=>
18496 Analyze_Pre_Post_Condition
;
18502 -- pragma Predicate
18503 -- ([Entity =>] type_LOCAL_NAME,
18504 -- [Check =>] boolean_EXPRESSION);
18506 when Pragma_Predicate
=> Predicate
: declare
18513 Check_Arg_Count
(2);
18514 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18515 Check_Optional_Identifier
(Arg2
, Name_Check
);
18517 Check_Arg_Is_Local_Name
(Arg1
);
18519 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18520 Find_Type
(Type_Id
);
18521 Typ
:= Entity
(Type_Id
);
18523 if Typ
= Any_Type
then
18527 -- A pragma that applies to a Ghost entity becomes Ghost for the
18528 -- purposes of legality checks and removal of ignored Ghost code.
18530 Mark_Pragma_As_Ghost
(N
, Typ
);
18532 -- The remaining processing is simply to link the pragma on to
18533 -- the rep item chain, for processing when the type is frozen.
18534 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18535 -- mark the type as having predicates.
18537 Set_Has_Predicates
(Typ
);
18538 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18541 -----------------------
18542 -- Predicate_Failure --
18543 -----------------------
18545 -- pragma Predicate_Failure
18546 -- ([Entity =>] type_LOCAL_NAME,
18547 -- [Message =>] string_EXPRESSION);
18549 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
18556 Check_Arg_Count
(2);
18557 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18558 Check_Optional_Identifier
(Arg2
, Name_Message
);
18560 Check_Arg_Is_Local_Name
(Arg1
);
18562 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18563 Find_Type
(Type_Id
);
18564 Typ
:= Entity
(Type_Id
);
18566 if Typ
= Any_Type
then
18570 -- A pragma that applies to a Ghost entity becomes Ghost for the
18571 -- purposes of legality checks and removal of ignored Ghost code.
18573 Mark_Pragma_As_Ghost
(N
, Typ
);
18575 -- The remaining processing is simply to link the pragma on to
18576 -- the rep item chain, for processing when the type is frozen.
18577 -- This is accomplished by a call to Rep_Item_Too_Late.
18579 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18580 end Predicate_Failure
;
18586 -- pragma Preelaborate [(library_unit_NAME)];
18588 -- Set the flag Is_Preelaborated of program unit name entity
18590 when Pragma_Preelaborate
=> Preelaborate
: declare
18591 Pa
: constant Node_Id
:= Parent
(N
);
18592 Pk
: constant Node_Kind
:= Nkind
(Pa
);
18596 Check_Ada_83_Warning
;
18597 Check_Valid_Library_Unit_Pragma
;
18599 if Nkind
(N
) = N_Null_Statement
then
18603 Ent
:= Find_Lib_Unit_Name
;
18605 -- A pragma that applies to a Ghost entity becomes Ghost for the
18606 -- purposes of legality checks and removal of ignored Ghost code.
18608 Mark_Pragma_As_Ghost
(N
, Ent
);
18609 Check_Duplicate_Pragma
(Ent
);
18611 -- This filters out pragmas inside generic parents that show up
18612 -- inside instantiations. Pragmas that come from aspects in the
18613 -- unit are not ignored.
18615 if Present
(Ent
) then
18616 if Pk
= N_Package_Specification
18617 and then Present
(Generic_Parent
(Pa
))
18618 and then not From_Aspect_Specification
(N
)
18623 if not Debug_Flag_U
then
18624 Set_Is_Preelaborated
(Ent
);
18625 Set_Suppress_Elaboration_Warnings
(Ent
);
18631 -------------------------------
18632 -- Prefix_Exception_Messages --
18633 -------------------------------
18635 -- pragma Prefix_Exception_Messages;
18637 when Pragma_Prefix_Exception_Messages
=>
18639 Check_Valid_Configuration_Pragma
;
18640 Check_Arg_Count
(0);
18641 Prefix_Exception_Messages
:= True;
18647 -- pragma Priority (EXPRESSION);
18649 when Pragma_Priority
=> Priority
: declare
18650 P
: constant Node_Id
:= Parent
(N
);
18655 Check_No_Identifiers
;
18656 Check_Arg_Count
(1);
18660 if Nkind
(P
) = N_Subprogram_Body
then
18661 Check_In_Main_Program
;
18663 Ent
:= Defining_Unit_Name
(Specification
(P
));
18665 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18666 Ent
:= Defining_Identifier
(Ent
);
18669 Arg
:= Get_Pragma_Arg
(Arg1
);
18670 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18674 if not Is_OK_Static_Expression
(Arg
) then
18675 Flag_Non_Static_Expr
18676 ("main subprogram priority is not static!", Arg
);
18679 -- If constraint error, then we already signalled an error
18681 elsif Raises_Constraint_Error
(Arg
) then
18684 -- Otherwise check in range except if Relaxed_RM_Semantics
18685 -- where we ignore the value if out of range.
18689 Val
: constant Uint
:= Expr_Value
(Arg
);
18691 if not Relaxed_RM_Semantics
18694 or else Val
> Expr_Value
(Expression
18695 (Parent
(RTE
(RE_Max_Priority
)))))
18698 ("main subprogram priority is out of range", Arg1
);
18701 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18706 -- Load an arbitrary entity from System.Tasking.Stages or
18707 -- System.Tasking.Restricted.Stages (depending on the
18708 -- supported profile) to make sure that one of these packages
18709 -- is implicitly with'ed, since we need to have the tasking
18710 -- run time active for the pragma Priority to have any effect.
18711 -- Previously we with'ed the package System.Tasking, but this
18712 -- package does not trigger the required initialization of the
18713 -- run-time library.
18716 Discard
: Entity_Id
;
18717 pragma Warnings
(Off
, Discard
);
18719 if Restricted_Profile
then
18720 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18722 Discard
:= RTE
(RE_Activate_Tasks
);
18726 -- Task or Protected, must be of type Integer
18728 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18729 Arg
:= Get_Pragma_Arg
(Arg1
);
18730 Ent
:= Defining_Identifier
(Parent
(P
));
18732 -- The expression must be analyzed in the special manner
18733 -- described in "Handling of Default and Per-Object
18734 -- Expressions" in sem.ads.
18736 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18738 if not Is_OK_Static_Expression
(Arg
) then
18739 Check_Restriction
(Static_Priorities
, Arg
);
18742 -- Anything else is incorrect
18748 -- Check duplicate pragma before we chain the pragma in the Rep
18749 -- Item chain of Ent.
18751 Check_Duplicate_Pragma
(Ent
);
18752 Record_Rep_Item
(Ent
, N
);
18755 -----------------------------------
18756 -- Priority_Specific_Dispatching --
18757 -----------------------------------
18759 -- pragma Priority_Specific_Dispatching (
18760 -- policy_IDENTIFIER,
18761 -- first_priority_EXPRESSION,
18762 -- last_priority_EXPRESSION);
18764 when Pragma_Priority_Specific_Dispatching
=>
18765 Priority_Specific_Dispatching
: declare
18766 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18767 -- This is the entity System.Any_Priority;
18770 Lower_Bound
: Node_Id
;
18771 Upper_Bound
: Node_Id
;
18777 Check_Arg_Count
(3);
18778 Check_No_Identifiers
;
18779 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18780 Check_Valid_Configuration_Pragma
;
18781 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18782 DP
:= Fold_Upper
(Name_Buffer
(1));
18784 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18785 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
18786 Lower_Val
:= Expr_Value
(Lower_Bound
);
18788 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18789 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
18790 Upper_Val
:= Expr_Value
(Upper_Bound
);
18792 -- It is not allowed to use Task_Dispatching_Policy and
18793 -- Priority_Specific_Dispatching in the same partition.
18795 if Task_Dispatching_Policy
/= ' ' then
18796 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18798 ("pragma% incompatible with Task_Dispatching_Policy#");
18800 -- Check lower bound in range
18802 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18804 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18807 ("first_priority is out of range", Arg2
);
18809 -- Check upper bound in range
18811 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18813 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18816 ("last_priority is out of range", Arg3
);
18818 -- Check that the priority range is valid
18820 elsif Lower_Val
> Upper_Val
then
18822 ("last_priority_expression must be greater than or equal to "
18823 & "first_priority_expression");
18825 -- Store the new policy, but always preserve System_Location since
18826 -- we like the error message with the run-time name.
18829 -- Check overlapping in the priority ranges specified in other
18830 -- Priority_Specific_Dispatching pragmas within the same
18831 -- partition. We can only check those we know about.
18834 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18836 if Specific_Dispatching
.Table
(J
).First_Priority
in
18837 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18838 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18839 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18842 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18844 ("priority range overlaps with "
18845 & "Priority_Specific_Dispatching#");
18849 -- The use of Priority_Specific_Dispatching is incompatible
18850 -- with Task_Dispatching_Policy.
18852 if Task_Dispatching_Policy
/= ' ' then
18853 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18855 ("Priority_Specific_Dispatching incompatible "
18856 & "with Task_Dispatching_Policy#");
18859 -- The use of Priority_Specific_Dispatching forces ceiling
18862 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18863 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18865 ("Priority_Specific_Dispatching incompatible "
18866 & "with Locking_Policy#");
18868 -- Set the Ceiling_Locking policy, but preserve System_Location
18869 -- since we like the error message with the run time name.
18872 Locking_Policy
:= 'C';
18874 if Locking_Policy_Sloc
/= System_Location
then
18875 Locking_Policy_Sloc
:= Loc
;
18879 -- Add entry in the table
18881 Specific_Dispatching
.Append
18882 ((Dispatching_Policy
=> DP
,
18883 First_Priority
=> UI_To_Int
(Lower_Val
),
18884 Last_Priority
=> UI_To_Int
(Upper_Val
),
18885 Pragma_Loc
=> Loc
));
18887 end Priority_Specific_Dispatching
;
18893 -- pragma Profile (profile_IDENTIFIER);
18895 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18897 when Pragma_Profile
=>
18899 Check_Arg_Count
(1);
18900 Check_Valid_Configuration_Pragma
;
18901 Check_No_Identifiers
;
18904 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18907 if Chars
(Argx
) = Name_Ravenscar
then
18908 Set_Ravenscar_Profile
(Ravenscar
, N
);
18910 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
18911 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
18913 elsif Chars
(Argx
) = Name_Restricted
then
18914 Set_Profile_Restrictions
18916 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18918 elsif Chars
(Argx
) = Name_Rational
then
18919 Set_Rational_Profile
;
18921 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18922 Set_Profile_Restrictions
18923 (No_Implementation_Extensions
,
18924 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18927 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18931 ----------------------
18932 -- Profile_Warnings --
18933 ----------------------
18935 -- pragma Profile_Warnings (profile_IDENTIFIER);
18937 -- profile_IDENTIFIER => Restricted | Ravenscar
18939 when Pragma_Profile_Warnings
=>
18941 Check_Arg_Count
(1);
18942 Check_Valid_Configuration_Pragma
;
18943 Check_No_Identifiers
;
18946 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18949 if Chars
(Argx
) = Name_Ravenscar
then
18950 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18952 elsif Chars
(Argx
) = Name_Restricted
then
18953 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18955 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18956 Set_Profile_Restrictions
18957 (No_Implementation_Extensions
, N
, Warn
=> True);
18960 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18964 --------------------------
18965 -- Propagate_Exceptions --
18966 --------------------------
18968 -- pragma Propagate_Exceptions;
18970 -- Note: this pragma is obsolete and has no effect
18972 when Pragma_Propagate_Exceptions
=>
18974 Check_Arg_Count
(0);
18976 if Warn_On_Obsolescent_Feature
then
18978 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18979 "and has no effect?j?", N
);
18982 -----------------------------
18983 -- Provide_Shift_Operators --
18984 -----------------------------
18986 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18988 when Pragma_Provide_Shift_Operators
=>
18989 Provide_Shift_Operators
: declare
18992 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18993 -- Insert declaration and pragma Instrinsic for named shift op
18995 ----------------------------
18996 -- Declare_Shift_Operator --
18997 ----------------------------
18999 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
19005 Make_Subprogram_Declaration
(Loc
,
19006 Make_Function_Specification
(Loc
,
19007 Defining_Unit_Name
=>
19008 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
19010 Result_Definition
=>
19011 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
19013 Parameter_Specifications
=> New_List
(
19014 Make_Parameter_Specification
(Loc
,
19015 Defining_Identifier
=>
19016 Make_Defining_Identifier
(Loc
, Name_Value
),
19018 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
19020 Make_Parameter_Specification
(Loc
,
19021 Defining_Identifier
=>
19022 Make_Defining_Identifier
(Loc
, Name_Amount
),
19024 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
19028 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
19029 Pragma_Argument_Associations
=> New_List
(
19030 Make_Pragma_Argument_Association
(Loc
,
19031 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
19032 Make_Pragma_Argument_Association
(Loc
,
19033 Expression
=> Make_Identifier
(Loc
, Nam
))));
19035 Insert_After
(N
, Import
);
19036 Insert_After
(N
, Func
);
19037 end Declare_Shift_Operator
;
19039 -- Start of processing for Provide_Shift_Operators
19043 Check_Arg_Count
(1);
19044 Check_Arg_Is_Local_Name
(Arg1
);
19046 Arg1
:= Get_Pragma_Arg
(Arg1
);
19048 -- We must have an entity name
19050 if not Is_Entity_Name
(Arg1
) then
19052 ("pragma % must apply to integer first subtype", Arg1
);
19055 -- If no Entity, means there was a prior error so ignore
19057 if Present
(Entity
(Arg1
)) then
19058 Ent
:= Entity
(Arg1
);
19060 -- Apply error checks
19062 if not Is_First_Subtype
(Ent
) then
19064 ("cannot apply pragma %",
19065 "\& is not a first subtype",
19068 elsif not Is_Integer_Type
(Ent
) then
19070 ("cannot apply pragma %",
19071 "\& is not an integer type",
19074 elsif Has_Shift_Operator
(Ent
) then
19076 ("cannot apply pragma %",
19077 "\& already has declared shift operators",
19080 elsif Is_Frozen
(Ent
) then
19082 ("pragma % appears too late",
19083 "\& is already frozen",
19087 -- Now declare the operators. We do this during analysis rather
19088 -- than expansion, since we want the operators available if we
19089 -- are operating in -gnatc or ASIS mode.
19091 Declare_Shift_Operator
(Name_Rotate_Left
);
19092 Declare_Shift_Operator
(Name_Rotate_Right
);
19093 Declare_Shift_Operator
(Name_Shift_Left
);
19094 Declare_Shift_Operator
(Name_Shift_Right
);
19095 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
19097 end Provide_Shift_Operators
;
19103 -- pragma Psect_Object (
19104 -- [Internal =>] LOCAL_NAME,
19105 -- [, [External =>] EXTERNAL_SYMBOL]
19106 -- [, [Size =>] EXTERNAL_SYMBOL]);
19108 when Pragma_Psect_Object | Pragma_Common_Object
=>
19109 Psect_Object
: declare
19110 Args
: Args_List
(1 .. 3);
19111 Names
: constant Name_List
(1 .. 3) := (
19116 Internal
: Node_Id
renames Args
(1);
19117 External
: Node_Id
renames Args
(2);
19118 Size
: Node_Id
renames Args
(3);
19120 Def_Id
: Entity_Id
;
19122 procedure Check_Arg
(Arg
: Node_Id
);
19123 -- Checks that argument is either a string literal or an
19124 -- identifier, and posts error message if not.
19130 procedure Check_Arg
(Arg
: Node_Id
) is
19132 if not Nkind_In
(Original_Node
(Arg
),
19137 ("inappropriate argument for pragma %", Arg
);
19141 -- Start of processing for Common_Object/Psect_Object
19145 Gather_Associations
(Names
, Args
);
19146 Process_Extended_Import_Export_Internal_Arg
(Internal
);
19148 Def_Id
:= Entity
(Internal
);
19150 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
19152 ("pragma% must designate an object", Internal
);
19155 Check_Arg
(Internal
);
19157 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
19159 ("cannot use pragma% for imported/exported object",
19163 if Is_Concurrent_Type
(Etype
(Internal
)) then
19165 ("cannot specify pragma % for task/protected object",
19169 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
19171 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
19173 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
19176 if Ekind
(Def_Id
) = E_Constant
then
19178 ("cannot specify pragma % for a constant", Internal
);
19181 if Is_Record_Type
(Etype
(Internal
)) then
19187 Ent
:= First_Entity
(Etype
(Internal
));
19188 while Present
(Ent
) loop
19189 Decl
:= Declaration_Node
(Ent
);
19191 if Ekind
(Ent
) = E_Component
19192 and then Nkind
(Decl
) = N_Component_Declaration
19193 and then Present
(Expression
(Decl
))
19194 and then Warn_On_Export_Import
19197 ("?x?object for pragma % has defaults", Internal
);
19207 if Present
(Size
) then
19211 if Present
(External
) then
19212 Check_Arg_Is_External_Name
(External
);
19215 -- If all error tests pass, link pragma on to the rep item chain
19217 Record_Rep_Item
(Def_Id
, N
);
19224 -- pragma Pure [(library_unit_NAME)];
19226 when Pragma_Pure
=> Pure
: declare
19230 Check_Ada_83_Warning
;
19231 Check_Valid_Library_Unit_Pragma
;
19233 if Nkind
(N
) = N_Null_Statement
then
19237 Ent
:= Find_Lib_Unit_Name
;
19239 -- A pragma that applies to a Ghost entity becomes Ghost for the
19240 -- purposes of legality checks and removal of ignored Ghost code.
19242 Mark_Pragma_As_Ghost
(N
, Ent
);
19244 if not Debug_Flag_U
then
19246 Set_Has_Pragma_Pure
(Ent
);
19247 Set_Suppress_Elaboration_Warnings
(Ent
);
19251 -------------------
19252 -- Pure_Function --
19253 -------------------
19255 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19257 when Pragma_Pure_Function
=> Pure_Function
: declare
19258 Def_Id
: Entity_Id
;
19261 Effective
: Boolean := False;
19265 Check_Arg_Count
(1);
19266 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19267 Check_Arg_Is_Local_Name
(Arg1
);
19268 E_Id
:= Get_Pragma_Arg
(Arg1
);
19270 if Error_Posted
(E_Id
) then
19274 -- Loop through homonyms (overloadings) of referenced entity
19276 E
:= Entity
(E_Id
);
19278 -- A pragma that applies to a Ghost entity becomes Ghost for the
19279 -- purposes of legality checks and removal of ignored Ghost code.
19281 Mark_Pragma_As_Ghost
(N
, E
);
19283 if Present
(E
) then
19285 Def_Id
:= Get_Base_Subprogram
(E
);
19287 if not Ekind_In
(Def_Id
, E_Function
,
19288 E_Generic_Function
,
19292 ("pragma% requires a function name", Arg1
);
19295 Set_Is_Pure
(Def_Id
);
19297 if not Has_Pragma_Pure_Function
(Def_Id
) then
19298 Set_Has_Pragma_Pure_Function
(Def_Id
);
19302 exit when From_Aspect_Specification
(N
);
19304 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
19308 and then Warn_On_Redundant_Constructs
19311 ("pragma Pure_Function on& is redundant?r?",
19317 --------------------
19318 -- Queuing_Policy --
19319 --------------------
19321 -- pragma Queuing_Policy (policy_IDENTIFIER);
19323 when Pragma_Queuing_Policy
=> declare
19327 Check_Ada_83_Warning
;
19328 Check_Arg_Count
(1);
19329 Check_No_Identifiers
;
19330 Check_Arg_Is_Queuing_Policy
(Arg1
);
19331 Check_Valid_Configuration_Pragma
;
19332 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
19333 QP
:= Fold_Upper
(Name_Buffer
(1));
19335 if Queuing_Policy
/= ' '
19336 and then Queuing_Policy
/= QP
19338 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
19339 Error_Pragma
("queuing policy incompatible with policy#");
19341 -- Set new policy, but always preserve System_Location since we
19342 -- like the error message with the run time name.
19345 Queuing_Policy
:= QP
;
19347 if Queuing_Policy_Sloc
/= System_Location
then
19348 Queuing_Policy_Sloc
:= Loc
;
19357 -- pragma Rational, for compatibility with foreign compiler
19359 when Pragma_Rational
=>
19360 Set_Rational_Profile
;
19362 ---------------------
19363 -- Refined_Depends --
19364 ---------------------
19366 -- pragma Refined_Depends (DEPENDENCY_RELATION);
19368 -- DEPENDENCY_RELATION ::=
19370 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
19372 -- DEPENDENCY_CLAUSE ::=
19373 -- OUTPUT_LIST =>[+] INPUT_LIST
19374 -- | NULL_DEPENDENCY_CLAUSE
19376 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19378 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19380 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19382 -- OUTPUT ::= NAME | FUNCTION_RESULT
19385 -- where FUNCTION_RESULT is a function Result attribute_reference
19387 -- Characteristics:
19389 -- * Analysis - The annotation undergoes initial checks to verify
19390 -- the legal placement and context. Secondary checks fully analyze
19391 -- the dependency clauses/global list in:
19393 -- Analyze_Refined_Depends_In_Decl_Part
19395 -- * Expansion - None.
19397 -- * Template - The annotation utilizes the generic template of the
19398 -- related subprogram body.
19400 -- * Globals - Capture of global references must occur after full
19403 -- * Instance - The annotation is instantiated automatically when
19404 -- the related generic subprogram body is instantiated.
19406 when Pragma_Refined_Depends
=> Refined_Depends
: declare
19407 Body_Id
: Entity_Id
;
19409 Spec_Id
: Entity_Id
;
19412 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
19416 -- Chain the pragma on the contract for further processing by
19417 -- Analyze_Refined_Depends_In_Decl_Part.
19419 Add_Contract_Item
(N
, Body_Id
);
19421 -- The legality checks of pragmas Refined_Depends and
19422 -- Refined_Global are affected by the SPARK mode in effect and
19423 -- the volatility of the context. In addition these two pragmas
19424 -- are subject to an inherent order:
19426 -- 1) Refined_Global
19427 -- 2) Refined_Depends
19429 -- Analyze all these pragmas in the order outlined above
19431 Analyze_If_Present
(Pragma_SPARK_Mode
);
19432 Analyze_If_Present
(Pragma_Volatile_Function
);
19433 Analyze_If_Present
(Pragma_Refined_Global
);
19434 Analyze_Refined_Depends_In_Decl_Part
(N
);
19436 end Refined_Depends
;
19438 --------------------
19439 -- Refined_Global --
19440 --------------------
19442 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
19444 -- GLOBAL_SPECIFICATION ::=
19447 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
19449 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
19451 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
19452 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
19453 -- GLOBAL_ITEM ::= NAME
19455 -- Characteristics:
19457 -- * Analysis - The annotation undergoes initial checks to verify
19458 -- the legal placement and context. Secondary checks fully analyze
19459 -- the dependency clauses/global list in:
19461 -- Analyze_Refined_Global_In_Decl_Part
19463 -- * Expansion - None.
19465 -- * Template - The annotation utilizes the generic template of the
19466 -- related subprogram body.
19468 -- * Globals - Capture of global references must occur after full
19471 -- * Instance - The annotation is instantiated automatically when
19472 -- the related generic subprogram body is instantiated.
19474 when Pragma_Refined_Global
=> Refined_Global
: declare
19475 Body_Id
: Entity_Id
;
19477 Spec_Id
: Entity_Id
;
19480 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
19484 -- Chain the pragma on the contract for further processing by
19485 -- Analyze_Refined_Global_In_Decl_Part.
19487 Add_Contract_Item
(N
, Body_Id
);
19489 -- The legality checks of pragmas Refined_Depends and
19490 -- Refined_Global are affected by the SPARK mode in effect and
19491 -- the volatility of the context. In addition these two pragmas
19492 -- are subject to an inherent order:
19494 -- 1) Refined_Global
19495 -- 2) Refined_Depends
19497 -- Analyze all these pragmas in the order outlined above
19499 Analyze_If_Present
(Pragma_SPARK_Mode
);
19500 Analyze_If_Present
(Pragma_Volatile_Function
);
19501 Analyze_Refined_Global_In_Decl_Part
(N
);
19502 Analyze_If_Present
(Pragma_Refined_Depends
);
19504 end Refined_Global
;
19510 -- pragma Refined_Post (boolean_EXPRESSION);
19512 -- Characteristics:
19514 -- * Analysis - The annotation is fully analyzed immediately upon
19515 -- elaboration as it cannot forward reference entities.
19517 -- * Expansion - The annotation is expanded during the expansion of
19518 -- the related subprogram body contract as performed in:
19520 -- Expand_Subprogram_Contract
19522 -- * Template - The annotation utilizes the generic template of the
19523 -- related subprogram body.
19525 -- * Globals - Capture of global references must occur after full
19528 -- * Instance - The annotation is instantiated automatically when
19529 -- the related generic subprogram body is instantiated.
19531 when Pragma_Refined_Post
=> Refined_Post
: declare
19532 Body_Id
: Entity_Id
;
19534 Spec_Id
: Entity_Id
;
19537 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
19539 -- Fully analyze the pragma when it appears inside a subprogram
19540 -- body because it cannot benefit from forward references.
19544 -- Chain the pragma on the contract for completeness
19546 Add_Contract_Item
(N
, Body_Id
);
19548 -- The legality checks of pragma Refined_Post are affected by
19549 -- the SPARK mode in effect and the volatility of the context.
19550 -- Analyze all pragmas in a specific order.
19552 Analyze_If_Present
(Pragma_SPARK_Mode
);
19553 Analyze_If_Present
(Pragma_Volatile_Function
);
19554 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
19556 -- Currently it is not possible to inline pre/postconditions on
19557 -- a subprogram subject to pragma Inline_Always.
19559 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
19563 -------------------
19564 -- Refined_State --
19565 -------------------
19567 -- pragma Refined_State (REFINEMENT_LIST);
19569 -- REFINEMENT_LIST ::=
19570 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19572 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19574 -- CONSTITUENT_LIST ::=
19577 -- | (CONSTITUENT {, CONSTITUENT})
19579 -- CONSTITUENT ::= object_NAME | state_NAME
19581 -- Characteristics:
19583 -- * Analysis - The annotation undergoes initial checks to verify
19584 -- the legal placement and context. Secondary checks preanalyze the
19585 -- refinement clauses in:
19587 -- Analyze_Refined_State_In_Decl_Part
19589 -- * Expansion - None.
19591 -- * Template - The annotation utilizes the template of the related
19594 -- * Globals - Capture of global references must occur after full
19597 -- * Instance - The annotation is instantiated automatically when
19598 -- the related generic package body is instantiated.
19600 when Pragma_Refined_State
=> Refined_State
: declare
19601 Pack_Decl
: Node_Id
;
19602 Spec_Id
: Entity_Id
;
19606 Check_No_Identifiers
;
19607 Check_Arg_Count
(1);
19609 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
19611 -- Ensure the proper placement of the pragma. Refined states must
19612 -- be associated with a package body.
19614 if Nkind
(Pack_Decl
) = N_Package_Body
then
19617 -- Otherwise the pragma is associated with an illegal construct
19624 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
19626 -- Chain the pragma on the contract for further processing by
19627 -- Analyze_Refined_State_In_Decl_Part.
19629 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
19631 -- The legality checks of pragma Refined_State are affected by the
19632 -- SPARK mode in effect. Analyze all pragmas in a specific order.
19634 Analyze_If_Present
(Pragma_SPARK_Mode
);
19636 -- A pragma that applies to a Ghost entity becomes Ghost for the
19637 -- purposes of legality checks and removal of ignored Ghost code.
19639 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
19641 -- State refinement is allowed only when the corresponding package
19642 -- declaration has non-null pragma Abstract_State. Refinement not
19643 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19645 if SPARK_Mode
/= Off
19647 (No
(Abstract_States
(Spec_Id
))
19648 or else Has_Null_Abstract_State
(Spec_Id
))
19651 ("useless refinement, package & does not define abstract "
19652 & "states", N
, Spec_Id
);
19657 -----------------------
19658 -- Relative_Deadline --
19659 -----------------------
19661 -- pragma Relative_Deadline (time_span_EXPRESSION);
19663 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
19664 P
: constant Node_Id
:= Parent
(N
);
19669 Check_No_Identifiers
;
19670 Check_Arg_Count
(1);
19672 Arg
:= Get_Pragma_Arg
(Arg1
);
19674 -- The expression must be analyzed in the special manner described
19675 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19677 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
19681 if Nkind
(P
) = N_Subprogram_Body
then
19682 Check_In_Main_Program
;
19684 -- Only Task and subprogram cases allowed
19686 elsif Nkind
(P
) /= N_Task_Definition
then
19690 -- Check duplicate pragma before we set the corresponding flag
19692 if Has_Relative_Deadline_Pragma
(P
) then
19693 Error_Pragma
("duplicate pragma% not allowed");
19696 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19697 -- Relative_Deadline pragma node cannot be inserted in the Rep
19698 -- Item chain of Ent since it is rewritten by the expander as a
19699 -- procedure call statement that will break the chain.
19701 Set_Has_Relative_Deadline_Pragma
(P
);
19702 end Relative_Deadline
;
19704 ------------------------
19705 -- Remote_Access_Type --
19706 ------------------------
19708 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19710 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
19715 Check_Arg_Count
(1);
19716 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19717 Check_Arg_Is_Local_Name
(Arg1
);
19719 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
19721 -- A pragma that applies to a Ghost entity becomes Ghost for the
19722 -- purposes of legality checks and removal of ignored Ghost code.
19724 Mark_Pragma_As_Ghost
(N
, E
);
19726 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
19727 and then Ekind
(E
) = E_General_Access_Type
19728 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
19729 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
19731 and then Is_Valid_Remote_Object_Type
19732 (Root_Type
(Directly_Designated_Type
(E
)))
19734 Set_Is_Remote_Types
(E
);
19738 ("pragma% applies only to formal access to classwide types",
19741 end Remote_Access_Type
;
19743 ---------------------------
19744 -- Remote_Call_Interface --
19745 ---------------------------
19747 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19749 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19750 Cunit_Node
: Node_Id
;
19751 Cunit_Ent
: Entity_Id
;
19755 Check_Ada_83_Warning
;
19756 Check_Valid_Library_Unit_Pragma
;
19758 if Nkind
(N
) = N_Null_Statement
then
19762 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19763 K
:= Nkind
(Unit
(Cunit_Node
));
19764 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19766 -- A pragma that applies to a Ghost entity becomes Ghost for the
19767 -- purposes of legality checks and removal of ignored Ghost code.
19769 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
19771 if K
= N_Package_Declaration
19772 or else K
= N_Generic_Package_Declaration
19773 or else K
= N_Subprogram_Declaration
19774 or else K
= N_Generic_Subprogram_Declaration
19775 or else (K
= N_Subprogram_Body
19776 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19781 "pragma% must apply to package or subprogram declaration");
19784 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19785 end Remote_Call_Interface
;
19791 -- pragma Remote_Types [(library_unit_NAME)];
19793 when Pragma_Remote_Types
=> Remote_Types
: declare
19794 Cunit_Node
: Node_Id
;
19795 Cunit_Ent
: Entity_Id
;
19798 Check_Ada_83_Warning
;
19799 Check_Valid_Library_Unit_Pragma
;
19801 if Nkind
(N
) = N_Null_Statement
then
19805 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19806 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19808 -- A pragma that applies to a Ghost entity becomes Ghost for the
19809 -- purposes of legality checks and removal of ignored Ghost code.
19811 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
19813 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19814 N_Generic_Package_Declaration
)
19817 ("pragma% can only apply to a package declaration");
19820 Set_Is_Remote_Types
(Cunit_Ent
);
19827 -- pragma Ravenscar;
19829 when Pragma_Ravenscar
=>
19831 Check_Arg_Count
(0);
19832 Check_Valid_Configuration_Pragma
;
19833 Set_Ravenscar_Profile
(Ravenscar
, N
);
19835 if Warn_On_Obsolescent_Feature
then
19837 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19839 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19842 -------------------------
19843 -- Restricted_Run_Time --
19844 -------------------------
19846 -- pragma Restricted_Run_Time;
19848 when Pragma_Restricted_Run_Time
=>
19850 Check_Arg_Count
(0);
19851 Check_Valid_Configuration_Pragma
;
19852 Set_Profile_Restrictions
19853 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19855 if Warn_On_Obsolescent_Feature
then
19857 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19860 ("|use pragma Profile (Restricted) instead?j?", N
);
19867 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19870 -- restriction_IDENTIFIER
19871 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19873 when Pragma_Restrictions
=>
19874 Process_Restrictions_Or_Restriction_Warnings
19875 (Warn
=> Treat_Restrictions_As_Warnings
);
19877 --------------------------
19878 -- Restriction_Warnings --
19879 --------------------------
19881 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19884 -- restriction_IDENTIFIER
19885 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19887 when Pragma_Restriction_Warnings
=>
19889 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19895 -- pragma Reviewable;
19897 when Pragma_Reviewable
=>
19898 Check_Ada_83_Warning
;
19899 Check_Arg_Count
(0);
19901 -- Call dummy debugging function rv. This is done to assist front
19902 -- end debugging. By placing a Reviewable pragma in the source
19903 -- program, a breakpoint on rv catches this place in the source,
19904 -- allowing convenient stepping to the point of interest.
19908 --------------------------
19909 -- Short_Circuit_And_Or --
19910 --------------------------
19912 -- pragma Short_Circuit_And_Or;
19914 when Pragma_Short_Circuit_And_Or
=>
19916 Check_Arg_Count
(0);
19917 Check_Valid_Configuration_Pragma
;
19918 Short_Circuit_And_Or
:= True;
19920 -------------------
19921 -- Share_Generic --
19922 -------------------
19924 -- pragma Share_Generic (GNAME {, GNAME});
19926 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19928 when Pragma_Share_Generic
=>
19930 Process_Generic_List
;
19936 -- pragma Shared (LOCAL_NAME);
19938 when Pragma_Shared
=>
19940 Process_Atomic_Independent_Shared_Volatile
;
19942 --------------------
19943 -- Shared_Passive --
19944 --------------------
19946 -- pragma Shared_Passive [(library_unit_NAME)];
19948 -- Set the flag Is_Shared_Passive of program unit name entity
19950 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19951 Cunit_Node
: Node_Id
;
19952 Cunit_Ent
: Entity_Id
;
19955 Check_Ada_83_Warning
;
19956 Check_Valid_Library_Unit_Pragma
;
19958 if Nkind
(N
) = N_Null_Statement
then
19962 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19963 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19965 -- A pragma that applies to a Ghost entity becomes Ghost for the
19966 -- purposes of legality checks and removal of ignored Ghost code.
19968 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
19970 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19971 N_Generic_Package_Declaration
)
19974 ("pragma% can only apply to a package declaration");
19977 Set_Is_Shared_Passive
(Cunit_Ent
);
19978 end Shared_Passive
;
19980 -----------------------
19981 -- Short_Descriptors --
19982 -----------------------
19984 -- pragma Short_Descriptors;
19986 -- Recognize and validate, but otherwise ignore
19988 when Pragma_Short_Descriptors
=>
19990 Check_Arg_Count
(0);
19991 Check_Valid_Configuration_Pragma
;
19993 ------------------------------
19994 -- Simple_Storage_Pool_Type --
19995 ------------------------------
19997 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19999 when Pragma_Simple_Storage_Pool_Type
=>
20000 Simple_Storage_Pool_Type
: declare
20006 Check_Arg_Count
(1);
20007 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20009 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20010 Find_Type
(Type_Id
);
20011 Typ
:= Entity
(Type_Id
);
20013 if Typ
= Any_Type
then
20017 -- A pragma that applies to a Ghost entity becomes Ghost for the
20018 -- purposes of legality checks and removal of ignored Ghost code.
20020 Mark_Pragma_As_Ghost
(N
, Typ
);
20022 -- We require the pragma to apply to a type declared in a package
20023 -- declaration, but not (immediately) within a package body.
20025 if Ekind
(Current_Scope
) /= E_Package
20026 or else In_Package_Body
(Current_Scope
)
20029 ("pragma% can only apply to type declared immediately "
20030 & "within a package declaration");
20033 -- A simple storage pool type must be an immutably limited record
20034 -- or private type. If the pragma is given for a private type,
20035 -- the full type is similarly restricted (which is checked later
20036 -- in Freeze_Entity).
20038 if Is_Record_Type
(Typ
)
20039 and then not Is_Limited_View
(Typ
)
20042 ("pragma% can only apply to explicitly limited record type");
20044 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
20046 ("pragma% can only apply to a private type that is limited");
20048 elsif not Is_Record_Type
(Typ
)
20049 and then not Is_Private_Type
(Typ
)
20052 ("pragma% can only apply to limited record or private type");
20055 Record_Rep_Item
(Typ
, N
);
20056 end Simple_Storage_Pool_Type
;
20058 ----------------------
20059 -- Source_File_Name --
20060 ----------------------
20062 -- There are five forms for this pragma:
20064 -- pragma Source_File_Name (
20065 -- [UNIT_NAME =>] unit_NAME,
20066 -- BODY_FILE_NAME => STRING_LITERAL
20067 -- [, [INDEX =>] INTEGER_LITERAL]);
20069 -- pragma Source_File_Name (
20070 -- [UNIT_NAME =>] unit_NAME,
20071 -- SPEC_FILE_NAME => STRING_LITERAL
20072 -- [, [INDEX =>] INTEGER_LITERAL]);
20074 -- pragma Source_File_Name (
20075 -- BODY_FILE_NAME => STRING_LITERAL
20076 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20077 -- [, CASING => CASING_SPEC]);
20079 -- pragma Source_File_Name (
20080 -- SPEC_FILE_NAME => STRING_LITERAL
20081 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20082 -- [, CASING => CASING_SPEC]);
20084 -- pragma Source_File_Name (
20085 -- SUBUNIT_FILE_NAME => STRING_LITERAL
20086 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20087 -- [, CASING => CASING_SPEC]);
20089 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
20091 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
20092 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
20093 -- only be used when no project file is used, while SFNP can only be
20094 -- used when a project file is used.
20096 -- No processing here. Processing was completed during parsing, since
20097 -- we need to have file names set as early as possible. Units are
20098 -- loaded well before semantic processing starts.
20100 -- The only processing we defer to this point is the check for
20101 -- correct placement.
20103 when Pragma_Source_File_Name
=>
20105 Check_Valid_Configuration_Pragma
;
20107 ------------------------------
20108 -- Source_File_Name_Project --
20109 ------------------------------
20111 -- See Source_File_Name for syntax
20113 -- No processing here. Processing was completed during parsing, since
20114 -- we need to have file names set as early as possible. Units are
20115 -- loaded well before semantic processing starts.
20117 -- The only processing we defer to this point is the check for
20118 -- correct placement.
20120 when Pragma_Source_File_Name_Project
=>
20122 Check_Valid_Configuration_Pragma
;
20124 -- Check that a pragma Source_File_Name_Project is used only in a
20125 -- configuration pragmas file.
20127 -- Pragmas Source_File_Name_Project should only be generated by
20128 -- the Project Manager in configuration pragmas files.
20130 -- This is really an ugly test. It seems to depend on some
20131 -- accidental and undocumented property. At the very least it
20132 -- needs to be documented, but it would be better to have a
20133 -- clean way of testing if we are in a configuration file???
20135 if Present
(Parent
(N
)) then
20137 ("pragma% can only appear in a configuration pragmas file");
20140 ----------------------
20141 -- Source_Reference --
20142 ----------------------
20144 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
20146 -- Nothing to do, all processing completed in Par.Prag, since we need
20147 -- the information for possible parser messages that are output.
20149 when Pragma_Source_Reference
=>
20156 -- pragma SPARK_Mode [(On | Off)];
20158 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
20159 Mode_Id
: SPARK_Mode_Type
;
20161 procedure Check_Pragma_Conformance
20162 (Context_Pragma
: Node_Id
;
20163 Entity
: Entity_Id
;
20164 Entity_Pragma
: Node_Id
);
20165 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20166 -- conformance of pragma N depending the following scenarios:
20168 -- If pragma Context_Pragma is not Empty, verify that pragma N is
20169 -- compatible with the pragma Context_Pragma that was inherited
20170 -- from the context:
20171 -- * If the mode of Context_Pragma is ON, then the new mode can
20173 -- * If the mode of Context_Pragma is OFF, then the only allowed
20174 -- new mode is also OFF. Emit error if this is not the case.
20176 -- If Entity is not Empty, verify that pragma N is compatible with
20177 -- pragma Entity_Pragma that belongs to Entity.
20178 -- * If Entity_Pragma is Empty, always issue an error as this
20179 -- corresponds to the case where a previous section of Entity
20180 -- has no SPARK_Mode set.
20181 -- * If the mode of Entity_Pragma is ON, then the new mode can
20183 -- * If the mode of Entity_Pragma is OFF, then the only allowed
20184 -- new mode is also OFF. Emit error if this is not the case.
20186 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
20187 -- Subsidiary to routines Process_xxx. Verify that the related
20188 -- entity E subject to pragma SPARK_Mode is library-level.
20190 procedure Process_Body
(Decl
: Node_Id
);
20191 -- Verify the legality of pragma SPARK_Mode when it appears as the
20192 -- top of the body declarations of entry, package, protected unit,
20193 -- subprogram or task unit body denoted by Decl.
20195 procedure Process_Overloadable
(Decl
: Node_Id
);
20196 -- Verify the legality of pragma SPARK_Mode when it applies to an
20197 -- entry or [generic] subprogram declaration denoted by Decl.
20199 procedure Process_Private_Part
(Decl
: Node_Id
);
20200 -- Verify the legality of pragma SPARK_Mode when it appears at the
20201 -- top of the private declarations of a package spec, protected or
20202 -- task unit declaration denoted by Decl.
20204 procedure Process_Statement_Part
(Decl
: Node_Id
);
20205 -- Verify the legality of pragma SPARK_Mode when it appears at the
20206 -- top of the statement sequence of a package body denoted by node
20209 procedure Process_Visible_Part
(Decl
: Node_Id
);
20210 -- Verify the legality of pragma SPARK_Mode when it appears at the
20211 -- top of the visible declarations of a package spec, protected or
20212 -- task unit declaration denoted by Decl. The routine is also used
20213 -- on protected or task units declared without a definition.
20215 procedure Set_SPARK_Context
;
20216 -- Subsidiary to routines Process_xxx. Set the global variables
20217 -- which represent the mode of the context from pragma N. Ensure
20218 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
20220 ------------------------------
20221 -- Check_Pragma_Conformance --
20222 ------------------------------
20224 procedure Check_Pragma_Conformance
20225 (Context_Pragma
: Node_Id
;
20226 Entity
: Entity_Id
;
20227 Entity_Pragma
: Node_Id
)
20229 Err_Id
: Entity_Id
;
20233 -- The current pragma may appear without an argument. If this
20234 -- is the case, associate all error messages with the pragma
20237 if Present
(Arg1
) then
20243 -- The mode of the current pragma is compared against that of
20244 -- an enclosing context.
20246 if Present
(Context_Pragma
) then
20247 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
20249 -- Issue an error if the new mode is less restrictive than
20250 -- that of the context.
20252 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
20253 and then Get_SPARK_Mode_From_Pragma
(N
) = On
20256 ("cannot change SPARK_Mode from Off to On", Err_N
);
20257 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
20258 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
20263 -- The mode of the current pragma is compared against that of
20264 -- an initial package, protected type, subprogram or task type
20267 if Present
(Entity
) then
20269 -- A simple protected or task type is transformed into an
20270 -- anonymous type whose name cannot be used to issue error
20271 -- messages. Recover the original entity of the type.
20273 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
20276 (Original_Node
(Unit_Declaration_Node
(Entity
)));
20281 -- Both the initial declaration and the completion carry
20282 -- SPARK_Mode pragmas.
20284 if Present
(Entity_Pragma
) then
20285 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
20287 -- Issue an error if the new mode is less restrictive
20288 -- than that of the initial declaration.
20290 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
20291 and then Get_SPARK_Mode_From_Pragma
(N
) = On
20293 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
20294 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
20296 ("\value Off was set for SPARK_Mode on&#",
20301 -- Otherwise the initial declaration lacks a SPARK_Mode
20302 -- pragma in which case the current pragma is illegal as
20303 -- it cannot "complete".
20306 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
20307 Error_Msg_Sloc
:= Sloc
(Err_Id
);
20309 ("\no value was set for SPARK_Mode on&#",
20314 end Check_Pragma_Conformance
;
20316 --------------------------------
20317 -- Check_Library_Level_Entity --
20318 --------------------------------
20320 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
20321 procedure Add_Entity_To_Name_Buffer
;
20322 -- Add the E_Kind of entity E to the name buffer
20324 -------------------------------
20325 -- Add_Entity_To_Name_Buffer --
20326 -------------------------------
20328 procedure Add_Entity_To_Name_Buffer
is
20330 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
20331 Add_Str_To_Name_Buffer
("entry");
20333 elsif Ekind_In
(E
, E_Generic_Package
,
20337 Add_Str_To_Name_Buffer
("package");
20339 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
20340 Add_Str_To_Name_Buffer
("protected type");
20342 elsif Ekind_In
(E
, E_Function
,
20343 E_Generic_Function
,
20344 E_Generic_Procedure
,
20348 Add_Str_To_Name_Buffer
("subprogram");
20351 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
20352 Add_Str_To_Name_Buffer
("task type");
20354 end Add_Entity_To_Name_Buffer
;
20358 Msg_1
: constant String := "incorrect placement of pragma%";
20361 -- Start of processing for Check_Library_Level_Entity
20364 if not Is_Library_Level_Entity
(E
) then
20365 Error_Msg_Name_1
:= Pname
;
20366 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
20369 Add_Str_To_Name_Buffer
("\& is not a library-level ");
20370 Add_Entity_To_Name_Buffer
;
20372 Msg_2
:= Name_Find
;
20373 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
20377 end Check_Library_Level_Entity
;
20383 procedure Process_Body
(Decl
: Node_Id
) is
20384 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20385 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
20388 -- Ignore pragma when applied to the special body created for
20389 -- inlining, recognized by its internal name _Parent.
20391 if Chars
(Body_Id
) = Name_uParent
then
20395 Check_Library_Level_Entity
(Body_Id
);
20397 -- For entry bodies, verify the legality against:
20398 -- * The mode of the context
20399 -- * The mode of the spec (if any)
20401 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
20403 -- A stand alone subprogram body
20405 if Body_Id
= Spec_Id
then
20406 Check_Pragma_Conformance
20407 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20409 Entity_Pragma
=> Empty
);
20411 -- An entry or subprogram body that completes a previous
20415 Check_Pragma_Conformance
20416 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20418 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
20422 Set_SPARK_Pragma
(Body_Id
, N
);
20423 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
20425 -- For package bodies, verify the legality against:
20426 -- * The mode of the context
20427 -- * The mode of the private part
20429 -- This case is separated from protected and task bodies
20430 -- because the statement part of the package body inherits
20431 -- the mode of the body declarations.
20433 elsif Nkind
(Decl
) = N_Package_Body
then
20434 Check_Pragma_Conformance
20435 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20437 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
20440 Set_SPARK_Pragma
(Body_Id
, N
);
20441 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
20442 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
20443 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
20445 -- For protected and task bodies, verify the legality against:
20446 -- * The mode of the context
20447 -- * The mode of the private part
20451 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
20453 Check_Pragma_Conformance
20454 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20456 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
20459 Set_SPARK_Pragma
(Body_Id
, N
);
20460 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
20464 --------------------------
20465 -- Process_Overloadable --
20466 --------------------------
20468 procedure Process_Overloadable
(Decl
: Node_Id
) is
20469 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20470 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
20473 Check_Library_Level_Entity
(Spec_Id
);
20475 -- Verify the legality against:
20476 -- * The mode of the context
20478 Check_Pragma_Conformance
20479 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
20481 Entity_Pragma
=> Empty
);
20483 Set_SPARK_Pragma
(Spec_Id
, N
);
20484 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
20486 -- When the pragma applies to the anonymous object created for
20487 -- a single task type, decorate the type as well. This scenario
20488 -- arises when the single task type lacks a task definition,
20489 -- therefore there is no issue with respect to a potential
20490 -- pragma SPARK_Mode in the private part.
20492 -- task type Anon_Task_Typ;
20493 -- Obj : Anon_Task_Typ;
20494 -- pragma SPARK_Mode ...;
20496 if Is_Single_Task_Object
(Spec_Id
) then
20497 Set_SPARK_Pragma
(Spec_Typ
, N
);
20498 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
20499 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
20500 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
20502 end Process_Overloadable
;
20504 --------------------------
20505 -- Process_Private_Part --
20506 --------------------------
20508 procedure Process_Private_Part
(Decl
: Node_Id
) is
20509 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20512 Check_Library_Level_Entity
(Spec_Id
);
20514 -- Verify the legality against:
20515 -- * The mode of the visible declarations
20517 Check_Pragma_Conformance
20518 (Context_Pragma
=> Empty
,
20520 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
20523 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
20524 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
20525 end Process_Private_Part
;
20527 ----------------------------
20528 -- Process_Statement_Part --
20529 ----------------------------
20531 procedure Process_Statement_Part
(Decl
: Node_Id
) is
20532 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20535 Check_Library_Level_Entity
(Body_Id
);
20537 -- Verify the legality against:
20538 -- * The mode of the body declarations
20540 Check_Pragma_Conformance
20541 (Context_Pragma
=> Empty
,
20543 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
20546 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
20547 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
20548 end Process_Statement_Part
;
20550 --------------------------
20551 -- Process_Visible_Part --
20552 --------------------------
20554 procedure Process_Visible_Part
(Decl
: Node_Id
) is
20555 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20556 Obj_Id
: Entity_Id
;
20559 Check_Library_Level_Entity
(Spec_Id
);
20561 -- Verify the legality against:
20562 -- * The mode of the context
20564 Check_Pragma_Conformance
20565 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
20567 Entity_Pragma
=> Empty
);
20569 -- A task unit declared without a definition does not set the
20570 -- SPARK_Mode of the context because the task does not have any
20571 -- entries that could inherit the mode.
20573 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
20574 N_Task_Type_Declaration
)
20579 Set_SPARK_Pragma
(Spec_Id
, N
);
20580 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
20581 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
20582 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
20584 -- When the pragma applies to a single protected or task type,
20585 -- decorate the corresponding anonymous object as well.
20587 -- protected Anon_Prot_Typ is
20588 -- pragma SPARK_Mode ...;
20590 -- end Anon_Prot_Typ;
20592 -- Obj : Anon_Prot_Typ;
20594 if Is_Single_Concurrent_Type
(Spec_Id
) then
20595 Obj_Id
:= Anonymous_Object
(Spec_Id
);
20597 Set_SPARK_Pragma
(Obj_Id
, N
);
20598 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
20600 end Process_Visible_Part
;
20602 -----------------------
20603 -- Set_SPARK_Context --
20604 -----------------------
20606 procedure Set_SPARK_Context
is
20608 SPARK_Mode
:= Mode_Id
;
20609 SPARK_Mode_Pragma
:= N
;
20611 if SPARK_Mode
= On
then
20612 Dynamic_Elaboration_Checks
:= False;
20614 end Set_SPARK_Context
;
20622 -- Start of processing for Do_SPARK_Mode
20625 -- When a SPARK_Mode pragma appears inside an instantiation whose
20626 -- enclosing context has SPARK_Mode set to "off", the pragma has
20627 -- no semantic effect.
20629 if Ignore_Pragma_SPARK_Mode
then
20630 Rewrite
(N
, Make_Null_Statement
(Loc
));
20636 Check_No_Identifiers
;
20637 Check_At_Most_N_Arguments
(1);
20639 -- Check the legality of the mode (no argument = ON)
20641 if Arg_Count
= 1 then
20642 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20643 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
20648 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
20649 Context
:= Parent
(N
);
20651 -- The pragma appears in a configuration pragmas file
20653 if No
(Context
) then
20654 Check_Valid_Configuration_Pragma
;
20656 if Present
(SPARK_Mode_Pragma
) then
20657 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
20658 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
20664 -- The pragma acts as a configuration pragma in a compilation unit
20666 -- pragma SPARK_Mode ...;
20667 -- package Pack is ...;
20669 elsif Nkind
(Context
) = N_Compilation_Unit
20670 and then List_Containing
(N
) = Context_Items
(Context
)
20672 Check_Valid_Configuration_Pragma
;
20675 -- Otherwise the placement of the pragma within the tree dictates
20676 -- its associated construct. Inspect the declarative list where
20677 -- the pragma resides to find a potential construct.
20681 while Present
(Stmt
) loop
20683 -- Skip prior pragmas, but check for duplicates. Note that
20684 -- this also takes care of pragmas generated for aspects.
20686 if Nkind
(Stmt
) = N_Pragma
then
20687 if Pragma_Name
(Stmt
) = Pname
then
20688 Error_Msg_Name_1
:= Pname
;
20689 Error_Msg_Sloc
:= Sloc
(Stmt
);
20690 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
20694 -- The pragma applies to an expression function that has
20695 -- already been rewritten into a subprogram declaration.
20697 -- function Expr_Func return ... is (...);
20698 -- pragma SPARK_Mode ...;
20700 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
20701 and then Nkind
(Original_Node
(Stmt
)) =
20702 N_Expression_Function
20704 Process_Overloadable
(Stmt
);
20707 -- The pragma applies to the anonymous object created for a
20708 -- single concurrent type.
20710 -- protected type Anon_Prot_Typ ...;
20711 -- Obj : Anon_Prot_Typ;
20712 -- pragma SPARK_Mode ...;
20714 elsif Nkind
(Stmt
) = N_Object_Declaration
20715 and then Is_Single_Concurrent_Object
20716 (Defining_Entity
(Stmt
))
20718 Process_Overloadable
(Stmt
);
20721 -- Skip internally generated code
20723 elsif not Comes_From_Source
(Stmt
) then
20726 -- The pragma applies to an entry or [generic] subprogram
20730 -- pragma SPARK_Mode ...;
20733 -- procedure Proc ...;
20734 -- pragma SPARK_Mode ...;
20736 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
20737 N_Subprogram_Declaration
)
20738 or else (Nkind
(Stmt
) = N_Entry_Declaration
20739 and then Is_Protected_Type
20740 (Scope
(Defining_Entity
(Stmt
))))
20742 Process_Overloadable
(Stmt
);
20745 -- Otherwise the pragma does not apply to a legal construct
20746 -- or it does not appear at the top of a declarative or a
20747 -- statement list. Issue an error and stop the analysis.
20757 -- The pragma applies to a package or a subprogram that acts as
20758 -- a compilation unit.
20760 -- procedure Proc ...;
20761 -- pragma SPARK_Mode ...;
20763 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
20764 Context
:= Unit
(Parent
(Context
));
20767 -- The pragma appears at the top of entry, package, protected
20768 -- unit, subprogram or task unit body declarations.
20770 -- entry Ent when ... is
20771 -- pragma SPARK_Mode ...;
20773 -- package body Pack is
20774 -- pragma SPARK_Mode ...;
20776 -- procedure Proc ... is
20777 -- pragma SPARK_Mode;
20779 -- protected body Prot is
20780 -- pragma SPARK_Mode ...;
20782 if Nkind_In
(Context
, N_Entry_Body
,
20788 Process_Body
(Context
);
20790 -- The pragma appears at the top of the visible or private
20791 -- declaration of a package spec, protected or task unit.
20794 -- pragma SPARK_Mode ...;
20796 -- pragma SPARK_Mode ...;
20798 -- protected [type] Prot is
20799 -- pragma SPARK_Mode ...;
20801 -- pragma SPARK_Mode ...;
20803 elsif Nkind_In
(Context
, N_Package_Specification
,
20804 N_Protected_Definition
,
20807 if List_Containing
(N
) = Visible_Declarations
(Context
) then
20808 Process_Visible_Part
(Parent
(Context
));
20810 Process_Private_Part
(Parent
(Context
));
20813 -- The pragma appears at the top of package body statements
20815 -- package body Pack is
20817 -- pragma SPARK_Mode;
20819 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
20820 and then Nkind
(Parent
(Context
)) = N_Package_Body
20822 Process_Statement_Part
(Parent
(Context
));
20824 -- The pragma appeared as an aspect of a [generic] subprogram
20825 -- declaration that acts as a compilation unit.
20828 -- procedure Proc ...;
20829 -- pragma SPARK_Mode ...;
20831 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
20832 N_Subprogram_Declaration
)
20834 Process_Overloadable
(Context
);
20836 -- The pragma does not apply to a legal construct, issue error
20844 --------------------------------
20845 -- Static_Elaboration_Desired --
20846 --------------------------------
20848 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
20850 when Pragma_Static_Elaboration_Desired
=>
20852 Check_At_Most_N_Arguments
(1);
20854 if Is_Compilation_Unit
(Current_Scope
)
20855 and then Ekind
(Current_Scope
) = E_Package
20857 Set_Static_Elaboration_Desired
(Current_Scope
, True);
20859 Error_Pragma
("pragma% must apply to a library-level package");
20866 -- pragma Storage_Size (EXPRESSION);
20868 when Pragma_Storage_Size
=> Storage_Size
: declare
20869 P
: constant Node_Id
:= Parent
(N
);
20873 Check_No_Identifiers
;
20874 Check_Arg_Count
(1);
20876 -- The expression must be analyzed in the special manner described
20877 -- in "Handling of Default Expressions" in sem.ads.
20879 Arg
:= Get_Pragma_Arg
(Arg1
);
20880 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
20882 if not Is_OK_Static_Expression
(Arg
) then
20883 Check_Restriction
(Static_Storage_Size
, Arg
);
20886 if Nkind
(P
) /= N_Task_Definition
then
20891 if Has_Storage_Size_Pragma
(P
) then
20892 Error_Pragma
("duplicate pragma% not allowed");
20894 Set_Has_Storage_Size_Pragma
(P
, True);
20897 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
20905 -- pragma Storage_Unit (NUMERIC_LITERAL);
20907 -- Only permitted argument is System'Storage_Unit value
20909 when Pragma_Storage_Unit
=>
20910 Check_No_Identifiers
;
20911 Check_Arg_Count
(1);
20912 Check_Arg_Is_Integer_Literal
(Arg1
);
20914 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
20915 UI_From_Int
(Ttypes
.System_Storage_Unit
)
20917 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
20919 ("the only allowed argument for pragma% is ^", Arg1
);
20922 --------------------
20923 -- Stream_Convert --
20924 --------------------
20926 -- pragma Stream_Convert (
20927 -- [Entity =>] type_LOCAL_NAME,
20928 -- [Read =>] function_NAME,
20929 -- [Write =>] function NAME);
20931 when Pragma_Stream_Convert
=> Stream_Convert
: declare
20933 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
20934 -- Check that the given argument is the name of a local function
20935 -- of one argument that is not overloaded earlier in the current
20936 -- local scope. A check is also made that the argument is a
20937 -- function with one parameter.
20939 --------------------------------------
20940 -- Check_OK_Stream_Convert_Function --
20941 --------------------------------------
20943 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
20947 Check_Arg_Is_Local_Name
(Arg
);
20948 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
20950 if Has_Homonym
(Ent
) then
20952 ("argument for pragma% may not be overloaded", Arg
);
20955 if Ekind
(Ent
) /= E_Function
20956 or else No
(First_Formal
(Ent
))
20957 or else Present
(Next_Formal
(First_Formal
(Ent
)))
20960 ("argument for pragma% must be function of one argument",
20963 end Check_OK_Stream_Convert_Function
;
20965 -- Start of processing for Stream_Convert
20969 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
20970 Check_Arg_Count
(3);
20971 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20972 Check_Optional_Identifier
(Arg2
, Name_Read
);
20973 Check_Optional_Identifier
(Arg3
, Name_Write
);
20974 Check_Arg_Is_Local_Name
(Arg1
);
20975 Check_OK_Stream_Convert_Function
(Arg2
);
20976 Check_OK_Stream_Convert_Function
(Arg3
);
20979 Typ
: constant Entity_Id
:=
20980 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
20981 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
20982 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
20985 Check_First_Subtype
(Arg1
);
20987 -- Check for too early or too late. Note that we don't enforce
20988 -- the rule about primitive operations in this case, since, as
20989 -- is the case for explicit stream attributes themselves, these
20990 -- restrictions are not appropriate. Note that the chaining of
20991 -- the pragma by Rep_Item_Too_Late is actually the critical
20992 -- processing done for this pragma.
20994 if Rep_Item_Too_Early
(Typ
, N
)
20996 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
21001 -- Return if previous error
21003 if Etype
(Typ
) = Any_Type
21005 Etype
(Read
) = Any_Type
21007 Etype
(Write
) = Any_Type
21014 if Underlying_Type
(Etype
(Read
)) /= Typ
then
21016 ("incorrect return type for function&", Arg2
);
21019 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
21021 ("incorrect parameter type for function&", Arg3
);
21024 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
21025 Underlying_Type
(Etype
(Write
))
21028 ("result type of & does not match Read parameter type",
21032 end Stream_Convert
;
21038 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21040 -- This is processed by the parser since some of the style checks
21041 -- take place during source scanning and parsing. This means that
21042 -- we don't need to issue error messages here.
21044 when Pragma_Style_Checks
=> Style_Checks
: declare
21045 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21051 Check_No_Identifiers
;
21053 -- Two argument form
21055 if Arg_Count
= 2 then
21056 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
21063 E_Id
:= Get_Pragma_Arg
(Arg2
);
21066 if not Is_Entity_Name
(E_Id
) then
21068 ("second argument of pragma% must be entity name",
21072 E
:= Entity
(E_Id
);
21074 if not Ignore_Style_Checks_Pragmas
then
21079 Set_Suppress_Style_Checks
21080 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
21081 exit when No
(Homonym
(E
));
21088 -- One argument form
21091 Check_Arg_Count
(1);
21093 if Nkind
(A
) = N_String_Literal
then
21097 Slen
: constant Natural := Natural (String_Length
(S
));
21098 Options
: String (1 .. Slen
);
21104 C
:= Get_String_Char
(S
, Int
(J
));
21105 exit when not In_Character_Range
(C
);
21106 Options
(J
) := Get_Character
(C
);
21108 -- If at end of string, set options. As per discussion
21109 -- above, no need to check for errors, since we issued
21110 -- them in the parser.
21113 if not Ignore_Style_Checks_Pragmas
then
21114 Set_Style_Check_Options
(Options
);
21124 elsif Nkind
(A
) = N_Identifier
then
21125 if Chars
(A
) = Name_All_Checks
then
21126 if not Ignore_Style_Checks_Pragmas
then
21128 Set_GNAT_Style_Check_Options
;
21130 Set_Default_Style_Check_Options
;
21134 elsif Chars
(A
) = Name_On
then
21135 if not Ignore_Style_Checks_Pragmas
then
21136 Style_Check
:= True;
21139 elsif Chars
(A
) = Name_Off
then
21140 if not Ignore_Style_Checks_Pragmas
then
21141 Style_Check
:= False;
21152 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
21154 when Pragma_Subtitle
=>
21156 Check_Arg_Count
(1);
21157 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
21158 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
21165 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21167 when Pragma_Suppress
=>
21168 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
21174 -- pragma Suppress_All;
21176 -- The only check made here is that the pragma has no arguments.
21177 -- There are no placement rules, and the processing required (setting
21178 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
21179 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
21180 -- then creates and inserts a pragma Suppress (All_Checks).
21182 when Pragma_Suppress_All
=>
21184 Check_Arg_Count
(0);
21186 -------------------------
21187 -- Suppress_Debug_Info --
21188 -------------------------
21190 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21192 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
21193 Nam_Id
: Entity_Id
;
21197 Check_Arg_Count
(1);
21198 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21199 Check_Arg_Is_Local_Name
(Arg1
);
21201 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
21203 -- A pragma that applies to a Ghost entity becomes Ghost for the
21204 -- purposes of legality checks and removal of ignored Ghost code.
21206 Mark_Pragma_As_Ghost
(N
, Nam_Id
);
21207 Set_Debug_Info_Off
(Nam_Id
);
21208 end Suppress_Debug_Info
;
21210 ----------------------------------
21211 -- Suppress_Exception_Locations --
21212 ----------------------------------
21214 -- pragma Suppress_Exception_Locations;
21216 when Pragma_Suppress_Exception_Locations
=>
21218 Check_Arg_Count
(0);
21219 Check_Valid_Configuration_Pragma
;
21220 Exception_Locations_Suppressed
:= True;
21222 -----------------------------
21223 -- Suppress_Initialization --
21224 -----------------------------
21226 -- pragma Suppress_Initialization ([Entity =>] type_Name);
21228 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
21234 Check_Arg_Count
(1);
21235 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21236 Check_Arg_Is_Local_Name
(Arg1
);
21238 E_Id
:= Get_Pragma_Arg
(Arg1
);
21240 if Etype
(E_Id
) = Any_Type
then
21244 E
:= Entity
(E_Id
);
21246 -- A pragma that applies to a Ghost entity becomes Ghost for the
21247 -- purposes of legality checks and removal of ignored Ghost code.
21249 Mark_Pragma_As_Ghost
(N
, E
);
21251 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
21253 ("pragma% requires variable, type or subtype", Arg1
);
21256 if Rep_Item_Too_Early
(E
, N
)
21258 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
21263 -- For incomplete/private type, set flag on full view
21265 if Is_Incomplete_Or_Private_Type
(E
) then
21266 if No
(Full_View
(Base_Type
(E
))) then
21268 ("argument of pragma% cannot be an incomplete type", Arg1
);
21270 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
21273 -- For first subtype, set flag on base type
21275 elsif Is_First_Subtype
(E
) then
21276 Set_Suppress_Initialization
(Base_Type
(E
));
21278 -- For other than first subtype, set flag on subtype or variable
21281 Set_Suppress_Initialization
(E
);
21289 -- pragma System_Name (DIRECT_NAME);
21291 -- Syntax check: one argument, which must be the identifier GNAT or
21292 -- the identifier GCC, no other identifiers are acceptable.
21294 when Pragma_System_Name
=>
21296 Check_No_Identifiers
;
21297 Check_Arg_Count
(1);
21298 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
21300 -----------------------------
21301 -- Task_Dispatching_Policy --
21302 -----------------------------
21304 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
21306 when Pragma_Task_Dispatching_Policy
=> declare
21310 Check_Ada_83_Warning
;
21311 Check_Arg_Count
(1);
21312 Check_No_Identifiers
;
21313 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
21314 Check_Valid_Configuration_Pragma
;
21315 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21316 DP
:= Fold_Upper
(Name_Buffer
(1));
21318 if Task_Dispatching_Policy
/= ' '
21319 and then Task_Dispatching_Policy
/= DP
21321 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21323 ("task dispatching policy incompatible with policy#");
21325 -- Set new policy, but always preserve System_Location since we
21326 -- like the error message with the run time name.
21329 Task_Dispatching_Policy
:= DP
;
21331 if Task_Dispatching_Policy_Sloc
/= System_Location
then
21332 Task_Dispatching_Policy_Sloc
:= Loc
;
21341 -- pragma Task_Info (EXPRESSION);
21343 when Pragma_Task_Info
=> Task_Info
: declare
21344 P
: constant Node_Id
:= Parent
(N
);
21350 if Warn_On_Obsolescent_Feature
then
21352 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
21353 & "instead?j?", N
);
21356 if Nkind
(P
) /= N_Task_Definition
then
21357 Error_Pragma
("pragma% must appear in task definition");
21360 Check_No_Identifiers
;
21361 Check_Arg_Count
(1);
21363 Analyze_And_Resolve
21364 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
21366 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
21370 Ent
:= Defining_Identifier
(Parent
(P
));
21372 -- Check duplicate pragma before we chain the pragma in the Rep
21373 -- Item chain of Ent.
21376 (Ent
, Name_Task_Info
, Check_Parents
=> False)
21378 Error_Pragma
("duplicate pragma% not allowed");
21381 Record_Rep_Item
(Ent
, N
);
21388 -- pragma Task_Name (string_EXPRESSION);
21390 when Pragma_Task_Name
=> Task_Name
: declare
21391 P
: constant Node_Id
:= Parent
(N
);
21396 Check_No_Identifiers
;
21397 Check_Arg_Count
(1);
21399 Arg
:= Get_Pragma_Arg
(Arg1
);
21401 -- The expression is used in the call to Create_Task, and must be
21402 -- expanded there, not in the context of the current spec. It must
21403 -- however be analyzed to capture global references, in case it
21404 -- appears in a generic context.
21406 Preanalyze_And_Resolve
(Arg
, Standard_String
);
21408 if Nkind
(P
) /= N_Task_Definition
then
21412 Ent
:= Defining_Identifier
(Parent
(P
));
21414 -- Check duplicate pragma before we chain the pragma in the Rep
21415 -- Item chain of Ent.
21418 (Ent
, Name_Task_Name
, Check_Parents
=> False)
21420 Error_Pragma
("duplicate pragma% not allowed");
21423 Record_Rep_Item
(Ent
, N
);
21430 -- pragma Task_Storage (
21431 -- [Task_Type =>] LOCAL_NAME,
21432 -- [Top_Guard =>] static_integer_EXPRESSION);
21434 when Pragma_Task_Storage
=> Task_Storage
: declare
21435 Args
: Args_List
(1 .. 2);
21436 Names
: constant Name_List
(1 .. 2) := (
21440 Task_Type
: Node_Id
renames Args
(1);
21441 Top_Guard
: Node_Id
renames Args
(2);
21447 Gather_Associations
(Names
, Args
);
21449 if No
(Task_Type
) then
21451 ("missing task_type argument for pragma%");
21454 Check_Arg_Is_Local_Name
(Task_Type
);
21456 Ent
:= Entity
(Task_Type
);
21458 if not Is_Task_Type
(Ent
) then
21460 ("argument for pragma% must be task type", Task_Type
);
21463 if No
(Top_Guard
) then
21465 ("pragma% takes two arguments", Task_Type
);
21467 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
21470 Check_First_Subtype
(Task_Type
);
21472 if Rep_Item_Too_Late
(Ent
, N
) then
21481 -- pragma Test_Case
21482 -- ([Name =>] Static_String_EXPRESSION
21483 -- ,[Mode =>] MODE_TYPE
21484 -- [, Requires => Boolean_EXPRESSION]
21485 -- [, Ensures => Boolean_EXPRESSION]);
21487 -- MODE_TYPE ::= Nominal | Robustness
21489 -- Characteristics:
21491 -- * Analysis - The annotation undergoes initial checks to verify
21492 -- the legal placement and context. Secondary checks preanalyze the
21495 -- Analyze_Test_Case_In_Decl_Part
21497 -- * Expansion - None.
21499 -- * Template - The annotation utilizes the generic template of the
21500 -- related subprogram when it is:
21502 -- aspect on subprogram declaration
21504 -- The annotation must prepare its own template when it is:
21506 -- pragma on subprogram declaration
21508 -- * Globals - Capture of global references must occur after full
21511 -- * Instance - The annotation is instantiated automatically when
21512 -- the related generic subprogram is instantiated except for the
21513 -- "pragma on subprogram declaration" case. In that scenario the
21514 -- annotation must instantiate itself.
21516 when Pragma_Test_Case
=> Test_Case
: declare
21517 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
21518 -- Ensure that the contract of subprogram Subp_Id does not contain
21519 -- another Test_Case pragma with the same Name as the current one.
21521 -------------------------
21522 -- Check_Distinct_Name --
21523 -------------------------
21525 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
21526 Items
: constant Node_Id
:= Contract
(Subp_Id
);
21527 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
21531 -- Inspect all Test_Case pragma of the related subprogram
21532 -- looking for one with a duplicate "Name" argument.
21534 if Present
(Items
) then
21535 Prag
:= Contract_Test_Cases
(Items
);
21536 while Present
(Prag
) loop
21537 if Pragma_Name
(Prag
) = Name_Test_Case
21539 and then String_Equal
21540 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
21542 Error_Msg_Sloc
:= Sloc
(Prag
);
21543 Error_Pragma
("name for pragma % is already used #");
21546 Prag
:= Next_Pragma
(Prag
);
21549 end Check_Distinct_Name
;
21553 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
21556 Subp_Decl
: Node_Id
;
21557 Subp_Id
: Entity_Id
;
21559 -- Start of processing for Test_Case
21563 Check_At_Least_N_Arguments
(2);
21564 Check_At_Most_N_Arguments
(4);
21566 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
21570 Check_Optional_Identifier
(Arg1
, Name_Name
);
21571 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
21575 Check_Optional_Identifier
(Arg2
, Name_Mode
);
21576 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
21578 -- Arguments "Requires" and "Ensures"
21580 if Present
(Arg3
) then
21581 if Present
(Arg4
) then
21582 Check_Identifier
(Arg3
, Name_Requires
);
21583 Check_Identifier
(Arg4
, Name_Ensures
);
21585 Check_Identifier_Is_One_Of
21586 (Arg3
, Name_Requires
, Name_Ensures
);
21590 -- Pragma Test_Case must be associated with a subprogram declared
21591 -- in a library-level package. First determine whether the current
21592 -- compilation unit is a legal context.
21594 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
21595 N_Generic_Package_Declaration
)
21599 -- Otherwise the placement is illegal
21606 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
21608 -- Find the enclosing context
21610 Context
:= Parent
(Subp_Decl
);
21612 if Present
(Context
) then
21613 Context
:= Parent
(Context
);
21616 -- Verify the placement of the pragma
21618 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
21620 ("pragma % cannot be applied to abstract subprogram");
21623 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
21624 Error_Pragma
("pragma % cannot be applied to entry");
21627 -- The context is a [generic] subprogram declared at the top level
21628 -- of the [generic] package unit.
21630 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
21631 N_Subprogram_Declaration
)
21632 and then Present
(Context
)
21633 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
21634 N_Package_Declaration
)
21638 -- Otherwise the placement is illegal
21645 Subp_Id
:= Defining_Entity
(Subp_Decl
);
21647 -- Chain the pragma on the contract for further processing by
21648 -- Analyze_Test_Case_In_Decl_Part.
21650 Add_Contract_Item
(N
, Subp_Id
);
21652 -- A pragma that applies to a Ghost entity becomes Ghost for the
21653 -- purposes of legality checks and removal of ignored Ghost code.
21655 Mark_Pragma_As_Ghost
(N
, Subp_Id
);
21657 -- Preanalyze the original aspect argument "Name" for ASIS or for
21658 -- a generic subprogram to properly capture global references.
21660 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
21661 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
21663 if Present
(Asp_Arg
) then
21665 -- The argument appears with an identifier in association
21668 if Nkind
(Asp_Arg
) = N_Component_Association
then
21669 Asp_Arg
:= Expression
(Asp_Arg
);
21672 Check_Expr_Is_OK_Static_Expression
21673 (Asp_Arg
, Standard_String
);
21677 -- Ensure that the all Test_Case pragmas of the related subprogram
21678 -- have distinct names.
21680 Check_Distinct_Name
(Subp_Id
);
21682 -- Fully analyze the pragma when it appears inside an entry
21683 -- or subprogram body because it cannot benefit from forward
21686 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
21688 N_Subprogram_Body_Stub
)
21690 -- The legality checks of pragma Test_Case are affected by the
21691 -- SPARK mode in effect and the volatility of the context.
21692 -- Analyze all pragmas in a specific order.
21694 Analyze_If_Present
(Pragma_SPARK_Mode
);
21695 Analyze_If_Present
(Pragma_Volatile_Function
);
21696 Analyze_Test_Case_In_Decl_Part
(N
);
21700 --------------------------
21701 -- Thread_Local_Storage --
21702 --------------------------
21704 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
21706 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
21712 Check_Arg_Count
(1);
21713 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21714 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21716 Id
:= Get_Pragma_Arg
(Arg1
);
21719 if not Is_Entity_Name
(Id
)
21720 or else Ekind
(Entity
(Id
)) /= E_Variable
21722 Error_Pragma_Arg
("local variable name required", Arg1
);
21727 -- A pragma that applies to a Ghost entity becomes Ghost for the
21728 -- purposes of legality checks and removal of ignored Ghost code.
21730 Mark_Pragma_As_Ghost
(N
, E
);
21732 if Rep_Item_Too_Early
(E
, N
)
21734 Rep_Item_Too_Late
(E
, N
)
21739 Set_Has_Pragma_Thread_Local_Storage
(E
);
21740 Set_Has_Gigi_Rep_Item
(E
);
21741 end Thread_Local_Storage
;
21747 -- pragma Time_Slice (static_duration_EXPRESSION);
21749 when Pragma_Time_Slice
=> Time_Slice
: declare
21755 Check_Arg_Count
(1);
21756 Check_No_Identifiers
;
21757 Check_In_Main_Program
;
21758 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
21760 if not Error_Posted
(Arg1
) then
21762 while Present
(Nod
) loop
21763 if Nkind
(Nod
) = N_Pragma
21764 and then Pragma_Name
(Nod
) = Name_Time_Slice
21766 Error_Msg_Name_1
:= Pname
;
21767 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
21774 -- Process only if in main unit
21776 if Get_Source_Unit
(Loc
) = Main_Unit
then
21777 Opt
.Time_Slice_Set
:= True;
21778 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
21780 if Val
<= Ureal_0
then
21781 Opt
.Time_Slice_Value
:= 0;
21783 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
21784 Opt
.Time_Slice_Value
:= 1_000_000_000
;
21787 Opt
.Time_Slice_Value
:=
21788 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
21797 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
21799 -- TITLING_OPTION ::=
21800 -- [Title =>] STRING_LITERAL
21801 -- | [Subtitle =>] STRING_LITERAL
21803 when Pragma_Title
=> Title
: declare
21804 Args
: Args_List
(1 .. 2);
21805 Names
: constant Name_List
(1 .. 2) := (
21811 Gather_Associations
(Names
, Args
);
21814 for J
in 1 .. 2 loop
21815 if Present
(Args
(J
)) then
21816 Check_Arg_Is_OK_Static_Expression
21817 (Args
(J
), Standard_String
);
21822 ----------------------------
21823 -- Type_Invariant[_Class] --
21824 ----------------------------
21826 -- pragma Type_Invariant[_Class]
21827 -- ([Entity =>] type_LOCAL_NAME,
21828 -- [Check =>] EXPRESSION);
21830 when Pragma_Type_Invariant |
21831 Pragma_Type_Invariant_Class
=>
21832 Type_Invariant
: declare
21833 I_Pragma
: Node_Id
;
21836 Check_Arg_Count
(2);
21838 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
21839 -- setting Class_Present for the Type_Invariant_Class case.
21841 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
21842 I_Pragma
:= New_Copy
(N
);
21843 Set_Pragma_Identifier
21844 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
21845 Rewrite
(N
, I_Pragma
);
21846 Set_Analyzed
(N
, False);
21848 end Type_Invariant
;
21850 ---------------------
21851 -- Unchecked_Union --
21852 ---------------------
21854 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
21856 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
21857 Assoc
: constant Node_Id
:= Arg1
;
21858 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
21868 Check_No_Identifiers
;
21869 Check_Arg_Count
(1);
21870 Check_Arg_Is_Local_Name
(Arg1
);
21872 Find_Type
(Type_Id
);
21874 Typ
:= Entity
(Type_Id
);
21876 -- A pragma that applies to a Ghost entity becomes Ghost for the
21877 -- purposes of legality checks and removal of ignored Ghost code.
21879 Mark_Pragma_As_Ghost
(N
, Typ
);
21882 or else Rep_Item_Too_Early
(Typ
, N
)
21886 Typ
:= Underlying_Type
(Typ
);
21889 if Rep_Item_Too_Late
(Typ
, N
) then
21893 Check_First_Subtype
(Arg1
);
21895 -- Note remaining cases are references to a type in the current
21896 -- declarative part. If we find an error, we post the error on
21897 -- the relevant type declaration at an appropriate point.
21899 if not Is_Record_Type
(Typ
) then
21900 Error_Msg_N
("unchecked union must be record type", Typ
);
21903 elsif Is_Tagged_Type
(Typ
) then
21904 Error_Msg_N
("unchecked union must not be tagged", Typ
);
21907 elsif not Has_Discriminants
(Typ
) then
21909 ("unchecked union must have one discriminant", Typ
);
21912 -- Note: in previous versions of GNAT we used to check for limited
21913 -- types and give an error, but in fact the standard does allow
21914 -- Unchecked_Union on limited types, so this check was removed.
21916 -- Similarly, GNAT used to require that all discriminants have
21917 -- default values, but this is not mandated by the RM.
21919 -- Proceed with basic error checks completed
21922 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
21923 Clist
:= Component_List
(Tdef
);
21925 -- Check presence of component list and variant part
21927 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
21929 ("unchecked union must have variant part", Tdef
);
21933 -- Check components
21935 Comp
:= First
(Component_Items
(Clist
));
21936 while Present
(Comp
) loop
21937 Check_Component
(Comp
, Typ
);
21941 -- Check variant part
21943 Vpart
:= Variant_Part
(Clist
);
21945 Variant
:= First
(Variants
(Vpart
));
21946 while Present
(Variant
) loop
21947 Check_Variant
(Variant
, Typ
);
21952 Set_Is_Unchecked_Union
(Typ
);
21953 Set_Convention
(Typ
, Convention_C
);
21954 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
21955 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
21956 end Unchecked_Union
;
21958 ------------------------
21959 -- Unimplemented_Unit --
21960 ------------------------
21962 -- pragma Unimplemented_Unit;
21964 -- Note: this only gives an error if we are generating code, or if
21965 -- we are in a generic library unit (where the pragma appears in the
21966 -- body, not in the spec).
21968 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
21969 Cunitent
: constant Entity_Id
:=
21970 Cunit_Entity
(Get_Source_Unit
(Loc
));
21971 Ent_Kind
: constant Entity_Kind
:=
21976 Check_Arg_Count
(0);
21978 if Operating_Mode
= Generate_Code
21979 or else Ent_Kind
= E_Generic_Function
21980 or else Ent_Kind
= E_Generic_Procedure
21981 or else Ent_Kind
= E_Generic_Package
21983 Get_Name_String
(Chars
(Cunitent
));
21984 Set_Casing
(Mixed_Case
);
21985 Write_Str
(Name_Buffer
(1 .. Name_Len
));
21986 Write_Str
(" is not supported in this configuration");
21988 raise Unrecoverable_Error
;
21990 end Unimplemented_Unit
;
21992 ------------------------
21993 -- Universal_Aliasing --
21994 ------------------------
21996 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
21998 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
22003 Check_Arg_Count
(1);
22004 Check_Optional_Identifier
(Arg2
, Name_Entity
);
22005 Check_Arg_Is_Local_Name
(Arg1
);
22006 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
22008 if E_Id
= Any_Type
then
22010 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
22011 Error_Pragma_Arg
("pragma% requires type", Arg1
);
22014 -- A pragma that applies to a Ghost entity becomes Ghost for the
22015 -- purposes of legality checks and removal of ignored Ghost code.
22017 Mark_Pragma_As_Ghost
(N
, E_Id
);
22018 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
22019 Record_Rep_Item
(E_Id
, N
);
22020 end Universal_Alias
;
22022 --------------------
22023 -- Universal_Data --
22024 --------------------
22026 -- pragma Universal_Data [(library_unit_NAME)];
22028 when Pragma_Universal_Data
=>
22031 -- If this is a configuration pragma, then set the universal
22032 -- addressing option, otherwise confirm that the pragma satisfies
22033 -- the requirements of library unit pragma placement and leave it
22034 -- to the GNAAMP back end to detect the pragma (avoids transitive
22035 -- setting of the option due to withed units).
22037 if Is_Configuration_Pragma
then
22038 Universal_Addressing_On_AAMP
:= True;
22040 Check_Valid_Library_Unit_Pragma
;
22043 if not AAMP_On_Target
then
22044 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
22051 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
22053 when Pragma_Unmodified
=> Unmodified
: declare
22055 Arg_Expr
: Node_Id
;
22056 Arg_Id
: Entity_Id
;
22058 Ghost_Error_Posted
: Boolean := False;
22059 -- Flag set when an error concerning the illegal mix of Ghost and
22060 -- non-Ghost variables is emitted.
22062 Ghost_Id
: Entity_Id
:= Empty
;
22063 -- The entity of the first Ghost variable encountered while
22064 -- processing the arguments of the pragma.
22068 Check_At_Least_N_Arguments
(1);
22070 -- Loop through arguments
22073 while Present
(Arg
) loop
22074 Check_No_Identifier
(Arg
);
22076 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
22077 -- in fact generate reference, so that the entity will have a
22078 -- reference, which will inhibit any warnings about it not
22079 -- being referenced, and also properly show up in the ali file
22080 -- as a reference. But this reference is recorded before the
22081 -- Has_Pragma_Unreferenced flag is set, so that no warning is
22082 -- generated for this reference.
22084 Check_Arg_Is_Local_Name
(Arg
);
22085 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22087 if Is_Entity_Name
(Arg_Expr
) then
22088 Arg_Id
:= Entity
(Arg_Expr
);
22090 if Is_Assignable
(Arg_Id
) then
22091 Set_Has_Pragma_Unmodified
(Arg_Id
);
22093 -- A pragma that applies to a Ghost entity becomes Ghost
22094 -- for the purposes of legality checks and removal of
22095 -- ignored Ghost code.
22097 Mark_Pragma_As_Ghost
(N
, Arg_Id
);
22099 -- Capture the entity of the first Ghost variable being
22100 -- processed for error detection purposes.
22102 if Is_Ghost_Entity
(Arg_Id
) then
22103 if No
(Ghost_Id
) then
22104 Ghost_Id
:= Arg_Id
;
22107 -- Otherwise the variable is non-Ghost. It is illegal
22108 -- to mix references to Ghost and non-Ghost entities
22111 elsif Present
(Ghost_Id
)
22112 and then not Ghost_Error_Posted
22114 Ghost_Error_Posted
:= True;
22116 Error_Msg_Name_1
:= Pname
;
22118 ("pragma % cannot mention ghost and non-ghost "
22121 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
22122 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
22124 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
22125 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
22128 -- Otherwise the pragma referenced an illegal entity
22132 ("pragma% can only be applied to a variable", Arg_Expr
);
22144 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
22146 -- or when used in a context clause:
22148 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
22150 when Pragma_Unreferenced
=> Unreferenced
: declare
22152 Arg_Expr
: Node_Id
;
22153 Arg_Id
: Entity_Id
;
22156 Ghost_Error_Posted
: Boolean := False;
22157 -- Flag set when an error concerning the illegal mix of Ghost and
22158 -- non-Ghost names is emitted.
22160 Ghost_Id
: Entity_Id
:= Empty
;
22161 -- The entity of the first Ghost name encountered while processing
22162 -- the arguments of the pragma.
22166 Check_At_Least_N_Arguments
(1);
22168 -- Check case of appearing within context clause
22170 if Is_In_Context_Clause
then
22172 -- The arguments must all be units mentioned in a with clause
22173 -- in the same context clause. Note we already checked (in
22174 -- Par.Prag) that the arguments are either identifiers or
22175 -- selected components.
22178 while Present
(Arg
) loop
22179 Citem
:= First
(List_Containing
(N
));
22180 while Citem
/= N
loop
22181 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22183 if Nkind
(Citem
) = N_With_Clause
22184 and then Same_Name
(Name
(Citem
), Arg_Expr
)
22186 Set_Has_Pragma_Unreferenced
22189 (Library_Unit
(Citem
))));
22190 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
22199 ("argument of pragma% is not withed unit", Arg
);
22205 -- Case of not in list of context items
22209 while Present
(Arg
) loop
22210 Check_No_Identifier
(Arg
);
22212 -- Note: the analyze call done by Check_Arg_Is_Local_Name
22213 -- will in fact generate reference, so that the entity will
22214 -- have a reference, which will inhibit any warnings about
22215 -- it not being referenced, and also properly show up in the
22216 -- ali file as a reference. But this reference is recorded
22217 -- before the Has_Pragma_Unreferenced flag is set, so that
22218 -- no warning is generated for this reference.
22220 Check_Arg_Is_Local_Name
(Arg
);
22221 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22223 if Is_Entity_Name
(Arg_Expr
) then
22224 Arg_Id
:= Entity
(Arg_Expr
);
22226 -- If the entity is overloaded, the pragma applies to the
22227 -- most recent overloading, as documented. In this case,
22228 -- name resolution does not generate a reference, so it
22229 -- must be done here explicitly.
22231 if Is_Overloaded
(Arg_Expr
) then
22232 Generate_Reference
(Arg_Id
, N
);
22235 Set_Has_Pragma_Unreferenced
(Arg_Id
);
22237 -- A pragma that applies to a Ghost entity becomes Ghost
22238 -- for the purposes of legality checks and removal of
22239 -- ignored Ghost code.
22241 Mark_Pragma_As_Ghost
(N
, Arg_Id
);
22243 -- Capture the entity of the first Ghost name being
22244 -- processed for error detection purposes.
22246 if Is_Ghost_Entity
(Arg_Id
) then
22247 if No
(Ghost_Id
) then
22248 Ghost_Id
:= Arg_Id
;
22251 -- Otherwise the name is non-Ghost. It is illegal to mix
22252 -- references to Ghost and non-Ghost entities
22255 elsif Present
(Ghost_Id
)
22256 and then not Ghost_Error_Posted
22258 Ghost_Error_Posted
:= True;
22260 Error_Msg_Name_1
:= Pname
;
22262 ("pragma % cannot mention ghost and non-ghost names",
22265 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
22266 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
22268 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
22269 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
22278 --------------------------
22279 -- Unreferenced_Objects --
22280 --------------------------
22282 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22284 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
22286 Arg_Expr
: Node_Id
;
22287 Arg_Id
: Entity_Id
;
22289 Ghost_Error_Posted
: Boolean := False;
22290 -- Flag set when an error concerning the illegal mix of Ghost and
22291 -- non-Ghost types is emitted.
22293 Ghost_Id
: Entity_Id
:= Empty
;
22294 -- The entity of the first Ghost type encountered while processing
22295 -- the arguments of the pragma.
22299 Check_At_Least_N_Arguments
(1);
22302 while Present
(Arg
) loop
22303 Check_No_Identifier
(Arg
);
22304 Check_Arg_Is_Local_Name
(Arg
);
22305 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22307 if Is_Entity_Name
(Arg_Expr
) then
22308 Arg_Id
:= Entity
(Arg_Expr
);
22310 if Is_Type
(Arg_Id
) then
22311 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
22313 -- A pragma that applies to a Ghost entity becomes Ghost
22314 -- for the purposes of legality checks and removal of
22315 -- ignored Ghost code.
22317 Mark_Pragma_As_Ghost
(N
, Arg_Id
);
22319 -- Capture the entity of the first Ghost type being
22320 -- processed for error detection purposes.
22322 if Is_Ghost_Entity
(Arg_Id
) then
22323 if No
(Ghost_Id
) then
22324 Ghost_Id
:= Arg_Id
;
22327 -- Otherwise the type is non-Ghost. It is illegal to mix
22328 -- references to Ghost and non-Ghost entities
22331 elsif Present
(Ghost_Id
)
22332 and then not Ghost_Error_Posted
22334 Ghost_Error_Posted
:= True;
22336 Error_Msg_Name_1
:= Pname
;
22338 ("pragma % cannot mention ghost and non-ghost types",
22341 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
22342 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
22344 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
22345 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
22349 ("argument for pragma% must be type or subtype", Arg
);
22353 ("argument for pragma% must be type or subtype", Arg
);
22358 end Unreferenced_Objects
;
22360 ------------------------------
22361 -- Unreserve_All_Interrupts --
22362 ------------------------------
22364 -- pragma Unreserve_All_Interrupts;
22366 when Pragma_Unreserve_All_Interrupts
=>
22368 Check_Arg_Count
(0);
22370 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
22371 Unreserve_All_Interrupts
:= True;
22378 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22380 when Pragma_Unsuppress
=>
22382 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
22384 ----------------------------
22385 -- Unevaluated_Use_Of_Old --
22386 ----------------------------
22388 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22390 when Pragma_Unevaluated_Use_Of_Old
=>
22392 Check_Arg_Count
(1);
22393 Check_No_Identifiers
;
22394 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
22396 -- Suppress/Unsuppress can appear as a configuration pragma, or in
22397 -- a declarative part or a package spec.
22399 if not Is_Configuration_Pragma
then
22400 Check_Is_In_Decl_Part_Or_Package_Spec
;
22403 -- Store proper setting of Uneval_Old
22405 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22406 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
22408 -------------------
22409 -- Use_VADS_Size --
22410 -------------------
22412 -- pragma Use_VADS_Size;
22414 when Pragma_Use_VADS_Size
=>
22416 Check_Arg_Count
(0);
22417 Check_Valid_Configuration_Pragma
;
22418 Use_VADS_Size
:= True;
22420 ---------------------
22421 -- Validity_Checks --
22422 ---------------------
22424 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22426 when Pragma_Validity_Checks
=> Validity_Checks
: declare
22427 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22433 Check_Arg_Count
(1);
22434 Check_No_Identifiers
;
22436 -- Pragma always active unless in CodePeer or GNATprove modes,
22437 -- which use a fixed configuration of validity checks.
22439 if not (CodePeer_Mode
or GNATprove_Mode
) then
22440 if Nkind
(A
) = N_String_Literal
then
22444 Slen
: constant Natural := Natural (String_Length
(S
));
22445 Options
: String (1 .. Slen
);
22449 -- Couldn't we use a for loop here over Options'Range???
22453 C
:= Get_String_Char
(S
, Int
(J
));
22455 -- This is a weird test, it skips setting validity
22456 -- checks entirely if any element of S is out of
22457 -- range of Character, what is that about ???
22459 exit when not In_Character_Range
(C
);
22460 Options
(J
) := Get_Character
(C
);
22463 Set_Validity_Check_Options
(Options
);
22471 elsif Nkind
(A
) = N_Identifier
then
22472 if Chars
(A
) = Name_All_Checks
then
22473 Set_Validity_Check_Options
("a");
22474 elsif Chars
(A
) = Name_On
then
22475 Validity_Checks_On
:= True;
22476 elsif Chars
(A
) = Name_Off
then
22477 Validity_Checks_On
:= False;
22481 end Validity_Checks
;
22487 -- pragma Volatile (LOCAL_NAME);
22489 when Pragma_Volatile
=>
22490 Process_Atomic_Independent_Shared_Volatile
;
22492 -------------------------
22493 -- Volatile_Components --
22494 -------------------------
22496 -- pragma Volatile_Components (array_LOCAL_NAME);
22498 -- Volatile is handled by the same circuit as Atomic_Components
22500 --------------------------
22501 -- Volatile_Full_Access --
22502 --------------------------
22504 -- pragma Volatile_Full_Access (LOCAL_NAME);
22506 when Pragma_Volatile_Full_Access
=>
22508 Process_Atomic_Independent_Shared_Volatile
;
22510 -----------------------
22511 -- Volatile_Function --
22512 -----------------------
22514 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
22516 when Pragma_Volatile_Function
=> Volatile_Function
: declare
22517 Over_Id
: Entity_Id
;
22518 Spec_Id
: Entity_Id
;
22519 Subp_Decl
: Node_Id
;
22523 Check_No_Identifiers
;
22524 Check_At_Most_N_Arguments
(1);
22527 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
22529 -- Generic subprogram
22531 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
22534 -- Body acts as spec
22536 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
22537 and then No
(Corresponding_Spec
(Subp_Decl
))
22541 -- Body stub acts as spec
22543 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
22544 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
22550 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
22558 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
22560 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
22565 -- Chain the pragma on the contract for completeness
22567 Add_Contract_Item
(N
, Spec_Id
);
22569 -- The legality checks of pragma Volatile_Function are affected by
22570 -- the SPARK mode in effect. Analyze all pragmas in a specific
22573 Analyze_If_Present
(Pragma_SPARK_Mode
);
22575 -- A pragma that applies to a Ghost entity becomes Ghost for the
22576 -- purposes of legality checks and removal of ignored Ghost code.
22578 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
22580 -- A volatile function cannot override a non-volatile function
22581 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
22582 -- in New_Overloaded_Entity, however at that point the pragma has
22583 -- not been processed yet.
22585 Over_Id
:= Overridden_Operation
(Spec_Id
);
22587 if Present
(Over_Id
)
22588 and then not Is_Volatile_Function
(Over_Id
)
22591 ("incompatible volatile function values in effect", Spec_Id
);
22593 Error_Msg_Sloc
:= Sloc
(Over_Id
);
22595 ("\& declared # with Volatile_Function value `False`",
22598 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
22600 ("\overridden # with Volatile_Function value `True`",
22604 -- Analyze the Boolean expression (if any)
22606 if Present
(Arg1
) then
22607 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
22609 end Volatile_Function
;
22611 ----------------------
22612 -- Warning_As_Error --
22613 ----------------------
22615 -- pragma Warning_As_Error (static_string_EXPRESSION);
22617 when Pragma_Warning_As_Error
=>
22619 Check_Arg_Count
(1);
22620 Check_No_Identifiers
;
22621 Check_Valid_Configuration_Pragma
;
22623 if not Is_Static_String_Expression
(Arg1
) then
22625 ("argument of pragma% must be static string expression",
22628 -- OK static string expression
22631 Acquire_Warning_Match_String
(Arg1
);
22632 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
22633 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
22634 new String'(Name_Buffer (1 .. Name_Len));
22641 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
22643 -- DETAILS ::= On | Off
22644 -- DETAILS ::= On | Off, local_NAME
22645 -- DETAILS ::= static_string_EXPRESSION
22646 -- DETAILS ::= On | Off, static_string_EXPRESSION
22648 -- TOOL_NAME ::= GNAT | GNATProve
22650 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
22652 -- Note: If the first argument matches an allowed tool name, it is
22653 -- always considered to be a tool name, even if there is a string
22654 -- variable of that name.
22656 -- Note if the second argument of DETAILS is a local_NAME then the
22657 -- second form is always understood. If the intention is to use
22658 -- the fourth form, then you can write NAME & "" to force the
22659 -- intepretation as a static_string_EXPRESSION.
22661 when Pragma_Warnings => Warnings : declare
22662 Reason : String_Id;
22666 Check_At_Least_N_Arguments (1);
22668 -- See if last argument is labeled Reason. If so, make sure we
22669 -- have a string literal or a concatenation of string literals,
22670 -- and acquire the REASON string. Then remove the REASON argument
22671 -- by decreasing Num_Args by one; Remaining processing looks only
22672 -- at first Num_Args arguments).
22675 Last_Arg : constant Node_Id :=
22676 Last (Pragma_Argument_Associations (N));
22679 if Nkind (Last_Arg) = N_Pragma_Argument_Association
22680 and then Chars (Last_Arg) = Name_Reason
22683 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
22684 Reason := End_String;
22685 Arg_Count := Arg_Count - 1;
22687 -- Not allowed in compiler units (bootstrap issues)
22689 Check_Compiler_Unit ("Reason for pragma Warnings", N);
22691 -- No REASON string, set null string as reason
22694 Reason := Null_String_Id;
22698 -- Now proceed with REASON taken care of and eliminated
22700 Check_No_Identifiers;
22702 -- If debug flag -gnatd.i is set, pragma is ignored
22704 if Debug_Flag_Dot_I then
22708 -- Process various forms of the pragma
22711 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
22712 Shifted_Args : List_Id;
22715 -- See if first argument is a tool name, currently either
22716 -- GNAT or GNATprove. If so, either ignore the pragma if the
22717 -- tool used does not match, or continue as if no tool name
22718 -- was given otherwise, by shifting the arguments.
22720 if Nkind (Argx) = N_Identifier
22721 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
22723 if Chars (Argx) = Name_Gnat then
22724 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
22725 Rewrite (N, Make_Null_Statement (Loc));
22730 elsif Chars (Argx) = Name_Gnatprove then
22731 if not GNATprove_Mode then
22732 Rewrite (N, Make_Null_Statement (Loc));
22738 raise Program_Error;
22741 -- At this point, the pragma Warnings applies to the tool,
22742 -- so continue with shifted arguments.
22744 Arg_Count := Arg_Count - 1;
22746 if Arg_Count = 1 then
22747 Shifted_Args := New_List (New_Copy (Arg2));
22748 elsif Arg_Count = 2 then
22749 Shifted_Args := New_List (New_Copy (Arg2),
22751 elsif Arg_Count = 3 then
22752 Shifted_Args := New_List (New_Copy (Arg2),
22756 raise Program_Error;
22761 Chars => Name_Warnings,
22762 Pragma_Argument_Associations => Shifted_Args));
22767 -- One argument case
22769 if Arg_Count = 1 then
22771 -- On/Off one argument case was processed by parser
22773 if Nkind (Argx) = N_Identifier
22774 and then Nam_In (Chars (Argx), Name_On, Name_Off)
22778 -- One argument case must be ON/OFF or static string expr
22780 elsif not Is_Static_String_Expression (Arg1) then
22782 ("argument of pragma% must be On/Off or static string "
22783 & "expression", Arg1);
22785 -- One argument string expression case
22789 Lit : constant Node_Id := Expr_Value_S (Argx);
22790 Str : constant String_Id := Strval (Lit);
22791 Len : constant Nat := String_Length (Str);
22799 while J <= Len loop
22800 C := Get_String_Char (Str, J);
22801 OK := In_Character_Range (C);
22804 Chr := Get_Character (C);
22806 -- Dash case: only -Wxxx is accepted
22813 C := Get_String_Char (Str, J);
22814 Chr := Get_Character (C);
22815 exit when Chr = 'W
';
22820 elsif J < Len and then Chr = '.' then
22822 C := Get_String_Char (Str, J);
22823 Chr := Get_Character (C);
22825 if not Set_Dot_Warning_Switch (Chr) then
22827 ("invalid warning switch character "
22828 & '.' & Chr, Arg1);
22834 OK := Set_Warning_Switch (Chr);
22840 ("invalid warning switch character " & Chr,
22849 -- Two or more arguments (must be two)
22852 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
22853 Check_Arg_Count (2);
22861 E_Id := Get_Pragma_Arg (Arg2);
22864 -- In the expansion of an inlined body, a reference to
22865 -- the formal may be wrapped in a conversion if the
22866 -- actual is a conversion. Retrieve the real entity name.
22868 if (In_Instance_Body or In_Inlined_Body)
22869 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
22871 E_Id := Expression (E_Id);
22874 -- Entity name case
22876 if Is_Entity_Name (E_Id) then
22877 E := Entity (E_Id);
22884 (E, (Chars (Get_Pragma_Arg (Arg1)) =
22887 -- For OFF case, make entry in warnings off
22888 -- pragma table for later processing. But we do
22889 -- not do that within an instance, since these
22890 -- warnings are about what is needed in the
22891 -- template, not an instance of it.
22893 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
22894 and then Warn_On_Warnings_Off
22895 and then not In_Instance
22897 Warnings_Off_Pragmas.Append ((N, E, Reason));
22900 if Is_Enumeration_Type (E) then
22904 Lit := First_Literal (E);
22905 while Present (Lit) loop
22906 Set_Warnings_Off (Lit);
22907 Next_Literal (Lit);
22912 exit when No (Homonym (E));
22917 -- Error if not entity or static string expression case
22919 elsif not Is_Static_String_Expression (Arg2) then
22921 ("second argument of pragma% must be entity name "
22922 & "or static string expression", Arg2);
22924 -- Static string expression case
22927 Acquire_Warning_Match_String (Arg2);
22929 -- Note on configuration pragma case: If this is a
22930 -- configuration pragma, then for an OFF pragma, we
22931 -- just set Config True in the call, which is all
22932 -- that needs to be done. For the case of ON, this
22933 -- is normally an error, unless it is canceling the
22934 -- effect of a previous OFF pragma in the same file.
22935 -- In any other case, an error will be signalled (ON
22936 -- with no matching OFF).
22938 -- Note: We set Used if we are inside a generic to
22939 -- disable the test that the non-config case actually
22940 -- cancels a warning. That's because we can't be sure
22941 -- there isn't an instantiation in some other unit
22942 -- where a warning is suppressed.
22944 -- We could do a little better here by checking if the
22945 -- generic unit we are inside is public, but for now
22946 -- we don't bother with that refinement.
22948 if Chars (Argx) = Name_Off then
22949 Set_Specific_Warning_Off
22950 (Loc, Name_Buffer (1 .. Name_Len), Reason,
22951 Config => Is_Configuration_Pragma,
22952 Used => Inside_A_Generic or else In_Instance);
22954 elsif Chars (Argx) = Name_On then
22955 Set_Specific_Warning_On
22956 (Loc, Name_Buffer (1 .. Name_Len), Err);
22960 ("??pragma Warnings On with no matching "
22961 & "Warnings Off", Loc);
22970 -------------------
22971 -- Weak_External --
22972 -------------------
22974 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
22976 when Pragma_Weak_External => Weak_External : declare
22981 Check_Arg_Count (1);
22982 Check_Optional_Identifier (Arg1, Name_Entity);
22983 Check_Arg_Is_Library_Level_Local_Name (Arg1);
22984 Ent := Entity (Get_Pragma_Arg (Arg1));
22986 if Rep_Item_Too_Early (Ent, N) then
22989 Ent := Underlying_Type (Ent);
22992 -- The only processing required is to link this item on to the
22993 -- list of rep items for the given entity. This is accomplished
22994 -- by the call to Rep_Item_Too_Late (when no error is detected
22995 -- and False is returned).
22997 if Rep_Item_Too_Late (Ent, N) then
23000 Set_Has_Gigi_Rep_Item (Ent);
23004 -----------------------------
23005 -- Wide_Character_Encoding --
23006 -----------------------------
23008 -- pragma Wide_Character_Encoding (IDENTIFIER);
23010 when Pragma_Wide_Character_Encoding =>
23013 -- Nothing to do, handled in parser. Note that we do not enforce
23014 -- configuration pragma placement, this pragma can appear at any
23015 -- place in the source, allowing mixed encodings within a single
23020 --------------------
23021 -- Unknown_Pragma --
23022 --------------------
23024 -- Should be impossible, since the case of an unknown pragma is
23025 -- separately processed before the case statement is entered.
23027 when Unknown_Pragma =>
23028 raise Program_Error;
23031 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23032 -- until AI is formally approved.
23034 -- Check_Order_Dependence;
23037 when Pragma_Exit => null;
23038 end Analyze_Pragma;
23040 ---------------------------------------------
23041 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23042 ---------------------------------------------
23044 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23046 Freeze_Id : Entity_Id := Empty)
23048 procedure Process_Class_Wide_Condition
23050 Spec_Id : Entity_Id;
23051 Subp_Decl : Node_Id);
23052 -- Replace the type of all references to the controlling formal of
23053 -- subprogram Spec_Id found in expression Expr with the corresponding
23054 -- class-wide type. Subp_Decl is the subprogram [body] declaration
23055 -- where the pragma resides.
23057 ----------------------------------
23058 -- Process_Class_Wide_Condition --
23059 ----------------------------------
23061 procedure Process_Class_Wide_Condition
23063 Spec_Id : Entity_Id;
23064 Subp_Decl : Node_Id)
23066 Disp_Typ : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
23068 ACW : Entity_Id := Empty;
23069 -- Access to Disp_Typ'Class, created if there is a controlling formal
23070 -- that is an access parameter.
23072 function Access_Class_Wide_Type return Entity_Id;
23073 -- If expression Expr contains a reference to a controlling access
23074 -- parameter, create an access to Disp_Typ'Class for the necessary
23075 -- conversions if one does not exist.
23077 function Replace_Type (N : Node_Id) return Traverse_Result;
23078 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
23079 -- aspect for a primitive subprogram of a tagged type Disp_Typ, a
23080 -- name that denotes a formal parameter of type Disp_Typ is treated
23081 -- as having type Disp_Typ'Class. Similarly, a name that denotes a
23082 -- formal access parameter of type access-to-Disp_Typ is interpreted
23083 -- as with type access-to-Disp_Typ'Class. This ensures the expression
23084 -- is well defined for a primitive subprogram of a type descended
23087 ----------------------------
23088 -- Access_Class_Wide_Type --
23089 ----------------------------
23091 function Access_Class_Wide_Type return Entity_Id is
23092 Loc : constant Source_Ptr := Sloc (N);
23096 ACW := Make_Temporary (Loc, 'T
');
23098 Insert_Before_And_Analyze (Subp_Decl,
23099 Make_Full_Type_Declaration (Loc,
23100 Defining_Identifier => ACW,
23102 Make_Access_To_Object_Definition (Loc,
23103 Subtype_Indication =>
23104 New_Occurrence_Of (Class_Wide_Type (Disp_Typ), Loc),
23105 All_Present => True)));
23107 Freeze_Before (Subp_Decl, ACW);
23111 end Access_Class_Wide_Type;
23117 function Replace_Type (N : Node_Id) return Traverse_Result is
23118 Context : constant Node_Id := Parent (N);
23119 Loc : constant Source_Ptr := Sloc (N);
23120 CW_Typ : Entity_Id := Empty;
23125 if Is_Entity_Name (N)
23126 and then Present (Entity (N))
23127 and then Is_Formal (Entity (N))
23130 Typ := Etype (Ent);
23132 -- Do not perform the type replacement for selector names in
23133 -- parameter associations. These carry an entity for reference
23134 -- purposes, but semantically they are just identifiers.
23136 if Nkind (Context) = N_Type_Conversion then
23139 elsif Nkind (Context) = N_Parameter_Association
23140 and then Selector_Name (Context) = N
23144 elsif Typ = Disp_Typ then
23145 CW_Typ := Class_Wide_Type (Typ);
23147 elsif Is_Access_Type (Typ)
23148 and then Designated_Type (Typ) = Disp_Typ
23150 CW_Typ := Access_Class_Wide_Type;
23153 if Present (CW_Typ) then
23155 Make_Type_Conversion (Loc,
23156 Subtype_Mark => New_Occurrence_Of (CW_Typ, Loc),
23157 Expression => New_Occurrence_Of (Ent, Loc)));
23158 Set_Etype (N, CW_Typ);
23165 procedure Replace_Types is new Traverse_Proc (Replace_Type);
23167 -- Start of processing for Process_Class_Wide_Condition
23170 -- The subprogram subject to Pre'Class/Post'Class does not have a
23171 -- dispatching type, therefore the aspect/pragma is illegal.
23173 if No (Disp_Typ) then
23174 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23176 if From_Aspect_Specification (N) then
23178 ("aspect % can only be specified for a primitive operation "
23179 & "of a tagged type", Corresponding_Aspect (N));
23181 -- The pragma is a source construct
23185 ("pragma % can only be specified for a primitive operation "
23186 & "of a tagged type", N);
23190 Replace_Types (Expr);
23191 end Process_Class_Wide_Condition;
23195 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23196 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23197 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
23199 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
23202 Restore_Scope : Boolean := False;
23204 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23207 -- Do not analyze the pragma multiple times
23209 if Is_Analyzed_Pragma (N) then
23213 -- Set the Ghost mode in effect from the pragma. Due to the delayed
23214 -- analysis of the pragma, the Ghost mode at point of declaration and
23215 -- point of analysis may not necessarely be the same. Use the mode in
23216 -- effect at the point of declaration.
23218 Set_Ghost_Mode (N);
23220 -- Ensure that the subprogram and its formals are visible when analyzing
23221 -- the expression of the pragma.
23223 if not In_Open_Scopes (Spec_Id) then
23224 Restore_Scope := True;
23225 Push_Scope (Spec_Id);
23227 if Is_Generic_Subprogram (Spec_Id) then
23228 Install_Generic_Formals (Spec_Id);
23230 Install_Formals (Spec_Id);
23234 Errors := Serious_Errors_Detected;
23235 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23237 -- Emit a clarification message when the expression contains at least
23238 -- one undefined reference, possibly due to contract "freezing".
23240 if Errors /= Serious_Errors_Detected
23241 and then Present (Freeze_Id)
23242 and then Has_Undefined_Reference (Expr)
23244 Contract_Freeze_Error (Spec_Id, Freeze_Id);
23247 -- For a class-wide condition, a reference to a controlling formal must
23248 -- be interpreted as having the class-wide type (or an access to such)
23249 -- so that the inherited condition can be properly applied to any
23250 -- overriding operation (see ARM12 6.6.1 (7)).
23252 if Class_Present (N) then
23253 Process_Class_Wide_Condition (Expr, Spec_Id, Subp_Decl);
23256 if Restore_Scope then
23260 -- Currently it is not possible to inline pre/postconditions on a
23261 -- subprogram subject to pragma Inline_Always.
23263 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23264 Ghost_Mode := Save_Ghost_Mode;
23266 Set_Is_Analyzed_Pragma (N);
23267 end Analyze_Pre_Post_Condition_In_Decl_Part;
23269 ------------------------------------------
23270 -- Analyze_Refined_Depends_In_Decl_Part --
23271 ------------------------------------------
23273 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23274 Body_Inputs : Elist_Id := No_Elist;
23275 Body_Outputs : Elist_Id := No_Elist;
23276 -- The inputs and outputs of the subprogram body synthesized from pragma
23277 -- Refined_Depends.
23279 Dependencies : List_Id := No_List;
23281 -- The corresponding Depends pragma along with its clauses
23283 Matched_Items : Elist_Id := No_Elist;
23284 -- A list containing the entities of all successfully matched items
23285 -- found in pragma Depends.
23287 Refinements : List_Id := No_List;
23288 -- The clauses of pragma Refined_Depends
23290 Spec_Id : Entity_Id;
23291 -- The entity of the subprogram subject to pragma Refined_Depends
23293 Spec_Inputs : Elist_Id := No_Elist;
23294 Spec_Outputs : Elist_Id := No_Elist;
23295 -- The inputs and outputs of the subprogram spec synthesized from pragma
23298 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
23299 -- Try to match a single dependency clause Dep_Clause against one or
23300 -- more refinement clauses found in list Refinements. Each successful
23301 -- match eliminates at least one refinement clause from Refinements.
23303 procedure Check_Output_States;
23304 -- Determine whether pragma Depends contains an output state with a
23305 -- visible refinement and if so, ensure that pragma Refined_Depends
23306 -- mentions all its constituents as outputs.
23308 procedure Normalize_Clauses (Clauses : List_Id);
23309 -- Given a list of dependence or refinement clauses Clauses, normalize
23310 -- each clause by creating multiple dependencies with exactly one input
23313 procedure Report_Extra_Clauses;
23314 -- Emit an error for each extra clause found in list Refinements
23316 -----------------------------
23317 -- Check_Dependency_Clause --
23318 -----------------------------
23320 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
23321 Dep_Input : constant Node_Id := Expression (Dep_Clause);
23322 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23324 function Is_In_Out_State_Clause return Boolean;
23325 -- Determine whether dependence clause Dep_Clause denotes an abstract
23326 -- state that depends on itself (State => State).
23328 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23329 -- Determine whether item Item denotes an abstract state with visible
23330 -- null refinement.
23332 procedure Match_Items
23333 (Dep_Item : Node_Id;
23334 Ref_Item : Node_Id;
23335 Matched : out Boolean);
23336 -- Try to match dependence item Dep_Item against refinement item
23337 -- Ref_Item. To match against a possible null refinement (see 2, 7),
23338 -- set Ref_Item to Empty. Flag Matched is set to True when one of
23339 -- the following conformance scenarios is in effect:
23340 -- 1) Both items denote null
23341 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
23342 -- 3) Both items denote attribute 'Result
23343 -- 4) Both items denote the same object
23344 -- 5) Both items denote the same formal parameter
23345 -- 6) Both items denote the same current instance of a type
23346 -- 7) Both items denote the same discriminant
23347 -- 8) Dep_Item is an abstract state with visible null refinement
23348 -- and Ref_Item denotes null.
23349 -- 9) Dep_Item is an abstract state with visible null refinement
23350 -- and Ref_Item is Empty (special case).
23351 -- 10) Dep_Item is an abstract state with visible non-null
23352 -- refinement and Ref_Item denotes one of its constituents.
23353 -- 11) Dep_Item is an abstract state without a visible refinement
23354 -- and Ref_Item denotes the same state.
23355 -- When scenario 10 is in effect, the entity of the abstract state
23356 -- denoted by Dep_Item is added to list Refined_States.
23358 procedure Record_Item
(Item_Id
: Entity_Id
);
23359 -- Store the entity of an item denoted by Item_Id in Matched_Items
23361 ----------------------------
23362 -- Is_In_Out_State_Clause --
23363 ----------------------------
23365 function Is_In_Out_State_Clause
return Boolean is
23366 Dep_Input_Id
: Entity_Id
;
23367 Dep_Output_Id
: Entity_Id
;
23370 -- Detect the following clause:
23373 if Is_Entity_Name
(Dep_Input
)
23374 and then Is_Entity_Name
(Dep_Output
)
23376 -- Handle abstract views generated for limited with clauses
23378 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
23379 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
23382 Ekind
(Dep_Input_Id
) = E_Abstract_State
23383 and then Dep_Input_Id
= Dep_Output_Id
;
23387 end Is_In_Out_State_Clause
;
23389 ---------------------------
23390 -- Is_Null_Refined_State --
23391 ---------------------------
23393 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
23394 Item_Id
: Entity_Id
;
23397 if Is_Entity_Name
(Item
) then
23399 -- Handle abstract views generated for limited with clauses
23401 Item_Id
:= Available_View
(Entity_Of
(Item
));
23404 Ekind
(Item_Id
) = E_Abstract_State
23405 and then Has_Null_Visible_Refinement
(Item_Id
);
23409 end Is_Null_Refined_State
;
23415 procedure Match_Items
23416 (Dep_Item
: Node_Id
;
23417 Ref_Item
: Node_Id
;
23418 Matched
: out Boolean)
23420 Dep_Item_Id
: Entity_Id
;
23421 Ref_Item_Id
: Entity_Id
;
23424 -- Assume that the two items do not match
23428 -- A null matches null or Empty (special case)
23430 if Nkind
(Dep_Item
) = N_Null
23431 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
23435 -- Attribute 'Result matches attribute 'Result
23437 elsif Is_Attribute_Result
(Dep_Item
)
23438 and then Is_Attribute_Result
(Dep_Item
)
23442 -- Abstract states, current instances of concurrent types,
23443 -- discriminants, formal parameters and objects.
23445 elsif Is_Entity_Name
(Dep_Item
) then
23447 -- Handle abstract views generated for limited with clauses
23449 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
23451 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
23453 -- An abstract state with visible null refinement matches
23454 -- null or Empty (special case).
23456 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
23457 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
23459 Record_Item
(Dep_Item_Id
);
23462 -- An abstract state with visible non-null refinement
23463 -- matches one of its constituents.
23465 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
23466 if Is_Entity_Name
(Ref_Item
) then
23467 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
23469 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
23472 and then Present
(Encapsulating_State
(Ref_Item_Id
))
23473 and then Encapsulating_State
(Ref_Item_Id
) =
23476 Record_Item
(Dep_Item_Id
);
23481 -- An abstract state without a visible refinement matches
23484 elsif Is_Entity_Name
(Ref_Item
)
23485 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
23487 Record_Item
(Dep_Item_Id
);
23491 -- A current instance of a concurrent type, discriminant,
23492 -- formal parameter or an object matches itself.
23494 elsif Is_Entity_Name
(Ref_Item
)
23495 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
23497 Record_Item
(Dep_Item_Id
);
23507 procedure Record_Item
(Item_Id
: Entity_Id
) is
23509 if not Contains
(Matched_Items
, Item_Id
) then
23510 Append_New_Elmt
(Item_Id
, Matched_Items
);
23516 Clause_Matched
: Boolean := False;
23517 Dummy
: Boolean := False;
23518 Inputs_Match
: Boolean;
23519 Next_Ref_Clause
: Node_Id
;
23520 Outputs_Match
: Boolean;
23521 Ref_Clause
: Node_Id
;
23522 Ref_Input
: Node_Id
;
23523 Ref_Output
: Node_Id
;
23525 -- Start of processing for Check_Dependency_Clause
23528 -- Do not perform this check in an instance because it was already
23529 -- performed successfully in the generic template.
23531 if Is_Generic_Instance
(Spec_Id
) then
23535 -- Examine all refinement clauses and compare them against the
23536 -- dependence clause.
23538 Ref_Clause
:= First
(Refinements
);
23539 while Present
(Ref_Clause
) loop
23540 Next_Ref_Clause
:= Next
(Ref_Clause
);
23542 -- Obtain the attributes of the current refinement clause
23544 Ref_Input
:= Expression
(Ref_Clause
);
23545 Ref_Output
:= First
(Choices
(Ref_Clause
));
23547 -- The current refinement clause matches the dependence clause
23548 -- when both outputs match and both inputs match. See routine
23549 -- Match_Items for all possible conformance scenarios.
23551 -- Depends Dep_Output => Dep_Input
23555 -- Refined_Depends Ref_Output => Ref_Input
23558 (Dep_Item
=> Dep_Input
,
23559 Ref_Item
=> Ref_Input
,
23560 Matched
=> Inputs_Match
);
23563 (Dep_Item
=> Dep_Output
,
23564 Ref_Item
=> Ref_Output
,
23565 Matched
=> Outputs_Match
);
23567 -- An In_Out state clause may be matched against a refinement with
23568 -- a null input or null output as long as the non-null side of the
23569 -- relation contains a valid constituent of the In_Out_State.
23571 if Is_In_Out_State_Clause
then
23573 -- Depends => (State => State)
23574 -- Refined_Depends => (null => Constit) -- OK
23577 and then not Outputs_Match
23578 and then Nkind
(Ref_Output
) = N_Null
23580 Outputs_Match
:= True;
23583 -- Depends => (State => State)
23584 -- Refined_Depends => (Constit => null) -- OK
23586 if not Inputs_Match
23587 and then Outputs_Match
23588 and then Nkind
(Ref_Input
) = N_Null
23590 Inputs_Match
:= True;
23594 -- The current refinement clause is legally constructed following
23595 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
23596 -- the pool of candidates. The seach continues because a single
23597 -- dependence clause may have multiple matching refinements.
23599 if Inputs_Match
and then Outputs_Match
then
23600 Clause_Matched
:= True;
23601 Remove
(Ref_Clause
);
23604 Ref_Clause
:= Next_Ref_Clause
;
23607 -- Depending on the order or composition of refinement clauses, an
23608 -- In_Out state clause may not be directly refinable.
23610 -- Depends => ((Output, State) => (Input, State))
23611 -- Refined_State => (State => (Constit_1, Constit_2))
23612 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
23614 -- Matching normalized clause (State => State) fails because there is
23615 -- no direct refinement capable of satisfying this relation. Another
23616 -- similar case arises when clauses (Constit_1 => Input) and (Output
23617 -- => Constit_2) are matched first, leaving no candidates for clause
23618 -- (State => State). Both scenarios are legal as long as one of the
23619 -- previous clauses mentioned a valid constituent of State.
23621 if not Clause_Matched
23622 and then Is_In_Out_State_Clause
23624 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
23626 Clause_Matched
:= True;
23629 -- A clause where the input is an abstract state with visible null
23630 -- refinement is implicitly matched when the output has already been
23631 -- matched in a previous clause.
23633 -- Depends => (Output => State) -- implicitly OK
23634 -- Refined_State => (State => null)
23635 -- Refined_Depends => (Output => ...)
23637 if not Clause_Matched
23638 and then Is_Null_Refined_State
(Dep_Input
)
23639 and then Is_Entity_Name
(Dep_Output
)
23641 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
23643 Clause_Matched
:= True;
23646 -- A clause where the output is an abstract state with visible null
23647 -- refinement is implicitly matched when the input has already been
23648 -- matched in a previous clause.
23650 -- Depends => (State => Input) -- implicitly OK
23651 -- Refined_State => (State => null)
23652 -- Refined_Depends => (... => Input)
23654 if not Clause_Matched
23655 and then Is_Null_Refined_State
(Dep_Output
)
23656 and then Is_Entity_Name
(Dep_Input
)
23658 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
23660 Clause_Matched
:= True;
23663 -- At this point either all refinement clauses have been examined or
23664 -- pragma Refined_Depends contains a solitary null. Only an abstract
23665 -- state with null refinement can possibly match these cases.
23667 -- Depends => (State => null)
23668 -- Refined_State => (State => null)
23669 -- Refined_Depends => null -- OK
23671 if not Clause_Matched
then
23673 (Dep_Item
=> Dep_Input
,
23675 Matched
=> Inputs_Match
);
23678 (Dep_Item
=> Dep_Output
,
23680 Matched
=> Outputs_Match
);
23682 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
23685 -- If the contents of Refined_Depends are legal, then the current
23686 -- dependence clause should be satisfied either by an explicit match
23687 -- or by one of the special cases.
23689 if not Clause_Matched
then
23691 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
23692 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
23694 end Check_Dependency_Clause
;
23696 -------------------------
23697 -- Check_Output_States --
23698 -------------------------
23700 procedure Check_Output_States
is
23701 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23702 -- Determine whether all constituents of state State_Id with visible
23703 -- refinement are used as outputs in pragma Refined_Depends. Emit an
23704 -- error if this is not the case.
23706 -----------------------------
23707 -- Check_Constituent_Usage --
23708 -----------------------------
23710 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23711 Constit_Elmt
: Elmt_Id
;
23712 Constit_Id
: Entity_Id
;
23713 Posted
: Boolean := False;
23716 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23717 while Present
(Constit_Elmt
) loop
23718 Constit_Id
:= Node
(Constit_Elmt
);
23720 -- The constituent acts as an input (SPARK RM 7.2.5(3))
23722 if Present
(Body_Inputs
)
23723 and then Appears_In
(Body_Inputs
, Constit_Id
)
23725 Error_Msg_Name_1
:= Chars
(State_Id
);
23727 ("constituent & of state % must act as output in "
23728 & "dependence refinement", N
, Constit_Id
);
23730 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23732 elsif No
(Body_Outputs
)
23733 or else not Appears_In
(Body_Outputs
, Constit_Id
)
23738 ("output state & must be replaced by all its "
23739 & "constituents in dependence refinement",
23744 ("\constituent & is missing in output list",
23748 Next_Elmt
(Constit_Elmt
);
23750 end Check_Constituent_Usage
;
23755 Item_Elmt
: Elmt_Id
;
23756 Item_Id
: Entity_Id
;
23758 -- Start of processing for Check_Output_States
23761 -- Do not perform this check in an instance because it was already
23762 -- performed successfully in the generic template.
23764 if Is_Generic_Instance
(Spec_Id
) then
23767 -- Inspect the outputs of pragma Depends looking for a state with a
23768 -- visible refinement.
23770 elsif Present
(Spec_Outputs
) then
23771 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
23772 while Present
(Item_Elmt
) loop
23773 Item
:= Node
(Item_Elmt
);
23775 -- Deal with the mixed nature of the input and output lists
23777 if Nkind
(Item
) = N_Defining_Identifier
then
23780 Item_Id
:= Available_View
(Entity_Of
(Item
));
23783 if Ekind
(Item_Id
) = E_Abstract_State
then
23785 -- The state acts as an input-output, skip it
23787 if Present
(Spec_Inputs
)
23788 and then Appears_In
(Spec_Inputs
, Item_Id
)
23792 -- Ensure that all of the constituents are utilized as
23793 -- outputs in pragma Refined_Depends.
23795 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
23796 Check_Constituent_Usage
(Item_Id
);
23800 Next_Elmt
(Item_Elmt
);
23803 end Check_Output_States
;
23805 -----------------------
23806 -- Normalize_Clauses --
23807 -----------------------
23809 procedure Normalize_Clauses
(Clauses
: List_Id
) is
23810 procedure Normalize_Inputs
(Clause
: Node_Id
);
23811 -- Normalize clause Clause by creating multiple clauses for each
23812 -- input item of Clause. It is assumed that Clause has exactly one
23813 -- output. The transformation is as follows:
23815 -- Output => (Input_1, Input_2) -- original
23817 -- Output => Input_1 -- normalizations
23818 -- Output => Input_2
23820 procedure Normalize_Outputs
(Clause
: Node_Id
);
23821 -- Normalize clause Clause by creating multiple clause for each
23822 -- output item of Clause. The transformation is as follows:
23824 -- (Output_1, Output_2) => Input -- original
23826 -- Output_1 => Input -- normalization
23827 -- Output_2 => Input
23829 ----------------------
23830 -- Normalize_Inputs --
23831 ----------------------
23833 procedure Normalize_Inputs
(Clause
: Node_Id
) is
23834 Inputs
: constant Node_Id
:= Expression
(Clause
);
23835 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
23836 Output
: constant List_Id
:= Choices
(Clause
);
23837 Last_Input
: Node_Id
;
23839 New_Clause
: Node_Id
;
23840 Next_Input
: Node_Id
;
23843 -- Normalization is performed only when the original clause has
23844 -- more than one input. Multiple inputs appear as an aggregate.
23846 if Nkind
(Inputs
) = N_Aggregate
then
23847 Last_Input
:= Last
(Expressions
(Inputs
));
23849 -- Create a new clause for each input
23851 Input
:= First
(Expressions
(Inputs
));
23852 while Present
(Input
) loop
23853 Next_Input
:= Next
(Input
);
23855 -- Unhook the current input from the original input list
23856 -- because it will be relocated to a new clause.
23860 -- Special processing for the last input. At this point the
23861 -- original aggregate has been stripped down to one element.
23862 -- Replace the aggregate by the element itself.
23864 if Input
= Last_Input
then
23865 Rewrite
(Inputs
, Input
);
23867 -- Generate a clause of the form:
23872 Make_Component_Association
(Loc
,
23873 Choices
=> New_Copy_List_Tree
(Output
),
23874 Expression
=> Input
);
23876 -- The new clause contains replicated content that has
23877 -- already been analyzed, mark the clause as analyzed.
23879 Set_Analyzed
(New_Clause
);
23880 Insert_After
(Clause
, New_Clause
);
23883 Input
:= Next_Input
;
23886 end Normalize_Inputs
;
23888 -----------------------
23889 -- Normalize_Outputs --
23890 -----------------------
23892 procedure Normalize_Outputs
(Clause
: Node_Id
) is
23893 Inputs
: constant Node_Id
:= Expression
(Clause
);
23894 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
23895 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
23896 Last_Output
: Node_Id
;
23897 New_Clause
: Node_Id
;
23898 Next_Output
: Node_Id
;
23902 -- Multiple outputs appear as an aggregate. Nothing to do when
23903 -- the clause has exactly one output.
23905 if Nkind
(Outputs
) = N_Aggregate
then
23906 Last_Output
:= Last
(Expressions
(Outputs
));
23908 -- Create a clause for each output. Note that each time a new
23909 -- clause is created, the original output list slowly shrinks
23910 -- until there is one item left.
23912 Output
:= First
(Expressions
(Outputs
));
23913 while Present
(Output
) loop
23914 Next_Output
:= Next
(Output
);
23916 -- Unhook the output from the original output list as it
23917 -- will be relocated to a new clause.
23921 -- Special processing for the last output. At this point
23922 -- the original aggregate has been stripped down to one
23923 -- element. Replace the aggregate by the element itself.
23925 if Output
= Last_Output
then
23926 Rewrite
(Outputs
, Output
);
23929 -- Generate a clause of the form:
23930 -- (Output => Inputs)
23933 Make_Component_Association
(Loc
,
23934 Choices
=> New_List
(Output
),
23935 Expression
=> New_Copy_Tree
(Inputs
));
23937 -- The new clause contains replicated content that has
23938 -- already been analyzed. There is not need to reanalyze
23941 Set_Analyzed
(New_Clause
);
23942 Insert_After
(Clause
, New_Clause
);
23945 Output
:= Next_Output
;
23948 end Normalize_Outputs
;
23954 -- Start of processing for Normalize_Clauses
23957 Clause
:= First
(Clauses
);
23958 while Present
(Clause
) loop
23959 Normalize_Outputs
(Clause
);
23963 Clause
:= First
(Clauses
);
23964 while Present
(Clause
) loop
23965 Normalize_Inputs
(Clause
);
23968 end Normalize_Clauses
;
23970 --------------------------
23971 -- Report_Extra_Clauses --
23972 --------------------------
23974 procedure Report_Extra_Clauses
is
23978 -- Do not perform this check in an instance because it was already
23979 -- performed successfully in the generic template.
23981 if Is_Generic_Instance
(Spec_Id
) then
23984 elsif Present
(Refinements
) then
23985 Clause
:= First
(Refinements
);
23986 while Present
(Clause
) loop
23988 -- Do not complain about a null input refinement, since a null
23989 -- input legitimately matches anything.
23991 if Nkind
(Clause
) = N_Component_Association
23992 and then Nkind
(Expression
(Clause
)) = N_Null
23998 ("unmatched or extra clause in dependence refinement",
24005 end Report_Extra_Clauses
;
24009 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
24010 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
24011 Errors
: constant Nat
:= Serious_Errors_Detected
;
24017 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
24020 -- Do not analyze the pragma multiple times
24022 if Is_Analyzed_Pragma
(N
) then
24026 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
24028 -- Use the anonymous object as the proper spec when Refined_Depends
24029 -- applies to the body of a single task type. The object carries the
24030 -- proper Chars as well as all non-refined versions of pragmas.
24032 if Is_Single_Concurrent_Type
(Spec_Id
) then
24033 Spec_Id
:= Anonymous_Object
(Spec_Id
);
24036 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
24038 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
24039 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
24041 if No
(Depends
) then
24043 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
24044 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
24048 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
24050 -- A null dependency relation renders the refinement useless because it
24051 -- cannot possibly mention abstract states with visible refinement. Note
24052 -- that the inverse is not true as states may be refined to null
24053 -- (SPARK RM 7.2.5(2)).
24055 if Nkind
(Deps
) = N_Null
then
24057 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
24058 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
24062 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
24063 -- This ensures that the categorization of all refined dependency items
24064 -- is consistent with their role.
24066 Analyze_Depends_In_Decl_Part
(N
);
24068 -- Do not match dependencies against refinements if Refined_Depends is
24069 -- illegal to avoid emitting misleading error.
24071 if Serious_Errors_Detected
= Errors
then
24073 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
24074 -- the inputs and outputs of the subprogram spec and body to verify
24075 -- the use of states with visible refinement and their constituents.
24077 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
24078 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
24080 Collect_Subprogram_Inputs_Outputs
24081 (Subp_Id
=> Spec_Id
,
24082 Synthesize
=> True,
24083 Subp_Inputs
=> Spec_Inputs
,
24084 Subp_Outputs
=> Spec_Outputs
,
24085 Global_Seen
=> Dummy
);
24087 Collect_Subprogram_Inputs_Outputs
24088 (Subp_Id
=> Body_Id
,
24089 Synthesize
=> True,
24090 Subp_Inputs
=> Body_Inputs
,
24091 Subp_Outputs
=> Body_Outputs
,
24092 Global_Seen
=> Dummy
);
24094 -- For an output state with a visible refinement, ensure that all
24095 -- constituents appear as outputs in the dependency refinement.
24097 Check_Output_States
;
24100 -- Matching is disabled in ASIS because clauses are not normalized as
24101 -- this is a tree altering activity similar to expansion.
24107 -- Multiple dependency clauses appear as component associations of an
24108 -- aggregate. Note that the clauses are copied because the algorithm
24109 -- modifies them and this should not be visible in Depends.
24111 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
24112 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
24113 Normalize_Clauses
(Dependencies
);
24115 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
24117 if Nkind
(Refs
) = N_Null
then
24118 Refinements
:= No_List
;
24120 -- Multiple dependency clauses appear as component associations of an
24121 -- aggregate. Note that the clauses are copied because the algorithm
24122 -- modifies them and this should not be visible in Refined_Depends.
24124 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
24125 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
24126 Normalize_Clauses
(Refinements
);
24129 -- At this point the clauses of pragmas Depends and Refined_Depends
24130 -- have been normalized into simple dependencies between one output
24131 -- and one input. Examine all clauses of pragma Depends looking for
24132 -- matching clauses in pragma Refined_Depends.
24134 Clause
:= First
(Dependencies
);
24135 while Present
(Clause
) loop
24136 Check_Dependency_Clause
(Clause
);
24140 if Serious_Errors_Detected
= Errors
then
24141 Report_Extra_Clauses
;
24146 Set_Is_Analyzed_Pragma
(N
);
24147 end Analyze_Refined_Depends_In_Decl_Part
;
24149 -----------------------------------------
24150 -- Analyze_Refined_Global_In_Decl_Part --
24151 -----------------------------------------
24153 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
24155 -- The corresponding Global pragma
24157 Has_In_State
: Boolean := False;
24158 Has_In_Out_State
: Boolean := False;
24159 Has_Out_State
: Boolean := False;
24160 Has_Proof_In_State
: Boolean := False;
24161 -- These flags are set when the corresponding Global pragma has a state
24162 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
24165 Has_Null_State
: Boolean := False;
24166 -- This flag is set when the corresponding Global pragma has at least
24167 -- one state with a null refinement.
24169 In_Constits
: Elist_Id
:= No_Elist
;
24170 In_Out_Constits
: Elist_Id
:= No_Elist
;
24171 Out_Constits
: Elist_Id
:= No_Elist
;
24172 Proof_In_Constits
: Elist_Id
:= No_Elist
;
24173 -- These lists contain the entities of all Input, In_Out, Output and
24174 -- Proof_In constituents that appear in Refined_Global and participate
24175 -- in state refinement.
24177 In_Items
: Elist_Id
:= No_Elist
;
24178 In_Out_Items
: Elist_Id
:= No_Elist
;
24179 Out_Items
: Elist_Id
:= No_Elist
;
24180 Proof_In_Items
: Elist_Id
:= No_Elist
;
24181 -- These list contain the entities of all Input, In_Out, Output and
24182 -- Proof_In items defined in the corresponding Global pragma.
24184 Spec_Id
: Entity_Id
;
24185 -- The entity of the subprogram subject to pragma Refined_Global
24187 States
: Elist_Id
:= No_Elist
;
24188 -- A list of all states with visible refinement found in pragma Global
24190 procedure Check_In_Out_States
;
24191 -- Determine whether the corresponding Global pragma mentions In_Out
24192 -- states with visible refinement and if so, ensure that one of the
24193 -- following completions apply to the constituents of the state:
24194 -- 1) there is at least one constituent of mode In_Out
24195 -- 2) there is at least one Input and one Output constituent
24196 -- 3) not all constituents are present and one of them is of mode
24198 -- This routine may remove elements from In_Constits, In_Out_Constits,
24199 -- Out_Constits and Proof_In_Constits.
24201 procedure Check_Input_States
;
24202 -- Determine whether the corresponding Global pragma mentions Input
24203 -- states with visible refinement and if so, ensure that at least one of
24204 -- its constituents appears as an Input item in Refined_Global.
24205 -- This routine may remove elements from In_Constits, In_Out_Constits,
24206 -- Out_Constits and Proof_In_Constits.
24208 procedure Check_Output_States
;
24209 -- Determine whether the corresponding Global pragma mentions Output
24210 -- states with visible refinement and if so, ensure that all of its
24211 -- constituents appear as Output items in Refined_Global.
24212 -- This routine may remove elements from In_Constits, In_Out_Constits,
24213 -- Out_Constits and Proof_In_Constits.
24215 procedure Check_Proof_In_States
;
24216 -- Determine whether the corresponding Global pragma mentions Proof_In
24217 -- states with visible refinement and if so, ensure that at least one of
24218 -- its constituents appears as a Proof_In item in Refined_Global.
24219 -- This routine may remove elements from In_Constits, In_Out_Constits,
24220 -- Out_Constits and Proof_In_Constits.
24222 procedure Check_Refined_Global_List
24224 Global_Mode
: Name_Id
:= Name_Input
);
24225 -- Verify the legality of a single global list declaration. Global_Mode
24226 -- denotes the current mode in effect.
24228 procedure Collect_Global_Items
24230 Mode
: Name_Id
:= Name_Input
);
24231 -- Gather all input, in out, output and Proof_In items from node List
24232 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
24233 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
24234 -- and Has_Proof_In_State are set when there is at least one abstract
24235 -- state with visible refinement available in the corresponding mode.
24236 -- Flag Has_Null_State is set when at least state has a null refinement.
24237 -- Mode enotes the current global mode in effect.
24239 function Present_Then_Remove
24241 Item
: Entity_Id
) return Boolean;
24242 -- Search List for a particular entity Item. If Item has been found,
24243 -- remove it from List. This routine is used to strip lists In_Constits,
24244 -- In_Out_Constits and Out_Constits of valid constituents.
24246 procedure Report_Extra_Constituents
;
24247 -- Emit an error for each constituent found in lists In_Constits,
24248 -- In_Out_Constits and Out_Constits.
24250 -------------------------
24251 -- Check_In_Out_States --
24252 -------------------------
24254 procedure Check_In_Out_States
is
24255 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24256 -- Determine whether one of the following coverage scenarios is in
24258 -- 1) there is at least one constituent of mode In_Out
24259 -- 2) there is at least one Input and one Output constituent
24260 -- 3) not all constituents are present and one of them is of mode
24262 -- If this is not the case, emit an error.
24264 -----------------------------
24265 -- Check_Constituent_Usage --
24266 -----------------------------
24268 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24269 Constit_Elmt
: Elmt_Id
;
24270 Constit_Id
: Entity_Id
;
24271 Has_Missing
: Boolean := False;
24272 In_Out_Seen
: Boolean := False;
24273 In_Seen
: Boolean := False;
24274 Out_Seen
: Boolean := False;
24277 -- Process all the constituents of the state and note their modes
24278 -- within the global refinement.
24280 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
24281 while Present
(Constit_Elmt
) loop
24282 Constit_Id
:= Node
(Constit_Elmt
);
24284 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
24287 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
24288 In_Out_Seen
:= True;
24290 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
24293 -- A Proof_In constituent cannot participate in the completion
24294 -- of an Output state (SPARK RM 7.2.4(5)).
24296 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
24297 Error_Msg_Name_1
:= Chars
(State_Id
);
24299 ("constituent & of state % must have mode Input, In_Out "
24300 & "or Output in global refinement", N
, Constit_Id
);
24303 Has_Missing
:= True;
24306 Next_Elmt
(Constit_Elmt
);
24309 -- A single In_Out constituent is a valid completion
24311 if In_Out_Seen
then
24314 -- A pair of one Input and one Output constituent is a valid
24317 elsif In_Seen
and Out_Seen
then
24320 -- A single Output constituent is a valid completion only when
24321 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
24323 elsif Out_Seen
and Has_Missing
then
24326 -- The state lacks a completion
24328 elsif not In_Seen
and not In_Out_Seen
and not Out_Seen
then
24330 ("missing global refinement of state &", N
, State_Id
);
24332 -- Otherwise the state has a malformed completion where at least
24333 -- one of the constituents has a different mode.
24337 ("global refinement of state & redefines the mode of its "
24338 & "constituents", N
, State_Id
);
24340 end Check_Constituent_Usage
;
24344 Item_Elmt
: Elmt_Id
;
24345 Item_Id
: Entity_Id
;
24347 -- Start of processing for Check_In_Out_States
24350 -- Do not perform this check in an instance because it was already
24351 -- performed successfully in the generic template.
24353 if Is_Generic_Instance
(Spec_Id
) then
24356 -- Inspect the In_Out items of the corresponding Global pragma
24357 -- looking for a state with a visible refinement.
24359 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
24360 Item_Elmt
:= First_Elmt
(In_Out_Items
);
24361 while Present
(Item_Elmt
) loop
24362 Item_Id
:= Node
(Item_Elmt
);
24364 -- Ensure that one of the three coverage variants is satisfied
24366 if Ekind
(Item_Id
) = E_Abstract_State
24367 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
24369 Check_Constituent_Usage
(Item_Id
);
24372 Next_Elmt
(Item_Elmt
);
24375 end Check_In_Out_States
;
24377 ------------------------
24378 -- Check_Input_States --
24379 ------------------------
24381 procedure Check_Input_States
is
24382 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24383 -- Determine whether at least one constituent of state State_Id with
24384 -- visible refinement is used and has mode Input. Ensure that the
24385 -- remaining constituents do not have In_Out, Output or Proof_In
24388 -----------------------------
24389 -- Check_Constituent_Usage --
24390 -----------------------------
24392 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24393 Constit_Elmt
: Elmt_Id
;
24394 Constit_Id
: Entity_Id
;
24395 In_Seen
: Boolean := False;
24398 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
24399 while Present
(Constit_Elmt
) loop
24400 Constit_Id
:= Node
(Constit_Elmt
);
24402 -- At least one of the constituents appears as an Input
24404 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
24407 -- The constituent appears in the global refinement, but has
24408 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
24410 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
24411 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
24412 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
24414 Error_Msg_Name_1
:= Chars
(State_Id
);
24416 ("constituent & of state % must have mode Input in global "
24417 & "refinement", N
, Constit_Id
);
24420 Next_Elmt
(Constit_Elmt
);
24423 -- Not one of the constituents appeared as Input
24425 if not In_Seen
then
24427 ("global refinement of state & must include at least one "
24428 & "constituent of mode Input", N
, State_Id
);
24430 end Check_Constituent_Usage
;
24434 Item_Elmt
: Elmt_Id
;
24435 Item_Id
: Entity_Id
;
24437 -- Start of processing for Check_Input_States
24440 -- Do not perform this check in an instance because it was already
24441 -- performed successfully in the generic template.
24443 if Is_Generic_Instance
(Spec_Id
) then
24446 -- Inspect the Input items of the corresponding Global pragma looking
24447 -- for a state with a visible refinement.
24449 elsif Has_In_State
and then Present
(In_Items
) then
24450 Item_Elmt
:= First_Elmt
(In_Items
);
24451 while Present
(Item_Elmt
) loop
24452 Item_Id
:= Node
(Item_Elmt
);
24454 -- Ensure that at least one of the constituents is utilized and
24455 -- is of mode Input.
24457 if Ekind
(Item_Id
) = E_Abstract_State
24458 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
24460 Check_Constituent_Usage
(Item_Id
);
24463 Next_Elmt
(Item_Elmt
);
24466 end Check_Input_States
;
24468 -------------------------
24469 -- Check_Output_States --
24470 -------------------------
24472 procedure Check_Output_States
is
24473 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24474 -- Determine whether all constituents of state State_Id with visible
24475 -- refinement are used and have mode Output. Emit an error if this is
24478 -----------------------------
24479 -- Check_Constituent_Usage --
24480 -----------------------------
24482 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24483 Constit_Elmt
: Elmt_Id
;
24484 Constit_Id
: Entity_Id
;
24485 Posted
: Boolean := False;
24488 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
24489 while Present
(Constit_Elmt
) loop
24490 Constit_Id
:= Node
(Constit_Elmt
);
24492 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
24495 -- The constituent appears in the global refinement, but has
24496 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
24498 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
24499 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
24500 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
24502 Error_Msg_Name_1
:= Chars
(State_Id
);
24504 ("constituent & of state % must have mode Output in "
24505 & "global refinement", N
, Constit_Id
);
24507 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24513 ("output state & must be replaced by all its "
24514 & "constituents in global refinement", N
, State_Id
);
24518 ("\constituent & is missing in output list",
24522 Next_Elmt
(Constit_Elmt
);
24524 end Check_Constituent_Usage
;
24528 Item_Elmt
: Elmt_Id
;
24529 Item_Id
: Entity_Id
;
24531 -- Start of processing for Check_Output_States
24534 -- Do not perform this check in an instance because it was already
24535 -- performed successfully in the generic template.
24537 if Is_Generic_Instance
(Spec_Id
) then
24540 -- Inspect the Output items of the corresponding Global pragma
24541 -- looking for a state with a visible refinement.
24543 elsif Has_Out_State
and then Present
(Out_Items
) then
24544 Item_Elmt
:= First_Elmt
(Out_Items
);
24545 while Present
(Item_Elmt
) loop
24546 Item_Id
:= Node
(Item_Elmt
);
24548 -- Ensure that all of the constituents are utilized and they
24549 -- have mode Output.
24551 if Ekind
(Item_Id
) = E_Abstract_State
24552 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
24554 Check_Constituent_Usage
(Item_Id
);
24557 Next_Elmt
(Item_Elmt
);
24560 end Check_Output_States
;
24562 ---------------------------
24563 -- Check_Proof_In_States --
24564 ---------------------------
24566 procedure Check_Proof_In_States
is
24567 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24568 -- Determine whether at least one constituent of state State_Id with
24569 -- visible refinement is used and has mode Proof_In. Ensure that the
24570 -- remaining constituents do not have Input, In_Out or Output modes.
24572 -----------------------------
24573 -- Check_Constituent_Usage --
24574 -----------------------------
24576 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24577 Constit_Elmt
: Elmt_Id
;
24578 Constit_Id
: Entity_Id
;
24579 Proof_In_Seen
: Boolean := False;
24582 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
24583 while Present
(Constit_Elmt
) loop
24584 Constit_Id
:= Node
(Constit_Elmt
);
24586 -- At least one of the constituents appears as Proof_In
24588 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
24589 Proof_In_Seen
:= True;
24591 -- The constituent appears in the global refinement, but has
24592 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
24594 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
24595 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
24596 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
24598 Error_Msg_Name_1
:= Chars
(State_Id
);
24600 ("constituent & of state % must have mode Proof_In in "
24601 & "global refinement", N
, Constit_Id
);
24604 Next_Elmt
(Constit_Elmt
);
24607 -- Not one of the constituents appeared as Proof_In
24609 if not Proof_In_Seen
then
24611 ("global refinement of state & must include at least one "
24612 & "constituent of mode Proof_In", N
, State_Id
);
24614 end Check_Constituent_Usage
;
24618 Item_Elmt
: Elmt_Id
;
24619 Item_Id
: Entity_Id
;
24621 -- Start of processing for Check_Proof_In_States
24624 -- Do not perform this check in an instance because it was already
24625 -- performed successfully in the generic template.
24627 if Is_Generic_Instance
(Spec_Id
) then
24630 -- Inspect the Proof_In items of the corresponding Global pragma
24631 -- looking for a state with a visible refinement.
24633 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
24634 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
24635 while Present
(Item_Elmt
) loop
24636 Item_Id
:= Node
(Item_Elmt
);
24638 -- Ensure that at least one of the constituents is utilized and
24639 -- is of mode Proof_In
24641 if Ekind
(Item_Id
) = E_Abstract_State
24642 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
24644 Check_Constituent_Usage
(Item_Id
);
24647 Next_Elmt
(Item_Elmt
);
24650 end Check_Proof_In_States
;
24652 -------------------------------
24653 -- Check_Refined_Global_List --
24654 -------------------------------
24656 procedure Check_Refined_Global_List
24658 Global_Mode
: Name_Id
:= Name_Input
)
24660 procedure Check_Refined_Global_Item
24662 Global_Mode
: Name_Id
);
24663 -- Verify the legality of a single global item declaration. Parameter
24664 -- Global_Mode denotes the current mode in effect.
24666 -------------------------------
24667 -- Check_Refined_Global_Item --
24668 -------------------------------
24670 procedure Check_Refined_Global_Item
24672 Global_Mode
: Name_Id
)
24674 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
24676 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
24677 -- Issue a common error message for all mode mismatches. Expect
24678 -- denotes the expected mode.
24680 -----------------------------
24681 -- Inconsistent_Mode_Error --
24682 -----------------------------
24684 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
24687 ("global item & has inconsistent modes", Item
, Item_Id
);
24689 Error_Msg_Name_1
:= Global_Mode
;
24690 Error_Msg_Name_2
:= Expect
;
24691 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
24692 end Inconsistent_Mode_Error
;
24694 -- Start of processing for Check_Refined_Global_Item
24697 -- When the state or object acts as a constituent of another
24698 -- state with a visible refinement, collect it for the state
24699 -- completeness checks performed later on. Note that the item
24700 -- acts as a constituent only when the encapsulating state is
24701 -- present in pragma Global.
24703 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
24704 and then Present
(Encapsulating_State
(Item_Id
))
24705 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
24706 and then Contains
(States
, Encapsulating_State
(Item_Id
))
24708 if Global_Mode
= Name_Input
then
24709 Append_New_Elmt
(Item_Id
, In_Constits
);
24711 elsif Global_Mode
= Name_In_Out
then
24712 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
24714 elsif Global_Mode
= Name_Output
then
24715 Append_New_Elmt
(Item_Id
, Out_Constits
);
24717 elsif Global_Mode
= Name_Proof_In
then
24718 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
24721 -- When not a constituent, ensure that both occurrences of the
24722 -- item in pragmas Global and Refined_Global match.
24724 elsif Contains
(In_Items
, Item_Id
) then
24725 if Global_Mode
/= Name_Input
then
24726 Inconsistent_Mode_Error
(Name_Input
);
24729 elsif Contains
(In_Out_Items
, Item_Id
) then
24730 if Global_Mode
/= Name_In_Out
then
24731 Inconsistent_Mode_Error
(Name_In_Out
);
24734 elsif Contains
(Out_Items
, Item_Id
) then
24735 if Global_Mode
/= Name_Output
then
24736 Inconsistent_Mode_Error
(Name_Output
);
24739 elsif Contains
(Proof_In_Items
, Item_Id
) then
24742 -- The item does not appear in the corresponding Global pragma,
24743 -- it must be an extra (SPARK RM 7.2.4(3)).
24746 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
24748 end Check_Refined_Global_Item
;
24754 -- Start of processing for Check_Refined_Global_List
24757 -- Do not perform this check in an instance because it was already
24758 -- performed successfully in the generic template.
24760 if Is_Generic_Instance
(Spec_Id
) then
24763 elsif Nkind
(List
) = N_Null
then
24766 -- Single global item declaration
24768 elsif Nkind_In
(List
, N_Expanded_Name
,
24770 N_Selected_Component
)
24772 Check_Refined_Global_Item
(List
, Global_Mode
);
24774 -- Simple global list or moded global list declaration
24776 elsif Nkind
(List
) = N_Aggregate
then
24778 -- The declaration of a simple global list appear as a collection
24781 if Present
(Expressions
(List
)) then
24782 Item
:= First
(Expressions
(List
));
24783 while Present
(Item
) loop
24784 Check_Refined_Global_Item
(Item
, Global_Mode
);
24788 -- The declaration of a moded global list appears as a collection
24789 -- of component associations where individual choices denote
24792 elsif Present
(Component_Associations
(List
)) then
24793 Item
:= First
(Component_Associations
(List
));
24794 while Present
(Item
) loop
24795 Check_Refined_Global_List
24796 (List
=> Expression
(Item
),
24797 Global_Mode
=> Chars
(First
(Choices
(Item
))));
24805 raise Program_Error
;
24811 raise Program_Error
;
24813 end Check_Refined_Global_List
;
24815 --------------------------
24816 -- Collect_Global_Items --
24817 --------------------------
24819 procedure Collect_Global_Items
24821 Mode
: Name_Id
:= Name_Input
)
24823 procedure Collect_Global_Item
24825 Item_Mode
: Name_Id
);
24826 -- Add a single item to the appropriate list. Item_Mode denotes the
24827 -- current mode in effect.
24829 -------------------------
24830 -- Collect_Global_Item --
24831 -------------------------
24833 procedure Collect_Global_Item
24835 Item_Mode
: Name_Id
)
24837 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
24838 -- The above handles abstract views of variables and states built
24839 -- for limited with clauses.
24842 -- Signal that the global list contains at least one abstract
24843 -- state with a visible refinement. Note that the refinement may
24844 -- be null in which case there are no constituents.
24846 if Ekind
(Item_Id
) = E_Abstract_State
then
24847 if Has_Null_Visible_Refinement
(Item_Id
) then
24848 Has_Null_State
:= True;
24850 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
24851 Append_New_Elmt
(Item_Id
, States
);
24853 if Item_Mode
= Name_Input
then
24854 Has_In_State
:= True;
24855 elsif Item_Mode
= Name_In_Out
then
24856 Has_In_Out_State
:= True;
24857 elsif Item_Mode
= Name_Output
then
24858 Has_Out_State
:= True;
24859 elsif Item_Mode
= Name_Proof_In
then
24860 Has_Proof_In_State
:= True;
24865 -- Add the item to the proper list
24867 if Item_Mode
= Name_Input
then
24868 Append_New_Elmt
(Item_Id
, In_Items
);
24869 elsif Item_Mode
= Name_In_Out
then
24870 Append_New_Elmt
(Item_Id
, In_Out_Items
);
24871 elsif Item_Mode
= Name_Output
then
24872 Append_New_Elmt
(Item_Id
, Out_Items
);
24873 elsif Item_Mode
= Name_Proof_In
then
24874 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
24876 end Collect_Global_Item
;
24882 -- Start of processing for Collect_Global_Items
24885 if Nkind
(List
) = N_Null
then
24888 -- Single global item declaration
24890 elsif Nkind_In
(List
, N_Expanded_Name
,
24892 N_Selected_Component
)
24894 Collect_Global_Item
(List
, Mode
);
24896 -- Single global list or moded global list declaration
24898 elsif Nkind
(List
) = N_Aggregate
then
24900 -- The declaration of a simple global list appear as a collection
24903 if Present
(Expressions
(List
)) then
24904 Item
:= First
(Expressions
(List
));
24905 while Present
(Item
) loop
24906 Collect_Global_Item
(Item
, Mode
);
24910 -- The declaration of a moded global list appears as a collection
24911 -- of component associations where individual choices denote mode.
24913 elsif Present
(Component_Associations
(List
)) then
24914 Item
:= First
(Component_Associations
(List
));
24915 while Present
(Item
) loop
24916 Collect_Global_Items
24917 (List
=> Expression
(Item
),
24918 Mode
=> Chars
(First
(Choices
(Item
))));
24926 raise Program_Error
;
24929 -- To accomodate partial decoration of disabled SPARK features, this
24930 -- routine may be called with illegal input. If this is the case, do
24931 -- not raise Program_Error.
24936 end Collect_Global_Items
;
24938 -------------------------
24939 -- Present_Then_Remove --
24940 -------------------------
24942 function Present_Then_Remove
24944 Item
: Entity_Id
) return Boolean
24949 if Present
(List
) then
24950 Elmt
:= First_Elmt
(List
);
24951 while Present
(Elmt
) loop
24952 if Node
(Elmt
) = Item
then
24953 Remove_Elmt
(List
, Elmt
);
24962 end Present_Then_Remove
;
24964 -------------------------------
24965 -- Report_Extra_Constituents --
24966 -------------------------------
24968 procedure Report_Extra_Constituents
is
24969 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
24970 -- Emit an error for every element of List
24972 ---------------------------------------
24973 -- Report_Extra_Constituents_In_List --
24974 ---------------------------------------
24976 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
24977 Constit_Elmt
: Elmt_Id
;
24980 if Present
(List
) then
24981 Constit_Elmt
:= First_Elmt
(List
);
24982 while Present
(Constit_Elmt
) loop
24983 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
24984 Next_Elmt
(Constit_Elmt
);
24987 end Report_Extra_Constituents_In_List
;
24989 -- Start of processing for Report_Extra_Constituents
24992 -- Do not perform this check in an instance because it was already
24993 -- performed successfully in the generic template.
24995 if Is_Generic_Instance
(Spec_Id
) then
24999 Report_Extra_Constituents_In_List
(In_Constits
);
25000 Report_Extra_Constituents_In_List
(In_Out_Constits
);
25001 Report_Extra_Constituents_In_List
(Out_Constits
);
25002 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
25004 end Report_Extra_Constituents
;
25008 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
25009 Errors
: constant Nat
:= Serious_Errors_Detected
;
25012 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
25015 -- Do not analyze the pragma multiple times
25017 if Is_Analyzed_Pragma
(N
) then
25021 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
25023 -- Use the anonymous object as the proper spec when Refined_Global
25024 -- applies to the body of a single task type. The object carries the
25025 -- proper Chars as well as all non-refined versions of pragmas.
25027 if Is_Single_Concurrent_Type
(Spec_Id
) then
25028 Spec_Id
:= Anonymous_Object
(Spec_Id
);
25031 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25032 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
25034 -- The subprogram declaration lacks pragma Global. This renders
25035 -- Refined_Global useless as there is nothing to refine.
25037 if No
(Global
) then
25039 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
25040 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
25044 -- Extract all relevant items from the corresponding Global pragma
25046 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
25048 -- Package and subprogram bodies are instantiated individually in
25049 -- a separate compiler pass. Due to this mode of instantiation, the
25050 -- refinement of a state may no longer be visible when a subprogram
25051 -- body contract is instantiated. Since the generic template is legal,
25052 -- do not perform this check in the instance to circumvent this oddity.
25054 if Is_Generic_Instance
(Spec_Id
) then
25057 -- Non-instance case
25060 -- The corresponding Global pragma must mention at least one state
25061 -- witha visible refinement at the point Refined_Global is processed.
25062 -- States with null refinements need Refined_Global pragma
25063 -- (SPARK RM 7.2.4(2)).
25065 if not Has_In_State
25066 and then not Has_In_Out_State
25067 and then not Has_Out_State
25068 and then not Has_Proof_In_State
25069 and then not Has_Null_State
25072 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
25073 & "depend on abstract state with visible refinement"),
25077 -- The global refinement of inputs and outputs cannot be null when
25078 -- the corresponding Global pragma contains at least one item except
25079 -- in the case where we have states with null refinements.
25081 elsif Nkind
(Items
) = N_Null
25083 (Present
(In_Items
)
25084 or else Present
(In_Out_Items
)
25085 or else Present
(Out_Items
)
25086 or else Present
(Proof_In_Items
))
25087 and then not Has_Null_State
25090 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
25091 & "global items"), N
, Spec_Id
);
25096 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
25097 -- This ensures that the categorization of all refined global items is
25098 -- consistent with their role.
25100 Analyze_Global_In_Decl_Part
(N
);
25102 -- Perform all refinement checks with respect to completeness and mode
25105 if Serious_Errors_Detected
= Errors
then
25106 Check_Refined_Global_List
(Items
);
25109 -- For Input states with visible refinement, at least one constituent
25110 -- must be used as an Input in the global refinement.
25112 if Serious_Errors_Detected
= Errors
then
25113 Check_Input_States
;
25116 -- Verify all possible completion variants for In_Out states with
25117 -- visible refinement.
25119 if Serious_Errors_Detected
= Errors
then
25120 Check_In_Out_States
;
25123 -- For Output states with visible refinement, all constituents must be
25124 -- used as Outputs in the global refinement.
25126 if Serious_Errors_Detected
= Errors
then
25127 Check_Output_States
;
25130 -- For Proof_In states with visible refinement, at least one constituent
25131 -- must be used as Proof_In in the global refinement.
25133 if Serious_Errors_Detected
= Errors
then
25134 Check_Proof_In_States
;
25137 -- Emit errors for all constituents that belong to other states with
25138 -- visible refinement that do not appear in Global.
25140 if Serious_Errors_Detected
= Errors
then
25141 Report_Extra_Constituents
;
25145 Set_Is_Analyzed_Pragma
(N
);
25146 end Analyze_Refined_Global_In_Decl_Part
;
25148 ----------------------------------------
25149 -- Analyze_Refined_State_In_Decl_Part --
25150 ----------------------------------------
25152 procedure Analyze_Refined_State_In_Decl_Part
25154 Freeze_Id
: Entity_Id
:= Empty
)
25156 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
25157 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
25158 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
25160 Available_States
: Elist_Id
:= No_Elist
;
25161 -- A list of all abstract states defined in the package declaration that
25162 -- are available for refinement. The list is used to report unrefined
25165 Body_States
: Elist_Id
:= No_Elist
;
25166 -- A list of all hidden states that appear in the body of the related
25167 -- package. The list is used to report unused hidden states.
25169 Constituents_Seen
: Elist_Id
:= No_Elist
;
25170 -- A list that contains all constituents processed so far. The list is
25171 -- used to detect multiple uses of the same constituent.
25173 Freeze_Posted
: Boolean := False;
25174 -- A flag that controls the output of a freezing-related error (see use
25177 Refined_States_Seen
: Elist_Id
:= No_Elist
;
25178 -- A list that contains all refined states processed so far. The list is
25179 -- used to detect duplicate refinements.
25181 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
25182 -- Perform full analysis of a single refinement clause
25184 procedure Report_Unrefined_States
(States
: Elist_Id
);
25185 -- Emit errors for all unrefined abstract states found in list States
25187 -------------------------------
25188 -- Analyze_Refinement_Clause --
25189 -------------------------------
25191 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
25192 AR_Constit
: Entity_Id
:= Empty
;
25193 AW_Constit
: Entity_Id
:= Empty
;
25194 ER_Constit
: Entity_Id
:= Empty
;
25195 EW_Constit
: Entity_Id
:= Empty
;
25196 -- The entities of external constituents that contain one of the
25197 -- following enabled properties: Async_Readers, Async_Writers,
25198 -- Effective_Reads and Effective_Writes.
25200 External_Constit_Seen
: Boolean := False;
25201 -- Flag used to mark when at least one external constituent is part
25202 -- of the state refinement.
25204 Non_Null_Seen
: Boolean := False;
25205 Null_Seen
: Boolean := False;
25206 -- Flags used to detect multiple uses of null in a single clause or a
25207 -- mixture of null and non-null constituents.
25209 Part_Of_Constits
: Elist_Id
:= No_Elist
;
25210 -- A list of all candidate constituents subject to indicator Part_Of
25211 -- where the encapsulating state is the current state.
25214 State_Id
: Entity_Id
;
25215 -- The current state being refined
25217 procedure Analyze_Constituent
(Constit
: Node_Id
);
25218 -- Perform full analysis of a single constituent
25220 procedure Check_External_Property
25221 (Prop_Nam
: Name_Id
;
25223 Constit
: Entity_Id
);
25224 -- Determine whether a property denoted by name Prop_Nam is present
25225 -- in both the refined state and constituent Constit. Flag Enabled
25226 -- should be set when the property applies to the refined state. If
25227 -- this is not the case, emit an error message.
25229 procedure Match_State
;
25230 -- Determine whether the state being refined appears in list
25231 -- Available_States. Emit an error when attempting to re-refine the
25232 -- state or when the state is not defined in the package declaration,
25233 -- otherwise remove the state from Available_States.
25235 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
25236 -- Emit errors for all unused Part_Of constituents in list Constits
25238 -------------------------
25239 -- Analyze_Constituent --
25240 -------------------------
25242 procedure Analyze_Constituent
(Constit
: Node_Id
) is
25243 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
25244 -- Determine whether constituent Constit denoted by its entity
25245 -- Constit_Id appears in Body_States. Emit an error when the
25246 -- constituent is not a valid hidden state of the related package
25247 -- or when it is used more than once. Otherwise remove the
25248 -- constituent from Body_States.
25250 -----------------------
25251 -- Match_Constituent --
25252 -----------------------
25254 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
25255 procedure Collect_Constituent
;
25256 -- Verify the legality of constituent Constit_Id and add it to
25257 -- the refinements of State_Id.
25259 -------------------------
25260 -- Collect_Constituent --
25261 -------------------------
25263 procedure Collect_Constituent
is
25265 if Is_Ghost_Entity
(State_Id
) then
25266 if Is_Ghost_Entity
(Constit_Id
) then
25268 -- The Ghost policy in effect at the point of abstract
25269 -- state declaration and constituent must match
25270 -- (SPARK RM 6.9(16)).
25272 if Is_Checked_Ghost_Entity
(State_Id
)
25273 and then Is_Ignored_Ghost_Entity
(Constit_Id
)
25275 Error_Msg_Sloc
:= Sloc
(Constit
);
25278 ("incompatible ghost policies in effect", State
);
25280 ("\abstract state & declared with ghost policy "
25281 & "Check", State
, State_Id
);
25283 ("\constituent & declared # with ghost policy "
25284 & "Ignore", State
, Constit_Id
);
25286 elsif Is_Ignored_Ghost_Entity
(State_Id
)
25287 and then Is_Checked_Ghost_Entity
(Constit_Id
)
25289 Error_Msg_Sloc
:= Sloc
(Constit
);
25292 ("incompatible ghost policies in effect", State
);
25294 ("\abstract state & declared with ghost policy "
25295 & "Ignore", State
, State_Id
);
25297 ("\constituent & declared # with ghost policy "
25298 & "Check", State
, Constit_Id
);
25301 -- A constituent of a Ghost abstract state must be a
25302 -- Ghost entity (SPARK RM 7.2.2(12)).
25306 ("constituent of ghost state & must be ghost",
25307 Constit
, State_Id
);
25311 -- A synchronized state must be refined by a synchronized
25312 -- object or another synchronized state (SPARK RM 9.6).
25314 if Is_Synchronized_State
(State_Id
)
25315 and then not Is_Synchronized_Object
(Constit_Id
)
25316 and then not Is_Synchronized_State
(Constit_Id
)
25319 ("constituent of synchronized state & must be "
25320 & "synchronized", Constit
, State_Id
);
25323 -- Add the constituent to the list of processed items to aid
25324 -- with the detection of duplicates.
25326 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
25328 -- Collect the constituent in the list of refinement items
25329 -- and establish a relation between the refined state and
25332 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
25333 Set_Encapsulating_State
(Constit_Id
, State_Id
);
25335 -- The state has at least one legal constituent, mark the
25336 -- start of the refinement region. The region ends when the
25337 -- body declarations end (see routine Analyze_Declarations).
25339 Set_Has_Visible_Refinement
(State_Id
);
25341 -- When the constituent is external, save its relevant
25342 -- property for further checks.
25344 if Async_Readers_Enabled
(Constit_Id
) then
25345 AR_Constit
:= Constit_Id
;
25346 External_Constit_Seen
:= True;
25349 if Async_Writers_Enabled
(Constit_Id
) then
25350 AW_Constit
:= Constit_Id
;
25351 External_Constit_Seen
:= True;
25354 if Effective_Reads_Enabled
(Constit_Id
) then
25355 ER_Constit
:= Constit_Id
;
25356 External_Constit_Seen
:= True;
25359 if Effective_Writes_Enabled
(Constit_Id
) then
25360 EW_Constit
:= Constit_Id
;
25361 External_Constit_Seen
:= True;
25363 end Collect_Constituent
;
25367 State_Elmt
: Elmt_Id
;
25369 -- Start of processing for Match_Constituent
25372 -- Detect a duplicate use of a constituent
25374 if Contains
(Constituents_Seen
, Constit_Id
) then
25376 ("duplicate use of constituent &", Constit
, Constit_Id
);
25380 -- The constituent is subject to a Part_Of indicator
25382 if Present
(Encapsulating_State
(Constit_Id
)) then
25383 if Encapsulating_State
(Constit_Id
) = State_Id
then
25384 Remove
(Part_Of_Constits
, Constit_Id
);
25385 Collect_Constituent
;
25387 -- The constituent is part of another state and is used
25388 -- incorrectly in the refinement of the current state.
25391 Error_Msg_Name_1
:= Chars
(State_Id
);
25393 ("& cannot act as constituent of state %",
25394 Constit
, Constit_Id
);
25396 ("\Part_Of indicator specifies encapsulator &",
25397 Constit
, Encapsulating_State
(Constit_Id
));
25400 -- The only other source of legal constituents is the body
25401 -- state space of the related package.
25404 if Present
(Body_States
) then
25405 State_Elmt
:= First_Elmt
(Body_States
);
25406 while Present
(State_Elmt
) loop
25408 -- Consume a valid constituent to signal that it has
25409 -- been encountered.
25411 if Node
(State_Elmt
) = Constit_Id
then
25412 Remove_Elmt
(Body_States
, State_Elmt
);
25413 Collect_Constituent
;
25417 Next_Elmt
(State_Elmt
);
25421 -- Constants are part of the hidden state of a package, but
25422 -- the compiler cannot determine whether they have variable
25423 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
25424 -- hidden state. Accept the constant quietly even if it is
25425 -- a visible state or lacks a Part_Of indicator.
25427 if Ekind
(Constit_Id
) = E_Constant
then
25430 -- If we get here, then the constituent is not a hidden
25431 -- state of the related package and may not be used in a
25432 -- refinement (SPARK RM 7.2.2(9)).
25435 Error_Msg_Name_1
:= Chars
(Spec_Id
);
25437 ("cannot use & in refinement, constituent is not a "
25438 & "hidden state of package %", Constit
, Constit_Id
);
25441 end Match_Constituent
;
25445 Constit_Id
: Entity_Id
;
25447 -- Start of processing for Analyze_Constituent
25450 -- Detect multiple uses of null in a single refinement clause or a
25451 -- mixture of null and non-null constituents.
25453 if Nkind
(Constit
) = N_Null
then
25456 ("multiple null constituents not allowed", Constit
);
25458 elsif Non_Null_Seen
then
25460 ("cannot mix null and non-null constituents", Constit
);
25465 -- Collect the constituent in the list of refinement items
25467 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
25469 -- The state has at least one legal constituent, mark the
25470 -- start of the refinement region. The region ends when the
25471 -- body declarations end (see Analyze_Declarations).
25473 Set_Has_Visible_Refinement
(State_Id
);
25476 -- Non-null constituents
25479 Non_Null_Seen
:= True;
25483 ("cannot mix null and non-null constituents", Constit
);
25487 Resolve_State
(Constit
);
25489 -- Ensure that the constituent denotes a valid state or a
25490 -- whole object (SPARK RM 7.2.2(5)).
25492 if Is_Entity_Name
(Constit
) then
25493 Constit_Id
:= Entity_Of
(Constit
);
25495 -- When a constituent is declared after a subprogram body
25496 -- that caused "freezing" of the related contract where
25497 -- pragma Refined_State resides, the constituent appears
25498 -- undefined and carries Any_Id as its entity.
25500 -- package body Pack
25501 -- with Refined_State => (State => Constit)
25504 -- with Refined_Global => (Input => Constit)
25512 if Constit_Id
= Any_Id
then
25513 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
25515 -- Emit a specialized info message when the contract of
25516 -- the related package body was "frozen" by another body.
25517 -- Note that it is not possible to precisely identify why
25518 -- the constituent is undefined because it is not visible
25519 -- when pragma Refined_State is analyzed. This message is
25520 -- a reasonable approximation.
25522 if Present
(Freeze_Id
) and then not Freeze_Posted
then
25523 Freeze_Posted
:= True;
25525 Error_Msg_Name_1
:= Chars
(Body_Id
);
25526 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
25528 ("body & declared # freezes the contract of %",
25531 ("\all constituents must be declared before body #",
25534 -- A misplaced constituent is a critical error because
25535 -- pragma Refined_Depends or Refined_Global depends on
25536 -- the proper link between a state and a constituent.
25537 -- Stop the compilation, as this leads to a multitude
25538 -- of misleading cascaded errors.
25540 raise Program_Error
;
25543 -- The constituent is a valid state or object
25545 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
25549 Match_Constituent
(Constit_Id
);
25551 -- The variable may eventually become a constituent of a
25552 -- single protected/task type. Record the reference now
25553 -- and verify its legality when analyzing the contract of
25554 -- the variable (SPARK RM 9.3).
25556 if Ekind
(Constit_Id
) = E_Variable
then
25557 Record_Possible_Part_Of_Reference
25558 (Var_Id
=> Constit_Id
,
25562 -- Otherwise the constituent is illegal
25566 ("constituent & must denote object or state",
25567 Constit
, Constit_Id
);
25570 -- The constituent is illegal
25573 SPARK_Msg_N
("malformed constituent", Constit
);
25576 end Analyze_Constituent
;
25578 -----------------------------
25579 -- Check_External_Property --
25580 -----------------------------
25582 procedure Check_External_Property
25583 (Prop_Nam
: Name_Id
;
25585 Constit
: Entity_Id
)
25588 Error_Msg_Name_1
:= Prop_Nam
;
25590 -- The property is enabled in the related Abstract_State pragma
25591 -- that defines the state (SPARK RM 7.2.8(3)).
25594 if No
(Constit
) then
25596 ("external state & requires at least one constituent with "
25597 & "property %", State
, State_Id
);
25600 -- The property is missing in the declaration of the state, but
25601 -- a constituent is introducing it in the state refinement
25602 -- (SPARK RM 7.2.8(3)).
25604 elsif Present
(Constit
) then
25605 Error_Msg_Name_2
:= Chars
(Constit
);
25607 ("external state & lacks property % set by constituent %",
25610 end Check_External_Property
;
25616 procedure Match_State
is
25617 State_Elmt
: Elmt_Id
;
25620 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
25622 if Contains
(Refined_States_Seen
, State_Id
) then
25624 ("duplicate refinement of state &", State
, State_Id
);
25628 -- Inspect the abstract states defined in the package declaration
25629 -- looking for a match.
25631 State_Elmt
:= First_Elmt
(Available_States
);
25632 while Present
(State_Elmt
) loop
25634 -- A valid abstract state is being refined in the body. Add
25635 -- the state to the list of processed refined states to aid
25636 -- with the detection of duplicate refinements. Remove the
25637 -- state from Available_States to signal that it has already
25640 if Node
(State_Elmt
) = State_Id
then
25641 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
25642 Remove_Elmt
(Available_States
, State_Elmt
);
25646 Next_Elmt
(State_Elmt
);
25649 -- If we get here, we are refining a state that is not defined in
25650 -- the package declaration.
25652 Error_Msg_Name_1
:= Chars
(Spec_Id
);
25654 ("cannot refine state, & is not defined in package %",
25658 --------------------------------
25659 -- Report_Unused_Constituents --
25660 --------------------------------
25662 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
25663 Constit_Elmt
: Elmt_Id
;
25664 Constit_Id
: Entity_Id
;
25665 Posted
: Boolean := False;
25668 if Present
(Constits
) then
25669 Constit_Elmt
:= First_Elmt
(Constits
);
25670 while Present
(Constit_Elmt
) loop
25671 Constit_Id
:= Node
(Constit_Elmt
);
25673 -- Generate an error message of the form:
25675 -- state ... has unused Part_Of constituents
25676 -- abstract state ... defined at ...
25677 -- constant ... defined at ...
25678 -- variable ... defined at ...
25683 ("state & has unused Part_Of constituents",
25687 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
25689 if Ekind
(Constit_Id
) = E_Abstract_State
then
25691 ("\abstract state & defined #", State
, Constit_Id
);
25693 elsif Ekind
(Constit_Id
) = E_Constant
then
25695 ("\constant & defined #", State
, Constit_Id
);
25698 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
25699 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
25702 Next_Elmt
(Constit_Elmt
);
25705 end Report_Unused_Constituents
;
25707 -- Local declarations
25709 Body_Ref
: Node_Id
;
25710 Body_Ref_Elmt
: Elmt_Id
;
25712 Extra_State
: Node_Id
;
25714 -- Start of processing for Analyze_Refinement_Clause
25717 -- A refinement clause appears as a component association where the
25718 -- sole choice is the state and the expressions are the constituents.
25719 -- This is a syntax error, always report.
25721 if Nkind
(Clause
) /= N_Component_Association
then
25722 Error_Msg_N
("malformed state refinement clause", Clause
);
25726 -- Analyze the state name of a refinement clause
25728 State
:= First
(Choices
(Clause
));
25731 Resolve_State
(State
);
25733 -- Ensure that the state name denotes a valid abstract state that is
25734 -- defined in the spec of the related package.
25736 if Is_Entity_Name
(State
) then
25737 State_Id
:= Entity_Of
(State
);
25739 -- When the abstract state is undefined, it appears as Any_Id. Do
25740 -- not continue with the analysis of the clause.
25742 if State_Id
= Any_Id
then
25745 -- Catch any attempts to re-refine a state or refine a state that
25746 -- is not defined in the package declaration.
25748 elsif Ekind
(State_Id
) = E_Abstract_State
then
25752 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
25756 -- References to a state with visible refinement are illegal.
25757 -- When nested packages are involved, detecting such references is
25758 -- tricky because pragma Refined_State is analyzed later than the
25759 -- offending pragma Depends or Global. References that occur in
25760 -- such nested context are stored in a list. Emit errors for all
25761 -- references found in Body_References (SPARK RM 6.1.4(8)).
25763 if Present
(Body_References
(State_Id
)) then
25764 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
25765 while Present
(Body_Ref_Elmt
) loop
25766 Body_Ref
:= Node
(Body_Ref_Elmt
);
25768 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
25769 Error_Msg_Sloc
:= Sloc
(State
);
25770 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
25772 Next_Elmt
(Body_Ref_Elmt
);
25776 -- The state name is illegal. This is a syntax error, always report.
25779 Error_Msg_N
("malformed state name in refinement clause", State
);
25783 -- A refinement clause may only refine one state at a time
25785 Extra_State
:= Next
(State
);
25787 if Present
(Extra_State
) then
25789 ("refinement clause cannot cover multiple states", Extra_State
);
25792 -- Replicate the Part_Of constituents of the refined state because
25793 -- the algorithm will consume items.
25795 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
25797 -- Analyze all constituents of the refinement. Multiple constituents
25798 -- appear as an aggregate.
25800 Constit
:= Expression
(Clause
);
25802 if Nkind
(Constit
) = N_Aggregate
then
25803 if Present
(Component_Associations
(Constit
)) then
25805 ("constituents of refinement clause must appear in "
25806 & "positional form", Constit
);
25808 else pragma Assert
(Present
(Expressions
(Constit
)));
25809 Constit
:= First
(Expressions
(Constit
));
25810 while Present
(Constit
) loop
25811 Analyze_Constituent
(Constit
);
25816 -- Various forms of a single constituent. Note that these may include
25817 -- malformed constituents.
25820 Analyze_Constituent
(Constit
);
25823 -- A refined external state is subject to special rules with respect
25824 -- to its properties and constituents.
25826 if Is_External_State
(State_Id
) then
25828 -- The set of properties that all external constituents yield must
25829 -- match that of the refined state. There are two cases to detect:
25830 -- the refined state lacks a property or has an extra property.
25832 if External_Constit_Seen
then
25833 Check_External_Property
25834 (Prop_Nam
=> Name_Async_Readers
,
25835 Enabled
=> Async_Readers_Enabled
(State_Id
),
25836 Constit
=> AR_Constit
);
25838 Check_External_Property
25839 (Prop_Nam
=> Name_Async_Writers
,
25840 Enabled
=> Async_Writers_Enabled
(State_Id
),
25841 Constit
=> AW_Constit
);
25843 Check_External_Property
25844 (Prop_Nam
=> Name_Effective_Reads
,
25845 Enabled
=> Effective_Reads_Enabled
(State_Id
),
25846 Constit
=> ER_Constit
);
25848 Check_External_Property
25849 (Prop_Nam
=> Name_Effective_Writes
,
25850 Enabled
=> Effective_Writes_Enabled
(State_Id
),
25851 Constit
=> EW_Constit
);
25853 -- An external state may be refined to null (SPARK RM 7.2.8(2))
25855 elsif Null_Seen
then
25858 -- The external state has constituents, but none of them are
25859 -- external (SPARK RM 7.2.8(2)).
25863 ("external state & requires at least one external "
25864 & "constituent or null refinement", State
, State_Id
);
25867 -- When a refined state is not external, it should not have external
25868 -- constituents (SPARK RM 7.2.8(1)).
25870 elsif External_Constit_Seen
then
25872 ("non-external state & cannot contain external constituents in "
25873 & "refinement", State
, State_Id
);
25876 -- Ensure that all Part_Of candidate constituents have been mentioned
25877 -- in the refinement clause.
25879 Report_Unused_Constituents
(Part_Of_Constits
);
25880 end Analyze_Refinement_Clause
;
25882 -----------------------------
25883 -- Report_Unrefined_States --
25884 -----------------------------
25886 procedure Report_Unrefined_States
(States
: Elist_Id
) is
25887 State_Elmt
: Elmt_Id
;
25890 if Present
(States
) then
25891 State_Elmt
:= First_Elmt
(States
);
25892 while Present
(State_Elmt
) loop
25894 ("abstract state & must be refined", Node
(State_Elmt
));
25896 Next_Elmt
(State_Elmt
);
25899 end Report_Unrefined_States
;
25901 -- Local declarations
25903 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
25906 -- Start of processing for Analyze_Refined_State_In_Decl_Part
25909 -- Do not analyze the pragma multiple times
25911 if Is_Analyzed_Pragma
(N
) then
25915 -- Replicate the abstract states declared by the package because the
25916 -- matching algorithm will consume states.
25918 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
25920 -- Gather all abstract states and objects declared in the visible
25921 -- state space of the package body. These items must be utilized as
25922 -- constituents in a state refinement.
25924 Body_States
:= Collect_Body_States
(Body_Id
);
25926 -- Multiple non-null state refinements appear as an aggregate
25928 if Nkind
(Clauses
) = N_Aggregate
then
25929 if Present
(Expressions
(Clauses
)) then
25931 ("state refinements must appear as component associations",
25934 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
25935 Clause
:= First
(Component_Associations
(Clauses
));
25936 while Present
(Clause
) loop
25937 Analyze_Refinement_Clause
(Clause
);
25942 -- Various forms of a single state refinement. Note that these may
25943 -- include malformed refinements.
25946 Analyze_Refinement_Clause
(Clauses
);
25949 -- List all abstract states that were left unrefined
25951 Report_Unrefined_States
(Available_States
);
25953 Set_Is_Analyzed_Pragma
(N
);
25954 end Analyze_Refined_State_In_Decl_Part
;
25956 ------------------------------------
25957 -- Analyze_Test_Case_In_Decl_Part --
25958 ------------------------------------
25960 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
25961 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
25962 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
25964 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
25965 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
25966 -- denoted by Arg_Nam.
25968 ------------------------------
25969 -- Preanalyze_Test_Case_Arg --
25970 ------------------------------
25972 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
25976 -- Preanalyze the original aspect argument for ASIS or for a generic
25977 -- subprogram to properly capture global references.
25979 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
25983 Arg_Nam
=> Arg_Nam
,
25984 From_Aspect
=> True);
25986 if Present
(Arg
) then
25987 Preanalyze_Assert_Expression
25988 (Expression
(Arg
), Standard_Boolean
);
25992 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
25994 if Present
(Arg
) then
25995 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
25997 end Preanalyze_Test_Case_Arg
;
26001 Restore_Scope
: Boolean := False;
26003 -- Start of processing for Analyze_Test_Case_In_Decl_Part
26006 -- Do not analyze the pragma multiple times
26008 if Is_Analyzed_Pragma
(N
) then
26012 -- Ensure that the formal parameters are visible when analyzing all
26013 -- clauses. This falls out of the general rule of aspects pertaining
26014 -- to subprogram declarations.
26016 if not In_Open_Scopes
(Spec_Id
) then
26017 Restore_Scope
:= True;
26018 Push_Scope
(Spec_Id
);
26020 if Is_Generic_Subprogram
(Spec_Id
) then
26021 Install_Generic_Formals
(Spec_Id
);
26023 Install_Formals
(Spec_Id
);
26027 Preanalyze_Test_Case_Arg
(Name_Requires
);
26028 Preanalyze_Test_Case_Arg
(Name_Ensures
);
26030 if Restore_Scope
then
26034 -- Currently it is not possible to inline pre/postconditions on a
26035 -- subprogram subject to pragma Inline_Always.
26037 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
26039 Set_Is_Analyzed_Pragma
(N
);
26040 end Analyze_Test_Case_In_Decl_Part
;
26046 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
26051 if Present
(List
) then
26052 Elmt
:= First_Elmt
(List
);
26053 while Present
(Elmt
) loop
26054 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
26057 Id
:= Entity_Of
(Node
(Elmt
));
26060 if Id
= Item_Id
then
26071 -----------------------------
26072 -- Check_Applicable_Policy --
26073 -----------------------------
26075 procedure Check_Applicable_Policy
(N
: Node_Id
) is
26079 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
26082 -- No effect if not valid assertion kind name
26084 if not Is_Valid_Assertion_Kind
(Ename
) then
26088 -- Loop through entries in check policy list
26090 PP
:= Opt
.Check_Policy_List
;
26091 while Present
(PP
) loop
26093 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
26094 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
26098 or else Pnm
= Name_Assertion
26099 or else (Pnm
= Name_Statement_Assertions
26100 and then Nam_In
(Ename
, Name_Assert
,
26101 Name_Assert_And_Cut
,
26103 Name_Loop_Invariant
,
26104 Name_Loop_Variant
))
26106 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
26109 when Name_Off | Name_Ignore
=>
26110 Set_Is_Ignored
(N
, True);
26111 Set_Is_Checked
(N
, False);
26113 when Name_On | Name_Check
=>
26114 Set_Is_Checked
(N
, True);
26115 Set_Is_Ignored
(N
, False);
26117 when Name_Disable
=>
26118 Set_Is_Ignored
(N
, True);
26119 Set_Is_Checked
(N
, False);
26120 Set_Is_Disabled
(N
, True);
26122 -- That should be exhaustive, the null here is a defence
26123 -- against a malformed tree from previous errors.
26132 PP
:= Next_Pragma
(PP
);
26136 -- If there are no specific entries that matched, then we let the
26137 -- setting of assertions govern. Note that this provides the needed
26138 -- compatibility with the RM for the cases of assertion, invariant,
26139 -- precondition, predicate, and postcondition.
26141 if Assertions_Enabled
then
26142 Set_Is_Checked
(N
, True);
26143 Set_Is_Ignored
(N
, False);
26145 Set_Is_Checked
(N
, False);
26146 Set_Is_Ignored
(N
, True);
26148 end Check_Applicable_Policy
;
26150 -------------------------------
26151 -- Check_External_Properties --
26152 -------------------------------
26154 procedure Check_External_Properties
26162 -- All properties enabled
26164 if AR
and AW
and ER
and EW
then
26167 -- Async_Readers + Effective_Writes
26168 -- Async_Readers + Async_Writers + Effective_Writes
26170 elsif AR
and EW
and not ER
then
26173 -- Async_Writers + Effective_Reads
26174 -- Async_Readers + Async_Writers + Effective_Reads
26176 elsif AW
and ER
and not EW
then
26179 -- Async_Readers + Async_Writers
26181 elsif AR
and AW
and not ER
and not EW
then
26186 elsif AR
and not AW
and not ER
and not EW
then
26191 elsif AW
and not AR
and not ER
and not EW
then
26196 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
26199 end Check_External_Properties
;
26205 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
26209 -- Loop through entries in check policy list
26211 PP
:= Opt
.Check_Policy_List
;
26212 while Present
(PP
) loop
26214 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
26215 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
26219 or else (Pnm
= Name_Assertion
26220 and then Is_Valid_Assertion_Kind
(Nam
))
26221 or else (Pnm
= Name_Statement_Assertions
26222 and then Nam_In
(Nam
, Name_Assert
,
26223 Name_Assert_And_Cut
,
26225 Name_Loop_Invariant
,
26226 Name_Loop_Variant
))
26228 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
26229 when Name_On | Name_Check
=>
26231 when Name_Off | Name_Ignore
=>
26232 return Name_Ignore
;
26233 when Name_Disable
=>
26234 return Name_Disable
;
26236 raise Program_Error
;
26240 PP
:= Next_Pragma
(PP
);
26245 -- If there are no specific entries that matched, then we let the
26246 -- setting of assertions govern. Note that this provides the needed
26247 -- compatibility with the RM for the cases of assertion, invariant,
26248 -- precondition, predicate, and postcondition.
26250 if Assertions_Enabled
then
26253 return Name_Ignore
;
26257 ---------------------------
26258 -- Check_Missing_Part_Of --
26259 ---------------------------
26261 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
26262 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
26263 -- Determine whether a package denoted by Pack_Id declares at least one
26266 -----------------------
26267 -- Has_Visible_State --
26268 -----------------------
26270 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
26271 Item_Id
: Entity_Id
;
26274 -- Traverse the entity chain of the package trying to find at least
26275 -- one visible abstract state, variable or a package [instantiation]
26276 -- that declares a visible state.
26278 Item_Id
:= First_Entity
(Pack_Id
);
26279 while Present
(Item_Id
)
26280 and then not In_Private_Part
(Item_Id
)
26282 -- Do not consider internally generated items
26284 if not Comes_From_Source
(Item_Id
) then
26287 -- A visible state has been found
26289 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
26292 -- Recursively peek into nested packages and instantiations
26294 elsif Ekind
(Item_Id
) = E_Package
26295 and then Has_Visible_State
(Item_Id
)
26300 Next_Entity
(Item_Id
);
26304 end Has_Visible_State
;
26308 Pack_Id
: Entity_Id
;
26309 Placement
: State_Space_Kind
;
26311 -- Start of processing for Check_Missing_Part_Of
26314 -- Do not consider abstract states, variables or package instantiations
26315 -- coming from an instance as those always inherit the Part_Of indicator
26316 -- of the instance itself.
26318 if In_Instance
then
26321 -- Do not consider internally generated entities as these can never
26322 -- have a Part_Of indicator.
26324 elsif not Comes_From_Source
(Item_Id
) then
26327 -- Perform these checks only when SPARK_Mode is enabled as they will
26328 -- interfere with standard Ada rules and produce false positives.
26330 elsif SPARK_Mode
/= On
then
26333 -- Do not consider constants, because the compiler cannot accurately
26334 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
26335 -- act as a hidden state of a package.
26337 elsif Ekind
(Item_Id
) = E_Constant
then
26341 -- Find where the abstract state, variable or package instantiation
26342 -- lives with respect to the state space.
26344 Find_Placement_In_State_Space
26345 (Item_Id
=> Item_Id
,
26346 Placement
=> Placement
,
26347 Pack_Id
=> Pack_Id
);
26349 -- Items that appear in a non-package construct (subprogram, block, etc)
26350 -- do not require a Part_Of indicator because they can never act as a
26353 if Placement
= Not_In_Package
then
26356 -- An item declared in the body state space of a package always act as a
26357 -- constituent and does not need explicit Part_Of indicator.
26359 elsif Placement
= Body_State_Space
then
26362 -- In general an item declared in the visible state space of a package
26363 -- does not require a Part_Of indicator. The only exception is when the
26364 -- related package is a private child unit in which case Part_Of must
26365 -- denote a state in the parent unit or in one of its descendants.
26367 elsif Placement
= Visible_State_Space
then
26368 if Is_Child_Unit
(Pack_Id
)
26369 and then Is_Private_Descendant
(Pack_Id
)
26371 -- A package instantiation does not need a Part_Of indicator when
26372 -- the related generic template has no visible state.
26374 if Ekind
(Item_Id
) = E_Package
26375 and then Is_Generic_Instance
(Item_Id
)
26376 and then not Has_Visible_State
(Item_Id
)
26380 -- All other cases require Part_Of
26384 ("indicator Part_Of is required in this context "
26385 & "(SPARK RM 7.2.6(3))", Item_Id
);
26386 Error_Msg_Name_1
:= Chars
(Pack_Id
);
26388 ("\& is declared in the visible part of private child "
26389 & "unit %", Item_Id
);
26393 -- When the item appears in the private state space of a packge, it must
26394 -- be a part of some state declared by the said package.
26396 else pragma Assert
(Placement
= Private_State_Space
);
26398 -- The related package does not declare a state, the item cannot act
26399 -- as a Part_Of constituent.
26401 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
26404 -- A package instantiation does not need a Part_Of indicator when the
26405 -- related generic template has no visible state.
26407 elsif Ekind
(Pack_Id
) = E_Package
26408 and then Is_Generic_Instance
(Pack_Id
)
26409 and then not Has_Visible_State
(Pack_Id
)
26413 -- All other cases require Part_Of
26417 ("indicator Part_Of is required in this context "
26418 & "(SPARK RM 7.2.6(2))", Item_Id
);
26419 Error_Msg_Name_1
:= Chars
(Pack_Id
);
26421 ("\& is declared in the private part of package %", Item_Id
);
26424 end Check_Missing_Part_Of
;
26426 ---------------------------------------------------
26427 -- Check_Postcondition_Use_In_Inlined_Subprogram --
26428 ---------------------------------------------------
26430 procedure Check_Postcondition_Use_In_Inlined_Subprogram
26432 Spec_Id
: Entity_Id
)
26435 if Warn_On_Redundant_Constructs
26436 and then Has_Pragma_Inline_Always
(Spec_Id
)
26438 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
26440 if From_Aspect_Specification
(Prag
) then
26442 ("aspect % not enforced on inlined subprogram &?r?",
26443 Corresponding_Aspect
(Prag
), Spec_Id
);
26446 ("pragma % not enforced on inlined subprogram &?r?",
26450 end Check_Postcondition_Use_In_Inlined_Subprogram
;
26452 -------------------------------------
26453 -- Check_State_And_Constituent_Use --
26454 -------------------------------------
26456 procedure Check_State_And_Constituent_Use
26457 (States
: Elist_Id
;
26458 Constits
: Elist_Id
;
26461 function Find_Encapsulating_State
26462 (Constit_Id
: Entity_Id
) return Entity_Id
;
26463 -- Given the entity of a constituent, try to find a corresponding
26464 -- encapsulating state that appears in the same context. The routine
26465 -- returns Empty is no such state is found.
26467 ------------------------------
26468 -- Find_Encapsulating_State --
26469 ------------------------------
26471 function Find_Encapsulating_State
26472 (Constit_Id
: Entity_Id
) return Entity_Id
26474 State_Id
: Entity_Id
;
26477 -- Since a constituent may be part of a larger constituent set, climb
26478 -- the encapsulating state chain looking for a state that appears in
26479 -- the same context.
26481 State_Id
:= Encapsulating_State
(Constit_Id
);
26482 while Present
(State_Id
) loop
26483 if Contains
(States
, State_Id
) then
26487 State_Id
:= Encapsulating_State
(State_Id
);
26491 end Find_Encapsulating_State
;
26495 Constit_Elmt
: Elmt_Id
;
26496 Constit_Id
: Entity_Id
;
26497 State_Id
: Entity_Id
;
26499 -- Start of processing for Check_State_And_Constituent_Use
26502 -- Nothing to do if there are no states or constituents
26504 if No
(States
) or else No
(Constits
) then
26508 -- Inspect the list of constituents and try to determine whether its
26509 -- encapsulating state is in list States.
26511 Constit_Elmt
:= First_Elmt
(Constits
);
26512 while Present
(Constit_Elmt
) loop
26513 Constit_Id
:= Node
(Constit_Elmt
);
26515 -- Determine whether the constituent is part of an encapsulating
26516 -- state that appears in the same context and if this is the case,
26517 -- emit an error (SPARK RM 7.2.6(7)).
26519 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
26521 if Present
(State_Id
) then
26522 Error_Msg_Name_1
:= Chars
(Constit_Id
);
26524 ("cannot mention state & and its constituent % in the same "
26525 & "context", Context
, State_Id
);
26529 Next_Elmt
(Constit_Elmt
);
26531 end Check_State_And_Constituent_Use
;
26533 ---------------------------------------
26534 -- Collect_Subprogram_Inputs_Outputs --
26535 ---------------------------------------
26537 procedure Collect_Subprogram_Inputs_Outputs
26538 (Subp_Id
: Entity_Id
;
26539 Synthesize
: Boolean := False;
26540 Subp_Inputs
: in out Elist_Id
;
26541 Subp_Outputs
: in out Elist_Id
;
26542 Global_Seen
: out Boolean)
26544 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
26545 -- Collect all relevant items from a dependency clause
26547 procedure Collect_Global_List
26549 Mode
: Name_Id
:= Name_Input
);
26550 -- Collect all relevant items from a global list
26552 -------------------------------
26553 -- Collect_Dependency_Clause --
26554 -------------------------------
26556 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
26557 procedure Collect_Dependency_Item
26559 Is_Input
: Boolean);
26560 -- Add an item to the proper subprogram input or output collection
26562 -----------------------------
26563 -- Collect_Dependency_Item --
26564 -----------------------------
26566 procedure Collect_Dependency_Item
26568 Is_Input
: Boolean)
26573 -- Nothing to collect when the item is null
26575 if Nkind
(Item
) = N_Null
then
26578 -- Ditto for attribute 'Result
26580 elsif Is_Attribute_Result
(Item
) then
26583 -- Multiple items appear as an aggregate
26585 elsif Nkind
(Item
) = N_Aggregate
then
26586 Extra
:= First
(Expressions
(Item
));
26587 while Present
(Extra
) loop
26588 Collect_Dependency_Item
(Extra
, Is_Input
);
26592 -- Otherwise this is a solitary item
26596 Append_New_Elmt
(Item
, Subp_Inputs
);
26598 Append_New_Elmt
(Item
, Subp_Outputs
);
26601 end Collect_Dependency_Item
;
26603 -- Start of processing for Collect_Dependency_Clause
26606 if Nkind
(Clause
) = N_Null
then
26609 -- A dependency cause appears as component association
26611 elsif Nkind
(Clause
) = N_Component_Association
then
26612 Collect_Dependency_Item
26613 (Item
=> Expression
(Clause
),
26616 Collect_Dependency_Item
26617 (Item
=> First
(Choices
(Clause
)),
26618 Is_Input
=> False);
26620 -- To accomodate partial decoration of disabled SPARK features, this
26621 -- routine may be called with illegal input. If this is the case, do
26622 -- not raise Program_Error.
26627 end Collect_Dependency_Clause
;
26629 -------------------------
26630 -- Collect_Global_List --
26631 -------------------------
26633 procedure Collect_Global_List
26635 Mode
: Name_Id
:= Name_Input
)
26637 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
26638 -- Add an item to the proper subprogram input or output collection
26640 -------------------------
26641 -- Collect_Global_Item --
26642 -------------------------
26644 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
26646 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
26647 Append_New_Elmt
(Item
, Subp_Inputs
);
26650 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
26651 Append_New_Elmt
(Item
, Subp_Outputs
);
26653 end Collect_Global_Item
;
26660 -- Start of processing for Collect_Global_List
26663 if Nkind
(List
) = N_Null
then
26666 -- Single global item declaration
26668 elsif Nkind_In
(List
, N_Expanded_Name
,
26670 N_Selected_Component
)
26672 Collect_Global_Item
(List
, Mode
);
26674 -- Simple global list or moded global list declaration
26676 elsif Nkind
(List
) = N_Aggregate
then
26677 if Present
(Expressions
(List
)) then
26678 Item
:= First
(Expressions
(List
));
26679 while Present
(Item
) loop
26680 Collect_Global_Item
(Item
, Mode
);
26685 Assoc
:= First
(Component_Associations
(List
));
26686 while Present
(Assoc
) loop
26687 Collect_Global_List
26688 (List
=> Expression
(Assoc
),
26689 Mode
=> Chars
(First
(Choices
(Assoc
))));
26694 -- To accomodate partial decoration of disabled SPARK features, this
26695 -- routine may be called with illegal input. If this is the case, do
26696 -- not raise Program_Error.
26701 end Collect_Global_List
;
26708 Formal
: Entity_Id
;
26710 Spec_Id
: Entity_Id
;
26711 Subp_Decl
: Node_Id
;
26714 -- Start of processing for Collect_Subprogram_Inputs_Outputs
26717 Global_Seen
:= False;
26719 -- Process all formal parameters of entries, [generic] subprograms, and
26722 if Ekind_In
(Subp_Id
, E_Entry
,
26725 E_Generic_Function
,
26726 E_Generic_Procedure
,
26730 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
26731 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
26733 -- Process all [generic] formal parameters
26735 Formal
:= First_Entity
(Spec_Id
);
26736 while Present
(Formal
) loop
26737 if Ekind_In
(Formal
, E_Generic_In_Parameter
,
26738 E_In_Out_Parameter
,
26741 Append_New_Elmt
(Formal
, Subp_Inputs
);
26744 if Ekind_In
(Formal
, E_Generic_In_Out_Parameter
,
26745 E_In_Out_Parameter
,
26748 Append_New_Elmt
(Formal
, Subp_Outputs
);
26750 -- Out parameters can act as inputs when the related type is
26751 -- tagged, unconstrained array, unconstrained record, or record
26752 -- with unconstrained components.
26754 if Ekind
(Formal
) = E_Out_Parameter
26755 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
26757 Append_New_Elmt
(Formal
, Subp_Inputs
);
26761 Next_Entity
(Formal
);
26764 -- Otherwise the input denotes a task type, a task body, or the
26765 -- anonymous object created for a single task type.
26767 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
26768 or else Is_Single_Task_Object
(Subp_Id
)
26770 Subp_Decl
:= Declaration_Node
(Subp_Id
);
26771 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
26774 -- When processing an entry, subprogram or task body, look for pragmas
26775 -- Refined_Depends and Refined_Global as they specify the inputs and
26778 if Is_Entry_Body
(Subp_Id
)
26779 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
26781 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
26782 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
26784 -- Subprogram declaration or stand alone body case, look for pragmas
26785 -- Depends and Global
26788 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
26789 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
26792 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
26793 -- because it provides finer granularity of inputs and outputs.
26795 if Present
(Global
) then
26796 Global_Seen
:= True;
26797 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
26799 -- When the related subprogram lacks pragma [Refined_]Global, fall back
26800 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
26801 -- the inputs and outputs from [Refined_]Depends.
26803 elsif Synthesize
and then Present
(Depends
) then
26804 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
26806 -- Multiple dependency clauses appear as an aggregate
26808 if Nkind
(Clauses
) = N_Aggregate
then
26809 Clause
:= First
(Component_Associations
(Clauses
));
26810 while Present
(Clause
) loop
26811 Collect_Dependency_Clause
(Clause
);
26815 -- Otherwise this is a single dependency clause
26818 Collect_Dependency_Clause
(Clauses
);
26822 -- The current instance of a protected type acts as a formal parameter
26823 -- of mode IN for functions and IN OUT for entries and procedures
26824 -- (SPARK RM 6.1.4).
26826 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
26827 Typ
:= Scope
(Spec_Id
);
26829 -- Use the anonymous object when the type is single protected
26831 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
26832 Typ
:= Anonymous_Object
(Typ
);
26835 Append_New_Elmt
(Typ
, Subp_Inputs
);
26837 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
26838 Append_New_Elmt
(Typ
, Subp_Outputs
);
26841 -- The current instance of a task type acts as a formal parameter of
26842 -- mode IN OUT (SPARK RM 6.1.4).
26844 elsif Ekind
(Spec_Id
) = E_Task_Type
then
26847 -- Use the anonymous object when the type is single task
26849 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
26850 Typ
:= Anonymous_Object
(Typ
);
26853 Append_New_Elmt
(Typ
, Subp_Inputs
);
26854 Append_New_Elmt
(Typ
, Subp_Outputs
);
26856 elsif Is_Single_Task_Object
(Spec_Id
) then
26857 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
26858 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
26860 end Collect_Subprogram_Inputs_Outputs
;
26862 ---------------------------
26863 -- Contract_Freeze_Error --
26864 ---------------------------
26866 procedure Contract_Freeze_Error
26867 (Contract_Id
: Entity_Id
;
26868 Freeze_Id
: Entity_Id
)
26871 Error_Msg_Name_1
:= Chars
(Contract_Id
);
26872 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
26875 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
26877 ("\all contractual items must be declared before body #", Contract_Id
);
26878 end Contract_Freeze_Error
;
26880 ---------------------------------
26881 -- Delay_Config_Pragma_Analyze --
26882 ---------------------------------
26884 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
26886 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
26887 Name_Priority_Specific_Dispatching
);
26888 end Delay_Config_Pragma_Analyze
;
26890 -----------------------
26891 -- Duplication_Error --
26892 -----------------------
26894 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
26895 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
26896 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
26899 Error_Msg_Sloc
:= Sloc
(Prev
);
26900 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
26902 -- Emit a precise message to distinguish between source pragmas and
26903 -- pragmas generated from aspects. The ordering of the two pragmas is
26907 -- Prag -- duplicate
26909 -- No error is emitted when both pragmas come from aspects because this
26910 -- is already detected by the general aspect analysis mechanism.
26912 if Prag_From_Asp
and Prev_From_Asp
then
26914 elsif Prag_From_Asp
then
26915 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
26916 elsif Prev_From_Asp
then
26917 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
26919 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
26921 end Duplication_Error
;
26923 --------------------------
26924 -- Find_Related_Context --
26925 --------------------------
26927 function Find_Related_Context
26929 Do_Checks
: Boolean := False) return Node_Id
26934 Stmt
:= Prev
(Prag
);
26935 while Present
(Stmt
) loop
26937 -- Skip prior pragmas, but check for duplicates
26939 if Nkind
(Stmt
) = N_Pragma
then
26940 if Do_Checks
and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
) then
26946 -- Skip internally generated code
26948 elsif not Comes_From_Source
(Stmt
) then
26950 -- The anonymous object created for a single concurrent type is a
26951 -- suitable context.
26953 if Nkind
(Stmt
) = N_Object_Declaration
26954 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
26959 -- Return the current source construct
26969 end Find_Related_Context
;
26971 --------------------------------------
26972 -- Find_Related_Declaration_Or_Body --
26973 --------------------------------------
26975 function Find_Related_Declaration_Or_Body
26977 Do_Checks
: Boolean := False) return Node_Id
26979 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
26981 procedure Expression_Function_Error
;
26982 -- Emit an error concerning pragma Prag that illegaly applies to an
26983 -- expression function.
26985 -------------------------------
26986 -- Expression_Function_Error --
26987 -------------------------------
26989 procedure Expression_Function_Error
is
26991 Error_Msg_Name_1
:= Prag_Nam
;
26993 -- Emit a precise message to distinguish between source pragmas and
26994 -- pragmas generated from aspects.
26996 if From_Aspect_Specification
(Prag
) then
26998 ("aspect % cannot apply to a stand alone expression function",
27002 ("pragma % cannot apply to a stand alone expression function",
27005 end Expression_Function_Error
;
27009 Context
: constant Node_Id
:= Parent
(Prag
);
27012 Look_For_Body
: constant Boolean :=
27013 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
27014 Name_Refined_Global
,
27015 Name_Refined_Post
);
27016 -- Refinement pragmas must be associated with a subprogram body [stub]
27018 -- Start of processing for Find_Related_Declaration_Or_Body
27021 Stmt
:= Prev
(Prag
);
27022 while Present
(Stmt
) loop
27024 -- Skip prior pragmas, but check for duplicates. Pragmas produced
27025 -- by splitting a complex pre/postcondition are not considered to
27028 if Nkind
(Stmt
) = N_Pragma
then
27030 and then not Split_PPC
(Stmt
)
27031 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
27038 -- Emit an error when a refinement pragma appears on an expression
27039 -- function without a completion.
27042 and then Look_For_Body
27043 and then Nkind
(Stmt
) = N_Subprogram_Declaration
27044 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
27045 and then not Has_Completion
(Defining_Entity
(Stmt
))
27047 Expression_Function_Error
;
27050 -- The refinement pragma applies to a subprogram body stub
27052 elsif Look_For_Body
27053 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
27057 -- Skip internally generated code
27059 elsif not Comes_From_Source
(Stmt
) then
27061 -- The anonymous object created for a single concurrent type is a
27062 -- suitable context.
27064 if Nkind
(Stmt
) = N_Object_Declaration
27065 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
27069 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
27071 -- The subprogram declaration is an internally generated spec
27072 -- for an expression function.
27074 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
27077 -- The subprogram is actually an instance housed within an
27078 -- anonymous wrapper package.
27080 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
27085 -- Return the current construct which is either a subprogram body,
27086 -- a subprogram declaration or is illegal.
27095 -- If we fall through, then the pragma was either the first declaration
27096 -- or it was preceded by other pragmas and no source constructs.
27098 -- The pragma is associated with a library-level subprogram
27100 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
27101 return Unit
(Parent
(Context
));
27103 -- The pragma appears inside the declarations of an entry body
27105 elsif Nkind
(Context
) = N_Entry_Body
then
27108 -- The pragma appears inside the statements of a subprogram body. This
27109 -- placement is the result of subprogram contract expansion.
27111 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
27112 return Parent
(Context
);
27114 -- The pragma appears inside the declarative part of a subprogram body
27116 elsif Nkind
(Context
) = N_Subprogram_Body
then
27119 -- The pragma appears inside the declarative part of a task body
27121 elsif Nkind
(Context
) = N_Task_Body
then
27124 -- The pragma is a byproduct of aspect expansion, return the related
27125 -- context of the original aspect. This case has a lower priority as
27126 -- the above circuitry pinpoints precisely the related context.
27128 elsif Present
(Corresponding_Aspect
(Prag
)) then
27129 return Parent
(Corresponding_Aspect
(Prag
));
27131 -- No candidate subprogram [body] found
27136 end Find_Related_Declaration_Or_Body
;
27138 ----------------------------------
27139 -- Find_Related_Package_Or_Body --
27140 ----------------------------------
27142 function Find_Related_Package_Or_Body
27144 Do_Checks
: Boolean := False) return Node_Id
27146 Context
: constant Node_Id
:= Parent
(Prag
);
27147 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
27151 Stmt
:= Prev
(Prag
);
27152 while Present
(Stmt
) loop
27154 -- Skip prior pragmas, but check for duplicates
27156 if Nkind
(Stmt
) = N_Pragma
then
27157 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
27163 -- Skip internally generated code
27165 elsif not Comes_From_Source
(Stmt
) then
27166 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
27168 -- The subprogram declaration is an internally generated spec
27169 -- for an expression function.
27171 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
27174 -- The subprogram is actually an instance housed within an
27175 -- anonymous wrapper package.
27177 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
27182 -- Return the current source construct which is illegal
27191 -- If we fall through, then the pragma was either the first declaration
27192 -- or it was preceded by other pragmas and no source constructs.
27194 -- The pragma is associated with a package. The immediate context in
27195 -- this case is the specification of the package.
27197 if Nkind
(Context
) = N_Package_Specification
then
27198 return Parent
(Context
);
27200 -- The pragma appears in the declarations of a package body
27202 elsif Nkind
(Context
) = N_Package_Body
then
27205 -- The pragma appears in the statements of a package body
27207 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
27208 and then Nkind
(Parent
(Context
)) = N_Package_Body
27210 return Parent
(Context
);
27212 -- The pragma is a byproduct of aspect expansion, return the related
27213 -- context of the original aspect. This case has a lower priority as
27214 -- the above circuitry pinpoints precisely the related context.
27216 elsif Present
(Corresponding_Aspect
(Prag
)) then
27217 return Parent
(Corresponding_Aspect
(Prag
));
27219 -- No candidate packge [body] found
27224 end Find_Related_Package_Or_Body
;
27230 function Get_Argument
27232 Context_Id
: Entity_Id
:= Empty
) return Node_Id
27234 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
27237 -- Use the expression of the original aspect when compiling for ASIS or
27238 -- when analyzing the template of a generic unit. In both cases the
27239 -- aspect's tree must be decorated to allow for ASIS queries or to save
27240 -- the global references in the generic context.
27242 if From_Aspect_Specification
(Prag
)
27243 and then (ASIS_Mode
or else (Present
(Context_Id
)
27244 and then Is_Generic_Unit
(Context_Id
)))
27246 return Corresponding_Aspect
(Prag
);
27248 -- Otherwise use the expression of the pragma
27250 elsif Present
(Args
) then
27251 return First
(Args
);
27258 -------------------------
27259 -- Get_Base_Subprogram --
27260 -------------------------
27262 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
27263 Result
: Entity_Id
;
27266 -- Follow subprogram renaming chain
27270 if Is_Subprogram
(Result
)
27272 Nkind
(Parent
(Declaration_Node
(Result
))) =
27273 N_Subprogram_Renaming_Declaration
27274 and then Present
(Alias
(Result
))
27276 Result
:= Alias
(Result
);
27280 end Get_Base_Subprogram
;
27282 -----------------------
27283 -- Get_SPARK_Mode_Type --
27284 -----------------------
27286 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
27288 if N
= Name_On
then
27290 elsif N
= Name_Off
then
27293 -- Any other argument is illegal
27296 raise Program_Error
;
27298 end Get_SPARK_Mode_Type
;
27300 --------------------------------
27301 -- Get_SPARK_Mode_From_Pragma --
27302 --------------------------------
27304 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
27309 pragma Assert
(Nkind
(N
) = N_Pragma
);
27310 Args
:= Pragma_Argument_Associations
(N
);
27312 -- Extract the mode from the argument list
27314 if Present
(Args
) then
27315 Mode
:= First
(Pragma_Argument_Associations
(N
));
27316 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
27318 -- If SPARK_Mode pragma has no argument, default is ON
27323 end Get_SPARK_Mode_From_Pragma
;
27325 ---------------------------
27326 -- Has_Extra_Parentheses --
27327 ---------------------------
27329 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
27333 -- The aggregate should not have an expression list because a clause
27334 -- is always interpreted as a component association. The only way an
27335 -- expression list can sneak in is by adding extra parentheses around
27336 -- the individual clauses:
27338 -- Depends (Output => Input) -- proper form
27339 -- Depends ((Output => Input)) -- extra parentheses
27341 -- Since the extra parentheses are not allowed by the syntax of the
27342 -- pragma, flag them now to avoid emitting misleading errors down the
27345 if Nkind
(Clause
) = N_Aggregate
27346 and then Present
(Expressions
(Clause
))
27348 Expr
:= First
(Expressions
(Clause
));
27349 while Present
(Expr
) loop
27351 -- A dependency clause surrounded by extra parentheses appears
27352 -- as an aggregate of component associations with an optional
27353 -- Paren_Count set.
27355 if Nkind
(Expr
) = N_Aggregate
27356 and then Present
(Component_Associations
(Expr
))
27359 ("dependency clause contains extra parentheses", Expr
);
27361 -- Otherwise the expression is a malformed construct
27364 SPARK_Msg_N
("malformed dependency clause", Expr
);
27374 end Has_Extra_Parentheses
;
27380 procedure Initialize
is
27391 Dummy
:= Dummy
+ 1;
27394 -----------------------------
27395 -- Is_Config_Static_String --
27396 -----------------------------
27398 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
27400 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
27401 -- This is an internal recursive function that is just like the outer
27402 -- function except that it adds the string to the name buffer rather
27403 -- than placing the string in the name buffer.
27405 ------------------------------
27406 -- Add_Config_Static_String --
27407 ------------------------------
27409 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
27416 if Nkind
(N
) = N_Op_Concat
then
27417 if Add_Config_Static_String
(Left_Opnd
(N
)) then
27418 N
:= Right_Opnd
(N
);
27424 if Nkind
(N
) /= N_String_Literal
then
27425 Error_Msg_N
("string literal expected for pragma argument", N
);
27429 for J
in 1 .. String_Length
(Strval
(N
)) loop
27430 C
:= Get_String_Char
(Strval
(N
), J
);
27432 if not In_Character_Range
(C
) then
27434 ("string literal contains invalid wide character",
27435 Sloc
(N
) + 1 + Source_Ptr
(J
));
27439 Add_Char_To_Name_Buffer
(Get_Character
(C
));
27444 end Add_Config_Static_String
;
27446 -- Start of processing for Is_Config_Static_String
27451 return Add_Config_Static_String
(Arg
);
27452 end Is_Config_Static_String
;
27454 ---------------------
27455 -- Is_CCT_Instance --
27456 ---------------------
27458 function Is_CCT_Instance
(Ref
: Node_Id
) return Boolean is
27459 Ref_Id
: constant Entity_Id
:= Entity
(Ref
);
27463 -- Climb the scope chain looking for an enclosing concurrent type that
27464 -- matches the referenced entity.
27466 S
:= Current_Scope
;
27467 while Present
(S
) and then S
/= Standard_Standard
loop
27468 if Ekind_In
(S
, E_Protected_Type
, E_Task_Type
) and then S
= Ref_Id
27477 end Is_CCT_Instance
;
27479 -------------------------------
27480 -- Is_Elaboration_SPARK_Mode --
27481 -------------------------------
27483 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
27486 (Nkind
(N
) = N_Pragma
27487 and then Pragma_Name
(N
) = Name_SPARK_Mode
27488 and then Is_List_Member
(N
));
27490 -- Pragma SPARK_Mode affects the elaboration of a package body when it
27491 -- appears in the statement part of the body.
27494 Present
(Parent
(N
))
27495 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
27496 and then List_Containing
(N
) = Statements
(Parent
(N
))
27497 and then Present
(Parent
(Parent
(N
)))
27498 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
27499 end Is_Elaboration_SPARK_Mode
;
27501 -----------------------
27502 -- Is_Enabled_Pragma --
27503 -----------------------
27505 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
27509 if Present
(Prag
) then
27510 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
27512 if Present
(Arg
) then
27513 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
27515 -- The lack of a Boolean argument automatically enables the pragma
27521 -- The pragma is missing, therefore it is not enabled
27526 end Is_Enabled_Pragma
;
27528 -----------------------------------------
27529 -- Is_Non_Significant_Pragma_Reference --
27530 -----------------------------------------
27532 -- This function makes use of the following static table which indicates
27533 -- whether appearance of some name in a given pragma is to be considered
27534 -- as a reference for the purposes of warnings about unreferenced objects.
27536 -- -1 indicates that appearence in any argument is significant
27537 -- 0 indicates that appearance in any argument is not significant
27538 -- +n indicates that appearance as argument n is significant, but all
27539 -- other arguments are not significant
27540 -- 9n arguments from n on are significant, before n insignificant
27542 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
27543 (Pragma_Abort_Defer
=> -1,
27544 Pragma_Abstract_State
=> -1,
27545 Pragma_Ada_83
=> -1,
27546 Pragma_Ada_95
=> -1,
27547 Pragma_Ada_05
=> -1,
27548 Pragma_Ada_2005
=> -1,
27549 Pragma_Ada_12
=> -1,
27550 Pragma_Ada_2012
=> -1,
27551 Pragma_All_Calls_Remote
=> -1,
27552 Pragma_Allow_Integer_Address
=> -1,
27553 Pragma_Annotate
=> 93,
27554 Pragma_Assert
=> -1,
27555 Pragma_Assert_And_Cut
=> -1,
27556 Pragma_Assertion_Policy
=> 0,
27557 Pragma_Assume
=> -1,
27558 Pragma_Assume_No_Invalid_Values
=> 0,
27559 Pragma_Async_Readers
=> 0,
27560 Pragma_Async_Writers
=> 0,
27561 Pragma_Asynchronous
=> 0,
27562 Pragma_Atomic
=> 0,
27563 Pragma_Atomic_Components
=> 0,
27564 Pragma_Attach_Handler
=> -1,
27565 Pragma_Attribute_Definition
=> 92,
27566 Pragma_Check
=> -1,
27567 Pragma_Check_Float_Overflow
=> 0,
27568 Pragma_Check_Name
=> 0,
27569 Pragma_Check_Policy
=> 0,
27570 Pragma_CPP_Class
=> 0,
27571 Pragma_CPP_Constructor
=> 0,
27572 Pragma_CPP_Virtual
=> 0,
27573 Pragma_CPP_Vtable
=> 0,
27575 Pragma_C_Pass_By_Copy
=> 0,
27576 Pragma_Comment
=> -1,
27577 Pragma_Common_Object
=> 0,
27578 Pragma_Compile_Time_Error
=> -1,
27579 Pragma_Compile_Time_Warning
=> -1,
27580 Pragma_Compiler_Unit
=> -1,
27581 Pragma_Compiler_Unit_Warning
=> -1,
27582 Pragma_Complete_Representation
=> 0,
27583 Pragma_Complex_Representation
=> 0,
27584 Pragma_Component_Alignment
=> 0,
27585 Pragma_Constant_After_Elaboration
=> 0,
27586 Pragma_Contract_Cases
=> -1,
27587 Pragma_Controlled
=> 0,
27588 Pragma_Convention
=> 0,
27589 Pragma_Convention_Identifier
=> 0,
27590 Pragma_Debug
=> -1,
27591 Pragma_Debug_Policy
=> 0,
27592 Pragma_Detect_Blocking
=> 0,
27593 Pragma_Default_Initial_Condition
=> -1,
27594 Pragma_Default_Scalar_Storage_Order
=> 0,
27595 Pragma_Default_Storage_Pool
=> 0,
27596 Pragma_Depends
=> -1,
27597 Pragma_Disable_Atomic_Synchronization
=> 0,
27598 Pragma_Discard_Names
=> 0,
27599 Pragma_Dispatching_Domain
=> -1,
27600 Pragma_Effective_Reads
=> 0,
27601 Pragma_Effective_Writes
=> 0,
27602 Pragma_Elaborate
=> 0,
27603 Pragma_Elaborate_All
=> 0,
27604 Pragma_Elaborate_Body
=> 0,
27605 Pragma_Elaboration_Checks
=> 0,
27606 Pragma_Eliminate
=> 0,
27607 Pragma_Enable_Atomic_Synchronization
=> 0,
27608 Pragma_Export
=> -1,
27609 Pragma_Export_Function
=> -1,
27610 Pragma_Export_Object
=> -1,
27611 Pragma_Export_Procedure
=> -1,
27612 Pragma_Export_Value
=> -1,
27613 Pragma_Export_Valued_Procedure
=> -1,
27614 Pragma_Extend_System
=> -1,
27615 Pragma_Extensions_Allowed
=> 0,
27616 Pragma_Extensions_Visible
=> 0,
27617 Pragma_External
=> -1,
27618 Pragma_Favor_Top_Level
=> 0,
27619 Pragma_External_Name_Casing
=> 0,
27620 Pragma_Fast_Math
=> 0,
27621 Pragma_Finalize_Storage_Only
=> 0,
27623 Pragma_Global
=> -1,
27624 Pragma_Ident
=> -1,
27625 Pragma_Ignore_Pragma
=> 0,
27626 Pragma_Implementation_Defined
=> -1,
27627 Pragma_Implemented
=> -1,
27628 Pragma_Implicit_Packing
=> 0,
27629 Pragma_Import
=> 93,
27630 Pragma_Import_Function
=> 0,
27631 Pragma_Import_Object
=> 0,
27632 Pragma_Import_Procedure
=> 0,
27633 Pragma_Import_Valued_Procedure
=> 0,
27634 Pragma_Independent
=> 0,
27635 Pragma_Independent_Components
=> 0,
27636 Pragma_Initial_Condition
=> -1,
27637 Pragma_Initialize_Scalars
=> 0,
27638 Pragma_Initializes
=> -1,
27639 Pragma_Inline
=> 0,
27640 Pragma_Inline_Always
=> 0,
27641 Pragma_Inline_Generic
=> 0,
27642 Pragma_Inspection_Point
=> -1,
27643 Pragma_Interface
=> 92,
27644 Pragma_Interface_Name
=> 0,
27645 Pragma_Interrupt_Handler
=> -1,
27646 Pragma_Interrupt_Priority
=> -1,
27647 Pragma_Interrupt_State
=> -1,
27648 Pragma_Invariant
=> -1,
27649 Pragma_Keep_Names
=> 0,
27650 Pragma_License
=> 0,
27651 Pragma_Link_With
=> -1,
27652 Pragma_Linker_Alias
=> -1,
27653 Pragma_Linker_Constructor
=> -1,
27654 Pragma_Linker_Destructor
=> -1,
27655 Pragma_Linker_Options
=> -1,
27656 Pragma_Linker_Section
=> 0,
27658 Pragma_Lock_Free
=> 0,
27659 Pragma_Locking_Policy
=> 0,
27660 Pragma_Loop_Invariant
=> -1,
27661 Pragma_Loop_Optimize
=> 0,
27662 Pragma_Loop_Variant
=> -1,
27663 Pragma_Machine_Attribute
=> -1,
27665 Pragma_Main_Storage
=> -1,
27666 Pragma_Memory_Size
=> 0,
27667 Pragma_No_Return
=> 0,
27668 Pragma_No_Body
=> 0,
27669 Pragma_No_Elaboration_Code_All
=> 0,
27670 Pragma_No_Inline
=> 0,
27671 Pragma_No_Run_Time
=> -1,
27672 Pragma_No_Strict_Aliasing
=> -1,
27673 Pragma_No_Tagged_Streams
=> 0,
27674 Pragma_Normalize_Scalars
=> 0,
27675 Pragma_Obsolescent
=> 0,
27676 Pragma_Optimize
=> 0,
27677 Pragma_Optimize_Alignment
=> 0,
27678 Pragma_Overflow_Mode
=> 0,
27679 Pragma_Overriding_Renamings
=> 0,
27680 Pragma_Ordered
=> 0,
27683 Pragma_Part_Of
=> 0,
27684 Pragma_Partition_Elaboration_Policy
=> 0,
27685 Pragma_Passive
=> 0,
27686 Pragma_Persistent_BSS
=> 0,
27687 Pragma_Polling
=> 0,
27688 Pragma_Prefix_Exception_Messages
=> 0,
27690 Pragma_Postcondition
=> -1,
27691 Pragma_Post_Class
=> -1,
27693 Pragma_Precondition
=> -1,
27694 Pragma_Predicate
=> -1,
27695 Pragma_Predicate_Failure
=> -1,
27696 Pragma_Preelaborable_Initialization
=> -1,
27697 Pragma_Preelaborate
=> 0,
27698 Pragma_Pre_Class
=> -1,
27699 Pragma_Priority
=> -1,
27700 Pragma_Priority_Specific_Dispatching
=> 0,
27701 Pragma_Profile
=> 0,
27702 Pragma_Profile_Warnings
=> 0,
27703 Pragma_Propagate_Exceptions
=> 0,
27704 Pragma_Provide_Shift_Operators
=> 0,
27705 Pragma_Psect_Object
=> 0,
27707 Pragma_Pure_Function
=> 0,
27708 Pragma_Queuing_Policy
=> 0,
27709 Pragma_Rational
=> 0,
27710 Pragma_Ravenscar
=> 0,
27711 Pragma_Refined_Depends
=> -1,
27712 Pragma_Refined_Global
=> -1,
27713 Pragma_Refined_Post
=> -1,
27714 Pragma_Refined_State
=> -1,
27715 Pragma_Relative_Deadline
=> 0,
27716 Pragma_Remote_Access_Type
=> -1,
27717 Pragma_Remote_Call_Interface
=> -1,
27718 Pragma_Remote_Types
=> -1,
27719 Pragma_Restricted_Run_Time
=> 0,
27720 Pragma_Restriction_Warnings
=> 0,
27721 Pragma_Restrictions
=> 0,
27722 Pragma_Reviewable
=> -1,
27723 Pragma_Short_Circuit_And_Or
=> 0,
27724 Pragma_Share_Generic
=> 0,
27725 Pragma_Shared
=> 0,
27726 Pragma_Shared_Passive
=> 0,
27727 Pragma_Short_Descriptors
=> 0,
27728 Pragma_Simple_Storage_Pool_Type
=> 0,
27729 Pragma_Source_File_Name
=> 0,
27730 Pragma_Source_File_Name_Project
=> 0,
27731 Pragma_Source_Reference
=> 0,
27732 Pragma_SPARK_Mode
=> 0,
27733 Pragma_Storage_Size
=> -1,
27734 Pragma_Storage_Unit
=> 0,
27735 Pragma_Static_Elaboration_Desired
=> 0,
27736 Pragma_Stream_Convert
=> 0,
27737 Pragma_Style_Checks
=> 0,
27738 Pragma_Subtitle
=> 0,
27739 Pragma_Suppress
=> 0,
27740 Pragma_Suppress_Exception_Locations
=> 0,
27741 Pragma_Suppress_All
=> 0,
27742 Pragma_Suppress_Debug_Info
=> 0,
27743 Pragma_Suppress_Initialization
=> 0,
27744 Pragma_System_Name
=> 0,
27745 Pragma_Task_Dispatching_Policy
=> 0,
27746 Pragma_Task_Info
=> -1,
27747 Pragma_Task_Name
=> -1,
27748 Pragma_Task_Storage
=> -1,
27749 Pragma_Test_Case
=> -1,
27750 Pragma_Thread_Local_Storage
=> -1,
27751 Pragma_Time_Slice
=> -1,
27753 Pragma_Type_Invariant
=> -1,
27754 Pragma_Type_Invariant_Class
=> -1,
27755 Pragma_Unchecked_Union
=> 0,
27756 Pragma_Unimplemented_Unit
=> 0,
27757 Pragma_Universal_Aliasing
=> 0,
27758 Pragma_Universal_Data
=> 0,
27759 Pragma_Unmodified
=> 0,
27760 Pragma_Unreferenced
=> 0,
27761 Pragma_Unreferenced_Objects
=> 0,
27762 Pragma_Unreserve_All_Interrupts
=> 0,
27763 Pragma_Unsuppress
=> 0,
27764 Pragma_Unevaluated_Use_Of_Old
=> 0,
27765 Pragma_Use_VADS_Size
=> 0,
27766 Pragma_Validity_Checks
=> 0,
27767 Pragma_Volatile
=> 0,
27768 Pragma_Volatile_Components
=> 0,
27769 Pragma_Volatile_Full_Access
=> 0,
27770 Pragma_Volatile_Function
=> 0,
27771 Pragma_Warning_As_Error
=> 0,
27772 Pragma_Warnings
=> 0,
27773 Pragma_Weak_External
=> 0,
27774 Pragma_Wide_Character_Encoding
=> 0,
27775 Unknown_Pragma
=> 0);
27777 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
27783 function Arg_No
return Nat
;
27784 -- Returns an integer showing what argument we are in. A value of
27785 -- zero means we are not in any of the arguments.
27791 function Arg_No
return Nat
is
27796 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
27810 -- Start of processing for Non_Significant_Pragma_Reference
27815 if Nkind
(P
) /= N_Pragma_Argument_Association
then
27819 Id
:= Get_Pragma_Id
(Parent
(P
));
27820 C
:= Sig_Flags
(Id
);
27835 return AN
< (C
- 90);
27841 end Is_Non_Significant_Pragma_Reference
;
27843 ------------------------------
27844 -- Is_Pragma_String_Literal --
27845 ------------------------------
27847 -- This function returns true if the corresponding pragma argument is a
27848 -- static string expression. These are the only cases in which string
27849 -- literals can appear as pragma arguments. We also allow a string literal
27850 -- as the first argument to pragma Assert (although it will of course
27851 -- always generate a type error).
27853 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
27854 Pragn
: constant Node_Id
:= Parent
(Par
);
27855 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
27856 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
27862 N
:= First
(Assoc
);
27869 if Pname
= Name_Assert
then
27872 elsif Pname
= Name_Export
then
27875 elsif Pname
= Name_Ident
then
27878 elsif Pname
= Name_Import
then
27881 elsif Pname
= Name_Interface_Name
then
27884 elsif Pname
= Name_Linker_Alias
then
27887 elsif Pname
= Name_Linker_Section
then
27890 elsif Pname
= Name_Machine_Attribute
then
27893 elsif Pname
= Name_Source_File_Name
then
27896 elsif Pname
= Name_Source_Reference
then
27899 elsif Pname
= Name_Title
then
27902 elsif Pname
= Name_Subtitle
then
27908 end Is_Pragma_String_Literal
;
27910 ---------------------------
27911 -- Is_Private_SPARK_Mode --
27912 ---------------------------
27914 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
27917 (Nkind
(N
) = N_Pragma
27918 and then Pragma_Name
(N
) = Name_SPARK_Mode
27919 and then Is_List_Member
(N
));
27921 -- For pragma SPARK_Mode to be private, it has to appear in the private
27922 -- declarations of a package.
27925 Present
(Parent
(N
))
27926 and then Nkind
(Parent
(N
)) = N_Package_Specification
27927 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
27928 end Is_Private_SPARK_Mode
;
27930 -------------------------------------
27931 -- Is_Unconstrained_Or_Tagged_Item --
27932 -------------------------------------
27934 function Is_Unconstrained_Or_Tagged_Item
27935 (Item
: Entity_Id
) return Boolean
27937 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
27938 -- Determine whether record type Typ has at least one unconstrained
27941 ---------------------------------
27942 -- Has_Unconstrained_Component --
27943 ---------------------------------
27945 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
27949 Comp
:= First_Component
(Typ
);
27950 while Present
(Comp
) loop
27951 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
27955 Next_Component
(Comp
);
27959 end Has_Unconstrained_Component
;
27963 Typ
: constant Entity_Id
:= Etype
(Item
);
27965 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
27968 if Is_Tagged_Type
(Typ
) then
27971 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
27974 elsif Is_Record_Type
(Typ
) then
27975 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
27978 return Has_Unconstrained_Component
(Typ
);
27981 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
27987 end Is_Unconstrained_Or_Tagged_Item
;
27989 -----------------------------
27990 -- Is_Valid_Assertion_Kind --
27991 -----------------------------
27993 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
28000 Name_Static_Predicate |
28001 Name_Dynamic_Predicate |
28006 Name_Type_Invariant |
28007 Name_uType_Invariant |
28011 Name_Assert_And_Cut |
28013 Name_Contract_Cases |
28015 Name_Default_Initial_Condition |
28017 Name_Initial_Condition |
28020 Name_Loop_Invariant |
28021 Name_Loop_Variant |
28022 Name_Postcondition |
28023 Name_Precondition |
28025 Name_Refined_Post |
28026 Name_Statement_Assertions
=> return True;
28028 when others => return False;
28030 end Is_Valid_Assertion_Kind
;
28032 --------------------------------------
28033 -- Process_Compilation_Unit_Pragmas --
28034 --------------------------------------
28036 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
28038 -- A special check for pragma Suppress_All, a very strange DEC pragma,
28039 -- strange because it comes at the end of the unit. Rational has the
28040 -- same name for a pragma, but treats it as a program unit pragma, In
28041 -- GNAT we just decide to allow it anywhere at all. If it appeared then
28042 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
28043 -- node, and we insert a pragma Suppress (All_Checks) at the start of
28044 -- the context clause to ensure the correct processing.
28046 if Has_Pragma_Suppress_All
(N
) then
28047 Prepend_To
(Context_Items
(N
),
28048 Make_Pragma
(Sloc
(N
),
28049 Chars
=> Name_Suppress
,
28050 Pragma_Argument_Associations
=> New_List
(
28051 Make_Pragma_Argument_Association
(Sloc
(N
),
28052 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
28055 -- Nothing else to do at the current time
28057 end Process_Compilation_Unit_Pragmas
;
28059 ------------------------------------
28060 -- Record_Possible_Body_Reference --
28061 ------------------------------------
28063 procedure Record_Possible_Body_Reference
28064 (State_Id
: Entity_Id
;
28068 Spec_Id
: Entity_Id
;
28071 -- Ensure that we are dealing with a reference to a state
28073 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
28075 -- Climb the tree starting from the reference looking for a package body
28076 -- whose spec declares the referenced state. This criteria automatically
28077 -- excludes references in package specs which are legal. Note that it is
28078 -- not wise to emit an error now as the package body may lack pragma
28079 -- Refined_State or the referenced state may not be mentioned in the
28080 -- refinement. This approach avoids the generation of misleading errors.
28083 while Present
(Context
) loop
28084 if Nkind
(Context
) = N_Package_Body
then
28085 Spec_Id
:= Corresponding_Spec
(Context
);
28087 if Present
(Abstract_States
(Spec_Id
))
28088 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
28090 if No
(Body_References
(State_Id
)) then
28091 Set_Body_References
(State_Id
, New_Elmt_List
);
28094 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
28099 Context
:= Parent
(Context
);
28101 end Record_Possible_Body_Reference
;
28103 ------------------------------------------
28104 -- Relocate_Pragmas_To_Anonymous_Object --
28105 ------------------------------------------
28107 procedure Relocate_Pragmas_To_Anonymous_Object
28108 (Typ_Decl
: Node_Id
;
28109 Obj_Decl
: Node_Id
)
28113 Next_Decl
: Node_Id
;
28116 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
28117 Def
:= Protected_Definition
(Typ_Decl
);
28119 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
28120 Def
:= Task_Definition
(Typ_Decl
);
28123 -- The concurrent definition has a visible declaration list. Inspect it
28124 -- and relocate all canidate pragmas.
28126 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
28127 Decl
:= First
(Visible_Declarations
(Def
));
28128 while Present
(Decl
) loop
28130 -- Preserve the following declaration for iteration purposes due
28131 -- to possible relocation of a pragma.
28133 Next_Decl
:= Next
(Decl
);
28135 if Nkind
(Decl
) = N_Pragma
28136 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
28139 Insert_After
(Obj_Decl
, Decl
);
28141 -- Skip internally generated code
28143 elsif not Comes_From_Source
(Decl
) then
28146 -- No candidate pragmas are available for relocation
28155 end Relocate_Pragmas_To_Anonymous_Object
;
28157 ------------------------------
28158 -- Relocate_Pragmas_To_Body --
28159 ------------------------------
28161 procedure Relocate_Pragmas_To_Body
28162 (Subp_Body
: Node_Id
;
28163 Target_Body
: Node_Id
:= Empty
)
28165 procedure Relocate_Pragma
(Prag
: Node_Id
);
28166 -- Remove a single pragma from its current list and add it to the
28167 -- declarations of the proper body (either Subp_Body or Target_Body).
28169 ---------------------
28170 -- Relocate_Pragma --
28171 ---------------------
28173 procedure Relocate_Pragma
(Prag
: Node_Id
) is
28178 -- When subprogram stubs or expression functions are involves, the
28179 -- destination declaration list belongs to the proper body.
28181 if Present
(Target_Body
) then
28182 Target
:= Target_Body
;
28184 Target
:= Subp_Body
;
28187 Decls
:= Declarations
(Target
);
28191 Set_Declarations
(Target
, Decls
);
28194 -- Unhook the pragma from its current list
28197 Prepend
(Prag
, Decls
);
28198 end Relocate_Pragma
;
28202 Body_Id
: constant Entity_Id
:=
28203 Defining_Unit_Name
(Specification
(Subp_Body
));
28204 Next_Stmt
: Node_Id
;
28207 -- Start of processing for Relocate_Pragmas_To_Body
28210 -- Do not process a body that comes from a separate unit as no construct
28211 -- can possibly follow it.
28213 if not Is_List_Member
(Subp_Body
) then
28216 -- Do not relocate pragmas that follow a stub if the stub does not have
28219 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
28220 and then No
(Target_Body
)
28224 -- Do not process internally generated routine _Postconditions
28226 elsif Ekind
(Body_Id
) = E_Procedure
28227 and then Chars
(Body_Id
) = Name_uPostconditions
28232 -- Look at what is following the body. We are interested in certain kind
28233 -- of pragmas (either from source or byproducts of expansion) that can
28234 -- apply to a body [stub].
28236 Stmt
:= Next
(Subp_Body
);
28237 while Present
(Stmt
) loop
28239 -- Preserve the following statement for iteration purposes due to a
28240 -- possible relocation of a pragma.
28242 Next_Stmt
:= Next
(Stmt
);
28244 -- Move a candidate pragma following the body to the declarations of
28247 if Nkind
(Stmt
) = N_Pragma
28248 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
28250 Relocate_Pragma
(Stmt
);
28252 -- Skip internally generated code
28254 elsif not Comes_From_Source
(Stmt
) then
28257 -- No candidate pragmas are available for relocation
28265 end Relocate_Pragmas_To_Body
;
28267 -------------------
28268 -- Resolve_State --
28269 -------------------
28271 procedure Resolve_State
(N
: Node_Id
) is
28276 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
28277 Func
:= Entity
(N
);
28279 -- Handle overloading of state names by functions. Traverse the
28280 -- homonym chain looking for an abstract state.
28282 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
28283 State
:= Homonym
(Func
);
28284 while Present
(State
) loop
28286 -- Resolve the overloading by setting the proper entity of the
28287 -- reference to that of the state.
28289 if Ekind
(State
) = E_Abstract_State
then
28290 Set_Etype
(N
, Standard_Void_Type
);
28291 Set_Entity
(N
, State
);
28292 Set_Associated_Node
(N
, State
);
28296 State
:= Homonym
(State
);
28299 -- A function can never act as a state. If the homonym chain does
28300 -- not contain a corresponding state, then something went wrong in
28301 -- the overloading mechanism.
28303 raise Program_Error
;
28308 ----------------------------
28309 -- Rewrite_Assertion_Kind --
28310 ----------------------------
28312 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
28316 if Nkind
(N
) = N_Attribute_Reference
28317 and then Attribute_Name
(N
) = Name_Class
28318 and then Nkind
(Prefix
(N
)) = N_Identifier
28320 case Chars
(Prefix
(N
)) is
28325 when Name_Type_Invariant
=>
28326 Nam
:= Name_uType_Invariant
;
28327 when Name_Invariant
=>
28328 Nam
:= Name_uInvariant
;
28333 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
28335 end Rewrite_Assertion_Kind
;
28343 Dummy
:= Dummy
+ 1;
28346 --------------------------------
28347 -- Set_Encoded_Interface_Name --
28348 --------------------------------
28350 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
28351 Str
: constant String_Id
:= Strval
(S
);
28352 Len
: constant Int
:= String_Length
(Str
);
28357 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
28360 -- Stores encoded value of character code CC. The encoding we use an
28361 -- underscore followed by four lower case hex digits.
28367 procedure Encode
is
28369 Store_String_Char
(Get_Char_Code
('_'));
28371 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
28373 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
28375 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
28377 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
28380 -- Start of processing for Set_Encoded_Interface_Name
28383 -- If first character is asterisk, this is a link name, and we leave it
28384 -- completely unmodified. We also ignore null strings (the latter case
28385 -- happens only in error cases) and no encoding should occur for AAMP
28386 -- interface names.
28389 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
28390 or else AAMP_On_Target
28392 Set_Interface_Name
(E
, S
);
28397 CC
:= Get_String_Char
(Str
, J
);
28399 exit when not In_Character_Range
(CC
);
28401 C
:= Get_Character
(CC
);
28403 exit when C
/= '_' and then C
/= '$'
28404 and then C
not in '0' .. '9'
28405 and then C
not in 'a' .. 'z'
28406 and then C
not in 'A' .. 'Z';
28409 Set_Interface_Name
(E
, S
);
28417 -- Here we need to encode. The encoding we use as follows:
28418 -- three underscores + four hex digits (lower case)
28422 for J
in 1 .. String_Length
(Str
) loop
28423 CC
:= Get_String_Char
(Str
, J
);
28425 if not In_Character_Range
(CC
) then
28428 C
:= Get_Character
(CC
);
28430 if C
= '_' or else C
= '$'
28431 or else C
in '0' .. '9'
28432 or else C
in 'a' .. 'z'
28433 or else C
in 'A' .. 'Z'
28435 Store_String_Char
(CC
);
28442 Set_Interface_Name
(E
,
28443 Make_String_Literal
(Sloc
(S
),
28444 Strval
=> End_String
));
28446 end Set_Encoded_Interface_Name
;
28448 ------------------------
28449 -- Set_Elab_Unit_Name --
28450 ------------------------
28452 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
28457 if Nkind
(N
) = N_Identifier
28458 and then Nkind
(With_Item
) = N_Identifier
28460 Set_Entity
(N
, Entity
(With_Item
));
28462 elsif Nkind
(N
) = N_Selected_Component
then
28463 Change_Selected_Component_To_Expanded_Name
(N
);
28464 Set_Entity
(N
, Entity
(With_Item
));
28465 Set_Entity
(Selector_Name
(N
), Entity
(N
));
28467 Pref
:= Prefix
(N
);
28468 Scop
:= Scope
(Entity
(N
));
28469 while Nkind
(Pref
) = N_Selected_Component
loop
28470 Change_Selected_Component_To_Expanded_Name
(Pref
);
28471 Set_Entity
(Selector_Name
(Pref
), Scop
);
28472 Set_Entity
(Pref
, Scop
);
28473 Pref
:= Prefix
(Pref
);
28474 Scop
:= Scope
(Scop
);
28477 Set_Entity
(Pref
, Scop
);
28480 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
28481 end Set_Elab_Unit_Name
;
28483 -------------------
28484 -- Test_Case_Arg --
28485 -------------------
28487 function Test_Case_Arg
28490 From_Aspect
: Boolean := False) return Node_Id
28492 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
28497 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
28502 -- The caller requests the aspect argument
28504 if From_Aspect
then
28505 if Present
(Aspect
)
28506 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
28508 Args
:= Expression
(Aspect
);
28510 -- "Name" and "Mode" may appear without an identifier as a
28511 -- positional association.
28513 if Present
(Expressions
(Args
)) then
28514 Arg
:= First
(Expressions
(Args
));
28516 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
28524 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
28529 -- Some or all arguments may appear as component associatons
28531 if Present
(Component_Associations
(Args
)) then
28532 Arg
:= First
(Component_Associations
(Args
));
28533 while Present
(Arg
) loop
28534 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
28543 -- Otherwise retrieve the argument directly from the pragma
28546 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
28548 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
28552 -- Skip argument "Name"
28556 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
28560 -- Skip argument "Mode"
28564 -- Arguments "Requires" and "Ensures" are optional and may not be
28567 while Present
(Arg
) loop
28568 if Chars
(Arg
) = Arg_Nam
then