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 Csets
; use Csets
;
37 with Debug
; use Debug
;
38 with Einfo
; use Einfo
;
39 with Elists
; use Elists
;
40 with Errout
; use Errout
;
41 with Exp_Dist
; use Exp_Dist
;
42 with Exp_Util
; use Exp_Util
;
43 with Freeze
; use Freeze
;
44 with Ghost
; use Ghost
;
46 with Lib
.Writ
; use Lib
.Writ
;
47 with Lib
.Xref
; use Lib
.Xref
;
48 with Namet
.Sp
; use Namet
.Sp
;
49 with Nlists
; use Nlists
;
50 with Nmake
; use Nmake
;
51 with Output
; use Output
;
52 with Par_SCO
; use Par_SCO
;
53 with Restrict
; use Restrict
;
54 with Rident
; use Rident
;
55 with Rtsfind
; use Rtsfind
;
57 with Sem_Aux
; use Sem_Aux
;
58 with Sem_Ch3
; use Sem_Ch3
;
59 with Sem_Ch6
; use Sem_Ch6
;
60 with Sem_Ch8
; use Sem_Ch8
;
61 with Sem_Ch12
; use Sem_Ch12
;
62 with Sem_Ch13
; use Sem_Ch13
;
63 with Sem_Disp
; use Sem_Disp
;
64 with Sem_Dist
; use Sem_Dist
;
65 with Sem_Elim
; use Sem_Elim
;
66 with Sem_Eval
; use Sem_Eval
;
67 with Sem_Intr
; use Sem_Intr
;
68 with Sem_Mech
; use Sem_Mech
;
69 with Sem_Res
; use Sem_Res
;
70 with Sem_Type
; use Sem_Type
;
71 with Sem_Util
; use Sem_Util
;
72 with Sem_Warn
; use Sem_Warn
;
73 with Stand
; use Stand
;
74 with Sinfo
; use Sinfo
;
75 with Sinfo
.CN
; use Sinfo
.CN
;
76 with Sinput
; use Sinput
;
77 with Stringt
; use Stringt
;
78 with Stylesw
; use Stylesw
;
80 with Targparm
; use Targparm
;
81 with Tbuild
; use Tbuild
;
83 with Uintp
; use Uintp
;
84 with Uname
; use Uname
;
85 with Urealp
; use Urealp
;
86 with Validsw
; use Validsw
;
87 with Warnsw
; use Warnsw
;
89 package body Sem_Prag
is
91 ----------------------------------------------
92 -- Common Handling of Import-Export Pragmas --
93 ----------------------------------------------
95 -- In the following section, a number of Import_xxx and Export_xxx pragmas
96 -- are defined by GNAT. These are compatible with the DEC pragmas of the
97 -- same name, and all have the following common form and processing:
100 -- [Internal =>] LOCAL_NAME
101 -- [, [External =>] EXTERNAL_SYMBOL]
102 -- [, other optional parameters ]);
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
109 -- EXTERNAL_SYMBOL ::=
111 -- | static_string_EXPRESSION
113 -- The internal LOCAL_NAME designates the entity that is imported or
114 -- exported, and must refer to an entity in the current declarative
115 -- part (as required by the rules for LOCAL_NAME).
117 -- The external linker name is designated by the External parameter if
118 -- given, or the Internal parameter if not (if there is no External
119 -- parameter, the External parameter is a copy of the Internal name).
121 -- If the External parameter is given as a string, then this string is
122 -- treated as an external name (exactly as though it had been given as an
123 -- External_Name parameter for a normal Import pragma).
125 -- If the External parameter is given as an identifier (or there is no
126 -- External parameter, so that the Internal identifier is used), then
127 -- the external name is the characters of the identifier, translated
128 -- to all lower case letters.
130 -- Note: the external name specified or implied by any of these special
131 -- Import_xxx or Export_xxx pragmas override an external or link name
132 -- specified in a previous Import or Export pragma.
134 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
135 -- named notation, following the standard rules for subprogram calls, i.e.
136 -- parameters can be given in any order if named notation is used, and
137 -- positional and named notation can be mixed, subject to the rule that all
138 -- positional parameters must appear first.
140 -- Note: All these pragmas are implemented exactly following the DEC design
141 -- and implementation and are intended to be fully compatible with the use
142 -- of these pragmas in the DEC Ada compiler.
144 --------------------------------------------
145 -- Checking for Duplicated External Names --
146 --------------------------------------------
148 -- It is suspicious if two separate Export pragmas use the same external
149 -- name. The following table is used to diagnose this situation so that
150 -- an appropriate warning can be issued.
152 -- The Node_Id stored is for the N_String_Literal node created to hold
153 -- the value of the external name. The Sloc of this node is used to
154 -- cross-reference the location of the duplication.
156 package Externals
is new Table
.Table
(
157 Table_Component_Type
=> Node_Id
,
158 Table_Index_Type
=> Int
,
159 Table_Low_Bound
=> 0,
160 Table_Initial
=> 100,
161 Table_Increment
=> 100,
162 Table_Name
=> "Name_Externals");
164 -------------------------------------
165 -- Local Subprograms and Variables --
166 -------------------------------------
168 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
);
169 -- Subsidiary routine to the analysis of pragmas Depends, Global and
170 -- Refined_State. Append an entity to a list. If the list is empty, create
173 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
174 -- This routine is used for possible casing adjustment of an explicit
175 -- external name supplied as a string literal (the node N), according to
176 -- the casing requirement of Opt.External_Name_Casing. If this is set to
177 -- As_Is, then the string literal is returned unchanged, but if it is set
178 -- to Uppercase or Lowercase, then a new string literal with appropriate
179 -- casing is constructed.
181 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
182 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
183 -- Query whether a particular item appears in a mixed list of nodes and
184 -- entities. It is assumed that all nodes in the list have entities.
186 function Check_Kind
(Nam
: Name_Id
) return Name_Id
;
187 -- This function is used in connection with pragmas Assert, Check,
188 -- and assertion aspects and pragmas, to determine if Check pragmas
189 -- (or corresponding assertion aspects or pragmas) are currently active
190 -- as determined by the presence of -gnata on the command line (which
191 -- sets the default), and the appearance of pragmas Check_Policy and
192 -- Assertion_Policy as configuration pragmas either in a configuration
193 -- pragma file, or at the start of the current unit, or locally given
194 -- Check_Policy and Assertion_Policy pragmas that are currently active.
196 -- The value returned is one of the names Check, Ignore, Disable (On
197 -- returns Check, and Off returns Ignore).
199 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class,
200 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost,
201 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre,
202 -- _Post, _Invariant, or _Type_Invariant, which are special names used
203 -- in identifiers to represent these attribute references.
205 procedure Check_Postcondition_Use_In_Inlined_Subprogram
207 Spec_Id
: Entity_Id
);
208 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
209 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
210 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
212 procedure Check_State_And_Constituent_Use
216 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
217 -- Global and Initializes. Determine whether a state from list States and a
218 -- corresponding constituent from list Constits (if any) appear in the same
219 -- context denoted by Context. If this is the case, emit an error.
221 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
222 -- Subsidiary to routines Find_Related_Package_Or_Body and
223 -- Find_Related_Subprogram_Or_Body. Emit an error on pragma Prag that
224 -- duplicates previous pragma Prev.
226 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
227 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
228 -- original one, following the renaming chain) is returned. Otherwise the
229 -- entity is returned unchanged. Should be in Einfo???
231 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
232 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
233 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
236 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
237 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
238 -- Determine whether dependency clause Clause is surrounded by extra
239 -- parentheses. If this is the case, issue an error message.
241 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
242 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
243 -- pragma Depends. Determine whether the type of dependency item Item is
244 -- tagged, unconstrained array, unconstrained record or a record with at
245 -- least one unconstrained component.
247 procedure Record_Possible_Body_Reference
248 (State_Id
: Entity_Id
;
250 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
251 -- Global. Given an abstract state denoted by State_Id and a reference Ref
252 -- to it, determine whether the reference appears in a package body that
253 -- will eventually refine the state. If this is the case, record the
254 -- reference for future checks (see Analyze_Refined_State_In_Decls).
256 procedure Resolve_State
(N
: Node_Id
);
257 -- Handle the overloading of state names by functions. When N denotes a
258 -- function, this routine finds the corresponding state and sets the entity
259 -- of N to that of the state.
261 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
262 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
263 -- then it is rewritten as an identifier with the corresponding special
264 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
267 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
268 -- Place semantic information on the argument of an Elaborate/Elaborate_All
269 -- pragma. Entity name for unit and its parents is taken from item in
270 -- previous with_clause that mentions the unit.
272 Dummy
: Integer := 0;
273 pragma Volatile
(Dummy
);
274 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
277 pragma No_Inline
(ip
);
278 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
279 -- is just to help debugging the front end. If a pragma Inspection_Point
280 -- is added to a source program, then breaking on ip will get you to that
281 -- point in the program.
284 pragma No_Inline
(rv
);
285 -- This is a dummy function called by the processing for pragma Reviewable.
286 -- It is there for assisting front end debugging. By placing a Reviewable
287 -- pragma in the source program, a breakpoint on rv catches this place in
288 -- the source, allowing convenient stepping to the point of interest.
294 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
) is
296 Append_New_Elmt
(Item
, To
=> To_List
);
299 -------------------------------
300 -- Adjust_External_Name_Case --
301 -------------------------------
303 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
307 -- Adjust case of literal if required
309 if Opt
.External_Name_Exp_Casing
= As_Is
then
313 -- Copy existing string
319 for J
in 1 .. String_Length
(Strval
(N
)) loop
320 CC
:= Get_String_Char
(Strval
(N
), J
);
322 if Opt
.External_Name_Exp_Casing
= Uppercase
323 and then CC
>= Get_Char_Code
('a')
324 and then CC
<= Get_Char_Code
('z')
326 Store_String_Char
(CC
- 32);
328 elsif Opt
.External_Name_Exp_Casing
= Lowercase
329 and then CC
>= Get_Char_Code
('A')
330 and then CC
<= Get_Char_Code
('Z')
332 Store_String_Char
(CC
+ 32);
335 Store_String_Char
(CC
);
340 Make_String_Literal
(Sloc
(N
),
341 Strval
=> End_String
);
343 end Adjust_External_Name_Case
;
345 -----------------------------------------
346 -- Analyze_Contract_Cases_In_Decl_Part --
347 -----------------------------------------
349 procedure Analyze_Contract_Cases_In_Decl_Part
(N
: Node_Id
) is
350 Others_Seen
: Boolean := False;
352 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
353 -- Verify the legality of a single contract case
355 ---------------------------
356 -- Analyze_Contract_Case --
357 ---------------------------
359 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
360 Case_Guard
: Node_Id
;
362 Extra_Guard
: Node_Id
;
365 if Nkind
(CCase
) = N_Component_Association
then
366 Case_Guard
:= First
(Choices
(CCase
));
367 Conseq
:= Expression
(CCase
);
369 -- Each contract case must have exactly one case guard
371 Extra_Guard
:= Next
(Case_Guard
);
373 if Present
(Extra_Guard
) then
375 ("contract case must have exactly one case guard",
379 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
381 if Nkind
(Case_Guard
) = N_Others_Choice
then
384 ("only one others choice allowed in contract cases",
390 elsif Others_Seen
then
392 ("others must be the last choice in contract cases", N
);
395 -- Preanalyze the case guard and consequence
397 if Nkind
(Case_Guard
) /= N_Others_Choice
then
398 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
401 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
403 -- The contract case is malformed
406 Error_Msg_N
("wrong syntax in contract case", CCase
);
408 end Analyze_Contract_Case
;
412 Subp_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
413 Spec_Id
: constant Entity_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
414 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
417 Restore_Scope
: Boolean := False;
419 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
424 -- Single and multiple contract cases must appear in aggregate form. If
425 -- this is not the case, then either the parser of the analysis of the
426 -- pragma failed to produce an aggregate.
428 pragma Assert
(Nkind
(CCases
) = N_Aggregate
);
430 if Present
(Component_Associations
(CCases
)) then
432 -- Ensure that the formal parameters are visible when analyzing all
433 -- clauses. This falls out of the general rule of aspects pertaining
434 -- to subprogram declarations.
436 if not In_Open_Scopes
(Spec_Id
) then
437 Restore_Scope
:= True;
438 Push_Scope
(Spec_Id
);
440 if Is_Generic_Subprogram
(Spec_Id
) then
441 Install_Generic_Formals
(Spec_Id
);
443 Install_Formals
(Spec_Id
);
447 CCase
:= First
(Component_Associations
(CCases
));
448 while Present
(CCase
) loop
449 Analyze_Contract_Case
(CCase
);
453 if Restore_Scope
then
457 -- Currently it is not possible to inline pre/postconditions on a
458 -- subprogram subject to pragma Inline_Always.
460 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
462 -- Otherwise the pragma is illegal
465 Error_Msg_N
("wrong syntax for constract cases", N
);
467 end Analyze_Contract_Cases_In_Decl_Part
;
469 ----------------------------------
470 -- Analyze_Depends_In_Decl_Part --
471 ----------------------------------
473 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
474 Loc
: constant Source_Ptr
:= Sloc
(N
);
475 Subp_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
476 Spec_Id
: constant Entity_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
478 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
479 -- A list containing the entities of all the inputs processed so far.
480 -- The list is populated with unique entities because the same input
481 -- may appear in multiple input lists.
483 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
484 -- A list containing the entities of all the outputs processed so far.
485 -- The list is populated with unique entities because output items are
486 -- unique in a dependence relation.
488 Constits_Seen
: Elist_Id
:= No_Elist
;
489 -- A list containing the entities of all constituents processed so far.
490 -- It aids in detecting illegal usage of a state and a corresponding
491 -- constituent in pragma [Refinde_]Depends.
493 Global_Seen
: Boolean := False;
494 -- A flag set when pragma Global has been processed
496 Null_Output_Seen
: Boolean := False;
497 -- A flag used to track the legality of a null output
499 Result_Seen
: Boolean := False;
500 -- A flag set when Spec_Id'Result is processed
502 States_Seen
: Elist_Id
:= No_Elist
;
503 -- A list containing the entities of all states processed so far. It
504 -- helps in detecting illegal usage of a state and a corresponding
505 -- constituent in pragma [Refined_]Depends.
507 Subp_Inputs
: Elist_Id
:= No_Elist
;
508 Subp_Outputs
: Elist_Id
:= No_Elist
;
509 -- Two lists containing the full set of inputs and output of the related
510 -- subprograms. Note that these lists contain both nodes and entities.
512 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
513 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
514 -- to the name buffer. The individual kinds are as follows:
515 -- E_Abstract_State - "state"
516 -- E_Constant - "constant"
517 -- E_Generic_In_Out_Parameter - "generic parameter"
518 -- E_Generic_Out_Parameter - "generic parameter"
519 -- E_In_Parameter - "parameter"
520 -- E_In_Out_Parameter - "parameter"
521 -- E_Out_Parameter - "parameter"
522 -- E_Variable - "global"
524 procedure Analyze_Dependency_Clause
527 -- Verify the legality of a single dependency clause. Flag Is_Last
528 -- denotes whether Clause is the last clause in the relation.
530 procedure Check_Function_Return
;
531 -- Verify that Funtion'Result appears as one of the outputs
532 -- (SPARK RM 6.1.5(10)).
539 -- Ensure that an item fulfils its designated input and/or output role
540 -- as specified by pragma Global (if any) or the enclosing context. If
541 -- this is not the case, emit an error. Item and Item_Id denote the
542 -- attributes of an item. Flag Is_Input should be set when item comes
543 -- from an input list. Flag Self_Ref should be set when the item is an
544 -- output and the dependency clause has operator "+".
546 procedure Check_Usage
547 (Subp_Items
: Elist_Id
;
548 Used_Items
: Elist_Id
;
550 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
551 -- error if this is not the case.
553 procedure Normalize_Clause
(Clause
: Node_Id
);
554 -- Remove a self-dependency "+" from the input list of a clause
556 -----------------------------
557 -- Add_Item_To_Name_Buffer --
558 -----------------------------
560 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
562 if Ekind
(Item_Id
) = E_Abstract_State
then
563 Add_Str_To_Name_Buffer
("state");
565 elsif Ekind
(Item_Id
) = E_Constant
then
566 Add_Str_To_Name_Buffer
("constant");
568 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
569 E_Generic_In_Parameter
)
571 Add_Str_To_Name_Buffer
("generic parameter");
573 elsif Is_Formal
(Item_Id
) then
574 Add_Str_To_Name_Buffer
("parameter");
576 elsif Ekind
(Item_Id
) = E_Variable
then
577 Add_Str_To_Name_Buffer
("global");
579 -- The routine should not be called with non-SPARK items
584 end Add_Item_To_Name_Buffer
;
586 -------------------------------
587 -- Analyze_Dependency_Clause --
588 -------------------------------
590 procedure Analyze_Dependency_Clause
594 procedure Analyze_Input_List
(Inputs
: Node_Id
);
595 -- Verify the legality of a single input list
597 procedure Analyze_Input_Output
602 Seen
: in out Elist_Id
;
603 Null_Seen
: in out Boolean;
604 Non_Null_Seen
: in out Boolean);
605 -- Verify the legality of a single input or output item. Flag
606 -- Is_Input should be set whenever Item is an input, False when it
607 -- denotes an output. Flag Self_Ref should be set when the item is an
608 -- output and the dependency clause has a "+". Flag Top_Level should
609 -- be set whenever Item appears immediately within an input or output
610 -- list. Seen is a collection of all abstract states, objects and
611 -- formals processed so far. Flag Null_Seen denotes whether a null
612 -- input or output has been encountered. Flag Non_Null_Seen denotes
613 -- whether a non-null input or output has been encountered.
615 ------------------------
616 -- Analyze_Input_List --
617 ------------------------
619 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
620 Inputs_Seen
: Elist_Id
:= No_Elist
;
621 -- A list containing the entities of all inputs that appear in the
622 -- current input list.
624 Non_Null_Input_Seen
: Boolean := False;
625 Null_Input_Seen
: Boolean := False;
626 -- Flags used to check the legality of an input list
631 -- Multiple inputs appear as an aggregate
633 if Nkind
(Inputs
) = N_Aggregate
then
634 if Present
(Component_Associations
(Inputs
)) then
636 ("nested dependency relations not allowed", Inputs
);
638 elsif Present
(Expressions
(Inputs
)) then
639 Input
:= First
(Expressions
(Inputs
));
640 while Present
(Input
) loop
647 Null_Seen
=> Null_Input_Seen
,
648 Non_Null_Seen
=> Non_Null_Input_Seen
);
653 -- Syntax error, always report
656 Error_Msg_N
("malformed input dependency list", Inputs
);
659 -- Process a solitary input
668 Null_Seen
=> Null_Input_Seen
,
669 Non_Null_Seen
=> Non_Null_Input_Seen
);
672 -- Detect an illegal dependency clause of the form
676 if Null_Output_Seen
and then Null_Input_Seen
then
678 ("null dependency clause cannot have a null input list",
681 end Analyze_Input_List
;
683 --------------------------
684 -- Analyze_Input_Output --
685 --------------------------
687 procedure Analyze_Input_Output
692 Seen
: in out Elist_Id
;
693 Null_Seen
: in out Boolean;
694 Non_Null_Seen
: in out Boolean)
696 Is_Output
: constant Boolean := not Is_Input
;
701 -- Multiple input or output items appear as an aggregate
703 if Nkind
(Item
) = N_Aggregate
then
704 if not Top_Level
then
705 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
707 elsif Present
(Component_Associations
(Item
)) then
709 ("nested dependency relations not allowed", Item
);
711 -- Recursively analyze the grouped items
713 elsif Present
(Expressions
(Item
)) then
714 Grouped
:= First
(Expressions
(Item
));
715 while Present
(Grouped
) loop
718 Is_Input
=> Is_Input
,
719 Self_Ref
=> Self_Ref
,
722 Null_Seen
=> Null_Seen
,
723 Non_Null_Seen
=> Non_Null_Seen
);
728 -- Syntax error, always report
731 Error_Msg_N
("malformed dependency list", Item
);
734 -- Process attribute 'Result in the context of a dependency clause
736 elsif Is_Attribute_Result
(Item
) then
737 Non_Null_Seen
:= True;
741 -- Attribute 'Result is allowed to appear on the output side of
742 -- a dependency clause (SPARK RM 6.1.5(6)).
745 SPARK_Msg_N
("function result cannot act as input", Item
);
749 ("cannot mix null and non-null dependency items", Item
);
755 -- Detect multiple uses of null in a single dependency list or
756 -- throughout the whole relation. Verify the placement of a null
757 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
759 elsif Nkind
(Item
) = N_Null
then
762 ("multiple null dependency relations not allowed", Item
);
764 elsif Non_Null_Seen
then
766 ("cannot mix null and non-null dependency items", Item
);
774 ("null output list must be the last clause in a "
775 & "dependency relation", Item
);
777 -- Catch a useless dependence of the form:
782 ("useless dependence, null depends on itself", Item
);
790 Non_Null_Seen
:= True;
793 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
797 Resolve_State
(Item
);
799 -- Find the entity of the item. If this is a renaming, climb
800 -- the renaming chain to reach the root object. Renamings of
801 -- non-entire objects do not yield an entity (Empty).
803 Item_Id
:= Entity_Of
(Item
);
805 if Present
(Item_Id
) then
806 if Ekind_In
(Item_Id
, E_Abstract_State
,
808 E_Generic_In_Out_Parameter
,
809 E_Generic_In_Parameter
,
815 -- Ensure that the item fulfils its role as input and/or
816 -- output as specified by pragma Global or the enclosing
819 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
821 -- Detect multiple uses of the same state, variable or
822 -- formal parameter. If this is not the case, add the
823 -- item to the list of processed relations.
825 if Contains
(Seen
, Item_Id
) then
827 ("duplicate use of item &", Item
, Item_Id
);
829 Add_Item
(Item_Id
, Seen
);
832 -- Detect illegal use of an input related to a null
833 -- output. Such input items cannot appear in other
834 -- input lists (SPARK RM 6.1.5(13)).
837 and then Null_Output_Seen
838 and then Contains
(All_Inputs_Seen
, Item_Id
)
841 ("input of a null output list cannot appear in "
842 & "multiple input lists", Item
);
845 -- Add an input or a self-referential output to the list
846 -- of all processed inputs.
848 if Is_Input
or else Self_Ref
then
849 Add_Item
(Item_Id
, All_Inputs_Seen
);
852 -- State related checks (SPARK RM 6.1.5(3))
854 if Ekind
(Item_Id
) = E_Abstract_State
then
856 -- Package and subprogram bodies are instantiated
857 -- individually in a separate compiler pass. Due to
858 -- this mode of instantiation, the refinement of a
859 -- state may no longer be visible when a subprogram
860 -- body contract is instantiated. Since the generic
861 -- template is legal, do not perform this check in
862 -- the instance to circumvent this oddity.
864 if Is_Generic_Instance
(Spec_Id
) then
867 -- An abstract state with visible refinement cannot
868 -- appear in pragma [Refined_]Depends as its place
869 -- must be taken by some of its constituents
870 -- (SPARK RM 6.1.4(7)).
872 elsif Has_Visible_Refinement
(Item_Id
) then
874 ("cannot mention state & in dependence relation",
876 SPARK_Msg_N
("\use its constituents instead", Item
);
879 -- If the reference to the abstract state appears in
880 -- an enclosing package body that will eventually
881 -- refine the state, record the reference for future
885 Record_Possible_Body_Reference
886 (State_Id
=> Item_Id
,
891 -- When the item renames an entire object, replace the
892 -- item with a reference to the object.
894 if Entity
(Item
) /= Item_Id
then
896 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
900 -- Add the entity of the current item to the list of
903 if Ekind
(Item_Id
) = E_Abstract_State
then
904 Add_Item
(Item_Id
, States_Seen
);
907 if Ekind_In
(Item_Id
, E_Abstract_State
,
910 and then Present
(Encapsulating_State
(Item_Id
))
912 Add_Item
(Item_Id
, Constits_Seen
);
915 -- All other input/output items are illegal
916 -- (SPARK RM 6.1.5(1)).
920 ("item must denote parameter, variable, or state",
924 -- All other input/output items are illegal
925 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
929 ("item must denote parameter, variable, or state", Item
);
932 end Analyze_Input_Output
;
940 Non_Null_Output_Seen
: Boolean := False;
941 -- Flag used to check the legality of an output list
943 -- Start of processing for Analyze_Dependency_Clause
946 Inputs
:= Expression
(Clause
);
949 -- An input list with a self-dependency appears as operator "+" where
950 -- the actuals inputs are the right operand.
952 if Nkind
(Inputs
) = N_Op_Plus
then
953 Inputs
:= Right_Opnd
(Inputs
);
957 -- Process the output_list of a dependency_clause
959 Output
:= First
(Choices
(Clause
));
960 while Present
(Output
) loop
964 Self_Ref
=> Self_Ref
,
966 Seen
=> All_Outputs_Seen
,
967 Null_Seen
=> Null_Output_Seen
,
968 Non_Null_Seen
=> Non_Null_Output_Seen
);
973 -- Process the input_list of a dependency_clause
975 Analyze_Input_List
(Inputs
);
976 end Analyze_Dependency_Clause
;
978 ---------------------------
979 -- Check_Function_Return --
980 ---------------------------
982 procedure Check_Function_Return
is
984 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
985 and then not Result_Seen
988 ("result of & must appear in exactly one output list",
991 end Check_Function_Return
;
1004 (Item_Is_Input
: out Boolean;
1005 Item_Is_Output
: out Boolean);
1006 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1007 -- Item_Is_Output are set depending on the role.
1009 procedure Role_Error
1010 (Item_Is_Input
: Boolean;
1011 Item_Is_Output
: Boolean);
1012 -- Emit an error message concerning the incorrect use of Item in
1013 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1014 -- denote whether the item is an input and/or an output.
1021 (Item_Is_Input
: out Boolean;
1022 Item_Is_Output
: out Boolean)
1025 Item_Is_Input
:= False;
1026 Item_Is_Output
:= False;
1028 -- Abstract state cases
1030 if Ekind
(Item_Id
) = E_Abstract_State
then
1032 -- When pragma Global is present, the mode of the state may be
1033 -- further constrained by setting a more restrictive mode.
1036 if Appears_In
(Subp_Inputs
, Item_Id
) then
1037 Item_Is_Input
:= True;
1040 if Appears_In
(Subp_Outputs
, Item_Id
) then
1041 Item_Is_Output
:= True;
1044 -- Otherwise the state has a default IN OUT mode
1047 Item_Is_Input
:= True;
1048 Item_Is_Output
:= True;
1053 elsif Ekind
(Item_Id
) = E_Constant
then
1054 Item_Is_Input
:= True;
1056 -- Generic parameter cases
1058 elsif Ekind
(Item_Id
) = E_Generic_In_Parameter
then
1059 Item_Is_Input
:= True;
1061 elsif Ekind
(Item_Id
) = E_Generic_In_Out_Parameter
then
1062 Item_Is_Input
:= True;
1063 Item_Is_Output
:= True;
1067 elsif Ekind
(Item_Id
) = E_In_Parameter
then
1068 Item_Is_Input
:= True;
1070 elsif Ekind
(Item_Id
) = E_In_Out_Parameter
then
1071 Item_Is_Input
:= True;
1072 Item_Is_Output
:= True;
1074 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1075 if Scope
(Item_Id
) = Spec_Id
then
1077 -- An OUT parameter of the related subprogram has mode IN
1078 -- if its type is unconstrained or tagged because array
1079 -- bounds, discriminants or tags can be read.
1081 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1082 Item_Is_Input
:= True;
1085 Item_Is_Output
:= True;
1087 -- An OUT parameter of an enclosing subprogram behaves as a
1088 -- read-write variable in which case the mode is IN OUT.
1091 Item_Is_Input
:= True;
1092 Item_Is_Output
:= True;
1097 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1099 -- When pragma Global is present, the mode of the variable may
1100 -- be further constrained by setting a more restrictive mode.
1104 -- A variable has mode IN when its type is unconstrained or
1105 -- tagged because array bounds, discriminants or tags can be
1108 if Appears_In
(Subp_Inputs
, Item_Id
)
1109 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1111 Item_Is_Input
:= True;
1114 if Appears_In
(Subp_Outputs
, Item_Id
) then
1115 Item_Is_Output
:= True;
1118 -- Otherwise the variable has a default IN OUT mode
1121 Item_Is_Input
:= True;
1122 Item_Is_Output
:= True;
1131 procedure Role_Error
1132 (Item_Is_Input
: Boolean;
1133 Item_Is_Output
: Boolean)
1135 Error_Msg
: Name_Id
;
1140 -- When the item is not part of the input and the output set of
1141 -- the related subprogram, then it appears as extra in pragma
1142 -- [Refined_]Depends.
1144 if not Item_Is_Input
and then not Item_Is_Output
then
1145 Add_Item_To_Name_Buffer
(Item_Id
);
1146 Add_Str_To_Name_Buffer
1147 (" & cannot appear in dependence relation");
1149 Error_Msg
:= Name_Find
;
1150 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1152 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1154 ("\& is not part of the input or output set of subprogram %",
1157 -- The mode of the item and its role in pragma [Refined_]Depends
1158 -- are in conflict. Construct a detailed message explaining the
1159 -- illegality (SPARK RM 6.1.5(5-6)).
1162 if Item_Is_Input
then
1163 Add_Str_To_Name_Buffer
("read-only");
1165 Add_Str_To_Name_Buffer
("write-only");
1168 Add_Char_To_Name_Buffer
(' ');
1169 Add_Item_To_Name_Buffer
(Item_Id
);
1170 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1172 if Item_Is_Input
then
1173 Add_Str_To_Name_Buffer
("output");
1175 Add_Str_To_Name_Buffer
("input");
1178 Add_Str_To_Name_Buffer
(" in dependence relation");
1179 Error_Msg
:= Name_Find
;
1180 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1186 Item_Is_Input
: Boolean;
1187 Item_Is_Output
: Boolean;
1189 -- Start of processing for Check_Role
1192 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1197 if not Item_Is_Input
then
1198 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1201 -- Self-referential item
1204 if not Item_Is_Input
or else not Item_Is_Output
then
1205 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1210 elsif not Item_Is_Output
then
1211 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1219 procedure Check_Usage
1220 (Subp_Items
: Elist_Id
;
1221 Used_Items
: Elist_Id
;
1224 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
);
1225 -- Emit an error concerning the illegal usage of an item
1231 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
) is
1232 Error_Msg
: Name_Id
;
1239 -- Unconstrained and tagged items are not part of the explicit
1240 -- input set of the related subprogram, they do not have to be
1241 -- present in a dependence relation and should not be flagged
1242 -- (SPARK RM 6.1.5(8)).
1244 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1247 Add_Item_To_Name_Buffer
(Item_Id
);
1248 Add_Str_To_Name_Buffer
1249 (" & must appear in at least one input dependence list");
1251 Error_Msg
:= Name_Find
;
1252 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1255 -- Output case (SPARK RM 6.1.5(10))
1260 Add_Item_To_Name_Buffer
(Item_Id
);
1261 Add_Str_To_Name_Buffer
1262 (" & must appear in exactly one output dependence list");
1264 Error_Msg
:= Name_Find
;
1265 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1273 Item_Id
: Entity_Id
;
1275 -- Start of processing for Check_Usage
1278 if No
(Subp_Items
) then
1282 -- Each input or output of the subprogram must appear in a dependency
1285 Elmt
:= First_Elmt
(Subp_Items
);
1286 while Present
(Elmt
) loop
1287 Item
:= Node
(Elmt
);
1289 if Nkind
(Item
) = N_Defining_Identifier
then
1292 Item_Id
:= Entity_Of
(Item
);
1295 -- The item does not appear in a dependency
1297 if Present
(Item_Id
)
1298 and then not Contains
(Used_Items
, Item_Id
)
1300 if Is_Formal
(Item_Id
) then
1301 Usage_Error
(Item
, Item_Id
);
1303 -- States and global objects are not used properly only when
1304 -- the subprogram is subject to pragma Global.
1306 elsif Global_Seen
then
1307 Usage_Error
(Item
, Item_Id
);
1315 ----------------------
1316 -- Normalize_Clause --
1317 ----------------------
1319 procedure Normalize_Clause
(Clause
: Node_Id
) is
1320 procedure Create_Or_Modify_Clause
1326 Multiple
: Boolean);
1327 -- Create a brand new clause to represent the self-reference or
1328 -- modify the input and/or output lists of an existing clause. Output
1329 -- denotes a self-referencial output. Outputs is the output list of a
1330 -- clause. Inputs is the input list of a clause. After denotes the
1331 -- clause after which the new clause is to be inserted. Flag In_Place
1332 -- should be set when normalizing the last output of an output list.
1333 -- Flag Multiple should be set when Output comes from a list with
1336 -----------------------------
1337 -- Create_Or_Modify_Clause --
1338 -----------------------------
1340 procedure Create_Or_Modify_Clause
1348 procedure Propagate_Output
1351 -- Handle the various cases of output propagation to the input
1352 -- list. Output denotes a self-referencial output item. Inputs
1353 -- is the input list of a clause.
1355 ----------------------
1356 -- Propagate_Output --
1357 ----------------------
1359 procedure Propagate_Output
1363 function In_Input_List
1365 Inputs
: List_Id
) return Boolean;
1366 -- Determine whether a particulat item appears in the input
1367 -- list of a clause.
1373 function In_Input_List
1375 Inputs
: List_Id
) return Boolean
1380 Elmt
:= First
(Inputs
);
1381 while Present
(Elmt
) loop
1382 if Entity_Of
(Elmt
) = Item
then
1394 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1397 -- Start of processing for Propagate_Output
1400 -- The clause is of the form:
1402 -- (Output =>+ null)
1404 -- Remove null input and replace it with a copy of the output:
1406 -- (Output => Output)
1408 if Nkind
(Inputs
) = N_Null
then
1409 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1411 -- The clause is of the form:
1413 -- (Output =>+ (Input1, ..., InputN))
1415 -- Determine whether the output is not already mentioned in the
1416 -- input list and if not, add it to the list of inputs:
1418 -- (Output => (Output, Input1, ..., InputN))
1420 elsif Nkind
(Inputs
) = N_Aggregate
then
1421 Grouped
:= Expressions
(Inputs
);
1423 if not In_Input_List
1427 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1430 -- The clause is of the form:
1432 -- (Output =>+ Input)
1434 -- If the input does not mention the output, group the two
1437 -- (Output => (Output, Input))
1439 elsif Entity_Of
(Inputs
) /= Output_Id
then
1441 Make_Aggregate
(Loc
,
1442 Expressions
=> New_List
(
1443 New_Copy_Tree
(Output
),
1444 New_Copy_Tree
(Inputs
))));
1446 end Propagate_Output
;
1450 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1451 New_Clause
: Node_Id
;
1453 -- Start of processing for Create_Or_Modify_Clause
1456 -- A null output depending on itself does not require any
1459 if Nkind
(Output
) = N_Null
then
1462 -- A function result cannot depend on itself because it cannot
1463 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1465 elsif Is_Attribute_Result
(Output
) then
1466 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1470 -- When performing the transformation in place, simply add the
1471 -- output to the list of inputs (if not already there). This
1472 -- case arises when dealing with the last output of an output
1473 -- list. Perform the normalization in place to avoid generating
1474 -- a malformed tree.
1477 Propagate_Output
(Output
, Inputs
);
1479 -- A list with multiple outputs is slowly trimmed until only
1480 -- one element remains. When this happens, replace aggregate
1481 -- with the element itself.
1485 Rewrite
(Outputs
, Output
);
1491 -- Unchain the output from its output list as it will appear in
1492 -- a new clause. Note that we cannot simply rewrite the output
1493 -- as null because this will violate the semantics of pragma
1498 -- Generate a new clause of the form:
1499 -- (Output => Inputs)
1502 Make_Component_Association
(Loc
,
1503 Choices
=> New_List
(Output
),
1504 Expression
=> New_Copy_Tree
(Inputs
));
1506 -- The new clause contains replicated content that has already
1507 -- been analyzed. There is not need to reanalyze or renormalize
1510 Set_Analyzed
(New_Clause
);
1513 (Output
=> First
(Choices
(New_Clause
)),
1514 Inputs
=> Expression
(New_Clause
));
1516 Insert_After
(After
, New_Clause
);
1518 end Create_Or_Modify_Clause
;
1522 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1524 Last_Output
: Node_Id
;
1525 Next_Output
: Node_Id
;
1528 -- Start of processing for Normalize_Clause
1531 -- A self-dependency appears as operator "+". Remove the "+" from the
1532 -- tree by moving the real inputs to their proper place.
1534 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1535 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1536 Inputs
:= Expression
(Clause
);
1538 -- Multiple outputs appear as an aggregate
1540 if Nkind
(Outputs
) = N_Aggregate
then
1541 Last_Output
:= Last
(Expressions
(Outputs
));
1543 Output
:= First
(Expressions
(Outputs
));
1544 while Present
(Output
) loop
1546 -- Normalization may remove an output from its list,
1547 -- preserve the subsequent output now.
1549 Next_Output
:= Next
(Output
);
1551 Create_Or_Modify_Clause
1556 In_Place
=> Output
= Last_Output
,
1559 Output
:= Next_Output
;
1565 Create_Or_Modify_Clause
1574 end Normalize_Clause
;
1578 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1579 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1583 Last_Clause
: Node_Id
;
1584 Restore_Scope
: Boolean := False;
1586 -- Start of processing for Analyze_Depends_In_Decl_Part
1591 -- Empty dependency list
1593 if Nkind
(Deps
) = N_Null
then
1595 -- Gather all states, objects and formal parameters that the
1596 -- subprogram may depend on. These items are obtained from the
1597 -- parameter profile or pragma [Refined_]Global (if available).
1599 Collect_Subprogram_Inputs_Outputs
1600 (Subp_Id
=> Subp_Id
,
1601 Subp_Inputs
=> Subp_Inputs
,
1602 Subp_Outputs
=> Subp_Outputs
,
1603 Global_Seen
=> Global_Seen
);
1605 -- Verify that every input or output of the subprogram appear in a
1608 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1609 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1610 Check_Function_Return
;
1612 -- Dependency clauses appear as component associations of an aggregate
1614 elsif Nkind
(Deps
) = N_Aggregate
then
1616 -- Do not attempt to perform analysis of a syntactically illegal
1617 -- clause as this will lead to misleading errors.
1619 if Has_Extra_Parentheses
(Deps
) then
1623 if Present
(Component_Associations
(Deps
)) then
1624 Last_Clause
:= Last
(Component_Associations
(Deps
));
1626 -- Gather all states, objects and formal parameters that the
1627 -- subprogram may depend on. These items are obtained from the
1628 -- parameter profile or pragma [Refined_]Global (if available).
1630 Collect_Subprogram_Inputs_Outputs
1631 (Subp_Id
=> Subp_Id
,
1632 Subp_Inputs
=> Subp_Inputs
,
1633 Subp_Outputs
=> Subp_Outputs
,
1634 Global_Seen
=> Global_Seen
);
1636 -- Ensure that the formal parameters are visible when analyzing
1637 -- all clauses. This falls out of the general rule of aspects
1638 -- pertaining to subprogram declarations.
1640 if not In_Open_Scopes
(Spec_Id
) then
1641 Restore_Scope
:= True;
1642 Push_Scope
(Spec_Id
);
1644 if Is_Generic_Subprogram
(Spec_Id
) then
1645 Install_Generic_Formals
(Spec_Id
);
1647 Install_Formals
(Spec_Id
);
1651 Clause
:= First
(Component_Associations
(Deps
));
1652 while Present
(Clause
) loop
1653 Errors
:= Serious_Errors_Detected
;
1655 -- The normalization mechanism may create extra clauses that
1656 -- contain replicated input and output names. There is no need
1657 -- to reanalyze them.
1659 if not Analyzed
(Clause
) then
1660 Set_Analyzed
(Clause
);
1662 Analyze_Dependency_Clause
1664 Is_Last
=> Clause
= Last_Clause
);
1667 -- Do not normalize a clause if errors were detected (count
1668 -- of Serious_Errors has increased) because the inputs and/or
1669 -- outputs may denote illegal items. Normalization is disabled
1670 -- in ASIS mode as it alters the tree by introducing new nodes
1671 -- similar to expansion.
1673 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1674 Normalize_Clause
(Clause
);
1680 if Restore_Scope
then
1684 -- Verify that every input or output of the subprogram appear in a
1687 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1688 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1689 Check_Function_Return
;
1691 -- The dependency list is malformed. This is a syntax error, always
1695 Error_Msg_N
("malformed dependency relation", Deps
);
1699 -- The top level dependency relation is malformed. This is a syntax
1700 -- error, always report.
1703 Error_Msg_N
("malformed dependency relation", Deps
);
1707 -- Ensure that a state and a corresponding constituent do not appear
1708 -- together in pragma [Refined_]Depends.
1710 Check_State_And_Constituent_Use
1711 (States
=> States_Seen
,
1712 Constits
=> Constits_Seen
,
1714 end Analyze_Depends_In_Decl_Part
;
1716 --------------------------------------------
1717 -- Analyze_External_Property_In_Decl_Part --
1718 --------------------------------------------
1720 procedure Analyze_External_Property_In_Decl_Part
1722 Expr_Val
: out Boolean)
1724 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1725 Obj_Id
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
1726 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Next
(Arg1
));
1729 Error_Msg_Name_1
:= Pragma_Name
(N
);
1731 -- An external property pragma must apply to an effectively volatile
1732 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1733 -- The check is performed at the end of the declarative region due to a
1734 -- possible out-of-order arrangement of pragmas:
1737 -- pragma Async_Readers (Obj);
1738 -- pragma Volatile (Obj);
1740 if not Is_Effectively_Volatile
(Obj_Id
) then
1742 ("external property % must apply to a volatile object", N
);
1745 -- Ensure that the Boolean expression (if present) is static. A missing
1746 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1750 if Present
(Expr
) then
1751 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
1753 if Is_OK_Static_Expression
(Expr
) then
1754 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
1756 SPARK_Msg_N
("expression of % must be static", Expr
);
1759 end Analyze_External_Property_In_Decl_Part
;
1761 ---------------------------------
1762 -- Analyze_Global_In_Decl_Part --
1763 ---------------------------------
1765 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
1766 Subp_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
1767 Spec_Id
: constant Entity_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
1768 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1770 Constits_Seen
: Elist_Id
:= No_Elist
;
1771 -- A list containing the entities of all constituents processed so far.
1772 -- It aids in detecting illegal usage of a state and a corresponding
1773 -- constituent in pragma [Refinde_]Global.
1775 Seen
: Elist_Id
:= No_Elist
;
1776 -- A list containing the entities of all the items processed so far. It
1777 -- plays a role in detecting distinct entities.
1779 States_Seen
: Elist_Id
:= No_Elist
;
1780 -- A list containing the entities of all states processed so far. It
1781 -- helps in detecting illegal usage of a state and a corresponding
1782 -- constituent in pragma [Refined_]Global.
1784 In_Out_Seen
: Boolean := False;
1785 Input_Seen
: Boolean := False;
1786 Output_Seen
: Boolean := False;
1787 Proof_Seen
: Boolean := False;
1788 -- Flags used to verify the consistency of modes
1790 procedure Analyze_Global_List
1792 Global_Mode
: Name_Id
:= Name_Input
);
1793 -- Verify the legality of a single global list declaration. Global_Mode
1794 -- denotes the current mode in effect.
1796 -------------------------
1797 -- Analyze_Global_List --
1798 -------------------------
1800 procedure Analyze_Global_List
1802 Global_Mode
: Name_Id
:= Name_Input
)
1804 procedure Analyze_Global_Item
1806 Global_Mode
: Name_Id
);
1807 -- Verify the legality of a single global item declaration denoted by
1808 -- Item. Global_Mode denotes the current mode in effect.
1810 procedure Check_Duplicate_Mode
1812 Status
: in out Boolean);
1813 -- Flag Status denotes whether a particular mode has been seen while
1814 -- processing a global list. This routine verifies that Mode is not a
1815 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1817 procedure Check_Mode_Restriction_In_Enclosing_Context
1819 Item_Id
: Entity_Id
);
1820 -- Verify that an item of mode In_Out or Output does not appear as an
1821 -- input in the Global aspect of an enclosing subprogram. If this is
1822 -- the case, emit an error. Item and Item_Id are respectively the
1823 -- item and its entity.
1825 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
1826 -- Mode denotes either In_Out or Output. Depending on the kind of the
1827 -- related subprogram, emit an error if those two modes apply to a
1828 -- function (SPARK RM 6.1.4(10)).
1830 -------------------------
1831 -- Analyze_Global_Item --
1832 -------------------------
1834 procedure Analyze_Global_Item
1836 Global_Mode
: Name_Id
)
1838 Item_Id
: Entity_Id
;
1841 -- Detect one of the following cases
1843 -- with Global => (null, Name)
1844 -- with Global => (Name_1, null, Name_2)
1845 -- with Global => (Name, null)
1847 if Nkind
(Item
) = N_Null
then
1848 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
1853 Resolve_State
(Item
);
1855 -- Find the entity of the item. If this is a renaming, climb the
1856 -- renaming chain to reach the root object. Renamings of non-
1857 -- entire objects do not yield an entity (Empty).
1859 Item_Id
:= Entity_Of
(Item
);
1861 if Present
(Item_Id
) then
1863 -- A global item may denote a formal parameter of an enclosing
1864 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1865 -- provide a better error diagnostic.
1867 if Is_Formal
(Item_Id
) then
1868 if Scope
(Item_Id
) = Spec_Id
then
1870 ("global item cannot reference parameter of "
1871 & "subprogram &", Item
, Spec_Id
);
1875 -- A formal object may act as a global item inside a generic
1877 elsif Is_Formal_Object
(Item_Id
) then
1880 -- The only legal references are those to abstract states and
1881 -- objects (SPARK RM 6.1.4(4)).
1883 elsif not Ekind_In
(Item_Id
, E_Abstract_State
,
1888 ("global item must denote object or state", Item
);
1892 -- State related checks
1894 if Ekind
(Item_Id
) = E_Abstract_State
then
1896 -- Package and subprogram bodies are instantiated
1897 -- individually in a separate compiler pass. Due to this
1898 -- mode of instantiation, the refinement of a state may
1899 -- no longer be visible when a subprogram body contract
1900 -- is instantiated. Since the generic template is legal,
1901 -- do not perform this check in the instance to circumvent
1904 if Is_Generic_Instance
(Spec_Id
) then
1907 -- An abstract state with visible refinement cannot appear
1908 -- in pragma [Refined_]Global as its place must be taken by
1909 -- some of its constituents (SPARK RM 6.1.4(7)).
1911 elsif Has_Visible_Refinement
(Item_Id
) then
1913 ("cannot mention state & in global refinement",
1915 SPARK_Msg_N
("\use its constituents instead", Item
);
1918 -- If the reference to the abstract state appears in an
1919 -- enclosing package body that will eventually refine the
1920 -- state, record the reference for future checks.
1923 Record_Possible_Body_Reference
1924 (State_Id
=> Item_Id
,
1928 -- Constant related checks
1930 elsif Ekind
(Item_Id
) = E_Constant
then
1932 -- A constant is read-only item, therefore it cannot act as
1935 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
1937 ("constant & cannot act as output", Item
, Item_Id
);
1941 -- Variable related checks. These are only relevant when
1942 -- SPARK_Mode is on as they are not standard Ada legality
1945 elsif SPARK_Mode
= On
1946 and then Ekind
(Item_Id
) = E_Variable
1947 and then Is_Effectively_Volatile
(Item_Id
)
1949 -- An effectively volatile object cannot appear as a global
1950 -- item of a function (SPARK RM 7.1.3(9)).
1952 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
1954 ("volatile object & cannot act as global item of a "
1955 & "function", Item
, Item_Id
);
1958 -- An effectively volatile object with external property
1959 -- Effective_Reads set to True must have mode Output or
1960 -- In_Out (SPARK RM 7.1.3(11)).
1962 elsif Effective_Reads_Enabled
(Item_Id
)
1963 and then Global_Mode
= Name_Input
1966 ("volatile object & with property Effective_Reads must "
1967 & "have mode In_Out or Output", Item
, Item_Id
);
1972 -- When the item renames an entire object, replace the item
1973 -- with a reference to the object.
1975 if Entity
(Item
) /= Item_Id
then
1976 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1980 -- Some form of illegal construct masquerading as a name
1981 -- (SPARK RM 6.1.4(4)).
1984 Error_Msg_N
("global item must denote object or state", Item
);
1988 -- Verify that an output does not appear as an input in an
1989 -- enclosing subprogram.
1991 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
1992 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
1995 -- The same entity might be referenced through various way.
1996 -- Check the entity of the item rather than the item itself
1997 -- (SPARK RM 6.1.4(10)).
1999 if Contains
(Seen
, Item_Id
) then
2000 SPARK_Msg_N
("duplicate global item", Item
);
2002 -- Add the entity of the current item to the list of processed
2006 Add_Item
(Item_Id
, Seen
);
2008 if Ekind
(Item_Id
) = E_Abstract_State
then
2009 Add_Item
(Item_Id
, States_Seen
);
2012 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
2013 and then Present
(Encapsulating_State
(Item_Id
))
2015 Add_Item
(Item_Id
, Constits_Seen
);
2018 end Analyze_Global_Item
;
2020 --------------------------
2021 -- Check_Duplicate_Mode --
2022 --------------------------
2024 procedure Check_Duplicate_Mode
2026 Status
: in out Boolean)
2030 SPARK_Msg_N
("duplicate global mode", Mode
);
2034 end Check_Duplicate_Mode
;
2036 -------------------------------------------------
2037 -- Check_Mode_Restriction_In_Enclosing_Context --
2038 -------------------------------------------------
2040 procedure Check_Mode_Restriction_In_Enclosing_Context
2042 Item_Id
: Entity_Id
)
2044 Context
: Entity_Id
;
2046 Inputs
: Elist_Id
:= No_Elist
;
2047 Outputs
: Elist_Id
:= No_Elist
;
2050 -- Traverse the scope stack looking for enclosing subprograms
2051 -- subject to pragma [Refined_]Global.
2053 Context
:= Scope
(Subp_Id
);
2054 while Present
(Context
) and then Context
/= Standard_Standard
loop
2055 if Is_Subprogram
(Context
)
2057 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2059 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2061 Collect_Subprogram_Inputs_Outputs
2062 (Subp_Id
=> Context
,
2063 Subp_Inputs
=> Inputs
,
2064 Subp_Outputs
=> Outputs
,
2065 Global_Seen
=> Dummy
);
2067 -- The item is classified as In_Out or Output but appears as
2068 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2070 if Appears_In
(Inputs
, Item_Id
)
2071 and then not Appears_In
(Outputs
, Item_Id
)
2074 ("global item & cannot have mode In_Out or Output",
2077 ("\item already appears as input of subprogram &",
2080 -- Stop the traversal once an error has been detected
2086 Context
:= Scope
(Context
);
2088 end Check_Mode_Restriction_In_Enclosing_Context
;
2090 ----------------------------------------
2091 -- Check_Mode_Restriction_In_Function --
2092 ----------------------------------------
2094 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2096 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2098 ("global mode & is not applicable to functions", Mode
);
2100 end Check_Mode_Restriction_In_Function
;
2108 -- Start of processing for Analyze_Global_List
2111 if Nkind
(List
) = N_Null
then
2112 Set_Analyzed
(List
);
2114 -- Single global item declaration
2116 elsif Nkind_In
(List
, N_Expanded_Name
,
2118 N_Selected_Component
)
2120 Analyze_Global_Item
(List
, Global_Mode
);
2122 -- Simple global list or moded global list declaration
2124 elsif Nkind
(List
) = N_Aggregate
then
2125 Set_Analyzed
(List
);
2127 -- The declaration of a simple global list appear as a collection
2130 if Present
(Expressions
(List
)) then
2131 if Present
(Component_Associations
(List
)) then
2133 ("cannot mix moded and non-moded global lists", List
);
2136 Item
:= First
(Expressions
(List
));
2137 while Present
(Item
) loop
2138 Analyze_Global_Item
(Item
, Global_Mode
);
2142 -- The declaration of a moded global list appears as a collection
2143 -- of component associations where individual choices denote
2146 elsif Present
(Component_Associations
(List
)) then
2147 if Present
(Expressions
(List
)) then
2149 ("cannot mix moded and non-moded global lists", List
);
2152 Assoc
:= First
(Component_Associations
(List
));
2153 while Present
(Assoc
) loop
2154 Mode
:= First
(Choices
(Assoc
));
2156 if Nkind
(Mode
) = N_Identifier
then
2157 if Chars
(Mode
) = Name_In_Out
then
2158 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2159 Check_Mode_Restriction_In_Function
(Mode
);
2161 elsif Chars
(Mode
) = Name_Input
then
2162 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2164 elsif Chars
(Mode
) = Name_Output
then
2165 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2166 Check_Mode_Restriction_In_Function
(Mode
);
2168 elsif Chars
(Mode
) = Name_Proof_In
then
2169 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2172 SPARK_Msg_N
("invalid mode selector", Mode
);
2176 SPARK_Msg_N
("invalid mode selector", Mode
);
2179 -- Items in a moded list appear as a collection of
2180 -- expressions. Reuse the existing machinery to analyze
2184 (List
=> Expression
(Assoc
),
2185 Global_Mode
=> Chars
(Mode
));
2193 raise Program_Error
;
2196 -- Any other attempt to declare a global item is illegal. This is a
2197 -- syntax error, always report.
2200 Error_Msg_N
("malformed global list", List
);
2202 end Analyze_Global_List
;
2206 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2208 Restore_Scope
: Boolean := False;
2210 -- Start of processing for Analyze_Global_In_Decl_Part
2215 -- There is nothing to be done for a null global list
2217 if Nkind
(Items
) = N_Null
then
2218 Set_Analyzed
(Items
);
2220 -- Analyze the various forms of global lists and items. Note that some
2221 -- of these may be malformed in which case the analysis emits error
2225 -- Ensure that the formal parameters are visible when processing an
2226 -- item. This falls out of the general rule of aspects pertaining to
2227 -- subprogram declarations.
2229 if not In_Open_Scopes
(Spec_Id
) then
2230 Restore_Scope
:= True;
2231 Push_Scope
(Spec_Id
);
2233 if Is_Generic_Subprogram
(Spec_Id
) then
2234 Install_Generic_Formals
(Spec_Id
);
2236 Install_Formals
(Spec_Id
);
2240 Analyze_Global_List
(Items
);
2242 if Restore_Scope
then
2247 -- Ensure that a state and a corresponding constituent do not appear
2248 -- together in pragma [Refined_]Global.
2250 Check_State_And_Constituent_Use
2251 (States
=> States_Seen
,
2252 Constits
=> Constits_Seen
,
2254 end Analyze_Global_In_Decl_Part
;
2256 --------------------------------------------
2257 -- Analyze_Initial_Condition_In_Decl_Part --
2258 --------------------------------------------
2260 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2261 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2262 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2263 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2268 -- The expression is preanalyzed because it has not been moved to its
2269 -- final place yet. A direct analysis may generate side effects and this
2270 -- is not desired at this point.
2272 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2273 end Analyze_Initial_Condition_In_Decl_Part
;
2275 --------------------------------------
2276 -- Analyze_Initializes_In_Decl_Part --
2277 --------------------------------------
2279 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2280 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2281 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2283 Constits_Seen
: Elist_Id
:= No_Elist
;
2284 -- A list containing the entities of all constituents processed so far.
2285 -- It aids in detecting illegal usage of a state and a corresponding
2286 -- constituent in pragma Initializes.
2288 Items_Seen
: Elist_Id
:= No_Elist
;
2289 -- A list of all initialization items processed so far. This list is
2290 -- used to detect duplicate items.
2292 Non_Null_Seen
: Boolean := False;
2293 Null_Seen
: Boolean := False;
2294 -- Flags used to check the legality of a null initialization list
2296 States_And_Objs
: Elist_Id
:= No_Elist
;
2297 -- A list of all abstract states and objects declared in the visible
2298 -- declarations of the related package. This list is used to detect the
2299 -- legality of initialization items.
2301 States_Seen
: Elist_Id
:= No_Elist
;
2302 -- A list containing the entities of all states processed so far. It
2303 -- helps in detecting illegal usage of a state and a corresponding
2304 -- constituent in pragma Initializes.
2306 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2307 -- Verify the legality of a single initialization item
2309 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2310 -- Verify the legality of a single initialization item followed by a
2311 -- list of input items.
2313 procedure Collect_States_And_Objects
;
2314 -- Inspect the visible declarations of the related package and gather
2315 -- the entities of all abstract states and objects in States_And_Objs.
2317 ---------------------------------
2318 -- Analyze_Initialization_Item --
2319 ---------------------------------
2321 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2322 Item_Id
: Entity_Id
;
2325 -- Null initialization list
2327 if Nkind
(Item
) = N_Null
then
2329 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2331 elsif Non_Null_Seen
then
2333 ("cannot mix null and non-null initialization items", Item
);
2338 -- Initialization item
2341 Non_Null_Seen
:= True;
2345 ("cannot mix null and non-null initialization items", Item
);
2349 Resolve_State
(Item
);
2351 if Is_Entity_Name
(Item
) then
2352 Item_Id
:= Entity_Of
(Item
);
2354 if Ekind_In
(Item_Id
, E_Abstract_State
,
2358 -- The state or variable must be declared in the visible
2359 -- declarations of the package (SPARK RM 7.1.5(7)).
2361 if not Contains
(States_And_Objs
, Item_Id
) then
2362 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2364 ("initialization item & must appear in the visible "
2365 & "declarations of package %", Item
, Item_Id
);
2367 -- Detect a duplicate use of the same initialization item
2368 -- (SPARK RM 7.1.5(5)).
2370 elsif Contains
(Items_Seen
, Item_Id
) then
2371 SPARK_Msg_N
("duplicate initialization item", Item
);
2373 -- The item is legal, add it to the list of processed states
2377 Add_Item
(Item_Id
, Items_Seen
);
2379 if Ekind
(Item_Id
) = E_Abstract_State
then
2380 Add_Item
(Item_Id
, States_Seen
);
2383 if Present
(Encapsulating_State
(Item_Id
)) then
2384 Add_Item
(Item_Id
, Constits_Seen
);
2388 -- The item references something that is not a state or object
2389 -- (SPARK RM 7.1.5(3)).
2393 ("initialization item must denote object or state", Item
);
2396 -- Some form of illegal construct masquerading as a name
2397 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2401 ("initialization item must denote object or state", Item
);
2404 end Analyze_Initialization_Item
;
2406 ---------------------------------------------
2407 -- Analyze_Initialization_Item_With_Inputs --
2408 ---------------------------------------------
2410 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2411 Inputs_Seen
: Elist_Id
:= No_Elist
;
2412 -- A list of all inputs processed so far. This list is used to detect
2413 -- duplicate uses of an input.
2415 Non_Null_Seen
: Boolean := False;
2416 Null_Seen
: Boolean := False;
2417 -- Flags used to check the legality of an input list
2419 procedure Analyze_Input_Item
(Input
: Node_Id
);
2420 -- Verify the legality of a single input item
2422 ------------------------
2423 -- Analyze_Input_Item --
2424 ------------------------
2426 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2427 Input_Id
: Entity_Id
;
2432 if Nkind
(Input
) = N_Null
then
2435 ("multiple null initializations not allowed", Item
);
2437 elsif Non_Null_Seen
then
2439 ("cannot mix null and non-null initialization item", Item
);
2447 Non_Null_Seen
:= True;
2451 ("cannot mix null and non-null initialization item", Item
);
2455 Resolve_State
(Input
);
2457 if Is_Entity_Name
(Input
) then
2458 Input_Id
:= Entity_Of
(Input
);
2460 if Ekind_In
(Input_Id
, E_Abstract_State
,
2467 -- The input cannot denote states or objects declared
2468 -- within the related package (SPARK RM 7.1.5(4)).
2470 if Within_Scope
(Input_Id
, Current_Scope
) then
2471 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2473 ("input item & cannot denote a visible object or "
2474 & "state of package %", Input
, Input_Id
);
2476 -- Detect a duplicate use of the same input item
2477 -- (SPARK RM 7.1.5(5)).
2479 elsif Contains
(Inputs_Seen
, Input_Id
) then
2480 SPARK_Msg_N
("duplicate input item", Input
);
2482 -- Input is legal, add it to the list of processed inputs
2485 Add_Item
(Input_Id
, Inputs_Seen
);
2487 if Ekind
(Input_Id
) = E_Abstract_State
then
2488 Add_Item
(Input_Id
, States_Seen
);
2491 if Ekind_In
(Input_Id
, E_Abstract_State
,
2494 and then Present
(Encapsulating_State
(Input_Id
))
2496 Add_Item
(Input_Id
, Constits_Seen
);
2500 -- The input references something that is not a state or an
2501 -- object (SPARK RM 7.1.5(3)).
2505 ("input item must denote object or state", Input
);
2508 -- Some form of illegal construct masquerading as a name
2509 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2513 ("input item must denote object or state", Input
);
2516 end Analyze_Input_Item
;
2520 Inputs
: constant Node_Id
:= Expression
(Item
);
2524 Name_Seen
: Boolean := False;
2525 -- A flag used to detect multiple item names
2527 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2530 -- Inspect the name of an item with inputs
2532 Elmt
:= First
(Choices
(Item
));
2533 while Present
(Elmt
) loop
2535 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
2538 Analyze_Initialization_Item
(Elmt
);
2544 -- Multiple input items appear as an aggregate
2546 if Nkind
(Inputs
) = N_Aggregate
then
2547 if Present
(Expressions
(Inputs
)) then
2548 Input
:= First
(Expressions
(Inputs
));
2549 while Present
(Input
) loop
2550 Analyze_Input_Item
(Input
);
2555 if Present
(Component_Associations
(Inputs
)) then
2557 ("inputs must appear in named association form", Inputs
);
2560 -- Single input item
2563 Analyze_Input_Item
(Inputs
);
2565 end Analyze_Initialization_Item_With_Inputs
;
2567 --------------------------------
2568 -- Collect_States_And_Objects --
2569 --------------------------------
2571 procedure Collect_States_And_Objects
is
2572 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
2576 -- Collect the abstract states defined in the package (if any)
2578 if Present
(Abstract_States
(Pack_Id
)) then
2579 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
2582 -- Collect all objects the appear in the visible declarations of the
2585 if Present
(Visible_Declarations
(Pack_Spec
)) then
2586 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
2587 while Present
(Decl
) loop
2588 if Comes_From_Source
(Decl
)
2589 and then Nkind
(Decl
) = N_Object_Declaration
2591 Add_Item
(Defining_Entity
(Decl
), States_And_Objs
);
2597 end Collect_States_And_Objects
;
2601 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2604 -- Start of processing for Analyze_Initializes_In_Decl_Part
2609 -- Nothing to do when the initialization list is empty
2611 if Nkind
(Inits
) = N_Null
then
2615 -- Single and multiple initialization clauses appear as an aggregate. If
2616 -- this is not the case, then either the parser or the analysis of the
2617 -- pragma failed to produce an aggregate.
2619 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
2621 -- Initialize the various lists used during analysis
2623 Collect_States_And_Objects
;
2625 if Present
(Expressions
(Inits
)) then
2626 Init
:= First
(Expressions
(Inits
));
2627 while Present
(Init
) loop
2628 Analyze_Initialization_Item
(Init
);
2633 if Present
(Component_Associations
(Inits
)) then
2634 Init
:= First
(Component_Associations
(Inits
));
2635 while Present
(Init
) loop
2636 Analyze_Initialization_Item_With_Inputs
(Init
);
2641 -- Ensure that a state and a corresponding constituent do not appear
2642 -- together in pragma Initializes.
2644 Check_State_And_Constituent_Use
2645 (States
=> States_Seen
,
2646 Constits
=> Constits_Seen
,
2648 end Analyze_Initializes_In_Decl_Part
;
2650 --------------------
2651 -- Analyze_Pragma --
2652 --------------------
2654 procedure Analyze_Pragma
(N
: Node_Id
) is
2655 Loc
: constant Source_Ptr
:= Sloc
(N
);
2656 Prag_Id
: Pragma_Id
;
2659 -- Name of the source pragma, or name of the corresponding aspect for
2660 -- pragmas which originate in a source aspect. In the latter case, the
2661 -- name may be different from the pragma name.
2663 Pragma_Exit
: exception;
2664 -- This exception is used to exit pragma processing completely. It
2665 -- is used when an error is detected, and no further processing is
2666 -- required. It is also used if an earlier error has left the tree in
2667 -- a state where the pragma should not be processed.
2670 -- Number of pragma argument associations
2676 -- First four pragma arguments (pragma argument association nodes, or
2677 -- Empty if the corresponding argument does not exist).
2679 type Name_List
is array (Natural range <>) of Name_Id
;
2680 type Args_List
is array (Natural range <>) of Node_Id
;
2681 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2683 -----------------------
2684 -- Local Subprograms --
2685 -----------------------
2687 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
2688 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
2689 -- get the given string argument, and place it in Name_Buffer, adding
2690 -- leading and trailing asterisks if they are not already present. The
2691 -- caller has already checked that Arg is a static string expression.
2693 procedure Ada_2005_Pragma
;
2694 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2695 -- Ada 95 mode, these are implementation defined pragmas, so should be
2696 -- caught by the No_Implementation_Pragmas restriction.
2698 procedure Ada_2012_Pragma
;
2699 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2700 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2701 -- should be caught by the No_Implementation_Pragmas restriction.
2703 procedure Analyze_Depends_Global
;
2704 -- Subsidiary to the analysis of pragma Depends and Global
2706 procedure Analyze_Part_Of
2707 (Item_Id
: Entity_Id
;
2710 Legal
: out Boolean);
2711 -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of.
2712 -- Perform full analysis of indicator Part_Of. Item_Id is the entity of
2713 -- an abstract state, object, or package instantiation. State is the
2714 -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is
2715 -- set when the indicator is legal.
2717 procedure Analyze_Pre_Post_Condition
;
2718 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
2720 procedure Analyze_Refined_Depends_Global_Post
2721 (Spec_Id
: out Entity_Id
;
2722 Body_Id
: out Entity_Id
;
2723 Legal
: out Boolean);
2724 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2725 -- Refined_Global and Refined_Post. Check the placement and related
2726 -- context of the pragma. Spec_Id is the entity of the related
2727 -- subprogram. Body_Id is the entity of the subprogram body. Flag
2728 -- Legal is set when the pragma is properly placed.
2730 procedure Check_Ada_83_Warning
;
2731 -- Issues a warning message for the current pragma if operating in Ada
2732 -- 83 mode (used for language pragmas that are not a standard part of
2733 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
2736 procedure Check_Arg_Count
(Required
: Nat
);
2737 -- Check argument count for pragma is equal to given parameter. If not,
2738 -- then issue an error message and raise Pragma_Exit.
2740 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2741 -- Arg which can either be a pragma argument association, in which case
2742 -- the check is applied to the expression of the association or an
2743 -- expression directly.
2745 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
2746 -- Check that an argument has the right form for an EXTERNAL_NAME
2747 -- parameter of an extended import/export pragma. The rule is that the
2748 -- name must be an identifier or string literal (in Ada 83 mode) or a
2749 -- static string expression (in Ada 95 mode).
2751 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
2752 -- Check the specified argument Arg to make sure that it is an
2753 -- identifier. If not give error and raise Pragma_Exit.
2755 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
2756 -- Check the specified argument Arg to make sure that it is an integer
2757 -- literal. If not give error and raise Pragma_Exit.
2759 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
2760 -- Check the specified argument Arg to make sure that it has the proper
2761 -- syntactic form for a local name and meets the semantic requirements
2762 -- for a local name. The local name is analyzed as part of the
2763 -- processing for this call. In addition, the local name is required
2764 -- to represent an entity at the library level.
2766 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
2767 -- Check the specified argument Arg to make sure that it has the proper
2768 -- syntactic form for a local name and meets the semantic requirements
2769 -- for a local name. The local name is analyzed as part of the
2770 -- processing for this call.
2772 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
2773 -- Check the specified argument Arg to make sure that it is a valid
2774 -- locking policy name. If not give error and raise Pragma_Exit.
2776 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
2777 -- Check the specified argument Arg to make sure that it is a valid
2778 -- elaboration policy name. If not give error and raise Pragma_Exit.
2780 procedure Check_Arg_Is_One_Of
2783 procedure Check_Arg_Is_One_Of
2785 N1
, N2
, N3
: Name_Id
);
2786 procedure Check_Arg_Is_One_Of
2788 N1
, N2
, N3
, N4
: Name_Id
);
2789 procedure Check_Arg_Is_One_Of
2791 N1
, N2
, N3
, N4
, N5
: Name_Id
);
2792 -- Check the specified argument Arg to make sure that it is an
2793 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2794 -- present). If not then give error and raise Pragma_Exit.
2796 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
2797 -- Check the specified argument Arg to make sure that it is a valid
2798 -- queuing policy name. If not give error and raise Pragma_Exit.
2800 procedure Check_Arg_Is_OK_Static_Expression
2802 Typ
: Entity_Id
:= Empty
);
2803 -- Check the specified argument Arg to make sure that it is a static
2804 -- expression of the given type (i.e. it will be analyzed and resolved
2805 -- using this type, which can be any valid argument to Resolve, e.g.
2806 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2807 -- Typ is left Empty, then any static expression is allowed. Includes
2808 -- checking that the argument does not raise Constraint_Error.
2810 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
2811 -- Check the specified argument Arg to make sure that it is a valid task
2812 -- dispatching policy name. If not give error and raise Pragma_Exit.
2814 procedure Check_Arg_Order
(Names
: Name_List
);
2815 -- Checks for an instance of two arguments with identifiers for the
2816 -- current pragma which are not in the sequence indicated by Names,
2817 -- and if so, generates a fatal message about bad order of arguments.
2819 procedure Check_At_Least_N_Arguments
(N
: Nat
);
2820 -- Check there are at least N arguments present
2822 procedure Check_At_Most_N_Arguments
(N
: Nat
);
2823 -- Check there are no more than N arguments present
2825 procedure Check_Component
2828 In_Variant_Part
: Boolean := False);
2829 -- Examine an Unchecked_Union component for correct use of per-object
2830 -- constrained subtypes, and for restrictions on finalizable components.
2831 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2832 -- should be set when Comp comes from a record variant.
2834 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
);
2835 -- Subsidiary routine to the analysis of pragmas Abstract_State,
2836 -- Initial_Condition and Initializes. Determine whether pragma First
2837 -- appears before pragma Second. If this is not the case, emit an error.
2839 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
2840 -- Check if a rep item of the same name as the current pragma is already
2841 -- chained as a rep pragma to the given entity. If so give a message
2842 -- about the duplicate, and then raise Pragma_Exit so does not return.
2843 -- Note that if E is a type, then this routine avoids flagging a pragma
2844 -- which applies to a parent type from which E is derived.
2846 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
2847 -- Nam is an N_String_Literal node containing the external name set by
2848 -- an Import or Export pragma (or extended Import or Export pragma).
2849 -- This procedure checks for possible duplications if this is the export
2850 -- case, and if found, issues an appropriate error message.
2852 procedure Check_Expr_Is_OK_Static_Expression
2854 Typ
: Entity_Id
:= Empty
);
2855 -- Check the specified expression Expr to make sure that it is a static
2856 -- expression of the given type (i.e. it will be analyzed and resolved
2857 -- using this type, which can be any valid argument to Resolve, e.g.
2858 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2859 -- Typ is left Empty, then any static expression is allowed. Includes
2860 -- checking that the expression does not raise Constraint_Error.
2862 procedure Check_First_Subtype
(Arg
: Node_Id
);
2863 -- Checks that Arg, whose expression is an entity name, references a
2866 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2867 -- Checks that the given argument has an identifier, and if so, requires
2868 -- it to match the given identifier name. If there is no identifier, or
2869 -- a non-matching identifier, then an error message is given and
2870 -- Pragma_Exit is raised.
2872 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
2873 -- Checks that the given argument has an identifier, and if so, requires
2874 -- it to match one of the given identifier names. If there is no
2875 -- identifier, or a non-matching identifier, then an error message is
2876 -- given and Pragma_Exit is raised.
2878 procedure Check_In_Main_Program
;
2879 -- Common checks for pragmas that appear within a main program
2880 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2882 procedure Check_Interrupt_Or_Attach_Handler
;
2883 -- Common processing for first argument of pragma Interrupt_Handler or
2884 -- pragma Attach_Handler.
2886 procedure Check_Loop_Pragma_Placement
;
2887 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
2888 -- appear immediately within a construct restricted to loops, and that
2889 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
2891 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
2892 -- Check that pragma appears in a declarative part, or in a package
2893 -- specification, i.e. that it does not occur in a statement sequence
2896 procedure Check_No_Identifier
(Arg
: Node_Id
);
2897 -- Checks that the given argument does not have an identifier. If
2898 -- an identifier is present, then an error message is issued, and
2899 -- Pragma_Exit is raised.
2901 procedure Check_No_Identifiers
;
2902 -- Checks that none of the arguments to the pragma has an identifier.
2903 -- If any argument has an identifier, then an error message is issued,
2904 -- and Pragma_Exit is raised.
2906 procedure Check_No_Link_Name
;
2907 -- Checks that no link name is specified
2909 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2910 -- Checks if the given argument has an identifier, and if so, requires
2911 -- it to match the given identifier name. If there is a non-matching
2912 -- identifier, then an error message is given and Pragma_Exit is raised.
2914 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
2915 -- Checks if the given argument has an identifier, and if so, requires
2916 -- it to match the given identifier name. If there is a non-matching
2917 -- identifier, then an error message is given and Pragma_Exit is raised.
2918 -- In this version of the procedure, the identifier name is given as
2919 -- a string with lower case letters.
2921 procedure Check_Static_Constraint
(Constr
: Node_Id
);
2922 -- Constr is a constraint from an N_Subtype_Indication node from a
2923 -- component constraint in an Unchecked_Union type. This routine checks
2924 -- that the constraint is static as required by the restrictions for
2927 procedure Check_Valid_Configuration_Pragma
;
2928 -- Legality checks for placement of a configuration pragma
2930 procedure Check_Valid_Library_Unit_Pragma
;
2931 -- Legality checks for library unit pragmas. A special case arises for
2932 -- pragmas in generic instances that come from copies of the original
2933 -- library unit pragmas in the generic templates. In the case of other
2934 -- than library level instantiations these can appear in contexts which
2935 -- would normally be invalid (they only apply to the original template
2936 -- and to library level instantiations), and they are simply ignored,
2937 -- which is implemented by rewriting them as null statements.
2939 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
2940 -- Check an Unchecked_Union variant for lack of nested variants and
2941 -- presence of at least one component. UU_Typ is the related Unchecked_
2944 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
2945 -- Subsidiary routine to the processing of pragmas Abstract_State,
2946 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
2947 -- Refined_Global and Refined_State. Transform argument Arg into
2948 -- an aggregate if not one already. N_Null is never transformed.
2949 -- Arg may denote an aspect specification or a pragma argument
2952 procedure Error_Pragma
(Msg
: String);
2953 pragma No_Return
(Error_Pragma
);
2954 -- Outputs error message for current pragma. The message contains a %
2955 -- that will be replaced with the pragma name, and the flag is placed
2956 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
2957 -- calls Fix_Error (see spec of that procedure for details).
2959 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
2960 pragma No_Return
(Error_Pragma_Arg
);
2961 -- Outputs error message for current pragma. The message may contain
2962 -- a % that will be replaced with the pragma name. The parameter Arg
2963 -- may either be a pragma argument association, in which case the flag
2964 -- is placed on the expression of this association, or an expression,
2965 -- in which case the flag is placed directly on the expression. The
2966 -- message is placed using Error_Msg_N, so the message may also contain
2967 -- an & insertion character which will reference the given Arg value.
2968 -- After placing the message, Pragma_Exit is raised. Note: this routine
2969 -- calls Fix_Error (see spec of that procedure for details).
2971 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
2972 pragma No_Return
(Error_Pragma_Arg
);
2973 -- Similar to above form of Error_Pragma_Arg except that two messages
2974 -- are provided, the second is a continuation comment starting with \.
2976 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
2977 pragma No_Return
(Error_Pragma_Arg_Ident
);
2978 -- Outputs error message for current pragma. The message may contain a %
2979 -- that will be replaced with the pragma name. The parameter Arg must be
2980 -- a pragma argument association with a non-empty identifier (i.e. its
2981 -- Chars field must be set), and the error message is placed on the
2982 -- identifier. The message is placed using Error_Msg_N so the message
2983 -- may also contain an & insertion character which will reference
2984 -- the identifier. After placing the message, Pragma_Exit is raised.
2985 -- Note: this routine calls Fix_Error (see spec of that procedure for
2988 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
2989 pragma No_Return
(Error_Pragma_Ref
);
2990 -- Outputs error message for current pragma. The message may contain
2991 -- a % that will be replaced with the pragma name. The parameter Ref
2992 -- must be an entity whose name can be referenced by & and sloc by #.
2993 -- After placing the message, Pragma_Exit is raised. Note: this routine
2994 -- calls Fix_Error (see spec of that procedure for details).
2996 function Find_Lib_Unit_Name
return Entity_Id
;
2997 -- Used for a library unit pragma to find the entity to which the
2998 -- library unit pragma applies, returns the entity found.
3000 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3001 -- If the pragma is a compilation unit pragma, the id must denote the
3002 -- compilation unit in the same compilation, and the pragma must appear
3003 -- in the list of preceding or trailing pragmas. If it is a program
3004 -- unit pragma that is not a compilation unit pragma, then the
3005 -- identifier must be visible.
3007 function Find_Unique_Parameterless_Procedure
3009 Arg
: Node_Id
) return Entity_Id
;
3010 -- Used for a procedure pragma to find the unique parameterless
3011 -- procedure identified by Name, returns it if it exists, otherwise
3012 -- errors out and uses Arg as the pragma argument for the message.
3014 function Fix_Error
(Msg
: String) return String;
3015 -- This is called prior to issuing an error message. Msg is the normal
3016 -- error message issued in the pragma case. This routine checks for the
3017 -- case of a pragma coming from an aspect in the source, and returns a
3018 -- message suitable for the aspect case as follows:
3020 -- Each substring "pragma" is replaced by "aspect"
3022 -- If "argument of" is at the start of the error message text, it is
3023 -- replaced by "entity for".
3025 -- If "argument" is at the start of the error message text, it is
3026 -- replaced by "entity".
3028 -- So for example, "argument of pragma X must be discrete type"
3029 -- returns "entity for aspect X must be a discrete type".
3031 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3032 -- be different from the pragma name). If the current pragma results
3033 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3034 -- original pragma name.
3036 procedure Gather_Associations
3038 Args
: out Args_List
);
3039 -- This procedure is used to gather the arguments for a pragma that
3040 -- permits arbitrary ordering of parameters using the normal rules
3041 -- for named and positional parameters. The Names argument is a list
3042 -- of Name_Id values that corresponds to the allowed pragma argument
3043 -- association identifiers in order. The result returned in Args is
3044 -- a list of corresponding expressions that are the pragma arguments.
3045 -- Note that this is a list of expressions, not of pragma argument
3046 -- associations (Gather_Associations has completely checked all the
3047 -- optional identifiers when it returns). An entry in Args is Empty
3048 -- on return if the corresponding argument is not present.
3050 procedure GNAT_Pragma
;
3051 -- Called for all GNAT defined pragmas to check the relevant restriction
3052 -- (No_Implementation_Pragmas).
3054 function Is_Before_First_Decl
3055 (Pragma_Node
: Node_Id
;
3056 Decls
: List_Id
) return Boolean;
3057 -- Return True if Pragma_Node is before the first declarative item in
3058 -- Decls where Decls is the list of declarative items.
3060 function Is_Configuration_Pragma
return Boolean;
3061 -- Determines if the placement of the current pragma is appropriate
3062 -- for a configuration pragma.
3064 function Is_In_Context_Clause
return Boolean;
3065 -- Returns True if pragma appears within the context clause of a unit,
3066 -- and False for any other placement (does not generate any messages).
3068 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3069 -- Analyzes the argument, and determines if it is a static string
3070 -- expression, returns True if so, False if non-static or not String.
3071 -- A special case is that a string literal returns True in Ada 83 mode
3072 -- (which has no such thing as static string expressions). Note that
3073 -- the call analyzes its argument, so this cannot be used for the case
3074 -- where an identifier might not be declared.
3076 procedure Pragma_Misplaced
;
3077 pragma No_Return
(Pragma_Misplaced
);
3078 -- Issue fatal error message for misplaced pragma
3080 procedure Process_Atomic_Independent_Shared_Volatile
;
3081 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3082 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3083 -- and treated as being identical in effect to pragma Atomic.
3085 procedure Process_Compile_Time_Warning_Or_Error
;
3086 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3088 procedure Process_Convention
3089 (C
: out Convention_Id
;
3090 Ent
: out Entity_Id
);
3091 -- Common processing for Convention, Interface, Import and Export.
3092 -- Checks first two arguments of pragma, and sets the appropriate
3093 -- convention value in the specified entity or entities. On return
3094 -- C is the convention, Ent is the referenced entity.
3096 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3097 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3098 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3100 procedure Process_Extended_Import_Export_Object_Pragma
3101 (Arg_Internal
: Node_Id
;
3102 Arg_External
: Node_Id
;
3103 Arg_Size
: Node_Id
);
3104 -- Common processing for the pragmas Import/Export_Object. The three
3105 -- arguments correspond to the three named parameters of the pragmas. An
3106 -- argument is empty if the corresponding parameter is not present in
3109 procedure Process_Extended_Import_Export_Internal_Arg
3110 (Arg_Internal
: Node_Id
:= Empty
);
3111 -- Common processing for all extended Import and Export pragmas. The
3112 -- argument is the pragma parameter for the Internal argument. If
3113 -- Arg_Internal is empty or inappropriate, an error message is posted.
3114 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3115 -- set to identify the referenced entity.
3117 procedure Process_Extended_Import_Export_Subprogram_Pragma
3118 (Arg_Internal
: Node_Id
;
3119 Arg_External
: Node_Id
;
3120 Arg_Parameter_Types
: Node_Id
;
3121 Arg_Result_Type
: Node_Id
:= Empty
;
3122 Arg_Mechanism
: Node_Id
;
3123 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3124 -- Common processing for all extended Import and Export pragmas applying
3125 -- to subprograms. The caller omits any arguments that do not apply to
3126 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3127 -- only in the Import_Function and Export_Function cases). The argument
3128 -- names correspond to the allowed pragma association identifiers.
3130 procedure Process_Generic_List
;
3131 -- Common processing for Share_Generic and Inline_Generic
3133 procedure Process_Import_Or_Interface
;
3134 -- Common processing for Import or Interface
3136 procedure Process_Import_Predefined_Type
;
3137 -- Processing for completing a type with pragma Import. This is used
3138 -- to declare types that match predefined C types, especially for cases
3139 -- without corresponding Ada predefined type.
3141 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3142 -- Inline status of a subprogram, indicated as follows:
3143 -- Suppressed: inlining is suppressed for the subprogram
3144 -- Disabled: no inlining is requested for the subprogram
3145 -- Enabled: inlining is requested/required for the subprogram
3147 procedure Process_Inline
(Status
: Inline_Status
);
3148 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3149 -- indicates the inline status specified by the pragma.
3151 procedure Process_Interface_Name
3152 (Subprogram_Def
: Entity_Id
;
3154 Link_Arg
: Node_Id
);
3155 -- Given the last two arguments of pragma Import, pragma Export, or
3156 -- pragma Interface_Name, performs validity checks and sets the
3157 -- Interface_Name field of the given subprogram entity to the
3158 -- appropriate external or link name, depending on the arguments given.
3159 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3160 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3161 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3162 -- nor Link_Arg is present, the interface name is set to the default
3163 -- from the subprogram name.
3165 procedure Process_Interrupt_Or_Attach_Handler
;
3166 -- Common processing for Interrupt and Attach_Handler pragmas
3168 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3169 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3170 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3171 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3172 -- is not set in the Restrictions case.
3174 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3175 -- Common processing for Suppress and Unsuppress. The boolean parameter
3176 -- Suppress_Case is True for the Suppress case, and False for the
3179 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
3180 -- Subsidiary to the analysis of pragmas Independent[_Components].
3181 -- Record such a pragma N applied to entity E for future checks.
3183 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3184 -- This procedure sets the Is_Exported flag for the given entity,
3185 -- checking that the entity was not previously imported. Arg is
3186 -- the argument that specified the entity. A check is also made
3187 -- for exporting inappropriate entities.
3189 procedure Set_Extended_Import_Export_External_Name
3190 (Internal_Ent
: Entity_Id
;
3191 Arg_External
: Node_Id
);
3192 -- Common processing for all extended import export pragmas. The first
3193 -- argument, Internal_Ent, is the internal entity, which has already
3194 -- been checked for validity by the caller. Arg_External is from the
3195 -- Import or Export pragma, and may be null if no External parameter
3196 -- was present. If Arg_External is present and is a non-null string
3197 -- (a null string is treated as the default), then the Interface_Name
3198 -- field of Internal_Ent is set appropriately.
3200 procedure Set_Imported
(E
: Entity_Id
);
3201 -- This procedure sets the Is_Imported flag for the given entity,
3202 -- checking that it is not previously exported or imported.
3204 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3205 -- Mech is a parameter passing mechanism (see Import_Function syntax
3206 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3207 -- has the right form, and if not issues an error message. If the
3208 -- argument has the right form then the Mechanism field of Ent is
3209 -- set appropriately.
3211 procedure Set_Rational_Profile
;
3212 -- Activate the set of configuration pragmas and permissions that make
3213 -- up the Rational profile.
3215 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
3216 -- Activate the set of configuration pragmas and restrictions that make
3217 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3218 -- is used for error messages on any constructs violating the profile.
3220 ----------------------------------
3221 -- Acquire_Warning_Match_String --
3222 ----------------------------------
3224 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3226 String_To_Name_Buffer
3227 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3229 -- Add asterisk at start if not already there
3231 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3232 Name_Buffer
(2 .. Name_Len
+ 1) :=
3233 Name_Buffer
(1 .. Name_Len
);
3234 Name_Buffer
(1) := '*';
3235 Name_Len
:= Name_Len
+ 1;
3238 -- Add asterisk at end if not already there
3240 if Name_Buffer
(Name_Len
) /= '*' then
3241 Name_Len
:= Name_Len
+ 1;
3242 Name_Buffer
(Name_Len
) := '*';
3244 end Acquire_Warning_Match_String
;
3246 ---------------------
3247 -- Ada_2005_Pragma --
3248 ---------------------
3250 procedure Ada_2005_Pragma
is
3252 if Ada_Version
<= Ada_95
then
3253 Check_Restriction
(No_Implementation_Pragmas
, N
);
3255 end Ada_2005_Pragma
;
3257 ---------------------
3258 -- Ada_2012_Pragma --
3259 ---------------------
3261 procedure Ada_2012_Pragma
is
3263 if Ada_Version
<= Ada_2005
then
3264 Check_Restriction
(No_Implementation_Pragmas
, N
);
3266 end Ada_2012_Pragma
;
3268 ----------------------------
3269 -- Analyze_Depends_Global --
3270 ----------------------------
3272 procedure Analyze_Depends_Global
is
3273 Spec_Id
: Entity_Id
;
3274 Subp_Decl
: Node_Id
;
3278 Check_Arg_Count
(1);
3280 -- Ensure the proper placement of the pragma. Depends/Global must be
3281 -- associated with a subprogram declaration or a body that acts as a
3284 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
3286 -- Generic subprogram
3288 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
3291 -- Body acts as spec
3293 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
3294 and then No
(Corresponding_Spec
(Subp_Decl
))
3298 -- Body stub acts as spec
3300 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
3301 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
3305 -- Subprogram declaration
3307 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
3315 Spec_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
3317 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
3319 -- Fully analyze the pragma when it appears inside a subprogram body
3320 -- because it cannot benefit from forward references.
3322 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
3323 if Pragma_Name
(N
) = Name_Depends
then
3324 Analyze_Depends_In_Decl_Part
(N
);
3326 else pragma Assert
(Pname
= Name_Global
);
3327 Analyze_Global_In_Decl_Part
(N
);
3331 -- Chain the pragma on the contract for further processing by
3332 -- Analyze_Depends_In_Decl_Part/Analyze_Global_In_Decl_Part.
3334 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
3335 end Analyze_Depends_Global
;
3337 ---------------------
3338 -- Analyze_Part_Of --
3339 ---------------------
3341 procedure Analyze_Part_Of
3342 (Item_Id
: Entity_Id
;
3345 Legal
: out Boolean)
3347 Pack_Id
: Entity_Id
;
3348 Placement
: State_Space_Kind
;
3349 Parent_Unit
: Entity_Id
;
3350 State_Id
: Entity_Id
;
3353 -- Assume that the pragma/option is illegal
3357 if Nkind_In
(State
, N_Expanded_Name
,
3359 N_Selected_Component
)
3362 Resolve_State
(State
);
3364 if Is_Entity_Name
(State
)
3365 and then Ekind
(Entity
(State
)) = E_Abstract_State
3367 State_Id
:= Entity
(State
);
3371 ("indicator Part_Of must denote an abstract state", State
);
3375 -- This is a syntax error, always report
3379 ("indicator Part_Of must denote an abstract state", State
);
3383 -- Determine where the state, object or the package instantiation
3384 -- lives with respect to the enclosing packages or package bodies (if
3385 -- any). This placement dictates the legality of the encapsulating
3388 Find_Placement_In_State_Space
3389 (Item_Id
=> Item_Id
,
3390 Placement
=> Placement
,
3391 Pack_Id
=> Pack_Id
);
3393 -- The item appears in a non-package construct with a declarative
3394 -- part (subprogram, block, etc). As such, the item is not allowed
3395 -- to be a part of an encapsulating state because the item is not
3398 if Placement
= Not_In_Package
then
3400 ("indicator Part_Of cannot appear in this context "
3401 & "(SPARK RM 7.2.6(5))", Indic
);
3402 Error_Msg_Name_1
:= Chars
(Scope
(State_Id
));
3404 ("\& is not part of the hidden state of package %",
3407 -- The item appears in the visible state space of some package. In
3408 -- general this scenario does not warrant Part_Of except when the
3409 -- package is a private child unit and the encapsulating state is
3410 -- declared in a parent unit or a public descendant of that parent
3413 elsif Placement
= Visible_State_Space
then
3414 if Is_Child_Unit
(Pack_Id
)
3415 and then Is_Private_Descendant
(Pack_Id
)
3417 -- A variable or state abstraction which is part of the
3418 -- visible state of a private child unit (or one of its public
3419 -- descendants) must have its Part_Of indicator specified. The
3420 -- Part_Of indicator must denote a state abstraction declared
3421 -- by either the parent unit of the private unit or by a public
3422 -- descendant of that parent unit.
3424 -- Find nearest private ancestor (which can be the current unit
3427 Parent_Unit
:= Pack_Id
;
3428 while Present
(Parent_Unit
) loop
3429 exit when Private_Present
3430 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3431 Parent_Unit
:= Scope
(Parent_Unit
);
3434 Parent_Unit
:= Scope
(Parent_Unit
);
3436 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(State_Id
)) then
3438 ("indicator Part_Of must denote an abstract state of& "
3439 & "or public descendant (SPARK RM 7.2.6(3))",
3440 Indic
, Parent_Unit
);
3442 elsif Scope
(State_Id
) = Parent_Unit
3443 or else (Is_Ancestor_Package
(Parent_Unit
, Scope
(State_Id
))
3445 not Is_Private_Descendant
(Scope
(State_Id
)))
3451 ("indicator Part_Of must denote an abstract state of& "
3452 & "or public descendant (SPARK RM 7.2.6(3))",
3453 Indic
, Parent_Unit
);
3456 -- Indicator Part_Of is not needed when the related package is not
3457 -- a private child unit or a public descendant thereof.
3461 ("indicator Part_Of cannot appear in this context "
3462 & "(SPARK RM 7.2.6(5))", Indic
);
3463 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3465 ("\& is declared in the visible part of package %",
3469 -- When the item appears in the private state space of a package, the
3470 -- encapsulating state must be declared in the same package.
3472 elsif Placement
= Private_State_Space
then
3473 if Scope
(State_Id
) /= Pack_Id
then
3475 ("indicator Part_Of must designate an abstract state of "
3476 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3477 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3479 ("\& is declared in the private part of package %",
3483 -- Items declared in the body state space of a package do not need
3484 -- Part_Of indicators as the refinement has already been seen.
3488 ("indicator Part_Of cannot appear in this context "
3489 & "(SPARK RM 7.2.6(5))", Indic
);
3491 if Scope
(State_Id
) = Pack_Id
then
3492 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3494 ("\& is declared in the body of package %", Indic
, Item_Id
);
3499 end Analyze_Part_Of
;
3501 --------------------------------
3502 -- Analyze_Pre_Post_Condition --
3503 --------------------------------
3505 procedure Analyze_Pre_Post_Condition
is
3506 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
3507 Subp_Decl
: Node_Id
;
3509 Duplicates_OK
: Boolean := False;
3510 -- Flag set when a pre/postcondition allows multiple pragmas of the
3513 In_Body_OK
: Boolean := False;
3514 -- Flag set when a pre/postcondition is allowed to appear on a body
3515 -- even though the subprogram may have a spec.
3517 Is_Pre_Post
: Boolean := False;
3518 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
3522 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
3523 -- offer uniformity among the various kinds of pre/postconditions by
3524 -- rewriting the pragma identifier. This allows the retrieval of the
3525 -- original pragma name by routine Original_Aspect_Pragma_Name.
3527 if Comes_From_Source
(N
) then
3528 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
3529 Is_Pre_Post
:= True;
3530 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
3531 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
3533 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
3534 Is_Pre_Post
:= True;
3535 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
3536 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
3540 -- Determine the semantics with respect to duplicates and placement
3541 -- in a body. Pragmas Precondition and Postcondition were introduced
3542 -- before aspects and are not subject to the same aspect-like rules.
3544 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
3545 Duplicates_OK
:= True;
3551 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
3552 -- argument without an identifier.
3555 Check_Arg_Count
(1);
3556 Check_No_Identifiers
;
3558 -- Pragmas Precondition and Postcondition have complex argument
3562 Check_At_Least_N_Arguments
(1);
3563 Check_At_Most_N_Arguments
(2);
3564 Check_Optional_Identifier
(Arg1
, Name_Check
);
3566 if Present
(Arg2
) then
3567 Check_Optional_Identifier
(Arg2
, Name_Message
);
3568 Preanalyze_Spec_Expression
3569 (Get_Pragma_Arg
(Arg2
), Standard_String
);
3573 -- For a pragma PPC in the extended main source unit, record enabled
3575 -- ??? nothing checks that the pragma is in the main source unit
3577 if Is_Checked
(N
) and then not Split_PPC
(N
) then
3578 Set_SCO_Pragma_Enabled
(Loc
);
3581 -- Ensure the proper placement of the pragma
3584 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> not Duplicates_OK
);
3586 -- When a pre/postcondition pragma applies to an abstract subprogram,
3587 -- its original form must be an aspect with 'Class.
3589 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
3590 if not From_Aspect_Specification
(N
) then
3592 ("pragma % cannot be applied to abstract subprogram");
3594 elsif not Class_Present
(N
) then
3596 ("aspect % requires ''Class for abstract subprogram");
3599 -- Entry declaration
3601 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
3604 -- Generic subprogram declaration
3606 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
3611 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
3612 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
3616 -- Subprogram body stub
3618 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
3619 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
3623 -- Subprogram declaration
3625 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
3627 -- AI05-0230: When a pre/postcondition pragma applies to a null
3628 -- procedure, its original form must be an aspect with 'Class.
3630 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
3631 and then Null_Present
(Specification
(Subp_Decl
))
3632 and then From_Aspect_Specification
(N
)
3633 and then not Class_Present
(N
)
3635 Error_Pragma
("aspect % requires ''Class for null procedure");
3638 -- Otherwise the placement is illegal
3645 -- Fully analyze the pragma when it appears inside a subprogram
3646 -- body because it cannot benefit from forward references.
3648 if Nkind_In
(Subp_Decl
, N_Subprogram_Body
,
3649 N_Subprogram_Body_Stub
)
3651 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
3654 -- Chain the pragma on the contract for further processing by
3655 -- Analyze_Pre_Post_Condition_In_Decl_Part.
3657 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
3658 end Analyze_Pre_Post_Condition
;
3660 -----------------------------------------
3661 -- Analyze_Refined_Depends_Global_Post --
3662 -----------------------------------------
3664 procedure Analyze_Refined_Depends_Global_Post
3665 (Spec_Id
: out Entity_Id
;
3666 Body_Id
: out Entity_Id
;
3667 Legal
: out Boolean)
3669 Body_Decl
: Node_Id
;
3670 Spec_Decl
: Node_Id
;
3673 -- Assume that the pragma is illegal
3680 Check_Arg_Count
(1);
3681 Check_No_Identifiers
;
3683 -- Verify the placement of the pragma and check for duplicates. The
3684 -- pragma must apply to a subprogram body [stub].
3686 Body_Decl
:= Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
3688 -- Extract the entities of the spec and body
3690 if Nkind
(Body_Decl
) = N_Subprogram_Body
then
3691 Body_Id
:= Defining_Entity
(Body_Decl
);
3692 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
3694 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
3695 Body_Id
:= Defining_Entity
(Body_Decl
);
3696 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
3703 -- The pragma must apply to the second declaration of a subprogram.
3704 -- In other words, the body [stub] cannot acts as a spec.
3706 if No
(Spec_Id
) then
3707 Error_Pragma
("pragma % cannot apply to a stand alone body");
3710 -- Catch the case where the subprogram body is a subunit and acts as
3711 -- the third declaration of the subprogram.
3713 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
3714 Error_Pragma
("pragma % cannot apply to a subunit");
3718 -- The pragma can only apply to the body [stub] of a subprogram
3719 -- declared in the visible part of a package. Retrieve the context of
3720 -- the subprogram declaration.
3722 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
3724 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
3726 ("pragma % must apply to the body of a subprogram declared in a "
3727 & "package specification");
3731 -- If we get here, then the pragma is legal
3733 if Nam_In
(Pname
, Name_Refined_Depends
,
3734 Name_Refined_Global
,
3737 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
3741 end Analyze_Refined_Depends_Global_Post
;
3743 --------------------------
3744 -- Check_Ada_83_Warning --
3745 --------------------------
3747 procedure Check_Ada_83_Warning
is
3749 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3750 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
3752 end Check_Ada_83_Warning
;
3754 ---------------------
3755 -- Check_Arg_Count --
3756 ---------------------
3758 procedure Check_Arg_Count
(Required
: Nat
) is
3760 if Arg_Count
/= Required
then
3761 Error_Pragma
("wrong number of arguments for pragma%");
3763 end Check_Arg_Count
;
3765 --------------------------------
3766 -- Check_Arg_Is_External_Name --
3767 --------------------------------
3769 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
3770 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3773 if Nkind
(Argx
) = N_Identifier
then
3777 Analyze_And_Resolve
(Argx
, Standard_String
);
3779 if Is_OK_Static_Expression
(Argx
) then
3782 elsif Etype
(Argx
) = Any_Type
then
3785 -- An interesting special case, if we have a string literal and
3786 -- we are in Ada 83 mode, then we allow it even though it will
3787 -- not be flagged as static. This allows expected Ada 83 mode
3788 -- use of external names which are string literals, even though
3789 -- technically these are not static in Ada 83.
3791 elsif Ada_Version
= Ada_83
3792 and then Nkind
(Argx
) = N_String_Literal
3796 -- Static expression that raises Constraint_Error. This has
3797 -- already been flagged, so just exit from pragma processing.
3799 elsif Is_OK_Static_Expression
(Argx
) then
3802 -- Here we have a real error (non-static expression)
3805 Error_Msg_Name_1
:= Pname
;
3808 Msg
: constant String :=
3809 "argument for pragma% must be a identifier or "
3810 & "static string expression!";
3812 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
3817 end Check_Arg_Is_External_Name
;
3819 -----------------------------
3820 -- Check_Arg_Is_Identifier --
3821 -----------------------------
3823 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
3824 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3826 if Nkind
(Argx
) /= N_Identifier
then
3828 ("argument for pragma% must be identifier", Argx
);
3830 end Check_Arg_Is_Identifier
;
3832 ----------------------------------
3833 -- Check_Arg_Is_Integer_Literal --
3834 ----------------------------------
3836 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
3837 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3839 if Nkind
(Argx
) /= N_Integer_Literal
then
3841 ("argument for pragma% must be integer literal", Argx
);
3843 end Check_Arg_Is_Integer_Literal
;
3845 -------------------------------------------
3846 -- Check_Arg_Is_Library_Level_Local_Name --
3847 -------------------------------------------
3851 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3852 -- | library_unit_NAME
3854 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
3856 Check_Arg_Is_Local_Name
(Arg
);
3858 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
3859 and then Comes_From_Source
(N
)
3862 ("argument for pragma% must be library level entity", Arg
);
3864 end Check_Arg_Is_Library_Level_Local_Name
;
3866 -----------------------------
3867 -- Check_Arg_Is_Local_Name --
3868 -----------------------------
3872 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3873 -- | library_unit_NAME
3875 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
3876 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3881 if Nkind
(Argx
) not in N_Direct_Name
3882 and then (Nkind
(Argx
) /= N_Attribute_Reference
3883 or else Present
(Expressions
(Argx
))
3884 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
3885 and then (not Is_Entity_Name
(Argx
)
3886 or else not Is_Compilation_Unit
(Entity
(Argx
)))
3888 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
3891 -- No further check required if not an entity name
3893 if not Is_Entity_Name
(Argx
) then
3899 Ent
: constant Entity_Id
:= Entity
(Argx
);
3900 Scop
: constant Entity_Id
:= Scope
(Ent
);
3903 -- Case of a pragma applied to a compilation unit: pragma must
3904 -- occur immediately after the program unit in the compilation.
3906 if Is_Compilation_Unit
(Ent
) then
3908 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
3911 -- Case of pragma placed immediately after spec
3913 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
3916 -- Case of pragma placed immediately after body
3918 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3919 and then Present
(Corresponding_Body
(Decl
))
3923 (Parent
(Unit_Declaration_Node
3924 (Corresponding_Body
(Decl
))));
3926 -- All other cases are illegal
3933 -- Special restricted placement rule from 10.2.1(11.8/2)
3935 elsif Is_Generic_Formal
(Ent
)
3936 and then Prag_Id
= Pragma_Preelaborable_Initialization
3938 OK
:= List_Containing
(N
) =
3939 Generic_Formal_Declarations
3940 (Unit_Declaration_Node
(Scop
));
3942 -- If this is an aspect applied to a subprogram body, the
3943 -- pragma is inserted in its declarative part.
3945 elsif From_Aspect_Specification
(N
)
3946 and then Ent
= Current_Scope
3948 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
3952 -- If the aspect is a predicate (possibly others ???) and the
3953 -- context is a record type, this is a discriminant expression
3954 -- within a type declaration, that freezes the predicated
3957 elsif From_Aspect_Specification
(N
)
3958 and then Prag_Id
= Pragma_Predicate
3959 and then Ekind
(Current_Scope
) = E_Record_Type
3960 and then Scop
= Scope
(Current_Scope
)
3964 -- Default case, just check that the pragma occurs in the scope
3965 -- of the entity denoted by the name.
3968 OK
:= Current_Scope
= Scop
;
3973 ("pragma% argument must be in same declarative part", Arg
);
3977 end Check_Arg_Is_Local_Name
;
3979 ---------------------------------
3980 -- Check_Arg_Is_Locking_Policy --
3981 ---------------------------------
3983 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
3984 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3987 Check_Arg_Is_Identifier
(Argx
);
3989 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
3990 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
3992 end Check_Arg_Is_Locking_Policy
;
3994 -----------------------------------------------
3995 -- Check_Arg_Is_Partition_Elaboration_Policy --
3996 -----------------------------------------------
3998 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
3999 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4002 Check_Arg_Is_Identifier
(Argx
);
4004 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
4006 ("& is not a valid partition elaboration policy name", Argx
);
4008 end Check_Arg_Is_Partition_Elaboration_Policy
;
4010 -------------------------
4011 -- Check_Arg_Is_One_Of --
4012 -------------------------
4014 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4015 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4018 Check_Arg_Is_Identifier
(Argx
);
4020 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
4021 Error_Msg_Name_2
:= N1
;
4022 Error_Msg_Name_3
:= N2
;
4023 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
4025 end Check_Arg_Is_One_Of
;
4027 procedure Check_Arg_Is_One_Of
4029 N1
, N2
, N3
: Name_Id
)
4031 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4034 Check_Arg_Is_Identifier
(Argx
);
4036 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
4037 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
4039 end Check_Arg_Is_One_Of
;
4041 procedure Check_Arg_Is_One_Of
4043 N1
, N2
, N3
, N4
: Name_Id
)
4045 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4048 Check_Arg_Is_Identifier
(Argx
);
4050 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
4051 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
4053 end Check_Arg_Is_One_Of
;
4055 procedure Check_Arg_Is_One_Of
4057 N1
, N2
, N3
, N4
, N5
: Name_Id
)
4059 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4062 Check_Arg_Is_Identifier
(Argx
);
4064 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
4065 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
4067 end Check_Arg_Is_One_Of
;
4069 ---------------------------------
4070 -- Check_Arg_Is_Queuing_Policy --
4071 ---------------------------------
4073 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
4074 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4077 Check_Arg_Is_Identifier
(Argx
);
4079 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
4080 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
4082 end Check_Arg_Is_Queuing_Policy
;
4084 ---------------------------------------
4085 -- Check_Arg_Is_OK_Static_Expression --
4086 ---------------------------------------
4088 procedure Check_Arg_Is_OK_Static_Expression
4090 Typ
: Entity_Id
:= Empty
)
4093 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
4094 end Check_Arg_Is_OK_Static_Expression
;
4096 ------------------------------------------
4097 -- Check_Arg_Is_Task_Dispatching_Policy --
4098 ------------------------------------------
4100 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
4101 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4104 Check_Arg_Is_Identifier
(Argx
);
4106 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
4108 ("& is not an allowed task dispatching policy name", Argx
);
4110 end Check_Arg_Is_Task_Dispatching_Policy
;
4112 ---------------------
4113 -- Check_Arg_Order --
4114 ---------------------
4116 procedure Check_Arg_Order
(Names
: Name_List
) is
4119 Highest_So_Far
: Natural := 0;
4120 -- Highest index in Names seen do far
4124 for J
in 1 .. Arg_Count
loop
4125 if Chars
(Arg
) /= No_Name
then
4126 for K
in Names
'Range loop
4127 if Chars
(Arg
) = Names
(K
) then
4128 if K
< Highest_So_Far
then
4129 Error_Msg_Name_1
:= Pname
;
4131 ("parameters out of order for pragma%", Arg
);
4132 Error_Msg_Name_1
:= Names
(K
);
4133 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
4134 Error_Msg_N
("\% must appear before %", Arg
);
4138 Highest_So_Far
:= K
;
4146 end Check_Arg_Order
;
4148 --------------------------------
4149 -- Check_At_Least_N_Arguments --
4150 --------------------------------
4152 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
4154 if Arg_Count
< N
then
4155 Error_Pragma
("too few arguments for pragma%");
4157 end Check_At_Least_N_Arguments
;
4159 -------------------------------
4160 -- Check_At_Most_N_Arguments --
4161 -------------------------------
4163 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
4166 if Arg_Count
> N
then
4168 for J
in 1 .. N
loop
4170 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
4173 end Check_At_Most_N_Arguments
;
4175 ---------------------
4176 -- Check_Component --
4177 ---------------------
4179 procedure Check_Component
4182 In_Variant_Part
: Boolean := False)
4184 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
4185 Sindic
: constant Node_Id
:=
4186 Subtype_Indication
(Component_Definition
(Comp
));
4187 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
4190 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4191 -- object constraint, then the component type shall be an Unchecked_
4194 if Nkind
(Sindic
) = N_Subtype_Indication
4195 and then Has_Per_Object_Constraint
(Comp_Id
)
4196 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4199 ("component subtype subject to per-object constraint "
4200 & "must be an Unchecked_Union", Comp
);
4202 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4203 -- the body of a generic unit, or within the body of any of its
4204 -- descendant library units, no part of the type of a component
4205 -- declared in a variant_part of the unchecked union type shall be of
4206 -- a formal private type or formal private extension declared within
4207 -- the formal part of the generic unit.
4209 elsif Ada_Version
>= Ada_2012
4210 and then In_Generic_Body
(UU_Typ
)
4211 and then In_Variant_Part
4212 and then Is_Private_Type
(Typ
)
4213 and then Is_Generic_Type
(Typ
)
4216 ("component of unchecked union cannot be of generic type", Comp
);
4218 elsif Needs_Finalization
(Typ
) then
4220 ("component of unchecked union cannot be controlled", Comp
);
4222 elsif Has_Task
(Typ
) then
4224 ("component of unchecked union cannot have tasks", Comp
);
4226 end Check_Component
;
4228 -----------------------------
4229 -- Check_Declaration_Order --
4230 -----------------------------
4232 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
) is
4233 procedure Check_Aspect_Specification_Order
;
4234 -- Inspect the aspect specifications of the context to determine the
4237 --------------------------------------
4238 -- Check_Aspect_Specification_Order --
4239 --------------------------------------
4241 procedure Check_Aspect_Specification_Order
is
4242 Asp_First
: constant Node_Id
:= Corresponding_Aspect
(First
);
4243 Asp_Second
: constant Node_Id
:= Corresponding_Aspect
(Second
);
4247 -- Both aspects must be part of the same aspect specification list
4250 (List_Containing
(Asp_First
) = List_Containing
(Asp_Second
));
4252 -- Try to reach Second starting from First in a left to right
4253 -- traversal of the aspect specifications.
4255 Asp
:= Next
(Asp_First
);
4256 while Present
(Asp
) loop
4258 -- The order is ok, First is followed by Second
4260 if Asp
= Asp_Second
then
4267 -- If we get here, then the aspects are out of order
4269 SPARK_Msg_N
("aspect % cannot come after aspect %", First
);
4270 end Check_Aspect_Specification_Order
;
4276 -- Start of processing for Check_Declaration_Order
4279 -- Cannot check the order if one of the pragmas is missing
4281 if No
(First
) or else No
(Second
) then
4285 -- Set up the error names in case the order is incorrect
4287 Error_Msg_Name_1
:= Pragma_Name
(First
);
4288 Error_Msg_Name_2
:= Pragma_Name
(Second
);
4290 if From_Aspect_Specification
(First
) then
4292 -- Both pragmas are actually aspects, check their declaration
4293 -- order in the associated aspect specification list. Otherwise
4294 -- First is an aspect and Second a source pragma.
4296 if From_Aspect_Specification
(Second
) then
4297 Check_Aspect_Specification_Order
;
4300 -- Abstract_States is a source pragma
4303 if From_Aspect_Specification
(Second
) then
4304 SPARK_Msg_N
("pragma % cannot come after aspect %", First
);
4306 -- Both pragmas are source constructs. Try to reach First from
4307 -- Second by traversing the declarations backwards.
4310 Stmt
:= Prev
(Second
);
4311 while Present
(Stmt
) loop
4313 -- The order is ok, First is followed by Second
4315 if Stmt
= First
then
4322 -- If we get here, then the pragmas are out of order
4324 SPARK_Msg_N
("pragma % cannot come after pragma %", First
);
4327 end Check_Declaration_Order
;
4329 ----------------------------
4330 -- Check_Duplicate_Pragma --
4331 ----------------------------
4333 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4334 Id
: Entity_Id
:= E
;
4338 -- Nothing to do if this pragma comes from an aspect specification,
4339 -- since we could not be duplicating a pragma, and we dealt with the
4340 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4342 if From_Aspect_Specification
(N
) then
4346 -- Otherwise current pragma may duplicate previous pragma or a
4347 -- previously given aspect specification or attribute definition
4348 -- clause for the same pragma.
4350 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4354 -- If the entity is a type, then we have to make sure that the
4355 -- ostensible duplicate is not for a parent type from which this
4359 if Nkind
(P
) = N_Pragma
then
4361 Args
: constant List_Id
:=
4362 Pragma_Argument_Associations
(P
);
4365 and then Is_Entity_Name
(Expression
(First
(Args
)))
4366 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4367 and then Entity
(Expression
(First
(Args
))) /= E
4373 elsif Nkind
(P
) = N_Aspect_Specification
4374 and then Is_Type
(Entity
(P
))
4375 and then Entity
(P
) /= E
4381 -- Here we have a definite duplicate
4383 Error_Msg_Name_1
:= Pragma_Name
(N
);
4384 Error_Msg_Sloc
:= Sloc
(P
);
4386 -- For a single protected or a single task object, the error is
4387 -- issued on the original entity.
4389 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4390 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4393 if Nkind
(P
) = N_Aspect_Specification
4394 or else From_Aspect_Specification
(P
)
4396 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4398 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4403 end Check_Duplicate_Pragma
;
4405 ----------------------------------
4406 -- Check_Duplicated_Export_Name --
4407 ----------------------------------
4409 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4410 String_Val
: constant String_Id
:= Strval
(Nam
);
4413 -- We are only interested in the export case, and in the case of
4414 -- generics, it is the instance, not the template, that is the
4415 -- problem (the template will generate a warning in any case).
4417 if not Inside_A_Generic
4418 and then (Prag_Id
= Pragma_Export
4420 Prag_Id
= Pragma_Export_Procedure
4422 Prag_Id
= Pragma_Export_Valued_Procedure
4424 Prag_Id
= Pragma_Export_Function
)
4426 for J
in Externals
.First
.. Externals
.Last
loop
4427 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4428 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4429 Error_Msg_N
("external name duplicates name given#", Nam
);
4434 Externals
.Append
(Nam
);
4436 end Check_Duplicated_Export_Name
;
4438 ----------------------------------------
4439 -- Check_Expr_Is_OK_Static_Expression --
4440 ----------------------------------------
4442 procedure Check_Expr_Is_OK_Static_Expression
4444 Typ
: Entity_Id
:= Empty
)
4447 if Present
(Typ
) then
4448 Analyze_And_Resolve
(Expr
, Typ
);
4450 Analyze_And_Resolve
(Expr
);
4453 if Is_OK_Static_Expression
(Expr
) then
4456 elsif Etype
(Expr
) = Any_Type
then
4459 -- An interesting special case, if we have a string literal and we
4460 -- are in Ada 83 mode, then we allow it even though it will not be
4461 -- flagged as static. This allows the use of Ada 95 pragmas like
4462 -- Import in Ada 83 mode. They will of course be flagged with
4463 -- warnings as usual, but will not cause errors.
4465 elsif Ada_Version
= Ada_83
4466 and then Nkind
(Expr
) = N_String_Literal
4470 -- Static expression that raises Constraint_Error. This has already
4471 -- been flagged, so just exit from pragma processing.
4473 elsif Is_OK_Static_Expression
(Expr
) then
4476 -- Finally, we have a real error
4479 Error_Msg_Name_1
:= Pname
;
4480 Flag_Non_Static_Expr
4481 (Fix_Error
("argument for pragma% must be a static expression!"),
4485 end Check_Expr_Is_OK_Static_Expression
;
4487 -------------------------
4488 -- Check_First_Subtype --
4489 -------------------------
4491 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4492 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4493 Ent
: constant Entity_Id
:= Entity
(Argx
);
4496 if Is_First_Subtype
(Ent
) then
4499 elsif Is_Type
(Ent
) then
4501 ("pragma% cannot apply to subtype", Argx
);
4503 elsif Is_Object
(Ent
) then
4505 ("pragma% cannot apply to object, requires a type", Argx
);
4509 ("pragma% cannot apply to&, requires a type", Argx
);
4511 end Check_First_Subtype
;
4513 ----------------------
4514 -- Check_Identifier --
4515 ----------------------
4517 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4520 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4522 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4523 Error_Msg_Name_1
:= Pname
;
4524 Error_Msg_Name_2
:= Id
;
4525 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4529 end Check_Identifier
;
4531 --------------------------------
4532 -- Check_Identifier_Is_One_Of --
4533 --------------------------------
4535 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4538 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4540 if Chars
(Arg
) = No_Name
then
4541 Error_Msg_Name_1
:= Pname
;
4542 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
4545 elsif Chars
(Arg
) /= N1
4546 and then Chars
(Arg
) /= N2
4548 Error_Msg_Name_1
:= Pname
;
4549 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
4553 end Check_Identifier_Is_One_Of
;
4555 ---------------------------
4556 -- Check_In_Main_Program --
4557 ---------------------------
4559 procedure Check_In_Main_Program
is
4560 P
: constant Node_Id
:= Parent
(N
);
4563 -- Must be at in subprogram body
4565 if Nkind
(P
) /= N_Subprogram_Body
then
4566 Error_Pragma
("% pragma allowed only in subprogram");
4568 -- Otherwise warn if obviously not main program
4570 elsif Present
(Parameter_Specifications
(Specification
(P
)))
4571 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
4573 Error_Msg_Name_1
:= Pname
;
4575 ("??pragma% is only effective in main program", N
);
4577 end Check_In_Main_Program
;
4579 ---------------------------------------
4580 -- Check_Interrupt_Or_Attach_Handler --
4581 ---------------------------------------
4583 procedure Check_Interrupt_Or_Attach_Handler
is
4584 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4585 Handler_Proc
, Proc_Scope
: Entity_Id
;
4590 if Prag_Id
= Pragma_Interrupt_Handler
then
4591 Check_Restriction
(No_Dynamic_Attachment
, N
);
4594 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
4595 Proc_Scope
:= Scope
(Handler_Proc
);
4597 -- On AAMP only, a pragma Interrupt_Handler is supported for
4598 -- nonprotected parameterless procedures.
4600 if not AAMP_On_Target
4601 or else Prag_Id
= Pragma_Attach_Handler
4603 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
4605 ("argument of pragma% must be protected procedure", Arg1
);
4608 -- For pragma case (as opposed to access case), check placement.
4609 -- We don't need to do that for aspects, because we have the
4610 -- check that they aspect applies an appropriate procedure.
4612 if not From_Aspect_Specification
(N
)
4613 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
4615 Error_Pragma
("pragma% must be in protected definition");
4619 if not Is_Library_Level_Entity
(Proc_Scope
)
4620 or else (AAMP_On_Target
4621 and then not Is_Library_Level_Entity
(Handler_Proc
))
4624 ("argument for pragma% must be library level entity", Arg1
);
4627 -- AI05-0033: A pragma cannot appear within a generic body, because
4628 -- instance can be in a nested scope. The check that protected type
4629 -- is itself a library-level declaration is done elsewhere.
4631 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4632 -- handle code prior to AI-0033. Analysis tools typically are not
4633 -- interested in this pragma in any case, so no need to worry too
4634 -- much about its placement.
4636 if Inside_A_Generic
then
4637 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
4638 and then In_Package_Body
(Scope
(Current_Scope
))
4639 and then not Relaxed_RM_Semantics
4641 Error_Pragma
("pragma% cannot be used inside a generic");
4644 end Check_Interrupt_Or_Attach_Handler
;
4646 ---------------------------------
4647 -- Check_Loop_Pragma_Placement --
4648 ---------------------------------
4650 procedure Check_Loop_Pragma_Placement
is
4651 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
4652 -- Verify whether the current pragma is properly grouped with other
4653 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4654 -- related loop where the pragma appears.
4656 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
4657 -- Determine whether an arbitrary statement Stmt denotes pragma
4658 -- Loop_Invariant or Loop_Variant.
4660 procedure Placement_Error
(Constr
: Node_Id
);
4661 pragma No_Return
(Placement_Error
);
4662 -- Node Constr denotes the last loop restricted construct before we
4663 -- encountered an illegal relation between enclosing constructs. Emit
4664 -- an error depending on what Constr was.
4666 --------------------------------
4667 -- Check_Loop_Pragma_Grouping --
4668 --------------------------------
4670 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
4671 Stop_Search
: exception;
4672 -- This exception is used to terminate the recursive descent of
4673 -- routine Check_Grouping.
4675 procedure Check_Grouping
(L
: List_Id
);
4676 -- Find the first group of pragmas in list L and if successful,
4677 -- ensure that the current pragma is part of that group. The
4678 -- routine raises Stop_Search once such a check is performed to
4679 -- halt the recursive descent.
4681 procedure Grouping_Error
(Prag
: Node_Id
);
4682 pragma No_Return
(Grouping_Error
);
4683 -- Emit an error concerning the current pragma indicating that it
4684 -- should be placed after pragma Prag.
4686 --------------------
4687 -- Check_Grouping --
4688 --------------------
4690 procedure Check_Grouping
(L
: List_Id
) is
4696 -- Inspect the list of declarations or statements looking for
4697 -- the first grouping of pragmas:
4700 -- pragma Loop_Invariant ...;
4701 -- pragma Loop_Variant ...;
4703 -- pragma Loop_Variant ...; -- current pragma
4705 -- If the current pragma is not in the grouping, then it must
4706 -- either appear in a different declarative or statement list
4707 -- or the construct at (1) is separating the pragma from the
4711 while Present
(Stmt
) loop
4713 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4714 -- inside a loop or a block housed inside a loop. Inspect
4715 -- the declarations and statements of the block as they may
4716 -- contain the first grouping.
4718 if Nkind
(Stmt
) = N_Block_Statement
then
4719 HSS
:= Handled_Statement_Sequence
(Stmt
);
4721 Check_Grouping
(Declarations
(Stmt
));
4723 if Present
(HSS
) then
4724 Check_Grouping
(Statements
(HSS
));
4727 -- First pragma of the first topmost grouping has been found
4729 elsif Is_Loop_Pragma
(Stmt
) then
4731 -- The group and the current pragma are not in the same
4732 -- declarative or statement list.
4734 if List_Containing
(Stmt
) /= List_Containing
(N
) then
4735 Grouping_Error
(Stmt
);
4737 -- Try to reach the current pragma from the first pragma
4738 -- of the grouping while skipping other members:
4740 -- pragma Loop_Invariant ...; -- first pragma
4741 -- pragma Loop_Variant ...; -- member
4743 -- pragma Loop_Variant ...; -- current pragma
4746 while Present
(Stmt
) loop
4748 -- The current pragma is either the first pragma
4749 -- of the group or is a member of the group. Stop
4750 -- the search as the placement is legal.
4755 -- Skip group members, but keep track of the last
4756 -- pragma in the group.
4758 elsif Is_Loop_Pragma
(Stmt
) then
4761 -- A non-pragma is separating the group from the
4762 -- current pragma, the placement is illegal.
4765 Grouping_Error
(Prag
);
4771 -- If the traversal did not reach the current pragma,
4772 -- then the list must be malformed.
4774 raise Program_Error
;
4782 --------------------
4783 -- Grouping_Error --
4784 --------------------
4786 procedure Grouping_Error
(Prag
: Node_Id
) is
4788 Error_Msg_Sloc
:= Sloc
(Prag
);
4789 Error_Pragma
("pragma% must appear next to pragma#");
4792 -- Start of processing for Check_Loop_Pragma_Grouping
4795 -- Inspect the statements of the loop or nested blocks housed
4796 -- within to determine whether the current pragma is part of the
4797 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4799 Check_Grouping
(Statements
(Loop_Stmt
));
4802 when Stop_Search
=> null;
4803 end Check_Loop_Pragma_Grouping
;
4805 --------------------
4806 -- Is_Loop_Pragma --
4807 --------------------
4809 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
4811 -- Inspect the original node as Loop_Invariant and Loop_Variant
4812 -- pragmas are rewritten to null when assertions are disabled.
4814 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
4816 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
4817 Name_Loop_Invariant
,
4824 ---------------------
4825 -- Placement_Error --
4826 ---------------------
4828 procedure Placement_Error
(Constr
: Node_Id
) is
4829 LA
: constant String := " with Loop_Entry";
4832 if Prag_Id
= Pragma_Assert
then
4833 Error_Msg_String
(1 .. LA
'Length) := LA
;
4834 Error_Msg_Strlen
:= LA
'Length;
4836 Error_Msg_Strlen
:= 0;
4839 if Nkind
(Constr
) = N_Pragma
then
4841 ("pragma %~ must appear immediately within the statements "
4845 ("block containing pragma %~ must appear immediately within "
4846 & "the statements of a loop", Constr
);
4848 end Placement_Error
;
4850 -- Local declarations
4855 -- Start of processing for Check_Loop_Pragma_Placement
4858 -- Check that pragma appears immediately within a loop statement,
4859 -- ignoring intervening block statements.
4863 while Present
(Stmt
) loop
4865 -- The pragma or previous block must appear immediately within the
4866 -- current block's declarative or statement part.
4868 if Nkind
(Stmt
) = N_Block_Statement
then
4869 if (No
(Declarations
(Stmt
))
4870 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
4872 List_Containing
(Prev
) /=
4873 Statements
(Handled_Statement_Sequence
(Stmt
))
4875 Placement_Error
(Prev
);
4878 -- Keep inspecting the parents because we are now within a
4879 -- chain of nested blocks.
4883 Stmt
:= Parent
(Stmt
);
4886 -- The pragma or previous block must appear immediately within the
4887 -- statements of the loop.
4889 elsif Nkind
(Stmt
) = N_Loop_Statement
then
4890 if List_Containing
(Prev
) /= Statements
(Stmt
) then
4891 Placement_Error
(Prev
);
4894 -- Stop the traversal because we reached the innermost loop
4895 -- regardless of whether we encountered an error or not.
4899 -- Ignore a handled statement sequence. Note that this node may
4900 -- be related to a subprogram body in which case we will emit an
4901 -- error on the next iteration of the search.
4903 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
4904 Stmt
:= Parent
(Stmt
);
4906 -- Any other statement breaks the chain from the pragma to the
4910 Placement_Error
(Prev
);
4915 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4916 -- grouped together with other such pragmas.
4918 if Is_Loop_Pragma
(N
) then
4920 -- The previous check should have located the related loop
4922 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
4923 Check_Loop_Pragma_Grouping
(Stmt
);
4925 end Check_Loop_Pragma_Placement
;
4927 -------------------------------------------
4928 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4929 -------------------------------------------
4931 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
4940 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4943 elsif Nkind_In
(P
, N_Package_Specification
,
4948 -- Note: the following tests seem a little peculiar, because
4949 -- they test for bodies, but if we were in the statement part
4950 -- of the body, we would already have hit the handled statement
4951 -- sequence, so the only way we get here is by being in the
4952 -- declarative part of the body.
4954 elsif Nkind_In
(P
, N_Subprogram_Body
,
4965 Error_Pragma
("pragma% is not in declarative part or package spec");
4966 end Check_Is_In_Decl_Part_Or_Package_Spec
;
4968 -------------------------
4969 -- Check_No_Identifier --
4970 -------------------------
4972 procedure Check_No_Identifier
(Arg
: Node_Id
) is
4974 if Nkind
(Arg
) = N_Pragma_Argument_Association
4975 and then Chars
(Arg
) /= No_Name
4977 Error_Pragma_Arg_Ident
4978 ("pragma% does not permit identifier& here", Arg
);
4980 end Check_No_Identifier
;
4982 --------------------------
4983 -- Check_No_Identifiers --
4984 --------------------------
4986 procedure Check_No_Identifiers
is
4990 for J
in 1 .. Arg_Count
loop
4991 Check_No_Identifier
(Arg_Node
);
4994 end Check_No_Identifiers
;
4996 ------------------------
4997 -- Check_No_Link_Name --
4998 ------------------------
5000 procedure Check_No_Link_Name
is
5002 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
5006 if Present
(Arg4
) then
5008 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
5010 end Check_No_Link_Name
;
5012 -------------------------------
5013 -- Check_Optional_Identifier --
5014 -------------------------------
5016 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5019 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5020 and then Chars
(Arg
) /= No_Name
5022 if Chars
(Arg
) /= Id
then
5023 Error_Msg_Name_1
:= Pname
;
5024 Error_Msg_Name_2
:= Id
;
5025 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5029 end Check_Optional_Identifier
;
5031 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
5033 Name_Buffer
(1 .. Id
'Length) := Id
;
5034 Name_Len
:= Id
'Length;
5035 Check_Optional_Identifier
(Arg
, Name_Find
);
5036 end Check_Optional_Identifier
;
5038 -----------------------------
5039 -- Check_Static_Constraint --
5040 -----------------------------
5042 -- Note: for convenience in writing this procedure, in addition to
5043 -- the officially (i.e. by spec) allowed argument which is always a
5044 -- constraint, it also allows ranges and discriminant associations.
5045 -- Above is not clear ???
5047 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5049 procedure Require_Static
(E
: Node_Id
);
5050 -- Require given expression to be static expression
5052 --------------------
5053 -- Require_Static --
5054 --------------------
5056 procedure Require_Static
(E
: Node_Id
) is
5058 if not Is_OK_Static_Expression
(E
) then
5059 Flag_Non_Static_Expr
5060 ("non-static constraint not allowed in Unchecked_Union!", E
);
5065 -- Start of processing for Check_Static_Constraint
5068 case Nkind
(Constr
) is
5069 when N_Discriminant_Association
=>
5070 Require_Static
(Expression
(Constr
));
5073 Require_Static
(Low_Bound
(Constr
));
5074 Require_Static
(High_Bound
(Constr
));
5076 when N_Attribute_Reference
=>
5077 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5078 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5080 when N_Range_Constraint
=>
5081 Check_Static_Constraint
(Range_Expression
(Constr
));
5083 when N_Index_Or_Discriminant_Constraint
=>
5087 IDC
:= First
(Constraints
(Constr
));
5088 while Present
(IDC
) loop
5089 Check_Static_Constraint
(IDC
);
5097 end Check_Static_Constraint
;
5099 --------------------------------------
5100 -- Check_Valid_Configuration_Pragma --
5101 --------------------------------------
5103 -- A configuration pragma must appear in the context clause of a
5104 -- compilation unit, and only other pragmas may precede it. Note that
5105 -- the test also allows use in a configuration pragma file.
5107 procedure Check_Valid_Configuration_Pragma
is
5109 if not Is_Configuration_Pragma
then
5110 Error_Pragma
("incorrect placement for configuration pragma%");
5112 end Check_Valid_Configuration_Pragma
;
5114 -------------------------------------
5115 -- Check_Valid_Library_Unit_Pragma --
5116 -------------------------------------
5118 procedure Check_Valid_Library_Unit_Pragma
is
5120 Parent_Node
: Node_Id
;
5121 Unit_Name
: Entity_Id
;
5122 Unit_Kind
: Node_Kind
;
5123 Unit_Node
: Node_Id
;
5124 Sindex
: Source_File_Index
;
5127 if not Is_List_Member
(N
) then
5131 Plist
:= List_Containing
(N
);
5132 Parent_Node
:= Parent
(Plist
);
5134 if Parent_Node
= Empty
then
5137 -- Case of pragma appearing after a compilation unit. In this case
5138 -- it must have an argument with the corresponding name and must
5139 -- be part of the following pragmas of its parent.
5141 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5142 if Plist
/= Pragmas_After
(Parent_Node
) then
5145 elsif Arg_Count
= 0 then
5147 ("argument required if outside compilation unit");
5150 Check_No_Identifiers
;
5151 Check_Arg_Count
(1);
5152 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5153 Unit_Kind
:= Nkind
(Unit_Node
);
5155 Analyze
(Get_Pragma_Arg
(Arg1
));
5157 if Unit_Kind
= N_Generic_Subprogram_Declaration
5158 or else Unit_Kind
= N_Subprogram_Declaration
5160 Unit_Name
:= Defining_Entity
(Unit_Node
);
5162 elsif Unit_Kind
in N_Generic_Instantiation
then
5163 Unit_Name
:= Defining_Entity
(Unit_Node
);
5166 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5169 if Chars
(Unit_Name
) /=
5170 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5173 ("pragma% argument is not current unit name", Arg1
);
5176 if Ekind
(Unit_Name
) = E_Package
5177 and then Present
(Renamed_Entity
(Unit_Name
))
5179 Error_Pragma
("pragma% not allowed for renamed package");
5183 -- Pragma appears other than after a compilation unit
5186 -- Here we check for the generic instantiation case and also
5187 -- for the case of processing a generic formal package. We
5188 -- detect these cases by noting that the Sloc on the node
5189 -- does not belong to the current compilation unit.
5191 Sindex
:= Source_Index
(Current_Sem_Unit
);
5193 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5194 Rewrite
(N
, Make_Null_Statement
(Loc
));
5197 -- If before first declaration, the pragma applies to the
5198 -- enclosing unit, and the name if present must be this name.
5200 elsif Is_Before_First_Decl
(N
, Plist
) then
5201 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5202 Unit_Kind
:= Nkind
(Unit_Node
);
5204 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5207 elsif Unit_Kind
= N_Subprogram_Body
5208 and then not Acts_As_Spec
(Unit_Node
)
5212 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5215 elsif Nkind
(Parent_Node
) = N_Package_Specification
5216 and then Plist
= Private_Declarations
(Parent_Node
)
5220 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5221 or else Nkind
(Parent_Node
) =
5222 N_Generic_Subprogram_Declaration
)
5223 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5227 elsif Arg_Count
> 0 then
5228 Analyze
(Get_Pragma_Arg
(Arg1
));
5230 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5232 ("name in pragma% must be enclosing unit", Arg1
);
5235 -- It is legal to have no argument in this context
5241 -- Error if not before first declaration. This is because a
5242 -- library unit pragma argument must be the name of a library
5243 -- unit (RM 10.1.5(7)), but the only names permitted in this
5244 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5245 -- generic subprogram declarations or generic instantiations.
5249 ("pragma% misplaced, must be before first declaration");
5253 end Check_Valid_Library_Unit_Pragma
;
5259 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5260 Clist
: constant Node_Id
:= Component_List
(Variant
);
5264 Comp
:= First
(Component_Items
(Clist
));
5265 while Present
(Comp
) loop
5266 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5271 ---------------------------
5272 -- Ensure_Aggregate_Form --
5273 ---------------------------
5275 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5276 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
5277 Expr
: constant Node_Id
:= Expression
(Arg
);
5278 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
5279 Comps
: List_Id
:= No_List
;
5280 Exprs
: List_Id
:= No_List
;
5281 Nam
: Name_Id
:= No_Name
;
5282 Nam_Loc
: Source_Ptr
;
5285 -- The pragma argument is in positional form:
5287 -- pragma Depends (Nam => ...)
5291 -- Note that the Sloc of the Chars field is the Sloc of the pragma
5292 -- argument association.
5294 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5296 Nam_Loc
:= Sloc
(Arg
);
5298 -- Remove the pragma argument name as this will be captured in the
5301 Set_Chars
(Arg
, No_Name
);
5304 -- The argument is already in aggregate form, but the presence of a
5305 -- name causes this to be interpreted as named association which in
5306 -- turn must be converted into an aggregate.
5308 -- pragma Global (In_Out => (A, B, C))
5312 -- pragma Global ((In_Out => (A, B, C)))
5314 -- aggregate aggregate
5316 if Nkind
(Expr
) = N_Aggregate
then
5317 if Nam
= No_Name
then
5321 -- Do not transform a null argument into an aggregate as N_Null has
5322 -- special meaning in formal verification pragmas.
5324 elsif Nkind
(Expr
) = N_Null
then
5328 -- Everything comes from source if the original comes from source
5330 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
5332 -- Positional argument is transformed into an aggregate with an
5333 -- Expressions list.
5335 if Nam
= No_Name
then
5336 Exprs
:= New_List
(Relocate_Node
(Expr
));
5338 -- An associative argument is transformed into an aggregate with
5339 -- Component_Associations.
5343 Make_Component_Association
(Loc
,
5344 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
5345 Expression
=> Relocate_Node
(Expr
)));
5348 Set_Expression
(Arg
,
5349 Make_Aggregate
(Loc
,
5350 Component_Associations
=> Comps
,
5351 Expressions
=> Exprs
));
5353 -- Restore Comes_From_Source default
5355 Set_Comes_From_Source_Default
(CFSD
);
5356 end Ensure_Aggregate_Form
;
5362 procedure Error_Pragma
(Msg
: String) is
5364 Error_Msg_Name_1
:= Pname
;
5365 Error_Msg_N
(Fix_Error
(Msg
), N
);
5369 ----------------------
5370 -- Error_Pragma_Arg --
5371 ----------------------
5373 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5375 Error_Msg_Name_1
:= Pname
;
5376 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
5378 end Error_Pragma_Arg
;
5380 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5382 Error_Msg_Name_1
:= Pname
;
5383 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
5384 Error_Pragma_Arg
(Msg2
, Arg
);
5385 end Error_Pragma_Arg
;
5387 ----------------------------
5388 -- Error_Pragma_Arg_Ident --
5389 ----------------------------
5391 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5393 Error_Msg_Name_1
:= Pname
;
5394 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
5396 end Error_Pragma_Arg_Ident
;
5398 ----------------------
5399 -- Error_Pragma_Ref --
5400 ----------------------
5402 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5404 Error_Msg_Name_1
:= Pname
;
5405 Error_Msg_Sloc
:= Sloc
(Ref
);
5406 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
5408 end Error_Pragma_Ref
;
5410 ------------------------
5411 -- Find_Lib_Unit_Name --
5412 ------------------------
5414 function Find_Lib_Unit_Name
return Entity_Id
is
5416 -- Return inner compilation unit entity, for case of nested
5417 -- categorization pragmas. This happens in generic unit.
5419 if Nkind
(Parent
(N
)) = N_Package_Specification
5420 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5422 return Defining_Entity
(Parent
(N
));
5424 return Current_Scope
;
5426 end Find_Lib_Unit_Name
;
5428 ----------------------------
5429 -- Find_Program_Unit_Name --
5430 ----------------------------
5432 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5433 Unit_Name
: Entity_Id
;
5434 Unit_Kind
: Node_Kind
;
5435 P
: constant Node_Id
:= Parent
(N
);
5438 if Nkind
(P
) = N_Compilation_Unit
then
5439 Unit_Kind
:= Nkind
(Unit
(P
));
5441 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
5442 N_Package_Declaration
)
5443 or else Unit_Kind
in N_Generic_Declaration
5445 Unit_Name
:= Defining_Entity
(Unit
(P
));
5447 if Chars
(Id
) = Chars
(Unit_Name
) then
5448 Set_Entity
(Id
, Unit_Name
);
5449 Set_Etype
(Id
, Etype
(Unit_Name
));
5451 Set_Etype
(Id
, Any_Type
);
5453 ("cannot find program unit referenced by pragma%");
5457 Set_Etype
(Id
, Any_Type
);
5458 Error_Pragma
("pragma% inapplicable to this unit");
5464 end Find_Program_Unit_Name
;
5466 -----------------------------------------
5467 -- Find_Unique_Parameterless_Procedure --
5468 -----------------------------------------
5470 function Find_Unique_Parameterless_Procedure
5472 Arg
: Node_Id
) return Entity_Id
5474 Proc
: Entity_Id
:= Empty
;
5477 -- The body of this procedure needs some comments ???
5479 if not Is_Entity_Name
(Name
) then
5481 ("argument of pragma% must be entity name", Arg
);
5483 elsif not Is_Overloaded
(Name
) then
5484 Proc
:= Entity
(Name
);
5486 if Ekind
(Proc
) /= E_Procedure
5487 or else Present
(First_Formal
(Proc
))
5490 ("argument of pragma% must be parameterless procedure", Arg
);
5495 Found
: Boolean := False;
5497 Index
: Interp_Index
;
5500 Get_First_Interp
(Name
, Index
, It
);
5501 while Present
(It
.Nam
) loop
5504 if Ekind
(Proc
) = E_Procedure
5505 and then No
(First_Formal
(Proc
))
5509 Set_Entity
(Name
, Proc
);
5510 Set_Is_Overloaded
(Name
, False);
5513 ("ambiguous handler name for pragma% ", Arg
);
5517 Get_Next_Interp
(Index
, It
);
5522 ("argument of pragma% must be parameterless procedure",
5525 Proc
:= Entity
(Name
);
5531 end Find_Unique_Parameterless_Procedure
;
5537 function Fix_Error
(Msg
: String) return String is
5538 Res
: String (Msg
'Range) := Msg
;
5539 Res_Last
: Natural := Msg
'Last;
5543 -- If we have a rewriting of another pragma, go to that pragma
5545 if Is_Rewrite_Substitution
(N
)
5546 and then Nkind
(Original_Node
(N
)) = N_Pragma
5548 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
5551 -- Case where pragma comes from an aspect specification
5553 if From_Aspect_Specification
(N
) then
5555 -- Change appearence of "pragma" in message to "aspect"
5558 while J
<= Res_Last
- 5 loop
5559 if Res
(J
.. J
+ 5) = "pragma" then
5560 Res
(J
.. J
+ 5) := "aspect";
5568 -- Change "argument of" at start of message to "entity for"
5571 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
5573 Res
(Res
'First .. Res
'First + 9) := "entity for";
5574 Res
(Res
'First + 10 .. Res_Last
- 1) :=
5575 Res
(Res
'First + 11 .. Res_Last
);
5576 Res_Last
:= Res_Last
- 1;
5579 -- Change "argument" at start of message to "entity"
5582 and then Res
(Res
'First .. Res
'First + 7) = "argument"
5584 Res
(Res
'First .. Res
'First + 5) := "entity";
5585 Res
(Res
'First + 6 .. Res_Last
- 2) :=
5586 Res
(Res
'First + 8 .. Res_Last
);
5587 Res_Last
:= Res_Last
- 2;
5590 -- Get name from corresponding aspect
5592 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
5595 -- Return possibly modified message
5597 return Res
(Res
'First .. Res_Last
);
5600 -------------------------
5601 -- Gather_Associations --
5602 -------------------------
5604 procedure Gather_Associations
5606 Args
: out Args_List
)
5611 -- Initialize all parameters to Empty
5613 for J
in Args
'Range loop
5617 -- That's all we have to do if there are no argument associations
5619 if No
(Pragma_Argument_Associations
(N
)) then
5623 -- Otherwise first deal with any positional parameters present
5625 Arg
:= First
(Pragma_Argument_Associations
(N
));
5626 for Index
in Args
'Range loop
5627 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
5628 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5632 -- Positional parameters all processed, if any left, then we
5633 -- have too many positional parameters.
5635 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
5637 ("too many positional associations for pragma%", Arg
);
5640 -- Process named parameters if any are present
5642 while Present
(Arg
) loop
5643 if Chars
(Arg
) = No_Name
then
5645 ("positional association cannot follow named association",
5649 for Index
in Names
'Range loop
5650 if Names
(Index
) = Chars
(Arg
) then
5651 if Present
(Args
(Index
)) then
5653 ("duplicate argument association for pragma%", Arg
);
5655 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5660 if Index
= Names
'Last then
5661 Error_Msg_Name_1
:= Pname
;
5662 Error_Msg_N
("pragma% does not allow & argument", Arg
);
5664 -- Check for possible misspelling
5666 for Index1
in Names
'Range loop
5667 if Is_Bad_Spelling_Of
5668 (Chars
(Arg
), Names
(Index1
))
5670 Error_Msg_Name_1
:= Names
(Index1
);
5671 Error_Msg_N
-- CODEFIX
5672 ("\possible misspelling of%", Arg
);
5684 end Gather_Associations
;
5690 procedure GNAT_Pragma
is
5692 -- We need to check the No_Implementation_Pragmas restriction for
5693 -- the case of a pragma from source. Note that the case of aspects
5694 -- generating corresponding pragmas marks these pragmas as not being
5695 -- from source, so this test also catches that case.
5697 if Comes_From_Source
(N
) then
5698 Check_Restriction
(No_Implementation_Pragmas
, N
);
5702 --------------------------
5703 -- Is_Before_First_Decl --
5704 --------------------------
5706 function Is_Before_First_Decl
5707 (Pragma_Node
: Node_Id
;
5708 Decls
: List_Id
) return Boolean
5710 Item
: Node_Id
:= First
(Decls
);
5713 -- Only other pragmas can come before this pragma
5716 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
5719 elsif Item
= Pragma_Node
then
5725 end Is_Before_First_Decl
;
5727 -----------------------------
5728 -- Is_Configuration_Pragma --
5729 -----------------------------
5731 -- A configuration pragma must appear in the context clause of a
5732 -- compilation unit, and only other pragmas may precede it. Note that
5733 -- the test below also permits use in a configuration pragma file.
5735 function Is_Configuration_Pragma
return Boolean is
5736 Lis
: constant List_Id
:= List_Containing
(N
);
5737 Par
: constant Node_Id
:= Parent
(N
);
5741 -- If no parent, then we are in the configuration pragma file,
5742 -- so the placement is definitely appropriate.
5747 -- Otherwise we must be in the context clause of a compilation unit
5748 -- and the only thing allowed before us in the context list is more
5749 -- configuration pragmas.
5751 elsif Nkind
(Par
) = N_Compilation_Unit
5752 and then Context_Items
(Par
) = Lis
5759 elsif Nkind
(Prg
) /= N_Pragma
then
5769 end Is_Configuration_Pragma
;
5771 --------------------------
5772 -- Is_In_Context_Clause --
5773 --------------------------
5775 function Is_In_Context_Clause
return Boolean is
5777 Parent_Node
: Node_Id
;
5780 if not Is_List_Member
(N
) then
5784 Plist
:= List_Containing
(N
);
5785 Parent_Node
:= Parent
(Plist
);
5787 if Parent_Node
= Empty
5788 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
5789 or else Context_Items
(Parent_Node
) /= Plist
5796 end Is_In_Context_Clause
;
5798 ---------------------------------
5799 -- Is_Static_String_Expression --
5800 ---------------------------------
5802 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
5803 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5804 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
5807 Analyze_And_Resolve
(Argx
);
5809 -- Special case Ada 83, where the expression will never be static,
5810 -- but we will return true if we had a string literal to start with.
5812 if Ada_Version
= Ada_83
then
5815 -- Normal case, true only if we end up with a string literal that
5816 -- is marked as being the result of evaluating a static expression.
5819 return Is_OK_Static_Expression
(Argx
)
5820 and then Nkind
(Argx
) = N_String_Literal
;
5823 end Is_Static_String_Expression
;
5825 ----------------------
5826 -- Pragma_Misplaced --
5827 ----------------------
5829 procedure Pragma_Misplaced
is
5831 Error_Pragma
("incorrect placement of pragma%");
5832 end Pragma_Misplaced
;
5834 ------------------------------------------------
5835 -- Process_Atomic_Independent_Shared_Volatile --
5836 ------------------------------------------------
5838 procedure Process_Atomic_Independent_Shared_Volatile
is
5845 procedure Set_Atomic_Full
(E
: Entity_Id
);
5846 -- Set given type as Is_Atomic or Has_Volatile_Full_Access. Also, if
5847 -- no explicit alignment was given, set alignment to unknown, since
5848 -- back end knows what the alignment requirements are for atomic and
5849 -- full access arrays. Note: this is necessary for derived types.
5851 ---------------------
5852 -- Set_Atomic_Full --
5853 ---------------------
5855 procedure Set_Atomic_Full
(E
: Entity_Id
) is
5857 if Prag_Id
= Pragma_Volatile_Full_Access
then
5858 Set_Has_Volatile_Full_Access
(E
);
5863 if not Has_Alignment_Clause
(E
) then
5864 Set_Alignment
(E
, Uint_0
);
5866 end Set_Atomic_Full
;
5868 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
5871 Check_Ada_83_Warning
;
5872 Check_No_Identifiers
;
5873 Check_Arg_Count
(1);
5874 Check_Arg_Is_Local_Name
(Arg1
);
5875 E_Id
:= Get_Pragma_Arg
(Arg1
);
5877 if Etype
(E_Id
) = Any_Type
then
5882 D
:= Declaration_Node
(E
);
5885 -- Check duplicate before we chain ourselves
5887 Check_Duplicate_Pragma
(E
);
5889 -- Check Atomic and VFA used together
5891 if (Is_Atomic
(E
) and then Prag_Id
= Pragma_Volatile_Full_Access
)
5892 or else (Has_Volatile_Full_Access
(E
)
5893 and then (Prag_Id
= Pragma_Atomic
5895 Prag_Id
= Pragma_Shared
))
5898 ("cannot have Volatile_Full_Access and Atomic for same entity");
5901 -- Now check appropriateness of the entity
5904 if Rep_Item_Too_Early
(E
, N
)
5906 Rep_Item_Too_Late
(E
, N
)
5910 Check_First_Subtype
(Arg1
);
5913 -- Attribute belongs on the base type. If the view of the type is
5914 -- currently private, it also belongs on the underlying type.
5916 if Prag_Id
= Pragma_Atomic
5918 Prag_Id
= Pragma_Shared
5920 Prag_Id
= Pragma_Volatile_Full_Access
5922 Set_Atomic_Full
(E
);
5923 Set_Atomic_Full
(Base_Type
(E
));
5924 Set_Atomic_Full
(Underlying_Type
(E
));
5927 -- Atomic/Shared/Volatile_Full_Access imply Independent
5929 if Prag_Id
/= Pragma_Volatile
then
5930 Set_Is_Independent
(E
);
5931 Set_Is_Independent
(Base_Type
(E
));
5932 Set_Is_Independent
(Underlying_Type
(E
));
5934 if Prag_Id
= Pragma_Independent
then
5935 Record_Independence_Check
(N
, Base_Type
(E
));
5939 -- Atomic/Shared/Volatile_Full_Access imply Volatile
5941 if Prag_Id
/= Pragma_Independent
then
5942 Set_Is_Volatile
(E
);
5943 Set_Is_Volatile
(Base_Type
(E
));
5944 Set_Is_Volatile
(Underlying_Type
(E
));
5946 Set_Treat_As_Volatile
(E
);
5947 Set_Treat_As_Volatile
(Underlying_Type
(E
));
5950 elsif K
= N_Object_Declaration
5951 or else (K
= N_Component_Declaration
5952 and then Original_Record_Component
(E
) = E
)
5954 if Rep_Item_Too_Late
(E
, N
) then
5958 if Prag_Id
= Pragma_Atomic
5960 Prag_Id
= Pragma_Shared
5962 Prag_Id
= Pragma_Volatile_Full_Access
5964 if Prag_Id
= Pragma_Volatile_Full_Access
then
5965 Set_Has_Volatile_Full_Access
(E
);
5970 -- If the object declaration has an explicit initialization, a
5971 -- temporary may have to be created to hold the expression, to
5972 -- ensure that access to the object remain atomic.
5974 if Nkind
(Parent
(E
)) = N_Object_Declaration
5975 and then Present
(Expression
(Parent
(E
)))
5977 Set_Has_Delayed_Freeze
(E
);
5980 -- An interesting improvement here. If an object of composite
5981 -- type X is declared atomic, and the type X isn't, that's a
5982 -- pity, since it may not have appropriate alignment etc. We
5983 -- can rescue this in the special case where the object and
5984 -- type are in the same unit by just setting the type as
5985 -- atomic, so that the back end will process it as atomic.
5987 -- Note: we used to do this for elementary types as well,
5988 -- but that turns out to be a bad idea and can have unwanted
5989 -- effects, most notably if the type is elementary, the object
5990 -- a simple component within a record, and both are in a spec:
5991 -- every object of this type in the entire program will be
5992 -- treated as atomic, thus incurring a potentially costly
5993 -- synchronization operation for every access.
5995 -- For Volatile_Full_Access we can do this for elementary types
5996 -- too, since there is no issue of atomic synchronization.
5998 -- Of course it would be best if the back end could just adjust
5999 -- the alignment etc for the specific object, but that's not
6000 -- something we are capable of doing at this point.
6002 Utyp
:= Underlying_Type
(Etype
(E
));
6005 and then (Is_Composite_Type
(Utyp
)
6006 or else Prag_Id
= Pragma_Volatile_Full_Access
)
6007 and then Sloc
(E
) > No_Location
6008 and then Sloc
(Utyp
) > No_Location
6010 Get_Source_File_Index
(Sloc
(E
)) =
6011 Get_Source_File_Index
(Sloc
(Utyp
))
6013 if Prag_Id
= Pragma_Volatile_Full_Access
then
6014 Set_Has_Volatile_Full_Access
(Utyp
);
6016 Set_Is_Atomic
(Utyp
);
6021 -- Atomic/Shared/Volatile_Full_Access imply Independent
6023 if Prag_Id
/= Pragma_Volatile
then
6024 Set_Is_Independent
(E
);
6026 if Prag_Id
= Pragma_Independent
then
6027 Record_Independence_Check
(N
, E
);
6031 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6033 if Prag_Id
/= Pragma_Independent
then
6034 Set_Is_Volatile
(E
);
6035 Set_Treat_As_Volatile
(E
);
6039 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6042 -- The following check is only relevant when SPARK_Mode is on as
6043 -- this is not a standard Ada legality rule. Pragma Volatile can
6044 -- only apply to a full type declaration or an object declaration
6045 -- (SPARK RM C.6(1)).
6048 and then Prag_Id
= Pragma_Volatile
6049 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6050 N_Object_Declaration
)
6053 ("argument of pragma % must denote a full type or object "
6054 & "declaration", Arg1
);
6056 end Process_Atomic_Independent_Shared_Volatile
;
6058 -------------------------------------------
6059 -- Process_Compile_Time_Warning_Or_Error --
6060 -------------------------------------------
6062 procedure Process_Compile_Time_Warning_Or_Error
is
6063 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6066 Check_Arg_Count
(2);
6067 Check_No_Identifiers
;
6068 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6069 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6071 if Compile_Time_Known_Value
(Arg1x
) then
6072 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6074 Str
: constant String_Id
:=
6075 Strval
(Get_Pragma_Arg
(Arg2
));
6076 Len
: constant Int
:= String_Length
(Str
);
6081 Cent
: constant Entity_Id
:=
6082 Cunit_Entity
(Current_Sem_Unit
);
6084 Force
: constant Boolean :=
6085 Prag_Id
= Pragma_Compile_Time_Warning
6087 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6088 and then (Ekind
(Cent
) /= E_Package
6089 or else not In_Private_Part
(Cent
));
6090 -- Set True if this is the warning case, and we are in the
6091 -- visible part of a package spec, or in a subprogram spec,
6092 -- in which case we want to force the client to see the
6093 -- warning, even though it is not in the main unit.
6096 -- Loop through segments of message separated by line feeds.
6097 -- We output these segments as separate messages with
6098 -- continuation marks for all but the first.
6103 Error_Msg_Strlen
:= 0;
6105 -- Loop to copy characters from argument to error message
6109 exit when Ptr
> Len
;
6110 CC
:= Get_String_Char
(Str
, Ptr
);
6113 -- Ignore wide chars ??? else store character
6115 if In_Character_Range
(CC
) then
6116 C
:= Get_Character
(CC
);
6117 exit when C
= ASCII
.LF
;
6118 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6119 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6123 -- Here with one line ready to go
6125 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6127 -- If this is a warning in a spec, then we want clients
6128 -- to see the warning, so mark the message with the
6129 -- special sequence !! to force the warning. In the case
6130 -- of a package spec, we do not force this if we are in
6131 -- the private part of the spec.
6134 if Cont
= False then
6135 Error_Msg_N
("<<~!!", Arg1
);
6138 Error_Msg_N
("\<<~!!", Arg1
);
6141 -- Error, rather than warning, or in a body, so we do not
6142 -- need to force visibility for client (error will be
6143 -- output in any case, and this is the situation in which
6144 -- we do not want a client to get a warning, since the
6145 -- warning is in the body or the spec private part).
6148 if Cont
= False then
6149 Error_Msg_N
("<<~", Arg1
);
6152 Error_Msg_N
("\<<~", Arg1
);
6156 exit when Ptr
> Len
;
6161 end Process_Compile_Time_Warning_Or_Error
;
6163 ------------------------
6164 -- Process_Convention --
6165 ------------------------
6167 procedure Process_Convention
6168 (C
: out Convention_Id
;
6169 Ent
: out Entity_Id
)
6173 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6174 -- Called if we have more than one Export/Import/Convention pragma.
6175 -- This is generally illegal, but we have a special case of allowing
6176 -- Import and Interface to coexist if they specify the convention in
6177 -- a consistent manner. We are allowed to do this, since Interface is
6178 -- an implementation defined pragma, and we choose to do it since we
6179 -- know Rational allows this combination. S is the entity id of the
6180 -- subprogram in question. This procedure also sets the special flag
6181 -- Import_Interface_Present in both pragmas in the case where we do
6182 -- have matching Import and Interface pragmas.
6184 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6185 -- Set convention in entity E, and also flag that the entity has a
6186 -- convention pragma. If entity is for a private or incomplete type,
6187 -- also set convention and flag on underlying type. This procedure
6188 -- also deals with the special case of C_Pass_By_Copy convention,
6189 -- and error checks for inappropriate convention specification.
6191 -------------------------------
6192 -- Diagnose_Multiple_Pragmas --
6193 -------------------------------
6195 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6196 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6200 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6201 -- Decl is a pragma node. This function returns True if this
6202 -- pragma has a first argument that is an identifier with a
6203 -- Chars field corresponding to the Convention_Id C.
6205 function Same_Name
(Decl
: Node_Id
) return Boolean;
6206 -- Decl is a pragma node. This function returns True if this
6207 -- pragma has a second argument that is an identifier with a
6208 -- Chars field that matches the Chars of the current subprogram.
6210 ---------------------
6211 -- Same_Convention --
6212 ---------------------
6214 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6215 Arg1
: constant Node_Id
:=
6216 First
(Pragma_Argument_Associations
(Decl
));
6219 if Present
(Arg1
) then
6221 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6223 if Nkind
(Arg
) = N_Identifier
6224 and then Is_Convention_Name
(Chars
(Arg
))
6225 and then Get_Convention_Id
(Chars
(Arg
)) = C
6233 end Same_Convention
;
6239 function Same_Name
(Decl
: Node_Id
) return Boolean is
6240 Arg1
: constant Node_Id
:=
6241 First
(Pragma_Argument_Associations
(Decl
));
6249 Arg2
:= Next
(Arg1
);
6256 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6258 if Nkind
(Arg
) = N_Identifier
6259 and then Chars
(Arg
) = Chars
(S
)
6268 -- Start of processing for Diagnose_Multiple_Pragmas
6273 -- Definitely give message if we have Convention/Export here
6275 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6278 -- If we have an Import or Export, scan back from pragma to
6279 -- find any previous pragma applying to the same procedure.
6280 -- The scan will be terminated by the start of the list, or
6281 -- hitting the subprogram declaration. This won't allow one
6282 -- pragma to appear in the public part and one in the private
6283 -- part, but that seems very unlikely in practice.
6287 while Present
(Decl
) and then Decl
/= Pdec
loop
6289 -- Look for pragma with same name as us
6291 if Nkind
(Decl
) = N_Pragma
6292 and then Same_Name
(Decl
)
6294 -- Give error if same as our pragma or Export/Convention
6296 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6302 -- Case of Import/Interface or the other way round
6304 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6307 -- Here we know that we have Import and Interface. It
6308 -- doesn't matter which way round they are. See if
6309 -- they specify the same convention. If so, all OK,
6310 -- and set special flags to stop other messages
6312 if Same_Convention
(Decl
) then
6313 Set_Import_Interface_Present
(N
);
6314 Set_Import_Interface_Present
(Decl
);
6317 -- If different conventions, special message
6320 Error_Msg_Sloc
:= Sloc
(Decl
);
6322 ("convention differs from that given#", Arg1
);
6332 -- Give message if needed if we fall through those tests
6333 -- except on Relaxed_RM_Semantics where we let go: either this
6334 -- is a case accepted/ignored by other Ada compilers (e.g.
6335 -- a mix of Convention and Import), or another error will be
6336 -- generated later (e.g. using both Import and Export).
6338 if Err
and not Relaxed_RM_Semantics
then
6340 ("at most one Convention/Export/Import pragma is allowed",
6343 end Diagnose_Multiple_Pragmas
;
6345 --------------------------------
6346 -- Set_Convention_From_Pragma --
6347 --------------------------------
6349 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6351 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6352 -- for an overridden dispatching operation. Technically this is
6353 -- an amendment and should only be done in Ada 2005 mode. However,
6354 -- this is clearly a mistake, since the problem that is addressed
6355 -- by this AI is that there is a clear gap in the RM.
6357 if Is_Dispatching_Operation
(E
)
6358 and then Present
(Overridden_Operation
(E
))
6359 and then C
/= Convention
(Overridden_Operation
(E
))
6362 ("cannot change convention for overridden dispatching "
6363 & "operation", Arg1
);
6366 -- Special checks for Convention_Stdcall
6368 if C
= Convention_Stdcall
then
6370 -- A dispatching call is not allowed. A dispatching subprogram
6371 -- cannot be used to interface to the Win32 API, so in fact
6372 -- this check does not impose any effective restriction.
6374 if Is_Dispatching_Operation
(E
) then
6375 Error_Msg_Sloc
:= Sloc
(E
);
6377 -- Note: make this unconditional so that if there is more
6378 -- than one call to which the pragma applies, we get a
6379 -- message for each call. Also don't use Error_Pragma,
6380 -- so that we get multiple messages.
6383 ("dispatching subprogram# cannot use Stdcall convention!",
6386 -- Subprograms are not allowed
6388 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6392 and then Ekind
(E
) /= E_Variable
6394 -- An access to subprogram is also allowed
6398 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6400 -- Allow internal call to set convention of subprogram type
6402 and then not (Ekind
(E
) = E_Subprogram_Type
)
6405 ("second argument of pragma% must be subprogram (type)",
6410 -- Set the convention
6412 Set_Convention
(E
, C
);
6413 Set_Has_Convention_Pragma
(E
);
6415 -- For the case of a record base type, also set the convention of
6416 -- any anonymous access types declared in the record which do not
6417 -- currently have a specified convention.
6419 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6424 Comp
:= First_Component
(E
);
6425 while Present
(Comp
) loop
6426 if Present
(Etype
(Comp
))
6427 and then Ekind_In
(Etype
(Comp
),
6428 E_Anonymous_Access_Type
,
6429 E_Anonymous_Access_Subprogram_Type
)
6430 and then not Has_Convention_Pragma
(Comp
)
6432 Set_Convention
(Comp
, C
);
6435 Next_Component
(Comp
);
6440 -- Deal with incomplete/private type case, where underlying type
6441 -- is available, so set convention of that underlying type.
6443 if Is_Incomplete_Or_Private_Type
(E
)
6444 and then Present
(Underlying_Type
(E
))
6446 Set_Convention
(Underlying_Type
(E
), C
);
6447 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6450 -- A class-wide type should inherit the convention of the specific
6451 -- root type (although this isn't specified clearly by the RM).
6453 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6454 Set_Convention
(Class_Wide_Type
(E
), C
);
6457 -- If the entity is a record type, then check for special case of
6458 -- C_Pass_By_Copy, which is treated the same as C except that the
6459 -- special record flag is set. This convention is only permitted
6460 -- on record types (see AI95-00131).
6462 if Cname
= Name_C_Pass_By_Copy
then
6463 if Is_Record_Type
(E
) then
6464 Set_C_Pass_By_Copy
(Base_Type
(E
));
6465 elsif Is_Incomplete_Or_Private_Type
(E
)
6466 and then Is_Record_Type
(Underlying_Type
(E
))
6468 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6471 ("C_Pass_By_Copy convention allowed only for record type",
6476 -- If the entity is a derived boolean type, check for the special
6477 -- case of convention C, C++, or Fortran, where we consider any
6478 -- nonzero value to represent true.
6480 if Is_Discrete_Type
(E
)
6481 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6487 C
= Convention_Fortran
)
6489 Set_Nonzero_Is_True
(Base_Type
(E
));
6491 end Set_Convention_From_Pragma
;
6495 Comp_Unit
: Unit_Number_Type
;
6500 -- Start of processing for Process_Convention
6503 Check_At_Least_N_Arguments
(2);
6504 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6505 Check_Arg_Is_Identifier
(Arg1
);
6506 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6508 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6509 -- tested again below to set the critical flag).
6511 if Cname
= Name_C_Pass_By_Copy
then
6514 -- Otherwise we must have something in the standard convention list
6516 elsif Is_Convention_Name
(Cname
) then
6517 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6519 -- Otherwise warn on unrecognized convention
6522 if Warn_On_Export_Import
then
6524 ("??unrecognized convention name, C assumed",
6525 Get_Pragma_Arg
(Arg1
));
6531 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6532 Check_Arg_Is_Local_Name
(Arg2
);
6534 Id
:= Get_Pragma_Arg
(Arg2
);
6537 if not Is_Entity_Name
(Id
) then
6538 Error_Pragma_Arg
("entity name required", Arg2
);
6543 -- Set entity to return
6547 -- Ada_Pass_By_Copy special checking
6549 if C
= Convention_Ada_Pass_By_Copy
then
6550 if not Is_First_Subtype
(E
) then
6552 ("convention `Ada_Pass_By_Copy` only allowed for types",
6556 if Is_By_Reference_Type
(E
) then
6558 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6562 -- Ada_Pass_By_Reference special checking
6564 elsif C
= Convention_Ada_Pass_By_Reference
then
6565 if not Is_First_Subtype
(E
) then
6567 ("convention `Ada_Pass_By_Reference` only allowed for types",
6571 if Is_By_Copy_Type
(E
) then
6573 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6578 -- Go to renamed subprogram if present, since convention applies to
6579 -- the actual renamed entity, not to the renaming entity. If the
6580 -- subprogram is inherited, go to parent subprogram.
6582 if Is_Subprogram
(E
)
6583 and then Present
(Alias
(E
))
6585 if Nkind
(Parent
(Declaration_Node
(E
))) =
6586 N_Subprogram_Renaming_Declaration
6588 if Scope
(E
) /= Scope
(Alias
(E
)) then
6590 ("cannot apply pragma% to non-local entity&#", E
);
6595 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6596 N_Private_Extension_Declaration
)
6597 and then Scope
(E
) = Scope
(Alias
(E
))
6601 -- Return the parent subprogram the entity was inherited from
6607 -- Check that we are not applying this to a specless body. Relax this
6608 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
6610 if Is_Subprogram
(E
)
6611 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6612 and then not Relaxed_RM_Semantics
6615 ("pragma% requires separate spec and must come before body");
6618 -- Check that we are not applying this to a named constant
6620 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6621 Error_Msg_Name_1
:= Pname
;
6623 ("cannot apply pragma% to named constant!",
6624 Get_Pragma_Arg
(Arg2
));
6626 ("\supply appropriate type for&!", Arg2
);
6629 if Ekind
(E
) = E_Enumeration_Literal
then
6630 Error_Pragma
("enumeration literal not allowed for pragma%");
6633 -- Check for rep item appearing too early or too late
6635 if Etype
(E
) = Any_Type
6636 or else Rep_Item_Too_Early
(E
, N
)
6640 elsif Present
(Underlying_Type
(E
)) then
6641 E
:= Underlying_Type
(E
);
6644 if Rep_Item_Too_Late
(E
, N
) then
6648 if Has_Convention_Pragma
(E
) then
6649 Diagnose_Multiple_Pragmas
(E
);
6651 elsif Convention
(E
) = Convention_Protected
6652 or else Ekind
(Scope
(E
)) = E_Protected_Type
6655 ("a protected operation cannot be given a different convention",
6659 -- For Intrinsic, a subprogram is required
6661 if C
= Convention_Intrinsic
6662 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
6665 ("second argument of pragma% must be a subprogram", Arg2
);
6668 -- Deal with non-subprogram cases
6670 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
6671 Set_Convention_From_Pragma
(E
);
6675 -- The pragma must apply to a first subtype, but it can also
6676 -- apply to a generic type in a generic formal part, in which
6677 -- case it will also appear in the corresponding instance.
6679 if Is_Generic_Type
(E
) or else In_Instance
then
6682 Check_First_Subtype
(Arg2
);
6685 Set_Convention_From_Pragma
(Base_Type
(E
));
6687 -- For access subprograms, we must set the convention on the
6688 -- internally generated directly designated type as well.
6690 if Ekind
(E
) = E_Access_Subprogram_Type
then
6691 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
6695 -- For the subprogram case, set proper convention for all homonyms
6696 -- in same scope and the same declarative part, i.e. the same
6697 -- compilation unit.
6700 Comp_Unit
:= Get_Source_Unit
(E
);
6701 Set_Convention_From_Pragma
(E
);
6703 -- Treat a pragma Import as an implicit body, and pragma import
6704 -- as implicit reference (for navigation in GPS).
6706 if Prag_Id
= Pragma_Import
then
6707 Generate_Reference
(E
, Id
, 'b');
6709 -- For exported entities we restrict the generation of references
6710 -- to entities exported to foreign languages since entities
6711 -- exported to Ada do not provide further information to GPS and
6712 -- add undesired references to the output of the gnatxref tool.
6714 elsif Prag_Id
= Pragma_Export
6715 and then Convention
(E
) /= Convention_Ada
6717 Generate_Reference
(E
, Id
, 'i');
6720 -- If the pragma comes from from an aspect, it only applies to the
6721 -- given entity, not its homonyms.
6723 if From_Aspect_Specification
(N
) then
6727 -- Otherwise Loop through the homonyms of the pragma argument's
6728 -- entity, an apply convention to those in the current scope.
6734 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
6736 -- Ignore entry for which convention is already set
6738 if Has_Convention_Pragma
(E1
) then
6742 -- Do not set the pragma on inherited operations or on formal
6745 if Comes_From_Source
(E1
)
6746 and then Comp_Unit
= Get_Source_Unit
(E1
)
6747 and then not Is_Formal_Subprogram
(E1
)
6748 and then Nkind
(Original_Node
(Parent
(E1
))) /=
6749 N_Full_Type_Declaration
6751 if Present
(Alias
(E1
))
6752 and then Scope
(E1
) /= Scope
(Alias
(E1
))
6755 ("cannot apply pragma% to non-local entity& declared#",
6759 Set_Convention_From_Pragma
(E1
);
6761 if Prag_Id
= Pragma_Import
then
6762 Generate_Reference
(E1
, Id
, 'b');
6770 end Process_Convention
;
6772 ----------------------------------------
6773 -- Process_Disable_Enable_Atomic_Sync --
6774 ----------------------------------------
6776 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
6778 Check_No_Identifiers
;
6779 Check_At_Most_N_Arguments
(1);
6781 -- Modeled internally as
6782 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
6786 Pragma_Identifier
=>
6787 Make_Identifier
(Loc
, Nam
),
6788 Pragma_Argument_Associations
=> New_List
(
6789 Make_Pragma_Argument_Association
(Loc
,
6791 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
6793 if Present
(Arg1
) then
6794 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
6798 end Process_Disable_Enable_Atomic_Sync
;
6800 -------------------------------------------------
6801 -- Process_Extended_Import_Export_Internal_Arg --
6802 -------------------------------------------------
6804 procedure Process_Extended_Import_Export_Internal_Arg
6805 (Arg_Internal
: Node_Id
:= Empty
)
6808 if No
(Arg_Internal
) then
6809 Error_Pragma
("Internal parameter required for pragma%");
6812 if Nkind
(Arg_Internal
) = N_Identifier
then
6815 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
6816 and then (Prag_Id
= Pragma_Import_Function
6818 Prag_Id
= Pragma_Export_Function
)
6824 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
6827 Check_Arg_Is_Local_Name
(Arg_Internal
);
6828 end Process_Extended_Import_Export_Internal_Arg
;
6830 --------------------------------------------------
6831 -- Process_Extended_Import_Export_Object_Pragma --
6832 --------------------------------------------------
6834 procedure Process_Extended_Import_Export_Object_Pragma
6835 (Arg_Internal
: Node_Id
;
6836 Arg_External
: Node_Id
;
6842 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
6843 Def_Id
:= Entity
(Arg_Internal
);
6845 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
6847 ("pragma% must designate an object", Arg_Internal
);
6850 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
6852 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
6855 ("previous Common/Psect_Object applies, pragma % not permitted",
6859 if Rep_Item_Too_Late
(Def_Id
, N
) then
6863 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
6865 if Present
(Arg_Size
) then
6866 Check_Arg_Is_External_Name
(Arg_Size
);
6869 -- Export_Object case
6871 if Prag_Id
= Pragma_Export_Object
then
6872 if not Is_Library_Level_Entity
(Def_Id
) then
6874 ("argument for pragma% must be library level entity",
6878 if Ekind
(Current_Scope
) = E_Generic_Package
then
6879 Error_Pragma
("pragma& cannot appear in a generic unit");
6882 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
6884 ("exported object must have compile time known size",
6888 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
6889 Error_Msg_N
("??duplicate Export_Object pragma", N
);
6891 Set_Exported
(Def_Id
, Arg_Internal
);
6894 -- Import_Object case
6897 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
6899 ("cannot use pragma% for task/protected object",
6903 if Ekind
(Def_Id
) = E_Constant
then
6905 ("cannot import a constant", Arg_Internal
);
6908 if Warn_On_Export_Import
6909 and then Has_Discriminants
(Etype
(Def_Id
))
6912 ("imported value must be initialized??", Arg_Internal
);
6915 if Warn_On_Export_Import
6916 and then Is_Access_Type
(Etype
(Def_Id
))
6919 ("cannot import object of an access type??", Arg_Internal
);
6922 if Warn_On_Export_Import
6923 and then Is_Imported
(Def_Id
)
6925 Error_Msg_N
("??duplicate Import_Object pragma", N
);
6927 -- Check for explicit initialization present. Note that an
6928 -- initialization generated by the code generator, e.g. for an
6929 -- access type, does not count here.
6931 elsif Present
(Expression
(Parent
(Def_Id
)))
6934 (Original_Node
(Expression
(Parent
(Def_Id
))))
6936 Error_Msg_Sloc
:= Sloc
(Def_Id
);
6938 ("imported entities cannot be initialized (RM B.1(24))",
6939 "\no initialization allowed for & declared#", Arg1
);
6941 Set_Imported
(Def_Id
);
6942 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
6945 end Process_Extended_Import_Export_Object_Pragma
;
6947 ------------------------------------------------------
6948 -- Process_Extended_Import_Export_Subprogram_Pragma --
6949 ------------------------------------------------------
6951 procedure Process_Extended_Import_Export_Subprogram_Pragma
6952 (Arg_Internal
: Node_Id
;
6953 Arg_External
: Node_Id
;
6954 Arg_Parameter_Types
: Node_Id
;
6955 Arg_Result_Type
: Node_Id
:= Empty
;
6956 Arg_Mechanism
: Node_Id
;
6957 Arg_Result_Mechanism
: Node_Id
:= Empty
)
6963 Ambiguous
: Boolean;
6966 function Same_Base_Type
6968 Formal
: Entity_Id
) return Boolean;
6969 -- Determines if Ptype references the type of Formal. Note that only
6970 -- the base types need to match according to the spec. Ptype here is
6971 -- the argument from the pragma, which is either a type name, or an
6972 -- access attribute.
6974 --------------------
6975 -- Same_Base_Type --
6976 --------------------
6978 function Same_Base_Type
6980 Formal
: Entity_Id
) return Boolean
6982 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
6986 -- Case where pragma argument is typ'Access
6988 if Nkind
(Ptype
) = N_Attribute_Reference
6989 and then Attribute_Name
(Ptype
) = Name_Access
6991 Pref
:= Prefix
(Ptype
);
6994 if not Is_Entity_Name
(Pref
)
6995 or else Entity
(Pref
) = Any_Type
7000 -- We have a match if the corresponding argument is of an
7001 -- anonymous access type, and its designated type matches the
7002 -- type of the prefix of the access attribute
7004 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7005 and then Base_Type
(Entity
(Pref
)) =
7006 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7008 -- Case where pragma argument is a type name
7013 if not Is_Entity_Name
(Ptype
)
7014 or else Entity
(Ptype
) = Any_Type
7019 -- We have a match if the corresponding argument is of the type
7020 -- given in the pragma (comparing base types)
7022 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7026 -- Start of processing for
7027 -- Process_Extended_Import_Export_Subprogram_Pragma
7030 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7034 -- Loop through homonyms (overloadings) of the entity
7036 Hom_Id
:= Entity
(Arg_Internal
);
7037 while Present
(Hom_Id
) loop
7038 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7040 -- We need a subprogram in the current scope
7042 if not Is_Subprogram
(Def_Id
)
7043 or else Scope
(Def_Id
) /= Current_Scope
7050 -- Pragma cannot apply to subprogram body
7052 if Is_Subprogram
(Def_Id
)
7053 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7057 ("pragma% requires separate spec"
7058 & " and must come before body");
7061 -- Test result type if given, note that the result type
7062 -- parameter can only be present for the function cases.
7064 if Present
(Arg_Result_Type
)
7065 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7069 elsif Etype
(Def_Id
) /= Standard_Void_Type
7071 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7075 -- Test parameter types if given. Note that this parameter
7076 -- has not been analyzed (and must not be, since it is
7077 -- semantic nonsense), so we get it as the parser left it.
7079 elsif Present
(Arg_Parameter_Types
) then
7080 Check_Matching_Types
: declare
7085 Formal
:= First_Formal
(Def_Id
);
7087 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7088 if Present
(Formal
) then
7092 -- A list of one type, e.g. (List) is parsed as
7093 -- a parenthesized expression.
7095 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7096 and then Paren_Count
(Arg_Parameter_Types
) = 1
7099 or else Present
(Next_Formal
(Formal
))
7104 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7107 -- A list of more than one type is parsed as a aggregate
7109 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7110 and then Paren_Count
(Arg_Parameter_Types
) = 0
7112 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7113 while Present
(Ptype
) or else Present
(Formal
) loop
7116 or else not Same_Base_Type
(Ptype
, Formal
)
7121 Next_Formal
(Formal
);
7126 -- Anything else is of the wrong form
7130 ("wrong form for Parameter_Types parameter",
7131 Arg_Parameter_Types
);
7133 end Check_Matching_Types
;
7136 -- Match is now False if the entry we found did not match
7137 -- either a supplied Parameter_Types or Result_Types argument
7143 -- Ambiguous case, the flag Ambiguous shows if we already
7144 -- detected this and output the initial messages.
7147 if not Ambiguous
then
7149 Error_Msg_Name_1
:= Pname
;
7151 ("pragma% does not uniquely identify subprogram!",
7153 Error_Msg_Sloc
:= Sloc
(Ent
);
7154 Error_Msg_N
("matching subprogram #!", N
);
7158 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7159 Error_Msg_N
("matching subprogram #!", N
);
7164 Hom_Id
:= Homonym
(Hom_Id
);
7167 -- See if we found an entry
7170 if not Ambiguous
then
7171 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7173 ("pragma% cannot be given for generic subprogram");
7176 ("pragma% does not identify local subprogram");
7183 -- Import pragmas must be for imported entities
7185 if Prag_Id
= Pragma_Import_Function
7187 Prag_Id
= Pragma_Import_Procedure
7189 Prag_Id
= Pragma_Import_Valued_Procedure
7191 if not Is_Imported
(Ent
) then
7193 ("pragma Import or Interface must precede pragma%");
7196 -- Here we have the Export case which can set the entity as exported
7198 -- But does not do so if the specified external name is null, since
7199 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7200 -- compatible) to request no external name.
7202 elsif Nkind
(Arg_External
) = N_String_Literal
7203 and then String_Length
(Strval
(Arg_External
)) = 0
7207 -- In all other cases, set entity as exported
7210 Set_Exported
(Ent
, Arg_Internal
);
7213 -- Special processing for Valued_Procedure cases
7215 if Prag_Id
= Pragma_Import_Valued_Procedure
7217 Prag_Id
= Pragma_Export_Valued_Procedure
7219 Formal
:= First_Formal
(Ent
);
7222 Error_Pragma
("at least one parameter required for pragma%");
7224 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7225 Error_Pragma
("first parameter must have mode out for pragma%");
7228 Set_Is_Valued_Procedure
(Ent
);
7232 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7234 -- Process Result_Mechanism argument if present. We have already
7235 -- checked that this is only allowed for the function case.
7237 if Present
(Arg_Result_Mechanism
) then
7238 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7241 -- Process Mechanism parameter if present. Note that this parameter
7242 -- is not analyzed, and must not be analyzed since it is semantic
7243 -- nonsense, so we get it in exactly as the parser left it.
7245 if Present
(Arg_Mechanism
) then
7253 -- A single mechanism association without a formal parameter
7254 -- name is parsed as a parenthesized expression. All other
7255 -- cases are parsed as aggregates, so we rewrite the single
7256 -- parameter case as an aggregate for consistency.
7258 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7259 and then Paren_Count
(Arg_Mechanism
) = 1
7261 Rewrite
(Arg_Mechanism
,
7262 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7263 Expressions
=> New_List
(
7264 Relocate_Node
(Arg_Mechanism
))));
7267 -- Case of only mechanism name given, applies to all formals
7269 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7270 Formal
:= First_Formal
(Ent
);
7271 while Present
(Formal
) loop
7272 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7273 Next_Formal
(Formal
);
7276 -- Case of list of mechanism associations given
7279 if Null_Record_Present
(Arg_Mechanism
) then
7281 ("inappropriate form for Mechanism parameter",
7285 -- Deal with positional ones first
7287 Formal
:= First_Formal
(Ent
);
7289 if Present
(Expressions
(Arg_Mechanism
)) then
7290 Mname
:= First
(Expressions
(Arg_Mechanism
));
7291 while Present
(Mname
) loop
7294 ("too many mechanism associations", Mname
);
7297 Set_Mechanism_Value
(Formal
, Mname
);
7298 Next_Formal
(Formal
);
7303 -- Deal with named entries
7305 if Present
(Component_Associations
(Arg_Mechanism
)) then
7306 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7307 while Present
(Massoc
) loop
7308 Choice
:= First
(Choices
(Massoc
));
7310 if Nkind
(Choice
) /= N_Identifier
7311 or else Present
(Next
(Choice
))
7314 ("incorrect form for mechanism association",
7318 Formal
:= First_Formal
(Ent
);
7322 ("parameter name & not present", Choice
);
7325 if Chars
(Choice
) = Chars
(Formal
) then
7327 (Formal
, Expression
(Massoc
));
7329 -- Set entity on identifier (needed by ASIS)
7331 Set_Entity
(Choice
, Formal
);
7336 Next_Formal
(Formal
);
7345 end Process_Extended_Import_Export_Subprogram_Pragma
;
7347 --------------------------
7348 -- Process_Generic_List --
7349 --------------------------
7351 procedure Process_Generic_List
is
7356 Check_No_Identifiers
;
7357 Check_At_Least_N_Arguments
(1);
7359 -- Check all arguments are names of generic units or instances
7362 while Present
(Arg
) loop
7363 Exp
:= Get_Pragma_Arg
(Arg
);
7366 if not Is_Entity_Name
(Exp
)
7368 (not Is_Generic_Instance
(Entity
(Exp
))
7370 not Is_Generic_Unit
(Entity
(Exp
)))
7373 ("pragma% argument must be name of generic unit/instance",
7379 end Process_Generic_List
;
7381 ------------------------------------
7382 -- Process_Import_Predefined_Type --
7383 ------------------------------------
7385 procedure Process_Import_Predefined_Type
is
7386 Loc
: constant Source_Ptr
:= Sloc
(N
);
7388 Ftyp
: Node_Id
:= Empty
;
7394 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7397 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7398 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7402 Ftyp
:= Node
(Elmt
);
7404 if Present
(Ftyp
) then
7406 -- Don't build a derived type declaration, because predefined C
7407 -- types have no declaration anywhere, so cannot really be named.
7408 -- Instead build a full type declaration, starting with an
7409 -- appropriate type definition is built
7411 if Is_Floating_Point_Type
(Ftyp
) then
7412 Def
:= Make_Floating_Point_Definition
(Loc
,
7413 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7414 Make_Real_Range_Specification
(Loc
,
7415 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7416 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7418 -- Should never have a predefined type we cannot handle
7421 raise Program_Error
;
7424 -- Build and insert a Full_Type_Declaration, which will be
7425 -- analyzed as soon as this list entry has been analyzed.
7427 Decl
:= Make_Full_Type_Declaration
(Loc
,
7428 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7429 Type_Definition
=> Def
);
7431 Insert_After
(N
, Decl
);
7432 Mark_Rewrite_Insertion
(Decl
);
7435 Error_Pragma_Arg
("no matching type found for pragma%",
7438 end Process_Import_Predefined_Type
;
7440 ---------------------------------
7441 -- Process_Import_Or_Interface --
7442 ---------------------------------
7444 procedure Process_Import_Or_Interface
is
7450 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7451 -- pragma Import (Entity, "external name");
7453 if Relaxed_RM_Semantics
7454 and then Arg_Count
= 2
7455 and then Prag_Id
= Pragma_Import
7456 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7459 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7462 if not Is_Entity_Name
(Def_Id
) then
7463 Error_Pragma_Arg
("entity name required", Arg1
);
7466 Def_Id
:= Entity
(Def_Id
);
7467 Kill_Size_Check_Code
(Def_Id
);
7468 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7471 Process_Convention
(C
, Def_Id
);
7472 Kill_Size_Check_Code
(Def_Id
);
7473 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7476 -- Various error checks
7478 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7480 -- We do not permit Import to apply to a renaming declaration
7482 if Present
(Renamed_Object
(Def_Id
)) then
7484 ("pragma% not allowed for object renaming", Arg2
);
7486 -- User initialization is not allowed for imported object, but
7487 -- the object declaration may contain a default initialization,
7488 -- that will be discarded. Note that an explicit initialization
7489 -- only counts if it comes from source, otherwise it is simply
7490 -- the code generator making an implicit initialization explicit.
7492 elsif Present
(Expression
(Parent
(Def_Id
)))
7493 and then Comes_From_Source
7494 (Original_Node
(Expression
(Parent
(Def_Id
))))
7496 -- Set imported flag to prevent cascaded errors
7498 Set_Is_Imported
(Def_Id
);
7500 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7502 ("no initialization allowed for declaration of& #",
7503 "\imported entities cannot be initialized (RM B.1(24))",
7507 -- If the pragma comes from an aspect specification the
7508 -- Is_Imported flag has already been set.
7510 if not From_Aspect_Specification
(N
) then
7511 Set_Imported
(Def_Id
);
7514 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7516 -- Note that we do not set Is_Public here. That's because we
7517 -- only want to set it if there is no address clause, and we
7518 -- don't know that yet, so we delay that processing till
7521 -- pragma Import completes deferred constants
7523 if Ekind
(Def_Id
) = E_Constant
then
7524 Set_Has_Completion
(Def_Id
);
7527 -- It is not possible to import a constant of an unconstrained
7528 -- array type (e.g. string) because there is no simple way to
7529 -- write a meaningful subtype for it.
7531 if Is_Array_Type
(Etype
(Def_Id
))
7532 and then not Is_Constrained
(Etype
(Def_Id
))
7535 ("imported constant& must have a constrained subtype",
7540 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7542 -- If the name is overloaded, pragma applies to all of the denoted
7543 -- entities in the same declarative part, unless the pragma comes
7544 -- from an aspect specification or was generated by the compiler
7545 -- (such as for pragma Provide_Shift_Operators).
7548 while Present
(Hom_Id
) loop
7550 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7552 -- Ignore inherited subprograms because the pragma will apply
7553 -- to the parent operation, which is the one called.
7555 if Is_Overloadable
(Def_Id
)
7556 and then Present
(Alias
(Def_Id
))
7560 -- If it is not a subprogram, it must be in an outer scope and
7561 -- pragma does not apply.
7563 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7566 -- The pragma does not apply to primitives of interfaces
7568 elsif Is_Dispatching_Operation
(Def_Id
)
7569 and then Present
(Find_Dispatching_Type
(Def_Id
))
7570 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
7574 -- Verify that the homonym is in the same declarative part (not
7575 -- just the same scope). If the pragma comes from an aspect
7576 -- specification we know that it is part of the declaration.
7578 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
7579 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
7580 and then not From_Aspect_Specification
(N
)
7585 -- If the pragma comes from an aspect specification the
7586 -- Is_Imported flag has already been set.
7588 if not From_Aspect_Specification
(N
) then
7589 Set_Imported
(Def_Id
);
7592 -- Reject an Import applied to an abstract subprogram
7594 if Is_Subprogram
(Def_Id
)
7595 and then Is_Abstract_Subprogram
(Def_Id
)
7597 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7599 ("cannot import abstract subprogram& declared#",
7603 -- Special processing for Convention_Intrinsic
7605 if C
= Convention_Intrinsic
then
7607 -- Link_Name argument not allowed for intrinsic
7611 Set_Is_Intrinsic_Subprogram
(Def_Id
);
7613 -- If no external name is present, then check that this
7614 -- is a valid intrinsic subprogram. If an external name
7615 -- is present, then this is handled by the back end.
7618 Check_Intrinsic_Subprogram
7619 (Def_Id
, Get_Pragma_Arg
(Arg2
));
7623 -- Verify that the subprogram does not have a completion
7624 -- through a renaming declaration. For other completions the
7625 -- pragma appears as a too late representation.
7628 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
7632 and then Nkind
(Decl
) = N_Subprogram_Declaration
7633 and then Present
(Corresponding_Body
(Decl
))
7634 and then Nkind
(Unit_Declaration_Node
7635 (Corresponding_Body
(Decl
))) =
7636 N_Subprogram_Renaming_Declaration
7638 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7640 ("cannot import&, renaming already provided for "
7641 & "declaration #", N
, Def_Id
);
7645 -- If the pragma comes from an aspect specification, there
7646 -- must be an Import aspect specified as well. In the rare
7647 -- case where Import is set to False, the suprogram needs to
7648 -- have a local completion.
7651 Imp_Aspect
: constant Node_Id
:=
7652 Find_Aspect
(Def_Id
, Aspect_Import
);
7656 if Present
(Imp_Aspect
)
7657 and then Present
(Expression
(Imp_Aspect
))
7659 Expr
:= Expression
(Imp_Aspect
);
7660 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
7662 if Is_Entity_Name
(Expr
)
7663 and then Entity
(Expr
) = Standard_True
7665 Set_Has_Completion
(Def_Id
);
7668 -- If there is no expression, the default is True, as for
7669 -- all boolean aspects. Same for the older pragma.
7672 Set_Has_Completion
(Def_Id
);
7676 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7679 if Is_Compilation_Unit
(Hom_Id
) then
7681 -- Its possible homonyms are not affected by the pragma.
7682 -- Such homonyms might be present in the context of other
7683 -- units being compiled.
7687 elsif From_Aspect_Specification
(N
) then
7690 -- If the pragma was created by the compiler, then we don't
7691 -- want it to apply to other homonyms. This kind of case can
7692 -- occur when using pragma Provide_Shift_Operators, which
7693 -- generates implicit shift and rotate operators with Import
7694 -- pragmas that might apply to earlier explicit or implicit
7695 -- declarations marked with Import (for example, coming from
7696 -- an earlier pragma Provide_Shift_Operators for another type),
7697 -- and we don't generally want other homonyms being treated
7698 -- as imported or the pragma flagged as an illegal duplicate.
7700 elsif not Comes_From_Source
(N
) then
7704 Hom_Id
:= Homonym
(Hom_Id
);
7708 -- When the convention is Java or CIL, we also allow Import to
7709 -- be given for packages, generic packages, exceptions, record
7710 -- components, and access to subprograms.
7712 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
7714 (Is_Package_Or_Generic_Package
(Def_Id
)
7715 or else Ekind
(Def_Id
) = E_Exception
7716 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
7717 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
7719 Set_Imported
(Def_Id
);
7720 Set_Is_Public
(Def_Id
);
7721 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7723 -- Import a CPP class
7725 elsif C
= Convention_CPP
7726 and then (Is_Record_Type
(Def_Id
)
7727 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
7729 if Ekind
(Def_Id
) = E_Incomplete_Type
then
7730 if Present
(Full_View
(Def_Id
)) then
7731 Def_Id
:= Full_View
(Def_Id
);
7735 ("cannot import 'C'P'P type before full declaration seen",
7736 Get_Pragma_Arg
(Arg2
));
7738 -- Although we have reported the error we decorate it as
7739 -- CPP_Class to avoid reporting spurious errors
7741 Set_Is_CPP_Class
(Def_Id
);
7746 -- Types treated as CPP classes must be declared limited (note:
7747 -- this used to be a warning but there is no real benefit to it
7748 -- since we did effectively intend to treat the type as limited
7751 if not Is_Limited_Type
(Def_Id
) then
7753 ("imported 'C'P'P type must be limited",
7754 Get_Pragma_Arg
(Arg2
));
7757 if Etype
(Def_Id
) /= Def_Id
7758 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
7760 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
7763 Set_Is_CPP_Class
(Def_Id
);
7765 -- Imported CPP types must not have discriminants (because C++
7766 -- classes do not have discriminants).
7768 if Has_Discriminants
(Def_Id
) then
7770 ("imported 'C'P'P type cannot have discriminants",
7771 First
(Discriminant_Specifications
7772 (Declaration_Node
(Def_Id
))));
7775 -- Check that components of imported CPP types do not have default
7776 -- expressions. For private types this check is performed when the
7777 -- full view is analyzed (see Process_Full_View).
7779 if not Is_Private_Type
(Def_Id
) then
7780 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
7783 -- Import a CPP exception
7785 elsif C
= Convention_CPP
7786 and then Ekind
(Def_Id
) = E_Exception
7790 ("'External_'Name arguments is required for 'Cpp exception",
7793 -- As only a string is allowed, Check_Arg_Is_External_Name
7796 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
7799 if Present
(Arg4
) then
7801 ("Link_Name argument not allowed for imported Cpp exception",
7805 -- Do not call Set_Interface_Name as the name of the exception
7806 -- shouldn't be modified (and in particular it shouldn't be
7807 -- the External_Name). For exceptions, the External_Name is the
7808 -- name of the RTTI structure.
7810 -- ??? Emit an error if pragma Import/Export_Exception is present
7812 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
7814 Check_Arg_Count
(3);
7815 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
7817 Process_Import_Predefined_Type
;
7821 ("second argument of pragma% must be object, subprogram "
7822 & "or incomplete type",
7826 -- If this pragma applies to a compilation unit, then the unit, which
7827 -- is a subprogram, does not require (or allow) a body. We also do
7828 -- not need to elaborate imported procedures.
7830 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
7832 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
7834 Set_Body_Required
(Cunit
, False);
7837 end Process_Import_Or_Interface
;
7839 --------------------
7840 -- Process_Inline --
7841 --------------------
7843 procedure Process_Inline
(Status
: Inline_Status
) is
7850 procedure Make_Inline
(Subp
: Entity_Id
);
7851 -- Subp is the defining unit name of the subprogram declaration. Set
7852 -- the flag, as well as the flag in the corresponding body, if there
7855 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
7856 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
7857 -- Has_Pragma_Inline_Always for the Inline_Always case.
7859 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
7860 -- Returns True if it can be determined at this stage that inlining
7861 -- is not possible, for example if the body is available and contains
7862 -- exception handlers, we prevent inlining, since otherwise we can
7863 -- get undefined symbols at link time. This function also emits a
7864 -- warning if front-end inlining is enabled and the pragma appears
7867 -- ??? is business with link symbols still valid, or does it relate
7868 -- to front end ZCX which is being phased out ???
7870 ---------------------------
7871 -- Inlining_Not_Possible --
7872 ---------------------------
7874 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
7875 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
7879 if Nkind
(Decl
) = N_Subprogram_Body
then
7880 Stats
:= Handled_Statement_Sequence
(Decl
);
7881 return Present
(Exception_Handlers
(Stats
))
7882 or else Present
(At_End_Proc
(Stats
));
7884 elsif Nkind
(Decl
) = N_Subprogram_Declaration
7885 and then Present
(Corresponding_Body
(Decl
))
7887 if Front_End_Inlining
7888 and then Analyzed
(Corresponding_Body
(Decl
))
7890 Error_Msg_N
("pragma appears too late, ignored??", N
);
7893 -- If the subprogram is a renaming as body, the body is just a
7894 -- call to the renamed subprogram, and inlining is trivially
7898 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
7899 N_Subprogram_Renaming_Declaration
7905 Handled_Statement_Sequence
7906 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
7909 Present
(Exception_Handlers
(Stats
))
7910 or else Present
(At_End_Proc
(Stats
));
7914 -- If body is not available, assume the best, the check is
7915 -- performed again when compiling enclosing package bodies.
7919 end Inlining_Not_Possible
;
7925 procedure Make_Inline
(Subp
: Entity_Id
) is
7926 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
7927 Inner_Subp
: Entity_Id
:= Subp
;
7930 -- Ignore if bad type, avoid cascaded error
7932 if Etype
(Subp
) = Any_Type
then
7936 -- If inlining is not possible, for now do not treat as an error
7938 elsif Status
/= Suppressed
7939 and then Inlining_Not_Possible
(Subp
)
7944 -- Here we have a candidate for inlining, but we must exclude
7945 -- derived operations. Otherwise we would end up trying to inline
7946 -- a phantom declaration, and the result would be to drag in a
7947 -- body which has no direct inlining associated with it. That
7948 -- would not only be inefficient but would also result in the
7949 -- backend doing cross-unit inlining in cases where it was
7950 -- definitely inappropriate to do so.
7952 -- However, a simple Comes_From_Source test is insufficient, since
7953 -- we do want to allow inlining of generic instances which also do
7954 -- not come from source. We also need to recognize specs generated
7955 -- by the front-end for bodies that carry the pragma. Finally,
7956 -- predefined operators do not come from source but are not
7957 -- inlineable either.
7959 elsif Is_Generic_Instance
(Subp
)
7960 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
7964 elsif not Comes_From_Source
(Subp
)
7965 and then Scope
(Subp
) /= Standard_Standard
7971 -- The referenced entity must either be the enclosing entity, or
7972 -- an entity declared within the current open scope.
7974 if Present
(Scope
(Subp
))
7975 and then Scope
(Subp
) /= Current_Scope
7976 and then Subp
/= Current_Scope
7979 ("argument of% must be entity in current scope", Assoc
);
7983 -- Processing for procedure, operator or function. If subprogram
7984 -- is aliased (as for an instance) indicate that the renamed
7985 -- entity (if declared in the same unit) is inlined.
7987 if Is_Subprogram
(Subp
) then
7988 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
7990 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
7991 Set_Inline_Flags
(Inner_Subp
);
7993 Decl
:= Parent
(Parent
(Inner_Subp
));
7995 if Nkind
(Decl
) = N_Subprogram_Declaration
7996 and then Present
(Corresponding_Body
(Decl
))
7998 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8000 elsif Is_Generic_Instance
(Subp
) then
8002 -- Indicate that the body needs to be created for
8003 -- inlining subsequent calls. The instantiation node
8004 -- follows the declaration of the wrapper package
8007 if Scope
(Subp
) /= Standard_Standard
8009 Need_Subprogram_Instance_Body
8010 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8016 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8017 -- appear in a formal part to apply to a formal subprogram.
8018 -- Do not apply check within an instance or a formal package
8019 -- the test will have been applied to the original generic.
8021 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8022 and then List_Containing
(Decl
) = List_Containing
(N
)
8023 and then not In_Instance
8026 ("Inline cannot apply to a formal subprogram", N
);
8028 -- If Subp is a renaming, it is the renamed entity that
8029 -- will appear in any call, and be inlined. However, for
8030 -- ASIS uses it is convenient to indicate that the renaming
8031 -- itself is an inlined subprogram, so that some gnatcheck
8032 -- rules can be applied in the absence of expansion.
8034 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8035 Set_Inline_Flags
(Subp
);
8041 -- For a generic subprogram set flag as well, for use at the point
8042 -- of instantiation, to determine whether the body should be
8045 elsif Is_Generic_Subprogram
(Subp
) then
8046 Set_Inline_Flags
(Subp
);
8049 -- Literals are by definition inlined
8051 elsif Kind
= E_Enumeration_Literal
then
8054 -- Anything else is an error
8058 ("expect subprogram name for pragma%", Assoc
);
8062 ----------------------
8063 -- Set_Inline_Flags --
8064 ----------------------
8066 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8068 -- First set the Has_Pragma_XXX flags and issue the appropriate
8069 -- errors and warnings for suspicious combinations.
8071 if Prag_Id
= Pragma_No_Inline
then
8072 if Has_Pragma_Inline_Always
(Subp
) then
8074 ("Inline_Always and No_Inline are mutually exclusive", N
);
8075 elsif Has_Pragma_Inline
(Subp
) then
8077 ("Inline and No_Inline both specified for& ??",
8078 N
, Entity
(Subp_Id
));
8081 Set_Has_Pragma_No_Inline
(Subp
);
8083 if Prag_Id
= Pragma_Inline_Always
then
8084 if Has_Pragma_No_Inline
(Subp
) then
8086 ("Inline_Always and No_Inline are mutually exclusive",
8090 Set_Has_Pragma_Inline_Always
(Subp
);
8092 if Has_Pragma_No_Inline
(Subp
) then
8094 ("Inline and No_Inline both specified for& ??",
8095 N
, Entity
(Subp_Id
));
8099 if not Has_Pragma_Inline
(Subp
) then
8100 Set_Has_Pragma_Inline
(Subp
);
8104 -- Then adjust the Is_Inlined flag. It can never be set if the
8105 -- subprogram is subject to pragma No_Inline.
8109 Set_Is_Inlined
(Subp
, False);
8113 if not Has_Pragma_No_Inline
(Subp
) then
8114 Set_Is_Inlined
(Subp
, True);
8117 end Set_Inline_Flags
;
8119 -- Start of processing for Process_Inline
8122 Check_No_Identifiers
;
8123 Check_At_Least_N_Arguments
(1);
8125 if Status
= Enabled
then
8126 Inline_Processing_Required
:= True;
8130 while Present
(Assoc
) loop
8131 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8135 if Is_Entity_Name
(Subp_Id
) then
8136 Subp
:= Entity
(Subp_Id
);
8138 if Subp
= Any_Id
then
8140 -- If previous error, avoid cascaded errors
8142 Check_Error_Detected
;
8148 -- For the pragma case, climb homonym chain. This is
8149 -- what implements allowing the pragma in the renaming
8150 -- case, with the result applying to the ancestors, and
8151 -- also allows Inline to apply to all previous homonyms.
8153 if not From_Aspect_Specification
(N
) then
8154 while Present
(Homonym
(Subp
))
8155 and then Scope
(Homonym
(Subp
)) = Current_Scope
8157 Make_Inline
(Homonym
(Subp
));
8158 Subp
:= Homonym
(Subp
);
8165 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
8172 ----------------------------
8173 -- Process_Interface_Name --
8174 ----------------------------
8176 procedure Process_Interface_Name
8177 (Subprogram_Def
: Entity_Id
;
8183 String_Val
: String_Id
;
8185 procedure Check_Form_Of_Interface_Name
8187 Ext_Name_Case
: Boolean);
8188 -- SN is a string literal node for an interface name. This routine
8189 -- performs some minimal checks that the name is reasonable. In
8190 -- particular that no spaces or other obviously incorrect characters
8191 -- appear. This is only a warning, since any characters are allowed.
8192 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8194 ----------------------------------
8195 -- Check_Form_Of_Interface_Name --
8196 ----------------------------------
8198 procedure Check_Form_Of_Interface_Name
8200 Ext_Name_Case
: Boolean)
8202 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8203 SL
: constant Nat
:= String_Length
(S
);
8208 Error_Msg_N
("interface name cannot be null string", SN
);
8211 for J
in 1 .. SL
loop
8212 C
:= Get_String_Char
(S
, J
);
8214 -- Look for dubious character and issue unconditional warning.
8215 -- Definitely dubious if not in character range.
8217 if not In_Character_Range
(C
)
8219 -- For all cases except CLI target,
8220 -- commas, spaces and slashes are dubious (in CLI, we use
8221 -- commas and backslashes in external names to specify
8222 -- assembly version and public key, while slashes and spaces
8223 -- can be used in names to mark nested classes and
8226 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8227 and then (Get_Character
(C
) = ','
8229 Get_Character
(C
) = '\'))
8230 or else (VM_Target
/= CLI_Target
8231 and then (Get_Character
(C
) = ' '
8233 Get_Character
(C
) = '/'))
8236 ("??interface name contains illegal character",
8237 Sloc
(SN
) + Source_Ptr
(J
));
8240 end Check_Form_Of_Interface_Name
;
8242 -- Start of processing for Process_Interface_Name
8245 if No
(Link_Arg
) then
8246 if No
(Ext_Arg
) then
8247 if VM_Target
= CLI_Target
8248 and then Ekind
(Subprogram_Def
) = E_Package
8249 and then Nkind
(Parent
(Subprogram_Def
)) =
8250 N_Package_Specification
8251 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8256 (Generic_Parent
(Parent
(Subprogram_Def
))));
8261 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8263 Link_Nam
:= Expression
(Ext_Arg
);
8266 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8267 Ext_Nam
:= Expression
(Ext_Arg
);
8272 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8273 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8274 Ext_Nam
:= Expression
(Ext_Arg
);
8275 Link_Nam
:= Expression
(Link_Arg
);
8278 -- Check expressions for external name and link name are static
8280 if Present
(Ext_Nam
) then
8281 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8282 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8284 -- Verify that external name is not the name of a local entity,
8285 -- which would hide the imported one and could lead to run-time
8286 -- surprises. The problem can only arise for entities declared in
8287 -- a package body (otherwise the external name is fully qualified
8288 -- and will not conflict).
8296 if Prag_Id
= Pragma_Import
then
8297 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8299 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
8301 if Nam
/= Chars
(Subprogram_Def
)
8302 and then Present
(E
)
8303 and then not Is_Overloadable
(E
)
8304 and then Is_Immediately_Visible
(E
)
8305 and then not Is_Imported
(E
)
8306 and then Ekind
(Scope
(E
)) = E_Package
8309 while Present
(Par
) loop
8310 if Nkind
(Par
) = N_Package_Body
then
8311 Error_Msg_Sloc
:= Sloc
(E
);
8313 ("imported entity is hidden by & declared#",
8318 Par
:= Parent
(Par
);
8325 if Present
(Link_Nam
) then
8326 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8327 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8330 -- If there is no link name, just set the external name
8332 if No
(Link_Nam
) then
8333 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8335 -- For the Link_Name case, the given literal is preceded by an
8336 -- asterisk, which indicates to GCC that the given name should be
8337 -- taken literally, and in particular that no prepending of
8338 -- underlines should occur, even in systems where this is the
8344 if VM_Target
= No_VM
then
8345 Store_String_Char
(Get_Char_Code
('*'));
8348 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8349 Store_String_Chars
(String_Val
);
8351 Make_String_Literal
(Sloc
(Link_Nam
),
8352 Strval
=> End_String
);
8355 -- Set the interface name. If the entity is a generic instance, use
8356 -- its alias, which is the callable entity.
8358 if Is_Generic_Instance
(Subprogram_Def
) then
8359 Set_Encoded_Interface_Name
8360 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8362 Set_Encoded_Interface_Name
8363 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8366 -- We allow duplicated export names in CIL/Java, as they are always
8367 -- enclosed in a namespace that differentiates them, and overloaded
8368 -- entities are supported by the VM.
8370 if Convention
(Subprogram_Def
) /= Convention_CIL
8372 Convention
(Subprogram_Def
) /= Convention_Java
8374 Check_Duplicated_Export_Name
(Link_Nam
);
8376 end Process_Interface_Name
;
8378 -----------------------------------------
8379 -- Process_Interrupt_Or_Attach_Handler --
8380 -----------------------------------------
8382 procedure Process_Interrupt_Or_Attach_Handler
is
8383 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8384 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8385 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8388 Set_Is_Interrupt_Handler
(Handler_Proc
);
8390 -- If the pragma is not associated with a handler procedure within a
8391 -- protected type, then it must be for a nonprotected procedure for
8392 -- the AAMP target, in which case we don't associate a representation
8393 -- item with the procedure's scope.
8395 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8396 if Prag_Id
= Pragma_Interrupt_Handler
8398 Prag_Id
= Pragma_Attach_Handler
8400 Record_Rep_Item
(Proc_Scope
, N
);
8403 end Process_Interrupt_Or_Attach_Handler
;
8405 --------------------------------------------------
8406 -- Process_Restrictions_Or_Restriction_Warnings --
8407 --------------------------------------------------
8409 -- Note: some of the simple identifier cases were handled in par-prag,
8410 -- but it is harmless (and more straightforward) to simply handle all
8411 -- cases here, even if it means we repeat a bit of work in some cases.
8413 procedure Process_Restrictions_Or_Restriction_Warnings
8417 R_Id
: Restriction_Id
;
8423 -- Ignore all Restrictions pragmas in CodePeer mode
8425 if CodePeer_Mode
then
8429 Check_Ada_83_Warning
;
8430 Check_At_Least_N_Arguments
(1);
8431 Check_Valid_Configuration_Pragma
;
8434 while Present
(Arg
) loop
8436 Expr
:= Get_Pragma_Arg
(Arg
);
8438 -- Case of no restriction identifier present
8440 if Id
= No_Name
then
8441 if Nkind
(Expr
) /= N_Identifier
then
8443 ("invalid form for restriction", Arg
);
8448 (Process_Restriction_Synonyms
(Expr
));
8450 if R_Id
not in All_Boolean_Restrictions
then
8451 Error_Msg_Name_1
:= Pname
;
8453 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8455 -- Check for possible misspelling
8457 for J
in Restriction_Id
loop
8459 Rnm
: constant String := Restriction_Id
'Image (J
);
8462 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8463 Name_Len
:= Rnm
'Length;
8464 Set_Casing
(All_Lower_Case
);
8466 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8468 (Identifier_Casing
(Current_Source_File
));
8469 Error_Msg_String
(1 .. Rnm
'Length) :=
8470 Name_Buffer
(1 .. Name_Len
);
8471 Error_Msg_Strlen
:= Rnm
'Length;
8472 Error_Msg_N
-- CODEFIX
8473 ("\possible misspelling of ""~""",
8474 Get_Pragma_Arg
(Arg
));
8483 if Implementation_Restriction
(R_Id
) then
8484 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8487 -- Special processing for No_Elaboration_Code restriction
8489 if R_Id
= No_Elaboration_Code
then
8491 -- Restriction is only recognized within a configuration
8492 -- pragma file, or within a unit of the main extended
8493 -- program. Note: the test for Main_Unit is needed to
8494 -- properly include the case of configuration pragma files.
8496 if not (Current_Sem_Unit
= Main_Unit
8497 or else In_Extended_Main_Source_Unit
(N
))
8501 -- Don't allow in a subunit unless already specified in
8504 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8505 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8506 and then not Restriction_Active
(No_Elaboration_Code
)
8509 ("invalid specification of ""No_Elaboration_Code""",
8512 ("\restriction cannot be specified in a subunit", N
);
8514 ("\unless also specified in body or spec", N
);
8517 -- If we accept a No_Elaboration_Code restriction, then it
8518 -- needs to be added to the configuration restriction set so
8519 -- that we get proper application to other units in the main
8520 -- extended source as required.
8523 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8527 -- If this is a warning, then set the warning unless we already
8528 -- have a real restriction active (we never want a warning to
8529 -- override a real restriction).
8532 if not Restriction_Active
(R_Id
) then
8533 Set_Restriction
(R_Id
, N
);
8534 Restriction_Warnings
(R_Id
) := True;
8537 -- If real restriction case, then set it and make sure that the
8538 -- restriction warning flag is off, since a real restriction
8539 -- always overrides a warning.
8542 Set_Restriction
(R_Id
, N
);
8543 Restriction_Warnings
(R_Id
) := False;
8546 -- Check for obsolescent restrictions in Ada 2005 mode
8549 and then Ada_Version
>= Ada_2005
8550 and then (R_Id
= No_Asynchronous_Control
8552 R_Id
= No_Unchecked_Deallocation
8554 R_Id
= No_Unchecked_Conversion
)
8556 Check_Restriction
(No_Obsolescent_Features
, N
);
8559 -- A very special case that must be processed here: pragma
8560 -- Restrictions (No_Exceptions) turns off all run-time
8561 -- checking. This is a bit dubious in terms of the formal
8562 -- language definition, but it is what is intended by RM
8563 -- H.4(12). Restriction_Warnings never affects generated code
8564 -- so this is done only in the real restriction case.
8566 -- Atomic_Synchronization is not a real check, so it is not
8567 -- affected by this processing).
8569 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8570 -- run-time checks in CodePeer and GNATprove modes: we want to
8571 -- generate checks for analysis purposes, as set respectively
8572 -- by -gnatC and -gnatd.F
8575 and then not (CodePeer_Mode
or GNATprove_Mode
)
8576 and then R_Id
= No_Exceptions
8578 for J
in Scope_Suppress
.Suppress
'Range loop
8579 if J
/= Atomic_Synchronization
then
8580 Scope_Suppress
.Suppress
(J
) := True;
8585 -- Case of No_Dependence => unit-name. Note that the parser
8586 -- already made the necessary entry in the No_Dependence table.
8588 elsif Id
= Name_No_Dependence
then
8589 if not OK_No_Dependence_Unit_Name
(Expr
) then
8593 -- Case of No_Specification_Of_Aspect => aspect-identifier
8595 elsif Id
= Name_No_Specification_Of_Aspect
then
8600 if Nkind
(Expr
) /= N_Identifier
then
8603 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
8606 if A_Id
= No_Aspect
then
8607 Error_Pragma_Arg
("invalid restriction name", Arg
);
8609 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
8613 -- Case of No_Use_Of_Attribute => attribute-identifier
8615 elsif Id
= Name_No_Use_Of_Attribute
then
8616 if Nkind
(Expr
) /= N_Identifier
8617 or else not Is_Attribute_Name
(Chars
(Expr
))
8619 Error_Msg_N
("unknown attribute name??", Expr
);
8622 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
8625 -- Case of No_Use_Of_Entity => fully-qualified-name
8627 elsif Id
= Name_No_Use_Of_Entity
then
8629 -- Restriction is only recognized within a configuration
8630 -- pragma file, or within a unit of the main extended
8631 -- program. Note: the test for Main_Unit is needed to
8632 -- properly include the case of configuration pragma files.
8634 if Current_Sem_Unit
= Main_Unit
8635 or else In_Extended_Main_Source_Unit
(N
)
8637 if not OK_No_Dependence_Unit_Name
(Expr
) then
8638 Error_Msg_N
("wrong form for entity name", Expr
);
8640 Set_Restriction_No_Use_Of_Entity
8641 (Expr
, Warn
, No_Profile
);
8645 -- Case of No_Use_Of_Pragma => pragma-identifier
8647 elsif Id
= Name_No_Use_Of_Pragma
then
8648 if Nkind
(Expr
) /= N_Identifier
8649 or else not Is_Pragma_Name
(Chars
(Expr
))
8651 Error_Msg_N
("unknown pragma name??", Expr
);
8653 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
8656 -- All other cases of restriction identifier present
8659 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
8660 Analyze_And_Resolve
(Expr
, Any_Integer
);
8662 if R_Id
not in All_Parameter_Restrictions
then
8664 ("invalid restriction parameter identifier", Arg
);
8666 elsif not Is_OK_Static_Expression
(Expr
) then
8667 Flag_Non_Static_Expr
8668 ("value must be static expression!", Expr
);
8671 elsif not Is_Integer_Type
(Etype
(Expr
))
8672 or else Expr_Value
(Expr
) < 0
8675 ("value must be non-negative integer", Arg
);
8678 -- Restriction pragma is active
8680 Val
:= Expr_Value
(Expr
);
8682 if not UI_Is_In_Int_Range
(Val
) then
8684 ("pragma ignored, value too large??", Arg
);
8687 -- Warning case. If the real restriction is active, then we
8688 -- ignore the request, since warning never overrides a real
8689 -- restriction. Otherwise we set the proper warning. Note that
8690 -- this circuit sets the warning again if it is already set,
8691 -- which is what we want, since the constant may have changed.
8694 if not Restriction_Active
(R_Id
) then
8696 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
8697 Restriction_Warnings
(R_Id
) := True;
8700 -- Real restriction case, set restriction and make sure warning
8701 -- flag is off since real restriction always overrides warning.
8704 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
8705 Restriction_Warnings
(R_Id
) := False;
8711 end Process_Restrictions_Or_Restriction_Warnings
;
8713 ---------------------------------
8714 -- Process_Suppress_Unsuppress --
8715 ---------------------------------
8717 -- Note: this procedure makes entries in the check suppress data
8718 -- structures managed by Sem. See spec of package Sem for full
8719 -- details on how we handle recording of check suppression.
8721 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
8726 In_Package_Spec
: constant Boolean :=
8727 Is_Package_Or_Generic_Package
(Current_Scope
)
8728 and then not In_Package_Body
(Current_Scope
);
8730 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
8731 -- Used to suppress a single check on the given entity
8733 --------------------------------
8734 -- Suppress_Unsuppress_Echeck --
8735 --------------------------------
8737 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
8739 -- Check for error of trying to set atomic synchronization for
8740 -- a non-atomic variable.
8742 if C
= Atomic_Synchronization
8743 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
8746 ("pragma & requires atomic type or variable",
8747 Pragma_Identifier
(Original_Node
(N
)));
8750 Set_Checks_May_Be_Suppressed
(E
);
8752 if In_Package_Spec
then
8753 Push_Global_Suppress_Stack_Entry
8756 Suppress
=> Suppress_Case
);
8758 Push_Local_Suppress_Stack_Entry
8761 Suppress
=> Suppress_Case
);
8764 -- If this is a first subtype, and the base type is distinct,
8765 -- then also set the suppress flags on the base type.
8767 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
8768 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
8770 end Suppress_Unsuppress_Echeck
;
8772 -- Start of processing for Process_Suppress_Unsuppress
8775 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
8776 -- on user code: we want to generate checks for analysis purposes, as
8777 -- set respectively by -gnatC and -gnatd.F
8779 if (CodePeer_Mode
or GNATprove_Mode
)
8780 and then Comes_From_Source
(N
)
8785 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
8786 -- declarative part or a package spec (RM 11.5(5)).
8788 if not Is_Configuration_Pragma
then
8789 Check_Is_In_Decl_Part_Or_Package_Spec
;
8792 Check_At_Least_N_Arguments
(1);
8793 Check_At_Most_N_Arguments
(2);
8794 Check_No_Identifier
(Arg1
);
8795 Check_Arg_Is_Identifier
(Arg1
);
8797 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
8799 if C
= No_Check_Id
then
8801 ("argument of pragma% is not valid check name", Arg1
);
8804 -- Warn that suppress of Elaboration_Check has no effect in SPARK
8806 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
8808 ("Suppress of Elaboration_Check ignored in SPARK??",
8809 "\elaboration checking rules are statically enforced "
8810 & "(SPARK RM 7.7)", Arg1
);
8813 -- One-argument case
8815 if Arg_Count
= 1 then
8817 -- Make an entry in the local scope suppress table. This is the
8818 -- table that directly shows the current value of the scope
8819 -- suppress check for any check id value.
8821 if C
= All_Checks
then
8823 -- For All_Checks, we set all specific predefined checks with
8824 -- the exception of Elaboration_Check, which is handled
8825 -- specially because of not wanting All_Checks to have the
8826 -- effect of deactivating static elaboration order processing.
8827 -- Atomic_Synchronization is also not affected, since this is
8828 -- not a real check.
8830 for J
in Scope_Suppress
.Suppress
'Range loop
8831 if J
/= Elaboration_Check
8833 J
/= Atomic_Synchronization
8835 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
8839 -- If not All_Checks, and predefined check, then set appropriate
8840 -- scope entry. Note that we will set Elaboration_Check if this
8841 -- is explicitly specified. Atomic_Synchronization is allowed
8842 -- only if internally generated and entity is atomic.
8844 elsif C
in Predefined_Check_Id
8845 and then (not Comes_From_Source
(N
)
8846 or else C
/= Atomic_Synchronization
)
8848 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
8851 -- Also make an entry in the Local_Entity_Suppress table
8853 Push_Local_Suppress_Stack_Entry
8856 Suppress
=> Suppress_Case
);
8858 -- Case of two arguments present, where the check is suppressed for
8859 -- a specified entity (given as the second argument of the pragma)
8862 -- This is obsolescent in Ada 2005 mode
8864 if Ada_Version
>= Ada_2005
then
8865 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
8868 Check_Optional_Identifier
(Arg2
, Name_On
);
8869 E_Id
:= Get_Pragma_Arg
(Arg2
);
8872 if not Is_Entity_Name
(E_Id
) then
8874 ("second argument of pragma% must be entity name", Arg2
);
8883 -- Enforce RM 11.5(7) which requires that for a pragma that
8884 -- appears within a package spec, the named entity must be
8885 -- within the package spec. We allow the package name itself
8886 -- to be mentioned since that makes sense, although it is not
8887 -- strictly allowed by 11.5(7).
8890 and then E
/= Current_Scope
8891 and then Scope
(E
) /= Current_Scope
8894 ("entity in pragma% is not in package spec (RM 11.5(7))",
8898 -- Loop through homonyms. As noted below, in the case of a package
8899 -- spec, only homonyms within the package spec are considered.
8902 Suppress_Unsuppress_Echeck
(E
, C
);
8904 if Is_Generic_Instance
(E
)
8905 and then Is_Subprogram
(E
)
8906 and then Present
(Alias
(E
))
8908 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
8911 -- Move to next homonym if not aspect spec case
8913 exit when From_Aspect_Specification
(N
);
8917 -- If we are within a package specification, the pragma only
8918 -- applies to homonyms in the same scope.
8920 exit when In_Package_Spec
8921 and then Scope
(E
) /= Current_Scope
;
8924 end Process_Suppress_Unsuppress
;
8926 -------------------------------
8927 -- Record_Independence_Check --
8928 -------------------------------
8930 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
8932 -- For GCC back ends the validation is done a priori
8934 if VM_Target
= No_VM
and then not AAMP_On_Target
then
8938 Independence_Checks
.Append
((N
, E
));
8939 end Record_Independence_Check
;
8945 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
8947 if Is_Imported
(E
) then
8949 ("cannot export entity& that was previously imported", Arg
);
8951 elsif Present
(Address_Clause
(E
))
8952 and then not Relaxed_RM_Semantics
8955 ("cannot export entity& that has an address clause", Arg
);
8958 Set_Is_Exported
(E
);
8960 -- Generate a reference for entity explicitly, because the
8961 -- identifier may be overloaded and name resolution will not
8964 Generate_Reference
(E
, Arg
);
8966 -- Deal with exporting non-library level entity
8968 if not Is_Library_Level_Entity
(E
) then
8970 -- Not allowed at all for subprograms
8972 if Is_Subprogram
(E
) then
8973 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
8975 -- Otherwise set public and statically allocated
8979 Set_Is_Statically_Allocated
(E
);
8981 -- Warn if the corresponding W flag is set
8983 if Warn_On_Export_Import
8985 -- Only do this for something that was in the source. Not
8986 -- clear if this can be False now (there used for sure to be
8987 -- cases on some systems where it was False), but anyway the
8988 -- test is harmless if not needed, so it is retained.
8990 and then Comes_From_Source
(Arg
)
8993 ("?x?& has been made static as a result of Export",
8996 ("\?x?this usage is non-standard and non-portable",
9002 if Warn_On_Export_Import
and then Is_Type
(E
) then
9003 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9006 if Warn_On_Export_Import
and Inside_A_Generic
then
9008 ("all instances of& will have the same external name?x?",
9013 ----------------------------------------------
9014 -- Set_Extended_Import_Export_External_Name --
9015 ----------------------------------------------
9017 procedure Set_Extended_Import_Export_External_Name
9018 (Internal_Ent
: Entity_Id
;
9019 Arg_External
: Node_Id
)
9021 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9025 if No
(Arg_External
) then
9029 Check_Arg_Is_External_Name
(Arg_External
);
9031 if Nkind
(Arg_External
) = N_String_Literal
then
9032 if String_Length
(Strval
(Arg_External
)) = 0 then
9035 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9038 elsif Nkind
(Arg_External
) = N_Identifier
then
9039 New_Name
:= Get_Default_External_Name
(Arg_External
);
9041 -- Check_Arg_Is_External_Name should let through only identifiers and
9042 -- string literals or static string expressions (which are folded to
9043 -- string literals).
9046 raise Program_Error
;
9049 -- If we already have an external name set (by a prior normal Import
9050 -- or Export pragma), then the external names must match
9052 if Present
(Interface_Name
(Internal_Ent
)) then
9054 -- Ignore mismatching names in CodePeer mode, to support some
9055 -- old compilers which would export the same procedure under
9056 -- different names, e.g:
9058 -- pragma Export_Procedure (P, "a");
9059 -- pragma Export_Procedure (P, "b");
9061 if CodePeer_Mode
then
9065 Check_Matching_Internal_Names
: declare
9066 S1
: constant String_Id
:= Strval
(Old_Name
);
9067 S2
: constant String_Id
:= Strval
(New_Name
);
9070 pragma No_Return
(Mismatch
);
9071 -- Called if names do not match
9077 procedure Mismatch
is
9079 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9081 ("external name does not match that given #",
9085 -- Start of processing for Check_Matching_Internal_Names
9088 if String_Length
(S1
) /= String_Length
(S2
) then
9092 for J
in 1 .. String_Length
(S1
) loop
9093 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9098 end Check_Matching_Internal_Names
;
9100 -- Otherwise set the given name
9103 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9104 Check_Duplicated_Export_Name
(New_Name
);
9106 end Set_Extended_Import_Export_External_Name
;
9112 procedure Set_Imported
(E
: Entity_Id
) is
9114 -- Error message if already imported or exported
9116 if Is_Exported
(E
) or else Is_Imported
(E
) then
9118 -- Error if being set Exported twice
9120 if Is_Exported
(E
) then
9121 Error_Msg_NE
("entity& was previously exported", N
, E
);
9123 -- Ignore error in CodePeer mode where we treat all imported
9124 -- subprograms as unknown.
9126 elsif CodePeer_Mode
then
9129 -- OK if Import/Interface case
9131 elsif Import_Interface_Present
(N
) then
9134 -- Error if being set Imported twice
9137 Error_Msg_NE
("entity& was previously imported", N
, E
);
9140 Error_Msg_Name_1
:= Pname
;
9142 ("\(pragma% applies to all previous entities)", N
);
9144 Error_Msg_Sloc
:= Sloc
(E
);
9145 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9147 -- Here if not previously imported or exported, OK to import
9150 Set_Is_Imported
(E
);
9152 -- For subprogram, set Import_Pragma field
9154 if Is_Subprogram
(E
) then
9155 Set_Import_Pragma
(E
, N
);
9158 -- If the entity is an object that is not at the library level,
9159 -- then it is statically allocated. We do not worry about objects
9160 -- with address clauses in this context since they are not really
9161 -- imported in the linker sense.
9164 and then not Is_Library_Level_Entity
(E
)
9165 and then No
(Address_Clause
(E
))
9167 Set_Is_Statically_Allocated
(E
);
9174 -------------------------
9175 -- Set_Mechanism_Value --
9176 -------------------------
9178 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9179 -- analyzed, since it is semantic nonsense), so we get it in the exact
9180 -- form created by the parser.
9182 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9183 procedure Bad_Mechanism
;
9184 pragma No_Return
(Bad_Mechanism
);
9185 -- Signal bad mechanism name
9187 -------------------------
9188 -- Bad_Mechanism_Value --
9189 -------------------------
9191 procedure Bad_Mechanism
is
9193 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9196 -- Start of processing for Set_Mechanism_Value
9199 if Mechanism
(Ent
) /= Default_Mechanism
then
9201 ("mechanism for & has already been set", Mech_Name
, Ent
);
9204 -- MECHANISM_NAME ::= value | reference
9206 if Nkind
(Mech_Name
) = N_Identifier
then
9207 if Chars
(Mech_Name
) = Name_Value
then
9208 Set_Mechanism
(Ent
, By_Copy
);
9211 elsif Chars
(Mech_Name
) = Name_Reference
then
9212 Set_Mechanism
(Ent
, By_Reference
);
9215 elsif Chars
(Mech_Name
) = Name_Copy
then
9217 ("bad mechanism name, Value assumed", Mech_Name
);
9226 end Set_Mechanism_Value
;
9228 --------------------------
9229 -- Set_Rational_Profile --
9230 --------------------------
9232 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9233 -- and extension to the semantics of renaming declarations.
9235 procedure Set_Rational_Profile
is
9237 Implicit_Packing
:= True;
9238 Overriding_Renamings
:= True;
9239 Use_VADS_Size
:= True;
9240 end Set_Rational_Profile
;
9242 ---------------------------
9243 -- Set_Ravenscar_Profile --
9244 ---------------------------
9246 -- The tasks to be done here are
9248 -- Set required policies
9250 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9251 -- pragma Locking_Policy (Ceiling_Locking)
9253 -- Set Detect_Blocking mode
9255 -- Set required restrictions (see System.Rident for detailed list)
9257 -- Set the No_Dependence rules
9258 -- No_Dependence => Ada.Asynchronous_Task_Control
9259 -- No_Dependence => Ada.Calendar
9260 -- No_Dependence => Ada.Execution_Time.Group_Budget
9261 -- No_Dependence => Ada.Execution_Time.Timers
9262 -- No_Dependence => Ada.Task_Attributes
9263 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9265 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9266 Prefix_Entity
: Entity_Id
;
9267 Selector_Entity
: Entity_Id
;
9268 Prefix_Node
: Node_Id
;
9272 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9274 if Task_Dispatching_Policy
/= ' '
9275 and then Task_Dispatching_Policy
/= 'F'
9277 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9278 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9280 -- Set the FIFO_Within_Priorities policy, but always preserve
9281 -- System_Location since we like the error message with the run time
9285 Task_Dispatching_Policy
:= 'F';
9287 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9288 Task_Dispatching_Policy_Sloc
:= Loc
;
9292 -- pragma Locking_Policy (Ceiling_Locking)
9294 if Locking_Policy
/= ' '
9295 and then Locking_Policy
/= 'C'
9297 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9298 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9300 -- Set the Ceiling_Locking policy, but preserve System_Location since
9301 -- we like the error message with the run time name.
9304 Locking_Policy
:= 'C';
9306 if Locking_Policy_Sloc
/= System_Location
then
9307 Locking_Policy_Sloc
:= Loc
;
9311 -- pragma Detect_Blocking
9313 Detect_Blocking
:= True;
9315 -- Set the corresponding restrictions
9317 Set_Profile_Restrictions
9318 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9320 -- Set the No_Dependence restrictions
9322 -- The following No_Dependence restrictions:
9323 -- No_Dependence => Ada.Asynchronous_Task_Control
9324 -- No_Dependence => Ada.Calendar
9325 -- No_Dependence => Ada.Task_Attributes
9326 -- are already set by previous call to Set_Profile_Restrictions.
9328 -- Set the following restrictions which were added to Ada 2005:
9329 -- No_Dependence => Ada.Execution_Time.Group_Budget
9330 -- No_Dependence => Ada.Execution_Time.Timers
9332 if Ada_Version
>= Ada_2005
then
9333 Name_Buffer
(1 .. 3) := "ada";
9336 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9338 Name_Buffer
(1 .. 14) := "execution_time";
9341 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9344 Make_Selected_Component
9346 Prefix
=> Prefix_Entity
,
9347 Selector_Name
=> Selector_Entity
);
9349 Name_Buffer
(1 .. 13) := "group_budgets";
9352 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9355 Make_Selected_Component
9357 Prefix
=> Prefix_Node
,
9358 Selector_Name
=> Selector_Entity
);
9360 Set_Restriction_No_Dependence
9362 Warn
=> Treat_Restrictions_As_Warnings
,
9363 Profile
=> Ravenscar
);
9365 Name_Buffer
(1 .. 6) := "timers";
9368 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9371 Make_Selected_Component
9373 Prefix
=> Prefix_Node
,
9374 Selector_Name
=> Selector_Entity
);
9376 Set_Restriction_No_Dependence
9378 Warn
=> Treat_Restrictions_As_Warnings
,
9379 Profile
=> Ravenscar
);
9382 -- Set the following restrictions which was added to Ada 2012 (see
9384 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9386 if Ada_Version
>= Ada_2012
then
9387 Name_Buffer
(1 .. 6) := "system";
9390 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9392 Name_Buffer
(1 .. 15) := "multiprocessors";
9395 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9398 Make_Selected_Component
9400 Prefix
=> Prefix_Entity
,
9401 Selector_Name
=> Selector_Entity
);
9403 Name_Buffer
(1 .. 19) := "dispatching_domains";
9406 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9409 Make_Selected_Component
9411 Prefix
=> Prefix_Node
,
9412 Selector_Name
=> Selector_Entity
);
9414 Set_Restriction_No_Dependence
9416 Warn
=> Treat_Restrictions_As_Warnings
,
9417 Profile
=> Ravenscar
);
9419 end Set_Ravenscar_Profile
;
9421 -- Start of processing for Analyze_Pragma
9424 -- The following code is a defense against recursion. Not clear that
9425 -- this can happen legitimately, but perhaps some error situations
9426 -- can cause it, and we did see this recursion during testing.
9428 if Analyzed
(N
) then
9431 Set_Analyzed
(N
, True);
9434 -- Deal with unrecognized pragma
9436 Pname
:= Pragma_Name
(N
);
9438 if not Is_Pragma_Name
(Pname
) then
9439 if Warn_On_Unrecognized_Pragma
then
9440 Error_Msg_Name_1
:= Pname
;
9441 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9443 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9444 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9445 Error_Msg_Name_1
:= PN
;
9446 Error_Msg_N
-- CODEFIX
9447 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9456 -- Ignore pragma if Ignore_Pragma applies
9458 if Get_Name_Table_Boolean3
(Pname
) then
9462 -- Here to start processing for recognized pragma
9464 Prag_Id
:= Get_Pragma_Id
(Pname
);
9465 Pname
:= Original_Aspect_Pragma_Name
(N
);
9467 -- Capture setting of Opt.Uneval_Old
9469 case Opt
.Uneval_Old
is
9471 Set_Uneval_Old_Accept
(N
);
9475 Set_Uneval_Old_Warn
(N
);
9477 raise Program_Error
;
9480 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9481 -- is already set, indicating that we have already checked the policy
9482 -- at the right point. This happens for example in the case of a pragma
9483 -- that is derived from an Aspect.
9485 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9488 -- For a pragma that is a rewriting of another pragma, copy the
9489 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9491 elsif Is_Rewrite_Substitution
(N
)
9492 and then Nkind
(Original_Node
(N
)) = N_Pragma
9493 and then Original_Node
(N
) /= N
9495 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
9496 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
9498 -- Otherwise query the applicable policy at this point
9501 Check_Applicable_Policy
(N
);
9503 -- If pragma is disabled, rewrite as NULL and skip analysis
9505 if Is_Disabled
(N
) then
9506 Rewrite
(N
, Make_Null_Statement
(Loc
));
9520 if Present
(Pragma_Argument_Associations
(N
)) then
9521 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
9522 Arg1
:= First
(Pragma_Argument_Associations
(N
));
9524 if Present
(Arg1
) then
9525 Arg2
:= Next
(Arg1
);
9527 if Present
(Arg2
) then
9528 Arg3
:= Next
(Arg2
);
9530 if Present
(Arg3
) then
9531 Arg4
:= Next
(Arg3
);
9537 Check_Restriction_No_Use_Of_Pragma
(N
);
9539 -- An enumeration type defines the pragmas that are supported by the
9540 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9541 -- into the corresponding enumeration value for the following case.
9549 -- pragma Abort_Defer;
9551 when Pragma_Abort_Defer
=>
9553 Check_Arg_Count
(0);
9555 -- The only required semantic processing is to check the
9556 -- placement. This pragma must appear at the start of the
9557 -- statement sequence of a handled sequence of statements.
9559 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
9560 or else N
/= First
(Statements
(Parent
(N
)))
9565 --------------------
9566 -- Abstract_State --
9567 --------------------
9569 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9571 -- ABSTRACT_STATE_LIST ::=
9573 -- | STATE_NAME_WITH_OPTIONS
9574 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9576 -- STATE_NAME_WITH_OPTIONS ::=
9578 -- | (STATE_NAME with OPTION_LIST)
9580 -- OPTION_LIST ::= OPTION {, OPTION}
9584 -- | NAME_VALUE_OPTION
9586 -- SIMPLE_OPTION ::= Ghost
9588 -- NAME_VALUE_OPTION ::=
9589 -- Part_Of => ABSTRACT_STATE
9590 -- | External [=> EXTERNAL_PROPERTY_LIST]
9592 -- EXTERNAL_PROPERTY_LIST ::=
9593 -- EXTERNAL_PROPERTY
9594 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9596 -- EXTERNAL_PROPERTY ::=
9597 -- Async_Readers [=> boolean_EXPRESSION]
9598 -- | Async_Writers [=> boolean_EXPRESSION]
9599 -- | Effective_Reads [=> boolean_EXPRESSION]
9600 -- | Effective_Writes [=> boolean_EXPRESSION]
9601 -- others => boolean_EXPRESSION
9603 -- STATE_NAME ::= defining_identifier
9605 -- ABSTRACT_STATE ::= name
9609 -- * Analysis - The annotation is fully analyzed immediately upon
9610 -- elaboration as it cannot forward reference entities.
9612 -- * Expansion - None.
9614 -- * Template - The annotation utilizes the generic template of the
9615 -- related package declaration.
9617 -- * Globals - The annotation cannot reference global entities.
9619 -- * Instance - The annotation is instantiated automatically when
9620 -- the related generic package is instantiated.
9622 when Pragma_Abstract_State
=> Abstract_State
: declare
9623 Missing_Parentheses
: Boolean := False;
9624 -- Flag set when a state declaration with options is not properly
9627 -- Flags used to verify the consistency of states
9629 Non_Null_Seen
: Boolean := False;
9630 Null_Seen
: Boolean := False;
9632 procedure Analyze_Abstract_State
9634 Pack_Id
: Entity_Id
);
9635 -- Verify the legality of a single state declaration. Create and
9636 -- decorate a state abstraction entity and introduce it into the
9637 -- visibility chain. Pack_Id denotes the entity or the related
9638 -- package where pragma Abstract_State appears.
9640 procedure Malformed_State_Error
(State
: Node_Id
);
9641 -- Emit an error concerning the illegal declaration of abstract
9642 -- state State. This routine diagnoses syntax errors that lead to
9643 -- a different parse tree. The error is issued regardless of the
9644 -- SPARK mode in effect.
9646 ----------------------------
9647 -- Analyze_Abstract_State --
9648 ----------------------------
9650 procedure Analyze_Abstract_State
9652 Pack_Id
: Entity_Id
)
9654 -- Flags used to verify the consistency of options
9656 AR_Seen
: Boolean := False;
9657 AW_Seen
: Boolean := False;
9658 ER_Seen
: Boolean := False;
9659 EW_Seen
: Boolean := False;
9660 External_Seen
: Boolean := False;
9661 Others_Seen
: Boolean := False;
9662 Part_Of_Seen
: Boolean := False;
9664 -- Flags used to store the static value of all external states'
9667 AR_Val
: Boolean := False;
9668 AW_Val
: Boolean := False;
9669 ER_Val
: Boolean := False;
9670 EW_Val
: Boolean := False;
9672 State_Id
: Entity_Id
:= Empty
;
9673 -- The entity to be generated for the current state declaration
9675 procedure Analyze_External_Option
(Opt
: Node_Id
);
9676 -- Verify the legality of option External
9678 procedure Analyze_External_Property
9680 Expr
: Node_Id
:= Empty
);
9681 -- Verify the legailty of a single external property. Prop
9682 -- denotes the external property. Expr is the expression used
9683 -- to set the property.
9685 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
9686 -- Verify the legality of option Part_Of
9688 procedure Check_Duplicate_Option
9690 Status
: in out Boolean);
9691 -- Flag Status denotes whether a particular option has been
9692 -- seen while processing a state. This routine verifies that
9693 -- Opt is not a duplicate option and sets the flag Status
9694 -- (SPARK RM 7.1.4(1)).
9696 procedure Check_Duplicate_Property
9698 Status
: in out Boolean);
9699 -- Flag Status denotes whether a particular property has been
9700 -- seen while processing option External. This routine verifies
9701 -- that Prop is not a duplicate property and sets flag Status.
9702 -- Opt is not a duplicate property and sets the flag Status.
9703 -- (SPARK RM 7.1.4(2))
9705 procedure Create_Abstract_State
9710 -- Generate an abstract state entity with name Nam and enter it
9711 -- into visibility. Decl is the "declaration" of the state as
9712 -- it appears in pragma Abstract_State. Loc is the location of
9713 -- the related state "declaration". Flag Is_Null should be set
9714 -- when the associated Abstract_State pragma defines a null
9717 -----------------------------
9718 -- Analyze_External_Option --
9719 -----------------------------
9721 procedure Analyze_External_Option
(Opt
: Node_Id
) is
9722 Errors
: constant Nat
:= Serious_Errors_Detected
;
9724 Props
: Node_Id
:= Empty
;
9727 Check_Duplicate_Option
(Opt
, External_Seen
);
9729 if Nkind
(Opt
) = N_Component_Association
then
9730 Props
:= Expression
(Opt
);
9733 -- External state with properties
9735 if Present
(Props
) then
9737 -- Multiple properties appear as an aggregate
9739 if Nkind
(Props
) = N_Aggregate
then
9741 -- Simple property form
9743 Prop
:= First
(Expressions
(Props
));
9744 while Present
(Prop
) loop
9745 Analyze_External_Property
(Prop
);
9749 -- Property with expression form
9751 Prop
:= First
(Component_Associations
(Props
));
9752 while Present
(Prop
) loop
9753 Analyze_External_Property
9754 (Prop
=> First
(Choices
(Prop
)),
9755 Expr
=> Expression
(Prop
));
9763 Analyze_External_Property
(Props
);
9766 -- An external state defined without any properties defaults
9767 -- all properties to True.
9776 -- Once all external properties have been processed, verify
9777 -- their mutual interaction. Do not perform the check when
9778 -- at least one of the properties is illegal as this will
9779 -- produce a bogus error.
9781 if Errors
= Serious_Errors_Detected
then
9782 Check_External_Properties
9783 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
9785 end Analyze_External_Option
;
9787 -------------------------------
9788 -- Analyze_External_Property --
9789 -------------------------------
9791 procedure Analyze_External_Property
9793 Expr
: Node_Id
:= Empty
)
9798 -- Check the placement of "others" (if available)
9800 if Nkind
(Prop
) = N_Others_Choice
then
9803 ("only one others choice allowed in option External",
9806 Others_Seen
:= True;
9809 elsif Others_Seen
then
9811 ("others must be the last property in option External",
9814 -- The only remaining legal options are the four predefined
9815 -- external properties.
9817 elsif Nkind
(Prop
) = N_Identifier
9818 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
9820 Name_Effective_Reads
,
9821 Name_Effective_Writes
)
9825 -- Otherwise the construct is not a valid property
9828 SPARK_Msg_N
("invalid external state property", Prop
);
9832 -- Ensure that the expression of the external state property
9833 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
9835 if Present
(Expr
) then
9836 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9838 if Is_OK_Static_Expression
(Expr
) then
9839 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
9842 ("expression of external state property must be "
9846 -- The lack of expression defaults the property to True
9854 if Nkind
(Prop
) = N_Identifier
then
9855 if Chars
(Prop
) = Name_Async_Readers
then
9856 Check_Duplicate_Property
(Prop
, AR_Seen
);
9859 elsif Chars
(Prop
) = Name_Async_Writers
then
9860 Check_Duplicate_Property
(Prop
, AW_Seen
);
9863 elsif Chars
(Prop
) = Name_Effective_Reads
then
9864 Check_Duplicate_Property
(Prop
, ER_Seen
);
9868 Check_Duplicate_Property
(Prop
, EW_Seen
);
9872 -- The handling of property "others" must take into account
9873 -- all other named properties that have been encountered so
9874 -- far. Only those that have not been seen are affected by
9894 end Analyze_External_Property
;
9896 ----------------------------
9897 -- Analyze_Part_Of_Option --
9898 ----------------------------
9900 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
9901 Encaps
: constant Node_Id
:= Expression
(Opt
);
9902 Encaps_Id
: Entity_Id
;
9906 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
9909 (Item_Id
=> State_Id
,
9911 Indic
=> First
(Choices
(Opt
)),
9914 -- The Part_Of indicator turns an abstract state into a
9915 -- constituent of the encapsulating state.
9918 Encaps_Id
:= Entity
(Encaps
);
9920 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
9921 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
9923 end Analyze_Part_Of_Option
;
9925 ----------------------------
9926 -- Check_Duplicate_Option --
9927 ----------------------------
9929 procedure Check_Duplicate_Option
9931 Status
: in out Boolean)
9935 SPARK_Msg_N
("duplicate state option", Opt
);
9939 end Check_Duplicate_Option
;
9941 ------------------------------
9942 -- Check_Duplicate_Property --
9943 ------------------------------
9945 procedure Check_Duplicate_Property
9947 Status
: in out Boolean)
9951 SPARK_Msg_N
("duplicate external property", Prop
);
9955 end Check_Duplicate_Property
;
9957 ---------------------------
9958 -- Create_Abstract_State --
9959 ---------------------------
9961 procedure Create_Abstract_State
9968 -- The abstract state may be semi-declared when the related
9969 -- package was withed through a limited with clause. In that
9970 -- case reuse the entity to fully declare the state.
9972 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
9973 State_Id
:= Entity
(Decl
);
9975 -- Otherwise the elaboration of pragma Abstract_State
9976 -- declares the state.
9979 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
9981 if Present
(Decl
) then
9982 Set_Entity
(Decl
, State_Id
);
9986 -- Null states never come from source
9988 Set_Comes_From_Source
(State_Id
, not Is_Null
);
9989 Set_Parent
(State_Id
, State
);
9990 Set_Ekind
(State_Id
, E_Abstract_State
);
9991 Set_Etype
(State_Id
, Standard_Void_Type
);
9992 Set_Encapsulating_State
(State_Id
, Empty
);
9993 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
9994 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
9996 -- An abstract state declared within a Ghost region becomes
9997 -- Ghost (SPARK RM 6.9(2)).
9999 if Ghost_Mode
> None
then
10000 Set_Is_Ghost_Entity
(State_Id
);
10003 -- Establish a link between the state declaration and the
10004 -- abstract state entity. Note that a null state remains as
10005 -- N_Null and does not carry any linkages.
10007 if not Is_Null
then
10008 if Present
(Decl
) then
10009 Set_Entity
(Decl
, State_Id
);
10010 Set_Etype
(Decl
, Standard_Void_Type
);
10013 -- Every non-null state must be defined, nameable and
10016 Push_Scope
(Pack_Id
);
10017 Generate_Definition
(State_Id
);
10018 Enter_Name
(State_Id
);
10021 end Create_Abstract_State
;
10028 -- Start of processing for Analyze_Abstract_State
10031 -- A package with a null abstract state is not allowed to
10032 -- declare additional states.
10036 ("package & has null abstract state", State
, Pack_Id
);
10038 -- Null states appear as internally generated entities
10040 elsif Nkind
(State
) = N_Null
then
10041 Create_Abstract_State
10042 (Nam
=> New_Internal_Name
('S'),
10044 Loc
=> Sloc
(State
),
10048 -- Catch a case where a null state appears in a list of
10049 -- non-null states.
10051 if Non_Null_Seen
then
10053 ("package & has non-null abstract state",
10057 -- Simple state declaration
10059 elsif Nkind
(State
) = N_Identifier
then
10060 Create_Abstract_State
10061 (Nam
=> Chars
(State
),
10063 Loc
=> Sloc
(State
),
10065 Non_Null_Seen
:= True;
10067 -- State declaration with various options. This construct
10068 -- appears as an extension aggregate in the tree.
10070 elsif Nkind
(State
) = N_Extension_Aggregate
then
10071 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10072 Create_Abstract_State
10073 (Nam
=> Chars
(Ancestor_Part
(State
)),
10074 Decl
=> Ancestor_Part
(State
),
10075 Loc
=> Sloc
(Ancestor_Part
(State
)),
10077 Non_Null_Seen
:= True;
10080 ("state name must be an identifier",
10081 Ancestor_Part
(State
));
10084 -- Options External and Ghost appear as expressions
10086 Opt
:= First
(Expressions
(State
));
10087 while Present
(Opt
) loop
10088 if Nkind
(Opt
) = N_Identifier
then
10089 if Chars
(Opt
) = Name_External
then
10090 Analyze_External_Option
(Opt
);
10092 elsif Chars
(Opt
) = Name_Ghost
then
10093 if Present
(State_Id
) then
10094 Set_Is_Ghost_Entity
(State_Id
);
10097 -- Option Part_Of without an encapsulating state is
10098 -- illegal. (SPARK RM 7.1.4(9)).
10100 elsif Chars
(Opt
) = Name_Part_Of
then
10102 ("indicator Part_Of must denote an abstract "
10105 -- Do not emit an error message when a previous state
10106 -- declaration with options was not parenthesized as
10107 -- the option is actually another state declaration.
10109 -- with Abstract_State
10110 -- (State_1 with ..., -- missing parentheses
10111 -- (State_2 with ...),
10112 -- State_3) -- ok state declaration
10114 elsif Missing_Parentheses
then
10117 -- Otherwise the option is not allowed. Note that it
10118 -- is not possible to distinguish between an option
10119 -- and a state declaration when a previous state with
10120 -- options not properly parentheses.
10122 -- with Abstract_State
10123 -- (State_1 with ..., -- missing parentheses
10124 -- State_2); -- could be an option
10128 ("simple option not allowed in state declaration",
10132 -- Catch a case where missing parentheses around a state
10133 -- declaration with options cause a subsequent state
10134 -- declaration with options to be treated as an option.
10136 -- with Abstract_State
10137 -- (State_1 with ..., -- missing parentheses
10138 -- (State_2 with ...))
10140 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10141 Missing_Parentheses
:= True;
10143 ("state declaration must be parenthesized",
10144 Ancestor_Part
(State
));
10146 -- Otherwise the option is malformed
10149 SPARK_Msg_N
("malformed option", Opt
);
10155 -- Options External and Part_Of appear as component
10158 Opt
:= First
(Component_Associations
(State
));
10159 while Present
(Opt
) loop
10160 Opt_Nam
:= First
(Choices
(Opt
));
10162 if Nkind
(Opt_Nam
) = N_Identifier
then
10163 if Chars
(Opt_Nam
) = Name_External
then
10164 Analyze_External_Option
(Opt
);
10166 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10167 Analyze_Part_Of_Option
(Opt
);
10170 SPARK_Msg_N
("invalid state option", Opt
);
10173 SPARK_Msg_N
("invalid state option", Opt
);
10179 -- Any other attempt to declare a state is illegal
10182 Malformed_State_Error
(State
);
10186 -- Guard against a junk state. In such cases no entity is
10187 -- generated and the subsequent checks cannot be applied.
10189 if Present
(State_Id
) then
10191 -- Verify whether the state does not introduce an illegal
10192 -- hidden state within a package subject to a null abstract
10195 Check_No_Hidden_State
(State_Id
);
10197 -- Check whether the lack of option Part_Of agrees with the
10198 -- placement of the abstract state with respect to the state
10201 if not Part_Of_Seen
then
10202 Check_Missing_Part_Of
(State_Id
);
10205 -- Associate the state with its related package
10207 if No
(Abstract_States
(Pack_Id
)) then
10208 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10211 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10213 end Analyze_Abstract_State
;
10215 ---------------------------
10216 -- Malformed_State_Error --
10217 ---------------------------
10219 procedure Malformed_State_Error
(State
: Node_Id
) is
10221 Error_Msg_N
("malformed abstract state declaration", State
);
10223 -- An abstract state with a simple option is being declared
10224 -- with "=>" rather than the legal "with". The state appears
10225 -- as a component association.
10227 if Nkind
(State
) = N_Component_Association
then
10228 Error_Msg_N
("\use WITH to specify simple option", State
);
10230 end Malformed_State_Error
;
10234 Pack_Decl
: Node_Id
;
10235 Pack_Id
: Entity_Id
;
10239 -- Start of processing for Abstract_State
10243 Check_No_Identifiers
;
10244 Check_Arg_Count
(1);
10246 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
10248 -- Ensure the proper placement of the pragma. Abstract states must
10249 -- be associated with a package declaration.
10251 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
10252 N_Package_Declaration
)
10256 -- Otherwise the pragma is associated with an illegal construct
10263 Pack_Id
:= Defining_Entity
(Pack_Decl
);
10265 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
10267 -- Mark the associated package as Ghost if it is subject to aspect
10268 -- or pragma Ghost as this affects the declaration of an abstract
10271 if Is_Subject_To_Ghost
(Unit_Declaration_Node
(Pack_Id
)) then
10272 Set_Is_Ghost_Entity
(Pack_Id
);
10275 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
10277 -- Multiple non-null abstract states appear as an aggregate
10279 if Nkind
(States
) = N_Aggregate
then
10280 State
:= First
(Expressions
(States
));
10281 while Present
(State
) loop
10282 Analyze_Abstract_State
(State
, Pack_Id
);
10286 -- An abstract state with a simple option is being illegaly
10287 -- declared with "=>" rather than "with". In this case the
10288 -- state declaration appears as a component association.
10290 if Present
(Component_Associations
(States
)) then
10291 State
:= First
(Component_Associations
(States
));
10292 while Present
(State
) loop
10293 Malformed_State_Error
(State
);
10298 -- Various forms of a single abstract state. Note that these may
10299 -- include malformed state declarations.
10302 Analyze_Abstract_State
(States
, Pack_Id
);
10305 -- Verify the declaration order of pragmas Abstract_State and
10308 Check_Declaration_Order
10310 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10312 -- Chain the pragma on the contract for completeness
10314 Add_Contract_Item
(N
, Pack_Id
);
10315 end Abstract_State
;
10323 -- Note: this pragma also has some specific processing in Par.Prag
10324 -- because we want to set the Ada version mode during parsing.
10326 when Pragma_Ada_83
=>
10328 Check_Arg_Count
(0);
10330 -- We really should check unconditionally for proper configuration
10331 -- pragma placement, since we really don't want mixed Ada modes
10332 -- within a single unit, and the GNAT reference manual has always
10333 -- said this was a configuration pragma, but we did not check and
10334 -- are hesitant to add the check now.
10336 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10337 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10338 -- or Ada 2012 mode.
10340 if Ada_Version
>= Ada_2005
then
10341 Check_Valid_Configuration_Pragma
;
10344 -- Now set Ada 83 mode
10346 Ada_Version
:= Ada_83
;
10347 Ada_Version_Explicit
:= Ada_83
;
10348 Ada_Version_Pragma
:= N
;
10356 -- Note: this pragma also has some specific processing in Par.Prag
10357 -- because we want to set the Ada 83 version mode during parsing.
10359 when Pragma_Ada_95
=>
10361 Check_Arg_Count
(0);
10363 -- We really should check unconditionally for proper configuration
10364 -- pragma placement, since we really don't want mixed Ada modes
10365 -- within a single unit, and the GNAT reference manual has always
10366 -- said this was a configuration pragma, but we did not check and
10367 -- are hesitant to add the check now.
10369 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10370 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10372 if Ada_Version
>= Ada_2005
then
10373 Check_Valid_Configuration_Pragma
;
10376 -- Now set Ada 95 mode
10378 Ada_Version
:= Ada_95
;
10379 Ada_Version_Explicit
:= Ada_95
;
10380 Ada_Version_Pragma
:= N
;
10382 ---------------------
10383 -- Ada_05/Ada_2005 --
10384 ---------------------
10387 -- pragma Ada_05 (LOCAL_NAME);
10389 -- pragma Ada_2005;
10390 -- pragma Ada_2005 (LOCAL_NAME):
10392 -- Note: these pragmas also have some specific processing in Par.Prag
10393 -- because we want to set the Ada 2005 version mode during parsing.
10395 -- The one argument form is used for managing the transition from
10396 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10397 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10398 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10399 -- mode, a preference rule is established which does not choose
10400 -- such an entity unless it is unambiguously specified. This avoids
10401 -- extra subprograms marked this way from generating ambiguities in
10402 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10403 -- intended for exclusive use in the GNAT run-time library.
10405 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10411 if Arg_Count
= 1 then
10412 Check_Arg_Is_Local_Name
(Arg1
);
10413 E_Id
:= Get_Pragma_Arg
(Arg1
);
10415 if Etype
(E_Id
) = Any_Type
then
10419 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10420 Record_Rep_Item
(Entity
(E_Id
), N
);
10423 Check_Arg_Count
(0);
10425 -- For Ada_2005 we unconditionally enforce the documented
10426 -- configuration pragma placement, since we do not want to
10427 -- tolerate mixed modes in a unit involving Ada 2005. That
10428 -- would cause real difficulties for those cases where there
10429 -- are incompatibilities between Ada 95 and Ada 2005.
10431 Check_Valid_Configuration_Pragma
;
10433 -- Now set appropriate Ada mode
10435 Ada_Version
:= Ada_2005
;
10436 Ada_Version_Explicit
:= Ada_2005
;
10437 Ada_Version_Pragma
:= N
;
10441 ---------------------
10442 -- Ada_12/Ada_2012 --
10443 ---------------------
10446 -- pragma Ada_12 (LOCAL_NAME);
10448 -- pragma Ada_2012;
10449 -- pragma Ada_2012 (LOCAL_NAME):
10451 -- Note: these pragmas also have some specific processing in Par.Prag
10452 -- because we want to set the Ada 2012 version mode during parsing.
10454 -- The one argument form is used for managing the transition from Ada
10455 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10456 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10457 -- mode will generate a warning. In addition, in any pre-Ada_2012
10458 -- mode, a preference rule is established which does not choose
10459 -- such an entity unless it is unambiguously specified. This avoids
10460 -- extra subprograms marked this way from generating ambiguities in
10461 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10462 -- intended for exclusive use in the GNAT run-time library.
10464 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10470 if Arg_Count
= 1 then
10471 Check_Arg_Is_Local_Name
(Arg1
);
10472 E_Id
:= Get_Pragma_Arg
(Arg1
);
10474 if Etype
(E_Id
) = Any_Type
then
10478 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10479 Record_Rep_Item
(Entity
(E_Id
), N
);
10482 Check_Arg_Count
(0);
10484 -- For Ada_2012 we unconditionally enforce the documented
10485 -- configuration pragma placement, since we do not want to
10486 -- tolerate mixed modes in a unit involving Ada 2012. That
10487 -- would cause real difficulties for those cases where there
10488 -- are incompatibilities between Ada 95 and Ada 2012. We could
10489 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10491 Check_Valid_Configuration_Pragma
;
10493 -- Now set appropriate Ada mode
10495 Ada_Version
:= Ada_2012
;
10496 Ada_Version_Explicit
:= Ada_2012
;
10497 Ada_Version_Pragma
:= N
;
10501 ----------------------
10502 -- All_Calls_Remote --
10503 ----------------------
10505 -- pragma All_Calls_Remote [(library_package_NAME)];
10507 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10508 Lib_Entity
: Entity_Id
;
10511 Check_Ada_83_Warning
;
10512 Check_Valid_Library_Unit_Pragma
;
10514 if Nkind
(N
) = N_Null_Statement
then
10518 Lib_Entity
:= Find_Lib_Unit_Name
;
10520 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10522 if Present
(Lib_Entity
)
10523 and then not Debug_Flag_U
10525 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10526 Error_Pragma
("pragma% only apply to rci unit");
10528 -- Set flag for entity of the library unit
10531 Set_Has_All_Calls_Remote
(Lib_Entity
);
10535 end All_Calls_Remote
;
10537 ---------------------------
10538 -- Allow_Integer_Address --
10539 ---------------------------
10541 -- pragma Allow_Integer_Address;
10543 when Pragma_Allow_Integer_Address
=>
10545 Check_Valid_Configuration_Pragma
;
10546 Check_Arg_Count
(0);
10548 -- If Address is a private type, then set the flag to allow
10549 -- integer address values. If Address is not private, then this
10550 -- pragma has no purpose, so it is simply ignored. Not clear if
10551 -- there are any such targets now.
10553 if Opt
.Address_Is_Private
then
10554 Opt
.Allow_Integer_Address
:= True;
10562 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10563 -- ARG ::= NAME | EXPRESSION
10565 -- The first two arguments are by convention intended to refer to an
10566 -- external tool and a tool-specific function. These arguments are
10569 when Pragma_Annotate
=> Annotate
: declare
10575 Check_At_Least_N_Arguments
(1);
10577 -- See if last argument is Entity => local_Name, and if so process
10578 -- and then remove it for remaining processing.
10581 Last_Arg
: constant Node_Id
:=
10582 Last
(Pragma_Argument_Associations
(N
));
10585 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
10586 and then Chars
(Last_Arg
) = Name_Entity
10588 Check_Arg_Is_Local_Name
(Last_Arg
);
10589 Arg_Count
:= Arg_Count
- 1;
10591 -- Not allowed in compiler units (bootstrap issues)
10593 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
10597 -- Continue processing with last argument removed for now
10599 Check_Arg_Is_Identifier
(Arg1
);
10600 Check_No_Identifiers
;
10603 -- Second parameter is optional, it is never analyzed
10608 -- Here if we have a second parameter
10611 -- Second parameter must be identifier
10613 Check_Arg_Is_Identifier
(Arg2
);
10615 -- Process remaining parameters if any
10617 Arg
:= Next
(Arg2
);
10618 while Present
(Arg
) loop
10619 Exp
:= Get_Pragma_Arg
(Arg
);
10622 if Is_Entity_Name
(Exp
) then
10625 -- For string literals, we assume Standard_String as the
10626 -- type, unless the string contains wide or wide_wide
10629 elsif Nkind
(Exp
) = N_String_Literal
then
10630 if Has_Wide_Wide_Character
(Exp
) then
10631 Resolve
(Exp
, Standard_Wide_Wide_String
);
10632 elsif Has_Wide_Character
(Exp
) then
10633 Resolve
(Exp
, Standard_Wide_String
);
10635 Resolve
(Exp
, Standard_String
);
10638 elsif Is_Overloaded
(Exp
) then
10640 ("ambiguous argument for pragma%", Exp
);
10651 -------------------------------------------------
10652 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
10653 -------------------------------------------------
10656 -- ( [Check => ] Boolean_EXPRESSION
10657 -- [, [Message =>] Static_String_EXPRESSION]);
10659 -- pragma Assert_And_Cut
10660 -- ( [Check => ] Boolean_EXPRESSION
10661 -- [, [Message =>] Static_String_EXPRESSION]);
10664 -- ( [Check => ] Boolean_EXPRESSION
10665 -- [, [Message =>] Static_String_EXPRESSION]);
10667 -- pragma Loop_Invariant
10668 -- ( [Check => ] Boolean_EXPRESSION
10669 -- [, [Message =>] Static_String_EXPRESSION]);
10671 when Pragma_Assert |
10672 Pragma_Assert_And_Cut |
10674 Pragma_Loop_Invariant
=>
10676 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
10677 -- Determine whether expression Expr contains a Loop_Entry
10678 -- attribute reference.
10680 -------------------------
10681 -- Contains_Loop_Entry --
10682 -------------------------
10684 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
10685 Has_Loop_Entry
: Boolean := False;
10687 function Process
(N
: Node_Id
) return Traverse_Result
;
10688 -- Process function for traversal to look for Loop_Entry
10694 function Process
(N
: Node_Id
) return Traverse_Result
is
10696 if Nkind
(N
) = N_Attribute_Reference
10697 and then Attribute_Name
(N
) = Name_Loop_Entry
10699 Has_Loop_Entry
:= True;
10706 procedure Traverse
is new Traverse_Proc
(Process
);
10708 -- Start of processing for Contains_Loop_Entry
10712 return Has_Loop_Entry
;
10713 end Contains_Loop_Entry
;
10720 -- Start of processing for Assert
10723 -- Assert is an Ada 2005 RM-defined pragma
10725 if Prag_Id
= Pragma_Assert
then
10728 -- The remaining ones are GNAT pragmas
10734 Check_At_Least_N_Arguments
(1);
10735 Check_At_Most_N_Arguments
(2);
10736 Check_Arg_Order
((Name_Check
, Name_Message
));
10737 Check_Optional_Identifier
(Arg1
, Name_Check
);
10738 Expr
:= Get_Pragma_Arg
(Arg1
);
10740 -- Special processing for Loop_Invariant, Loop_Variant or for
10741 -- other cases where a Loop_Entry attribute is present. If the
10742 -- assertion pragma contains attribute Loop_Entry, ensure that
10743 -- the related pragma is within a loop.
10745 if Prag_Id
= Pragma_Loop_Invariant
10746 or else Prag_Id
= Pragma_Loop_Variant
10747 or else Contains_Loop_Entry
(Expr
)
10749 Check_Loop_Pragma_Placement
;
10751 -- Perform preanalysis to deal with embedded Loop_Entry
10754 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
10757 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
10758 -- a corresponding Check pragma:
10760 -- pragma Check (name, condition [, msg]);
10762 -- Where name is the identifier matching the pragma name. So
10763 -- rewrite pragma in this manner, transfer the message argument
10764 -- if present, and analyze the result
10766 -- Note: When dealing with a semantically analyzed tree, the
10767 -- information that a Check node N corresponds to a source Assert,
10768 -- Assume, or Assert_And_Cut pragma can be retrieved from the
10769 -- pragma kind of Original_Node(N).
10772 Make_Pragma_Argument_Association
(Loc
,
10773 Expression
=> Make_Identifier
(Loc
, Pname
)),
10774 Make_Pragma_Argument_Association
(Sloc
(Expr
),
10775 Expression
=> Expr
));
10777 if Arg_Count
> 1 then
10778 Check_Optional_Identifier
(Arg2
, Name_Message
);
10780 -- Provide semantic annnotations for optional argument, for
10781 -- ASIS use, before rewriting.
10783 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
10784 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
10787 -- Rewrite as Check pragma
10791 Chars
=> Name_Check
,
10792 Pragma_Argument_Associations
=> Newa
));
10796 ----------------------
10797 -- Assertion_Policy --
10798 ----------------------
10800 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
10802 -- The following form is Ada 2012 only, but we allow it in all modes
10804 -- Pragma Assertion_Policy (
10805 -- ASSERTION_KIND => POLICY_IDENTIFIER
10806 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
10808 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
10810 -- RM_ASSERTION_KIND ::= Assert |
10811 -- Static_Predicate |
10812 -- Dynamic_Predicate |
10817 -- Type_Invariant |
10818 -- Type_Invariant'Class
10820 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
10822 -- Contract_Cases |
10824 -- Default_Initial_Condition |
10826 -- Initial_Condition |
10827 -- Loop_Invariant |
10833 -- Statement_Assertions
10835 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
10836 -- ID_ASSERTION_KIND list contains implementation-defined additions
10837 -- recognized by GNAT. The effect is to control the behavior of
10838 -- identically named aspects and pragmas, depending on the specified
10839 -- policy identifier:
10841 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
10843 -- Note: Check and Ignore are language-defined. Disable is a GNAT
10844 -- implementation defined addition that results in totally ignoring
10845 -- the corresponding assertion. If Disable is specified, then the
10846 -- argument of the assertion is not even analyzed. This is useful
10847 -- when the aspect/pragma argument references entities in a with'ed
10848 -- package that is replaced by a dummy package in the final build.
10850 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
10851 -- and Type_Invariant'Class were recognized by the parser and
10852 -- transformed into references to the special internal identifiers
10853 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
10854 -- processing is required here.
10856 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
10865 -- This can always appear as a configuration pragma
10867 if Is_Configuration_Pragma
then
10870 -- It can also appear in a declarative part or package spec in Ada
10871 -- 2012 mode. We allow this in other modes, but in that case we
10872 -- consider that we have an Ada 2012 pragma on our hands.
10875 Check_Is_In_Decl_Part_Or_Package_Spec
;
10879 -- One argument case with no identifier (first form above)
10882 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
10883 or else Chars
(Arg1
) = No_Name
)
10885 Check_Arg_Is_One_Of
10886 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
10888 -- Treat one argument Assertion_Policy as equivalent to:
10890 -- pragma Check_Policy (Assertion, policy)
10892 -- So rewrite pragma in that manner and link on to the chain
10893 -- of Check_Policy pragmas, marking the pragma as analyzed.
10895 Policy
:= Get_Pragma_Arg
(Arg1
);
10899 Chars
=> Name_Check_Policy
,
10900 Pragma_Argument_Associations
=> New_List
(
10901 Make_Pragma_Argument_Association
(Loc
,
10902 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
10904 Make_Pragma_Argument_Association
(Loc
,
10906 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
10909 -- Here if we have two or more arguments
10912 Check_At_Least_N_Arguments
(1);
10915 -- Loop through arguments
10918 while Present
(Arg
) loop
10919 LocP
:= Sloc
(Arg
);
10921 -- Kind must be specified
10923 if Nkind
(Arg
) /= N_Pragma_Argument_Association
10924 or else Chars
(Arg
) = No_Name
10927 ("missing assertion kind for pragma%", Arg
);
10930 -- Check Kind and Policy have allowed forms
10932 Kind
:= Chars
(Arg
);
10934 if not Is_Valid_Assertion_Kind
(Kind
) then
10936 ("invalid assertion kind for pragma%", Arg
);
10939 Check_Arg_Is_One_Of
10940 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
10942 -- Rewrite the Assertion_Policy pragma as a series of
10943 -- Check_Policy pragmas of the form:
10945 -- Check_Policy (Kind, Policy);
10947 -- Note: the insertion of the pragmas cannot be done with
10948 -- Insert_Action because in the configuration case, there
10949 -- are no scopes on the scope stack and the mechanism will
10952 Insert_Before_And_Analyze
(N
,
10954 Chars
=> Name_Check_Policy
,
10955 Pragma_Argument_Associations
=> New_List
(
10956 Make_Pragma_Argument_Association
(LocP
,
10957 Expression
=> Make_Identifier
(LocP
, Kind
)),
10958 Make_Pragma_Argument_Association
(LocP
,
10959 Expression
=> Get_Pragma_Arg
(Arg
)))));
10964 -- Rewrite the Assertion_Policy pragma as null since we have
10965 -- now inserted all the equivalent Check pragmas.
10967 Rewrite
(N
, Make_Null_Statement
(Loc
));
10970 end Assertion_Policy
;
10972 ------------------------------
10973 -- Assume_No_Invalid_Values --
10974 ------------------------------
10976 -- pragma Assume_No_Invalid_Values (On | Off);
10978 when Pragma_Assume_No_Invalid_Values
=>
10980 Check_Valid_Configuration_Pragma
;
10981 Check_Arg_Count
(1);
10982 Check_No_Identifiers
;
10983 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
10985 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
10986 Assume_No_Invalid_Values
:= True;
10988 Assume_No_Invalid_Values
:= False;
10991 --------------------------
10992 -- Attribute_Definition --
10993 --------------------------
10995 -- pragma Attribute_Definition
10996 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
10997 -- [Entity =>] LOCAL_NAME,
10998 -- [Expression =>] EXPRESSION | NAME);
11000 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11001 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11006 Check_Arg_Count
(3);
11007 Check_Optional_Identifier
(Arg1
, "attribute");
11008 Check_Optional_Identifier
(Arg2
, "entity");
11009 Check_Optional_Identifier
(Arg3
, "expression");
11011 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11012 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11016 Check_Arg_Is_Local_Name
(Arg2
);
11018 -- If the attribute is not recognized, then issue a warning (not
11019 -- an error), and ignore the pragma.
11021 Aname
:= Chars
(Attribute_Designator
);
11023 if not Is_Attribute_Name
(Aname
) then
11024 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11028 -- Otherwise, rewrite the pragma as an attribute definition clause
11031 Make_Attribute_Definition_Clause
(Loc
,
11032 Name
=> Get_Pragma_Arg
(Arg2
),
11034 Expression
=> Get_Pragma_Arg
(Arg3
)));
11036 end Attribute_Definition
;
11038 ------------------------------------------------------------------
11039 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11040 ------------------------------------------------------------------
11042 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11043 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11044 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11045 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11047 -- FLAG ::= boolean_EXPRESSION
11049 when Pragma_Async_Readers |
11050 Pragma_Async_Writers |
11051 Pragma_Effective_Reads |
11052 Pragma_Effective_Writes
=>
11053 Async_Effective
: declare
11057 Obj_Id
: Entity_Id
;
11061 Check_No_Identifiers
;
11062 Check_At_Least_N_Arguments
(1);
11063 Check_At_Most_N_Arguments
(2);
11064 Check_Arg_Is_Local_Name
(Arg1
);
11065 Error_Msg_Name_1
:= Pname
;
11067 Obj
:= Get_Pragma_Arg
(Arg1
);
11068 Expr
:= Get_Pragma_Arg
(Arg2
);
11070 -- Perform minimal verification to ensure that the argument is at
11071 -- least a variable. Subsequent finer grained checks will be done
11072 -- at the end of the declarative region the contains the pragma.
11074 if Is_Entity_Name
(Obj
)
11075 and then Present
(Entity
(Obj
))
11076 and then Ekind
(Entity
(Obj
)) = E_Variable
11078 Obj_Id
:= Entity
(Obj
);
11080 -- Detect a duplicate pragma. Note that it is not efficient to
11081 -- examine preceding statements as Boolean aspects may appear
11082 -- anywhere between the related object declaration and its
11083 -- freeze point. As an alternative, inspect the contents of the
11084 -- variable contract.
11086 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
11088 if Present
(Duplic
) then
11089 Error_Msg_Sloc
:= Sloc
(Duplic
);
11090 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
11092 -- No duplicate detected
11095 if Present
(Expr
) then
11096 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
11099 -- Chain the pragma on the contract for further processing
11100 -- by Analyze_External_Property_In_Decl_Part.
11102 Add_Contract_Item
(N
, Obj_Id
);
11105 Error_Pragma
("pragma % must apply to a volatile object");
11107 end Async_Effective
;
11113 -- pragma Asynchronous (LOCAL_NAME);
11115 when Pragma_Asynchronous
=> Asynchronous
: declare
11121 Formal
: Entity_Id
;
11123 procedure Process_Async_Pragma
;
11124 -- Common processing for procedure and access-to-procedure case
11126 --------------------------
11127 -- Process_Async_Pragma --
11128 --------------------------
11130 procedure Process_Async_Pragma
is
11133 Set_Is_Asynchronous
(Nm
);
11137 -- The formals should be of mode IN (RM E.4.1(6))
11140 while Present
(S
) loop
11141 Formal
:= Defining_Identifier
(S
);
11143 if Nkind
(Formal
) = N_Defining_Identifier
11144 and then Ekind
(Formal
) /= E_In_Parameter
11147 ("pragma% procedure can only have IN parameter",
11154 Set_Is_Asynchronous
(Nm
);
11155 end Process_Async_Pragma
;
11157 -- Start of processing for pragma Asynchronous
11160 Check_Ada_83_Warning
;
11161 Check_No_Identifiers
;
11162 Check_Arg_Count
(1);
11163 Check_Arg_Is_Local_Name
(Arg1
);
11165 if Debug_Flag_U
then
11169 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11170 Analyze
(Get_Pragma_Arg
(Arg1
));
11171 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11173 if not Is_Remote_Call_Interface
(C_Ent
)
11174 and then not Is_Remote_Types
(C_Ent
)
11176 -- This pragma should only appear in an RCI or Remote Types
11177 -- unit (RM E.4.1(4)).
11180 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11183 if Ekind
(Nm
) = E_Procedure
11184 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11186 if not Is_Remote_Call_Interface
(Nm
) then
11188 ("pragma% cannot be applied on non-remote procedure",
11192 L
:= Parameter_Specifications
(Parent
(Nm
));
11193 Process_Async_Pragma
;
11196 elsif Ekind
(Nm
) = E_Function
then
11198 ("pragma% cannot be applied to function", Arg1
);
11200 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11201 if Is_Record_Type
(Nm
) then
11203 -- A record type that is the Equivalent_Type for a remote
11204 -- access-to-subprogram type.
11206 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11209 -- A non-expanded RAS type (distribution is not enabled)
11211 N
:= Declaration_Node
(Nm
);
11214 if Nkind
(N
) = N_Full_Type_Declaration
11215 and then Nkind
(Type_Definition
(N
)) =
11216 N_Access_Procedure_Definition
11218 L
:= Parameter_Specifications
(Type_Definition
(N
));
11219 Process_Async_Pragma
;
11221 if Is_Asynchronous
(Nm
)
11222 and then Expander_Active
11223 and then Get_PCS_Name
/= Name_No_DSA
11225 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11230 ("pragma% cannot reference access-to-function type",
11234 -- Only other possibility is Access-to-class-wide type
11236 elsif Is_Access_Type
(Nm
)
11237 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11239 Check_First_Subtype
(Arg1
);
11240 Set_Is_Asynchronous
(Nm
);
11241 if Expander_Active
then
11242 RACW_Type_Is_Asynchronous
(Nm
);
11246 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11254 -- pragma Atomic (LOCAL_NAME);
11256 when Pragma_Atomic
=>
11257 Process_Atomic_Independent_Shared_Volatile
;
11259 -----------------------
11260 -- Atomic_Components --
11261 -----------------------
11263 -- pragma Atomic_Components (array_LOCAL_NAME);
11265 -- This processing is shared by Volatile_Components
11267 when Pragma_Atomic_Components |
11268 Pragma_Volatile_Components
=>
11270 Atomic_Components
: declare
11277 Check_Ada_83_Warning
;
11278 Check_No_Identifiers
;
11279 Check_Arg_Count
(1);
11280 Check_Arg_Is_Local_Name
(Arg1
);
11281 E_Id
:= Get_Pragma_Arg
(Arg1
);
11283 if Etype
(E_Id
) = Any_Type
then
11287 E
:= Entity
(E_Id
);
11289 Check_Duplicate_Pragma
(E
);
11291 if Rep_Item_Too_Early
(E
, N
)
11293 Rep_Item_Too_Late
(E
, N
)
11298 D
:= Declaration_Node
(E
);
11301 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11303 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11304 and then Nkind
(D
) = N_Object_Declaration
11305 and then Nkind
(Object_Definition
(D
)) =
11306 N_Constrained_Array_Definition
)
11308 -- The flag is set on the object, or on the base type
11310 if Nkind
(D
) /= N_Object_Declaration
then
11311 E
:= Base_Type
(E
);
11314 -- Atomic implies both Independent and Volatile
11316 if Prag_Id
= Pragma_Atomic_Components
then
11317 Set_Has_Atomic_Components
(E
);
11318 Set_Has_Independent_Components
(E
);
11321 Set_Has_Volatile_Components
(E
);
11324 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11326 end Atomic_Components
;
11328 --------------------
11329 -- Attach_Handler --
11330 --------------------
11332 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11334 when Pragma_Attach_Handler
=>
11335 Check_Ada_83_Warning
;
11336 Check_No_Identifiers
;
11337 Check_Arg_Count
(2);
11339 if No_Run_Time_Mode
then
11340 Error_Msg_CRT
("Attach_Handler pragma", N
);
11342 Check_Interrupt_Or_Attach_Handler
;
11344 -- The expression that designates the attribute may depend on a
11345 -- discriminant, and is therefore a per-object expression, to
11346 -- be expanded in the init proc. If expansion is enabled, then
11347 -- perform semantic checks on a copy only.
11352 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11355 -- In Relaxed_RM_Semantics mode, we allow any static
11356 -- integer value, for compatibility with other compilers.
11358 if Relaxed_RM_Semantics
11359 and then Nkind
(Parg2
) = N_Integer_Literal
11361 Typ
:= Standard_Integer
;
11363 Typ
:= RTE
(RE_Interrupt_ID
);
11366 if Expander_Active
then
11367 Temp
:= New_Copy_Tree
(Parg2
);
11368 Set_Parent
(Temp
, N
);
11369 Preanalyze_And_Resolve
(Temp
, Typ
);
11372 Resolve
(Parg2
, Typ
);
11376 Process_Interrupt_Or_Attach_Handler
;
11379 --------------------
11380 -- C_Pass_By_Copy --
11381 --------------------
11383 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11385 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11391 Check_Valid_Configuration_Pragma
;
11392 Check_Arg_Count
(1);
11393 Check_Optional_Identifier
(Arg1
, "max_size");
11395 Arg
:= Get_Pragma_Arg
(Arg1
);
11396 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11398 Val
:= Expr_Value
(Arg
);
11402 ("maximum size for pragma% must be positive", Arg1
);
11404 elsif UI_Is_In_Int_Range
(Val
) then
11405 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11407 -- If a giant value is given, Int'Last will do well enough.
11408 -- If sometime someone complains that a record larger than
11409 -- two gigabytes is not copied, we will worry about it then.
11412 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11414 end C_Pass_By_Copy
;
11420 -- pragma Check ([Name =>] CHECK_KIND,
11421 -- [Check =>] Boolean_EXPRESSION
11422 -- [,[Message =>] String_EXPRESSION]);
11424 -- CHECK_KIND ::= IDENTIFIER |
11427 -- Invariant'Class |
11428 -- Type_Invariant'Class
11430 -- The identifiers Assertions and Statement_Assertions are not
11431 -- allowed, since they have special meaning for Check_Policy.
11433 when Pragma_Check
=> Check
: declare
11441 Check_At_Least_N_Arguments
(2);
11442 Check_At_Most_N_Arguments
(3);
11443 Check_Optional_Identifier
(Arg1
, Name_Name
);
11444 Check_Optional_Identifier
(Arg2
, Name_Check
);
11446 if Arg_Count
= 3 then
11447 Check_Optional_Identifier
(Arg3
, Name_Message
);
11448 Str
:= Get_Pragma_Arg
(Arg3
);
11451 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11452 Check_Arg_Is_Identifier
(Arg1
);
11453 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11455 -- Check forbidden name Assertions or Statement_Assertions
11458 when Name_Assertions
=>
11460 ("""Assertions"" is not allowed as a check kind "
11461 & "for pragma%", Arg1
);
11463 when Name_Statement_Assertions
=>
11465 ("""Statement_Assertions"" is not allowed as a check kind "
11466 & "for pragma%", Arg1
);
11472 -- Check applicable policy. We skip this if Checked/Ignored status
11473 -- is already set (e.g. in the case of a pragma from an aspect).
11475 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11478 -- For a non-source pragma that is a rewriting of another pragma,
11479 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11481 elsif Is_Rewrite_Substitution
(N
)
11482 and then Nkind
(Original_Node
(N
)) = N_Pragma
11483 and then Original_Node
(N
) /= N
11485 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11486 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11488 -- Otherwise query the applicable policy at this point
11491 case Check_Kind
(Cname
) is
11492 when Name_Ignore
=>
11493 Set_Is_Ignored
(N
, True);
11494 Set_Is_Checked
(N
, False);
11497 Set_Is_Ignored
(N
, False);
11498 Set_Is_Checked
(N
, True);
11500 -- For disable, rewrite pragma as null statement and skip
11501 -- rest of the analysis of the pragma.
11503 when Name_Disable
=>
11504 Rewrite
(N
, Make_Null_Statement
(Loc
));
11508 -- No other possibilities
11511 raise Program_Error
;
11515 -- If check kind was not Disable, then continue pragma analysis
11517 Expr
:= Get_Pragma_Arg
(Arg2
);
11519 -- Deal with SCO generation
11522 when Name_Predicate |
11525 -- Nothing to do: since checks occur in client units,
11526 -- the SCO for the aspect in the declaration unit is
11527 -- conservatively always enabled.
11533 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11535 -- Mark aspect/pragma SCO as enabled
11537 Set_SCO_Pragma_Enabled
(Loc
);
11541 -- Deal with analyzing the string argument
11543 if Arg_Count
= 3 then
11545 -- If checks are not on we don't want any expansion (since
11546 -- such expansion would not get properly deleted) but
11547 -- we do want to analyze (to get proper references).
11548 -- The Preanalyze_And_Resolve routine does just what we want
11550 if Is_Ignored
(N
) then
11551 Preanalyze_And_Resolve
(Str
, Standard_String
);
11553 -- Otherwise we need a proper analysis and expansion
11556 Analyze_And_Resolve
(Str
, Standard_String
);
11560 -- Now you might think we could just do the same with the Boolean
11561 -- expression if checks are off (and expansion is on) and then
11562 -- rewrite the check as a null statement. This would work but we
11563 -- would lose the useful warnings about an assertion being bound
11564 -- to fail even if assertions are turned off.
11566 -- So instead we wrap the boolean expression in an if statement
11567 -- that looks like:
11569 -- if False and then condition then
11573 -- The reason we do this rewriting during semantic analysis rather
11574 -- than as part of normal expansion is that we cannot analyze and
11575 -- expand the code for the boolean expression directly, or it may
11576 -- cause insertion of actions that would escape the attempt to
11577 -- suppress the check code.
11579 -- Note that the Sloc for the if statement corresponds to the
11580 -- argument condition, not the pragma itself. The reason for
11581 -- this is that we may generate a warning if the condition is
11582 -- False at compile time, and we do not want to delete this
11583 -- warning when we delete the if statement.
11585 if Expander_Active
and Is_Ignored
(N
) then
11586 Eloc
:= Sloc
(Expr
);
11589 Make_If_Statement
(Eloc
,
11591 Make_And_Then
(Eloc
,
11592 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
11593 Right_Opnd
=> Expr
),
11594 Then_Statements
=> New_List
(
11595 Make_Null_Statement
(Eloc
))));
11597 -- Now go ahead and analyze the if statement
11599 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11601 -- One rather special treatment. If we are now in Eliminated
11602 -- overflow mode, then suppress overflow checking since we do
11603 -- not want to drag in the bignum stuff if we are in Ignore
11604 -- mode anyway. This is particularly important if we are using
11605 -- a configurable run time that does not support bignum ops.
11607 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
11609 Svo
: constant Boolean :=
11610 Scope_Suppress
.Suppress
(Overflow_Check
);
11612 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
11613 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
11615 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
11616 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
11619 -- Not that special case!
11625 -- All done with this check
11627 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11629 -- Check is active or expansion not active. In these cases we can
11630 -- just go ahead and analyze the boolean with no worries.
11633 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11634 Analyze_And_Resolve
(Expr
, Any_Boolean
);
11635 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11639 --------------------------
11640 -- Check_Float_Overflow --
11641 --------------------------
11643 -- pragma Check_Float_Overflow;
11645 when Pragma_Check_Float_Overflow
=>
11647 Check_Valid_Configuration_Pragma
;
11648 Check_Arg_Count
(0);
11649 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
11655 -- pragma Check_Name (check_IDENTIFIER);
11657 when Pragma_Check_Name
=>
11659 Check_No_Identifiers
;
11660 Check_Valid_Configuration_Pragma
;
11661 Check_Arg_Count
(1);
11662 Check_Arg_Is_Identifier
(Arg1
);
11665 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
11668 for J
in Check_Names
.First
.. Check_Names
.Last
loop
11669 if Check_Names
.Table
(J
) = Nam
then
11674 Check_Names
.Append
(Nam
);
11681 -- This is the old style syntax, which is still allowed in all modes:
11683 -- pragma Check_Policy ([Name =>] CHECK_KIND
11684 -- [Policy =>] POLICY_IDENTIFIER);
11686 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
11688 -- CHECK_KIND ::= IDENTIFIER |
11691 -- Type_Invariant'Class |
11694 -- This is the new style syntax, compatible with Assertion_Policy
11695 -- and also allowed in all modes.
11697 -- Pragma Check_Policy (
11698 -- CHECK_KIND => POLICY_IDENTIFIER
11699 -- {, CHECK_KIND => POLICY_IDENTIFIER});
11701 -- Note: the identifiers Name and Policy are not allowed as
11702 -- Check_Kind values. This avoids ambiguities between the old and
11703 -- new form syntax.
11705 when Pragma_Check_Policy
=> Check_Policy
: declare
11711 Check_At_Least_N_Arguments
(1);
11713 -- A Check_Policy pragma can appear either as a configuration
11714 -- pragma, or in a declarative part or a package spec (see RM
11715 -- 11.5(5) for rules for Suppress/Unsuppress which are also
11716 -- followed for Check_Policy).
11718 if not Is_Configuration_Pragma
then
11719 Check_Is_In_Decl_Part_Or_Package_Spec
;
11722 -- Figure out if we have the old or new syntax. We have the
11723 -- old syntax if the first argument has no identifier, or the
11724 -- identifier is Name.
11726 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
11727 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
11731 Check_Arg_Count
(2);
11732 Check_Optional_Identifier
(Arg1
, Name_Name
);
11733 Kind
:= Get_Pragma_Arg
(Arg1
);
11734 Rewrite_Assertion_Kind
(Kind
);
11735 Check_Arg_Is_Identifier
(Arg1
);
11737 -- Check forbidden check kind
11739 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
11740 Error_Msg_Name_2
:= Chars
(Kind
);
11742 ("pragma% does not allow% as check name", Arg1
);
11747 Check_Optional_Identifier
(Arg2
, Name_Policy
);
11748 Check_Arg_Is_One_Of
11750 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
11751 Ident
:= Get_Pragma_Arg
(Arg2
);
11753 if Chars
(Kind
) = Name_Ghost
then
11755 -- Pragma Check_Policy specifying a Ghost policy cannot
11756 -- occur within a ghost subprogram or package.
11758 if Ghost_Mode
> None
then
11760 ("pragma % cannot appear within ghost subprogram or "
11763 -- The policy identifier of pragma Ghost must be either
11764 -- Check or Ignore (SPARK RM 6.9(7)).
11766 elsif not Nam_In
(Chars
(Ident
), Name_Check
,
11770 ("argument of pragma % Ghost must be Check or Ignore",
11775 -- And chain pragma on the Check_Policy_List for search
11777 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
11778 Opt
.Check_Policy_List
:= N
;
11780 -- For the new syntax, what we do is to convert each argument to
11781 -- an old syntax equivalent. We do that because we want to chain
11782 -- old style Check_Policy pragmas for the search (we don't want
11783 -- to have to deal with multiple arguments in the search).
11793 while Present
(Arg
) loop
11794 LocP
:= Sloc
(Arg
);
11795 Argx
:= Get_Pragma_Arg
(Arg
);
11797 -- Kind must be specified
11799 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11800 or else Chars
(Arg
) = No_Name
11803 ("missing assertion kind for pragma%", Arg
);
11806 -- Construct equivalent old form syntax Check_Policy
11807 -- pragma and insert it to get remaining checks.
11811 Chars
=> Name_Check_Policy
,
11812 Pragma_Argument_Associations
=> New_List
(
11813 Make_Pragma_Argument_Association
(LocP
,
11815 Make_Identifier
(LocP
, Chars
(Arg
))),
11816 Make_Pragma_Argument_Association
(Sloc
(Argx
),
11817 Expression
=> Argx
))));
11822 -- Rewrite original Check_Policy pragma to null, since we
11823 -- have converted it into a series of old syntax pragmas.
11825 Rewrite
(N
, Make_Null_Statement
(Loc
));
11831 ---------------------
11832 -- CIL_Constructor --
11833 ---------------------
11835 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
11837 -- Processing for this pragma is shared with Java_Constructor
11843 -- pragma Comment (static_string_EXPRESSION)
11845 -- Processing for pragma Comment shares the circuitry for pragma
11846 -- Ident. The only differences are that Ident enforces a limit of 31
11847 -- characters on its argument, and also enforces limitations on
11848 -- placement for DEC compatibility. Pragma Comment shares neither of
11849 -- these restrictions.
11851 -------------------
11852 -- Common_Object --
11853 -------------------
11855 -- pragma Common_Object (
11856 -- [Internal =>] LOCAL_NAME
11857 -- [, [External =>] EXTERNAL_SYMBOL]
11858 -- [, [Size =>] EXTERNAL_SYMBOL]);
11860 -- Processing for this pragma is shared with Psect_Object
11862 ------------------------
11863 -- Compile_Time_Error --
11864 ------------------------
11866 -- pragma Compile_Time_Error
11867 -- (boolean_EXPRESSION, static_string_EXPRESSION);
11869 when Pragma_Compile_Time_Error
=>
11871 Process_Compile_Time_Warning_Or_Error
;
11873 --------------------------
11874 -- Compile_Time_Warning --
11875 --------------------------
11877 -- pragma Compile_Time_Warning
11878 -- (boolean_EXPRESSION, static_string_EXPRESSION);
11880 when Pragma_Compile_Time_Warning
=>
11882 Process_Compile_Time_Warning_Or_Error
;
11884 ---------------------------
11885 -- Compiler_Unit_Warning --
11886 ---------------------------
11888 -- pragma Compiler_Unit_Warning;
11892 -- Originally, we had only pragma Compiler_Unit, and it resulted in
11893 -- errors not warnings. This means that we had introduced a big extra
11894 -- inertia to compiler changes, since even if we implemented a new
11895 -- feature, and even if all versions to be used for bootstrapping
11896 -- implemented this new feature, we could not use it, since old
11897 -- compilers would give errors for using this feature in units
11898 -- having Compiler_Unit pragmas.
11900 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
11901 -- problem. We no longer have any units mentioning Compiler_Unit,
11902 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
11903 -- and thus generates a warning which can be ignored. So that deals
11904 -- with the problem of old compilers not implementing the newer form
11907 -- Newer compilers recognize the new pragma, but generate warning
11908 -- messages instead of errors, which again can be ignored in the
11909 -- case of an old compiler which implements a wanted new feature
11910 -- but at the time felt like warning about it for older compilers.
11912 -- We retain Compiler_Unit so that new compilers can be used to build
11913 -- older run-times that use this pragma. That's an unusual case, but
11914 -- it's easy enough to handle, so why not?
11916 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
11918 Check_Arg_Count
(0);
11920 -- Only recognized in main unit
11922 if Current_Sem_Unit
= Main_Unit
then
11923 Compiler_Unit
:= True;
11926 -----------------------------
11927 -- Complete_Representation --
11928 -----------------------------
11930 -- pragma Complete_Representation;
11932 when Pragma_Complete_Representation
=>
11934 Check_Arg_Count
(0);
11936 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
11938 ("pragma & must appear within record representation clause");
11941 ----------------------------
11942 -- Complex_Representation --
11943 ----------------------------
11945 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
11947 when Pragma_Complex_Representation
=> Complex_Representation
: declare
11954 Check_Arg_Count
(1);
11955 Check_Optional_Identifier
(Arg1
, Name_Entity
);
11956 Check_Arg_Is_Local_Name
(Arg1
);
11957 E_Id
:= Get_Pragma_Arg
(Arg1
);
11959 if Etype
(E_Id
) = Any_Type
then
11963 E
:= Entity
(E_Id
);
11965 if not Is_Record_Type
(E
) then
11967 ("argument for pragma% must be record type", Arg1
);
11970 Ent
:= First_Entity
(E
);
11973 or else No
(Next_Entity
(Ent
))
11974 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
11975 or else not Is_Floating_Point_Type
(Etype
(Ent
))
11976 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
11979 ("record for pragma% must have two fields of the same "
11980 & "floating-point type", Arg1
);
11983 Set_Has_Complex_Representation
(Base_Type
(E
));
11985 -- We need to treat the type has having a non-standard
11986 -- representation, for back-end purposes, even though in
11987 -- general a complex will have the default representation
11988 -- of a record with two real components.
11990 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
11992 end Complex_Representation
;
11994 -------------------------
11995 -- Component_Alignment --
11996 -------------------------
11998 -- pragma Component_Alignment (
11999 -- [Form =>] ALIGNMENT_CHOICE
12000 -- [, [Name =>] type_LOCAL_NAME]);
12002 -- ALIGNMENT_CHOICE ::=
12004 -- | Component_Size_4
12008 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12009 Args
: Args_List
(1 .. 2);
12010 Names
: constant Name_List
(1 .. 2) := (
12014 Form
: Node_Id
renames Args
(1);
12015 Name
: Node_Id
renames Args
(2);
12017 Atype
: Component_Alignment_Kind
;
12022 Gather_Associations
(Names
, Args
);
12025 Error_Pragma
("missing Form argument for pragma%");
12028 Check_Arg_Is_Identifier
(Form
);
12030 -- Get proper alignment, note that Default = Component_Size on all
12031 -- machines we have so far, and we want to set this value rather
12032 -- than the default value to indicate that it has been explicitly
12033 -- set (and thus will not get overridden by the default component
12034 -- alignment for the current scope)
12036 if Chars
(Form
) = Name_Component_Size
then
12037 Atype
:= Calign_Component_Size
;
12039 elsif Chars
(Form
) = Name_Component_Size_4
then
12040 Atype
:= Calign_Component_Size_4
;
12042 elsif Chars
(Form
) = Name_Default
then
12043 Atype
:= Calign_Component_Size
;
12045 elsif Chars
(Form
) = Name_Storage_Unit
then
12046 Atype
:= Calign_Storage_Unit
;
12050 ("invalid Form parameter for pragma%", Form
);
12053 -- Case with no name, supplied, affects scope table entry
12057 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12059 -- Case of name supplied
12062 Check_Arg_Is_Local_Name
(Name
);
12064 Typ
:= Entity
(Name
);
12067 or else Rep_Item_Too_Early
(Typ
, N
)
12071 Typ
:= Underlying_Type
(Typ
);
12074 if not Is_Record_Type
(Typ
)
12075 and then not Is_Array_Type
(Typ
)
12078 ("Name parameter of pragma% must identify record or "
12079 & "array type", Name
);
12082 -- An explicit Component_Alignment pragma overrides an
12083 -- implicit pragma Pack, but not an explicit one.
12085 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12086 Set_Is_Packed
(Base_Type
(Typ
), False);
12087 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12090 end Component_AlignmentP
;
12092 --------------------
12093 -- Contract_Cases --
12094 --------------------
12096 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12098 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12100 -- CASE_GUARD ::= boolean_EXPRESSION | others
12102 -- CONSEQUENCE ::= boolean_EXPRESSION
12104 -- Characteristics:
12106 -- * Analysis - The annotation undergoes initial checks to verify
12107 -- the legal placement and context. Secondary checks preanalyze the
12110 -- Analyze_Contract_Cases_In_Decl_Part
12112 -- * Expansion - The annotation is expanded during the expansion of
12113 -- the related subprogram [body] contract as performed in:
12115 -- Expand_Subprogram_Contract
12117 -- * Template - The annotation utilizes the generic template of the
12118 -- related subprogram [body] when it is:
12120 -- aspect on subprogram declaration
12121 -- aspect on stand alone subprogram body
12122 -- pragma on stand alone subprogram body
12124 -- The annotation must prepare its own template when it is:
12126 -- pragma on subprogram declaration
12128 -- * Globals - Capture of global references must occur after full
12131 -- * Instance - The annotation is instantiated automatically when
12132 -- the related generic subprogram [body] is instantiated except for
12133 -- the "pragma on subprogram declaration" case. In that scenario
12134 -- the annotation must instantiate itself.
12136 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12137 Spec_Id
: Entity_Id
;
12138 Subp_Decl
: Node_Id
;
12142 Check_No_Identifiers
;
12143 Check_Arg_Count
(1);
12145 -- The pragma is analyzed at the end of the declarative part which
12146 -- contains the related subprogram. Reset the analyzed flag.
12148 Set_Analyzed
(N
, False);
12150 -- Ensure the proper placement of the pragma. Contract_Cases must
12151 -- be associated with a subprogram declaration or a body that acts
12155 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12157 -- Generic subprogram
12159 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
12162 -- Body acts as spec
12164 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12165 and then No
(Corresponding_Spec
(Subp_Decl
))
12169 -- Body stub acts as spec
12171 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12172 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12178 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12186 Spec_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
12188 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
12190 -- Fully analyze the pragma when it appears inside a subprogram
12191 -- body because it cannot benefit from forward references.
12193 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12194 Analyze_Contract_Cases_In_Decl_Part
(N
);
12197 -- Chain the pragma on the contract for further processing by
12198 -- Analyze_Contract_Cases_In_Decl_Part.
12200 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12201 end Contract_Cases
;
12207 -- pragma Controlled (first_subtype_LOCAL_NAME);
12209 when Pragma_Controlled
=> Controlled
: declare
12213 Check_No_Identifiers
;
12214 Check_Arg_Count
(1);
12215 Check_Arg_Is_Local_Name
(Arg1
);
12216 Arg
:= Get_Pragma_Arg
(Arg1
);
12218 if not Is_Entity_Name
(Arg
)
12219 or else not Is_Access_Type
(Entity
(Arg
))
12221 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12223 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12231 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12232 -- [Entity =>] LOCAL_NAME);
12234 when Pragma_Convention
=> Convention
: declare
12237 pragma Warnings
(Off
, C
);
12238 pragma Warnings
(Off
, E
);
12240 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12241 Check_Ada_83_Warning
;
12242 Check_Arg_Count
(2);
12243 Process_Convention
(C
, E
);
12246 ---------------------------
12247 -- Convention_Identifier --
12248 ---------------------------
12250 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12251 -- [Convention =>] convention_IDENTIFIER);
12253 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12259 Check_Arg_Order
((Name_Name
, Name_Convention
));
12260 Check_Arg_Count
(2);
12261 Check_Optional_Identifier
(Arg1
, Name_Name
);
12262 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12263 Check_Arg_Is_Identifier
(Arg1
);
12264 Check_Arg_Is_Identifier
(Arg2
);
12265 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12266 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12268 if Is_Convention_Name
(Cname
) then
12269 Record_Convention_Identifier
12270 (Idnam
, Get_Convention_Id
(Cname
));
12273 ("second arg for % pragma must be convention", Arg2
);
12275 end Convention_Identifier
;
12281 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12283 when Pragma_CPP_Class
=> CPP_Class
: declare
12287 if Warn_On_Obsolescent_Feature
then
12289 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12290 & "effect; replace it by pragma import?j?", N
);
12293 Check_Arg_Count
(1);
12297 Chars
=> Name_Import
,
12298 Pragma_Argument_Associations
=> New_List
(
12299 Make_Pragma_Argument_Association
(Loc
,
12300 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12301 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12305 ---------------------
12306 -- CPP_Constructor --
12307 ---------------------
12309 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12310 -- [, [External_Name =>] static_string_EXPRESSION ]
12311 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12313 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12316 Def_Id
: Entity_Id
;
12317 Tag_Typ
: Entity_Id
;
12321 Check_At_Least_N_Arguments
(1);
12322 Check_At_Most_N_Arguments
(3);
12323 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12324 Check_Arg_Is_Local_Name
(Arg1
);
12326 Id
:= Get_Pragma_Arg
(Arg1
);
12327 Find_Program_Unit_Name
(Id
);
12329 -- If we did not find the name, we are done
12331 if Etype
(Id
) = Any_Type
then
12335 Def_Id
:= Entity
(Id
);
12337 -- Check if already defined as constructor
12339 if Is_Constructor
(Def_Id
) then
12341 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12345 if Ekind
(Def_Id
) = E_Function
12346 and then (Is_CPP_Class
(Etype
(Def_Id
))
12347 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12349 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12351 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12353 ("'C'P'P constructor must be defined in the scope of "
12354 & "its returned type", Arg1
);
12357 if Arg_Count
>= 2 then
12358 Set_Imported
(Def_Id
);
12359 Set_Is_Public
(Def_Id
);
12360 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12363 Set_Has_Completion
(Def_Id
);
12364 Set_Is_Constructor
(Def_Id
);
12365 Set_Convention
(Def_Id
, Convention_CPP
);
12367 -- Imported C++ constructors are not dispatching primitives
12368 -- because in C++ they don't have a dispatch table slot.
12369 -- However, in Ada the constructor has the profile of a
12370 -- function that returns a tagged type and therefore it has
12371 -- been treated as a primitive operation during semantic
12372 -- analysis. We now remove it from the list of primitive
12373 -- operations of the type.
12375 if Is_Tagged_Type
(Etype
(Def_Id
))
12376 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12377 and then Is_Dispatching_Operation
(Def_Id
)
12379 Tag_Typ
:= Etype
(Def_Id
);
12381 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12382 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12386 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12387 Set_Is_Dispatching_Operation
(Def_Id
, False);
12390 -- For backward compatibility, if the constructor returns a
12391 -- class wide type, and we internally change the return type to
12392 -- the corresponding root type.
12394 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12395 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12399 ("pragma% requires function returning a 'C'P'P_Class type",
12402 end CPP_Constructor
;
12408 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12412 if Warn_On_Obsolescent_Feature
then
12414 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12423 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12427 if Warn_On_Obsolescent_Feature
then
12429 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12438 -- pragma CPU (EXPRESSION);
12440 when Pragma_CPU
=> CPU
: declare
12441 P
: constant Node_Id
:= Parent
(N
);
12447 Check_No_Identifiers
;
12448 Check_Arg_Count
(1);
12452 if Nkind
(P
) = N_Subprogram_Body
then
12453 Check_In_Main_Program
;
12455 Arg
:= Get_Pragma_Arg
(Arg1
);
12456 Analyze_And_Resolve
(Arg
, Any_Integer
);
12458 Ent
:= Defining_Unit_Name
(Specification
(P
));
12460 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12461 Ent
:= Defining_Identifier
(Ent
);
12466 if not Is_OK_Static_Expression
(Arg
) then
12467 Flag_Non_Static_Expr
12468 ("main subprogram affinity is not static!", Arg
);
12471 -- If constraint error, then we already signalled an error
12473 elsif Raises_Constraint_Error
(Arg
) then
12476 -- Otherwise check in range
12480 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12481 -- This is the entity System.Multiprocessors.CPU_Range;
12483 Val
: constant Uint
:= Expr_Value
(Arg
);
12486 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12488 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12491 ("main subprogram CPU is out of range", Arg1
);
12497 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12501 elsif Nkind
(P
) = N_Task_Definition
then
12502 Arg
:= Get_Pragma_Arg
(Arg1
);
12503 Ent
:= Defining_Identifier
(Parent
(P
));
12505 -- The expression must be analyzed in the special manner
12506 -- described in "Handling of Default and Per-Object
12507 -- Expressions" in sem.ads.
12509 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12511 -- Anything else is incorrect
12517 -- Check duplicate pragma before we chain the pragma in the Rep
12518 -- Item chain of Ent.
12520 Check_Duplicate_Pragma
(Ent
);
12521 Record_Rep_Item
(Ent
, N
);
12528 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12530 when Pragma_Debug
=> Debug
: declare
12537 -- The condition for executing the call is that the expander
12538 -- is active and that we are not ignoring this debug pragma.
12543 (Expander_Active
and then not Is_Ignored
(N
)),
12546 if not Is_Ignored
(N
) then
12547 Set_SCO_Pragma_Enabled
(Loc
);
12550 if Arg_Count
= 2 then
12552 Make_And_Then
(Loc
,
12553 Left_Opnd
=> Relocate_Node
(Cond
),
12554 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12555 Call
:= Get_Pragma_Arg
(Arg2
);
12557 Call
:= Get_Pragma_Arg
(Arg1
);
12561 N_Indexed_Component
,
12565 N_Selected_Component
)
12567 -- If this pragma Debug comes from source, its argument was
12568 -- parsed as a name form (which is syntactically identical).
12569 -- In a generic context a parameterless call will be left as
12570 -- an expanded name (if global) or selected_component if local.
12571 -- Change it to a procedure call statement now.
12573 Change_Name_To_Procedure_Call_Statement
(Call
);
12575 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12577 -- Already in the form of a procedure call statement: nothing
12578 -- to do (could happen in case of an internally generated
12584 -- All other cases: diagnose error
12587 ("argument of pragma ""Debug"" is not procedure call",
12592 -- Rewrite into a conditional with an appropriate condition. We
12593 -- wrap the procedure call in a block so that overhead from e.g.
12594 -- use of the secondary stack does not generate execution overhead
12595 -- for suppressed conditions.
12597 -- Normally the analysis that follows will freeze the subprogram
12598 -- being called. However, if the call is to a null procedure,
12599 -- we want to freeze it before creating the block, because the
12600 -- analysis that follows may be done with expansion disabled, in
12601 -- which case the body will not be generated, leading to spurious
12604 if Nkind
(Call
) = N_Procedure_Call_Statement
12605 and then Is_Entity_Name
(Name
(Call
))
12607 Analyze
(Name
(Call
));
12608 Freeze_Before
(N
, Entity
(Name
(Call
)));
12612 Make_Implicit_If_Statement
(N
,
12614 Then_Statements
=> New_List
(
12615 Make_Block_Statement
(Loc
,
12616 Handled_Statement_Sequence
=>
12617 Make_Handled_Sequence_Of_Statements
(Loc
,
12618 Statements
=> New_List
(Relocate_Node
(Call
)))))));
12621 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12622 -- after analysis of the normally rewritten node, to capture all
12623 -- references to entities, which avoids issuing wrong warnings
12624 -- about unused entities.
12626 if GNATprove_Mode
then
12627 Rewrite
(N
, Make_Null_Statement
(Loc
));
12635 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12637 when Pragma_Debug_Policy
=>
12639 Check_Arg_Count
(1);
12640 Check_No_Identifiers
;
12641 Check_Arg_Is_Identifier
(Arg1
);
12643 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12644 -- rewrite it that way, and let the rest of the checking come
12645 -- from analyzing the rewritten pragma.
12649 Chars
=> Name_Check_Policy
,
12650 Pragma_Argument_Associations
=> New_List
(
12651 Make_Pragma_Argument_Association
(Loc
,
12652 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
12654 Make_Pragma_Argument_Association
(Loc
,
12655 Expression
=> Get_Pragma_Arg
(Arg1
)))));
12658 -------------------------------
12659 -- Default_Initial_Condition --
12660 -------------------------------
12662 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
12664 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
12671 Check_No_Identifiers
;
12672 Check_At_Most_N_Arguments
(1);
12675 while Present
(Stmt
) loop
12677 -- Skip prior pragmas, but check for duplicates
12679 if Nkind
(Stmt
) = N_Pragma
then
12680 if Pragma_Name
(Stmt
) = Pname
then
12681 Error_Msg_Name_1
:= Pname
;
12682 Error_Msg_Sloc
:= Sloc
(Stmt
);
12683 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
12686 -- Skip internally generated code
12688 elsif not Comes_From_Source
(Stmt
) then
12691 -- The associated private type [extension] has been found, stop
12694 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
12695 N_Private_Type_Declaration
)
12697 Typ
:= Defining_Entity
(Stmt
);
12700 -- The pragma does not apply to a legal construct, issue an
12701 -- error and stop the analysis.
12708 Stmt
:= Prev
(Stmt
);
12711 Set_Has_Default_Init_Cond
(Typ
);
12712 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
12714 -- Chain the pragma on the rep item chain for further processing
12716 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
12717 end Default_Init_Cond
;
12719 ----------------------------------
12720 -- Default_Scalar_Storage_Order --
12721 ----------------------------------
12723 -- pragma Default_Scalar_Storage_Order
12724 -- (High_Order_First | Low_Order_First);
12726 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
12727 Default
: Character;
12731 Check_Arg_Count
(1);
12733 -- Default_Scalar_Storage_Order can appear as a configuration
12734 -- pragma, or in a declarative part of a package spec.
12736 if not Is_Configuration_Pragma
then
12737 Check_Is_In_Decl_Part_Or_Package_Spec
;
12740 Check_No_Identifiers
;
12741 Check_Arg_Is_One_Of
12742 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
12743 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12744 Default
:= Fold_Upper
(Name_Buffer
(1));
12746 if not Support_Nondefault_SSO_On_Target
12747 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
12749 if Warn_On_Unrecognized_Pragma
then
12751 ("non-default Scalar_Storage_Order not supported "
12752 & "on target?g?", N
);
12754 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
12757 -- Here set the specified default
12760 Opt
.Default_SSO
:= Default
;
12764 --------------------------
12765 -- Default_Storage_Pool --
12766 --------------------------
12768 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
12770 when Pragma_Default_Storage_Pool
=>
12772 Check_Arg_Count
(1);
12774 -- Default_Storage_Pool can appear as a configuration pragma, or
12775 -- in a declarative part of a package spec.
12777 if not Is_Configuration_Pragma
then
12778 Check_Is_In_Decl_Part_Or_Package_Spec
;
12781 -- Case of Default_Storage_Pool (null);
12783 if Nkind
(Expression
(Arg1
)) = N_Null
then
12784 Analyze
(Expression
(Arg1
));
12786 -- This is an odd case, this is not really an expression, so
12787 -- we don't have a type for it. So just set the type to Empty.
12789 Set_Etype
(Expression
(Arg1
), Empty
);
12791 -- Case of Default_Storage_Pool (storage_pool_NAME);
12794 -- If it's a configuration pragma, then the only allowed
12795 -- argument is "null".
12797 if Is_Configuration_Pragma
then
12798 Error_Pragma_Arg
("NULL expected", Arg1
);
12801 -- The expected type for a non-"null" argument is
12802 -- Root_Storage_Pool'Class, and the pool must be a variable.
12804 Analyze_And_Resolve
12805 (Get_Pragma_Arg
(Arg1
),
12806 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
12808 if not Is_Variable
(Expression
(Arg1
)) then
12810 ("default storage pool must be a variable", Arg1
);
12814 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
12815 -- for an access type will use this information to set the
12816 -- appropriate attributes of the access type.
12818 Default_Pool
:= Expression
(Arg1
);
12824 -- pragma Depends (DEPENDENCY_RELATION);
12826 -- DEPENDENCY_RELATION ::=
12828 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
12830 -- DEPENDENCY_CLAUSE ::=
12831 -- OUTPUT_LIST =>[+] INPUT_LIST
12832 -- | NULL_DEPENDENCY_CLAUSE
12834 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
12836 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
12838 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
12840 -- OUTPUT ::= NAME | FUNCTION_RESULT
12843 -- where FUNCTION_RESULT is a function Result attribute_reference
12845 -- Characteristics:
12847 -- * Analysis - The annotation undergoes initial checks to verify
12848 -- the legal placement and context. Secondary checks fully analyze
12849 -- the dependency clauses in:
12851 -- Analyze_Depends_In_Decl_Part
12853 -- * Expansion - None.
12855 -- * Template - The annotation utilizes the generic template of the
12856 -- related subprogram [body] when it is:
12858 -- aspect on subprogram declaration
12859 -- aspect on stand alone subprogram body
12860 -- pragma on stand alone subprogram body
12862 -- The annotation must prepare its own template when it is:
12864 -- pragma on subprogram declaration
12866 -- * Globals - Capture of global references must occur after full
12869 -- * Instance - The annotation is instantiated automatically when
12870 -- the related generic subprogram [body] is instantiated except for
12871 -- the "pragma on subprogram declaration" case. In that scenario
12872 -- the annotation must instantiate itself.
12874 when Pragma_Depends
=>
12875 Analyze_Depends_Global
;
12877 ---------------------
12878 -- Detect_Blocking --
12879 ---------------------
12881 -- pragma Detect_Blocking;
12883 when Pragma_Detect_Blocking
=>
12885 Check_Arg_Count
(0);
12886 Check_Valid_Configuration_Pragma
;
12887 Detect_Blocking
:= True;
12889 ------------------------------------
12890 -- Disable_Atomic_Synchronization --
12891 ------------------------------------
12893 -- pragma Disable_Atomic_Synchronization [(Entity)];
12895 when Pragma_Disable_Atomic_Synchronization
=>
12897 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
12899 -------------------
12900 -- Discard_Names --
12901 -------------------
12903 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
12905 when Pragma_Discard_Names
=> Discard_Names
: declare
12910 Check_Ada_83_Warning
;
12912 -- Deal with configuration pragma case
12914 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
12915 Global_Discard_Names
:= True;
12918 -- Otherwise, check correct appropriate context
12921 Check_Is_In_Decl_Part_Or_Package_Spec
;
12923 if Arg_Count
= 0 then
12925 -- If there is no parameter, then from now on this pragma
12926 -- applies to any enumeration, exception or tagged type
12927 -- defined in the current declarative part, and recursively
12928 -- to any nested scope.
12930 Set_Discard_Names
(Current_Scope
);
12934 Check_Arg_Count
(1);
12935 Check_Optional_Identifier
(Arg1
, Name_On
);
12936 Check_Arg_Is_Local_Name
(Arg1
);
12938 E_Id
:= Get_Pragma_Arg
(Arg1
);
12940 if Etype
(E_Id
) = Any_Type
then
12943 E
:= Entity
(E_Id
);
12946 if (Is_First_Subtype
(E
)
12948 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
12949 or else Ekind
(E
) = E_Exception
12951 Set_Discard_Names
(E
);
12952 Record_Rep_Item
(E
, N
);
12956 ("inappropriate entity for pragma%", Arg1
);
12963 ------------------------
12964 -- Dispatching_Domain --
12965 ------------------------
12967 -- pragma Dispatching_Domain (EXPRESSION);
12969 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
12970 P
: constant Node_Id
:= Parent
(N
);
12976 Check_No_Identifiers
;
12977 Check_Arg_Count
(1);
12979 -- This pragma is born obsolete, but not the aspect
12981 if not From_Aspect_Specification
(N
) then
12983 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
12986 if Nkind
(P
) = N_Task_Definition
then
12987 Arg
:= Get_Pragma_Arg
(Arg1
);
12988 Ent
:= Defining_Identifier
(Parent
(P
));
12990 -- The expression must be analyzed in the special manner
12991 -- described in "Handling of Default and Per-Object
12992 -- Expressions" in sem.ads.
12994 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
12996 -- Check duplicate pragma before we chain the pragma in the Rep
12997 -- Item chain of Ent.
12999 Check_Duplicate_Pragma
(Ent
);
13000 Record_Rep_Item
(Ent
, N
);
13002 -- Anything else is incorrect
13007 end Dispatching_Domain
;
13013 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13015 when Pragma_Elaborate
=> Elaborate
: declare
13020 -- Pragma must be in context items list of a compilation unit
13022 if not Is_In_Context_Clause
then
13026 -- Must be at least one argument
13028 if Arg_Count
= 0 then
13029 Error_Pragma
("pragma% requires at least one argument");
13032 -- In Ada 83 mode, there can be no items following it in the
13033 -- context list except other pragmas and implicit with clauses
13034 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13035 -- placement rule does not apply.
13037 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13039 while Present
(Citem
) loop
13040 if Nkind
(Citem
) = N_Pragma
13041 or else (Nkind
(Citem
) = N_With_Clause
13042 and then Implicit_With
(Citem
))
13047 ("(Ada 83) pragma% must be at end of context clause");
13054 -- Finally, the arguments must all be units mentioned in a with
13055 -- clause in the same context clause. Note we already checked (in
13056 -- Par.Prag) that the arguments are all identifiers or selected
13060 Outer
: while Present
(Arg
) loop
13061 Citem
:= First
(List_Containing
(N
));
13062 Inner
: while Citem
/= N
loop
13063 if Nkind
(Citem
) = N_With_Clause
13064 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13066 Set_Elaborate_Present
(Citem
, True);
13067 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13069 -- With the pragma present, elaboration calls on
13070 -- subprograms from the named unit need no further
13071 -- checks, as long as the pragma appears in the current
13072 -- compilation unit. If the pragma appears in some unit
13073 -- in the context, there might still be a need for an
13074 -- Elaborate_All_Desirable from the current compilation
13075 -- to the named unit, so we keep the check enabled.
13077 if In_Extended_Main_Source_Unit
(N
) then
13079 -- This does not apply in SPARK mode, where we allow
13080 -- pragma Elaborate, but we don't trust it to be right
13081 -- so we will still insist on the Elaborate_All.
13083 if SPARK_Mode
/= On
then
13084 Set_Suppress_Elaboration_Warnings
13085 (Entity
(Name
(Citem
)));
13097 ("argument of pragma% is not withed unit", Arg
);
13103 -- Give a warning if operating in static mode with one of the
13104 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13107 and not Dynamic_Elaboration_Checks
13109 -- pragma Elaborate not allowed in SPARK mode anyway. We
13110 -- already complained about it, no point in generating any
13111 -- further complaint.
13113 and SPARK_Mode
/= On
13116 ("?l?use of pragma Elaborate may not be safe", N
);
13118 ("?l?use pragma Elaborate_All instead if possible", N
);
13122 -------------------
13123 -- Elaborate_All --
13124 -------------------
13126 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13128 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13133 Check_Ada_83_Warning
;
13135 -- Pragma must be in context items list of a compilation unit
13137 if not Is_In_Context_Clause
then
13141 -- Must be at least one argument
13143 if Arg_Count
= 0 then
13144 Error_Pragma
("pragma% requires at least one argument");
13147 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13148 -- have to appear at the end of the context clause, but may
13149 -- appear mixed in with other items, even in Ada 83 mode.
13151 -- Final check: the arguments must all be units mentioned in
13152 -- a with clause in the same context clause. Note that we
13153 -- already checked (in Par.Prag) that all the arguments are
13154 -- either identifiers or selected components.
13157 Outr
: while Present
(Arg
) loop
13158 Citem
:= First
(List_Containing
(N
));
13159 Innr
: while Citem
/= N
loop
13160 if Nkind
(Citem
) = N_With_Clause
13161 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13163 Set_Elaborate_All_Present
(Citem
, True);
13164 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13166 -- Suppress warnings and elaboration checks on the named
13167 -- unit if the pragma is in the current compilation, as
13168 -- for pragma Elaborate.
13170 if In_Extended_Main_Source_Unit
(N
) then
13171 Set_Suppress_Elaboration_Warnings
13172 (Entity
(Name
(Citem
)));
13181 Set_Error_Posted
(N
);
13183 ("argument of pragma% is not withed unit", Arg
);
13190 --------------------
13191 -- Elaborate_Body --
13192 --------------------
13194 -- pragma Elaborate_Body [( library_unit_NAME )];
13196 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13197 Cunit_Node
: Node_Id
;
13198 Cunit_Ent
: Entity_Id
;
13201 Check_Ada_83_Warning
;
13202 Check_Valid_Library_Unit_Pragma
;
13204 if Nkind
(N
) = N_Null_Statement
then
13208 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13209 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13211 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13214 Error_Pragma
("pragma% must refer to a spec, not a body");
13216 Set_Body_Required
(Cunit_Node
, True);
13217 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13219 -- If we are in dynamic elaboration mode, then we suppress
13220 -- elaboration warnings for the unit, since it is definitely
13221 -- fine NOT to do dynamic checks at the first level (and such
13222 -- checks will be suppressed because no elaboration boolean
13223 -- is created for Elaborate_Body packages).
13225 -- But in the static model of elaboration, Elaborate_Body is
13226 -- definitely NOT good enough to ensure elaboration safety on
13227 -- its own, since the body may WITH other units that are not
13228 -- safe from an elaboration point of view, so a client must
13229 -- still do an Elaborate_All on such units.
13231 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13232 -- Elaborate_Body always suppressed elab warnings.
13234 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13235 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13238 end Elaborate_Body
;
13240 ------------------------
13241 -- Elaboration_Checks --
13242 ------------------------
13244 -- pragma Elaboration_Checks (Static | Dynamic);
13246 when Pragma_Elaboration_Checks
=>
13248 Check_Arg_Count
(1);
13249 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13251 -- Set flag accordingly (ignore attempt at dynamic elaboration
13252 -- checks in SPARK mode).
13254 Dynamic_Elaboration_Checks
:=
13255 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
)
13256 and then SPARK_Mode
/= On
;
13262 -- pragma Eliminate (
13263 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13264 -- [,[Entity =>] IDENTIFIER |
13265 -- SELECTED_COMPONENT |
13267 -- [, OVERLOADING_RESOLUTION]);
13269 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13272 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13273 -- FUNCTION_PROFILE
13275 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13277 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13278 -- Result_Type => result_SUBTYPE_NAME]
13280 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13281 -- SUBTYPE_NAME ::= STRING_LITERAL
13283 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13284 -- SOURCE_TRACE ::= STRING_LITERAL
13286 when Pragma_Eliminate
=> Eliminate
: declare
13287 Args
: Args_List
(1 .. 5);
13288 Names
: constant Name_List
(1 .. 5) := (
13291 Name_Parameter_Types
,
13293 Name_Source_Location
);
13295 Unit_Name
: Node_Id
renames Args
(1);
13296 Entity
: Node_Id
renames Args
(2);
13297 Parameter_Types
: Node_Id
renames Args
(3);
13298 Result_Type
: Node_Id
renames Args
(4);
13299 Source_Location
: Node_Id
renames Args
(5);
13303 Check_Valid_Configuration_Pragma
;
13304 Gather_Associations
(Names
, Args
);
13306 if No
(Unit_Name
) then
13307 Error_Pragma
("missing Unit_Name argument for pragma%");
13311 and then (Present
(Parameter_Types
)
13313 Present
(Result_Type
)
13315 Present
(Source_Location
))
13317 Error_Pragma
("missing Entity argument for pragma%");
13320 if (Present
(Parameter_Types
)
13322 Present
(Result_Type
))
13324 Present
(Source_Location
)
13327 ("parameter profile and source location cannot be used "
13328 & "together in pragma%");
13331 Process_Eliminate_Pragma
13340 -----------------------------------
13341 -- Enable_Atomic_Synchronization --
13342 -----------------------------------
13344 -- pragma Enable_Atomic_Synchronization [(Entity)];
13346 when Pragma_Enable_Atomic_Synchronization
=>
13348 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13355 -- [ Convention =>] convention_IDENTIFIER,
13356 -- [ Entity =>] LOCAL_NAME
13357 -- [, [External_Name =>] static_string_EXPRESSION ]
13358 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13360 when Pragma_Export
=> Export
: declare
13362 Def_Id
: Entity_Id
;
13364 pragma Warnings
(Off
, C
);
13367 Check_Ada_83_Warning
;
13371 Name_External_Name
,
13374 Check_At_Least_N_Arguments
(2);
13375 Check_At_Most_N_Arguments
(4);
13377 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13378 -- pragma Export (Entity, "external name");
13380 if Relaxed_RM_Semantics
13381 and then Arg_Count
= 2
13382 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13385 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13388 if not Is_Entity_Name
(Def_Id
) then
13389 Error_Pragma_Arg
("entity name required", Arg1
);
13392 Def_Id
:= Entity
(Def_Id
);
13393 Set_Exported
(Def_Id
, Arg1
);
13396 Process_Convention
(C
, Def_Id
);
13398 if Ekind
(Def_Id
) /= E_Constant
then
13399 Note_Possible_Modification
13400 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13403 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13404 Set_Exported
(Def_Id
, Arg2
);
13407 -- If the entity is a deferred constant, propagate the information
13408 -- to the full view, because gigi elaborates the full view only.
13410 if Ekind
(Def_Id
) = E_Constant
13411 and then Present
(Full_View
(Def_Id
))
13414 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13416 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13417 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13418 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13423 ---------------------
13424 -- Export_Function --
13425 ---------------------
13427 -- pragma Export_Function (
13428 -- [Internal =>] LOCAL_NAME
13429 -- [, [External =>] EXTERNAL_SYMBOL]
13430 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13431 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13432 -- [, [Mechanism =>] MECHANISM]
13433 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13435 -- EXTERNAL_SYMBOL ::=
13437 -- | static_string_EXPRESSION
13439 -- PARAMETER_TYPES ::=
13441 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13443 -- TYPE_DESIGNATOR ::=
13445 -- | subtype_Name ' Access
13449 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13451 -- MECHANISM_ASSOCIATION ::=
13452 -- [formal_parameter_NAME =>] MECHANISM_NAME
13454 -- MECHANISM_NAME ::=
13458 when Pragma_Export_Function
=> Export_Function
: declare
13459 Args
: Args_List
(1 .. 6);
13460 Names
: constant Name_List
(1 .. 6) := (
13463 Name_Parameter_Types
,
13466 Name_Result_Mechanism
);
13468 Internal
: Node_Id
renames Args
(1);
13469 External
: Node_Id
renames Args
(2);
13470 Parameter_Types
: Node_Id
renames Args
(3);
13471 Result_Type
: Node_Id
renames Args
(4);
13472 Mechanism
: Node_Id
renames Args
(5);
13473 Result_Mechanism
: Node_Id
renames Args
(6);
13477 Gather_Associations
(Names
, Args
);
13478 Process_Extended_Import_Export_Subprogram_Pragma
(
13479 Arg_Internal
=> Internal
,
13480 Arg_External
=> External
,
13481 Arg_Parameter_Types
=> Parameter_Types
,
13482 Arg_Result_Type
=> Result_Type
,
13483 Arg_Mechanism
=> Mechanism
,
13484 Arg_Result_Mechanism
=> Result_Mechanism
);
13485 end Export_Function
;
13487 -------------------
13488 -- Export_Object --
13489 -------------------
13491 -- pragma Export_Object (
13492 -- [Internal =>] LOCAL_NAME
13493 -- [, [External =>] EXTERNAL_SYMBOL]
13494 -- [, [Size =>] EXTERNAL_SYMBOL]);
13496 -- EXTERNAL_SYMBOL ::=
13498 -- | static_string_EXPRESSION
13500 -- PARAMETER_TYPES ::=
13502 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13504 -- TYPE_DESIGNATOR ::=
13506 -- | subtype_Name ' Access
13510 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13512 -- MECHANISM_ASSOCIATION ::=
13513 -- [formal_parameter_NAME =>] MECHANISM_NAME
13515 -- MECHANISM_NAME ::=
13519 when Pragma_Export_Object
=> Export_Object
: declare
13520 Args
: Args_List
(1 .. 3);
13521 Names
: constant Name_List
(1 .. 3) := (
13526 Internal
: Node_Id
renames Args
(1);
13527 External
: Node_Id
renames Args
(2);
13528 Size
: Node_Id
renames Args
(3);
13532 Gather_Associations
(Names
, Args
);
13533 Process_Extended_Import_Export_Object_Pragma
(
13534 Arg_Internal
=> Internal
,
13535 Arg_External
=> External
,
13539 ----------------------
13540 -- Export_Procedure --
13541 ----------------------
13543 -- pragma Export_Procedure (
13544 -- [Internal =>] LOCAL_NAME
13545 -- [, [External =>] EXTERNAL_SYMBOL]
13546 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13547 -- [, [Mechanism =>] MECHANISM]);
13549 -- EXTERNAL_SYMBOL ::=
13551 -- | static_string_EXPRESSION
13553 -- PARAMETER_TYPES ::=
13555 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13557 -- TYPE_DESIGNATOR ::=
13559 -- | subtype_Name ' Access
13563 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13565 -- MECHANISM_ASSOCIATION ::=
13566 -- [formal_parameter_NAME =>] MECHANISM_NAME
13568 -- MECHANISM_NAME ::=
13572 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13573 Args
: Args_List
(1 .. 4);
13574 Names
: constant Name_List
(1 .. 4) := (
13577 Name_Parameter_Types
,
13580 Internal
: Node_Id
renames Args
(1);
13581 External
: Node_Id
renames Args
(2);
13582 Parameter_Types
: Node_Id
renames Args
(3);
13583 Mechanism
: Node_Id
renames Args
(4);
13587 Gather_Associations
(Names
, Args
);
13588 Process_Extended_Import_Export_Subprogram_Pragma
(
13589 Arg_Internal
=> Internal
,
13590 Arg_External
=> External
,
13591 Arg_Parameter_Types
=> Parameter_Types
,
13592 Arg_Mechanism
=> Mechanism
);
13593 end Export_Procedure
;
13599 -- pragma Export_Value (
13600 -- [Value =>] static_integer_EXPRESSION,
13601 -- [Link_Name =>] static_string_EXPRESSION);
13603 when Pragma_Export_Value
=>
13605 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13606 Check_Arg_Count
(2);
13608 Check_Optional_Identifier
(Arg1
, Name_Value
);
13609 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
13611 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13612 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
13614 -----------------------------
13615 -- Export_Valued_Procedure --
13616 -----------------------------
13618 -- pragma Export_Valued_Procedure (
13619 -- [Internal =>] LOCAL_NAME
13620 -- [, [External =>] EXTERNAL_SYMBOL,]
13621 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13622 -- [, [Mechanism =>] MECHANISM]);
13624 -- EXTERNAL_SYMBOL ::=
13626 -- | static_string_EXPRESSION
13628 -- PARAMETER_TYPES ::=
13630 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13632 -- TYPE_DESIGNATOR ::=
13634 -- | subtype_Name ' Access
13638 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13640 -- MECHANISM_ASSOCIATION ::=
13641 -- [formal_parameter_NAME =>] MECHANISM_NAME
13643 -- MECHANISM_NAME ::=
13647 when Pragma_Export_Valued_Procedure
=>
13648 Export_Valued_Procedure
: declare
13649 Args
: Args_List
(1 .. 4);
13650 Names
: constant Name_List
(1 .. 4) := (
13653 Name_Parameter_Types
,
13656 Internal
: Node_Id
renames Args
(1);
13657 External
: Node_Id
renames Args
(2);
13658 Parameter_Types
: Node_Id
renames Args
(3);
13659 Mechanism
: Node_Id
renames Args
(4);
13663 Gather_Associations
(Names
, Args
);
13664 Process_Extended_Import_Export_Subprogram_Pragma
(
13665 Arg_Internal
=> Internal
,
13666 Arg_External
=> External
,
13667 Arg_Parameter_Types
=> Parameter_Types
,
13668 Arg_Mechanism
=> Mechanism
);
13669 end Export_Valued_Procedure
;
13671 -------------------
13672 -- Extend_System --
13673 -------------------
13675 -- pragma Extend_System ([Name =>] Identifier);
13677 when Pragma_Extend_System
=> Extend_System
: declare
13680 Check_Valid_Configuration_Pragma
;
13681 Check_Arg_Count
(1);
13682 Check_Optional_Identifier
(Arg1
, Name_Name
);
13683 Check_Arg_Is_Identifier
(Arg1
);
13685 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13688 and then Name_Buffer
(1 .. 4) = "aux_"
13690 if Present
(System_Extend_Pragma_Arg
) then
13691 if Chars
(Get_Pragma_Arg
(Arg1
)) =
13692 Chars
(Expression
(System_Extend_Pragma_Arg
))
13696 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
13697 Error_Pragma
("pragma% conflicts with that #");
13701 System_Extend_Pragma_Arg
:= Arg1
;
13703 if not GNAT_Mode
then
13704 System_Extend_Unit
:= Arg1
;
13708 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
13712 ------------------------
13713 -- Extensions_Allowed --
13714 ------------------------
13716 -- pragma Extensions_Allowed (ON | OFF);
13718 when Pragma_Extensions_Allowed
=>
13720 Check_Arg_Count
(1);
13721 Check_No_Identifiers
;
13722 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13724 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13725 Extensions_Allowed
:= True;
13726 Ada_Version
:= Ada_Version_Type
'Last;
13729 Extensions_Allowed
:= False;
13730 Ada_Version
:= Ada_Version_Explicit
;
13731 Ada_Version_Pragma
:= Empty
;
13734 ------------------------
13735 -- Extensions_Visible --
13736 ------------------------
13738 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
13740 -- Characteristics:
13742 -- * Analysis - The annotation is fully analyzed immediately upon
13743 -- elaboration as its expression must be static.
13745 -- * Expansion - None.
13747 -- * Template - The annotation utilizes the generic template of the
13748 -- related subprogram [body] when it is:
13750 -- aspect on subprogram declaration
13751 -- aspect on stand alone subprogram body
13752 -- pragma on stand alone subprogram body
13754 -- The annotation must prepare its own template when it is:
13756 -- pragma on subprogram declaration
13758 -- * Globals - Capture of global references must occur after full
13761 -- * Instance - The annotation is instantiated automatically when
13762 -- the related generic subprogram [body] is instantiated except for
13763 -- the "pragma on subprogram declaration" case. In that scenario
13764 -- the annotation must instantiate itself.
13766 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
13768 Formal
: Entity_Id
;
13769 Has_OK_Formal
: Boolean := False;
13770 Spec_Id
: Entity_Id
;
13771 Subp_Decl
: Node_Id
;
13775 Check_No_Identifiers
;
13776 Check_At_Most_N_Arguments
(1);
13779 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
13781 -- Generic subprogram declaration
13783 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
13786 -- Body acts as spec
13788 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13789 and then No
(Corresponding_Spec
(Subp_Decl
))
13793 -- Body stub acts as spec
13795 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13796 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13800 -- Subprogram declaration
13802 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13805 -- Otherwise the pragma is associated with an illegal construct
13808 Error_Pragma
("pragma % must apply to a subprogram");
13812 Spec_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
13814 -- Examine the formals of the related subprogram
13816 Formal
:= First_Formal
(Spec_Id
);
13817 while Present
(Formal
) loop
13819 -- At least one of the formals is of a specific tagged type,
13820 -- the pragma is legal.
13822 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
13823 Has_OK_Formal
:= True;
13826 -- A generic subprogram with at least one formal of a private
13827 -- type ensures the legality of the pragma because the actual
13828 -- may be specifically tagged. Note that this is verified by
13829 -- the check above at instantiation time.
13831 elsif Is_Private_Type
(Etype
(Formal
))
13832 and then Is_Generic_Type
(Etype
(Formal
))
13834 Has_OK_Formal
:= True;
13838 Next_Formal
(Formal
);
13841 if not Has_OK_Formal
then
13842 Error_Msg_Name_1
:= Pname
;
13843 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
13845 ("\subprogram & lacks parameter of specific tagged or "
13846 & "generic private type", N
, Spec_Id
);
13850 -- Analyze the Boolean expression (if any)
13852 if Present
(Arg1
) then
13853 Expr
:= Expression
(Get_Argument
(N
, Spec_Id
));
13855 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
13857 if not Is_OK_Static_Expression
(Expr
) then
13859 ("expression of pragma % must be static", Expr
);
13864 -- Chain the pragma on the contract for completeness
13866 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13867 end Extensions_Visible
;
13873 -- pragma External (
13874 -- [ Convention =>] convention_IDENTIFIER,
13875 -- [ Entity =>] LOCAL_NAME
13876 -- [, [External_Name =>] static_string_EXPRESSION ]
13877 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13879 when Pragma_External
=> External
: declare
13880 Def_Id
: Entity_Id
;
13883 pragma Warnings
(Off
, C
);
13890 Name_External_Name
,
13892 Check_At_Least_N_Arguments
(2);
13893 Check_At_Most_N_Arguments
(4);
13894 Process_Convention
(C
, Def_Id
);
13895 Note_Possible_Modification
13896 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13897 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13898 Set_Exported
(Def_Id
, Arg2
);
13901 --------------------------
13902 -- External_Name_Casing --
13903 --------------------------
13905 -- pragma External_Name_Casing (
13906 -- UPPERCASE | LOWERCASE
13907 -- [, AS_IS | UPPERCASE | LOWERCASE]);
13909 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
13912 Check_No_Identifiers
;
13914 if Arg_Count
= 2 then
13915 Check_Arg_Is_One_Of
13916 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
13918 case Chars
(Get_Pragma_Arg
(Arg2
)) is
13920 Opt
.External_Name_Exp_Casing
:= As_Is
;
13922 when Name_Uppercase
=>
13923 Opt
.External_Name_Exp_Casing
:= Uppercase
;
13925 when Name_Lowercase
=>
13926 Opt
.External_Name_Exp_Casing
:= Lowercase
;
13933 Check_Arg_Count
(1);
13936 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
13938 case Chars
(Get_Pragma_Arg
(Arg1
)) is
13939 when Name_Uppercase
=>
13940 Opt
.External_Name_Imp_Casing
:= Uppercase
;
13942 when Name_Lowercase
=>
13943 Opt
.External_Name_Imp_Casing
:= Lowercase
;
13948 end External_Name_Casing
;
13954 -- pragma Fast_Math;
13956 when Pragma_Fast_Math
=>
13958 Check_No_Identifiers
;
13959 Check_Valid_Configuration_Pragma
;
13962 --------------------------
13963 -- Favor_Top_Level --
13964 --------------------------
13966 -- pragma Favor_Top_Level (type_NAME);
13968 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
13969 Named_Entity
: Entity_Id
;
13973 Check_No_Identifiers
;
13974 Check_Arg_Count
(1);
13975 Check_Arg_Is_Local_Name
(Arg1
);
13976 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
13978 -- If it's an access-to-subprogram type (in particular, not a
13979 -- subtype), set the flag on that type.
13981 if Is_Access_Subprogram_Type
(Named_Entity
) then
13982 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
13984 -- Otherwise it's an error (name denotes the wrong sort of entity)
13988 ("access-to-subprogram type expected",
13989 Get_Pragma_Arg
(Arg1
));
13991 end Favor_Top_Level
;
13993 ---------------------------
13994 -- Finalize_Storage_Only --
13995 ---------------------------
13997 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
13999 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14000 Assoc
: constant Node_Id
:= Arg1
;
14001 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14006 Check_No_Identifiers
;
14007 Check_Arg_Count
(1);
14008 Check_Arg_Is_Local_Name
(Arg1
);
14010 Find_Type
(Type_Id
);
14011 Typ
:= Entity
(Type_Id
);
14014 or else Rep_Item_Too_Early
(Typ
, N
)
14018 Typ
:= Underlying_Type
(Typ
);
14021 if not Is_Controlled
(Typ
) then
14022 Error_Pragma
("pragma% must specify controlled type");
14025 Check_First_Subtype
(Arg1
);
14027 if Finalize_Storage_Only
(Typ
) then
14028 Error_Pragma
("duplicate pragma%, only one allowed");
14030 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14031 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14033 end Finalize_Storage
;
14039 -- pragma Ghost [ (boolean_EXPRESSION) ];
14041 when Pragma_Ghost
=> Ghost
: declare
14045 Orig_Stmt
: Node_Id
;
14046 Prev_Id
: Entity_Id
;
14051 Check_No_Identifiers
;
14052 Check_At_Most_N_Arguments
(1);
14054 Context
:= Parent
(N
);
14056 -- Handle compilation units
14058 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
14059 Context
:= Unit
(Parent
(Context
));
14064 while Present
(Stmt
) loop
14066 -- Skip prior pragmas, but check for duplicates
14068 if Nkind
(Stmt
) = N_Pragma
then
14069 if Pragma_Name
(Stmt
) = Pname
then
14070 Error_Msg_Name_1
:= Pname
;
14071 Error_Msg_Sloc
:= Sloc
(Stmt
);
14072 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
14075 -- Protected and task types cannot be subject to pragma Ghost
14077 elsif Nkind
(Stmt
) = N_Protected_Type_Declaration
then
14078 Error_Pragma
("pragma % cannot apply to a protected type");
14081 elsif Nkind
(Stmt
) = N_Task_Type_Declaration
then
14082 Error_Pragma
("pragma % cannot apply to a task type");
14085 -- Skip internally generated code
14087 elsif not Comes_From_Source
(Stmt
) then
14088 Orig_Stmt
:= Original_Node
(Stmt
);
14090 -- When pragma Ghost applies to an untagged derivation, the
14091 -- derivation is transformed into a [sub]type declaration.
14093 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
14094 N_Subtype_Declaration
)
14095 and then Comes_From_Source
(Orig_Stmt
)
14096 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
14097 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
14098 N_Derived_Type_Definition
14100 Id
:= Defining_Entity
(Stmt
);
14103 -- When pragma Ghost applies to an expression function, the
14104 -- expression function is transformed into a subprogram.
14106 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
14107 and then Comes_From_Source
(Orig_Stmt
)
14108 and then Nkind
(Orig_Stmt
) = N_Expression_Function
14110 Id
:= Defining_Entity
(Stmt
);
14114 -- The pragma applies to a legal construct, stop the traversal
14116 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
14117 N_Full_Type_Declaration
,
14118 N_Generic_Subprogram_Declaration
,
14119 N_Object_Declaration
,
14120 N_Private_Extension_Declaration
,
14121 N_Private_Type_Declaration
,
14122 N_Subprogram_Declaration
,
14123 N_Subtype_Declaration
)
14125 Id
:= Defining_Entity
(Stmt
);
14128 -- The pragma does not apply to a legal construct, issue an
14129 -- error and stop the analysis.
14133 ("pragma % must apply to an object, package, subprogram "
14138 Stmt
:= Prev
(Stmt
);
14143 -- When pragma Ghost is associated with a [generic] package, it
14144 -- appears in the visible declarations.
14146 if Nkind
(Context
) = N_Package_Specification
14147 and then Present
(Visible_Declarations
(Context
))
14148 and then List_Containing
(N
) = Visible_Declarations
(Context
)
14150 Id
:= Defining_Entity
(Context
);
14152 -- Pragma Ghost applies to a stand alone subprogram body
14154 elsif Nkind
(Context
) = N_Subprogram_Body
14155 and then No
(Corresponding_Spec
(Context
))
14157 Id
:= Defining_Entity
(Context
);
14163 ("pragma % must apply to an object, package, subprogram or "
14168 -- A derived type or type extension cannot be subject to pragma
14169 -- Ghost if either the parent type or one of the progenitor types
14170 -- is not Ghost (SPARK RM 6.9(9)).
14172 if Is_Derived_Type
(Id
) then
14173 Check_Ghost_Derivation
(Id
);
14176 -- Handle completions of types and constants that are subject to
14179 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
14180 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
14182 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
14183 Error_Msg_Name_1
:= Pname
;
14185 -- The full declaration of a deferred constant cannot be
14186 -- subject to pragma Ghost unless the deferred declaration
14187 -- is also Ghost (SPARK RM 6.9(10)).
14189 if Ekind
(Prev_Id
) = E_Constant
then
14190 Error_Msg_Name_1
:= Pname
;
14191 Error_Msg_NE
(Fix_Error
14192 ("pragma % must apply to declaration of deferred "
14193 & "constant &"), N
, Id
);
14196 -- Pragma Ghost may appear on the full view of an incomplete
14197 -- type because the incomplete declaration lacks aspects and
14198 -- cannot be subject to pragma Ghost.
14200 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
14203 -- The full declaration of a type cannot be subject to
14204 -- pragma Ghost unless the partial view is also Ghost
14205 -- (SPARK RM 6.9(10)).
14208 Error_Msg_NE
(Fix_Error
14209 ("pragma % must apply to partial view of type &"),
14216 -- Analyze the Boolean expression (if any)
14218 if Present
(Arg1
) then
14219 Expr
:= Get_Pragma_Arg
(Arg1
);
14221 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14223 if Is_OK_Static_Expression
(Expr
) then
14225 -- "Ghostness" cannot be turned off once enabled within a
14226 -- region (SPARK RM 6.9(7)).
14228 if Is_False
(Expr_Value
(Expr
))
14229 and then Ghost_Mode
> None
14232 ("pragma % with value False cannot appear in enabled "
14237 -- Otherwie the expression is not static
14241 ("expression of pragma % must be static", Expr
);
14246 Set_Is_Ghost_Entity
(Id
);
14253 -- pragma Global (GLOBAL_SPECIFICATION);
14255 -- GLOBAL_SPECIFICATION ::=
14258 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14260 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14262 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14263 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14264 -- GLOBAL_ITEM ::= NAME
14266 -- Characteristics:
14268 -- * Analysis - The annotation undergoes initial checks to verify
14269 -- the legal placement and context. Secondary checks fully analyze
14270 -- the dependency clauses in:
14272 -- Analyze_Global_In_Decl_Part
14274 -- * Expansion - None.
14276 -- * Template - The annotation utilizes the generic template of the
14277 -- related subprogram [body] when it is:
14279 -- aspect on subprogram declaration
14280 -- aspect on stand alone subprogram body
14281 -- pragma on stand alone subprogram body
14283 -- The annotation must prepare its own template when it is:
14285 -- pragma on subprogram declaration
14287 -- * Globals - Capture of global references must occur after full
14290 -- * Instance - The annotation is instantiated automatically when
14291 -- the related generic subprogram [body] is instantiated except for
14292 -- the "pragma on subprogram declaration" case. In that scenario
14293 -- the annotation must instantiate itself.
14295 when Pragma_Global
=>
14296 Analyze_Depends_Global
;
14302 -- pragma Ident (static_string_EXPRESSION)
14304 -- Note: pragma Comment shares this processing. Pragma Ident is
14305 -- identical in effect to pragma Commment.
14307 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14312 Check_Arg_Count
(1);
14313 Check_No_Identifiers
;
14314 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
14317 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14324 GP
:= Parent
(Parent
(N
));
14326 if Nkind_In
(GP
, N_Package_Declaration
,
14327 N_Generic_Package_Declaration
)
14332 -- If we have a compilation unit, then record the ident value,
14333 -- checking for improper duplication.
14335 if Nkind
(GP
) = N_Compilation_Unit
then
14336 CS
:= Ident_String
(Current_Sem_Unit
);
14338 if Present
(CS
) then
14340 -- If we have multiple instances, concatenate them, but
14341 -- not in ASIS, where we want the original tree.
14343 if not ASIS_Mode
then
14344 Start_String
(Strval
(CS
));
14345 Store_String_Char
(' ');
14346 Store_String_Chars
(Strval
(Str
));
14347 Set_Strval
(CS
, End_String
);
14351 Set_Ident_String
(Current_Sem_Unit
, Str
);
14354 -- For subunits, we just ignore the Ident, since in GNAT these
14355 -- are not separate object files, and hence not separate units
14356 -- in the unit table.
14358 elsif Nkind
(GP
) = N_Subunit
then
14364 -------------------
14365 -- Ignore_Pragma --
14366 -------------------
14368 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
14370 -- Entirely handled in the parser, nothing to do here
14372 when Pragma_Ignore_Pragma
=>
14375 ----------------------------
14376 -- Implementation_Defined --
14377 ----------------------------
14379 -- pragma Implementation_Defined (LOCAL_NAME);
14381 -- Marks previously declared entity as implementation defined. For
14382 -- an overloaded entity, applies to the most recent homonym.
14384 -- pragma Implementation_Defined;
14386 -- The form with no arguments appears anywhere within a scope, most
14387 -- typically a package spec, and indicates that all entities that are
14388 -- defined within the package spec are Implementation_Defined.
14390 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14395 Check_No_Identifiers
;
14397 -- Form with no arguments
14399 if Arg_Count
= 0 then
14400 Set_Is_Implementation_Defined
(Current_Scope
);
14402 -- Form with one argument
14405 Check_Arg_Count
(1);
14406 Check_Arg_Is_Local_Name
(Arg1
);
14407 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14408 Set_Is_Implementation_Defined
(Ent
);
14410 end Implementation_Defined
;
14416 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14418 -- IMPLEMENTATION_KIND ::=
14419 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14421 -- "By_Any" and "Optional" are treated as synonyms in order to
14422 -- support Ada 2012 aspect Synchronization.
14424 when Pragma_Implemented
=> Implemented
: declare
14425 Proc_Id
: Entity_Id
;
14430 Check_Arg_Count
(2);
14431 Check_No_Identifiers
;
14432 Check_Arg_Is_Identifier
(Arg1
);
14433 Check_Arg_Is_Local_Name
(Arg1
);
14434 Check_Arg_Is_One_Of
(Arg2
,
14437 Name_By_Protected_Procedure
,
14440 -- Extract the name of the local procedure
14442 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14444 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14445 -- primitive procedure of a synchronized tagged type.
14447 if Ekind
(Proc_Id
) = E_Procedure
14448 and then Is_Primitive
(Proc_Id
)
14449 and then Present
(First_Formal
(Proc_Id
))
14451 Typ
:= Etype
(First_Formal
(Proc_Id
));
14453 if Is_Tagged_Type
(Typ
)
14456 -- Check for a protected, a synchronized or a task interface
14458 ((Is_Interface
(Typ
)
14459 and then Is_Synchronized_Interface
(Typ
))
14461 -- Check for a protected type or a task type that implements
14465 (Is_Concurrent_Record_Type
(Typ
)
14466 and then Present
(Interfaces
(Typ
)))
14468 -- In analysis-only mode, examine original protected type
14471 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
14472 and then Present
(Interface_List
(Parent
(Typ
))))
14474 -- Check for a private record extension with keyword
14478 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14479 E_Record_Subtype_With_Private
)
14480 and then Synchronized_Present
(Parent
(Typ
))))
14485 ("controlling formal must be of synchronized tagged type",
14490 -- Procedures declared inside a protected type must be accepted
14492 elsif Ekind
(Proc_Id
) = E_Procedure
14493 and then Is_Protected_Type
(Scope
(Proc_Id
))
14497 -- The first argument is not a primitive procedure
14501 ("pragma % must be applied to a primitive procedure", Arg1
);
14505 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14506 -- By_Protected_Procedure to the primitive procedure of a task
14509 if Chars
(Arg2
) = Name_By_Protected_Procedure
14510 and then Is_Interface
(Typ
)
14511 and then Is_Task_Interface
(Typ
)
14514 ("implementation kind By_Protected_Procedure cannot be "
14515 & "applied to a task interface primitive", Arg2
);
14519 Record_Rep_Item
(Proc_Id
, N
);
14522 ----------------------
14523 -- Implicit_Packing --
14524 ----------------------
14526 -- pragma Implicit_Packing;
14528 when Pragma_Implicit_Packing
=>
14530 Check_Arg_Count
(0);
14531 Implicit_Packing
:= True;
14538 -- [Convention =>] convention_IDENTIFIER,
14539 -- [Entity =>] LOCAL_NAME
14540 -- [, [External_Name =>] static_string_EXPRESSION ]
14541 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14543 when Pragma_Import
=>
14544 Check_Ada_83_Warning
;
14548 Name_External_Name
,
14551 Check_At_Least_N_Arguments
(2);
14552 Check_At_Most_N_Arguments
(4);
14553 Process_Import_Or_Interface
;
14555 ---------------------
14556 -- Import_Function --
14557 ---------------------
14559 -- pragma Import_Function (
14560 -- [Internal =>] LOCAL_NAME,
14561 -- [, [External =>] EXTERNAL_SYMBOL]
14562 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14563 -- [, [Result_Type =>] SUBTYPE_MARK]
14564 -- [, [Mechanism =>] MECHANISM]
14565 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14567 -- EXTERNAL_SYMBOL ::=
14569 -- | static_string_EXPRESSION
14571 -- PARAMETER_TYPES ::=
14573 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14575 -- TYPE_DESIGNATOR ::=
14577 -- | subtype_Name ' Access
14581 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14583 -- MECHANISM_ASSOCIATION ::=
14584 -- [formal_parameter_NAME =>] MECHANISM_NAME
14586 -- MECHANISM_NAME ::=
14590 when Pragma_Import_Function
=> Import_Function
: declare
14591 Args
: Args_List
(1 .. 6);
14592 Names
: constant Name_List
(1 .. 6) := (
14595 Name_Parameter_Types
,
14598 Name_Result_Mechanism
);
14600 Internal
: Node_Id
renames Args
(1);
14601 External
: Node_Id
renames Args
(2);
14602 Parameter_Types
: Node_Id
renames Args
(3);
14603 Result_Type
: Node_Id
renames Args
(4);
14604 Mechanism
: Node_Id
renames Args
(5);
14605 Result_Mechanism
: Node_Id
renames Args
(6);
14609 Gather_Associations
(Names
, Args
);
14610 Process_Extended_Import_Export_Subprogram_Pragma
(
14611 Arg_Internal
=> Internal
,
14612 Arg_External
=> External
,
14613 Arg_Parameter_Types
=> Parameter_Types
,
14614 Arg_Result_Type
=> Result_Type
,
14615 Arg_Mechanism
=> Mechanism
,
14616 Arg_Result_Mechanism
=> Result_Mechanism
);
14617 end Import_Function
;
14619 -------------------
14620 -- Import_Object --
14621 -------------------
14623 -- pragma Import_Object (
14624 -- [Internal =>] LOCAL_NAME
14625 -- [, [External =>] EXTERNAL_SYMBOL]
14626 -- [, [Size =>] EXTERNAL_SYMBOL]);
14628 -- EXTERNAL_SYMBOL ::=
14630 -- | static_string_EXPRESSION
14632 when Pragma_Import_Object
=> Import_Object
: declare
14633 Args
: Args_List
(1 .. 3);
14634 Names
: constant Name_List
(1 .. 3) := (
14639 Internal
: Node_Id
renames Args
(1);
14640 External
: Node_Id
renames Args
(2);
14641 Size
: Node_Id
renames Args
(3);
14645 Gather_Associations
(Names
, Args
);
14646 Process_Extended_Import_Export_Object_Pragma
(
14647 Arg_Internal
=> Internal
,
14648 Arg_External
=> External
,
14652 ----------------------
14653 -- Import_Procedure --
14654 ----------------------
14656 -- pragma Import_Procedure (
14657 -- [Internal =>] LOCAL_NAME
14658 -- [, [External =>] EXTERNAL_SYMBOL]
14659 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14660 -- [, [Mechanism =>] MECHANISM]);
14662 -- EXTERNAL_SYMBOL ::=
14664 -- | static_string_EXPRESSION
14666 -- PARAMETER_TYPES ::=
14668 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14670 -- TYPE_DESIGNATOR ::=
14672 -- | subtype_Name ' Access
14676 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14678 -- MECHANISM_ASSOCIATION ::=
14679 -- [formal_parameter_NAME =>] MECHANISM_NAME
14681 -- MECHANISM_NAME ::=
14685 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14686 Args
: Args_List
(1 .. 4);
14687 Names
: constant Name_List
(1 .. 4) := (
14690 Name_Parameter_Types
,
14693 Internal
: Node_Id
renames Args
(1);
14694 External
: Node_Id
renames Args
(2);
14695 Parameter_Types
: Node_Id
renames Args
(3);
14696 Mechanism
: Node_Id
renames Args
(4);
14700 Gather_Associations
(Names
, Args
);
14701 Process_Extended_Import_Export_Subprogram_Pragma
(
14702 Arg_Internal
=> Internal
,
14703 Arg_External
=> External
,
14704 Arg_Parameter_Types
=> Parameter_Types
,
14705 Arg_Mechanism
=> Mechanism
);
14706 end Import_Procedure
;
14708 -----------------------------
14709 -- Import_Valued_Procedure --
14710 -----------------------------
14712 -- pragma Import_Valued_Procedure (
14713 -- [Internal =>] LOCAL_NAME
14714 -- [, [External =>] EXTERNAL_SYMBOL]
14715 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14716 -- [, [Mechanism =>] MECHANISM]);
14718 -- EXTERNAL_SYMBOL ::=
14720 -- | static_string_EXPRESSION
14722 -- PARAMETER_TYPES ::=
14724 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14726 -- TYPE_DESIGNATOR ::=
14728 -- | subtype_Name ' Access
14732 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14734 -- MECHANISM_ASSOCIATION ::=
14735 -- [formal_parameter_NAME =>] MECHANISM_NAME
14737 -- MECHANISM_NAME ::=
14741 when Pragma_Import_Valued_Procedure
=>
14742 Import_Valued_Procedure
: declare
14743 Args
: Args_List
(1 .. 4);
14744 Names
: constant Name_List
(1 .. 4) := (
14747 Name_Parameter_Types
,
14750 Internal
: Node_Id
renames Args
(1);
14751 External
: Node_Id
renames Args
(2);
14752 Parameter_Types
: Node_Id
renames Args
(3);
14753 Mechanism
: Node_Id
renames Args
(4);
14757 Gather_Associations
(Names
, Args
);
14758 Process_Extended_Import_Export_Subprogram_Pragma
(
14759 Arg_Internal
=> Internal
,
14760 Arg_External
=> External
,
14761 Arg_Parameter_Types
=> Parameter_Types
,
14762 Arg_Mechanism
=> Mechanism
);
14763 end Import_Valued_Procedure
;
14769 -- pragma Independent (LOCAL_NAME);
14771 when Pragma_Independent
=>
14772 Process_Atomic_Independent_Shared_Volatile
;
14774 ----------------------------
14775 -- Independent_Components --
14776 ----------------------------
14778 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
14780 when Pragma_Independent_Components
=> Independent_Components
: declare
14788 Check_Ada_83_Warning
;
14790 Check_No_Identifiers
;
14791 Check_Arg_Count
(1);
14792 Check_Arg_Is_Local_Name
(Arg1
);
14793 E_Id
:= Get_Pragma_Arg
(Arg1
);
14795 if Etype
(E_Id
) = Any_Type
then
14799 E
:= Entity
(E_Id
);
14801 -- Check duplicate before we chain ourselves
14803 Check_Duplicate_Pragma
(E
);
14805 -- Check appropriate entity
14807 if Rep_Item_Too_Early
(E
, N
)
14809 Rep_Item_Too_Late
(E
, N
)
14814 D
:= Declaration_Node
(E
);
14817 -- The flag is set on the base type, or on the object
14819 if K
= N_Full_Type_Declaration
14820 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
14822 Set_Has_Independent_Components
(Base_Type
(E
));
14823 Record_Independence_Check
(N
, Base_Type
(E
));
14825 -- For record type, set all components independent
14827 if Is_Record_Type
(E
) then
14828 C
:= First_Component
(E
);
14829 while Present
(C
) loop
14830 Set_Is_Independent
(C
);
14831 Next_Component
(C
);
14835 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
14836 and then Nkind
(D
) = N_Object_Declaration
14837 and then Nkind
(Object_Definition
(D
)) =
14838 N_Constrained_Array_Definition
14840 Set_Has_Independent_Components
(E
);
14841 Record_Independence_Check
(N
, E
);
14844 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
14846 end Independent_Components
;
14848 -----------------------
14849 -- Initial_Condition --
14850 -----------------------
14852 -- pragma Initial_Condition (boolean_EXPRESSION);
14854 -- Characteristics:
14856 -- * Analysis - The annotation undergoes initial checks to verify
14857 -- the legal placement and context. Secondary checks preanalyze the
14860 -- Analyze_Initial_Condition_In_Decl_Part
14862 -- * Expansion - The annotation is expanded during the expansion of
14863 -- the package body whose declaration is subject to the annotation
14866 -- Expand_Pragma_Initial_Condition
14868 -- * Template - The annotation utilizes the generic template of the
14869 -- related package declaration.
14871 -- * Globals - Capture of global references must occur after full
14874 -- * Instance - The annotation is instantiated automatically when
14875 -- the related generic package is instantiated.
14877 when Pragma_Initial_Condition
=> Initial_Condition
: declare
14878 Pack_Decl
: Node_Id
;
14879 Pack_Id
: Entity_Id
;
14883 Check_No_Identifiers
;
14884 Check_Arg_Count
(1);
14886 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
14888 -- Ensure the proper placement of the pragma. Initial_Condition
14889 -- must be associated with a package declaration.
14891 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
14892 N_Package_Declaration
)
14896 -- Otherwise the pragma is associated with an illegal context
14903 -- The pragma must be analyzed at the end of the visible
14904 -- declarations of the related package. Save the pragma for later
14905 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
14906 -- the contract of the package.
14908 Pack_Id
:= Defining_Entity
(Pack_Decl
);
14910 -- Verify the declaration order of pragma Initial_Condition with
14911 -- respect to pragmas Abstract_State and Initializes when SPARK
14912 -- checks are enabled.
14914 if SPARK_Mode
/= Off
then
14915 Check_Declaration_Order
14916 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
14919 Check_Declaration_Order
14920 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
14924 -- Chain the pragma on the contract for further processing by
14925 -- Analyze_Initial_Condition_In_Decl_Part.
14927 Add_Contract_Item
(N
, Pack_Id
);
14928 end Initial_Condition
;
14930 ------------------------
14931 -- Initialize_Scalars --
14932 ------------------------
14934 -- pragma Initialize_Scalars;
14936 when Pragma_Initialize_Scalars
=>
14938 Check_Arg_Count
(0);
14939 Check_Valid_Configuration_Pragma
;
14940 Check_Restriction
(No_Initialize_Scalars
, N
);
14942 -- Initialize_Scalars creates false positives in CodePeer, and
14943 -- incorrect negative results in GNATprove mode, so ignore this
14944 -- pragma in these modes.
14946 if not Restriction_Active
(No_Initialize_Scalars
)
14947 and then not (CodePeer_Mode
or GNATprove_Mode
)
14949 Init_Or_Norm_Scalars
:= True;
14950 Initialize_Scalars
:= True;
14957 -- pragma Initializes (INITIALIZATION_SPEC);
14959 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
14961 -- INITIALIZATION_LIST ::=
14962 -- INITIALIZATION_ITEM
14963 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
14965 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
14970 -- | (INPUT {, INPUT})
14974 -- Characteristics:
14976 -- * Analysis - The annotation undergoes initial checks to verify
14977 -- the legal placement and context. Secondary checks preanalyze the
14980 -- Analyze_Initializes_In_Decl_Part
14982 -- * Expansion - None.
14984 -- * Template - The annotation utilizes the generic template of the
14985 -- related package declaration.
14987 -- * Globals - Capture of global references must occur after full
14990 -- * Instance - The annotation is instantiated automatically when
14991 -- the related generic package is instantiated.
14993 when Pragma_Initializes
=> Initializes
: declare
14994 Pack_Decl
: Node_Id
;
14995 Pack_Id
: Entity_Id
;
14999 Check_No_Identifiers
;
15000 Check_Arg_Count
(1);
15002 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
15004 -- Ensure the proper placement of the pragma. Initializes must be
15005 -- associated with a package declaration.
15007 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
15008 N_Package_Declaration
)
15012 -- Otherwise the pragma is associated with an illegal construc
15019 Pack_Id
:= Defining_Entity
(Pack_Decl
);
15021 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
15023 -- Verify the declaration order of pragmas Abstract_State and
15024 -- Initializes when SPARK checks are enabled.
15026 if SPARK_Mode
/= Off
then
15027 Check_Declaration_Order
15028 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15032 -- Chain the pragma on the contract for further processing by
15033 -- Analyze_Initializes_In_Decl_Part.
15035 Add_Contract_Item
(N
, Pack_Id
);
15042 -- pragma Inline ( NAME {, NAME} );
15044 when Pragma_Inline
=>
15046 -- Pragma always active unless in GNATprove mode. It is disabled
15047 -- in GNATprove mode because frontend inlining is applied
15048 -- independently of pragmas Inline and Inline_Always for
15049 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15052 if not GNATprove_Mode
then
15054 -- Inline status is Enabled if inlining option is active
15056 if Inline_Active
then
15057 Process_Inline
(Enabled
);
15059 Process_Inline
(Disabled
);
15063 -------------------
15064 -- Inline_Always --
15065 -------------------
15067 -- pragma Inline_Always ( NAME {, NAME} );
15069 when Pragma_Inline_Always
=>
15072 -- Pragma always active unless in CodePeer mode or GNATprove
15073 -- mode. It is disabled in CodePeer mode because inlining is
15074 -- not helpful, and enabling it caused walk order issues. It
15075 -- is disabled in GNATprove mode because frontend inlining is
15076 -- applied independently of pragmas Inline and Inline_Always for
15077 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15080 if not CodePeer_Mode
and not GNATprove_Mode
then
15081 Process_Inline
(Enabled
);
15084 --------------------
15085 -- Inline_Generic --
15086 --------------------
15088 -- pragma Inline_Generic (NAME {, NAME});
15090 when Pragma_Inline_Generic
=>
15092 Process_Generic_List
;
15094 ----------------------
15095 -- Inspection_Point --
15096 ----------------------
15098 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15100 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15107 if Arg_Count
> 0 then
15110 Exp
:= Get_Pragma_Arg
(Arg
);
15113 if not Is_Entity_Name
(Exp
)
15114 or else not Is_Object
(Entity
(Exp
))
15116 Error_Pragma_Arg
("object name required", Arg
);
15120 exit when No
(Arg
);
15123 end Inspection_Point
;
15129 -- pragma Interface (
15130 -- [ Convention =>] convention_IDENTIFIER,
15131 -- [ Entity =>] LOCAL_NAME
15132 -- [, [External_Name =>] static_string_EXPRESSION ]
15133 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15135 when Pragma_Interface
=>
15140 Name_External_Name
,
15142 Check_At_Least_N_Arguments
(2);
15143 Check_At_Most_N_Arguments
(4);
15144 Process_Import_Or_Interface
;
15146 -- In Ada 2005, the permission to use Interface (a reserved word)
15147 -- as a pragma name is considered an obsolescent feature, and this
15148 -- pragma was already obsolescent in Ada 95.
15150 if Ada_Version
>= Ada_95
then
15152 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15154 if Warn_On_Obsolescent_Feature
then
15156 ("pragma Interface is an obsolescent feature?j?", N
);
15158 ("|use pragma Import instead?j?", N
);
15162 --------------------
15163 -- Interface_Name --
15164 --------------------
15166 -- pragma Interface_Name (
15167 -- [ Entity =>] LOCAL_NAME
15168 -- [,[External_Name =>] static_string_EXPRESSION ]
15169 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15171 when Pragma_Interface_Name
=> Interface_Name
: declare
15173 Def_Id
: Entity_Id
;
15174 Hom_Id
: Entity_Id
;
15180 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15181 Check_At_Least_N_Arguments
(2);
15182 Check_At_Most_N_Arguments
(3);
15183 Id
:= Get_Pragma_Arg
(Arg1
);
15186 -- This is obsolete from Ada 95 on, but it is an implementation
15187 -- defined pragma, so we do not consider that it violates the
15188 -- restriction (No_Obsolescent_Features).
15190 if Ada_Version
>= Ada_95
then
15191 if Warn_On_Obsolescent_Feature
then
15193 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15195 ("|use pragma Import instead?j?", N
);
15199 if not Is_Entity_Name
(Id
) then
15201 ("first argument for pragma% must be entity name", Arg1
);
15202 elsif Etype
(Id
) = Any_Type
then
15205 Def_Id
:= Entity
(Id
);
15208 -- Special DEC-compatible processing for the object case, forces
15209 -- object to be imported.
15211 if Ekind
(Def_Id
) = E_Variable
then
15212 Kill_Size_Check_Code
(Def_Id
);
15213 Note_Possible_Modification
(Id
, Sure
=> False);
15215 -- Initialization is not allowed for imported variable
15217 if Present
(Expression
(Parent
(Def_Id
)))
15218 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15220 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15222 ("no initialization allowed for declaration of& #",
15226 -- For compatibility, support VADS usage of providing both
15227 -- pragmas Interface and Interface_Name to obtain the effect
15228 -- of a single Import pragma.
15230 if Is_Imported
(Def_Id
)
15231 and then Present
(First_Rep_Item
(Def_Id
))
15232 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15234 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15238 Set_Imported
(Def_Id
);
15241 Set_Is_Public
(Def_Id
);
15242 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15245 -- Otherwise must be subprogram
15247 elsif not Is_Subprogram
(Def_Id
) then
15249 ("argument of pragma% is not subprogram", Arg1
);
15252 Check_At_Most_N_Arguments
(3);
15256 -- Loop through homonyms
15259 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15261 if Is_Imported
(Def_Id
) then
15262 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15266 exit when From_Aspect_Specification
(N
);
15267 Hom_Id
:= Homonym
(Hom_Id
);
15269 exit when No
(Hom_Id
)
15270 or else Scope
(Hom_Id
) /= Current_Scope
;
15275 ("argument of pragma% is not imported subprogram",
15279 end Interface_Name
;
15281 -----------------------
15282 -- Interrupt_Handler --
15283 -----------------------
15285 -- pragma Interrupt_Handler (handler_NAME);
15287 when Pragma_Interrupt_Handler
=>
15288 Check_Ada_83_Warning
;
15289 Check_Arg_Count
(1);
15290 Check_No_Identifiers
;
15292 if No_Run_Time_Mode
then
15293 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15295 Check_Interrupt_Or_Attach_Handler
;
15296 Process_Interrupt_Or_Attach_Handler
;
15299 ------------------------
15300 -- Interrupt_Priority --
15301 ------------------------
15303 -- pragma Interrupt_Priority [(EXPRESSION)];
15305 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15306 P
: constant Node_Id
:= Parent
(N
);
15311 Check_Ada_83_Warning
;
15313 if Arg_Count
/= 0 then
15314 Arg
:= Get_Pragma_Arg
(Arg1
);
15315 Check_Arg_Count
(1);
15316 Check_No_Identifiers
;
15318 -- The expression must be analyzed in the special manner
15319 -- described in "Handling of Default and Per-Object
15320 -- Expressions" in sem.ads.
15322 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15325 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15330 Ent
:= Defining_Identifier
(Parent
(P
));
15332 -- Check duplicate pragma before we chain the pragma in the Rep
15333 -- Item chain of Ent.
15335 Check_Duplicate_Pragma
(Ent
);
15336 Record_Rep_Item
(Ent
, N
);
15338 end Interrupt_Priority
;
15340 ---------------------
15341 -- Interrupt_State --
15342 ---------------------
15344 -- pragma Interrupt_State (
15345 -- [Name =>] INTERRUPT_ID,
15346 -- [State =>] INTERRUPT_STATE);
15348 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15349 -- INTERRUPT_STATE => System | Runtime | User
15351 -- Note: if the interrupt id is given as an identifier, then it must
15352 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15353 -- given as a static integer expression which must be in the range of
15354 -- Ada.Interrupts.Interrupt_ID.
15356 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15357 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15358 -- This is the entity Ada.Interrupts.Interrupt_ID;
15360 State_Type
: Character;
15361 -- Set to 's'/'r'/'u' for System/Runtime/User
15364 -- Index to entry in Interrupt_States table
15367 -- Value of interrupt
15369 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15370 -- The first argument to the pragma
15372 Int_Ent
: Entity_Id
;
15373 -- Interrupt entity in Ada.Interrupts.Names
15377 Check_Arg_Order
((Name_Name
, Name_State
));
15378 Check_Arg_Count
(2);
15380 Check_Optional_Identifier
(Arg1
, Name_Name
);
15381 Check_Optional_Identifier
(Arg2
, Name_State
);
15382 Check_Arg_Is_Identifier
(Arg2
);
15384 -- First argument is identifier
15386 if Nkind
(Arg1X
) = N_Identifier
then
15388 -- Search list of names in Ada.Interrupts.Names
15390 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15392 if No
(Int_Ent
) then
15393 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15395 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15396 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15400 Next_Entity
(Int_Ent
);
15403 -- First argument is not an identifier, so it must be a static
15404 -- expression of type Ada.Interrupts.Interrupt_ID.
15407 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15408 Int_Val
:= Expr_Value
(Arg1X
);
15410 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15412 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15415 ("value not in range of type "
15416 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15422 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15423 when Name_Runtime
=> State_Type
:= 'r';
15424 when Name_System
=> State_Type
:= 's';
15425 when Name_User
=> State_Type
:= 'u';
15428 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15431 -- Check if entry is already stored
15433 IST_Num
:= Interrupt_States
.First
;
15435 -- If entry not found, add it
15437 if IST_Num
> Interrupt_States
.Last
then
15438 Interrupt_States
.Append
15439 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15440 Interrupt_State
=> State_Type
,
15441 Pragma_Loc
=> Loc
));
15444 -- Case of entry for the same entry
15446 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15449 -- If state matches, done, no need to make redundant entry
15452 State_Type
= Interrupt_States
.Table
(IST_Num
).
15455 -- Otherwise if state does not match, error
15458 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15460 ("state conflicts with that given #", Arg2
);
15464 IST_Num
:= IST_Num
+ 1;
15466 end Interrupt_State
;
15472 -- pragma Invariant
15473 -- ([Entity =>] type_LOCAL_NAME,
15474 -- [Check =>] EXPRESSION
15475 -- [,[Message =>] String_Expression]);
15477 when Pragma_Invariant
=> Invariant
: declare
15484 Check_At_Least_N_Arguments
(2);
15485 Check_At_Most_N_Arguments
(3);
15486 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15487 Check_Optional_Identifier
(Arg2
, Name_Check
);
15489 if Arg_Count
= 3 then
15490 Check_Optional_Identifier
(Arg3
, Name_Message
);
15491 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
15494 Check_Arg_Is_Local_Name
(Arg1
);
15496 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15497 Find_Type
(Type_Id
);
15498 Typ
:= Entity
(Type_Id
);
15500 if Typ
= Any_Type
then
15503 -- Invariants allowed in interface types (RM 7.3.2(3/3))
15505 elsif Is_Interface
(Typ
) then
15508 -- An invariant must apply to a private type, or appear in the
15509 -- private part of a package spec and apply to a completion.
15510 -- a class-wide invariant can only appear on a private declaration
15511 -- or private extension, not a completion.
15513 elsif Ekind_In
(Typ
, E_Private_Type
,
15514 E_Record_Type_With_Private
,
15515 E_Limited_Private_Type
)
15519 elsif In_Private_Part
(Current_Scope
)
15520 and then Has_Private_Declaration
(Typ
)
15521 and then not Class_Present
(N
)
15525 elsif In_Private_Part
(Current_Scope
) then
15527 ("pragma% only allowed for private type declared in "
15528 & "visible part", Arg1
);
15532 ("pragma% only allowed for private type", Arg1
);
15535 -- Not allowed for abstract type in the non-class case (it is
15536 -- allowed to use Invariant'Class for abstract types).
15538 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
15540 ("pragma% not allowed for abstract type", Arg1
);
15543 -- Note that the type has at least one invariant, and also that
15544 -- it has inheritable invariants if we have Invariant'Class
15545 -- or Type_Invariant'Class. Build the corresponding invariant
15546 -- procedure declaration, so that calls to it can be generated
15547 -- before the body is built (e.g. within an expression function).
15549 -- Interface types have no invariant procedure; their invariants
15550 -- are propagated to the build invariant procedure of all the
15551 -- types covering the interface type.
15553 if not Is_Interface
(Typ
) then
15554 Insert_After_And_Analyze
15555 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
15558 if Class_Present
(N
) then
15559 Set_Has_Inheritable_Invariants
(Typ
);
15562 -- The remaining processing is simply to link the pragma on to
15563 -- the rep item chain, for processing when the type is frozen.
15564 -- This is accomplished by a call to Rep_Item_Too_Late.
15566 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15569 ----------------------
15570 -- Java_Constructor --
15571 ----------------------
15573 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15575 -- Also handles pragma CIL_Constructor
15577 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15578 Java_Constructor
: declare
15579 Convention
: Convention_Id
;
15580 Def_Id
: Entity_Id
;
15581 Hom_Id
: Entity_Id
;
15583 This_Formal
: Entity_Id
;
15587 Check_Arg_Count
(1);
15588 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15589 Check_Arg_Is_Local_Name
(Arg1
);
15591 Id
:= Get_Pragma_Arg
(Arg1
);
15592 Find_Program_Unit_Name
(Id
);
15594 -- If we did not find the name, we are done
15596 if Etype
(Id
) = Any_Type
then
15600 -- Check wrong use of pragma in wrong VM target
15602 if VM_Target
= No_VM
then
15605 elsif VM_Target
= CLI_Target
15606 and then Prag_Id
= Pragma_Java_Constructor
15608 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15610 elsif VM_Target
= JVM_Target
15611 and then Prag_Id
= Pragma_CIL_Constructor
15613 Error_Pragma
("must use pragma 'Java_'Constructor");
15617 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15618 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15619 when others => null;
15622 Hom_Id
:= Entity
(Id
);
15624 -- Loop through homonyms
15627 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15629 -- The constructor is required to be a function
15631 if Ekind
(Def_Id
) /= E_Function
then
15632 if VM_Target
= JVM_Target
then
15634 ("pragma% requires function returning a 'Java access "
15638 ("pragma% requires function returning a 'C'I'L access "
15643 -- Check arguments: For tagged type the first formal must be
15644 -- named "this" and its type must be a named access type
15645 -- designating a class-wide tagged type that has convention
15646 -- CIL/Java. The first formal must also have a null default
15647 -- value. For example:
15649 -- type Typ is tagged ...
15650 -- type Ref is access all Typ;
15651 -- pragma Convention (CIL, Typ);
15653 -- function New_Typ (This : Ref) return Ref;
15654 -- function New_Typ (This : Ref; I : Integer) return Ref;
15655 -- pragma Cil_Constructor (New_Typ);
15657 -- Reason: The first formal must NOT be a primitive of the
15660 -- This rule also applies to constructors of delegates used
15661 -- to interface with standard target libraries. For example:
15663 -- type Delegate is access procedure ...
15664 -- pragma Import (CIL, Delegate, ...);
15666 -- function new_Delegate
15667 -- (This : Delegate := null; ... ) return Delegate;
15669 -- For value-types this rule does not apply.
15671 if not Is_Value_Type
(Etype
(Def_Id
)) then
15672 if No
(First_Formal
(Def_Id
)) then
15673 Error_Msg_Name_1
:= Pname
;
15674 Error_Msg_N
("% function must have parameters", Def_Id
);
15678 -- In the JRE library we have several occurrences in which
15679 -- the "this" parameter is not the first formal.
15681 This_Formal
:= First_Formal
(Def_Id
);
15683 -- In the JRE library we have several occurrences in which
15684 -- the "this" parameter is not the first formal. Search for
15687 if VM_Target
= JVM_Target
then
15688 while Present
(This_Formal
)
15689 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15691 Next_Formal
(This_Formal
);
15694 if No
(This_Formal
) then
15695 This_Formal
:= First_Formal
(Def_Id
);
15699 -- Warning: The first parameter should be named "this".
15700 -- We temporarily allow it because we have the following
15701 -- case in the Java runtime (file s-osinte.ads) ???
15703 -- function new_Thread
15704 -- (Self_Id : System.Address) return Thread_Id;
15705 -- pragma Java_Constructor (new_Thread);
15707 if VM_Target
= JVM_Target
15708 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15710 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15714 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15715 Error_Msg_Name_1
:= Pname
;
15717 ("first formal of % function must be named `this`",
15718 Parent
(This_Formal
));
15720 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15721 Error_Msg_Name_1
:= Pname
;
15723 ("first formal of % function must be an access type",
15724 Parameter_Type
(Parent
(This_Formal
)));
15726 -- For delegates the type of the first formal must be a
15727 -- named access-to-subprogram type (see previous example)
15729 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15730 and then Ekind
(Etype
(This_Formal
))
15731 /= E_Access_Subprogram_Type
15733 Error_Msg_Name_1
:= Pname
;
15735 ("first formal of % function must be a named access "
15736 & "to subprogram type",
15737 Parameter_Type
(Parent
(This_Formal
)));
15739 -- Warning: We should reject anonymous access types because
15740 -- the constructor must not be handled as a primitive of the
15741 -- tagged type. We temporarily allow it because this profile
15742 -- is currently generated by cil2ada???
15744 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
15745 and then not Ekind_In
(Etype
(This_Formal
),
15747 E_General_Access_Type
,
15748 E_Anonymous_Access_Type
)
15750 Error_Msg_Name_1
:= Pname
;
15752 ("first formal of % function must be a named access "
15753 & "type", Parameter_Type
(Parent
(This_Formal
)));
15755 elsif Atree
.Convention
15756 (Designated_Type
(Etype
(This_Formal
))) /= Convention
15758 Error_Msg_Name_1
:= Pname
;
15760 if Convention
= Convention_Java
then
15762 ("pragma% requires convention 'Cil in designated "
15763 & "type", Parameter_Type
(Parent
(This_Formal
)));
15766 ("pragma% requires convention 'Java in designated "
15767 & "type", Parameter_Type
(Parent
(This_Formal
)));
15770 elsif No
(Expression
(Parent
(This_Formal
)))
15771 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
15773 Error_Msg_Name_1
:= Pname
;
15775 ("pragma% requires first formal with default `null`",
15776 Parameter_Type
(Parent
(This_Formal
)));
15780 -- Check result type: the constructor must be a function
15782 -- * a value type (only allowed in the CIL compiler)
15783 -- * an access-to-subprogram type with convention Java/CIL
15784 -- * an access-type designating a type that has convention
15787 if Is_Value_Type
(Etype
(Def_Id
)) then
15790 -- Access-to-subprogram type with convention Java/CIL
15792 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
15793 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
15794 if Convention
= Convention_Java
then
15796 ("pragma% requires function returning a 'Java "
15797 & "access type", Arg1
);
15799 pragma Assert
(Convention
= Convention_CIL
);
15801 ("pragma% requires function returning a 'C'I'L "
15802 & "access type", Arg1
);
15806 elsif Is_Access_Type
(Etype
(Def_Id
)) then
15807 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
15808 E_General_Access_Type
)
15811 (Designated_Type
(Etype
(Def_Id
))) /= Convention
15813 Error_Msg_Name_1
:= Pname
;
15815 if Convention
= Convention_Java
then
15817 ("pragma% requires function returning a named "
15818 & "'Java access type", Arg1
);
15821 ("pragma% requires function returning a named "
15822 & "'C'I'L access type", Arg1
);
15827 Set_Is_Constructor
(Def_Id
);
15828 Set_Convention
(Def_Id
, Convention
);
15829 Set_Is_Imported
(Def_Id
);
15831 exit when From_Aspect_Specification
(N
);
15832 Hom_Id
:= Homonym
(Hom_Id
);
15834 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
15836 end Java_Constructor
;
15838 ----------------------
15839 -- Java_Interface --
15840 ----------------------
15842 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
15844 when Pragma_Java_Interface
=> Java_Interface
: declare
15850 Check_Arg_Count
(1);
15851 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15852 Check_Arg_Is_Local_Name
(Arg1
);
15854 Arg
:= Get_Pragma_Arg
(Arg1
);
15857 if Etype
(Arg
) = Any_Type
then
15861 if not Is_Entity_Name
(Arg
)
15862 or else not Is_Type
(Entity
(Arg
))
15864 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
15867 Typ
:= Underlying_Type
(Entity
(Arg
));
15869 -- For now simply check some of the semantic constraints on the
15870 -- type. This currently leaves out some restrictions on interface
15871 -- types, namely that the parent type must be java.lang.Object.Typ
15872 -- and that all primitives of the type should be declared
15875 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
15877 ("pragma% requires an abstract tagged type", Arg1
);
15879 elsif not Has_Discriminants
(Typ
)
15880 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
15881 /= E_Anonymous_Access_Type
15883 not Is_Class_Wide_Type
15884 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
15887 ("type must have a class-wide access discriminant", Arg1
);
15889 end Java_Interface
;
15895 -- pragma Keep_Names ([On => ] LOCAL_NAME);
15897 when Pragma_Keep_Names
=> Keep_Names
: declare
15902 Check_Arg_Count
(1);
15903 Check_Optional_Identifier
(Arg1
, Name_On
);
15904 Check_Arg_Is_Local_Name
(Arg1
);
15906 Arg
:= Get_Pragma_Arg
(Arg1
);
15909 if Etype
(Arg
) = Any_Type
then
15913 if not Is_Entity_Name
(Arg
)
15914 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
15917 ("pragma% requires a local enumeration type", Arg1
);
15920 Set_Discard_Names
(Entity
(Arg
), False);
15927 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
15929 when Pragma_License
=>
15932 -- Do not analyze pragma any further in CodePeer mode, to avoid
15933 -- extraneous errors in this implementation-dependent pragma,
15934 -- which has a different profile on other compilers.
15936 if CodePeer_Mode
then
15940 Check_Arg_Count
(1);
15941 Check_No_Identifiers
;
15942 Check_Valid_Configuration_Pragma
;
15943 Check_Arg_Is_Identifier
(Arg1
);
15946 Sind
: constant Source_File_Index
:=
15947 Source_Index
(Current_Sem_Unit
);
15950 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15952 Set_License
(Sind
, GPL
);
15954 when Name_Modified_GPL
=>
15955 Set_License
(Sind
, Modified_GPL
);
15957 when Name_Restricted
=>
15958 Set_License
(Sind
, Restricted
);
15960 when Name_Unrestricted
=>
15961 Set_License
(Sind
, Unrestricted
);
15964 Error_Pragma_Arg
("invalid license name", Arg1
);
15972 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
15974 when Pragma_Link_With
=> Link_With
: declare
15980 if Operating_Mode
= Generate_Code
15981 and then In_Extended_Main_Source_Unit
(N
)
15983 Check_At_Least_N_Arguments
(1);
15984 Check_No_Identifiers
;
15985 Check_Is_In_Decl_Part_Or_Package_Spec
;
15986 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15990 while Present
(Arg
) loop
15991 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
15993 -- Store argument, converting sequences of spaces to a
15994 -- single null character (this is one of the differences
15995 -- in processing between Link_With and Linker_Options).
15997 Arg_Store
: declare
15998 C
: constant Char_Code
:= Get_Char_Code
(' ');
15999 S
: constant String_Id
:=
16000 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16001 L
: constant Nat
:= String_Length
(S
);
16004 procedure Skip_Spaces
;
16005 -- Advance F past any spaces
16011 procedure Skip_Spaces
is
16013 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16018 -- Start of processing for Arg_Store
16021 Skip_Spaces
; -- skip leading spaces
16023 -- Loop through characters, changing any embedded
16024 -- sequence of spaces to a single null character (this
16025 -- is how Link_With/Linker_Options differ)
16028 if Get_String_Char
(S
, F
) = C
then
16031 Store_String_Char
(ASCII
.NUL
);
16034 Store_String_Char
(Get_String_Char
(S
, F
));
16042 if Present
(Arg
) then
16043 Store_String_Char
(ASCII
.NUL
);
16047 Store_Linker_Option_String
(End_String
);
16055 -- pragma Linker_Alias (
16056 -- [Entity =>] LOCAL_NAME
16057 -- [Target =>] static_string_EXPRESSION);
16059 when Pragma_Linker_Alias
=>
16061 Check_Arg_Order
((Name_Entity
, Name_Target
));
16062 Check_Arg_Count
(2);
16063 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16064 Check_Optional_Identifier
(Arg2
, Name_Target
);
16065 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16066 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16068 -- The only processing required is to link this item on to the
16069 -- list of rep items for the given entity. This is accomplished
16070 -- by the call to Rep_Item_Too_Late (when no error is detected
16071 -- and False is returned).
16073 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16076 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16079 ------------------------
16080 -- Linker_Constructor --
16081 ------------------------
16083 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16085 -- Code is shared with Linker_Destructor
16087 -----------------------
16088 -- Linker_Destructor --
16089 -----------------------
16091 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16093 when Pragma_Linker_Constructor |
16094 Pragma_Linker_Destructor
=>
16095 Linker_Constructor
: declare
16101 Check_Arg_Count
(1);
16102 Check_No_Identifiers
;
16103 Check_Arg_Is_Local_Name
(Arg1
);
16104 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16106 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16108 if not Is_Library_Level_Entity
(Proc
) then
16110 ("argument for pragma% must be library level entity", Arg1
);
16113 -- The only processing required is to link this item on to the
16114 -- list of rep items for the given entity. This is accomplished
16115 -- by the call to Rep_Item_Too_Late (when no error is detected
16116 -- and False is returned).
16118 if Rep_Item_Too_Late
(Proc
, N
) then
16121 Set_Has_Gigi_Rep_Item
(Proc
);
16123 end Linker_Constructor
;
16125 --------------------
16126 -- Linker_Options --
16127 --------------------
16129 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16131 when Pragma_Linker_Options
=> Linker_Options
: declare
16135 Check_Ada_83_Warning
;
16136 Check_No_Identifiers
;
16137 Check_Arg_Count
(1);
16138 Check_Is_In_Decl_Part_Or_Package_Spec
;
16139 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16140 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16143 while Present
(Arg
) loop
16144 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16145 Store_String_Char
(ASCII
.NUL
);
16147 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16151 if Operating_Mode
= Generate_Code
16152 and then In_Extended_Main_Source_Unit
(N
)
16154 Store_Linker_Option_String
(End_String
);
16156 end Linker_Options
;
16158 --------------------
16159 -- Linker_Section --
16160 --------------------
16162 -- pragma Linker_Section (
16163 -- [Entity =>] LOCAL_NAME
16164 -- [Section =>] static_string_EXPRESSION);
16166 when Pragma_Linker_Section
=> Linker_Section
: declare
16173 Check_Arg_Order
((Name_Entity
, Name_Section
));
16174 Check_Arg_Count
(2);
16175 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16176 Check_Optional_Identifier
(Arg2
, Name_Section
);
16177 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16178 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16180 -- Check kind of entity
16182 Arg
:= Get_Pragma_Arg
(Arg1
);
16183 Ent
:= Entity
(Arg
);
16185 case Ekind
(Ent
) is
16187 -- Objects (constants and variables) and types. For these cases
16188 -- all we need to do is to set the Linker_Section_pragma field,
16189 -- checking that we do not have a duplicate.
16191 when E_Constant | E_Variable | Type_Kind
=>
16192 LPE
:= Linker_Section_Pragma
(Ent
);
16194 if Present
(LPE
) then
16195 Error_Msg_Sloc
:= Sloc
(LPE
);
16197 ("Linker_Section already specified for &#", Arg1
, Ent
);
16200 Set_Linker_Section_Pragma
(Ent
, N
);
16204 when Subprogram_Kind
=>
16206 -- Aspect case, entity already set
16208 if From_Aspect_Specification
(N
) then
16209 Set_Linker_Section_Pragma
16210 (Entity
(Corresponding_Aspect
(N
)), N
);
16212 -- Pragma case, we must climb the homonym chain, but skip
16213 -- any for which the linker section is already set.
16217 if No
(Linker_Section_Pragma
(Ent
)) then
16218 Set_Linker_Section_Pragma
(Ent
, N
);
16221 Ent
:= Homonym
(Ent
);
16223 or else Scope
(Ent
) /= Current_Scope
;
16227 -- All other cases are illegal
16231 ("pragma% applies only to objects, subprograms, and types",
16234 end Linker_Section
;
16240 -- pragma List (On | Off)
16242 -- There is nothing to do here, since we did all the processing for
16243 -- this pragma in Par.Prag (so that it works properly even in syntax
16246 when Pragma_List
=>
16253 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16255 when Pragma_Lock_Free
=> Lock_Free
: declare
16256 P
: constant Node_Id
:= Parent
(N
);
16262 Check_No_Identifiers
;
16263 Check_At_Most_N_Arguments
(1);
16265 -- Protected definition case
16267 if Nkind
(P
) = N_Protected_Definition
then
16268 Ent
:= Defining_Identifier
(Parent
(P
));
16272 if Arg_Count
= 1 then
16273 Arg
:= Get_Pragma_Arg
(Arg1
);
16274 Val
:= Is_True
(Static_Boolean
(Arg
));
16276 -- No arguments (expression is considered to be True)
16282 -- Check duplicate pragma before we chain the pragma in the Rep
16283 -- Item chain of Ent.
16285 Check_Duplicate_Pragma
(Ent
);
16286 Record_Rep_Item
(Ent
, N
);
16287 Set_Uses_Lock_Free
(Ent
, Val
);
16289 -- Anything else is incorrect placement
16296 --------------------
16297 -- Locking_Policy --
16298 --------------------
16300 -- pragma Locking_Policy (policy_IDENTIFIER);
16302 when Pragma_Locking_Policy
=> declare
16303 subtype LP_Range
is Name_Id
16304 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16309 Check_Ada_83_Warning
;
16310 Check_Arg_Count
(1);
16311 Check_No_Identifiers
;
16312 Check_Arg_Is_Locking_Policy
(Arg1
);
16313 Check_Valid_Configuration_Pragma
;
16314 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16317 when Name_Ceiling_Locking
=>
16319 when Name_Inheritance_Locking
=>
16321 when Name_Concurrent_Readers_Locking
=>
16325 if Locking_Policy
/= ' '
16326 and then Locking_Policy
/= LP
16328 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16329 Error_Pragma
("locking policy incompatible with policy#");
16331 -- Set new policy, but always preserve System_Location since we
16332 -- like the error message with the run time name.
16335 Locking_Policy
:= LP
;
16337 if Locking_Policy_Sloc
/= System_Location
then
16338 Locking_Policy_Sloc
:= Loc
;
16343 -------------------
16344 -- Loop_Optimize --
16345 -------------------
16347 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16349 -- OPTIMIZATION_HINT ::=
16350 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16352 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16357 Check_At_Least_N_Arguments
(1);
16358 Check_No_Identifiers
;
16360 Hint
:= First
(Pragma_Argument_Associations
(N
));
16361 while Present
(Hint
) loop
16362 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16370 Check_Loop_Pragma_Placement
;
16377 -- pragma Loop_Variant
16378 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16380 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16382 -- CHANGE_DIRECTION ::= Increases | Decreases
16384 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16389 Check_At_Least_N_Arguments
(1);
16390 Check_Loop_Pragma_Placement
;
16392 -- Process all increasing / decreasing expressions
16394 Variant
:= First
(Pragma_Argument_Associations
(N
));
16395 while Present
(Variant
) loop
16396 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16399 Error_Pragma_Arg
("wrong change modifier", Variant
);
16402 Preanalyze_Assert_Expression
16403 (Expression
(Variant
), Any_Discrete
);
16409 -----------------------
16410 -- Machine_Attribute --
16411 -----------------------
16413 -- pragma Machine_Attribute (
16414 -- [Entity =>] LOCAL_NAME,
16415 -- [Attribute_Name =>] static_string_EXPRESSION
16416 -- [, [Info =>] static_EXPRESSION] );
16418 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16419 Def_Id
: Entity_Id
;
16423 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16425 if Arg_Count
= 3 then
16426 Check_Optional_Identifier
(Arg3
, Name_Info
);
16427 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16429 Check_Arg_Count
(2);
16432 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16433 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16434 Check_Arg_Is_Local_Name
(Arg1
);
16435 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16436 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16438 if Is_Access_Type
(Def_Id
) then
16439 Def_Id
:= Designated_Type
(Def_Id
);
16442 if Rep_Item_Too_Early
(Def_Id
, N
) then
16446 Def_Id
:= Underlying_Type
(Def_Id
);
16448 -- The only processing required is to link this item on to the
16449 -- list of rep items for the given entity. This is accomplished
16450 -- by the call to Rep_Item_Too_Late (when no error is detected
16451 -- and False is returned).
16453 if Rep_Item_Too_Late
(Def_Id
, N
) then
16456 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16458 end Machine_Attribute
;
16465 -- (MAIN_OPTION [, MAIN_OPTION]);
16468 -- [STACK_SIZE =>] static_integer_EXPRESSION
16469 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16470 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16472 when Pragma_Main
=> Main
: declare
16473 Args
: Args_List
(1 .. 3);
16474 Names
: constant Name_List
(1 .. 3) := (
16476 Name_Task_Stack_Size_Default
,
16477 Name_Time_Slicing_Enabled
);
16483 Gather_Associations
(Names
, Args
);
16485 for J
in 1 .. 2 loop
16486 if Present
(Args
(J
)) then
16487 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16491 if Present
(Args
(3)) then
16492 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
16496 while Present
(Nod
) loop
16497 if Nkind
(Nod
) = N_Pragma
16498 and then Pragma_Name
(Nod
) = Name_Main
16500 Error_Msg_Name_1
:= Pname
;
16501 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16512 -- pragma Main_Storage
16513 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16515 -- MAIN_STORAGE_OPTION ::=
16516 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16517 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16519 when Pragma_Main_Storage
=> Main_Storage
: declare
16520 Args
: Args_List
(1 .. 2);
16521 Names
: constant Name_List
(1 .. 2) := (
16522 Name_Working_Storage
,
16529 Gather_Associations
(Names
, Args
);
16531 for J
in 1 .. 2 loop
16532 if Present
(Args
(J
)) then
16533 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16537 Check_In_Main_Program
;
16540 while Present
(Nod
) loop
16541 if Nkind
(Nod
) = N_Pragma
16542 and then Pragma_Name
(Nod
) = Name_Main_Storage
16544 Error_Msg_Name_1
:= Pname
;
16545 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16556 -- pragma Memory_Size (NUMERIC_LITERAL)
16558 when Pragma_Memory_Size
=>
16561 -- Memory size is simply ignored
16563 Check_No_Identifiers
;
16564 Check_Arg_Count
(1);
16565 Check_Arg_Is_Integer_Literal
(Arg1
);
16573 -- The only correct use of this pragma is on its own in a file, in
16574 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16575 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16576 -- check for a file containing nothing but a No_Body pragma). If we
16577 -- attempt to process it during normal semantics processing, it means
16578 -- it was misplaced.
16580 when Pragma_No_Body
=>
16584 -----------------------------
16585 -- No_Elaboration_Code_All --
16586 -----------------------------
16588 -- pragma No_Elaboration_Code_All;
16590 when Pragma_No_Elaboration_Code_All
=> NECA
: declare
16593 Check_Valid_Library_Unit_Pragma
;
16595 if Nkind
(N
) = N_Null_Statement
then
16599 -- Must appear for a spec or generic spec
16601 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
16602 N_Generic_Package_Declaration
,
16603 N_Generic_Subprogram_Declaration
,
16604 N_Package_Declaration
,
16605 N_Subprogram_Declaration
)
16609 ("pragma% can only occur for package "
16610 & "or subprogram spec"));
16613 -- Set flag in unit table
16615 Set_No_Elab_Code_All
(Current_Sem_Unit
);
16617 -- Set restriction No_Elaboration_Code if this is the main unit
16619 if Current_Sem_Unit
= Main_Unit
then
16620 Set_Restriction
(No_Elaboration_Code
, N
);
16623 -- If we are in the main unit or in an extended main source unit,
16624 -- then we also add it to the configuration restrictions so that
16625 -- it will apply to all units in the extended main source.
16627 if Current_Sem_Unit
= Main_Unit
16628 or else In_Extended_Main_Source_Unit
(N
)
16630 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
16633 -- If in main extended unit, activate transitive with test
16635 if In_Extended_Main_Source_Unit
(N
) then
16636 Opt
.No_Elab_Code_All_Pragma
:= N
;
16644 -- pragma No_Inline ( NAME {, NAME} );
16646 when Pragma_No_Inline
=>
16648 Process_Inline
(Suppressed
);
16654 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16656 when Pragma_No_Return
=> No_Return
: declare
16664 Check_At_Least_N_Arguments
(1);
16666 -- Loop through arguments of pragma
16669 while Present
(Arg
) loop
16670 Check_Arg_Is_Local_Name
(Arg
);
16671 Id
:= Get_Pragma_Arg
(Arg
);
16674 if not Is_Entity_Name
(Id
) then
16675 Error_Pragma_Arg
("entity name required", Arg
);
16678 if Etype
(Id
) = Any_Type
then
16682 -- Loop to find matching procedures
16687 and then Scope
(E
) = Current_Scope
16689 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16692 -- Set flag on any alias as well
16694 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16695 Set_No_Return
(Alias
(E
));
16701 exit when From_Aspect_Specification
(N
);
16705 -- If entity in not in current scope it may be the enclosing
16706 -- suprogram body to which the aspect applies.
16709 if Entity
(Id
) = Current_Scope
16710 and then From_Aspect_Specification
(N
)
16712 Set_No_Return
(Entity
(Id
));
16714 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16726 -- pragma No_Run_Time;
16728 -- Note: this pragma is retained for backwards compatibility. See
16729 -- body of Rtsfind for full details on its handling.
16731 when Pragma_No_Run_Time
=>
16733 Check_Valid_Configuration_Pragma
;
16734 Check_Arg_Count
(0);
16736 No_Run_Time_Mode
:= True;
16737 Configurable_Run_Time_Mode
:= True;
16739 -- Set Duration to 32 bits if word size is 32
16741 if Ttypes
.System_Word_Size
= 32 then
16742 Duration_32_Bits_On_Target
:= True;
16745 -- Set appropriate restrictions
16747 Set_Restriction
(No_Finalization
, N
);
16748 Set_Restriction
(No_Exception_Handlers
, N
);
16749 Set_Restriction
(Max_Tasks
, N
, 0);
16750 Set_Restriction
(No_Tasking
, N
);
16752 -----------------------
16753 -- No_Tagged_Streams --
16754 -----------------------
16756 -- pragma No_Tagged_Streams;
16757 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
16759 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
16765 Check_At_Most_N_Arguments
(1);
16767 -- One argument case
16769 if Arg_Count
= 1 then
16770 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16771 Check_Arg_Is_Local_Name
(Arg1
);
16772 E_Id
:= Get_Pragma_Arg
(Arg1
);
16774 if Etype
(E_Id
) = Any_Type
then
16778 E
:= Entity
(E_Id
);
16780 Check_Duplicate_Pragma
(E
);
16782 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
16784 ("argument for pragma% must be root tagged type", Arg1
);
16787 if Rep_Item_Too_Early
(E
, N
)
16789 Rep_Item_Too_Late
(E
, N
)
16793 Set_No_Tagged_Streams_Pragma
(E
, N
);
16796 -- Zero argument case
16799 Check_Is_In_Decl_Part_Or_Package_Spec
;
16800 No_Tagged_Streams
:= N
;
16802 end No_Tagged_Strms
;
16804 ------------------------
16805 -- No_Strict_Aliasing --
16806 ------------------------
16808 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16810 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
16815 Check_At_Most_N_Arguments
(1);
16817 if Arg_Count
= 0 then
16818 Check_Valid_Configuration_Pragma
;
16819 Opt
.No_Strict_Aliasing
:= True;
16822 Check_Optional_Identifier
(Arg2
, Name_Entity
);
16823 Check_Arg_Is_Local_Name
(Arg1
);
16824 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16826 if E_Id
= Any_Type
then
16828 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
16829 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
16832 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
16834 end No_Strict_Aliasing
;
16836 -----------------------
16837 -- Normalize_Scalars --
16838 -----------------------
16840 -- pragma Normalize_Scalars;
16842 when Pragma_Normalize_Scalars
=>
16843 Check_Ada_83_Warning
;
16844 Check_Arg_Count
(0);
16845 Check_Valid_Configuration_Pragma
;
16847 -- Normalize_Scalars creates false positives in CodePeer, and
16848 -- incorrect negative results in GNATprove mode, so ignore this
16849 -- pragma in these modes.
16851 if not (CodePeer_Mode
or GNATprove_Mode
) then
16852 Normalize_Scalars
:= True;
16853 Init_Or_Norm_Scalars
:= True;
16860 -- pragma Obsolescent;
16862 -- pragma Obsolescent (
16863 -- [Message =>] static_string_EXPRESSION
16864 -- [,[Version =>] Ada_05]]);
16866 -- pragma Obsolescent (
16867 -- [Entity =>] NAME
16868 -- [,[Message =>] static_string_EXPRESSION
16869 -- [,[Version =>] Ada_05]] );
16871 when Pragma_Obsolescent
=> Obsolescent
: declare
16875 procedure Set_Obsolescent
(E
: Entity_Id
);
16876 -- Given an entity Ent, mark it as obsolescent if appropriate
16878 ---------------------
16879 -- Set_Obsolescent --
16880 ---------------------
16882 procedure Set_Obsolescent
(E
: Entity_Id
) is
16891 -- Entity name was given
16893 if Present
(Ename
) then
16895 -- If entity name matches, we are fine. Save entity in
16896 -- pragma argument, for ASIS use.
16898 if Chars
(Ename
) = Chars
(Ent
) then
16899 Set_Entity
(Ename
, Ent
);
16900 Generate_Reference
(Ent
, Ename
);
16902 -- If entity name does not match, only possibility is an
16903 -- enumeration literal from an enumeration type declaration.
16905 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
16907 ("pragma % entity name does not match declaration");
16910 Ent
:= First_Literal
(E
);
16914 ("pragma % entity name does not match any "
16915 & "enumeration literal");
16917 elsif Chars
(Ent
) = Chars
(Ename
) then
16918 Set_Entity
(Ename
, Ent
);
16919 Generate_Reference
(Ent
, Ename
);
16923 Ent
:= Next_Literal
(Ent
);
16929 -- Ent points to entity to be marked
16931 if Arg_Count
>= 1 then
16933 -- Deal with static string argument
16935 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16936 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
16938 for J
in 1 .. String_Length
(S
) loop
16939 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
16941 ("pragma% argument does not allow wide characters",
16946 Obsolescent_Warnings
.Append
16947 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
16949 -- Check for Ada_05 parameter
16951 if Arg_Count
/= 1 then
16952 Check_Arg_Count
(2);
16955 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
16958 Check_Arg_Is_Identifier
(Argx
);
16960 if Chars
(Argx
) /= Name_Ada_05
then
16961 Error_Msg_Name_2
:= Name_Ada_05
;
16963 ("only allowed argument for pragma% is %", Argx
);
16966 if Ada_Version_Explicit
< Ada_2005
16967 or else not Warn_On_Ada_2005_Compatibility
16975 -- Set flag if pragma active
16978 Set_Is_Obsolescent
(Ent
);
16982 end Set_Obsolescent
;
16984 -- Start of processing for pragma Obsolescent
16989 Check_At_Most_N_Arguments
(3);
16991 -- See if first argument specifies an entity name
16995 (Chars
(Arg1
) = Name_Entity
16997 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
16999 N_Operator_Symbol
))
17001 Ename
:= Get_Pragma_Arg
(Arg1
);
17003 -- Eliminate first argument, so we can share processing
17007 Arg_Count
:= Arg_Count
- 1;
17009 -- No Entity name argument given
17015 if Arg_Count
>= 1 then
17016 Check_Optional_Identifier
(Arg1
, Name_Message
);
17018 if Arg_Count
= 2 then
17019 Check_Optional_Identifier
(Arg2
, Name_Version
);
17023 -- Get immediately preceding declaration
17026 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17030 -- Cases where we do not follow anything other than another pragma
17034 -- First case: library level compilation unit declaration with
17035 -- the pragma immediately following the declaration.
17037 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17039 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17042 -- Case 2: library unit placement for package
17046 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17048 if Is_Package_Or_Generic_Package
(Ent
) then
17049 Set_Obsolescent
(Ent
);
17055 -- Cases where we must follow a declaration, including an
17056 -- abstract subprogram declaration, which is not in the
17057 -- other node subtypes.
17060 if Nkind
(Decl
) not in N_Declaration
17061 and then Nkind
(Decl
) not in N_Later_Decl_Item
17062 and then Nkind
(Decl
) not in N_Generic_Declaration
17063 and then Nkind
(Decl
) not in N_Renaming_Declaration
17064 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
17067 ("pragma% misplaced, "
17068 & "must immediately follow a declaration");
17071 Set_Obsolescent
(Defining_Entity
(Decl
));
17081 -- pragma Optimize (Time | Space | Off);
17083 -- The actual check for optimize is done in Gigi. Note that this
17084 -- pragma does not actually change the optimization setting, it
17085 -- simply checks that it is consistent with the pragma.
17087 when Pragma_Optimize
=>
17088 Check_No_Identifiers
;
17089 Check_Arg_Count
(1);
17090 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17092 ------------------------
17093 -- Optimize_Alignment --
17094 ------------------------
17096 -- pragma Optimize_Alignment (Time | Space | Off);
17098 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17100 Check_No_Identifiers
;
17101 Check_Arg_Count
(1);
17102 Check_Valid_Configuration_Pragma
;
17105 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17109 Opt
.Optimize_Alignment
:= 'T';
17111 Opt
.Optimize_Alignment
:= 'S';
17113 Opt
.Optimize_Alignment
:= 'O';
17115 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17119 -- Set indication that mode is set locally. If we are in fact in a
17120 -- configuration pragma file, this setting is harmless since the
17121 -- switch will get reset anyway at the start of each unit.
17123 Optimize_Alignment_Local
:= True;
17124 end Optimize_Alignment
;
17130 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17132 when Pragma_Ordered
=> Ordered
: declare
17133 Assoc
: constant Node_Id
:= Arg1
;
17139 Check_No_Identifiers
;
17140 Check_Arg_Count
(1);
17141 Check_Arg_Is_Local_Name
(Arg1
);
17143 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17144 Find_Type
(Type_Id
);
17145 Typ
:= Entity
(Type_Id
);
17147 if Typ
= Any_Type
then
17150 Typ
:= Underlying_Type
(Typ
);
17153 if not Is_Enumeration_Type
(Typ
) then
17154 Error_Pragma
("pragma% must specify enumeration type");
17157 Check_First_Subtype
(Arg1
);
17158 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17161 -------------------
17162 -- Overflow_Mode --
17163 -------------------
17165 -- pragma Overflow_Mode
17166 -- ([General => ] MODE [, [Assertions => ] MODE]);
17168 -- MODE := STRICT | MINIMIZED | ELIMINATED
17170 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17171 -- since System.Bignums makes this assumption. This is true of nearly
17172 -- all (all?) targets.
17174 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17175 function Get_Overflow_Mode
17177 Arg
: Node_Id
) return Overflow_Mode_Type
;
17178 -- Function to process one pragma argument, Arg. If an identifier
17179 -- is present, it must be Name. Mode type is returned if a valid
17180 -- argument exists, otherwise an error is signalled.
17182 -----------------------
17183 -- Get_Overflow_Mode --
17184 -----------------------
17186 function Get_Overflow_Mode
17188 Arg
: Node_Id
) return Overflow_Mode_Type
17190 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17193 Check_Optional_Identifier
(Arg
, Name
);
17194 Check_Arg_Is_Identifier
(Argx
);
17196 if Chars
(Argx
) = Name_Strict
then
17199 elsif Chars
(Argx
) = Name_Minimized
then
17202 elsif Chars
(Argx
) = Name_Eliminated
then
17203 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17205 ("Eliminated not implemented on this target", Argx
);
17211 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17213 end Get_Overflow_Mode
;
17215 -- Start of processing for Overflow_Mode
17219 Check_At_Least_N_Arguments
(1);
17220 Check_At_Most_N_Arguments
(2);
17222 -- Process first argument
17224 Scope_Suppress
.Overflow_Mode_General
:=
17225 Get_Overflow_Mode
(Name_General
, Arg1
);
17227 -- Case of only one argument
17229 if Arg_Count
= 1 then
17230 Scope_Suppress
.Overflow_Mode_Assertions
:=
17231 Scope_Suppress
.Overflow_Mode_General
;
17233 -- Case of two arguments present
17236 Scope_Suppress
.Overflow_Mode_Assertions
:=
17237 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17241 --------------------------
17242 -- Overriding Renamings --
17243 --------------------------
17245 -- pragma Overriding_Renamings;
17247 when Pragma_Overriding_Renamings
=>
17249 Check_Arg_Count
(0);
17250 Check_Valid_Configuration_Pragma
;
17251 Overriding_Renamings
:= True;
17257 -- pragma Pack (first_subtype_LOCAL_NAME);
17259 when Pragma_Pack
=> Pack
: declare
17260 Assoc
: constant Node_Id
:= Arg1
;
17264 Ignore
: Boolean := False;
17267 Check_No_Identifiers
;
17268 Check_Arg_Count
(1);
17269 Check_Arg_Is_Local_Name
(Arg1
);
17270 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17272 if not Is_Entity_Name
(Type_Id
)
17273 or else not Is_Type
(Entity
(Type_Id
))
17276 ("argument for pragma% must be type or subtype", Arg1
);
17279 Find_Type
(Type_Id
);
17280 Typ
:= Entity
(Type_Id
);
17283 or else Rep_Item_Too_Early
(Typ
, N
)
17287 Typ
:= Underlying_Type
(Typ
);
17290 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17291 Error_Pragma
("pragma% must specify array or record type");
17294 Check_First_Subtype
(Arg1
);
17295 Check_Duplicate_Pragma
(Typ
);
17299 if Is_Array_Type
(Typ
) then
17300 Ctyp
:= Component_Type
(Typ
);
17302 -- Ignore pack that does nothing
17304 if Known_Static_Esize
(Ctyp
)
17305 and then Known_Static_RM_Size
(Ctyp
)
17306 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17307 and then Addressable
(Esize
(Ctyp
))
17312 -- Process OK pragma Pack. Note that if there is a separate
17313 -- component clause present, the Pack will be cancelled. This
17314 -- processing is in Freeze.
17316 if not Rep_Item_Too_Late
(Typ
, N
) then
17318 -- In CodePeer mode, we do not need complex front-end
17319 -- expansions related to pragma Pack, so disable handling
17322 if CodePeer_Mode
then
17325 -- Don't attempt any packing for VM targets. We possibly
17326 -- could deal with some cases of array bit-packing, but we
17327 -- don't bother, since this is not a typical kind of
17328 -- representation in the VM context anyway (and would not
17329 -- for example work nicely with the debugger).
17331 elsif VM_Target
/= No_VM
then
17332 if not GNAT_Mode
then
17334 ("??pragma% ignored in this configuration");
17337 -- Normal case where we do the pack action
17341 Set_Is_Packed
(Base_Type
(Typ
));
17342 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17345 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17349 -- For record types, the pack is always effective
17351 else pragma Assert
(Is_Record_Type
(Typ
));
17352 if not Rep_Item_Too_Late
(Typ
, N
) then
17354 -- Ignore pack request with warning in VM mode (skip warning
17355 -- if we are compiling GNAT run time library).
17357 if VM_Target
/= No_VM
then
17358 if not GNAT_Mode
then
17360 ("??pragma% ignored in this configuration");
17363 -- Normal case of pack request active
17366 Set_Is_Packed
(Base_Type
(Typ
));
17367 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17368 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17380 -- There is nothing to do here, since we did all the processing for
17381 -- this pragma in Par.Prag (so that it works properly even in syntax
17384 when Pragma_Page
=>
17391 -- pragma Part_Of (ABSTRACT_STATE);
17393 -- ABSTRACT_STATE ::= NAME
17395 when Pragma_Part_Of
=> Part_Of
: declare
17396 procedure Propagate_Part_Of
17397 (Pack_Id
: Entity_Id
;
17398 State_Id
: Entity_Id
;
17399 Instance
: Node_Id
);
17400 -- Propagate the Part_Of indicator to all abstract states and
17401 -- objects declared in the visible state space of a package
17402 -- denoted by Pack_Id. State_Id is the encapsulating state.
17403 -- Instance is the package instantiation node.
17405 -----------------------
17406 -- Propagate_Part_Of --
17407 -----------------------
17409 procedure Propagate_Part_Of
17410 (Pack_Id
: Entity_Id
;
17411 State_Id
: Entity_Id
;
17412 Instance
: Node_Id
)
17414 Has_Item
: Boolean := False;
17415 -- Flag set when the visible state space contains at least one
17416 -- abstract state or variable.
17418 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17419 -- Propagate the Part_Of indicator to all abstract states and
17420 -- objects declared in the visible state space of a package
17421 -- denoted by Pack_Id.
17423 -----------------------
17424 -- Propagate_Part_Of --
17425 -----------------------
17427 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17428 Item_Id
: Entity_Id
;
17431 -- Traverse the entity chain of the package and set relevant
17432 -- attributes of abstract states and objects declared in the
17433 -- visible state space of the package.
17435 Item_Id
:= First_Entity
(Pack_Id
);
17436 while Present
(Item_Id
)
17437 and then not In_Private_Part
(Item_Id
)
17439 -- Do not consider internally generated items
17441 if not Comes_From_Source
(Item_Id
) then
17444 -- The Part_Of indicator turns an abstract state or an
17445 -- object into a constituent of the encapsulating state.
17447 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17453 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17454 Set_Encapsulating_State
(Item_Id
, State_Id
);
17456 -- Recursively handle nested packages and instantiations
17458 elsif Ekind
(Item_Id
) = E_Package
then
17459 Propagate_Part_Of
(Item_Id
);
17462 Next_Entity
(Item_Id
);
17464 end Propagate_Part_Of
;
17466 -- Start of processing for Propagate_Part_Of
17469 Propagate_Part_Of
(Pack_Id
);
17471 -- Detect a package instantiation that is subject to a Part_Of
17472 -- indicator, but has no visible state.
17474 if not Has_Item
then
17476 ("package instantiation & has Part_Of indicator but "
17477 & "lacks visible state", Instance
, Pack_Id
);
17479 end Propagate_Part_Of
;
17483 Item_Id
: Entity_Id
;
17486 State_Id
: Entity_Id
;
17489 -- Start of processing for Part_Of
17493 Check_No_Identifiers
;
17494 Check_Arg_Count
(1);
17496 -- Ensure the proper placement of the pragma. Part_Of must appear
17497 -- on an object declaration or a package instantiation.
17500 while Present
(Stmt
) loop
17502 -- Skip prior pragmas, but check for duplicates
17504 if Nkind
(Stmt
) = N_Pragma
then
17505 if Pragma_Name
(Stmt
) = Pname
then
17506 Error_Msg_Name_1
:= Pname
;
17507 Error_Msg_Sloc
:= Sloc
(Stmt
);
17508 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17511 -- Skip internally generated code
17513 elsif not Comes_From_Source
(Stmt
) then
17516 -- The pragma applies to an object declaration (possibly a
17517 -- variable) or a package instantiation. Stop the traversal
17518 -- and continue the analysis.
17520 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17521 N_Package_Instantiation
)
17525 -- The pragma does not apply to a legal construct, issue an
17526 -- error and stop the analysis.
17533 Stmt
:= Prev
(Stmt
);
17536 -- Extract the entity of the related object declaration or package
17537 -- instantiation. In the case of the instantiation, use the entity
17538 -- of the instance spec.
17540 if Nkind
(Stmt
) = N_Package_Instantiation
then
17541 Stmt
:= Instance_Spec
(Stmt
);
17544 Item_Id
:= Defining_Entity
(Stmt
);
17545 State
:= Get_Pragma_Arg
(Arg1
);
17547 -- Detect any discrepancies between the placement of the object
17548 -- or package instantiation with respect to state space and the
17549 -- encapsulating state.
17552 (Item_Id
=> Item_Id
,
17559 -- Constants without "variable input" are not considered part
17560 -- of the hidden state of a package (SPARK RM 7.1.1(2)). As a
17561 -- result such constants do not require a Part_Of indicator.
17563 if Ekind
(Item_Id
) = E_Constant
17564 and then not Has_Variable_Input
(Item_Id
)
17567 ("useless Part_Of indicator, constant & does not have "
17568 & "variable input", N
, Item_Id
);
17572 State_Id
:= Entity
(State
);
17574 -- The Part_Of indicator turns an object into a constituent of
17575 -- the encapsulating state.
17577 if Ekind_In
(Item_Id
, E_Constant
, E_Variable
) then
17578 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17579 Set_Encapsulating_State
(Item_Id
, State_Id
);
17581 -- Propagate the Part_Of indicator to the visible state space
17582 -- of the package instantiation.
17586 (Pack_Id
=> Item_Id
,
17587 State_Id
=> State_Id
,
17591 -- Add the pragma to the contract of the item. This aids with
17592 -- the detection of a missing but required Part_Of indicator.
17594 Add_Contract_Item
(N
, Item_Id
);
17598 ----------------------------------
17599 -- Partition_Elaboration_Policy --
17600 ----------------------------------
17602 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17604 when Pragma_Partition_Elaboration_Policy
=> declare
17605 subtype PEP_Range
is Name_Id
17606 range First_Partition_Elaboration_Policy_Name
17607 .. Last_Partition_Elaboration_Policy_Name
;
17608 PEP_Val
: PEP_Range
;
17613 Check_Arg_Count
(1);
17614 Check_No_Identifiers
;
17615 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17616 Check_Valid_Configuration_Pragma
;
17617 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17620 when Name_Concurrent
=>
17622 when Name_Sequential
=>
17626 if Partition_Elaboration_Policy
/= ' '
17627 and then Partition_Elaboration_Policy
/= PEP
17629 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17631 ("partition elaboration policy incompatible with policy#");
17633 -- Set new policy, but always preserve System_Location since we
17634 -- like the error message with the run time name.
17637 Partition_Elaboration_Policy
:= PEP
;
17639 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17640 Partition_Elaboration_Policy_Sloc
:= Loc
;
17649 -- pragma Passive [(PASSIVE_FORM)];
17651 -- PASSIVE_FORM ::= Semaphore | No
17653 when Pragma_Passive
=>
17656 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17657 Error_Pragma
("pragma% must be within task definition");
17660 if Arg_Count
/= 0 then
17661 Check_Arg_Count
(1);
17662 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17665 ----------------------------------
17666 -- Preelaborable_Initialization --
17667 ----------------------------------
17669 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17671 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17676 Check_Arg_Count
(1);
17677 Check_No_Identifiers
;
17678 Check_Arg_Is_Identifier
(Arg1
);
17679 Check_Arg_Is_Local_Name
(Arg1
);
17680 Check_First_Subtype
(Arg1
);
17681 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17683 -- The pragma may come from an aspect on a private declaration,
17684 -- even if the freeze point at which this is analyzed in the
17685 -- private part after the full view.
17687 if Has_Private_Declaration
(Ent
)
17688 and then From_Aspect_Specification
(N
)
17692 -- Check appropriate type argument
17694 elsif Is_Private_Type
(Ent
)
17695 or else Is_Protected_Type
(Ent
)
17696 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17698 -- AI05-0028: The pragma applies to all composite types. Note
17699 -- that we apply this binding interpretation to earlier versions
17700 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
17701 -- choice since there are other compilers that do the same.
17703 or else Is_Composite_Type
(Ent
)
17709 ("pragma % can only be applied to private, formal derived, "
17710 & "protected, or composite type", Arg1
);
17713 -- Give an error if the pragma is applied to a protected type that
17714 -- does not qualify (due to having entries, or due to components
17715 -- that do not qualify).
17717 if Is_Protected_Type
(Ent
)
17718 and then not Has_Preelaborable_Initialization
(Ent
)
17721 ("protected type & does not have preelaborable "
17722 & "initialization", Ent
);
17724 -- Otherwise mark the type as definitely having preelaborable
17728 Set_Known_To_Have_Preelab_Init
(Ent
);
17731 if Has_Pragma_Preelab_Init
(Ent
)
17732 and then Warn_On_Redundant_Constructs
17734 Error_Pragma
("?r?duplicate pragma%!");
17736 Set_Has_Pragma_Preelab_Init
(Ent
);
17740 --------------------
17741 -- Persistent_BSS --
17742 --------------------
17744 -- pragma Persistent_BSS [(object_NAME)];
17746 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17753 Check_At_Most_N_Arguments
(1);
17755 -- Case of application to specific object (one argument)
17757 if Arg_Count
= 1 then
17758 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17760 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17762 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17765 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17768 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17769 Decl
:= Parent
(Ent
);
17771 -- Check for duplication before inserting in list of
17772 -- representation items.
17774 Check_Duplicate_Pragma
(Ent
);
17776 if Rep_Item_Too_Late
(Ent
, N
) then
17780 if Present
(Expression
(Decl
)) then
17782 ("object for pragma% cannot have initialization", Arg1
);
17785 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17787 ("object type for pragma% is not potentially persistent",
17792 Make_Linker_Section_Pragma
17793 (Ent
, Sloc
(N
), ".persistent.bss");
17794 Insert_After
(N
, Prag
);
17797 -- Case of use as configuration pragma with no arguments
17800 Check_Valid_Configuration_Pragma
;
17801 Persistent_BSS_Mode
:= True;
17803 end Persistent_BSS
;
17809 -- pragma Polling (ON | OFF);
17811 when Pragma_Polling
=>
17813 Check_Arg_Count
(1);
17814 Check_No_Identifiers
;
17815 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17816 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17818 -----------------------------------
17819 -- Post/Post_Class/Postcondition --
17820 -----------------------------------
17822 -- pragma Post (Boolean_EXPRESSION);
17823 -- pragma Post_Class (Boolean_EXPRESSION);
17824 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
17825 -- [,[Message =>] String_EXPRESSION]);
17827 -- Characteristics:
17829 -- * Analysis - The annotation undergoes initial checks to verify
17830 -- the legal placement and context. Secondary checks preanalyze the
17833 -- Analyze_Pre_Post_Condition_In_Decl_Part
17835 -- * Expansion - The annotation is expanded during the expansion of
17836 -- the related subprogram [body] contract as performed in:
17838 -- Expand_Subprogram_Contract
17840 -- * Template - The annotation utilizes the generic template of the
17841 -- related subprogram [body] when it is:
17843 -- aspect on subprogram declaration
17844 -- aspect on stand alone subprogram body
17845 -- pragma on stand alone subprogram body
17847 -- The annotation must prepare its own template when it is:
17849 -- pragma on subprogram declaration
17851 -- * Globals - Capture of global references must occur after full
17854 -- * Instance - The annotation is instantiated automatically when
17855 -- the related generic subprogram [body] is instantiated except for
17856 -- the "pragma on subprogram declaration" case. In that scenario
17857 -- the annotation must instantiate itself.
17860 Pragma_Post_Class |
17861 Pragma_Postcondition
=>
17862 Analyze_Pre_Post_Condition
;
17864 --------------------------------
17865 -- Pre/Pre_Class/Precondition --
17866 --------------------------------
17868 -- pragma Pre (Boolean_EXPRESSION);
17869 -- pragma Pre_Class (Boolean_EXPRESSION);
17870 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
17871 -- [,[Message =>] String_EXPRESSION]);
17873 -- Characteristics:
17875 -- * Analysis - The annotation undergoes initial checks to verify
17876 -- the legal placement and context. Secondary checks preanalyze the
17879 -- Analyze_Pre_Post_Condition_In_Decl_Part
17881 -- * Expansion - The annotation is expanded during the expansion of
17882 -- the related subprogram [body] contract as performed in:
17884 -- Expand_Subprogram_Contract
17886 -- * Template - The annotation utilizes the generic template of the
17887 -- related subprogram [body] when it is:
17889 -- aspect on subprogram declaration
17890 -- aspect on stand alone subprogram body
17891 -- pragma on stand alone subprogram body
17893 -- The annotation must prepare its own template when it is:
17895 -- pragma on subprogram declaration
17897 -- * Globals - Capture of global references must occur after full
17900 -- * Instance - The annotation is instantiated automatically when
17901 -- the related generic subprogram [body] is instantiated except for
17902 -- the "pragma on subprogram declaration" case. In that scenario
17903 -- the annotation must instantiate itself.
17907 Pragma_Precondition
=>
17908 Analyze_Pre_Post_Condition
;
17914 -- pragma Predicate
17915 -- ([Entity =>] type_LOCAL_NAME,
17916 -- [Check =>] boolean_EXPRESSION);
17918 when Pragma_Predicate
=> Predicate
: declare
17925 Check_Arg_Count
(2);
17926 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17927 Check_Optional_Identifier
(Arg2
, Name_Check
);
17929 Check_Arg_Is_Local_Name
(Arg1
);
17931 Type_Id
:= Get_Pragma_Arg
(Arg1
);
17932 Find_Type
(Type_Id
);
17933 Typ
:= Entity
(Type_Id
);
17935 if Typ
= Any_Type
then
17939 -- The remaining processing is simply to link the pragma on to
17940 -- the rep item chain, for processing when the type is frozen.
17941 -- This is accomplished by a call to Rep_Item_Too_Late. We also
17942 -- mark the type as having predicates.
17944 Set_Has_Predicates
(Typ
);
17945 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
17952 -- pragma Preelaborate [(library_unit_NAME)];
17954 -- Set the flag Is_Preelaborated of program unit name entity
17956 when Pragma_Preelaborate
=> Preelaborate
: declare
17957 Pa
: constant Node_Id
:= Parent
(N
);
17958 Pk
: constant Node_Kind
:= Nkind
(Pa
);
17962 Check_Ada_83_Warning
;
17963 Check_Valid_Library_Unit_Pragma
;
17965 if Nkind
(N
) = N_Null_Statement
then
17969 Ent
:= Find_Lib_Unit_Name
;
17970 Check_Duplicate_Pragma
(Ent
);
17972 -- This filters out pragmas inside generic parents that show up
17973 -- inside instantiations. Pragmas that come from aspects in the
17974 -- unit are not ignored.
17976 if Present
(Ent
) then
17977 if Pk
= N_Package_Specification
17978 and then Present
(Generic_Parent
(Pa
))
17979 and then not From_Aspect_Specification
(N
)
17984 if not Debug_Flag_U
then
17985 Set_Is_Preelaborated
(Ent
);
17986 Set_Suppress_Elaboration_Warnings
(Ent
);
17992 -------------------------------
17993 -- Prefix_Exception_Messages --
17994 -------------------------------
17996 -- pragma Prefix_Exception_Messages;
17998 when Pragma_Prefix_Exception_Messages
=>
18000 Check_Valid_Configuration_Pragma
;
18001 Check_Arg_Count
(0);
18002 Prefix_Exception_Messages
:= True;
18008 -- pragma Priority (EXPRESSION);
18010 when Pragma_Priority
=> Priority
: declare
18011 P
: constant Node_Id
:= Parent
(N
);
18016 Check_No_Identifiers
;
18017 Check_Arg_Count
(1);
18021 if Nkind
(P
) = N_Subprogram_Body
then
18022 Check_In_Main_Program
;
18024 Ent
:= Defining_Unit_Name
(Specification
(P
));
18026 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18027 Ent
:= Defining_Identifier
(Ent
);
18030 Arg
:= Get_Pragma_Arg
(Arg1
);
18031 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18035 if not Is_OK_Static_Expression
(Arg
) then
18036 Flag_Non_Static_Expr
18037 ("main subprogram priority is not static!", Arg
);
18040 -- If constraint error, then we already signalled an error
18042 elsif Raises_Constraint_Error
(Arg
) then
18045 -- Otherwise check in range except if Relaxed_RM_Semantics
18046 -- where we ignore the value if out of range.
18050 Val
: constant Uint
:= Expr_Value
(Arg
);
18052 if not Relaxed_RM_Semantics
18055 or else Val
> Expr_Value
(Expression
18056 (Parent
(RTE
(RE_Max_Priority
)))))
18059 ("main subprogram priority is out of range", Arg1
);
18062 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18067 -- Load an arbitrary entity from System.Tasking.Stages or
18068 -- System.Tasking.Restricted.Stages (depending on the
18069 -- supported profile) to make sure that one of these packages
18070 -- is implicitly with'ed, since we need to have the tasking
18071 -- run time active for the pragma Priority to have any effect.
18072 -- Previously we with'ed the package System.Tasking, but this
18073 -- package does not trigger the required initialization of the
18074 -- run-time library.
18077 Discard
: Entity_Id
;
18078 pragma Warnings
(Off
, Discard
);
18080 if Restricted_Profile
then
18081 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18083 Discard
:= RTE
(RE_Activate_Tasks
);
18087 -- Task or Protected, must be of type Integer
18089 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18090 Arg
:= Get_Pragma_Arg
(Arg1
);
18091 Ent
:= Defining_Identifier
(Parent
(P
));
18093 -- The expression must be analyzed in the special manner
18094 -- described in "Handling of Default and Per-Object
18095 -- Expressions" in sem.ads.
18097 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18099 if not Is_OK_Static_Expression
(Arg
) then
18100 Check_Restriction
(Static_Priorities
, Arg
);
18103 -- Anything else is incorrect
18109 -- Check duplicate pragma before we chain the pragma in the Rep
18110 -- Item chain of Ent.
18112 Check_Duplicate_Pragma
(Ent
);
18113 Record_Rep_Item
(Ent
, N
);
18116 -----------------------------------
18117 -- Priority_Specific_Dispatching --
18118 -----------------------------------
18120 -- pragma Priority_Specific_Dispatching (
18121 -- policy_IDENTIFIER,
18122 -- first_priority_EXPRESSION,
18123 -- last_priority_EXPRESSION);
18125 when Pragma_Priority_Specific_Dispatching
=>
18126 Priority_Specific_Dispatching
: declare
18127 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18128 -- This is the entity System.Any_Priority;
18131 Lower_Bound
: Node_Id
;
18132 Upper_Bound
: Node_Id
;
18138 Check_Arg_Count
(3);
18139 Check_No_Identifiers
;
18140 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18141 Check_Valid_Configuration_Pragma
;
18142 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18143 DP
:= Fold_Upper
(Name_Buffer
(1));
18145 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18146 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
18147 Lower_Val
:= Expr_Value
(Lower_Bound
);
18149 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18150 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
18151 Upper_Val
:= Expr_Value
(Upper_Bound
);
18153 -- It is not allowed to use Task_Dispatching_Policy and
18154 -- Priority_Specific_Dispatching in the same partition.
18156 if Task_Dispatching_Policy
/= ' ' then
18157 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18159 ("pragma% incompatible with Task_Dispatching_Policy#");
18161 -- Check lower bound in range
18163 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18165 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18168 ("first_priority is out of range", Arg2
);
18170 -- Check upper bound in range
18172 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18174 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18177 ("last_priority is out of range", Arg3
);
18179 -- Check that the priority range is valid
18181 elsif Lower_Val
> Upper_Val
then
18183 ("last_priority_expression must be greater than or equal to "
18184 & "first_priority_expression");
18186 -- Store the new policy, but always preserve System_Location since
18187 -- we like the error message with the run-time name.
18190 -- Check overlapping in the priority ranges specified in other
18191 -- Priority_Specific_Dispatching pragmas within the same
18192 -- partition. We can only check those we know about.
18195 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18197 if Specific_Dispatching
.Table
(J
).First_Priority
in
18198 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18199 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18200 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18203 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18205 ("priority range overlaps with "
18206 & "Priority_Specific_Dispatching#");
18210 -- The use of Priority_Specific_Dispatching is incompatible
18211 -- with Task_Dispatching_Policy.
18213 if Task_Dispatching_Policy
/= ' ' then
18214 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18216 ("Priority_Specific_Dispatching incompatible "
18217 & "with Task_Dispatching_Policy#");
18220 -- The use of Priority_Specific_Dispatching forces ceiling
18223 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18224 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18226 ("Priority_Specific_Dispatching incompatible "
18227 & "with Locking_Policy#");
18229 -- Set the Ceiling_Locking policy, but preserve System_Location
18230 -- since we like the error message with the run time name.
18233 Locking_Policy
:= 'C';
18235 if Locking_Policy_Sloc
/= System_Location
then
18236 Locking_Policy_Sloc
:= Loc
;
18240 -- Add entry in the table
18242 Specific_Dispatching
.Append
18243 ((Dispatching_Policy
=> DP
,
18244 First_Priority
=> UI_To_Int
(Lower_Val
),
18245 Last_Priority
=> UI_To_Int
(Upper_Val
),
18246 Pragma_Loc
=> Loc
));
18248 end Priority_Specific_Dispatching
;
18254 -- pragma Profile (profile_IDENTIFIER);
18256 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18258 when Pragma_Profile
=>
18260 Check_Arg_Count
(1);
18261 Check_Valid_Configuration_Pragma
;
18262 Check_No_Identifiers
;
18265 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18268 if Chars
(Argx
) = Name_Ravenscar
then
18269 Set_Ravenscar_Profile
(N
);
18271 elsif Chars
(Argx
) = Name_Restricted
then
18272 Set_Profile_Restrictions
18274 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18276 elsif Chars
(Argx
) = Name_Rational
then
18277 Set_Rational_Profile
;
18279 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18280 Set_Profile_Restrictions
18281 (No_Implementation_Extensions
,
18282 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18285 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18289 ----------------------
18290 -- Profile_Warnings --
18291 ----------------------
18293 -- pragma Profile_Warnings (profile_IDENTIFIER);
18295 -- profile_IDENTIFIER => Restricted | Ravenscar
18297 when Pragma_Profile_Warnings
=>
18299 Check_Arg_Count
(1);
18300 Check_Valid_Configuration_Pragma
;
18301 Check_No_Identifiers
;
18304 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18307 if Chars
(Argx
) = Name_Ravenscar
then
18308 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18310 elsif Chars
(Argx
) = Name_Restricted
then
18311 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18313 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18314 Set_Profile_Restrictions
18315 (No_Implementation_Extensions
, N
, Warn
=> True);
18318 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18322 --------------------------
18323 -- Propagate_Exceptions --
18324 --------------------------
18326 -- pragma Propagate_Exceptions;
18328 -- Note: this pragma is obsolete and has no effect
18330 when Pragma_Propagate_Exceptions
=>
18332 Check_Arg_Count
(0);
18334 if Warn_On_Obsolescent_Feature
then
18336 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18337 "and has no effect?j?", N
);
18340 -----------------------------
18341 -- Provide_Shift_Operators --
18342 -----------------------------
18344 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18346 when Pragma_Provide_Shift_Operators
=>
18347 Provide_Shift_Operators
: declare
18350 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18351 -- Insert declaration and pragma Instrinsic for named shift op
18353 ----------------------------
18354 -- Declare_Shift_Operator --
18355 ----------------------------
18357 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18363 Make_Subprogram_Declaration
(Loc
,
18364 Make_Function_Specification
(Loc
,
18365 Defining_Unit_Name
=>
18366 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18368 Result_Definition
=>
18369 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18371 Parameter_Specifications
=> New_List
(
18372 Make_Parameter_Specification
(Loc
,
18373 Defining_Identifier
=>
18374 Make_Defining_Identifier
(Loc
, Name_Value
),
18376 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18378 Make_Parameter_Specification
(Loc
,
18379 Defining_Identifier
=>
18380 Make_Defining_Identifier
(Loc
, Name_Amount
),
18382 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18386 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18387 Pragma_Argument_Associations
=> New_List
(
18388 Make_Pragma_Argument_Association
(Loc
,
18389 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18390 Make_Pragma_Argument_Association
(Loc
,
18391 Expression
=> Make_Identifier
(Loc
, Nam
))));
18393 Insert_After
(N
, Import
);
18394 Insert_After
(N
, Func
);
18395 end Declare_Shift_Operator
;
18397 -- Start of processing for Provide_Shift_Operators
18401 Check_Arg_Count
(1);
18402 Check_Arg_Is_Local_Name
(Arg1
);
18404 Arg1
:= Get_Pragma_Arg
(Arg1
);
18406 -- We must have an entity name
18408 if not Is_Entity_Name
(Arg1
) then
18410 ("pragma % must apply to integer first subtype", Arg1
);
18413 -- If no Entity, means there was a prior error so ignore
18415 if Present
(Entity
(Arg1
)) then
18416 Ent
:= Entity
(Arg1
);
18418 -- Apply error checks
18420 if not Is_First_Subtype
(Ent
) then
18422 ("cannot apply pragma %",
18423 "\& is not a first subtype",
18426 elsif not Is_Integer_Type
(Ent
) then
18428 ("cannot apply pragma %",
18429 "\& is not an integer type",
18432 elsif Has_Shift_Operator
(Ent
) then
18434 ("cannot apply pragma %",
18435 "\& already has declared shift operators",
18438 elsif Is_Frozen
(Ent
) then
18440 ("pragma % appears too late",
18441 "\& is already frozen",
18445 -- Now declare the operators. We do this during analysis rather
18446 -- than expansion, since we want the operators available if we
18447 -- are operating in -gnatc or ASIS mode.
18449 Declare_Shift_Operator
(Name_Rotate_Left
);
18450 Declare_Shift_Operator
(Name_Rotate_Right
);
18451 Declare_Shift_Operator
(Name_Shift_Left
);
18452 Declare_Shift_Operator
(Name_Shift_Right
);
18453 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18455 end Provide_Shift_Operators
;
18461 -- pragma Psect_Object (
18462 -- [Internal =>] LOCAL_NAME,
18463 -- [, [External =>] EXTERNAL_SYMBOL]
18464 -- [, [Size =>] EXTERNAL_SYMBOL]);
18466 when Pragma_Psect_Object | Pragma_Common_Object
=>
18467 Psect_Object
: declare
18468 Args
: Args_List
(1 .. 3);
18469 Names
: constant Name_List
(1 .. 3) := (
18474 Internal
: Node_Id
renames Args
(1);
18475 External
: Node_Id
renames Args
(2);
18476 Size
: Node_Id
renames Args
(3);
18478 Def_Id
: Entity_Id
;
18480 procedure Check_Arg
(Arg
: Node_Id
);
18481 -- Checks that argument is either a string literal or an
18482 -- identifier, and posts error message if not.
18488 procedure Check_Arg
(Arg
: Node_Id
) is
18490 if not Nkind_In
(Original_Node
(Arg
),
18495 ("inappropriate argument for pragma %", Arg
);
18499 -- Start of processing for Common_Object/Psect_Object
18503 Gather_Associations
(Names
, Args
);
18504 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18506 Def_Id
:= Entity
(Internal
);
18508 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18510 ("pragma% must designate an object", Internal
);
18513 Check_Arg
(Internal
);
18515 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18517 ("cannot use pragma% for imported/exported object",
18521 if Is_Concurrent_Type
(Etype
(Internal
)) then
18523 ("cannot specify pragma % for task/protected object",
18527 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18529 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18531 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18534 if Ekind
(Def_Id
) = E_Constant
then
18536 ("cannot specify pragma % for a constant", Internal
);
18539 if Is_Record_Type
(Etype
(Internal
)) then
18545 Ent
:= First_Entity
(Etype
(Internal
));
18546 while Present
(Ent
) loop
18547 Decl
:= Declaration_Node
(Ent
);
18549 if Ekind
(Ent
) = E_Component
18550 and then Nkind
(Decl
) = N_Component_Declaration
18551 and then Present
(Expression
(Decl
))
18552 and then Warn_On_Export_Import
18555 ("?x?object for pragma % has defaults", Internal
);
18565 if Present
(Size
) then
18569 if Present
(External
) then
18570 Check_Arg_Is_External_Name
(External
);
18573 -- If all error tests pass, link pragma on to the rep item chain
18575 Record_Rep_Item
(Def_Id
, N
);
18582 -- pragma Pure [(library_unit_NAME)];
18584 when Pragma_Pure
=> Pure
: declare
18588 Check_Ada_83_Warning
;
18589 Check_Valid_Library_Unit_Pragma
;
18591 if Nkind
(N
) = N_Null_Statement
then
18595 Ent
:= Find_Lib_Unit_Name
;
18597 Set_Has_Pragma_Pure
(Ent
);
18598 Set_Suppress_Elaboration_Warnings
(Ent
);
18601 -------------------
18602 -- Pure_Function --
18603 -------------------
18605 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18607 when Pragma_Pure_Function
=> Pure_Function
: declare
18610 Def_Id
: Entity_Id
;
18611 Effective
: Boolean := False;
18615 Check_Arg_Count
(1);
18616 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18617 Check_Arg_Is_Local_Name
(Arg1
);
18618 E_Id
:= Get_Pragma_Arg
(Arg1
);
18620 if Error_Posted
(E_Id
) then
18624 -- Loop through homonyms (overloadings) of referenced entity
18626 E
:= Entity
(E_Id
);
18628 if Present
(E
) then
18630 Def_Id
:= Get_Base_Subprogram
(E
);
18632 if not Ekind_In
(Def_Id
, E_Function
,
18633 E_Generic_Function
,
18637 ("pragma% requires a function name", Arg1
);
18640 Set_Is_Pure
(Def_Id
);
18642 if not Has_Pragma_Pure_Function
(Def_Id
) then
18643 Set_Has_Pragma_Pure_Function
(Def_Id
);
18647 exit when From_Aspect_Specification
(N
);
18649 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18653 and then Warn_On_Redundant_Constructs
18656 ("pragma Pure_Function on& is redundant?r?",
18662 --------------------
18663 -- Queuing_Policy --
18664 --------------------
18666 -- pragma Queuing_Policy (policy_IDENTIFIER);
18668 when Pragma_Queuing_Policy
=> declare
18672 Check_Ada_83_Warning
;
18673 Check_Arg_Count
(1);
18674 Check_No_Identifiers
;
18675 Check_Arg_Is_Queuing_Policy
(Arg1
);
18676 Check_Valid_Configuration_Pragma
;
18677 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18678 QP
:= Fold_Upper
(Name_Buffer
(1));
18680 if Queuing_Policy
/= ' '
18681 and then Queuing_Policy
/= QP
18683 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18684 Error_Pragma
("queuing policy incompatible with policy#");
18686 -- Set new policy, but always preserve System_Location since we
18687 -- like the error message with the run time name.
18690 Queuing_Policy
:= QP
;
18692 if Queuing_Policy_Sloc
/= System_Location
then
18693 Queuing_Policy_Sloc
:= Loc
;
18702 -- pragma Rational, for compatibility with foreign compiler
18704 when Pragma_Rational
=>
18705 Set_Rational_Profile
;
18707 ------------------------------------
18708 -- Refined_Depends/Refined_Global --
18709 ------------------------------------
18711 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18713 -- DEPENDENCY_RELATION ::=
18715 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18717 -- DEPENDENCY_CLAUSE ::=
18718 -- OUTPUT_LIST =>[+] INPUT_LIST
18719 -- | NULL_DEPENDENCY_CLAUSE
18721 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18723 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18725 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18727 -- OUTPUT ::= NAME | FUNCTION_RESULT
18730 -- where FUNCTION_RESULT is a function Result attribute_reference
18732 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18734 -- GLOBAL_SPECIFICATION ::=
18737 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18739 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18741 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
18742 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
18743 -- GLOBAL_ITEM ::= NAME
18745 -- Characteristics:
18747 -- * Analysis - The annotation undergoes initial checks to verify
18748 -- the legal placement and context. Secondary checks fully analyze
18749 -- the dependency clauses/global list in:
18751 -- Analyze_Refined_Depends_In_Decl_Part
18752 -- Analyze_Refined_Global_In_Decl_Part
18754 -- * Expansion - None.
18756 -- * Template - The annotation utilizes the generic template of the
18757 -- related subprogram body.
18759 -- * Globals - Capture of global references must occur after full
18762 -- * Instance - The annotation is instantiated automatically when
18763 -- the related generic subprogram body is instantiated.
18765 when Pragma_Refined_Depends |
18766 Pragma_Refined_Global
=> Refined_Depends_Global
:
18768 Body_Id
: Entity_Id
;
18770 Spec_Id
: Entity_Id
;
18773 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
18775 -- Chain the pragma on the contract for further processing by
18776 -- Analyze_Refined_[Depends|Global]_In_Decl_Part.
18779 Add_Contract_Item
(N
, Body_Id
);
18781 end Refined_Depends_Global
;
18787 -- pragma Refined_Post (boolean_EXPRESSION);
18789 -- Characteristics:
18791 -- * Analysis - The annotation is fully analyzed immediately upon
18792 -- elaboration as it cannot forward reference entities.
18794 -- * Expansion - The annotation is expanded during the expansion of
18795 -- the related subprogram body contract as performed in:
18797 -- Expand_Subprogram_Contract
18799 -- * Template - The annotation utilizes the generic template of the
18800 -- related subprogram body.
18802 -- * Globals - Capture of global references must occur after full
18805 -- * Instance - The annotation is instantiated automatically when
18806 -- the related generic subprogram body is instantiated.
18808 when Pragma_Refined_Post
=> Refined_Post
: declare
18809 Body_Id
: Entity_Id
;
18811 Spec_Id
: Entity_Id
;
18814 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
18816 -- Fully analyze the pragma when it appears inside a subprogram
18817 -- body because it cannot benefit from forward references.
18820 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
18822 -- Currently it is not possible to inline pre/postconditions on
18823 -- a subprogram subject to pragma Inline_Always.
18825 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
18827 -- Chain the pragma on the contract for completeness
18829 Add_Contract_Item
(N
, Body_Id
);
18833 -------------------
18834 -- Refined_State --
18835 -------------------
18837 -- pragma Refined_State (REFINEMENT_LIST);
18839 -- REFINEMENT_LIST ::=
18840 -- REFINEMENT_CLAUSE
18841 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
18843 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
18845 -- CONSTITUENT_LIST ::=
18848 -- | (CONSTITUENT {, CONSTITUENT})
18850 -- CONSTITUENT ::= object_NAME | state_NAME
18852 -- Characteristics:
18854 -- * Analysis - The annotation undergoes initial checks to verify
18855 -- the legal placement and context. Secondary checks preanalyze the
18856 -- refinement clauses in:
18858 -- Analyze_Refined_State_In_Decl_Part
18860 -- * Expansion - None.
18862 -- * Template - The annotation utilizes the template of the related
18865 -- * Globals - Capture of global references must occur after full
18868 -- * Instance - The annotation is instantiated automatically when
18869 -- the related generic package body is instantiated.
18871 when Pragma_Refined_State
=> Refined_State
: declare
18872 Pack_Decl
: Node_Id
;
18873 Spec_Id
: Entity_Id
;
18877 Check_No_Identifiers
;
18878 Check_Arg_Count
(1);
18880 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18882 -- Ensure the proper placement of the pragma. Refined states must
18883 -- be associated with a package body.
18885 if Nkind
(Pack_Decl
) = N_Package_Body
then
18888 -- Otherwise the pragma is associated with an illegal construct
18895 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
18897 -- State refinement is allowed only when the corresponding package
18898 -- declaration has non-null pragma Abstract_State. Refinement not
18899 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
18901 if SPARK_Mode
/= Off
18903 (No
(Abstract_States
(Spec_Id
))
18904 or else Has_Null_Abstract_State
(Spec_Id
))
18907 ("useless refinement, package & does not define abstract "
18908 & "states", N
, Spec_Id
);
18912 -- Chain the pragma on the contract for further processing by
18913 -- Analyze_Refined_State_In_Decl_Part.
18915 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
18918 -----------------------
18919 -- Relative_Deadline --
18920 -----------------------
18922 -- pragma Relative_Deadline (time_span_EXPRESSION);
18924 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
18925 P
: constant Node_Id
:= Parent
(N
);
18930 Check_No_Identifiers
;
18931 Check_Arg_Count
(1);
18933 Arg
:= Get_Pragma_Arg
(Arg1
);
18935 -- The expression must be analyzed in the special manner described
18936 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
18938 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
18942 if Nkind
(P
) = N_Subprogram_Body
then
18943 Check_In_Main_Program
;
18945 -- Only Task and subprogram cases allowed
18947 elsif Nkind
(P
) /= N_Task_Definition
then
18951 -- Check duplicate pragma before we set the corresponding flag
18953 if Has_Relative_Deadline_Pragma
(P
) then
18954 Error_Pragma
("duplicate pragma% not allowed");
18957 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
18958 -- Relative_Deadline pragma node cannot be inserted in the Rep
18959 -- Item chain of Ent since it is rewritten by the expander as a
18960 -- procedure call statement that will break the chain.
18962 Set_Has_Relative_Deadline_Pragma
(P
, True);
18963 end Relative_Deadline
;
18965 ------------------------
18966 -- Remote_Access_Type --
18967 ------------------------
18969 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
18971 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
18976 Check_Arg_Count
(1);
18977 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18978 Check_Arg_Is_Local_Name
(Arg1
);
18980 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
18982 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
18983 and then Ekind
(E
) = E_General_Access_Type
18984 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
18985 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
18987 and then Is_Valid_Remote_Object_Type
18988 (Root_Type
(Directly_Designated_Type
(E
)))
18990 Set_Is_Remote_Types
(E
);
18994 ("pragma% applies only to formal access to classwide types",
18997 end Remote_Access_Type
;
18999 ---------------------------
19000 -- Remote_Call_Interface --
19001 ---------------------------
19003 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19005 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19006 Cunit_Node
: Node_Id
;
19007 Cunit_Ent
: Entity_Id
;
19011 Check_Ada_83_Warning
;
19012 Check_Valid_Library_Unit_Pragma
;
19014 if Nkind
(N
) = N_Null_Statement
then
19018 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19019 K
:= Nkind
(Unit
(Cunit_Node
));
19020 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19022 if K
= N_Package_Declaration
19023 or else K
= N_Generic_Package_Declaration
19024 or else K
= N_Subprogram_Declaration
19025 or else K
= N_Generic_Subprogram_Declaration
19026 or else (K
= N_Subprogram_Body
19027 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19032 "pragma% must apply to package or subprogram declaration");
19035 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19036 end Remote_Call_Interface
;
19042 -- pragma Remote_Types [(library_unit_NAME)];
19044 when Pragma_Remote_Types
=> Remote_Types
: declare
19045 Cunit_Node
: Node_Id
;
19046 Cunit_Ent
: Entity_Id
;
19049 Check_Ada_83_Warning
;
19050 Check_Valid_Library_Unit_Pragma
;
19052 if Nkind
(N
) = N_Null_Statement
then
19056 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19057 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19059 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19060 N_Generic_Package_Declaration
)
19063 ("pragma% can only apply to a package declaration");
19066 Set_Is_Remote_Types
(Cunit_Ent
);
19073 -- pragma Ravenscar;
19075 when Pragma_Ravenscar
=>
19077 Check_Arg_Count
(0);
19078 Check_Valid_Configuration_Pragma
;
19079 Set_Ravenscar_Profile
(N
);
19081 if Warn_On_Obsolescent_Feature
then
19083 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19085 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19088 -------------------------
19089 -- Restricted_Run_Time --
19090 -------------------------
19092 -- pragma Restricted_Run_Time;
19094 when Pragma_Restricted_Run_Time
=>
19096 Check_Arg_Count
(0);
19097 Check_Valid_Configuration_Pragma
;
19098 Set_Profile_Restrictions
19099 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19101 if Warn_On_Obsolescent_Feature
then
19103 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19106 ("|use pragma Profile (Restricted) instead?j?", N
);
19113 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19116 -- restriction_IDENTIFIER
19117 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19119 when Pragma_Restrictions
=>
19120 Process_Restrictions_Or_Restriction_Warnings
19121 (Warn
=> Treat_Restrictions_As_Warnings
);
19123 --------------------------
19124 -- Restriction_Warnings --
19125 --------------------------
19127 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19130 -- restriction_IDENTIFIER
19131 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19133 when Pragma_Restriction_Warnings
=>
19135 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19141 -- pragma Reviewable;
19143 when Pragma_Reviewable
=>
19144 Check_Ada_83_Warning
;
19145 Check_Arg_Count
(0);
19147 -- Call dummy debugging function rv. This is done to assist front
19148 -- end debugging. By placing a Reviewable pragma in the source
19149 -- program, a breakpoint on rv catches this place in the source,
19150 -- allowing convenient stepping to the point of interest.
19154 --------------------------
19155 -- Short_Circuit_And_Or --
19156 --------------------------
19158 -- pragma Short_Circuit_And_Or;
19160 when Pragma_Short_Circuit_And_Or
=>
19162 Check_Arg_Count
(0);
19163 Check_Valid_Configuration_Pragma
;
19164 Short_Circuit_And_Or
:= True;
19166 -------------------
19167 -- Share_Generic --
19168 -------------------
19170 -- pragma Share_Generic (GNAME {, GNAME});
19172 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19174 when Pragma_Share_Generic
=>
19176 Process_Generic_List
;
19182 -- pragma Shared (LOCAL_NAME);
19184 when Pragma_Shared
=>
19186 Process_Atomic_Independent_Shared_Volatile
;
19188 --------------------
19189 -- Shared_Passive --
19190 --------------------
19192 -- pragma Shared_Passive [(library_unit_NAME)];
19194 -- Set the flag Is_Shared_Passive of program unit name entity
19196 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19197 Cunit_Node
: Node_Id
;
19198 Cunit_Ent
: Entity_Id
;
19201 Check_Ada_83_Warning
;
19202 Check_Valid_Library_Unit_Pragma
;
19204 if Nkind
(N
) = N_Null_Statement
then
19208 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19209 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19211 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19212 N_Generic_Package_Declaration
)
19215 ("pragma% can only apply to a package declaration");
19218 Set_Is_Shared_Passive
(Cunit_Ent
);
19219 end Shared_Passive
;
19221 -----------------------
19222 -- Short_Descriptors --
19223 -----------------------
19225 -- pragma Short_Descriptors;
19227 -- Recognize and validate, but otherwise ignore
19229 when Pragma_Short_Descriptors
=>
19231 Check_Arg_Count
(0);
19232 Check_Valid_Configuration_Pragma
;
19234 ------------------------------
19235 -- Simple_Storage_Pool_Type --
19236 ------------------------------
19238 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19240 when Pragma_Simple_Storage_Pool_Type
=>
19241 Simple_Storage_Pool_Type
: declare
19247 Check_Arg_Count
(1);
19248 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19250 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19251 Find_Type
(Type_Id
);
19252 Typ
:= Entity
(Type_Id
);
19254 if Typ
= Any_Type
then
19258 -- We require the pragma to apply to a type declared in a package
19259 -- declaration, but not (immediately) within a package body.
19261 if Ekind
(Current_Scope
) /= E_Package
19262 or else In_Package_Body
(Current_Scope
)
19265 ("pragma% can only apply to type declared immediately "
19266 & "within a package declaration");
19269 -- A simple storage pool type must be an immutably limited record
19270 -- or private type. If the pragma is given for a private type,
19271 -- the full type is similarly restricted (which is checked later
19272 -- in Freeze_Entity).
19274 if Is_Record_Type
(Typ
)
19275 and then not Is_Limited_View
(Typ
)
19278 ("pragma% can only apply to explicitly limited record type");
19280 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19282 ("pragma% can only apply to a private type that is limited");
19284 elsif not Is_Record_Type
(Typ
)
19285 and then not Is_Private_Type
(Typ
)
19288 ("pragma% can only apply to limited record or private type");
19291 Record_Rep_Item
(Typ
, N
);
19292 end Simple_Storage_Pool_Type
;
19294 ----------------------
19295 -- Source_File_Name --
19296 ----------------------
19298 -- There are five forms for this pragma:
19300 -- pragma Source_File_Name (
19301 -- [UNIT_NAME =>] unit_NAME,
19302 -- BODY_FILE_NAME => STRING_LITERAL
19303 -- [, [INDEX =>] INTEGER_LITERAL]);
19305 -- pragma Source_File_Name (
19306 -- [UNIT_NAME =>] unit_NAME,
19307 -- SPEC_FILE_NAME => STRING_LITERAL
19308 -- [, [INDEX =>] INTEGER_LITERAL]);
19310 -- pragma Source_File_Name (
19311 -- BODY_FILE_NAME => STRING_LITERAL
19312 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19313 -- [, CASING => CASING_SPEC]);
19315 -- pragma Source_File_Name (
19316 -- SPEC_FILE_NAME => STRING_LITERAL
19317 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19318 -- [, CASING => CASING_SPEC]);
19320 -- pragma Source_File_Name (
19321 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19322 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19323 -- [, CASING => CASING_SPEC]);
19325 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19327 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19328 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19329 -- only be used when no project file is used, while SFNP can only be
19330 -- used when a project file is used.
19332 -- No processing here. Processing was completed during parsing, since
19333 -- we need to have file names set as early as possible. Units are
19334 -- loaded well before semantic processing starts.
19336 -- The only processing we defer to this point is the check for
19337 -- correct placement.
19339 when Pragma_Source_File_Name
=>
19341 Check_Valid_Configuration_Pragma
;
19343 ------------------------------
19344 -- Source_File_Name_Project --
19345 ------------------------------
19347 -- See Source_File_Name for syntax
19349 -- No processing here. Processing was completed during parsing, since
19350 -- we need to have file names set as early as possible. Units are
19351 -- loaded well before semantic processing starts.
19353 -- The only processing we defer to this point is the check for
19354 -- correct placement.
19356 when Pragma_Source_File_Name_Project
=>
19358 Check_Valid_Configuration_Pragma
;
19360 -- Check that a pragma Source_File_Name_Project is used only in a
19361 -- configuration pragmas file.
19363 -- Pragmas Source_File_Name_Project should only be generated by
19364 -- the Project Manager in configuration pragmas files.
19366 -- This is really an ugly test. It seems to depend on some
19367 -- accidental and undocumented property. At the very least it
19368 -- needs to be documented, but it would be better to have a
19369 -- clean way of testing if we are in a configuration file???
19371 if Present
(Parent
(N
)) then
19373 ("pragma% can only appear in a configuration pragmas file");
19376 ----------------------
19377 -- Source_Reference --
19378 ----------------------
19380 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19382 -- Nothing to do, all processing completed in Par.Prag, since we need
19383 -- the information for possible parser messages that are output.
19385 when Pragma_Source_Reference
=>
19392 -- pragma SPARK_Mode [(On | Off)];
19394 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19395 Mode_Id
: SPARK_Mode_Type
;
19397 procedure Check_Pragma_Conformance
19398 (Context_Pragma
: Node_Id
;
19399 Entity_Pragma
: Node_Id
;
19400 Entity
: Entity_Id
);
19401 -- If Context_Pragma is not Empty, verify that the new pragma N
19402 -- is compatible with the pragma Context_Pragma that was inherited
19403 -- from the context:
19404 -- . if Context_Pragma is ON, then the new mode can be anything
19405 -- . if Context_Pragma is OFF, then the only allowed new mode is
19408 -- If Entity is not Empty, verify that the new pragma N is
19409 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19410 -- for Entity (which may be Empty):
19411 -- . if Entity_Pragma is ON, then the new mode can be anything
19412 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19414 -- . if Entity_Pragma is Empty, we always issue an error, as this
19415 -- corresponds to a case where a previous section of Entity
19416 -- had no SPARK_Mode set.
19418 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19419 -- Verify that pragma is applied to library-level entity E
19421 procedure Set_SPARK_Flags
;
19422 -- Sets SPARK_Mode from Mode_Id and SPARK_Mode_Pragma from N,
19423 -- and ensures that Dynamic_Elaboration_Checks are off if the
19424 -- call sets SPARK_Mode On.
19426 ------------------------------
19427 -- Check_Pragma_Conformance --
19428 ------------------------------
19430 procedure Check_Pragma_Conformance
19431 (Context_Pragma
: Node_Id
;
19432 Entity_Pragma
: Node_Id
;
19433 Entity
: Entity_Id
)
19435 Arg
: Node_Id
:= Arg1
;
19438 -- The current pragma may appear without an argument. If this
19439 -- is the case, associate all error messages with the pragma
19446 -- The mode of the current pragma is compared against that of
19447 -- an enclosing context.
19449 if Present
(Context_Pragma
) then
19450 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19452 -- Issue an error if the new mode is less restrictive than
19453 -- that of the context.
19455 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19456 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19459 ("cannot change SPARK_Mode from Off to On", Arg
);
19460 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19461 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg
);
19466 -- The mode of the current pragma is compared against that of
19467 -- an initial package/subprogram declaration.
19469 if Present
(Entity
) then
19471 -- Both the initial declaration and the completion carry
19472 -- SPARK_Mode pragmas.
19474 if Present
(Entity_Pragma
) then
19475 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
19477 -- Issue an error if the new mode is less restrictive
19478 -- than that of the initial declaration.
19480 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19481 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19483 Error_Msg_N
("incorrect use of SPARK_Mode", Arg
);
19484 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19486 ("\value Off was set for SPARK_Mode on&#",
19491 -- Otherwise the initial declaration lacks a SPARK_Mode
19492 -- pragma in which case the current pragma is illegal as
19493 -- it cannot "complete".
19496 Error_Msg_N
("incorrect use of SPARK_Mode", Arg
);
19497 Error_Msg_Sloc
:= Sloc
(Entity
);
19499 ("\no value was set for SPARK_Mode on&#",
19504 end Check_Pragma_Conformance
;
19506 --------------------------------
19507 -- Check_Library_Level_Entity --
19508 --------------------------------
19510 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19511 MsgF
: constant String := "incorrect placement of pragma%";
19514 if not Is_Library_Level_Entity
(E
) then
19515 Error_Msg_Name_1
:= Pname
;
19516 Error_Msg_N
(Fix_Error
(MsgF
), N
);
19518 if Ekind_In
(E
, E_Generic_Package
,
19523 ("\& is not a library-level package", N
, E
);
19526 ("\& is not a library-level subprogram", N
, E
);
19531 end Check_Library_Level_Entity
;
19533 ---------------------
19534 -- Set_SPARK_Flags --
19535 ---------------------
19537 procedure Set_SPARK_Flags
is
19539 SPARK_Mode
:= Mode_Id
;
19540 SPARK_Mode_Pragma
:= N
;
19542 if SPARK_Mode
= On
then
19543 Dynamic_Elaboration_Checks
:= False;
19545 end Set_SPARK_Flags
;
19549 Body_Id
: Entity_Id
;
19552 Spec_Id
: Entity_Id
;
19555 -- Start of processing for Do_SPARK_Mode
19558 -- When a SPARK_Mode pragma appears inside an instantiation whose
19559 -- enclosing context has SPARK_Mode set to "off", the pragma has
19560 -- no semantic effect.
19562 if Ignore_Pragma_SPARK_Mode
then
19563 Rewrite
(N
, Make_Null_Statement
(Loc
));
19569 Check_No_Identifiers
;
19570 Check_At_Most_N_Arguments
(1);
19572 -- Check the legality of the mode (no argument = ON)
19574 if Arg_Count
= 1 then
19575 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19576 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19581 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19582 Context
:= Parent
(N
);
19584 -- The pragma appears in a configuration pragmas file
19586 if No
(Context
) then
19587 Check_Valid_Configuration_Pragma
;
19589 if Present
(SPARK_Mode_Pragma
) then
19590 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19591 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19597 -- The pragma acts as a configuration pragma in a compilation unit
19599 -- pragma SPARK_Mode ...;
19600 -- package Pack is ...;
19602 elsif Nkind
(Context
) = N_Compilation_Unit
19603 and then List_Containing
(N
) = Context_Items
(Context
)
19605 Check_Valid_Configuration_Pragma
;
19608 -- Otherwise the placement of the pragma within the tree dictates
19609 -- its associated construct. Inspect the declarative list where
19610 -- the pragma resides to find a potential construct.
19614 while Present
(Stmt
) loop
19616 -- Skip prior pragmas, but check for duplicates
19618 if Nkind
(Stmt
) = N_Pragma
then
19619 if Pragma_Name
(Stmt
) = Pname
then
19620 Error_Msg_Name_1
:= Pname
;
19621 Error_Msg_Sloc
:= Sloc
(Stmt
);
19622 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19626 -- The pragma applies to a [generic] subprogram declaration.
19627 -- Note that this case covers an internally generated spec
19628 -- for a stand alone body.
19631 -- procedure Proc ...;
19632 -- pragma SPARK_Mode ..;
19634 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
19635 N_Subprogram_Declaration
)
19637 Spec_Id
:= Defining_Entity
(Stmt
);
19638 Check_Library_Level_Entity
(Spec_Id
);
19639 Check_Pragma_Conformance
19640 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19641 Entity_Pragma
=> Empty
,
19644 Set_SPARK_Pragma
(Spec_Id
, N
);
19645 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19648 -- Skip internally generated code
19650 elsif not Comes_From_Source
(Stmt
) then
19653 -- Otherwise the pragma does not apply to a legal construct
19654 -- or it does not appear at the top of a declarative or a
19655 -- statement list. Issue an error and stop the analysis.
19665 -- The pragma applies to a package or a subprogram that acts as
19666 -- a compilation unit.
19668 -- procedure Proc ...;
19669 -- pragma SPARK_Mode ...;
19671 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19672 Context
:= Unit
(Parent
(Context
));
19675 -- The pragma appears within package declarations
19677 if Nkind
(Context
) = N_Package_Specification
then
19678 Spec_Id
:= Defining_Entity
(Context
);
19679 Check_Library_Level_Entity
(Spec_Id
);
19681 -- The pragma is at the top of the visible declarations
19684 -- pragma SPARK_Mode ...;
19686 if List_Containing
(N
) = Visible_Declarations
(Context
) then
19687 Check_Pragma_Conformance
19688 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19689 Entity_Pragma
=> Empty
,
19693 Set_SPARK_Pragma
(Spec_Id
, N
);
19694 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19695 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19696 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19698 -- The pragma is at the top of the private declarations
19702 -- pragma SPARK_Mode ...;
19705 Check_Pragma_Conformance
19706 (Context_Pragma
=> Empty
,
19707 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19708 Entity
=> Spec_Id
);
19711 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19712 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19715 -- The pragma appears at the top of package body declarations
19717 -- package body Pack is
19718 -- pragma SPARK_Mode ...;
19720 elsif Nkind
(Context
) = N_Package_Body
then
19721 Spec_Id
:= Corresponding_Spec
(Context
);
19722 Body_Id
:= Defining_Entity
(Context
);
19723 Check_Library_Level_Entity
(Body_Id
);
19724 Check_Pragma_Conformance
19725 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19726 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19727 Entity
=> Spec_Id
);
19730 Set_SPARK_Pragma
(Body_Id
, N
);
19731 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19732 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19733 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19735 -- The pragma appears at the top of package body statements
19737 -- package body Pack is
19739 -- pragma SPARK_Mode;
19741 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
19742 and then Nkind
(Parent
(Context
)) = N_Package_Body
19744 Context
:= Parent
(Context
);
19745 Spec_Id
:= Corresponding_Spec
(Context
);
19746 Body_Id
:= Defining_Entity
(Context
);
19747 Check_Library_Level_Entity
(Body_Id
);
19748 Check_Pragma_Conformance
19749 (Context_Pragma
=> Empty
,
19750 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
19751 Entity
=> Body_Id
);
19754 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19755 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
19757 -- The pragma appeared as an aspect of a [generic] subprogram
19758 -- declaration that acts as a compilation unit.
19761 -- procedure Proc ...;
19762 -- pragma SPARK_Mode ...;
19764 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
19765 N_Subprogram_Declaration
)
19767 Spec_Id
:= Defining_Entity
(Context
);
19768 Check_Library_Level_Entity
(Spec_Id
);
19769 Check_Pragma_Conformance
19770 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19771 Entity_Pragma
=> Empty
,
19774 Set_SPARK_Pragma
(Spec_Id
, N
);
19775 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19777 -- The pragma appears at the top of subprogram body
19780 -- procedure Proc ... is
19781 -- pragma SPARK_Mode;
19783 elsif Nkind
(Context
) = N_Subprogram_Body
then
19784 Spec_Id
:= Corresponding_Spec
(Context
);
19785 Context
:= Specification
(Context
);
19786 Body_Id
:= Defining_Entity
(Context
);
19788 -- Ignore pragma when applied to the special body created
19789 -- for inlining, recognized by its internal name _Parent.
19791 if Chars
(Body_Id
) = Name_uParent
then
19795 Check_Library_Level_Entity
(Body_Id
);
19797 -- The body is a completion of a previous declaration
19799 if Present
(Spec_Id
) then
19800 Check_Pragma_Conformance
19801 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19802 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19803 Entity
=> Spec_Id
);
19805 -- The body acts as spec
19808 Check_Pragma_Conformance
19809 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19810 Entity_Pragma
=> Empty
,
19816 Set_SPARK_Pragma
(Body_Id
, N
);
19817 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19819 -- The pragma does not apply to a legal construct, issue error
19827 --------------------------------
19828 -- Static_Elaboration_Desired --
19829 --------------------------------
19831 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
19833 when Pragma_Static_Elaboration_Desired
=>
19835 Check_At_Most_N_Arguments
(1);
19837 if Is_Compilation_Unit
(Current_Scope
)
19838 and then Ekind
(Current_Scope
) = E_Package
19840 Set_Static_Elaboration_Desired
(Current_Scope
, True);
19842 Error_Pragma
("pragma% must apply to a library-level package");
19849 -- pragma Storage_Size (EXPRESSION);
19851 when Pragma_Storage_Size
=> Storage_Size
: declare
19852 P
: constant Node_Id
:= Parent
(N
);
19856 Check_No_Identifiers
;
19857 Check_Arg_Count
(1);
19859 -- The expression must be analyzed in the special manner described
19860 -- in "Handling of Default Expressions" in sem.ads.
19862 Arg
:= Get_Pragma_Arg
(Arg1
);
19863 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
19865 if not Is_OK_Static_Expression
(Arg
) then
19866 Check_Restriction
(Static_Storage_Size
, Arg
);
19869 if Nkind
(P
) /= N_Task_Definition
then
19874 if Has_Storage_Size_Pragma
(P
) then
19875 Error_Pragma
("duplicate pragma% not allowed");
19877 Set_Has_Storage_Size_Pragma
(P
, True);
19880 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
19888 -- pragma Storage_Unit (NUMERIC_LITERAL);
19890 -- Only permitted argument is System'Storage_Unit value
19892 when Pragma_Storage_Unit
=>
19893 Check_No_Identifiers
;
19894 Check_Arg_Count
(1);
19895 Check_Arg_Is_Integer_Literal
(Arg1
);
19897 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
19898 UI_From_Int
(Ttypes
.System_Storage_Unit
)
19900 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
19902 ("the only allowed argument for pragma% is ^", Arg1
);
19905 --------------------
19906 -- Stream_Convert --
19907 --------------------
19909 -- pragma Stream_Convert (
19910 -- [Entity =>] type_LOCAL_NAME,
19911 -- [Read =>] function_NAME,
19912 -- [Write =>] function NAME);
19914 when Pragma_Stream_Convert
=> Stream_Convert
: declare
19916 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
19917 -- Check that the given argument is the name of a local function
19918 -- of one argument that is not overloaded earlier in the current
19919 -- local scope. A check is also made that the argument is a
19920 -- function with one parameter.
19922 --------------------------------------
19923 -- Check_OK_Stream_Convert_Function --
19924 --------------------------------------
19926 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
19930 Check_Arg_Is_Local_Name
(Arg
);
19931 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
19933 if Has_Homonym
(Ent
) then
19935 ("argument for pragma% may not be overloaded", Arg
);
19938 if Ekind
(Ent
) /= E_Function
19939 or else No
(First_Formal
(Ent
))
19940 or else Present
(Next_Formal
(First_Formal
(Ent
)))
19943 ("argument for pragma% must be function of one argument",
19946 end Check_OK_Stream_Convert_Function
;
19948 -- Start of processing for Stream_Convert
19952 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
19953 Check_Arg_Count
(3);
19954 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19955 Check_Optional_Identifier
(Arg2
, Name_Read
);
19956 Check_Optional_Identifier
(Arg3
, Name_Write
);
19957 Check_Arg_Is_Local_Name
(Arg1
);
19958 Check_OK_Stream_Convert_Function
(Arg2
);
19959 Check_OK_Stream_Convert_Function
(Arg3
);
19962 Typ
: constant Entity_Id
:=
19963 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
19964 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
19965 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
19968 Check_First_Subtype
(Arg1
);
19970 -- Check for too early or too late. Note that we don't enforce
19971 -- the rule about primitive operations in this case, since, as
19972 -- is the case for explicit stream attributes themselves, these
19973 -- restrictions are not appropriate. Note that the chaining of
19974 -- the pragma by Rep_Item_Too_Late is actually the critical
19975 -- processing done for this pragma.
19977 if Rep_Item_Too_Early
(Typ
, N
)
19979 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
19984 -- Return if previous error
19986 if Etype
(Typ
) = Any_Type
19988 Etype
(Read
) = Any_Type
19990 Etype
(Write
) = Any_Type
19997 if Underlying_Type
(Etype
(Read
)) /= Typ
then
19999 ("incorrect return type for function&", Arg2
);
20002 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
20004 ("incorrect parameter type for function&", Arg3
);
20007 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
20008 Underlying_Type
(Etype
(Write
))
20011 ("result type of & does not match Read parameter type",
20015 end Stream_Convert
;
20021 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20023 -- This is processed by the parser since some of the style checks
20024 -- take place during source scanning and parsing. This means that
20025 -- we don't need to issue error messages here.
20027 when Pragma_Style_Checks
=> Style_Checks
: declare
20028 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20034 Check_No_Identifiers
;
20036 -- Two argument form
20038 if Arg_Count
= 2 then
20039 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20046 E_Id
:= Get_Pragma_Arg
(Arg2
);
20049 if not Is_Entity_Name
(E_Id
) then
20051 ("second argument of pragma% must be entity name",
20055 E
:= Entity
(E_Id
);
20057 if not Ignore_Style_Checks_Pragmas
then
20062 Set_Suppress_Style_Checks
20063 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
20064 exit when No
(Homonym
(E
));
20071 -- One argument form
20074 Check_Arg_Count
(1);
20076 if Nkind
(A
) = N_String_Literal
then
20080 Slen
: constant Natural := Natural (String_Length
(S
));
20081 Options
: String (1 .. Slen
);
20087 C
:= Get_String_Char
(S
, Int
(J
));
20088 exit when not In_Character_Range
(C
);
20089 Options
(J
) := Get_Character
(C
);
20091 -- If at end of string, set options. As per discussion
20092 -- above, no need to check for errors, since we issued
20093 -- them in the parser.
20096 if not Ignore_Style_Checks_Pragmas
then
20097 Set_Style_Check_Options
(Options
);
20107 elsif Nkind
(A
) = N_Identifier
then
20108 if Chars
(A
) = Name_All_Checks
then
20109 if not Ignore_Style_Checks_Pragmas
then
20111 Set_GNAT_Style_Check_Options
;
20113 Set_Default_Style_Check_Options
;
20117 elsif Chars
(A
) = Name_On
then
20118 if not Ignore_Style_Checks_Pragmas
then
20119 Style_Check
:= True;
20122 elsif Chars
(A
) = Name_Off
then
20123 if not Ignore_Style_Checks_Pragmas
then
20124 Style_Check
:= False;
20135 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20137 when Pragma_Subtitle
=>
20139 Check_Arg_Count
(1);
20140 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
20141 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20148 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20150 when Pragma_Suppress
=>
20151 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
20157 -- pragma Suppress_All;
20159 -- The only check made here is that the pragma has no arguments.
20160 -- There are no placement rules, and the processing required (setting
20161 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20162 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20163 -- then creates and inserts a pragma Suppress (All_Checks).
20165 when Pragma_Suppress_All
=>
20167 Check_Arg_Count
(0);
20169 -------------------------
20170 -- Suppress_Debug_Info --
20171 -------------------------
20173 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20175 when Pragma_Suppress_Debug_Info
=>
20177 Check_Arg_Count
(1);
20178 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20179 Check_Arg_Is_Local_Name
(Arg1
);
20180 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
20182 ----------------------------------
20183 -- Suppress_Exception_Locations --
20184 ----------------------------------
20186 -- pragma Suppress_Exception_Locations;
20188 when Pragma_Suppress_Exception_Locations
=>
20190 Check_Arg_Count
(0);
20191 Check_Valid_Configuration_Pragma
;
20192 Exception_Locations_Suppressed
:= True;
20194 -----------------------------
20195 -- Suppress_Initialization --
20196 -----------------------------
20198 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20200 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
20206 Check_Arg_Count
(1);
20207 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20208 Check_Arg_Is_Local_Name
(Arg1
);
20210 E_Id
:= Get_Pragma_Arg
(Arg1
);
20212 if Etype
(E_Id
) = Any_Type
then
20216 E
:= Entity
(E_Id
);
20218 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
20220 ("pragma% requires variable, type or subtype", Arg1
);
20223 if Rep_Item_Too_Early
(E
, N
)
20225 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
20230 -- For incomplete/private type, set flag on full view
20232 if Is_Incomplete_Or_Private_Type
(E
) then
20233 if No
(Full_View
(Base_Type
(E
))) then
20235 ("argument of pragma% cannot be an incomplete type", Arg1
);
20237 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
20240 -- For first subtype, set flag on base type
20242 elsif Is_First_Subtype
(E
) then
20243 Set_Suppress_Initialization
(Base_Type
(E
));
20245 -- For other than first subtype, set flag on subtype or variable
20248 Set_Suppress_Initialization
(E
);
20256 -- pragma System_Name (DIRECT_NAME);
20258 -- Syntax check: one argument, which must be the identifier GNAT or
20259 -- the identifier GCC, no other identifiers are acceptable.
20261 when Pragma_System_Name
=>
20263 Check_No_Identifiers
;
20264 Check_Arg_Count
(1);
20265 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
20267 -----------------------------
20268 -- Task_Dispatching_Policy --
20269 -----------------------------
20271 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20273 when Pragma_Task_Dispatching_Policy
=> declare
20277 Check_Ada_83_Warning
;
20278 Check_Arg_Count
(1);
20279 Check_No_Identifiers
;
20280 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20281 Check_Valid_Configuration_Pragma
;
20282 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20283 DP
:= Fold_Upper
(Name_Buffer
(1));
20285 if Task_Dispatching_Policy
/= ' '
20286 and then Task_Dispatching_Policy
/= DP
20288 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20290 ("task dispatching policy incompatible with policy#");
20292 -- Set new policy, but always preserve System_Location since we
20293 -- like the error message with the run time name.
20296 Task_Dispatching_Policy
:= DP
;
20298 if Task_Dispatching_Policy_Sloc
/= System_Location
then
20299 Task_Dispatching_Policy_Sloc
:= Loc
;
20308 -- pragma Task_Info (EXPRESSION);
20310 when Pragma_Task_Info
=> Task_Info
: declare
20311 P
: constant Node_Id
:= Parent
(N
);
20317 if Warn_On_Obsolescent_Feature
then
20319 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20320 & "instead?j?", N
);
20323 if Nkind
(P
) /= N_Task_Definition
then
20324 Error_Pragma
("pragma% must appear in task definition");
20327 Check_No_Identifiers
;
20328 Check_Arg_Count
(1);
20330 Analyze_And_Resolve
20331 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
20333 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
20337 Ent
:= Defining_Identifier
(Parent
(P
));
20339 -- Check duplicate pragma before we chain the pragma in the Rep
20340 -- Item chain of Ent.
20343 (Ent
, Name_Task_Info
, Check_Parents
=> False)
20345 Error_Pragma
("duplicate pragma% not allowed");
20348 Record_Rep_Item
(Ent
, N
);
20355 -- pragma Task_Name (string_EXPRESSION);
20357 when Pragma_Task_Name
=> Task_Name
: declare
20358 P
: constant Node_Id
:= Parent
(N
);
20363 Check_No_Identifiers
;
20364 Check_Arg_Count
(1);
20366 Arg
:= Get_Pragma_Arg
(Arg1
);
20368 -- The expression is used in the call to Create_Task, and must be
20369 -- expanded there, not in the context of the current spec. It must
20370 -- however be analyzed to capture global references, in case it
20371 -- appears in a generic context.
20373 Preanalyze_And_Resolve
(Arg
, Standard_String
);
20375 if Nkind
(P
) /= N_Task_Definition
then
20379 Ent
:= Defining_Identifier
(Parent
(P
));
20381 -- Check duplicate pragma before we chain the pragma in the Rep
20382 -- Item chain of Ent.
20385 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20387 Error_Pragma
("duplicate pragma% not allowed");
20390 Record_Rep_Item
(Ent
, N
);
20397 -- pragma Task_Storage (
20398 -- [Task_Type =>] LOCAL_NAME,
20399 -- [Top_Guard =>] static_integer_EXPRESSION);
20401 when Pragma_Task_Storage
=> Task_Storage
: declare
20402 Args
: Args_List
(1 .. 2);
20403 Names
: constant Name_List
(1 .. 2) := (
20407 Task_Type
: Node_Id
renames Args
(1);
20408 Top_Guard
: Node_Id
renames Args
(2);
20414 Gather_Associations
(Names
, Args
);
20416 if No
(Task_Type
) then
20418 ("missing task_type argument for pragma%");
20421 Check_Arg_Is_Local_Name
(Task_Type
);
20423 Ent
:= Entity
(Task_Type
);
20425 if not Is_Task_Type
(Ent
) then
20427 ("argument for pragma% must be task type", Task_Type
);
20430 if No
(Top_Guard
) then
20432 ("pragma% takes two arguments", Task_Type
);
20434 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
20437 Check_First_Subtype
(Task_Type
);
20439 if Rep_Item_Too_Late
(Ent
, N
) then
20448 -- pragma Test_Case
20449 -- ([Name =>] Static_String_EXPRESSION
20450 -- ,[Mode =>] MODE_TYPE
20451 -- [, Requires => Boolean_EXPRESSION]
20452 -- [, Ensures => Boolean_EXPRESSION]);
20454 -- MODE_TYPE ::= Nominal | Robustness
20456 -- Characteristics:
20458 -- * Analysis - The annotation undergoes initial checks to verify
20459 -- the legal placement and context. Secondary checks preanalyze the
20462 -- Analyze_Test_Case_In_Decl_Part
20464 -- * Expansion - None.
20466 -- * Template - The annotation utilizes the generic template of the
20467 -- related subprogram when it is:
20469 -- aspect on subprogram declaration
20471 -- The annotation must prepare its own template when it is:
20473 -- pragma on subprogram declaration
20475 -- * Globals - Capture of global references must occur after full
20478 -- * Instance - The annotation is instantiated automatically when
20479 -- the related generic subprogram is instantiated except for the
20480 -- "pragma on subprogram declaration" case. In that scenario the
20481 -- annotation must instantiate itself.
20483 when Pragma_Test_Case
=> Test_Case
: declare
20484 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
20485 -- Ensure that the contract of subprogram Subp_Id does not contain
20486 -- another Test_Case pragma with the same Name as the current one.
20488 -------------------------
20489 -- Check_Distinct_Name --
20490 -------------------------
20492 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
20493 Items
: constant Node_Id
:= Contract
(Subp_Id
);
20494 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
20498 -- Inspect all Test_Case pragma of the related subprogram
20499 -- looking for one with a duplicate "Name" argument.
20501 if Present
(Items
) then
20502 Prag
:= Contract_Test_Cases
(Items
);
20503 while Present
(Prag
) loop
20504 if Pragma_Name
(Prag
) = Name_Test_Case
20505 and then String_Equal
20506 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
20508 Error_Msg_Sloc
:= Sloc
(Prag
);
20509 Error_Pragma
("name for pragma % is already used #");
20512 Prag
:= Next_Pragma
(Prag
);
20515 end Check_Distinct_Name
;
20519 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
20522 Subp_Decl
: Node_Id
;
20523 Subp_Id
: Entity_Id
;
20525 -- Start of processing for Test_Case
20529 Check_At_Least_N_Arguments
(2);
20530 Check_At_Most_N_Arguments
(4);
20532 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
20536 Check_Optional_Identifier
(Arg1
, Name_Name
);
20537 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20541 Check_Optional_Identifier
(Arg2
, Name_Mode
);
20542 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
20544 -- Arguments "Requires" and "Ensures"
20546 if Present
(Arg3
) then
20547 if Present
(Arg4
) then
20548 Check_Identifier
(Arg3
, Name_Requires
);
20549 Check_Identifier
(Arg4
, Name_Ensures
);
20551 Check_Identifier_Is_One_Of
20552 (Arg3
, Name_Requires
, Name_Ensures
);
20556 -- Pragma Test_Case must be associated with a subprogram declared
20557 -- in a library-level package. First determine whether the current
20558 -- compilation unit is a legal context.
20560 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
20561 N_Generic_Package_Declaration
)
20565 -- Otherwise the placement is illegal
20572 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
20574 -- Find the enclosing context
20576 Context
:= Parent
(Subp_Decl
);
20578 if Present
(Context
) then
20579 Context
:= Parent
(Context
);
20582 -- Verify the placement of the pragma
20584 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
20586 ("pragma % cannot be applied to abstract subprogram");
20589 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
20590 Error_Pragma
("pragma % cannot be applied to entry");
20593 -- The context is a [generic] subprogram declared at the top level
20594 -- of the [generic] package unit.
20596 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
20597 N_Subprogram_Declaration
)
20598 and then Present
(Context
)
20599 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
20600 N_Package_Declaration
)
20602 Subp_Id
:= Defining_Entity
(Subp_Decl
);
20604 -- Otherwise the placement is illegal
20611 -- Preanalyze the original aspect argument "Name" for ASIS or for
20612 -- a generic subprogram to properly capture global references.
20614 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
20615 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
20617 if Present
(Asp_Arg
) then
20619 -- The argument appears with an identifier in association
20622 if Nkind
(Asp_Arg
) = N_Component_Association
then
20623 Asp_Arg
:= Expression
(Asp_Arg
);
20626 Check_Expr_Is_OK_Static_Expression
20627 (Asp_Arg
, Standard_String
);
20631 -- Ensure that the all Test_Case pragmas of the related subprogram
20632 -- have distinct names.
20634 Check_Distinct_Name
(Subp_Id
);
20636 -- Fully analyze the pragma when it appears inside a subprogram
20637 -- body because it cannot benefit from forward references.
20639 if Nkind_In
(Subp_Decl
, N_Subprogram_Body
,
20640 N_Subprogram_Body_Stub
)
20642 Analyze_Test_Case_In_Decl_Part
(N
);
20645 -- Chain the pragma on the contract for further processing by
20646 -- Analyze_Test_Case_In_Decl_Part.
20648 Add_Contract_Item
(N
, Subp_Id
);
20651 --------------------------
20652 -- Thread_Local_Storage --
20653 --------------------------
20655 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20657 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20663 Check_Arg_Count
(1);
20664 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20665 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20667 Id
:= Get_Pragma_Arg
(Arg1
);
20670 if not Is_Entity_Name
(Id
)
20671 or else Ekind
(Entity
(Id
)) /= E_Variable
20673 Error_Pragma_Arg
("local variable name required", Arg1
);
20678 if Rep_Item_Too_Early
(E
, N
)
20679 or else Rep_Item_Too_Late
(E
, N
)
20684 Set_Has_Pragma_Thread_Local_Storage
(E
);
20685 Set_Has_Gigi_Rep_Item
(E
);
20686 end Thread_Local_Storage
;
20692 -- pragma Time_Slice (static_duration_EXPRESSION);
20694 when Pragma_Time_Slice
=> Time_Slice
: declare
20700 Check_Arg_Count
(1);
20701 Check_No_Identifiers
;
20702 Check_In_Main_Program
;
20703 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
20705 if not Error_Posted
(Arg1
) then
20707 while Present
(Nod
) loop
20708 if Nkind
(Nod
) = N_Pragma
20709 and then Pragma_Name
(Nod
) = Name_Time_Slice
20711 Error_Msg_Name_1
:= Pname
;
20712 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20719 -- Process only if in main unit
20721 if Get_Source_Unit
(Loc
) = Main_Unit
then
20722 Opt
.Time_Slice_Set
:= True;
20723 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20725 if Val
<= Ureal_0
then
20726 Opt
.Time_Slice_Value
:= 0;
20728 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20729 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20732 Opt
.Time_Slice_Value
:=
20733 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20742 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20744 -- TITLING_OPTION ::=
20745 -- [Title =>] STRING_LITERAL
20746 -- | [Subtitle =>] STRING_LITERAL
20748 when Pragma_Title
=> Title
: declare
20749 Args
: Args_List
(1 .. 2);
20750 Names
: constant Name_List
(1 .. 2) := (
20756 Gather_Associations
(Names
, Args
);
20759 for J
in 1 .. 2 loop
20760 if Present
(Args
(J
)) then
20761 Check_Arg_Is_OK_Static_Expression
20762 (Args
(J
), Standard_String
);
20767 ----------------------------
20768 -- Type_Invariant[_Class] --
20769 ----------------------------
20771 -- pragma Type_Invariant[_Class]
20772 -- ([Entity =>] type_LOCAL_NAME,
20773 -- [Check =>] EXPRESSION);
20775 when Pragma_Type_Invariant |
20776 Pragma_Type_Invariant_Class
=>
20777 Type_Invariant
: declare
20778 I_Pragma
: Node_Id
;
20781 Check_Arg_Count
(2);
20783 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20784 -- setting Class_Present for the Type_Invariant_Class case.
20786 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20787 I_Pragma
:= New_Copy
(N
);
20788 Set_Pragma_Identifier
20789 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20790 Rewrite
(N
, I_Pragma
);
20791 Set_Analyzed
(N
, False);
20793 end Type_Invariant
;
20795 ---------------------
20796 -- Unchecked_Union --
20797 ---------------------
20799 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20801 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20802 Assoc
: constant Node_Id
:= Arg1
;
20803 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20813 Check_No_Identifiers
;
20814 Check_Arg_Count
(1);
20815 Check_Arg_Is_Local_Name
(Arg1
);
20817 Find_Type
(Type_Id
);
20819 Typ
:= Entity
(Type_Id
);
20822 or else Rep_Item_Too_Early
(Typ
, N
)
20826 Typ
:= Underlying_Type
(Typ
);
20829 if Rep_Item_Too_Late
(Typ
, N
) then
20833 Check_First_Subtype
(Arg1
);
20835 -- Note remaining cases are references to a type in the current
20836 -- declarative part. If we find an error, we post the error on
20837 -- the relevant type declaration at an appropriate point.
20839 if not Is_Record_Type
(Typ
) then
20840 Error_Msg_N
("unchecked union must be record type", Typ
);
20843 elsif Is_Tagged_Type
(Typ
) then
20844 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20847 elsif not Has_Discriminants
(Typ
) then
20849 ("unchecked union must have one discriminant", Typ
);
20852 -- Note: in previous versions of GNAT we used to check for limited
20853 -- types and give an error, but in fact the standard does allow
20854 -- Unchecked_Union on limited types, so this check was removed.
20856 -- Similarly, GNAT used to require that all discriminants have
20857 -- default values, but this is not mandated by the RM.
20859 -- Proceed with basic error checks completed
20862 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20863 Clist
:= Component_List
(Tdef
);
20865 -- Check presence of component list and variant part
20867 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20869 ("unchecked union must have variant part", Tdef
);
20873 -- Check components
20875 Comp
:= First
(Component_Items
(Clist
));
20876 while Present
(Comp
) loop
20877 Check_Component
(Comp
, Typ
);
20881 -- Check variant part
20883 Vpart
:= Variant_Part
(Clist
);
20885 Variant
:= First
(Variants
(Vpart
));
20886 while Present
(Variant
) loop
20887 Check_Variant
(Variant
, Typ
);
20892 Set_Is_Unchecked_Union
(Typ
);
20893 Set_Convention
(Typ
, Convention_C
);
20894 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20895 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20896 end Unchecked_Union
;
20898 ------------------------
20899 -- Unimplemented_Unit --
20900 ------------------------
20902 -- pragma Unimplemented_Unit;
20904 -- Note: this only gives an error if we are generating code, or if
20905 -- we are in a generic library unit (where the pragma appears in the
20906 -- body, not in the spec).
20908 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20909 Cunitent
: constant Entity_Id
:=
20910 Cunit_Entity
(Get_Source_Unit
(Loc
));
20911 Ent_Kind
: constant Entity_Kind
:=
20916 Check_Arg_Count
(0);
20918 if Operating_Mode
= Generate_Code
20919 or else Ent_Kind
= E_Generic_Function
20920 or else Ent_Kind
= E_Generic_Procedure
20921 or else Ent_Kind
= E_Generic_Package
20923 Get_Name_String
(Chars
(Cunitent
));
20924 Set_Casing
(Mixed_Case
);
20925 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20926 Write_Str
(" is not supported in this configuration");
20928 raise Unrecoverable_Error
;
20930 end Unimplemented_Unit
;
20932 ------------------------
20933 -- Universal_Aliasing --
20934 ------------------------
20936 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20938 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20943 Check_Arg_Count
(1);
20944 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20945 Check_Arg_Is_Local_Name
(Arg1
);
20946 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20948 if E_Id
= Any_Type
then
20950 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20951 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20954 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20955 Record_Rep_Item
(E_Id
, N
);
20956 end Universal_Alias
;
20958 --------------------
20959 -- Universal_Data --
20960 --------------------
20962 -- pragma Universal_Data [(library_unit_NAME)];
20964 when Pragma_Universal_Data
=>
20967 -- If this is a configuration pragma, then set the universal
20968 -- addressing option, otherwise confirm that the pragma satisfies
20969 -- the requirements of library unit pragma placement and leave it
20970 -- to the GNAAMP back end to detect the pragma (avoids transitive
20971 -- setting of the option due to withed units).
20973 if Is_Configuration_Pragma
then
20974 Universal_Addressing_On_AAMP
:= True;
20976 Check_Valid_Library_Unit_Pragma
;
20979 if not AAMP_On_Target
then
20980 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
20987 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
20989 when Pragma_Unmodified
=> Unmodified
: declare
20990 Arg_Node
: Node_Id
;
20991 Arg_Expr
: Node_Id
;
20992 Arg_Ent
: Entity_Id
;
20996 Check_At_Least_N_Arguments
(1);
20998 -- Loop through arguments
21001 while Present
(Arg_Node
) loop
21002 Check_No_Identifier
(Arg_Node
);
21004 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
21005 -- in fact generate reference, so that the entity will have a
21006 -- reference, which will inhibit any warnings about it not
21007 -- being referenced, and also properly show up in the ali file
21008 -- as a reference. But this reference is recorded before the
21009 -- Has_Pragma_Unreferenced flag is set, so that no warning is
21010 -- generated for this reference.
21012 Check_Arg_Is_Local_Name
(Arg_Node
);
21013 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21015 if Is_Entity_Name
(Arg_Expr
) then
21016 Arg_Ent
:= Entity
(Arg_Expr
);
21018 if not Is_Assignable
(Arg_Ent
) then
21020 ("pragma% can only be applied to a variable",
21023 Set_Has_Pragma_Unmodified
(Arg_Ent
);
21035 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
21037 -- or when used in a context clause:
21039 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21041 when Pragma_Unreferenced
=> Unreferenced
: declare
21042 Arg_Node
: Node_Id
;
21043 Arg_Expr
: Node_Id
;
21044 Arg_Ent
: Entity_Id
;
21049 Check_At_Least_N_Arguments
(1);
21051 -- Check case of appearing within context clause
21053 if Is_In_Context_Clause
then
21055 -- The arguments must all be units mentioned in a with clause
21056 -- in the same context clause. Note we already checked (in
21057 -- Par.Prag) that the arguments are either identifiers or
21058 -- selected components.
21061 while Present
(Arg_Node
) loop
21062 Citem
:= First
(List_Containing
(N
));
21063 while Citem
/= N
loop
21064 if Nkind
(Citem
) = N_With_Clause
21066 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
21068 Set_Has_Pragma_Unreferenced
21071 (Library_Unit
(Citem
))));
21073 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
21082 ("argument of pragma% is not withed unit", Arg_Node
);
21088 -- Case of not in list of context items
21092 while Present
(Arg_Node
) loop
21093 Check_No_Identifier
(Arg_Node
);
21095 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21096 -- will in fact generate reference, so that the entity will
21097 -- have a reference, which will inhibit any warnings about
21098 -- it not being referenced, and also properly show up in the
21099 -- ali file as a reference. But this reference is recorded
21100 -- before the Has_Pragma_Unreferenced flag is set, so that
21101 -- no warning is generated for this reference.
21103 Check_Arg_Is_Local_Name
(Arg_Node
);
21104 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21106 if Is_Entity_Name
(Arg_Expr
) then
21107 Arg_Ent
:= Entity
(Arg_Expr
);
21109 -- If the entity is overloaded, the pragma applies to the
21110 -- most recent overloading, as documented. In this case,
21111 -- name resolution does not generate a reference, so it
21112 -- must be done here explicitly.
21114 if Is_Overloaded
(Arg_Expr
) then
21115 Generate_Reference
(Arg_Ent
, N
);
21118 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
21126 --------------------------
21127 -- Unreferenced_Objects --
21128 --------------------------
21130 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
21132 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
21133 Arg_Node
: Node_Id
;
21134 Arg_Expr
: Node_Id
;
21138 Check_At_Least_N_Arguments
(1);
21141 while Present
(Arg_Node
) loop
21142 Check_No_Identifier
(Arg_Node
);
21143 Check_Arg_Is_Local_Name
(Arg_Node
);
21144 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21146 if not Is_Entity_Name
(Arg_Expr
)
21147 or else not Is_Type
(Entity
(Arg_Expr
))
21150 ("argument for pragma% must be type or subtype", Arg_Node
);
21153 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
21156 end Unreferenced_Objects
;
21158 ------------------------------
21159 -- Unreserve_All_Interrupts --
21160 ------------------------------
21162 -- pragma Unreserve_All_Interrupts;
21164 when Pragma_Unreserve_All_Interrupts
=>
21166 Check_Arg_Count
(0);
21168 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
21169 Unreserve_All_Interrupts
:= True;
21176 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21178 when Pragma_Unsuppress
=>
21180 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
21182 ----------------------------
21183 -- Unevaluated_Use_Of_Old --
21184 ----------------------------
21186 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
21188 when Pragma_Unevaluated_Use_Of_Old
=>
21190 Check_Arg_Count
(1);
21191 Check_No_Identifiers
;
21192 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
21194 -- Suppress/Unsuppress can appear as a configuration pragma, or in
21195 -- a declarative part or a package spec.
21197 if not Is_Configuration_Pragma
then
21198 Check_Is_In_Decl_Part_Or_Package_Spec
;
21201 -- Store proper setting of Uneval_Old
21203 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21204 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
21206 -------------------
21207 -- Use_VADS_Size --
21208 -------------------
21210 -- pragma Use_VADS_Size;
21212 when Pragma_Use_VADS_Size
=>
21214 Check_Arg_Count
(0);
21215 Check_Valid_Configuration_Pragma
;
21216 Use_VADS_Size
:= True;
21218 ---------------------
21219 -- Validity_Checks --
21220 ---------------------
21222 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21224 when Pragma_Validity_Checks
=> Validity_Checks
: declare
21225 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21231 Check_Arg_Count
(1);
21232 Check_No_Identifiers
;
21234 -- Pragma always active unless in CodePeer or GNATprove modes,
21235 -- which use a fixed configuration of validity checks.
21237 if not (CodePeer_Mode
or GNATprove_Mode
) then
21238 if Nkind
(A
) = N_String_Literal
then
21242 Slen
: constant Natural := Natural (String_Length
(S
));
21243 Options
: String (1 .. Slen
);
21247 -- Couldn't we use a for loop here over Options'Range???
21251 C
:= Get_String_Char
(S
, Int
(J
));
21253 -- This is a weird test, it skips setting validity
21254 -- checks entirely if any element of S is out of
21255 -- range of Character, what is that about ???
21257 exit when not In_Character_Range
(C
);
21258 Options
(J
) := Get_Character
(C
);
21261 Set_Validity_Check_Options
(Options
);
21269 elsif Nkind
(A
) = N_Identifier
then
21270 if Chars
(A
) = Name_All_Checks
then
21271 Set_Validity_Check_Options
("a");
21272 elsif Chars
(A
) = Name_On
then
21273 Validity_Checks_On
:= True;
21274 elsif Chars
(A
) = Name_Off
then
21275 Validity_Checks_On
:= False;
21279 end Validity_Checks
;
21285 -- pragma Volatile (LOCAL_NAME);
21287 when Pragma_Volatile
=>
21288 Process_Atomic_Independent_Shared_Volatile
;
21290 --------------------------
21291 -- Volatile_Full_Access --
21292 --------------------------
21294 -- pragma Volatile_Full_Access (LOCAL_NAME);
21296 when Pragma_Volatile_Full_Access
=>
21298 Process_Atomic_Independent_Shared_Volatile
;
21300 -------------------------
21301 -- Volatile_Components --
21302 -------------------------
21304 -- pragma Volatile_Components (array_LOCAL_NAME);
21306 -- Volatile is handled by the same circuit as Atomic_Components
21308 ----------------------
21309 -- Warning_As_Error --
21310 ----------------------
21312 -- pragma Warning_As_Error (static_string_EXPRESSION);
21314 when Pragma_Warning_As_Error
=>
21316 Check_Arg_Count
(1);
21317 Check_No_Identifiers
;
21318 Check_Valid_Configuration_Pragma
;
21320 if not Is_Static_String_Expression
(Arg1
) then
21322 ("argument of pragma% must be static string expression",
21325 -- OK static string expression
21328 Acquire_Warning_Match_String
(Arg1
);
21329 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
21330 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
21331 new String'(Name_Buffer (1 .. Name_Len));
21338 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
21340 -- DETAILS ::= On | Off
21341 -- DETAILS ::= On | Off, local_NAME
21342 -- DETAILS ::= static_string_EXPRESSION
21343 -- DETAILS ::= On | Off, static_string_EXPRESSION
21345 -- TOOL_NAME ::= GNAT | GNATProve
21347 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
21349 -- Note: If the first argument matches an allowed tool name, it is
21350 -- always considered to be a tool name, even if there is a string
21351 -- variable of that name.
21353 -- Note if the second argument of DETAILS is a local_NAME then the
21354 -- second form is always understood. If the intention is to use
21355 -- the fourth form, then you can write NAME & "" to force the
21356 -- intepretation as a static_string_EXPRESSION.
21358 when Pragma_Warnings => Warnings : declare
21359 Reason : String_Id;
21363 Check_At_Least_N_Arguments (1);
21365 -- See if last argument is labeled Reason. If so, make sure we
21366 -- have a string literal or a concatenation of string literals,
21367 -- and acquire the REASON string. Then remove the REASON argument
21368 -- by decreasing Num_Args by one; Remaining processing looks only
21369 -- at first Num_Args arguments).
21372 Last_Arg : constant Node_Id :=
21373 Last (Pragma_Argument_Associations (N));
21376 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21377 and then Chars (Last_Arg) = Name_Reason
21380 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21381 Reason := End_String;
21382 Arg_Count := Arg_Count - 1;
21384 -- Not allowed in compiler units (bootstrap issues)
21386 Check_Compiler_Unit ("Reason for pragma Warnings", N);
21388 -- No REASON string, set null string as reason
21391 Reason := Null_String_Id;
21395 -- Now proceed with REASON taken care of and eliminated
21397 Check_No_Identifiers;
21399 -- If debug flag -gnatd.i is set, pragma is ignored
21401 if Debug_Flag_Dot_I then
21405 -- Process various forms of the pragma
21408 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21409 Shifted_Args : List_Id;
21412 -- See if first argument is a tool name, currently either
21413 -- GNAT or GNATprove. If so, either ignore the pragma if the
21414 -- tool used does not match, or continue as if no tool name
21415 -- was given otherwise, by shifting the arguments.
21417 if Nkind (Argx) = N_Identifier
21418 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
21420 if Chars (Argx) = Name_Gnat then
21421 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
21422 Rewrite (N, Make_Null_Statement (Loc));
21427 elsif Chars (Argx) = Name_Gnatprove then
21428 if not GNATprove_Mode then
21429 Rewrite (N, Make_Null_Statement (Loc));
21435 raise Program_Error;
21438 -- At this point, the pragma Warnings applies to the tool,
21439 -- so continue with shifted arguments.
21441 Arg_Count := Arg_Count - 1;
21443 if Arg_Count = 1 then
21444 Shifted_Args := New_List (New_Copy (Arg2));
21445 elsif Arg_Count = 2 then
21446 Shifted_Args := New_List (New_Copy (Arg2),
21448 elsif Arg_Count = 3 then
21449 Shifted_Args := New_List (New_Copy (Arg2),
21453 raise Program_Error;
21458 Chars => Name_Warnings,
21459 Pragma_Argument_Associations => Shifted_Args));
21464 -- One argument case
21466 if Arg_Count = 1 then
21468 -- On/Off one argument case was processed by parser
21470 if Nkind (Argx) = N_Identifier
21471 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21475 -- One argument case must be ON/OFF or static string expr
21477 elsif not Is_Static_String_Expression (Arg1) then
21479 ("argument of pragma% must be On/Off or static string "
21480 & "expression", Arg1);
21482 -- One argument string expression case
21486 Lit : constant Node_Id := Expr_Value_S (Argx);
21487 Str : constant String_Id := Strval (Lit);
21488 Len : constant Nat := String_Length (Str);
21496 while J <= Len loop
21497 C := Get_String_Char (Str, J);
21498 OK := In_Character_Range (C);
21501 Chr := Get_Character (C);
21503 -- Dash case: only -Wxxx is accepted
21510 C := Get_String_Char (Str, J);
21511 Chr := Get_Character (C);
21512 exit when Chr = 'W
';
21517 elsif J < Len and then Chr = '.' then
21519 C := Get_String_Char (Str, J);
21520 Chr := Get_Character (C);
21522 if not Set_Dot_Warning_Switch (Chr) then
21524 ("invalid warning switch character "
21525 & '.' & Chr, Arg1);
21531 OK := Set_Warning_Switch (Chr);
21537 ("invalid warning switch character " & Chr,
21546 -- Two or more arguments (must be two)
21549 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21550 Check_Arg_Count (2);
21558 E_Id := Get_Pragma_Arg (Arg2);
21561 -- In the expansion of an inlined body, a reference to
21562 -- the formal may be wrapped in a conversion if the
21563 -- actual is a conversion. Retrieve the real entity name.
21565 if (In_Instance_Body or In_Inlined_Body)
21566 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21568 E_Id := Expression (E_Id);
21571 -- Entity name case
21573 if Is_Entity_Name (E_Id) then
21574 E := Entity (E_Id);
21581 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21584 -- For OFF case, make entry in warnings off
21585 -- pragma table for later processing. But we do
21586 -- not do that within an instance, since these
21587 -- warnings are about what is needed in the
21588 -- template, not an instance of it.
21590 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21591 and then Warn_On_Warnings_Off
21592 and then not In_Instance
21594 Warnings_Off_Pragmas.Append ((N, E, Reason));
21597 if Is_Enumeration_Type (E) then
21601 Lit := First_Literal (E);
21602 while Present (Lit) loop
21603 Set_Warnings_Off (Lit);
21604 Next_Literal (Lit);
21609 exit when No (Homonym (E));
21614 -- Error if not entity or static string expression case
21616 elsif not Is_Static_String_Expression (Arg2) then
21618 ("second argument of pragma% must be entity name "
21619 & "or static string expression", Arg2);
21621 -- Static string expression case
21624 Acquire_Warning_Match_String (Arg2);
21626 -- Note on configuration pragma case: If this is a
21627 -- configuration pragma, then for an OFF pragma, we
21628 -- just set Config True in the call, which is all
21629 -- that needs to be done. For the case of ON, this
21630 -- is normally an error, unless it is canceling the
21631 -- effect of a previous OFF pragma in the same file.
21632 -- In any other case, an error will be signalled (ON
21633 -- with no matching OFF).
21635 -- Note: We set Used if we are inside a generic to
21636 -- disable the test that the non-config case actually
21637 -- cancels a warning. That's because we can't be sure
21638 -- there isn't an instantiation in some other unit
21639 -- where a warning is suppressed.
21641 -- We could do a little better here by checking if the
21642 -- generic unit we are inside is public, but for now
21643 -- we don't bother with that refinement.
21645 if Chars (Argx) = Name_Off then
21646 Set_Specific_Warning_Off
21647 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21648 Config => Is_Configuration_Pragma,
21649 Used => Inside_A_Generic or else In_Instance);
21651 elsif Chars (Argx) = Name_On then
21652 Set_Specific_Warning_On
21653 (Loc, Name_Buffer (1 .. Name_Len), Err);
21657 ("??pragma Warnings On with no matching "
21658 & "Warnings Off", Loc);
21667 -------------------
21668 -- Weak_External --
21669 -------------------
21671 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21673 when Pragma_Weak_External => Weak_External : declare
21678 Check_Arg_Count (1);
21679 Check_Optional_Identifier (Arg1, Name_Entity);
21680 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21681 Ent := Entity (Get_Pragma_Arg (Arg1));
21683 if Rep_Item_Too_Early (Ent, N) then
21686 Ent := Underlying_Type (Ent);
21689 -- The only processing required is to link this item on to the
21690 -- list of rep items for the given entity. This is accomplished
21691 -- by the call to Rep_Item_Too_Late (when no error is detected
21692 -- and False is returned).
21694 if Rep_Item_Too_Late (Ent, N) then
21697 Set_Has_Gigi_Rep_Item (Ent);
21701 -----------------------------
21702 -- Wide_Character_Encoding --
21703 -----------------------------
21705 -- pragma Wide_Character_Encoding (IDENTIFIER);
21707 when Pragma_Wide_Character_Encoding =>
21710 -- Nothing to do, handled in parser. Note that we do not enforce
21711 -- configuration pragma placement, this pragma can appear at any
21712 -- place in the source, allowing mixed encodings within a single
21717 --------------------
21718 -- Unknown_Pragma --
21719 --------------------
21721 -- Should be impossible, since the case of an unknown pragma is
21722 -- separately processed before the case statement is entered.
21724 when Unknown_Pragma =>
21725 raise Program_Error;
21728 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21729 -- until AI is formally approved.
21731 -- Check_Order_Dependence;
21734 when Pragma_Exit => null;
21735 end Analyze_Pragma;
21737 ---------------------------------------------
21738 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21739 ---------------------------------------------
21741 procedure Analyze_Pre_Post_Condition_In_Decl_Part (N : Node_Id) is
21742 procedure Process_Class_Wide_Condition
21744 Spec_Id : Entity_Id;
21745 Subp_Decl : Node_Id);
21746 -- Replace the type of all references to the controlling formal of
21747 -- subprogram Spec_Id found in expression Expr with the corresponding
21748 -- class-wide type. Subp_Decl is the subprogram [body] declaration
21749 -- where the pragma resides.
21751 ----------------------------------
21752 -- Process_Class_Wide_Condition --
21753 ----------------------------------
21755 procedure Process_Class_Wide_Condition
21757 Spec_Id : Entity_Id;
21758 Subp_Decl : Node_Id)
21760 Disp_Typ : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
21762 ACW : Entity_Id := Empty;
21763 -- Access to Disp_Typ'Class, created if there is a controlling formal
21764 -- that is an access parameter.
21766 function Access_Class_Wide_Type return Entity_Id;
21767 -- If expression Expr contains a reference to a controlling access
21768 -- parameter, create an access to Disp_Typ'Class for the necessary
21769 -- conversions if one does not exist.
21771 function Replace_Type (N : Node_Id) return Traverse_Result;
21772 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21773 -- aspect for a primitive subprogram of a tagged type Disp_Typ, a
21774 -- name that denotes a formal parameter of type Disp_Typ is treated
21775 -- as having type Disp_Typ'Class. Similarly, a name that denotes a
21776 -- formal access parameter of type access-to-Disp_Typ is interpreted
21777 -- as with type access-to-Disp_Typ'Class. This ensures the expression
21778 -- is well defined for a primitive subprogram of a type descended
21781 ----------------------------
21782 -- Access_Class_Wide_Type --
21783 ----------------------------
21785 function Access_Class_Wide_Type return Entity_Id is
21786 Loc : constant Source_Ptr := Sloc (N);
21790 ACW := Make_Temporary (Loc, 'T
');
21792 Insert_Before_And_Analyze (Subp_Decl,
21793 Make_Full_Type_Declaration (Loc,
21794 Defining_Identifier => ACW,
21796 Make_Access_To_Object_Definition (Loc,
21797 Subtype_Indication =>
21798 New_Occurrence_Of (Class_Wide_Type (Disp_Typ), Loc),
21799 All_Present => True)));
21801 Freeze_Before (Subp_Decl, ACW);
21805 end Access_Class_Wide_Type;
21811 function Replace_Type (N : Node_Id) return Traverse_Result is
21812 Context : constant Node_Id := Parent (N);
21813 Loc : constant Source_Ptr := Sloc (N);
21814 CW_Typ : Entity_Id := Empty;
21819 if Is_Entity_Name (N)
21820 and then Present (Entity (N))
21821 and then Is_Formal (Entity (N))
21824 Typ := Etype (Ent);
21826 -- Do not perform the type replacement for selector names in
21827 -- parameter associations. These carry an entity for reference
21828 -- purposes, but semantically they are just identifiers.
21830 if Nkind (Context) = N_Type_Conversion then
21833 elsif Nkind (Context) = N_Parameter_Association
21834 and then Selector_Name (Context) = N
21838 elsif Typ = Disp_Typ then
21839 CW_Typ := Class_Wide_Type (Typ);
21841 elsif Is_Access_Type (Typ)
21842 and then Designated_Type (Typ) = Disp_Typ
21844 CW_Typ := Access_Class_Wide_Type;
21847 if Present (CW_Typ) then
21849 Make_Type_Conversion (Loc,
21850 Subtype_Mark => New_Occurrence_Of (CW_Typ, Loc),
21851 Expression => New_Occurrence_Of (Ent, Loc)));
21852 Set_Etype (N, CW_Typ);
21859 procedure Replace_Types is new Traverse_Proc (Replace_Type);
21861 -- Start of processing for Process_Class_Wide_Condition
21864 -- The subprogram subject to Pre'Class/Post'Class does not have a
21865 -- dispatching type, therefore the aspect/pragma is illegal.
21867 if No (Disp_Typ) then
21868 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
21870 if From_Aspect_Specification (N) then
21872 ("aspect % can only be specified for a primitive operation "
21873 & "of a tagged type", Corresponding_Aspect (N));
21875 -- The pragma is a source construct
21879 ("pragma % can only be specified for a primitive operation "
21880 & "of a tagged type", N);
21884 Replace_Types (Expr);
21885 end Process_Class_Wide_Condition;
21889 Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
21890 Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl);
21891 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
21893 Restore_Scope : Boolean := False;
21895 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
21898 -- Ensure that the subprogram and its formals are visible when analyzing
21899 -- the expression of the pragma.
21901 if not In_Open_Scopes (Spec_Id) then
21902 Restore_Scope := True;
21903 Push_Scope (Spec_Id);
21905 if Is_Generic_Subprogram (Spec_Id) then
21906 Install_Generic_Formals (Spec_Id);
21908 Install_Formals (Spec_Id);
21912 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21914 -- For a class-wide condition, a reference to a controlling formal must
21915 -- be interpreted as having the class-wide type (or an access to such)
21916 -- so that the inherited condition can be properly applied to any
21917 -- overriding operation (see ARM12 6.6.1 (7)).
21919 if Class_Present (N) then
21920 Process_Class_Wide_Condition (Expr, Spec_Id, Subp_Decl);
21923 if Restore_Scope then
21927 -- Currently it is not possible to inline pre/postconditions on a
21928 -- subprogram subject to pragma Inline_Always.
21930 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
21931 end Analyze_Pre_Post_Condition_In_Decl_Part;
21933 ------------------------------------------
21934 -- Analyze_Refined_Depends_In_Decl_Part --
21935 ------------------------------------------
21937 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21938 Body_Inputs : Elist_Id := No_Elist;
21939 Body_Outputs : Elist_Id := No_Elist;
21940 -- The inputs and outputs of the subprogram body synthesized from pragma
21941 -- Refined_Depends.
21943 Dependencies : List_Id := No_List;
21945 -- The corresponding Depends pragma along with its clauses
21947 Matched_Items : Elist_Id := No_Elist;
21948 -- A list containing the entities of all successfully matched items
21949 -- found in pragma Depends.
21951 Refinements : List_Id := No_List;
21952 -- The clauses of pragma Refined_Depends
21954 Spec_Id : Entity_Id;
21955 -- The entity of the subprogram subject to pragma Refined_Depends
21957 Spec_Inputs : Elist_Id := No_Elist;
21958 Spec_Outputs : Elist_Id := No_Elist;
21959 -- The inputs and outputs of the subprogram spec synthesized from pragma
21962 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21963 -- Try to match a single dependency clause Dep_Clause against one or
21964 -- more refinement clauses found in list Refinements. Each successful
21965 -- match eliminates at least one refinement clause from Refinements.
21967 procedure Check_Output_States;
21968 -- Determine whether pragma Depends contains an output state with a
21969 -- visible refinement and if so, ensure that pragma Refined_Depends
21970 -- mentions all its constituents as outputs.
21972 procedure Normalize_Clauses (Clauses : List_Id);
21973 -- Given a list of dependence or refinement clauses Clauses, normalize
21974 -- each clause by creating multiple dependencies with exactly one input
21977 procedure Report_Extra_Clauses;
21978 -- Emit an error for each extra clause found in list Refinements
21980 -----------------------------
21981 -- Check_Dependency_Clause --
21982 -----------------------------
21984 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21985 Dep_Input : constant Node_Id := Expression (Dep_Clause);
21986 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21988 function Is_In_Out_State_Clause return Boolean;
21989 -- Determine whether dependence clause Dep_Clause denotes an abstract
21990 -- state that depends on itself (State => State).
21992 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
21993 -- Determine whether item Item denotes an abstract state with visible
21994 -- null refinement.
21996 procedure Match_Items
21997 (Dep_Item : Node_Id;
21998 Ref_Item : Node_Id;
21999 Matched : out Boolean);
22000 -- Try to match dependence item Dep_Item against refinement item
22001 -- Ref_Item. To match against a possible null refinement (see 2, 7),
22002 -- set Ref_Item to Empty. Flag Matched is set to True when one of
22003 -- the following conformance scenarios is in effect:
22004 -- 1) Both items denote null
22005 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
22006 -- 3) Both items denote attribute 'Result
22007 -- 4) Both items denote the same formal parameter
22008 -- 5) Both items denote the same object
22009 -- 6) Dep_Item is an abstract state with visible null refinement
22010 -- and Ref_Item denotes null.
22011 -- 7) Dep_Item is an abstract state with visible null refinement
22012 -- and Ref_Item is Empty (special case).
22013 -- 8) Dep_Item is an abstract state with visible non-null
22014 -- refinement and Ref_Item denotes one of its constituents.
22015 -- 9) Dep_Item is an abstract state without a visible refinement
22016 -- and Ref_Item denotes the same state.
22017 -- When scenario 8 is in effect, the entity of the abstract state
22018 -- denoted by Dep_Item is added to list Refined_States.
22020 procedure Record_Item
(Item_Id
: Entity_Id
);
22021 -- Store the entity of an item denoted by Item_Id in Matched_Items
22023 ----------------------------
22024 -- Is_In_Out_State_Clause --
22025 ----------------------------
22027 function Is_In_Out_State_Clause
return Boolean is
22028 Dep_Input_Id
: Entity_Id
;
22029 Dep_Output_Id
: Entity_Id
;
22032 -- Detect the following clause:
22035 if Is_Entity_Name
(Dep_Input
)
22036 and then Is_Entity_Name
(Dep_Output
)
22038 -- Handle abstract views generated for limited with clauses
22040 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
22041 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
22044 Ekind
(Dep_Input_Id
) = E_Abstract_State
22045 and then Dep_Input_Id
= Dep_Output_Id
;
22049 end Is_In_Out_State_Clause
;
22051 ---------------------------
22052 -- Is_Null_Refined_State --
22053 ---------------------------
22055 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
22056 Item_Id
: Entity_Id
;
22059 if Is_Entity_Name
(Item
) then
22061 -- Handle abstract views generated for limited with clauses
22063 Item_Id
:= Available_View
(Entity_Of
(Item
));
22065 return Ekind
(Item_Id
) = E_Abstract_State
22066 and then Has_Null_Refinement
(Item_Id
);
22071 end Is_Null_Refined_State
;
22077 procedure Match_Items
22078 (Dep_Item
: Node_Id
;
22079 Ref_Item
: Node_Id
;
22080 Matched
: out Boolean)
22082 Dep_Item_Id
: Entity_Id
;
22083 Ref_Item_Id
: Entity_Id
;
22086 -- Assume that the two items do not match
22090 -- A null matches null or Empty (special case)
22092 if Nkind
(Dep_Item
) = N_Null
22093 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
22097 -- Attribute 'Result matches attribute 'Result
22099 elsif Is_Attribute_Result
(Dep_Item
)
22100 and then Is_Attribute_Result
(Dep_Item
)
22104 -- Abstract states, formal parameters and objects
22106 elsif Is_Entity_Name
(Dep_Item
) then
22108 -- Handle abstract views generated for limited with clauses
22110 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
22112 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
22114 -- An abstract state with visible null refinement matches
22115 -- null or Empty (special case).
22117 if Has_Null_Refinement
(Dep_Item_Id
)
22118 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
22120 Record_Item
(Dep_Item_Id
);
22123 -- An abstract state with visible non-null refinement
22124 -- matches one of its constituents.
22126 elsif Has_Non_Null_Refinement
(Dep_Item_Id
) then
22127 if Is_Entity_Name
(Ref_Item
) then
22128 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
22130 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
22133 and then Present
(Encapsulating_State
(Ref_Item_Id
))
22134 and then Encapsulating_State
(Ref_Item_Id
) =
22137 Record_Item
(Dep_Item_Id
);
22142 -- An abstract state without a visible refinement matches
22145 elsif Is_Entity_Name
(Ref_Item
)
22146 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22148 Record_Item
(Dep_Item_Id
);
22152 -- A formal parameter or an object matches itself
22154 elsif Is_Entity_Name
(Ref_Item
)
22155 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22157 Record_Item
(Dep_Item_Id
);
22167 procedure Record_Item
(Item_Id
: Entity_Id
) is
22169 if not Contains
(Matched_Items
, Item_Id
) then
22170 Add_Item
(Item_Id
, Matched_Items
);
22176 Clause_Matched
: Boolean := False;
22177 Dummy
: Boolean := False;
22178 Inputs_Match
: Boolean;
22179 Next_Ref_Clause
: Node_Id
;
22180 Outputs_Match
: Boolean;
22181 Ref_Clause
: Node_Id
;
22182 Ref_Input
: Node_Id
;
22183 Ref_Output
: Node_Id
;
22185 -- Start of processing for Check_Dependency_Clause
22188 -- Do not perform this check in an instance because it was already
22189 -- performed successfully in the generic template.
22191 if Is_Generic_Instance
(Spec_Id
) then
22195 -- Examine all refinement clauses and compare them against the
22196 -- dependence clause.
22198 Ref_Clause
:= First
(Refinements
);
22199 while Present
(Ref_Clause
) loop
22200 Next_Ref_Clause
:= Next
(Ref_Clause
);
22202 -- Obtain the attributes of the current refinement clause
22204 Ref_Input
:= Expression
(Ref_Clause
);
22205 Ref_Output
:= First
(Choices
(Ref_Clause
));
22207 -- The current refinement clause matches the dependence clause
22208 -- when both outputs match and both inputs match. See routine
22209 -- Match_Items for all possible conformance scenarios.
22211 -- Depends Dep_Output => Dep_Input
22215 -- Refined_Depends Ref_Output => Ref_Input
22218 (Dep_Item
=> Dep_Input
,
22219 Ref_Item
=> Ref_Input
,
22220 Matched
=> Inputs_Match
);
22223 (Dep_Item
=> Dep_Output
,
22224 Ref_Item
=> Ref_Output
,
22225 Matched
=> Outputs_Match
);
22227 -- An In_Out state clause may be matched against a refinement with
22228 -- a null input or null output as long as the non-null side of the
22229 -- relation contains a valid constituent of the In_Out_State.
22231 if Is_In_Out_State_Clause
then
22233 -- Depends => (State => State)
22234 -- Refined_Depends => (null => Constit) -- OK
22237 and then not Outputs_Match
22238 and then Nkind
(Ref_Output
) = N_Null
22240 Outputs_Match
:= True;
22243 -- Depends => (State => State)
22244 -- Refined_Depends => (Constit => null) -- OK
22246 if not Inputs_Match
22247 and then Outputs_Match
22248 and then Nkind
(Ref_Input
) = N_Null
22250 Inputs_Match
:= True;
22254 -- The current refinement clause is legally constructed following
22255 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
22256 -- the pool of candidates. The seach continues because a single
22257 -- dependence clause may have multiple matching refinements.
22259 if Inputs_Match
and then Outputs_Match
then
22260 Clause_Matched
:= True;
22261 Remove
(Ref_Clause
);
22264 Ref_Clause
:= Next_Ref_Clause
;
22267 -- Depending on the order or composition of refinement clauses, an
22268 -- In_Out state clause may not be directly refinable.
22270 -- Depends => ((Output, State) => (Input, State))
22271 -- Refined_State => (State => (Constit_1, Constit_2))
22272 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
22274 -- Matching normalized clause (State => State) fails because there is
22275 -- no direct refinement capable of satisfying this relation. Another
22276 -- similar case arises when clauses (Constit_1 => Input) and (Output
22277 -- => Constit_2) are matched first, leaving no candidates for clause
22278 -- (State => State). Both scenarios are legal as long as one of the
22279 -- previous clauses mentioned a valid constituent of State.
22281 if not Clause_Matched
22282 and then Is_In_Out_State_Clause
22284 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22286 Clause_Matched
:= True;
22289 -- A clause where the input is an abstract state with visible null
22290 -- refinement is implicitly matched when the output has already been
22291 -- matched in a previous clause.
22293 -- Depends => (Output => State) -- implicitly OK
22294 -- Refined_State => (State => null)
22295 -- Refined_Depends => (Output => ...)
22297 if not Clause_Matched
22298 and then Is_Null_Refined_State
(Dep_Input
)
22299 and then Is_Entity_Name
(Dep_Output
)
22301 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
22303 Clause_Matched
:= True;
22306 -- A clause where the output is an abstract state with visible null
22307 -- refinement is implicitly matched when the input has already been
22308 -- matched in a previous clause.
22310 -- Depends => (State => Input) -- implicitly OK
22311 -- Refined_State => (State => null)
22312 -- Refined_Depends => (... => Input)
22314 if not Clause_Matched
22315 and then Is_Null_Refined_State
(Dep_Output
)
22316 and then Is_Entity_Name
(Dep_Input
)
22318 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22320 Clause_Matched
:= True;
22323 -- At this point either all refinement clauses have been examined or
22324 -- pragma Refined_Depends contains a solitary null. Only an abstract
22325 -- state with null refinement can possibly match these cases.
22327 -- Depends => (State => null)
22328 -- Refined_State => (State => null)
22329 -- Refined_Depends => null -- OK
22331 if not Clause_Matched
then
22333 (Dep_Item
=> Dep_Input
,
22335 Matched
=> Inputs_Match
);
22338 (Dep_Item
=> Dep_Output
,
22340 Matched
=> Outputs_Match
);
22342 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
22345 -- If the contents of Refined_Depends are legal, then the current
22346 -- dependence clause should be satisfied either by an explicit match
22347 -- or by one of the special cases.
22349 if not Clause_Matched
then
22351 ("dependence clause of subprogram & has no matching refinement "
22352 & "in body", Dep_Clause
, Spec_Id
);
22354 end Check_Dependency_Clause
;
22356 -------------------------
22357 -- Check_Output_States --
22358 -------------------------
22360 procedure Check_Output_States
is
22361 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22362 -- Determine whether all constituents of state State_Id with visible
22363 -- refinement are used as outputs in pragma Refined_Depends. Emit an
22364 -- error if this is not the case.
22366 -----------------------------
22367 -- Check_Constituent_Usage --
22368 -----------------------------
22370 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22371 Constit_Elmt
: Elmt_Id
;
22372 Constit_Id
: Entity_Id
;
22373 Posted
: Boolean := False;
22376 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22377 while Present
(Constit_Elmt
) loop
22378 Constit_Id
:= Node
(Constit_Elmt
);
22380 -- The constituent acts as an input (SPARK RM 7.2.5(3))
22382 if Present
(Body_Inputs
)
22383 and then Appears_In
(Body_Inputs
, Constit_Id
)
22385 Error_Msg_Name_1
:= Chars
(State_Id
);
22387 ("constituent & of state % must act as output in "
22388 & "dependence refinement", N
, Constit_Id
);
22390 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22392 elsif No
(Body_Outputs
)
22393 or else not Appears_In
(Body_Outputs
, Constit_Id
)
22398 ("output state & must be replaced by all its "
22399 & "constituents in dependence refinement",
22404 ("\constituent & is missing in output list",
22408 Next_Elmt
(Constit_Elmt
);
22410 end Check_Constituent_Usage
;
22415 Item_Elmt
: Elmt_Id
;
22416 Item_Id
: Entity_Id
;
22418 -- Start of processing for Check_Output_States
22421 -- Do not perform this check in an instance because it was already
22422 -- performed successfully in the generic template.
22424 if Is_Generic_Instance
(Spec_Id
) then
22427 -- Inspect the outputs of pragma Depends looking for a state with a
22428 -- visible refinement.
22430 elsif Present
(Spec_Outputs
) then
22431 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
22432 while Present
(Item_Elmt
) loop
22433 Item
:= Node
(Item_Elmt
);
22435 -- Deal with the mixed nature of the input and output lists
22437 if Nkind
(Item
) = N_Defining_Identifier
then
22440 Item_Id
:= Available_View
(Entity_Of
(Item
));
22443 if Ekind
(Item_Id
) = E_Abstract_State
then
22445 -- The state acts as an input-output, skip it
22447 if Present
(Spec_Inputs
)
22448 and then Appears_In
(Spec_Inputs
, Item_Id
)
22452 -- Ensure that all of the constituents are utilized as
22453 -- outputs in pragma Refined_Depends.
22455 elsif Has_Non_Null_Refinement
(Item_Id
) then
22456 Check_Constituent_Usage
(Item_Id
);
22460 Next_Elmt
(Item_Elmt
);
22463 end Check_Output_States
;
22465 -----------------------
22466 -- Normalize_Clauses --
22467 -----------------------
22469 procedure Normalize_Clauses
(Clauses
: List_Id
) is
22470 procedure Normalize_Inputs
(Clause
: Node_Id
);
22471 -- Normalize clause Clause by creating multiple clauses for each
22472 -- input item of Clause. It is assumed that Clause has exactly one
22473 -- output. The transformation is as follows:
22475 -- Output => (Input_1, Input_2) -- original
22477 -- Output => Input_1 -- normalizations
22478 -- Output => Input_2
22480 procedure Normalize_Outputs
(Clause
: Node_Id
);
22481 -- Normalize clause Clause by creating multiple clause for each
22482 -- output item of Clause. The transformation is as follows:
22484 -- (Output_1, Output_2) => Input -- original
22486 -- Output_1 => Input -- normalization
22487 -- Output_2 => Input
22489 ----------------------
22490 -- Normalize_Inputs --
22491 ----------------------
22493 procedure Normalize_Inputs
(Clause
: Node_Id
) is
22494 Inputs
: constant Node_Id
:= Expression
(Clause
);
22495 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22496 Output
: constant List_Id
:= Choices
(Clause
);
22497 Last_Input
: Node_Id
;
22499 New_Clause
: Node_Id
;
22500 Next_Input
: Node_Id
;
22503 -- Normalization is performed only when the original clause has
22504 -- more than one input. Multiple inputs appear as an aggregate.
22506 if Nkind
(Inputs
) = N_Aggregate
then
22507 Last_Input
:= Last
(Expressions
(Inputs
));
22509 -- Create a new clause for each input
22511 Input
:= First
(Expressions
(Inputs
));
22512 while Present
(Input
) loop
22513 Next_Input
:= Next
(Input
);
22515 -- Unhook the current input from the original input list
22516 -- because it will be relocated to a new clause.
22520 -- Special processing for the last input. At this point the
22521 -- original aggregate has been stripped down to one element.
22522 -- Replace the aggregate by the element itself.
22524 if Input
= Last_Input
then
22525 Rewrite
(Inputs
, Input
);
22527 -- Generate a clause of the form:
22532 Make_Component_Association
(Loc
,
22533 Choices
=> New_Copy_List_Tree
(Output
),
22534 Expression
=> Input
);
22536 -- The new clause contains replicated content that has
22537 -- already been analyzed, mark the clause as analyzed.
22539 Set_Analyzed
(New_Clause
);
22540 Insert_After
(Clause
, New_Clause
);
22543 Input
:= Next_Input
;
22546 end Normalize_Inputs
;
22548 -----------------------
22549 -- Normalize_Outputs --
22550 -----------------------
22552 procedure Normalize_Outputs
(Clause
: Node_Id
) is
22553 Inputs
: constant Node_Id
:= Expression
(Clause
);
22554 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22555 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
22556 Last_Output
: Node_Id
;
22557 New_Clause
: Node_Id
;
22558 Next_Output
: Node_Id
;
22562 -- Multiple outputs appear as an aggregate. Nothing to do when
22563 -- the clause has exactly one output.
22565 if Nkind
(Outputs
) = N_Aggregate
then
22566 Last_Output
:= Last
(Expressions
(Outputs
));
22568 -- Create a clause for each output. Note that each time a new
22569 -- clause is created, the original output list slowly shrinks
22570 -- until there is one item left.
22572 Output
:= First
(Expressions
(Outputs
));
22573 while Present
(Output
) loop
22574 Next_Output
:= Next
(Output
);
22576 -- Unhook the output from the original output list as it
22577 -- will be relocated to a new clause.
22581 -- Special processing for the last output. At this point
22582 -- the original aggregate has been stripped down to one
22583 -- element. Replace the aggregate by the element itself.
22585 if Output
= Last_Output
then
22586 Rewrite
(Outputs
, Output
);
22589 -- Generate a clause of the form:
22590 -- (Output => Inputs)
22593 Make_Component_Association
(Loc
,
22594 Choices
=> New_List
(Output
),
22595 Expression
=> New_Copy_Tree
(Inputs
));
22597 -- The new clause contains replicated content that has
22598 -- already been analyzed. There is not need to reanalyze
22601 Set_Analyzed
(New_Clause
);
22602 Insert_After
(Clause
, New_Clause
);
22605 Output
:= Next_Output
;
22608 end Normalize_Outputs
;
22614 -- Start of processing for Normalize_Clauses
22617 Clause
:= First
(Clauses
);
22618 while Present
(Clause
) loop
22619 Normalize_Outputs
(Clause
);
22623 Clause
:= First
(Clauses
);
22624 while Present
(Clause
) loop
22625 Normalize_Inputs
(Clause
);
22628 end Normalize_Clauses
;
22630 --------------------------
22631 -- Report_Extra_Clauses --
22632 --------------------------
22634 procedure Report_Extra_Clauses
is
22638 -- Do not perform this check in an instance because it was already
22639 -- performed successfully in the generic template.
22641 if Is_Generic_Instance
(Spec_Id
) then
22644 elsif Present
(Refinements
) then
22645 Clause
:= First
(Refinements
);
22646 while Present
(Clause
) loop
22648 -- Do not complain about a null input refinement, since a null
22649 -- input legitimately matches anything.
22651 if Nkind
(Clause
) = N_Component_Association
22652 and then Nkind
(Expression
(Clause
)) = N_Null
22658 ("unmatched or extra clause in dependence refinement",
22665 end Report_Extra_Clauses
;
22669 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22670 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
22671 Errors
: constant Nat
:= Serious_Errors_Detected
;
22677 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22680 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22681 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22683 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22686 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
22688 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22689 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22691 if No
(Depends
) then
22693 ("useless refinement, declaration of subprogram & lacks aspect or "
22694 & "pragma Depends", N
, Spec_Id
);
22698 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
22700 -- A null dependency relation renders the refinement useless because it
22701 -- cannot possibly mention abstract states with visible refinement. Note
22702 -- that the inverse is not true as states may be refined to null
22703 -- (SPARK RM 7.2.5(2)).
22705 if Nkind
(Deps
) = N_Null
then
22707 ("useless refinement, subprogram & does not depend on abstract "
22708 & "state with visible refinement", N
, Spec_Id
);
22712 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22713 -- This ensures that the categorization of all refined dependency items
22714 -- is consistent with their role.
22716 Analyze_Depends_In_Decl_Part
(N
);
22718 -- Do not match dependencies against refinements if Refined_Depends is
22719 -- illegal to avoid emitting misleading error.
22721 if Serious_Errors_Detected
= Errors
then
22723 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
22724 -- the inputs and outputs of the subprogram spec and body to verify
22725 -- the use of states with visible refinement and their constituents.
22727 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
22728 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
22730 Collect_Subprogram_Inputs_Outputs
22731 (Subp_Id
=> Spec_Id
,
22732 Synthesize
=> True,
22733 Subp_Inputs
=> Spec_Inputs
,
22734 Subp_Outputs
=> Spec_Outputs
,
22735 Global_Seen
=> Dummy
);
22737 Collect_Subprogram_Inputs_Outputs
22738 (Subp_Id
=> Body_Id
,
22739 Synthesize
=> True,
22740 Subp_Inputs
=> Body_Inputs
,
22741 Subp_Outputs
=> Body_Outputs
,
22742 Global_Seen
=> Dummy
);
22744 -- For an output state with a visible refinement, ensure that all
22745 -- constituents appear as outputs in the dependency refinement.
22747 Check_Output_States
;
22750 -- Matching is disabled in ASIS because clauses are not normalized as
22751 -- this is a tree altering activity similar to expansion.
22757 -- Multiple dependency clauses appear as component associations of an
22758 -- aggregate. Note that the clauses are copied because the algorithm
22759 -- modifies them and this should not be visible in Depends.
22761 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
22762 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
22763 Normalize_Clauses
(Dependencies
);
22765 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
22767 if Nkind
(Refs
) = N_Null
then
22768 Refinements
:= No_List
;
22770 -- Multiple dependency clauses appear as component associations of an
22771 -- aggregate. Note that the clauses are copied because the algorithm
22772 -- modifies them and this should not be visible in Refined_Depends.
22774 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
22775 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
22776 Normalize_Clauses
(Refinements
);
22779 -- At this point the clauses of pragmas Depends and Refined_Depends
22780 -- have been normalized into simple dependencies between one output
22781 -- and one input. Examine all clauses of pragma Depends looking for
22782 -- matching clauses in pragma Refined_Depends.
22784 Clause
:= First
(Dependencies
);
22785 while Present
(Clause
) loop
22786 Check_Dependency_Clause
(Clause
);
22790 if Serious_Errors_Detected
= Errors
then
22791 Report_Extra_Clauses
;
22794 end Analyze_Refined_Depends_In_Decl_Part
;
22796 -----------------------------------------
22797 -- Analyze_Refined_Global_In_Decl_Part --
22798 -----------------------------------------
22800 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
22802 -- The corresponding Global pragma
22804 Has_In_State
: Boolean := False;
22805 Has_In_Out_State
: Boolean := False;
22806 Has_Out_State
: Boolean := False;
22807 Has_Proof_In_State
: Boolean := False;
22808 -- These flags are set when the corresponding Global pragma has a state
22809 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22812 Has_Null_State
: Boolean := False;
22813 -- This flag is set when the corresponding Global pragma has at least
22814 -- one state with a null refinement.
22816 In_Constits
: Elist_Id
:= No_Elist
;
22817 In_Out_Constits
: Elist_Id
:= No_Elist
;
22818 Out_Constits
: Elist_Id
:= No_Elist
;
22819 Proof_In_Constits
: Elist_Id
:= No_Elist
;
22820 -- These lists contain the entities of all Input, In_Out, Output and
22821 -- Proof_In constituents that appear in Refined_Global and participate
22822 -- in state refinement.
22824 In_Items
: Elist_Id
:= No_Elist
;
22825 In_Out_Items
: Elist_Id
:= No_Elist
;
22826 Out_Items
: Elist_Id
:= No_Elist
;
22827 Proof_In_Items
: Elist_Id
:= No_Elist
;
22828 -- These list contain the entities of all Input, In_Out, Output and
22829 -- Proof_In items defined in the corresponding Global pragma.
22831 Spec_Id
: Entity_Id
;
22832 -- The entity of the subprogram subject to pragma Refined_Global
22834 procedure Check_In_Out_States
;
22835 -- Determine whether the corresponding Global pragma mentions In_Out
22836 -- states with visible refinement and if so, ensure that one of the
22837 -- following completions apply to the constituents of the state:
22838 -- 1) there is at least one constituent of mode In_Out
22839 -- 2) there is at least one Input and one Output constituent
22840 -- 3) not all constituents are present and one of them is of mode
22842 -- This routine may remove elements from In_Constits, In_Out_Constits,
22843 -- Out_Constits and Proof_In_Constits.
22845 procedure Check_Input_States
;
22846 -- Determine whether the corresponding Global pragma mentions Input
22847 -- states with visible refinement and if so, ensure that at least one of
22848 -- its constituents appears as an Input item in Refined_Global.
22849 -- This routine may remove elements from In_Constits, In_Out_Constits,
22850 -- Out_Constits and Proof_In_Constits.
22852 procedure Check_Output_States
;
22853 -- Determine whether the corresponding Global pragma mentions Output
22854 -- states with visible refinement and if so, ensure that all of its
22855 -- constituents appear as Output items in Refined_Global.
22856 -- This routine may remove elements from In_Constits, In_Out_Constits,
22857 -- Out_Constits and Proof_In_Constits.
22859 procedure Check_Proof_In_States
;
22860 -- Determine whether the corresponding Global pragma mentions Proof_In
22861 -- states with visible refinement and if so, ensure that at least one of
22862 -- its constituents appears as a Proof_In item in Refined_Global.
22863 -- This routine may remove elements from In_Constits, In_Out_Constits,
22864 -- Out_Constits and Proof_In_Constits.
22866 procedure Check_Refined_Global_List
22868 Global_Mode
: Name_Id
:= Name_Input
);
22869 -- Verify the legality of a single global list declaration. Global_Mode
22870 -- denotes the current mode in effect.
22872 procedure Collect_Global_Items
22874 Mode
: Name_Id
:= Name_Input
);
22875 -- Gather all input, in out, output and Proof_In items from node List
22876 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
22877 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
22878 -- and Has_Proof_In_State are set when there is at least one abstract
22879 -- state with visible refinement available in the corresponding mode.
22880 -- Flag Has_Null_State is set when at least state has a null refinement.
22881 -- Mode enotes the current global mode in effect.
22883 function Present_Then_Remove
22885 Item
: Entity_Id
) return Boolean;
22886 -- Search List for a particular entity Item. If Item has been found,
22887 -- remove it from List. This routine is used to strip lists In_Constits,
22888 -- In_Out_Constits and Out_Constits of valid constituents.
22890 procedure Report_Extra_Constituents
;
22891 -- Emit an error for each constituent found in lists In_Constits,
22892 -- In_Out_Constits and Out_Constits.
22894 -------------------------
22895 -- Check_In_Out_States --
22896 -------------------------
22898 procedure Check_In_Out_States
is
22899 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22900 -- Determine whether one of the following coverage scenarios is in
22902 -- 1) there is at least one constituent of mode In_Out
22903 -- 2) there is at least one Input and one Output constituent
22904 -- 3) not all constituents are present and one of them is of mode
22906 -- If this is not the case, emit an error.
22908 -----------------------------
22909 -- Check_Constituent_Usage --
22910 -----------------------------
22912 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22913 Constit_Elmt
: Elmt_Id
;
22914 Constit_Id
: Entity_Id
;
22915 Has_Missing
: Boolean := False;
22916 In_Out_Seen
: Boolean := False;
22917 In_Seen
: Boolean := False;
22918 Out_Seen
: Boolean := False;
22921 -- Process all the constituents of the state and note their modes
22922 -- within the global refinement.
22924 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22925 while Present
(Constit_Elmt
) loop
22926 Constit_Id
:= Node
(Constit_Elmt
);
22928 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22931 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22932 In_Out_Seen
:= True;
22934 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22937 -- A Proof_In constituent cannot participate in the completion
22938 -- of an Output state (SPARK RM 7.2.4(5)).
22940 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22941 Error_Msg_Name_1
:= Chars
(State_Id
);
22943 ("constituent & of state % must have mode Input, In_Out "
22944 & "or Output in global refinement", N
, Constit_Id
);
22947 Has_Missing
:= True;
22950 Next_Elmt
(Constit_Elmt
);
22953 -- A single In_Out constituent is a valid completion
22955 if In_Out_Seen
then
22958 -- A pair of one Input and one Output constituent is a valid
22961 elsif In_Seen
and then Out_Seen
then
22964 -- A single Output constituent is a valid completion only when
22965 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22967 elsif Has_Missing
and then Out_Seen
then
22972 ("global refinement of state & redefines the mode of its "
22973 & "constituents", N
, State_Id
);
22975 end Check_Constituent_Usage
;
22979 Item_Elmt
: Elmt_Id
;
22980 Item_Id
: Entity_Id
;
22982 -- Start of processing for Check_In_Out_States
22985 -- Do not perform this check in an instance because it was already
22986 -- performed successfully in the generic template.
22988 if Is_Generic_Instance
(Spec_Id
) then
22991 -- Inspect the In_Out items of the corresponding Global pragma
22992 -- looking for a state with a visible refinement.
22994 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
22995 Item_Elmt
:= First_Elmt
(In_Out_Items
);
22996 while Present
(Item_Elmt
) loop
22997 Item_Id
:= Node
(Item_Elmt
);
22999 -- Ensure that one of the three coverage variants is satisfied
23001 if Ekind
(Item_Id
) = E_Abstract_State
23002 and then Has_Non_Null_Refinement
(Item_Id
)
23004 Check_Constituent_Usage
(Item_Id
);
23007 Next_Elmt
(Item_Elmt
);
23010 end Check_In_Out_States
;
23012 ------------------------
23013 -- Check_Input_States --
23014 ------------------------
23016 procedure Check_Input_States
is
23017 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23018 -- Determine whether at least one constituent of state State_Id with
23019 -- visible refinement is used and has mode Input. Ensure that the
23020 -- remaining constituents do not have In_Out, Output or Proof_In
23023 -----------------------------
23024 -- Check_Constituent_Usage --
23025 -----------------------------
23027 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23028 Constit_Elmt
: Elmt_Id
;
23029 Constit_Id
: Entity_Id
;
23030 In_Seen
: Boolean := False;
23033 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23034 while Present
(Constit_Elmt
) loop
23035 Constit_Id
:= Node
(Constit_Elmt
);
23037 -- At least one of the constituents appears as an Input
23039 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
23042 -- The constituent appears in the global refinement, but has
23043 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
23045 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23046 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
23047 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
23049 Error_Msg_Name_1
:= Chars
(State_Id
);
23051 ("constituent & of state % must have mode Input in global "
23052 & "refinement", N
, Constit_Id
);
23055 Next_Elmt
(Constit_Elmt
);
23058 -- Not one of the constituents appeared as Input
23060 if not In_Seen
then
23062 ("global refinement of state & must include at least one "
23063 & "constituent of mode Input", N
, State_Id
);
23065 end Check_Constituent_Usage
;
23069 Item_Elmt
: Elmt_Id
;
23070 Item_Id
: Entity_Id
;
23072 -- Start of processing for Check_Input_States
23075 -- Do not perform this check in an instance because it was already
23076 -- performed successfully in the generic template.
23078 if Is_Generic_Instance
(Spec_Id
) then
23081 -- Inspect the Input items of the corresponding Global pragma looking
23082 -- for a state with a visible refinement.
23084 elsif Has_In_State
and then Present
(In_Items
) then
23085 Item_Elmt
:= First_Elmt
(In_Items
);
23086 while Present
(Item_Elmt
) loop
23087 Item_Id
:= Node
(Item_Elmt
);
23089 -- Ensure that at least one of the constituents is utilized and
23090 -- is of mode Input.
23092 if Ekind
(Item_Id
) = E_Abstract_State
23093 and then Has_Non_Null_Refinement
(Item_Id
)
23095 Check_Constituent_Usage
(Item_Id
);
23098 Next_Elmt
(Item_Elmt
);
23101 end Check_Input_States
;
23103 -------------------------
23104 -- Check_Output_States --
23105 -------------------------
23107 procedure Check_Output_States
is
23108 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23109 -- Determine whether all constituents of state State_Id with visible
23110 -- refinement are used and have mode Output. Emit an error if this is
23113 -----------------------------
23114 -- Check_Constituent_Usage --
23115 -----------------------------
23117 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23118 Constit_Elmt
: Elmt_Id
;
23119 Constit_Id
: Entity_Id
;
23120 Posted
: Boolean := False;
23123 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23124 while Present
(Constit_Elmt
) loop
23125 Constit_Id
:= Node
(Constit_Elmt
);
23127 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
23130 -- The constituent appears in the global refinement, but has
23131 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
23133 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23134 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23135 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
23137 Error_Msg_Name_1
:= Chars
(State_Id
);
23139 ("constituent & of state % must have mode Output in "
23140 & "global refinement", N
, Constit_Id
);
23142 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23148 ("output state & must be replaced by all its "
23149 & "constituents in global refinement", N
, State_Id
);
23153 ("\constituent & is missing in output list",
23157 Next_Elmt
(Constit_Elmt
);
23159 end Check_Constituent_Usage
;
23163 Item_Elmt
: Elmt_Id
;
23164 Item_Id
: Entity_Id
;
23166 -- Start of processing for Check_Output_States
23169 -- Do not perform this check in an instance because it was already
23170 -- performed successfully in the generic template.
23172 if Is_Generic_Instance
(Spec_Id
) then
23175 -- Inspect the Output items of the corresponding Global pragma
23176 -- looking for a state with a visible refinement.
23178 elsif Has_Out_State
and then Present
(Out_Items
) then
23179 Item_Elmt
:= First_Elmt
(Out_Items
);
23180 while Present
(Item_Elmt
) loop
23181 Item_Id
:= Node
(Item_Elmt
);
23183 -- Ensure that all of the constituents are utilized and they
23184 -- have mode Output.
23186 if Ekind
(Item_Id
) = E_Abstract_State
23187 and then Has_Non_Null_Refinement
(Item_Id
)
23189 Check_Constituent_Usage
(Item_Id
);
23192 Next_Elmt
(Item_Elmt
);
23195 end Check_Output_States
;
23197 ---------------------------
23198 -- Check_Proof_In_States --
23199 ---------------------------
23201 procedure Check_Proof_In_States
is
23202 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23203 -- Determine whether at least one constituent of state State_Id with
23204 -- visible refinement is used and has mode Proof_In. Ensure that the
23205 -- remaining constituents do not have Input, In_Out or Output modes.
23207 -----------------------------
23208 -- Check_Constituent_Usage --
23209 -----------------------------
23211 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23212 Constit_Elmt
: Elmt_Id
;
23213 Constit_Id
: Entity_Id
;
23214 Proof_In_Seen
: Boolean := False;
23217 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23218 while Present
(Constit_Elmt
) loop
23219 Constit_Id
:= Node
(Constit_Elmt
);
23221 -- At least one of the constituents appears as Proof_In
23223 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
23224 Proof_In_Seen
:= True;
23226 -- The constituent appears in the global refinement, but has
23227 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
23229 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23230 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23231 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
23233 Error_Msg_Name_1
:= Chars
(State_Id
);
23235 ("constituent & of state % must have mode Proof_In in "
23236 & "global refinement", N
, Constit_Id
);
23239 Next_Elmt
(Constit_Elmt
);
23242 -- Not one of the constituents appeared as Proof_In
23244 if not Proof_In_Seen
then
23246 ("global refinement of state & must include at least one "
23247 & "constituent of mode Proof_In", N
, State_Id
);
23249 end Check_Constituent_Usage
;
23253 Item_Elmt
: Elmt_Id
;
23254 Item_Id
: Entity_Id
;
23256 -- Start of processing for Check_Proof_In_States
23259 -- Do not perform this check in an instance because it was already
23260 -- performed successfully in the generic template.
23262 if Is_Generic_Instance
(Spec_Id
) then
23265 -- Inspect the Proof_In items of the corresponding Global pragma
23266 -- looking for a state with a visible refinement.
23268 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
23269 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
23270 while Present
(Item_Elmt
) loop
23271 Item_Id
:= Node
(Item_Elmt
);
23273 -- Ensure that at least one of the constituents is utilized and
23274 -- is of mode Proof_In
23276 if Ekind
(Item_Id
) = E_Abstract_State
23277 and then Has_Non_Null_Refinement
(Item_Id
)
23279 Check_Constituent_Usage
(Item_Id
);
23282 Next_Elmt
(Item_Elmt
);
23285 end Check_Proof_In_States
;
23287 -------------------------------
23288 -- Check_Refined_Global_List --
23289 -------------------------------
23291 procedure Check_Refined_Global_List
23293 Global_Mode
: Name_Id
:= Name_Input
)
23295 procedure Check_Refined_Global_Item
23297 Global_Mode
: Name_Id
);
23298 -- Verify the legality of a single global item declaration. Parameter
23299 -- Global_Mode denotes the current mode in effect.
23301 -------------------------------
23302 -- Check_Refined_Global_Item --
23303 -------------------------------
23305 procedure Check_Refined_Global_Item
23307 Global_Mode
: Name_Id
)
23309 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
23311 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
23312 -- Issue a common error message for all mode mismatches. Expect
23313 -- denotes the expected mode.
23315 -----------------------------
23316 -- Inconsistent_Mode_Error --
23317 -----------------------------
23319 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
23322 ("global item & has inconsistent modes", Item
, Item_Id
);
23324 Error_Msg_Name_1
:= Global_Mode
;
23325 Error_Msg_Name_2
:= Expect
;
23326 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
23327 end Inconsistent_Mode_Error
;
23329 -- Start of processing for Check_Refined_Global_Item
23332 -- When the state or object acts as a constituent of another
23333 -- state with a visible refinement, collect it for the state
23334 -- completeness checks performed later on.
23336 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
23337 and then Present
(Encapsulating_State
(Item_Id
))
23338 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
23340 if Global_Mode
= Name_Input
then
23341 Add_Item
(Item_Id
, In_Constits
);
23343 elsif Global_Mode
= Name_In_Out
then
23344 Add_Item
(Item_Id
, In_Out_Constits
);
23346 elsif Global_Mode
= Name_Output
then
23347 Add_Item
(Item_Id
, Out_Constits
);
23349 elsif Global_Mode
= Name_Proof_In
then
23350 Add_Item
(Item_Id
, Proof_In_Constits
);
23353 -- When not a constituent, ensure that both occurrences of the
23354 -- item in pragmas Global and Refined_Global match.
23356 elsif Contains
(In_Items
, Item_Id
) then
23357 if Global_Mode
/= Name_Input
then
23358 Inconsistent_Mode_Error
(Name_Input
);
23361 elsif Contains
(In_Out_Items
, Item_Id
) then
23362 if Global_Mode
/= Name_In_Out
then
23363 Inconsistent_Mode_Error
(Name_In_Out
);
23366 elsif Contains
(Out_Items
, Item_Id
) then
23367 if Global_Mode
/= Name_Output
then
23368 Inconsistent_Mode_Error
(Name_Output
);
23371 elsif Contains
(Proof_In_Items
, Item_Id
) then
23374 -- The item does not appear in the corresponding Global pragma,
23375 -- it must be an extra (SPARK RM 7.2.4(3)).
23378 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
23380 end Check_Refined_Global_Item
;
23386 -- Start of processing for Check_Refined_Global_List
23389 -- Do not perform this check in an instance because it was already
23390 -- performed successfully in the generic template.
23392 if Is_Generic_Instance
(Spec_Id
) then
23395 elsif Nkind
(List
) = N_Null
then
23398 -- Single global item declaration
23400 elsif Nkind_In
(List
, N_Expanded_Name
,
23402 N_Selected_Component
)
23404 Check_Refined_Global_Item
(List
, Global_Mode
);
23406 -- Simple global list or moded global list declaration
23408 elsif Nkind
(List
) = N_Aggregate
then
23410 -- The declaration of a simple global list appear as a collection
23413 if Present
(Expressions
(List
)) then
23414 Item
:= First
(Expressions
(List
));
23415 while Present
(Item
) loop
23416 Check_Refined_Global_Item
(Item
, Global_Mode
);
23420 -- The declaration of a moded global list appears as a collection
23421 -- of component associations where individual choices denote
23424 elsif Present
(Component_Associations
(List
)) then
23425 Item
:= First
(Component_Associations
(List
));
23426 while Present
(Item
) loop
23427 Check_Refined_Global_List
23428 (List
=> Expression
(Item
),
23429 Global_Mode
=> Chars
(First
(Choices
(Item
))));
23437 raise Program_Error
;
23443 raise Program_Error
;
23445 end Check_Refined_Global_List
;
23447 --------------------------
23448 -- Collect_Global_Items --
23449 --------------------------
23451 procedure Collect_Global_Items
23453 Mode
: Name_Id
:= Name_Input
)
23455 procedure Collect_Global_Item
23457 Item_Mode
: Name_Id
);
23458 -- Add a single item to the appropriate list. Item_Mode denotes the
23459 -- current mode in effect.
23461 -------------------------
23462 -- Collect_Global_Item --
23463 -------------------------
23465 procedure Collect_Global_Item
23467 Item_Mode
: Name_Id
)
23469 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
23470 -- The above handles abstract views of variables and states built
23471 -- for limited with clauses.
23474 -- Signal that the global list contains at least one abstract
23475 -- state with a visible refinement. Note that the refinement may
23476 -- be null in which case there are no constituents.
23478 if Ekind
(Item_Id
) = E_Abstract_State
then
23479 if Has_Null_Refinement
(Item_Id
) then
23480 Has_Null_State
:= True;
23482 elsif Has_Non_Null_Refinement
(Item_Id
) then
23483 if Item_Mode
= Name_Input
then
23484 Has_In_State
:= True;
23485 elsif Item_Mode
= Name_In_Out
then
23486 Has_In_Out_State
:= True;
23487 elsif Item_Mode
= Name_Output
then
23488 Has_Out_State
:= True;
23489 elsif Item_Mode
= Name_Proof_In
then
23490 Has_Proof_In_State
:= True;
23495 -- Add the item to the proper list
23497 if Item_Mode
= Name_Input
then
23498 Add_Item
(Item_Id
, In_Items
);
23499 elsif Item_Mode
= Name_In_Out
then
23500 Add_Item
(Item_Id
, In_Out_Items
);
23501 elsif Item_Mode
= Name_Output
then
23502 Add_Item
(Item_Id
, Out_Items
);
23503 elsif Item_Mode
= Name_Proof_In
then
23504 Add_Item
(Item_Id
, Proof_In_Items
);
23506 end Collect_Global_Item
;
23512 -- Start of processing for Collect_Global_Items
23515 if Nkind
(List
) = N_Null
then
23518 -- Single global item declaration
23520 elsif Nkind_In
(List
, N_Expanded_Name
,
23522 N_Selected_Component
)
23524 Collect_Global_Item
(List
, Mode
);
23526 -- Single global list or moded global list declaration
23528 elsif Nkind
(List
) = N_Aggregate
then
23530 -- The declaration of a simple global list appear as a collection
23533 if Present
(Expressions
(List
)) then
23534 Item
:= First
(Expressions
(List
));
23535 while Present
(Item
) loop
23536 Collect_Global_Item
(Item
, Mode
);
23540 -- The declaration of a moded global list appears as a collection
23541 -- of component associations where individual choices denote mode.
23543 elsif Present
(Component_Associations
(List
)) then
23544 Item
:= First
(Component_Associations
(List
));
23545 while Present
(Item
) loop
23546 Collect_Global_Items
23547 (List
=> Expression
(Item
),
23548 Mode
=> Chars
(First
(Choices
(Item
))));
23556 raise Program_Error
;
23559 -- To accomodate partial decoration of disabled SPARK features, this
23560 -- routine may be called with illegal input. If this is the case, do
23561 -- not raise Program_Error.
23566 end Collect_Global_Items
;
23568 -------------------------
23569 -- Present_Then_Remove --
23570 -------------------------
23572 function Present_Then_Remove
23574 Item
: Entity_Id
) return Boolean
23579 if Present
(List
) then
23580 Elmt
:= First_Elmt
(List
);
23581 while Present
(Elmt
) loop
23582 if Node
(Elmt
) = Item
then
23583 Remove_Elmt
(List
, Elmt
);
23592 end Present_Then_Remove
;
23594 -------------------------------
23595 -- Report_Extra_Constituents --
23596 -------------------------------
23598 procedure Report_Extra_Constituents
is
23599 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
23600 -- Emit an error for every element of List
23602 ---------------------------------------
23603 -- Report_Extra_Constituents_In_List --
23604 ---------------------------------------
23606 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
23607 Constit_Elmt
: Elmt_Id
;
23610 if Present
(List
) then
23611 Constit_Elmt
:= First_Elmt
(List
);
23612 while Present
(Constit_Elmt
) loop
23613 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
23614 Next_Elmt
(Constit_Elmt
);
23617 end Report_Extra_Constituents_In_List
;
23619 -- Start of processing for Report_Extra_Constituents
23622 -- Do not perform this check in an instance because it was already
23623 -- performed successfully in the generic template.
23625 if Is_Generic_Instance
(Spec_Id
) then
23629 Report_Extra_Constituents_In_List
(In_Constits
);
23630 Report_Extra_Constituents_In_List
(In_Out_Constits
);
23631 Report_Extra_Constituents_In_List
(Out_Constits
);
23632 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
23634 end Report_Extra_Constituents
;
23638 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
23639 Errors
: constant Nat
:= Serious_Errors_Detected
;
23642 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23645 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
23646 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
23648 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
23651 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
23652 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
23654 -- The subprogram declaration lacks pragma Global. This renders
23655 -- Refined_Global useless as there is nothing to refine.
23657 if No
(Global
) then
23659 ("useless refinement, declaration of subprogram & lacks aspect or "
23660 & "pragma Global", N
, Spec_Id
);
23664 -- Extract all relevant items from the corresponding Global pragma
23666 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
23668 -- Package and subprogram bodies are instantiated individually in
23669 -- a separate compiler pass. Due to this mode of instantiation, the
23670 -- refinement of a state may no longer be visible when a subprogram
23671 -- body contract is instantiated. Since the generic template is legal,
23672 -- do not perform this check in the instance to circumvent this oddity.
23674 if Is_Generic_Instance
(Spec_Id
) then
23677 -- Non-instance case
23680 -- The corresponding Global pragma must mention at least one state
23681 -- witha visible refinement at the point Refined_Global is processed.
23682 -- States with null refinements need Refined_Global pragma
23683 -- (SPARK RM 7.2.4(2)).
23685 if not Has_In_State
23686 and then not Has_In_Out_State
23687 and then not Has_Out_State
23688 and then not Has_Proof_In_State
23689 and then not Has_Null_State
23692 ("useless refinement, subprogram & does not depend on abstract "
23693 & "state with visible refinement", N
, Spec_Id
);
23696 -- The global refinement of inputs and outputs cannot be null when
23697 -- the corresponding Global pragma contains at least one item except
23698 -- in the case where we have states with null refinements.
23700 elsif Nkind
(Items
) = N_Null
23702 (Present
(In_Items
)
23703 or else Present
(In_Out_Items
)
23704 or else Present
(Out_Items
)
23705 or else Present
(Proof_In_Items
))
23706 and then not Has_Null_State
23709 ("refinement cannot be null, subprogram & has global items",
23715 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23716 -- This ensures that the categorization of all refined global items is
23717 -- consistent with their role.
23719 Analyze_Global_In_Decl_Part
(N
);
23721 -- Perform all refinement checks with respect to completeness and mode
23724 if Serious_Errors_Detected
= Errors
then
23725 Check_Refined_Global_List
(Items
);
23728 -- For Input states with visible refinement, at least one constituent
23729 -- must be used as an Input in the global refinement.
23731 if Serious_Errors_Detected
= Errors
then
23732 Check_Input_States
;
23735 -- Verify all possible completion variants for In_Out states with
23736 -- visible refinement.
23738 if Serious_Errors_Detected
= Errors
then
23739 Check_In_Out_States
;
23742 -- For Output states with visible refinement, all constituents must be
23743 -- used as Outputs in the global refinement.
23745 if Serious_Errors_Detected
= Errors
then
23746 Check_Output_States
;
23749 -- For Proof_In states with visible refinement, at least one constituent
23750 -- must be used as Proof_In in the global refinement.
23752 if Serious_Errors_Detected
= Errors
then
23753 Check_Proof_In_States
;
23756 -- Emit errors for all constituents that belong to other states with
23757 -- visible refinement that do not appear in Global.
23759 if Serious_Errors_Detected
= Errors
then
23760 Report_Extra_Constituents
;
23762 end Analyze_Refined_Global_In_Decl_Part
;
23764 ----------------------------------------
23765 -- Analyze_Refined_State_In_Decl_Part --
23766 ----------------------------------------
23768 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
23769 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
23770 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
23771 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
23773 Available_States
: Elist_Id
:= No_Elist
;
23774 -- A list of all abstract states defined in the package declaration that
23775 -- are available for refinement. The list is used to report unrefined
23778 Body_States
: Elist_Id
:= No_Elist
;
23779 -- A list of all hidden states that appear in the body of the related
23780 -- package. The list is used to report unused hidden states.
23782 Constituents_Seen
: Elist_Id
:= No_Elist
;
23783 -- A list that contains all constituents processed so far. The list is
23784 -- used to detect multiple uses of the same constituent.
23786 Refined_States_Seen
: Elist_Id
:= No_Elist
;
23787 -- A list that contains all refined states processed so far. The list is
23788 -- used to detect duplicate refinements.
23790 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
23791 -- Perform full analysis of a single refinement clause
23793 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
23794 -- Gather the entities of all abstract states and objects declared in
23795 -- the body state space of package Pack_Id.
23797 procedure Report_Unrefined_States
(States
: Elist_Id
);
23798 -- Emit errors for all unrefined abstract states found in list States
23800 procedure Report_Unused_States
(States
: Elist_Id
);
23801 -- Emit errors for all unused states found in list States
23803 -------------------------------
23804 -- Analyze_Refinement_Clause --
23805 -------------------------------
23807 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
23808 AR_Constit
: Entity_Id
:= Empty
;
23809 AW_Constit
: Entity_Id
:= Empty
;
23810 ER_Constit
: Entity_Id
:= Empty
;
23811 EW_Constit
: Entity_Id
:= Empty
;
23812 -- The entities of external constituents that contain one of the
23813 -- following enabled properties: Async_Readers, Async_Writers,
23814 -- Effective_Reads and Effective_Writes.
23816 External_Constit_Seen
: Boolean := False;
23817 -- Flag used to mark when at least one external constituent is part
23818 -- of the state refinement.
23820 Non_Null_Seen
: Boolean := False;
23821 Null_Seen
: Boolean := False;
23822 -- Flags used to detect multiple uses of null in a single clause or a
23823 -- mixture of null and non-null constituents.
23825 Part_Of_Constits
: Elist_Id
:= No_Elist
;
23826 -- A list of all candidate constituents subject to indicator Part_Of
23827 -- where the encapsulating state is the current state.
23830 State_Id
: Entity_Id
;
23831 -- The current state being refined
23833 procedure Analyze_Constituent
(Constit
: Node_Id
);
23834 -- Perform full analysis of a single constituent
23836 procedure Check_External_Property
23837 (Prop_Nam
: Name_Id
;
23839 Constit
: Entity_Id
);
23840 -- Determine whether a property denoted by name Prop_Nam is present
23841 -- in both the refined state and constituent Constit. Flag Enabled
23842 -- should be set when the property applies to the refined state. If
23843 -- this is not the case, emit an error message.
23845 procedure Check_Matching_State
;
23846 -- Determine whether the state being refined appears in list
23847 -- Available_States. Emit an error when attempting to re-refine the
23848 -- state or when the state is not defined in the package declaration,
23849 -- otherwise remove the state from Available_States.
23851 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
23852 -- Emit errors for all unused Part_Of constituents in list Constits
23854 -------------------------
23855 -- Analyze_Constituent --
23856 -------------------------
23858 procedure Analyze_Constituent
(Constit
: Node_Id
) is
23859 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
);
23860 -- Verify that the constituent Constit_Id is a Ghost entity if the
23861 -- abstract state being refined is also Ghost. If this is the case
23862 -- verify that the Ghost policy in effect at the point of state
23863 -- and constituent declaration is the same.
23865 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
23866 -- Determine whether constituent Constit denoted by its entity
23867 -- Constit_Id appears in Hidden_States. Emit an error when the
23868 -- constituent is not a valid hidden state of the related package
23869 -- or when it is used more than once. Otherwise remove the
23870 -- constituent from Hidden_States.
23872 --------------------------------
23873 -- Check_Matching_Constituent --
23874 --------------------------------
23876 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
23877 procedure Collect_Constituent
;
23878 -- Add constituent Constit_Id to the refinements of State_Id
23880 -------------------------
23881 -- Collect_Constituent --
23882 -------------------------
23884 procedure Collect_Constituent
is
23886 -- Add the constituent to the list of processed items to aid
23887 -- with the detection of duplicates.
23889 Add_Item
(Constit_Id
, Constituents_Seen
);
23891 -- Collect the constituent in the list of refinement items
23892 -- and establish a relation between the refined state and
23895 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
23896 Set_Encapsulating_State
(Constit_Id
, State_Id
);
23898 -- The state has at least one legal constituent, mark the
23899 -- start of the refinement region. The region ends when the
23900 -- body declarations end (see routine Analyze_Declarations).
23902 Set_Has_Visible_Refinement
(State_Id
);
23904 -- When the constituent is external, save its relevant
23905 -- property for further checks.
23907 if Async_Readers_Enabled
(Constit_Id
) then
23908 AR_Constit
:= Constit_Id
;
23909 External_Constit_Seen
:= True;
23912 if Async_Writers_Enabled
(Constit_Id
) then
23913 AW_Constit
:= Constit_Id
;
23914 External_Constit_Seen
:= True;
23917 if Effective_Reads_Enabled
(Constit_Id
) then
23918 ER_Constit
:= Constit_Id
;
23919 External_Constit_Seen
:= True;
23922 if Effective_Writes_Enabled
(Constit_Id
) then
23923 EW_Constit
:= Constit_Id
;
23924 External_Constit_Seen
:= True;
23926 end Collect_Constituent
;
23930 State_Elmt
: Elmt_Id
;
23932 -- Start of processing for Check_Matching_Constituent
23935 -- Detect a duplicate use of a constituent
23937 if Contains
(Constituents_Seen
, Constit_Id
) then
23939 ("duplicate use of constituent &", Constit
, Constit_Id
);
23943 -- The constituent is subject to a Part_Of indicator
23945 if Present
(Encapsulating_State
(Constit_Id
)) then
23946 if Encapsulating_State
(Constit_Id
) = State_Id
then
23947 Check_Ghost_Constituent
(Constit_Id
);
23948 Remove
(Part_Of_Constits
, Constit_Id
);
23949 Collect_Constituent
;
23951 -- The constituent is part of another state and is used
23952 -- incorrectly in the refinement of the current state.
23955 Error_Msg_Name_1
:= Chars
(State_Id
);
23957 ("& cannot act as constituent of state %",
23958 Constit
, Constit_Id
);
23960 ("\Part_Of indicator specifies & as encapsulating "
23961 & "state", Constit
, Encapsulating_State
(Constit_Id
));
23964 -- The only other source of legal constituents is the body
23965 -- state space of the related package.
23968 if Present
(Body_States
) then
23969 State_Elmt
:= First_Elmt
(Body_States
);
23970 while Present
(State_Elmt
) loop
23972 -- Consume a valid constituent to signal that it has
23973 -- been encountered.
23975 if Node
(State_Elmt
) = Constit_Id
then
23976 Check_Ghost_Constituent
(Constit_Id
);
23977 Remove_Elmt
(Body_States
, State_Elmt
);
23978 Collect_Constituent
;
23982 Next_Elmt
(State_Elmt
);
23986 -- If we get here, then the constituent is not a hidden
23987 -- state of the related package and may not be used in a
23988 -- refinement (SPARK RM 7.2.2(9)).
23990 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23992 ("cannot use & in refinement, constituent is not a hidden "
23993 & "state of package %", Constit
, Constit_Id
);
23995 end Check_Matching_Constituent
;
23997 -----------------------------
23998 -- Check_Ghost_Constituent --
23999 -----------------------------
24001 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
) is
24003 if Is_Ghost_Entity
(State_Id
) then
24004 if Is_Ghost_Entity
(Constit_Id
) then
24006 -- The Ghost policy in effect at the point of abstract
24007 -- state declaration and constituent must match
24008 -- (SPARK RM 6.9(16)).
24010 if Is_Checked_Ghost_Entity
(State_Id
)
24011 and then Is_Ignored_Ghost_Entity
(Constit_Id
)
24013 Error_Msg_Sloc
:= Sloc
(Constit
);
24016 ("incompatible ghost policies in effect", State
);
24018 ("\abstract state & declared with ghost policy "
24019 & "Check", State
, State_Id
);
24021 ("\constituent & declared # with ghost policy "
24022 & "Ignore", State
, Constit_Id
);
24024 elsif Is_Ignored_Ghost_Entity
(State_Id
)
24025 and then Is_Checked_Ghost_Entity
(Constit_Id
)
24027 Error_Msg_Sloc
:= Sloc
(Constit
);
24030 ("incompatible ghost policies in effect", State
);
24032 ("\abstract state & declared with ghost policy "
24033 & "Ignore", State
, State_Id
);
24035 ("\constituent & declared # with ghost policy "
24036 & "Check", State
, Constit_Id
);
24039 -- A constituent of a Ghost abstract state must be a Ghost
24040 -- entity (SPARK RM 7.2.2(12)).
24044 ("constituent of ghost state & must be ghost",
24045 Constit
, State_Id
);
24048 end Check_Ghost_Constituent
;
24052 Constit_Id
: Entity_Id
;
24054 -- Start of processing for Analyze_Constituent
24057 -- Detect multiple uses of null in a single refinement clause or a
24058 -- mixture of null and non-null constituents.
24060 if Nkind
(Constit
) = N_Null
then
24063 ("multiple null constituents not allowed", Constit
);
24065 elsif Non_Null_Seen
then
24067 ("cannot mix null and non-null constituents", Constit
);
24072 -- Collect the constituent in the list of refinement items
24074 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
24076 -- The state has at least one legal constituent, mark the
24077 -- start of the refinement region. The region ends when the
24078 -- body declarations end (see Analyze_Declarations).
24080 Set_Has_Visible_Refinement
(State_Id
);
24083 -- Non-null constituents
24086 Non_Null_Seen
:= True;
24090 ("cannot mix null and non-null constituents", Constit
);
24094 Resolve_State
(Constit
);
24096 -- Ensure that the constituent denotes a valid state or a
24097 -- whole object (SPARK RM 7.2.2(5)).
24099 if Is_Entity_Name
(Constit
) then
24100 Constit_Id
:= Entity_Of
(Constit
);
24102 if Ekind_In
(Constit_Id
, E_Abstract_State
,
24106 Check_Matching_Constituent
(Constit_Id
);
24110 ("constituent & must denote object or state",
24111 Constit
, Constit_Id
);
24114 -- The constituent is illegal
24117 SPARK_Msg_N
("malformed constituent", Constit
);
24120 end Analyze_Constituent
;
24122 -----------------------------
24123 -- Check_External_Property --
24124 -----------------------------
24126 procedure Check_External_Property
24127 (Prop_Nam
: Name_Id
;
24129 Constit
: Entity_Id
)
24132 Error_Msg_Name_1
:= Prop_Nam
;
24134 -- The property is enabled in the related Abstract_State pragma
24135 -- that defines the state (SPARK RM 7.2.8(3)).
24138 if No
(Constit
) then
24140 ("external state & requires at least one constituent with "
24141 & "property %", State
, State_Id
);
24144 -- The property is missing in the declaration of the state, but
24145 -- a constituent is introducing it in the state refinement
24146 -- (SPARK RM 7.2.8(3)).
24148 elsif Present
(Constit
) then
24149 Error_Msg_Name_2
:= Chars
(Constit
);
24151 ("external state & lacks property % set by constituent %",
24154 end Check_External_Property
;
24156 --------------------------
24157 -- Check_Matching_State --
24158 --------------------------
24160 procedure Check_Matching_State
is
24161 State_Elmt
: Elmt_Id
;
24164 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
24166 if Contains
(Refined_States_Seen
, State_Id
) then
24168 ("duplicate refinement of state &", State
, State_Id
);
24172 -- Inspect the abstract states defined in the package declaration
24173 -- looking for a match.
24175 State_Elmt
:= First_Elmt
(Available_States
);
24176 while Present
(State_Elmt
) loop
24178 -- A valid abstract state is being refined in the body. Add
24179 -- the state to the list of processed refined states to aid
24180 -- with the detection of duplicate refinements. Remove the
24181 -- state from Available_States to signal that it has already
24184 if Node
(State_Elmt
) = State_Id
then
24185 Add_Item
(State_Id
, Refined_States_Seen
);
24186 Remove_Elmt
(Available_States
, State_Elmt
);
24190 Next_Elmt
(State_Elmt
);
24193 -- If we get here, we are refining a state that is not defined in
24194 -- the package declaration.
24196 Error_Msg_Name_1
:= Chars
(Spec_Id
);
24198 ("cannot refine state, & is not defined in package %",
24200 end Check_Matching_State
;
24202 --------------------------------
24203 -- Report_Unused_Constituents --
24204 --------------------------------
24206 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
24207 Constit_Elmt
: Elmt_Id
;
24208 Constit_Id
: Entity_Id
;
24209 Posted
: Boolean := False;
24212 if Present
(Constits
) then
24213 Constit_Elmt
:= First_Elmt
(Constits
);
24214 while Present
(Constit_Elmt
) loop
24215 Constit_Id
:= Node
(Constit_Elmt
);
24217 -- Generate an error message of the form:
24219 -- state ... has unused Part_Of constituents
24220 -- abstract state ... defined at ...
24221 -- constant ... defined at ...
24222 -- variable ... defined at ...
24227 ("state & has unused Part_Of constituents",
24231 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
24233 if Ekind
(Constit_Id
) = E_Abstract_State
then
24235 ("\abstract state & defined #", State
, Constit_Id
);
24237 elsif Ekind
(Constit_Id
) = E_Constant
then
24239 ("\constant & defined #", State
, Constit_Id
);
24242 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
24243 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
24246 Next_Elmt
(Constit_Elmt
);
24249 end Report_Unused_Constituents
;
24251 -- Local declarations
24253 Body_Ref
: Node_Id
;
24254 Body_Ref_Elmt
: Elmt_Id
;
24256 Extra_State
: Node_Id
;
24258 -- Start of processing for Analyze_Refinement_Clause
24261 -- A refinement clause appears as a component association where the
24262 -- sole choice is the state and the expressions are the constituents.
24263 -- This is a syntax error, always report.
24265 if Nkind
(Clause
) /= N_Component_Association
then
24266 Error_Msg_N
("malformed state refinement clause", Clause
);
24270 -- Analyze the state name of a refinement clause
24272 State
:= First
(Choices
(Clause
));
24275 Resolve_State
(State
);
24277 -- Ensure that the state name denotes a valid abstract state that is
24278 -- defined in the spec of the related package.
24280 if Is_Entity_Name
(State
) then
24281 State_Id
:= Entity_Of
(State
);
24283 -- Catch any attempts to re-refine a state or refine a state that
24284 -- is not defined in the package declaration.
24286 if Ekind
(State_Id
) = E_Abstract_State
then
24287 Check_Matching_State
;
24290 ("& must denote an abstract state", State
, State_Id
);
24294 -- References to a state with visible refinement are illegal.
24295 -- When nested packages are involved, detecting such references is
24296 -- tricky because pragma Refined_State is analyzed later than the
24297 -- offending pragma Depends or Global. References that occur in
24298 -- such nested context are stored in a list. Emit errors for all
24299 -- references found in Body_References (SPARK RM 6.1.4(8)).
24301 if Present
(Body_References
(State_Id
)) then
24302 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
24303 while Present
(Body_Ref_Elmt
) loop
24304 Body_Ref
:= Node
(Body_Ref_Elmt
);
24306 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
24307 Error_Msg_Sloc
:= Sloc
(State
);
24308 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
24310 Next_Elmt
(Body_Ref_Elmt
);
24314 -- The state name is illegal. This is a syntax error, always report.
24317 Error_Msg_N
("malformed state name in refinement clause", State
);
24321 -- A refinement clause may only refine one state at a time
24323 Extra_State
:= Next
(State
);
24325 if Present
(Extra_State
) then
24327 ("refinement clause cannot cover multiple states", Extra_State
);
24330 -- Replicate the Part_Of constituents of the refined state because
24331 -- the algorithm will consume items.
24333 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
24335 -- Analyze all constituents of the refinement. Multiple constituents
24336 -- appear as an aggregate.
24338 Constit
:= Expression
(Clause
);
24340 if Nkind
(Constit
) = N_Aggregate
then
24341 if Present
(Component_Associations
(Constit
)) then
24343 ("constituents of refinement clause must appear in "
24344 & "positional form", Constit
);
24346 else pragma Assert
(Present
(Expressions
(Constit
)));
24347 Constit
:= First
(Expressions
(Constit
));
24348 while Present
(Constit
) loop
24349 Analyze_Constituent
(Constit
);
24354 -- Various forms of a single constituent. Note that these may include
24355 -- malformed constituents.
24358 Analyze_Constituent
(Constit
);
24361 -- A refined external state is subject to special rules with respect
24362 -- to its properties and constituents.
24364 if Is_External_State
(State_Id
) then
24366 -- The set of properties that all external constituents yield must
24367 -- match that of the refined state. There are two cases to detect:
24368 -- the refined state lacks a property or has an extra property.
24370 if External_Constit_Seen
then
24371 Check_External_Property
24372 (Prop_Nam
=> Name_Async_Readers
,
24373 Enabled
=> Async_Readers_Enabled
(State_Id
),
24374 Constit
=> AR_Constit
);
24376 Check_External_Property
24377 (Prop_Nam
=> Name_Async_Writers
,
24378 Enabled
=> Async_Writers_Enabled
(State_Id
),
24379 Constit
=> AW_Constit
);
24381 Check_External_Property
24382 (Prop_Nam
=> Name_Effective_Reads
,
24383 Enabled
=> Effective_Reads_Enabled
(State_Id
),
24384 Constit
=> ER_Constit
);
24386 Check_External_Property
24387 (Prop_Nam
=> Name_Effective_Writes
,
24388 Enabled
=> Effective_Writes_Enabled
(State_Id
),
24389 Constit
=> EW_Constit
);
24391 -- An external state may be refined to null (SPARK RM 7.2.8(2))
24393 elsif Null_Seen
then
24396 -- The external state has constituents, but none of them are
24397 -- external (SPARK RM 7.2.8(2)).
24401 ("external state & requires at least one external "
24402 & "constituent or null refinement", State
, State_Id
);
24405 -- When a refined state is not external, it should not have external
24406 -- constituents (SPARK RM 7.2.8(1)).
24408 elsif External_Constit_Seen
then
24410 ("non-external state & cannot contain external constituents in "
24411 & "refinement", State
, State_Id
);
24414 -- Ensure that all Part_Of candidate constituents have been mentioned
24415 -- in the refinement clause.
24417 Report_Unused_Constituents
(Part_Of_Constits
);
24418 end Analyze_Refinement_Clause
;
24420 -------------------------
24421 -- Collect_Body_States --
24422 -------------------------
24424 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
24425 Result
: Elist_Id
:= No_Elist
;
24426 -- A list containing all body states of Pack_Id
24428 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
24429 -- Gather the entities of all abstract states and objects declared in
24430 -- the visible state space of package Pack_Id.
24432 ----------------------------
24433 -- Collect_Visible_States --
24434 ----------------------------
24436 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
24438 Item_Id
: Entity_Id
;
24441 -- Traverse the entity chain of the package and inspect all
24444 Item_Id
:= First_Entity
(Pack_Id
);
24445 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
24447 -- Do not consider internally generated items as those cannot
24448 -- be named and participate in refinement.
24450 if not Comes_From_Source
(Item_Id
) then
24453 elsif Ekind
(Item_Id
) = E_Abstract_State
then
24454 Add_Item
(Item_Id
, Result
);
24456 elsif Ekind_In
(Item_Id
, E_Constant
, E_Variable
) then
24457 Decl
:= Declaration_Node
(Item_Id
);
24459 -- Do not consider constants or variables that map generic
24460 -- formals to their actuals as the formals cannot be named
24461 -- from the outside and participate in refinement.
24463 if Present
(Corresponding_Generic_Association
(Decl
)) then
24466 -- Constants without "variable input" are not considered a
24467 -- hidden state of a package (SPARK RM 7.1.1(2)).
24469 elsif Ekind
(Item_Id
) = E_Constant
24470 and then not Has_Variable_Input
(Item_Id
)
24475 Add_Item
(Item_Id
, Result
);
24478 -- Recursively gather the visible states of a nested package
24480 elsif Ekind
(Item_Id
) = E_Package
then
24481 Collect_Visible_States
(Item_Id
);
24484 Next_Entity
(Item_Id
);
24486 end Collect_Visible_States
;
24490 Pack_Body
: constant Node_Id
:=
24491 Declaration_Node
(Body_Entity
(Pack_Id
));
24493 Item_Id
: Entity_Id
;
24495 -- Start of processing for Collect_Body_States
24498 -- Inspect the declarations of the body looking for source objects,
24499 -- packages and package instantiations.
24501 Decl
:= First
(Declarations
(Pack_Body
));
24502 while Present
(Decl
) loop
24504 -- Capture source objects as internally generated temporaries
24505 -- cannot be named and participate in refinement.
24507 if Nkind
(Decl
) = N_Object_Declaration
then
24508 Item_Id
:= Defining_Entity
(Decl
);
24510 if Comes_From_Source
(Item_Id
) then
24511 Add_Item
(Item_Id
, Result
);
24514 -- Capture the visible abstract states and objects of a source
24515 -- package [instantiation].
24517 elsif Nkind
(Decl
) = N_Package_Declaration
then
24518 Item_Id
:= Defining_Entity
(Decl
);
24520 if Comes_From_Source
(Item_Id
) then
24521 Collect_Visible_States
(Item_Id
);
24529 end Collect_Body_States
;
24531 -----------------------------
24532 -- Report_Unrefined_States --
24533 -----------------------------
24535 procedure Report_Unrefined_States
(States
: Elist_Id
) is
24536 State_Elmt
: Elmt_Id
;
24539 if Present
(States
) then
24540 State_Elmt
:= First_Elmt
(States
);
24541 while Present
(State_Elmt
) loop
24543 ("abstract state & must be refined", Node
(State_Elmt
));
24545 Next_Elmt
(State_Elmt
);
24548 end Report_Unrefined_States
;
24550 --------------------------
24551 -- Report_Unused_States --
24552 --------------------------
24554 procedure Report_Unused_States
(States
: Elist_Id
) is
24555 Posted
: Boolean := False;
24556 State_Elmt
: Elmt_Id
;
24557 State_Id
: Entity_Id
;
24560 if Present
(States
) then
24561 State_Elmt
:= First_Elmt
(States
);
24562 while Present
(State_Elmt
) loop
24563 State_Id
:= Node
(State_Elmt
);
24565 -- Generate an error message of the form:
24567 -- body of package ... has unused hidden states
24568 -- abstract state ... defined at ...
24569 -- constant ... defined at ...
24570 -- variable ... defined at ...
24575 ("body of package & has unused hidden states", Body_Id
);
24578 Error_Msg_Sloc
:= Sloc
(State_Id
);
24580 if Ekind
(State_Id
) = E_Abstract_State
then
24582 ("\abstract state & defined #", Body_Id
, State_Id
);
24584 elsif Ekind
(State_Id
) = E_Constant
then
24585 SPARK_Msg_NE
("\constant & defined #", Body_Id
, State_Id
);
24588 pragma Assert
(Ekind
(State_Id
) = E_Variable
);
24589 SPARK_Msg_NE
("\variable & defined #", Body_Id
, State_Id
);
24592 Next_Elmt
(State_Elmt
);
24595 end Report_Unused_States
;
24597 -- Local declarations
24599 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
24602 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24607 -- Replicate the abstract states declared by the package because the
24608 -- matching algorithm will consume states.
24610 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
24612 -- Gather all abstract states and objects declared in the visible
24613 -- state space of the package body. These items must be utilized as
24614 -- constituents in a state refinement.
24616 Body_States
:= Collect_Body_States
(Spec_Id
);
24618 -- Multiple non-null state refinements appear as an aggregate
24620 if Nkind
(Clauses
) = N_Aggregate
then
24621 if Present
(Expressions
(Clauses
)) then
24623 ("state refinements must appear as component associations",
24626 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
24627 Clause
:= First
(Component_Associations
(Clauses
));
24628 while Present
(Clause
) loop
24629 Analyze_Refinement_Clause
(Clause
);
24634 -- Various forms of a single state refinement. Note that these may
24635 -- include malformed refinements.
24638 Analyze_Refinement_Clause
(Clauses
);
24641 -- List all abstract states that were left unrefined
24643 Report_Unrefined_States
(Available_States
);
24645 -- Ensure that all abstract states and objects declared in the body
24646 -- state space of the related package are utilized as constituents.
24648 Report_Unused_States
(Body_States
);
24649 end Analyze_Refined_State_In_Decl_Part
;
24651 ------------------------------------
24652 -- Analyze_Test_Case_In_Decl_Part --
24653 ------------------------------------
24655 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
24656 Subp_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
24657 Spec_Id
: constant Entity_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
24659 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
24660 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
24661 -- denoted by Arg_Nam.
24663 ------------------------------
24664 -- Preanalyze_Test_Case_Arg --
24665 ------------------------------
24667 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
24671 -- Preanalyze the original aspect argument for ASIS or for a generic
24672 -- subprogram to properly capture global references.
24674 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
24678 Arg_Nam
=> Arg_Nam
,
24679 From_Aspect
=> True);
24681 if Present
(Arg
) then
24682 Preanalyze_Assert_Expression
24683 (Expression
(Arg
), Standard_Boolean
);
24687 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
24689 if Present
(Arg
) then
24690 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
24692 end Preanalyze_Test_Case_Arg
;
24696 Restore_Scope
: Boolean := False;
24698 -- Start of processing for Analyze_Test_Case_In_Decl_Part
24701 -- Ensure that the formal parameters are visible when analyzing all
24702 -- clauses. This falls out of the general rule of aspects pertaining
24703 -- to subprogram declarations.
24705 if not In_Open_Scopes
(Spec_Id
) then
24706 Restore_Scope
:= True;
24707 Push_Scope
(Spec_Id
);
24709 if Is_Generic_Subprogram
(Spec_Id
) then
24710 Install_Generic_Formals
(Spec_Id
);
24712 Install_Formals
(Spec_Id
);
24716 Preanalyze_Test_Case_Arg
(Name_Requires
);
24717 Preanalyze_Test_Case_Arg
(Name_Ensures
);
24719 if Restore_Scope
then
24723 -- Currently it is not possible to inline pre/postconditions on a
24724 -- subprogram subject to pragma Inline_Always.
24726 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
24727 end Analyze_Test_Case_In_Decl_Part
;
24733 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
24738 if Present
(List
) then
24739 Elmt
:= First_Elmt
(List
);
24740 while Present
(Elmt
) loop
24741 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
24744 Id
:= Entity_Of
(Node
(Elmt
));
24747 if Id
= Item_Id
then
24758 -----------------------------
24759 -- Check_Applicable_Policy --
24760 -----------------------------
24762 procedure Check_Applicable_Policy
(N
: Node_Id
) is
24766 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
24769 -- No effect if not valid assertion kind name
24771 if not Is_Valid_Assertion_Kind
(Ename
) then
24775 -- Loop through entries in check policy list
24777 PP
:= Opt
.Check_Policy_List
;
24778 while Present
(PP
) loop
24780 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24781 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24785 or else Pnm
= Name_Assertion
24786 or else (Pnm
= Name_Statement_Assertions
24787 and then Nam_In
(Ename
, Name_Assert
,
24788 Name_Assert_And_Cut
,
24790 Name_Loop_Invariant
,
24791 Name_Loop_Variant
))
24793 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
24796 when Name_Off | Name_Ignore
=>
24797 Set_Is_Ignored
(N
, True);
24798 Set_Is_Checked
(N
, False);
24800 when Name_On | Name_Check
=>
24801 Set_Is_Checked
(N
, True);
24802 Set_Is_Ignored
(N
, False);
24804 when Name_Disable
=>
24805 Set_Is_Ignored
(N
, True);
24806 Set_Is_Checked
(N
, False);
24807 Set_Is_Disabled
(N
, True);
24809 -- That should be exhaustive, the null here is a defence
24810 -- against a malformed tree from previous errors.
24819 PP
:= Next_Pragma
(PP
);
24823 -- If there are no specific entries that matched, then we let the
24824 -- setting of assertions govern. Note that this provides the needed
24825 -- compatibility with the RM for the cases of assertion, invariant,
24826 -- precondition, predicate, and postcondition.
24828 if Assertions_Enabled
then
24829 Set_Is_Checked
(N
, True);
24830 Set_Is_Ignored
(N
, False);
24832 Set_Is_Checked
(N
, False);
24833 Set_Is_Ignored
(N
, True);
24835 end Check_Applicable_Policy
;
24837 -------------------------------
24838 -- Check_External_Properties --
24839 -------------------------------
24841 procedure Check_External_Properties
24849 -- All properties enabled
24851 if AR
and AW
and ER
and EW
then
24854 -- Async_Readers + Effective_Writes
24855 -- Async_Readers + Async_Writers + Effective_Writes
24857 elsif AR
and EW
and not ER
then
24860 -- Async_Writers + Effective_Reads
24861 -- Async_Readers + Async_Writers + Effective_Reads
24863 elsif AW
and ER
and not EW
then
24866 -- Async_Readers + Async_Writers
24868 elsif AR
and AW
and not ER
and not EW
then
24873 elsif AR
and not AW
and not ER
and not EW
then
24878 elsif AW
and not AR
and not ER
and not EW
then
24883 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24886 end Check_External_Properties
;
24892 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
24896 -- Loop through entries in check policy list
24898 PP
:= Opt
.Check_Policy_List
;
24899 while Present
(PP
) loop
24901 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24902 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24906 or else (Pnm
= Name_Assertion
24907 and then Is_Valid_Assertion_Kind
(Nam
))
24908 or else (Pnm
= Name_Statement_Assertions
24909 and then Nam_In
(Nam
, Name_Assert
,
24910 Name_Assert_And_Cut
,
24912 Name_Loop_Invariant
,
24913 Name_Loop_Variant
))
24915 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
24916 when Name_On | Name_Check
=>
24918 when Name_Off | Name_Ignore
=>
24919 return Name_Ignore
;
24920 when Name_Disable
=>
24921 return Name_Disable
;
24923 raise Program_Error
;
24927 PP
:= Next_Pragma
(PP
);
24932 -- If there are no specific entries that matched, then we let the
24933 -- setting of assertions govern. Note that this provides the needed
24934 -- compatibility with the RM for the cases of assertion, invariant,
24935 -- precondition, predicate, and postcondition.
24937 if Assertions_Enabled
then
24940 return Name_Ignore
;
24944 ---------------------------
24945 -- Check_Missing_Part_Of --
24946 ---------------------------
24948 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
24949 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
24950 -- Determine whether a package denoted by Pack_Id declares at least one
24953 -----------------------
24954 -- Has_Visible_State --
24955 -----------------------
24957 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
24958 Item_Id
: Entity_Id
;
24961 -- Traverse the entity chain of the package trying to find at least
24962 -- one visible abstract state, variable or a package [instantiation]
24963 -- that declares a visible state.
24965 Item_Id
:= First_Entity
(Pack_Id
);
24966 while Present
(Item_Id
)
24967 and then not In_Private_Part
(Item_Id
)
24969 -- Do not consider internally generated items
24971 if not Comes_From_Source
(Item_Id
) then
24974 -- A visible state has been found
24976 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24979 -- Recursively peek into nested packages and instantiations
24981 elsif Ekind
(Item_Id
) = E_Package
24982 and then Has_Visible_State
(Item_Id
)
24987 Next_Entity
(Item_Id
);
24991 end Has_Visible_State
;
24995 Pack_Id
: Entity_Id
;
24996 Placement
: State_Space_Kind
;
24998 -- Start of processing for Check_Missing_Part_Of
25001 -- Do not consider abstract states, variables or package instantiations
25002 -- coming from an instance as those always inherit the Part_Of indicator
25003 -- of the instance itself.
25005 if In_Instance
then
25008 -- Do not consider internally generated entities as these can never
25009 -- have a Part_Of indicator.
25011 elsif not Comes_From_Source
(Item_Id
) then
25014 -- Perform these checks only when SPARK_Mode is enabled as they will
25015 -- interfere with standard Ada rules and produce false positives.
25017 elsif SPARK_Mode
/= On
then
25020 -- Do not consider constants without variable input because those are
25021 -- not part of the hidden state of a package (SPARK RM 7.1.1(2)).
25023 elsif Ekind
(Item_Id
) = E_Constant
25024 and then not Has_Variable_Input
(Item_Id
)
25029 -- Find where the abstract state, variable or package instantiation
25030 -- lives with respect to the state space.
25032 Find_Placement_In_State_Space
25033 (Item_Id
=> Item_Id
,
25034 Placement
=> Placement
,
25035 Pack_Id
=> Pack_Id
);
25037 -- Items that appear in a non-package construct (subprogram, block, etc)
25038 -- do not require a Part_Of indicator because they can never act as a
25041 if Placement
= Not_In_Package
then
25044 -- An item declared in the body state space of a package always act as a
25045 -- constituent and does not need explicit Part_Of indicator.
25047 elsif Placement
= Body_State_Space
then
25050 -- In general an item declared in the visible state space of a package
25051 -- does not require a Part_Of indicator. The only exception is when the
25052 -- related package is a private child unit in which case Part_Of must
25053 -- denote a state in the parent unit or in one of its descendants.
25055 elsif Placement
= Visible_State_Space
then
25056 if Is_Child_Unit
(Pack_Id
)
25057 and then Is_Private_Descendant
(Pack_Id
)
25059 -- A package instantiation does not need a Part_Of indicator when
25060 -- the related generic template has no visible state.
25062 if Ekind
(Item_Id
) = E_Package
25063 and then Is_Generic_Instance
(Item_Id
)
25064 and then not Has_Visible_State
(Item_Id
)
25068 -- All other cases require Part_Of
25072 ("indicator Part_Of is required in this context "
25073 & "(SPARK RM 7.2.6(3))", Item_Id
);
25074 Error_Msg_Name_1
:= Chars
(Pack_Id
);
25076 ("\& is declared in the visible part of private child "
25077 & "unit %", Item_Id
);
25081 -- When the item appears in the private state space of a packge, it must
25082 -- be a part of some state declared by the said package.
25084 else pragma Assert
(Placement
= Private_State_Space
);
25086 -- The related package does not declare a state, the item cannot act
25087 -- as a Part_Of constituent.
25089 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
25092 -- A package instantiation does not need a Part_Of indicator when the
25093 -- related generic template has no visible state.
25095 elsif Ekind
(Pack_Id
) = E_Package
25096 and then Is_Generic_Instance
(Pack_Id
)
25097 and then not Has_Visible_State
(Pack_Id
)
25101 -- All other cases require Part_Of
25105 ("indicator Part_Of is required in this context "
25106 & "(SPARK RM 7.2.6(2))", Item_Id
);
25107 Error_Msg_Name_1
:= Chars
(Pack_Id
);
25109 ("\& is declared in the private part of package %", Item_Id
);
25112 end Check_Missing_Part_Of
;
25114 ---------------------------------------------------
25115 -- Check_Postcondition_Use_In_Inlined_Subprogram --
25116 ---------------------------------------------------
25118 procedure Check_Postcondition_Use_In_Inlined_Subprogram
25120 Spec_Id
: Entity_Id
)
25123 if Warn_On_Redundant_Constructs
25124 and then Has_Pragma_Inline_Always
(Spec_Id
)
25126 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
25128 if From_Aspect_Specification
(Prag
) then
25130 ("aspect % not enforced on inlined subprogram &?r?",
25131 Corresponding_Aspect
(Prag
), Spec_Id
);
25134 ("pragma % not enforced on inlined subprogram &?r?",
25138 end Check_Postcondition_Use_In_Inlined_Subprogram
;
25140 -------------------------------------
25141 -- Check_State_And_Constituent_Use --
25142 -------------------------------------
25144 procedure Check_State_And_Constituent_Use
25145 (States
: Elist_Id
;
25146 Constits
: Elist_Id
;
25149 function Find_Encapsulating_State
25150 (Constit_Id
: Entity_Id
) return Entity_Id
;
25151 -- Given the entity of a constituent, try to find a corresponding
25152 -- encapsulating state that appears in the same context. The routine
25153 -- returns Empty is no such state is found.
25155 ------------------------------
25156 -- Find_Encapsulating_State --
25157 ------------------------------
25159 function Find_Encapsulating_State
25160 (Constit_Id
: Entity_Id
) return Entity_Id
25162 State_Id
: Entity_Id
;
25165 -- Since a constituent may be part of a larger constituent set, climb
25166 -- the encapsulated state chain looking for a state that appears in
25167 -- the same context.
25169 State_Id
:= Encapsulating_State
(Constit_Id
);
25170 while Present
(State_Id
) loop
25171 if Contains
(States
, State_Id
) then
25175 State_Id
:= Encapsulating_State
(State_Id
);
25179 end Find_Encapsulating_State
;
25183 Constit_Elmt
: Elmt_Id
;
25184 Constit_Id
: Entity_Id
;
25185 State_Id
: Entity_Id
;
25187 -- Start of processing for Check_State_And_Constituent_Use
25190 -- Nothing to do if there are no states or constituents
25192 if No
(States
) or else No
(Constits
) then
25196 -- Inspect the list of constituents and try to determine whether its
25197 -- encapsulating state is in list States.
25199 Constit_Elmt
:= First_Elmt
(Constits
);
25200 while Present
(Constit_Elmt
) loop
25201 Constit_Id
:= Node
(Constit_Elmt
);
25203 -- Determine whether the constituent is part of an encapsulating
25204 -- state that appears in the same context and if this is the case,
25205 -- emit an error (SPARK RM 7.2.6(7)).
25207 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
25209 if Present
(State_Id
) then
25210 Error_Msg_Name_1
:= Chars
(Constit_Id
);
25212 ("cannot mention state & and its constituent % in the same "
25213 & "context", Context
, State_Id
);
25217 Next_Elmt
(Constit_Elmt
);
25219 end Check_State_And_Constituent_Use
;
25221 ---------------------------------------
25222 -- Collect_Subprogram_Inputs_Outputs --
25223 ---------------------------------------
25225 procedure Collect_Subprogram_Inputs_Outputs
25226 (Subp_Id
: Entity_Id
;
25227 Synthesize
: Boolean := False;
25228 Subp_Inputs
: in out Elist_Id
;
25229 Subp_Outputs
: in out Elist_Id
;
25230 Global_Seen
: out Boolean)
25232 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
25233 -- Collect all relevant items from a dependency clause
25235 procedure Collect_Global_List
25237 Mode
: Name_Id
:= Name_Input
);
25238 -- Collect all relevant items from a global list
25240 -------------------------------
25241 -- Collect_Dependency_Clause --
25242 -------------------------------
25244 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
25245 procedure Collect_Dependency_Item
25247 Is_Input
: Boolean);
25248 -- Add an item to the proper subprogram input or output collection
25250 -----------------------------
25251 -- Collect_Dependency_Item --
25252 -----------------------------
25254 procedure Collect_Dependency_Item
25256 Is_Input
: Boolean)
25261 -- Nothing to collect when the item is null
25263 if Nkind
(Item
) = N_Null
then
25266 -- Ditto for attribute 'Result
25268 elsif Is_Attribute_Result
(Item
) then
25271 -- Multiple items appear as an aggregate
25273 elsif Nkind
(Item
) = N_Aggregate
then
25274 Extra
:= First
(Expressions
(Item
));
25275 while Present
(Extra
) loop
25276 Collect_Dependency_Item
(Extra
, Is_Input
);
25280 -- Otherwise this is a solitary item
25284 Add_Item
(Item
, Subp_Inputs
);
25286 Add_Item
(Item
, Subp_Outputs
);
25289 end Collect_Dependency_Item
;
25291 -- Start of processing for Collect_Dependency_Clause
25294 if Nkind
(Clause
) = N_Null
then
25297 -- A dependency cause appears as component association
25299 elsif Nkind
(Clause
) = N_Component_Association
then
25300 Collect_Dependency_Item
25301 (Item
=> Expression
(Clause
),
25304 Collect_Dependency_Item
25305 (Item
=> First
(Choices
(Clause
)),
25306 Is_Input
=> False);
25308 -- To accomodate partial decoration of disabled SPARK features, this
25309 -- routine may be called with illegal input. If this is the case, do
25310 -- not raise Program_Error.
25315 end Collect_Dependency_Clause
;
25317 -------------------------
25318 -- Collect_Global_List --
25319 -------------------------
25321 procedure Collect_Global_List
25323 Mode
: Name_Id
:= Name_Input
)
25325 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
25326 -- Add an item to the proper subprogram input or output collection
25328 -------------------------
25329 -- Collect_Global_Item --
25330 -------------------------
25332 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
25334 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
25335 Add_Item
(Item
, Subp_Inputs
);
25338 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
25339 Add_Item
(Item
, Subp_Outputs
);
25341 end Collect_Global_Item
;
25348 -- Start of processing for Collect_Global_List
25351 if Nkind
(List
) = N_Null
then
25354 -- Single global item declaration
25356 elsif Nkind_In
(List
, N_Expanded_Name
,
25358 N_Selected_Component
)
25360 Collect_Global_Item
(List
, Mode
);
25362 -- Simple global list or moded global list declaration
25364 elsif Nkind
(List
) = N_Aggregate
then
25365 if Present
(Expressions
(List
)) then
25366 Item
:= First
(Expressions
(List
));
25367 while Present
(Item
) loop
25368 Collect_Global_Item
(Item
, Mode
);
25373 Assoc
:= First
(Component_Associations
(List
));
25374 while Present
(Assoc
) loop
25375 Collect_Global_List
25376 (List
=> Expression
(Assoc
),
25377 Mode
=> Chars
(First
(Choices
(Assoc
))));
25382 -- To accomodate partial decoration of disabled SPARK features, this
25383 -- routine may be called with illegal input. If this is the case, do
25384 -- not raise Program_Error.
25389 end Collect_Global_List
;
25393 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
25394 Spec_Id
: constant Entity_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
25398 Formal
: Entity_Id
;
25402 -- Start of processing for Collect_Subprogram_Inputs_Outputs
25405 Global_Seen
:= False;
25407 -- Process all [generic] formal parameters
25409 Formal
:= First_Entity
(Spec_Id
);
25410 while Present
(Formal
) loop
25411 if Ekind_In
(Formal
, E_Generic_In_Parameter
,
25412 E_In_Out_Parameter
,
25415 Add_Item
(Formal
, Subp_Inputs
);
25418 if Ekind_In
(Formal
, E_Generic_In_Out_Parameter
,
25419 E_In_Out_Parameter
,
25422 Add_Item
(Formal
, Subp_Outputs
);
25424 -- Out parameters can act as inputs when the related type is
25425 -- tagged, unconstrained array, unconstrained record or record
25426 -- with unconstrained components.
25428 if Ekind
(Formal
) = E_Out_Parameter
25429 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
25431 Add_Item
(Formal
, Subp_Inputs
);
25435 Next_Entity
(Formal
);
25438 -- When processing a subprogram body, look for pragmas Refined_Depends
25439 -- and Refined_Global as they specify the inputs and outputs.
25441 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
25442 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
25443 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
25445 -- Subprogram declaration or stand alone body case, look for pragmas
25446 -- Depends and Global
25449 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
25450 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25453 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
25454 -- because it provides finer granularity of inputs and outputs.
25456 if Present
(Global
) then
25457 Global_Seen
:= True;
25458 List
:= Expression
(Get_Argument
(Global
, Spec_Id
));
25460 -- The pragma may not have been analyzed because of the arbitrary
25461 -- declaration order of aspects. Make sure that it is analyzed for
25462 -- the purposes of item extraction.
25464 if not Analyzed
(List
) then
25465 if Pragma_Name
(Global
) = Name_Refined_Global
then
25466 Analyze_Refined_Global_In_Decl_Part
(Global
);
25468 Analyze_Global_In_Decl_Part
(Global
);
25472 Collect_Global_List
(List
);
25474 -- When the related subprogram lacks pragma [Refined_]Global, fall back
25475 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
25476 -- the inputs and outputs from [Refined_]Depends.
25478 elsif Synthesize
and then Present
(Depends
) then
25479 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
25481 -- Multiple dependency clauses appear as an aggregate
25483 if Nkind
(Clauses
) = N_Aggregate
then
25484 Clause
:= First
(Component_Associations
(Clauses
));
25485 while Present
(Clause
) loop
25486 Collect_Dependency_Clause
(Clause
);
25490 -- Otherwise this is a single dependency clause
25493 Collect_Dependency_Clause
(Clauses
);
25496 end Collect_Subprogram_Inputs_Outputs
;
25498 ---------------------------------
25499 -- Delay_Config_Pragma_Analyze --
25500 ---------------------------------
25502 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
25504 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
25505 Name_Priority_Specific_Dispatching
);
25506 end Delay_Config_Pragma_Analyze
;
25508 -----------------------
25509 -- Duplication_Error --
25510 -----------------------
25512 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
25513 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
25514 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
25517 Error_Msg_Sloc
:= Sloc
(Prev
);
25518 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
25520 -- Emit a precise message to distinguish between source pragmas and
25521 -- pragmas generated from aspects. The ordering of the two pragmas is
25525 -- Prag -- duplicate
25527 -- No error is emitted when both pragmas come from aspects because this
25528 -- is already detected by the general aspect analysis mechanism.
25530 if Prag_From_Asp
and Prev_From_Asp
then
25532 elsif Prag_From_Asp
then
25533 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
25534 elsif Prev_From_Asp
then
25535 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
25537 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
25539 end Duplication_Error
;
25541 ----------------------------------
25542 -- Find_Related_Package_Or_Body --
25543 ----------------------------------
25545 function Find_Related_Package_Or_Body
25547 Do_Checks
: Boolean := False) return Node_Id
25549 Context
: constant Node_Id
:= Parent
(Prag
);
25550 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
25554 Stmt
:= Prev
(Prag
);
25555 while Present
(Stmt
) loop
25557 -- Skip prior pragmas, but check for duplicates
25559 if Nkind
(Stmt
) = N_Pragma
then
25560 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
25566 -- Skip internally generated code
25568 elsif not Comes_From_Source
(Stmt
) then
25569 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
25571 -- The subprogram declaration is an internally generated spec
25572 -- for an expression function.
25574 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
25577 -- The subprogram is actually an instance housed within an
25578 -- anonymous wrapper package.
25580 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
25585 -- Return the current source construct which is illegal
25594 -- If we fall through, then the pragma was either the first declaration
25595 -- or it was preceded by other pragmas and no source constructs.
25597 -- The pragma is associated with a package. The immediate context in
25598 -- this case is the specification of the package.
25600 if Nkind
(Context
) = N_Package_Specification
then
25601 return Parent
(Context
);
25603 -- The pragma appears in the declarations of a package body
25605 elsif Nkind
(Context
) = N_Package_Body
then
25608 -- The pragma appears in the statements of a package body
25610 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
25611 and then Nkind
(Parent
(Context
)) = N_Package_Body
25613 return Parent
(Context
);
25615 -- The pragma is a byproduct of aspect expansion, return the related
25616 -- context of the original aspect. This case has a lower priority as
25617 -- the above circuitry pinpoints precisely the related context.
25619 elsif Present
(Corresponding_Aspect
(Prag
)) then
25620 return Parent
(Corresponding_Aspect
(Prag
));
25622 -- No candidate packge [body] found
25627 end Find_Related_Package_Or_Body
;
25629 -------------------------------------
25630 -- Find_Related_Subprogram_Or_Body --
25631 -------------------------------------
25633 function Find_Related_Subprogram_Or_Body
25635 Do_Checks
: Boolean := False) return Node_Id
25637 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
25639 procedure Expression_Function_Error
;
25640 -- Emit an error concerning pragma Prag that illegaly applies to an
25641 -- expression function.
25643 -------------------------------
25644 -- Expression_Function_Error --
25645 -------------------------------
25647 procedure Expression_Function_Error
is
25649 Error_Msg_Name_1
:= Prag_Nam
;
25651 -- Emit a precise message to distinguish between source pragmas and
25652 -- pragmas generated from aspects.
25654 if From_Aspect_Specification
(Prag
) then
25656 ("aspect % cannot apply to a stand alone expression function",
25660 ("pragma % cannot apply to a stand alone expression function",
25663 end Expression_Function_Error
;
25667 Context
: constant Node_Id
:= Parent
(Prag
);
25670 Look_For_Body
: constant Boolean :=
25671 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
25672 Name_Refined_Global
,
25673 Name_Refined_Post
);
25674 -- Refinement pragmas must be associated with a subprogram body [stub]
25676 -- Start of processing for Find_Related_Subprogram_Or_Body
25679 Stmt
:= Prev
(Prag
);
25680 while Present
(Stmt
) loop
25682 -- Skip prior pragmas, but check for duplicates. Pragmas produced
25683 -- by splitting a complex pre/postcondition are not considered to
25686 if Nkind
(Stmt
) = N_Pragma
then
25688 and then not Split_PPC
(Stmt
)
25689 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
25696 -- Emit an error when a refinement pragma appears on an expression
25697 -- function without a completion.
25700 and then Look_For_Body
25701 and then Nkind
(Stmt
) = N_Subprogram_Declaration
25702 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
25703 and then not Has_Completion
(Defining_Entity
(Stmt
))
25705 Expression_Function_Error
;
25708 -- The refinement pragma applies to a subprogram body stub
25710 elsif Look_For_Body
25711 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
25715 -- Skip internally generated code
25717 elsif not Comes_From_Source
(Stmt
) then
25718 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
25720 -- The subprogram declaration is an internally generated spec
25721 -- for an expression function.
25723 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
25726 -- The subprogram is actually an instance housed within an
25727 -- anonymous wrapper package.
25729 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
25734 -- Return the current construct which is either a subprogram body,
25735 -- a subprogram declaration or is illegal.
25744 -- If we fall through, then the pragma was either the first declaration
25745 -- or it was preceded by other pragmas and no source constructs.
25747 -- The pragma is associated with a library-level subprogram
25749 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
25750 return Unit
(Parent
(Context
));
25752 -- The pragma appears inside the statements of a subprogram body. This
25753 -- placement is the result of subprogram contract expansion.
25755 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
25756 return Parent
(Context
);
25758 -- The pragma appears inside the declarative part of a subprogram body
25760 elsif Nkind
(Context
) = N_Subprogram_Body
then
25763 -- The pragma is a byproduct of aspect expansion, return the related
25764 -- context of the original aspect. This case has a lower priority as
25765 -- the above circuitry pinpoints precisely the related context.
25767 elsif Present
(Corresponding_Aspect
(Prag
)) then
25768 return Parent
(Corresponding_Aspect
(Prag
));
25770 -- No candidate subprogram [body] found
25775 end Find_Related_Subprogram_Or_Body
;
25781 function Get_Argument
25783 Context_Id
: Entity_Id
:= Empty
) return Node_Id
25785 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
25788 -- Use the expression of the original aspect when compiling for ASIS or
25789 -- when analyzing the template of a generic unit. In both cases the
25790 -- aspect's tree must be decorated to allow for ASIS queries or to save
25791 -- the global references in the generic context.
25793 if From_Aspect_Specification
(Prag
)
25794 and then (ASIS_Mode
or else (Present
(Context_Id
)
25795 and then Is_Generic_Unit
(Context_Id
)))
25797 return Corresponding_Aspect
(Prag
);
25799 -- Otherwise use the expression of the pragma
25801 elsif Present
(Args
) then
25802 return First
(Args
);
25809 -------------------------
25810 -- Get_Base_Subprogram --
25811 -------------------------
25813 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
25814 Result
: Entity_Id
;
25817 -- Follow subprogram renaming chain
25821 if Is_Subprogram
(Result
)
25823 Nkind
(Parent
(Declaration_Node
(Result
))) =
25824 N_Subprogram_Renaming_Declaration
25825 and then Present
(Alias
(Result
))
25827 Result
:= Alias
(Result
);
25831 end Get_Base_Subprogram
;
25833 -----------------------
25834 -- Get_SPARK_Mode_Type --
25835 -----------------------
25837 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
25839 if N
= Name_On
then
25841 elsif N
= Name_Off
then
25844 -- Any other argument is illegal
25847 raise Program_Error
;
25849 end Get_SPARK_Mode_Type
;
25851 --------------------------------
25852 -- Get_SPARK_Mode_From_Pragma --
25853 --------------------------------
25855 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
25860 pragma Assert
(Nkind
(N
) = N_Pragma
);
25861 Args
:= Pragma_Argument_Associations
(N
);
25863 -- Extract the mode from the argument list
25865 if Present
(Args
) then
25866 Mode
:= First
(Pragma_Argument_Associations
(N
));
25867 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
25869 -- If SPARK_Mode pragma has no argument, default is ON
25874 end Get_SPARK_Mode_From_Pragma
;
25876 ---------------------------
25877 -- Has_Extra_Parentheses --
25878 ---------------------------
25880 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
25884 -- The aggregate should not have an expression list because a clause
25885 -- is always interpreted as a component association. The only way an
25886 -- expression list can sneak in is by adding extra parentheses around
25887 -- the individual clauses:
25889 -- Depends (Output => Input) -- proper form
25890 -- Depends ((Output => Input)) -- extra parentheses
25892 -- Since the extra parentheses are not allowed by the syntax of the
25893 -- pragma, flag them now to avoid emitting misleading errors down the
25896 if Nkind
(Clause
) = N_Aggregate
25897 and then Present
(Expressions
(Clause
))
25899 Expr
:= First
(Expressions
(Clause
));
25900 while Present
(Expr
) loop
25902 -- A dependency clause surrounded by extra parentheses appears
25903 -- as an aggregate of component associations with an optional
25904 -- Paren_Count set.
25906 if Nkind
(Expr
) = N_Aggregate
25907 and then Present
(Component_Associations
(Expr
))
25910 ("dependency clause contains extra parentheses", Expr
);
25912 -- Otherwise the expression is a malformed construct
25915 SPARK_Msg_N
("malformed dependency clause", Expr
);
25925 end Has_Extra_Parentheses
;
25931 procedure Initialize
is
25942 Dummy
:= Dummy
+ 1;
25945 -----------------------------
25946 -- Is_Config_Static_String --
25947 -----------------------------
25949 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25951 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
25952 -- This is an internal recursive function that is just like the outer
25953 -- function except that it adds the string to the name buffer rather
25954 -- than placing the string in the name buffer.
25956 ------------------------------
25957 -- Add_Config_Static_String --
25958 ------------------------------
25960 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25967 if Nkind
(N
) = N_Op_Concat
then
25968 if Add_Config_Static_String
(Left_Opnd
(N
)) then
25969 N
:= Right_Opnd
(N
);
25975 if Nkind
(N
) /= N_String_Literal
then
25976 Error_Msg_N
("string literal expected for pragma argument", N
);
25980 for J
in 1 .. String_Length
(Strval
(N
)) loop
25981 C
:= Get_String_Char
(Strval
(N
), J
);
25983 if not In_Character_Range
(C
) then
25985 ("string literal contains invalid wide character",
25986 Sloc
(N
) + 1 + Source_Ptr
(J
));
25990 Add_Char_To_Name_Buffer
(Get_Character
(C
));
25995 end Add_Config_Static_String
;
25997 -- Start of processing for Is_Config_Static_String
26002 return Add_Config_Static_String
(Arg
);
26003 end Is_Config_Static_String
;
26005 -------------------------------
26006 -- Is_Elaboration_SPARK_Mode --
26007 -------------------------------
26009 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
26012 (Nkind
(N
) = N_Pragma
26013 and then Pragma_Name
(N
) = Name_SPARK_Mode
26014 and then Is_List_Member
(N
));
26016 -- Pragma SPARK_Mode affects the elaboration of a package body when it
26017 -- appears in the statement part of the body.
26020 Present
(Parent
(N
))
26021 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
26022 and then List_Containing
(N
) = Statements
(Parent
(N
))
26023 and then Present
(Parent
(Parent
(N
)))
26024 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
26025 end Is_Elaboration_SPARK_Mode
;
26027 -----------------------------------------
26028 -- Is_Non_Significant_Pragma_Reference --
26029 -----------------------------------------
26031 -- This function makes use of the following static table which indicates
26032 -- whether appearance of some name in a given pragma is to be considered
26033 -- as a reference for the purposes of warnings about unreferenced objects.
26035 -- -1 indicates that appearence in any argument is significant
26036 -- 0 indicates that appearance in any argument is not significant
26037 -- +n indicates that appearance as argument n is significant, but all
26038 -- other arguments are not significant
26039 -- 9n arguments from n on are significant, before n inisignificant
26041 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
26042 (Pragma_Abort_Defer
=> -1,
26043 Pragma_Abstract_State
=> -1,
26044 Pragma_Ada_83
=> -1,
26045 Pragma_Ada_95
=> -1,
26046 Pragma_Ada_05
=> -1,
26047 Pragma_Ada_2005
=> -1,
26048 Pragma_Ada_12
=> -1,
26049 Pragma_Ada_2012
=> -1,
26050 Pragma_All_Calls_Remote
=> -1,
26051 Pragma_Allow_Integer_Address
=> -1,
26052 Pragma_Annotate
=> 93,
26053 Pragma_Assert
=> -1,
26054 Pragma_Assert_And_Cut
=> -1,
26055 Pragma_Assertion_Policy
=> 0,
26056 Pragma_Assume
=> -1,
26057 Pragma_Assume_No_Invalid_Values
=> 0,
26058 Pragma_Async_Readers
=> 0,
26059 Pragma_Async_Writers
=> 0,
26060 Pragma_Asynchronous
=> 0,
26061 Pragma_Atomic
=> 0,
26062 Pragma_Atomic_Components
=> 0,
26063 Pragma_Attach_Handler
=> -1,
26064 Pragma_Attribute_Definition
=> 92,
26065 Pragma_Check
=> -1,
26066 Pragma_Check_Float_Overflow
=> 0,
26067 Pragma_Check_Name
=> 0,
26068 Pragma_Check_Policy
=> 0,
26069 Pragma_CIL_Constructor
=> 0,
26070 Pragma_CPP_Class
=> 0,
26071 Pragma_CPP_Constructor
=> 0,
26072 Pragma_CPP_Virtual
=> 0,
26073 Pragma_CPP_Vtable
=> 0,
26075 Pragma_C_Pass_By_Copy
=> 0,
26076 Pragma_Comment
=> -1,
26077 Pragma_Common_Object
=> 0,
26078 Pragma_Compile_Time_Error
=> -1,
26079 Pragma_Compile_Time_Warning
=> -1,
26080 Pragma_Compiler_Unit
=> -1,
26081 Pragma_Compiler_Unit_Warning
=> -1,
26082 Pragma_Complete_Representation
=> 0,
26083 Pragma_Complex_Representation
=> 0,
26084 Pragma_Component_Alignment
=> 0,
26085 Pragma_Contract_Cases
=> -1,
26086 Pragma_Controlled
=> 0,
26087 Pragma_Convention
=> 0,
26088 Pragma_Convention_Identifier
=> 0,
26089 Pragma_Debug
=> -1,
26090 Pragma_Debug_Policy
=> 0,
26091 Pragma_Detect_Blocking
=> 0,
26092 Pragma_Default_Initial_Condition
=> -1,
26093 Pragma_Default_Scalar_Storage_Order
=> 0,
26094 Pragma_Default_Storage_Pool
=> 0,
26095 Pragma_Depends
=> -1,
26096 Pragma_Disable_Atomic_Synchronization
=> 0,
26097 Pragma_Discard_Names
=> 0,
26098 Pragma_Dispatching_Domain
=> -1,
26099 Pragma_Effective_Reads
=> 0,
26100 Pragma_Effective_Writes
=> 0,
26101 Pragma_Elaborate
=> 0,
26102 Pragma_Elaborate_All
=> 0,
26103 Pragma_Elaborate_Body
=> 0,
26104 Pragma_Elaboration_Checks
=> 0,
26105 Pragma_Eliminate
=> 0,
26106 Pragma_Enable_Atomic_Synchronization
=> 0,
26107 Pragma_Export
=> -1,
26108 Pragma_Export_Function
=> -1,
26109 Pragma_Export_Object
=> -1,
26110 Pragma_Export_Procedure
=> -1,
26111 Pragma_Export_Value
=> -1,
26112 Pragma_Export_Valued_Procedure
=> -1,
26113 Pragma_Extend_System
=> -1,
26114 Pragma_Extensions_Allowed
=> 0,
26115 Pragma_Extensions_Visible
=> 0,
26116 Pragma_External
=> -1,
26117 Pragma_Favor_Top_Level
=> 0,
26118 Pragma_External_Name_Casing
=> 0,
26119 Pragma_Fast_Math
=> 0,
26120 Pragma_Finalize_Storage_Only
=> 0,
26122 Pragma_Global
=> -1,
26123 Pragma_Ident
=> -1,
26124 Pragma_Ignore_Pragma
=> 0,
26125 Pragma_Implementation_Defined
=> -1,
26126 Pragma_Implemented
=> -1,
26127 Pragma_Implicit_Packing
=> 0,
26128 Pragma_Import
=> 93,
26129 Pragma_Import_Function
=> 0,
26130 Pragma_Import_Object
=> 0,
26131 Pragma_Import_Procedure
=> 0,
26132 Pragma_Import_Valued_Procedure
=> 0,
26133 Pragma_Independent
=> 0,
26134 Pragma_Independent_Components
=> 0,
26135 Pragma_Initial_Condition
=> -1,
26136 Pragma_Initialize_Scalars
=> 0,
26137 Pragma_Initializes
=> -1,
26138 Pragma_Inline
=> 0,
26139 Pragma_Inline_Always
=> 0,
26140 Pragma_Inline_Generic
=> 0,
26141 Pragma_Inspection_Point
=> -1,
26142 Pragma_Interface
=> 92,
26143 Pragma_Interface_Name
=> 0,
26144 Pragma_Interrupt_Handler
=> -1,
26145 Pragma_Interrupt_Priority
=> -1,
26146 Pragma_Interrupt_State
=> -1,
26147 Pragma_Invariant
=> -1,
26148 Pragma_Java_Constructor
=> -1,
26149 Pragma_Java_Interface
=> -1,
26150 Pragma_Keep_Names
=> 0,
26151 Pragma_License
=> 0,
26152 Pragma_Link_With
=> -1,
26153 Pragma_Linker_Alias
=> -1,
26154 Pragma_Linker_Constructor
=> -1,
26155 Pragma_Linker_Destructor
=> -1,
26156 Pragma_Linker_Options
=> -1,
26157 Pragma_Linker_Section
=> 0,
26159 Pragma_Lock_Free
=> 0,
26160 Pragma_Locking_Policy
=> 0,
26161 Pragma_Loop_Invariant
=> -1,
26162 Pragma_Loop_Optimize
=> 0,
26163 Pragma_Loop_Variant
=> -1,
26164 Pragma_Machine_Attribute
=> -1,
26166 Pragma_Main_Storage
=> -1,
26167 Pragma_Memory_Size
=> 0,
26168 Pragma_No_Return
=> 0,
26169 Pragma_No_Body
=> 0,
26170 Pragma_No_Elaboration_Code_All
=> 0,
26171 Pragma_No_Inline
=> 0,
26172 Pragma_No_Run_Time
=> -1,
26173 Pragma_No_Strict_Aliasing
=> -1,
26174 Pragma_No_Tagged_Streams
=> 0,
26175 Pragma_Normalize_Scalars
=> 0,
26176 Pragma_Obsolescent
=> 0,
26177 Pragma_Optimize
=> 0,
26178 Pragma_Optimize_Alignment
=> 0,
26179 Pragma_Overflow_Mode
=> 0,
26180 Pragma_Overriding_Renamings
=> 0,
26181 Pragma_Ordered
=> 0,
26184 Pragma_Part_Of
=> 0,
26185 Pragma_Partition_Elaboration_Policy
=> 0,
26186 Pragma_Passive
=> 0,
26187 Pragma_Persistent_BSS
=> 0,
26188 Pragma_Polling
=> 0,
26189 Pragma_Prefix_Exception_Messages
=> 0,
26191 Pragma_Postcondition
=> -1,
26192 Pragma_Post_Class
=> -1,
26194 Pragma_Precondition
=> -1,
26195 Pragma_Predicate
=> -1,
26196 Pragma_Preelaborable_Initialization
=> -1,
26197 Pragma_Preelaborate
=> 0,
26198 Pragma_Pre_Class
=> -1,
26199 Pragma_Priority
=> -1,
26200 Pragma_Priority_Specific_Dispatching
=> 0,
26201 Pragma_Profile
=> 0,
26202 Pragma_Profile_Warnings
=> 0,
26203 Pragma_Propagate_Exceptions
=> 0,
26204 Pragma_Provide_Shift_Operators
=> 0,
26205 Pragma_Psect_Object
=> 0,
26207 Pragma_Pure_Function
=> 0,
26208 Pragma_Queuing_Policy
=> 0,
26209 Pragma_Rational
=> 0,
26210 Pragma_Ravenscar
=> 0,
26211 Pragma_Refined_Depends
=> -1,
26212 Pragma_Refined_Global
=> -1,
26213 Pragma_Refined_Post
=> -1,
26214 Pragma_Refined_State
=> -1,
26215 Pragma_Relative_Deadline
=> 0,
26216 Pragma_Remote_Access_Type
=> -1,
26217 Pragma_Remote_Call_Interface
=> -1,
26218 Pragma_Remote_Types
=> -1,
26219 Pragma_Restricted_Run_Time
=> 0,
26220 Pragma_Restriction_Warnings
=> 0,
26221 Pragma_Restrictions
=> 0,
26222 Pragma_Reviewable
=> -1,
26223 Pragma_Short_Circuit_And_Or
=> 0,
26224 Pragma_Share_Generic
=> 0,
26225 Pragma_Shared
=> 0,
26226 Pragma_Shared_Passive
=> 0,
26227 Pragma_Short_Descriptors
=> 0,
26228 Pragma_Simple_Storage_Pool_Type
=> 0,
26229 Pragma_Source_File_Name
=> 0,
26230 Pragma_Source_File_Name_Project
=> 0,
26231 Pragma_Source_Reference
=> 0,
26232 Pragma_SPARK_Mode
=> 0,
26233 Pragma_Storage_Size
=> -1,
26234 Pragma_Storage_Unit
=> 0,
26235 Pragma_Static_Elaboration_Desired
=> 0,
26236 Pragma_Stream_Convert
=> 0,
26237 Pragma_Style_Checks
=> 0,
26238 Pragma_Subtitle
=> 0,
26239 Pragma_Suppress
=> 0,
26240 Pragma_Suppress_Exception_Locations
=> 0,
26241 Pragma_Suppress_All
=> 0,
26242 Pragma_Suppress_Debug_Info
=> 0,
26243 Pragma_Suppress_Initialization
=> 0,
26244 Pragma_System_Name
=> 0,
26245 Pragma_Task_Dispatching_Policy
=> 0,
26246 Pragma_Task_Info
=> -1,
26247 Pragma_Task_Name
=> -1,
26248 Pragma_Task_Storage
=> -1,
26249 Pragma_Test_Case
=> -1,
26250 Pragma_Thread_Local_Storage
=> -1,
26251 Pragma_Time_Slice
=> -1,
26253 Pragma_Type_Invariant
=> -1,
26254 Pragma_Type_Invariant_Class
=> -1,
26255 Pragma_Unchecked_Union
=> 0,
26256 Pragma_Unimplemented_Unit
=> 0,
26257 Pragma_Universal_Aliasing
=> 0,
26258 Pragma_Universal_Data
=> 0,
26259 Pragma_Unmodified
=> 0,
26260 Pragma_Unreferenced
=> 0,
26261 Pragma_Unreferenced_Objects
=> 0,
26262 Pragma_Unreserve_All_Interrupts
=> 0,
26263 Pragma_Unsuppress
=> 0,
26264 Pragma_Unevaluated_Use_Of_Old
=> 0,
26265 Pragma_Use_VADS_Size
=> 0,
26266 Pragma_Validity_Checks
=> 0,
26267 Pragma_Volatile
=> 0,
26268 Pragma_Volatile_Components
=> 0,
26269 Pragma_Volatile_Full_Access
=> 0,
26270 Pragma_Warning_As_Error
=> 0,
26271 Pragma_Warnings
=> 0,
26272 Pragma_Weak_External
=> 0,
26273 Pragma_Wide_Character_Encoding
=> 0,
26274 Unknown_Pragma
=> 0);
26276 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
26282 function Arg_No
return Nat
;
26283 -- Returns an integer showing what argument we are in. A value of
26284 -- zero means we are not in any of the arguments.
26290 function Arg_No
return Nat
is
26295 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
26309 -- Start of processing for Non_Significant_Pragma_Reference
26314 if Nkind
(P
) /= N_Pragma_Argument_Association
then
26318 Id
:= Get_Pragma_Id
(Parent
(P
));
26319 C
:= Sig_Flags
(Id
);
26334 return AN
< (C
- 90);
26340 end Is_Non_Significant_Pragma_Reference
;
26342 ------------------------------
26343 -- Is_Pragma_String_Literal --
26344 ------------------------------
26346 -- This function returns true if the corresponding pragma argument is a
26347 -- static string expression. These are the only cases in which string
26348 -- literals can appear as pragma arguments. We also allow a string literal
26349 -- as the first argument to pragma Assert (although it will of course
26350 -- always generate a type error).
26352 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
26353 Pragn
: constant Node_Id
:= Parent
(Par
);
26354 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
26355 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
26361 N
:= First
(Assoc
);
26368 if Pname
= Name_Assert
then
26371 elsif Pname
= Name_Export
then
26374 elsif Pname
= Name_Ident
then
26377 elsif Pname
= Name_Import
then
26380 elsif Pname
= Name_Interface_Name
then
26383 elsif Pname
= Name_Linker_Alias
then
26386 elsif Pname
= Name_Linker_Section
then
26389 elsif Pname
= Name_Machine_Attribute
then
26392 elsif Pname
= Name_Source_File_Name
then
26395 elsif Pname
= Name_Source_Reference
then
26398 elsif Pname
= Name_Title
then
26401 elsif Pname
= Name_Subtitle
then
26407 end Is_Pragma_String_Literal
;
26409 ---------------------------
26410 -- Is_Private_SPARK_Mode --
26411 ---------------------------
26413 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
26416 (Nkind
(N
) = N_Pragma
26417 and then Pragma_Name
(N
) = Name_SPARK_Mode
26418 and then Is_List_Member
(N
));
26420 -- For pragma SPARK_Mode to be private, it has to appear in the private
26421 -- declarations of a package.
26424 Present
(Parent
(N
))
26425 and then Nkind
(Parent
(N
)) = N_Package_Specification
26426 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
26427 end Is_Private_SPARK_Mode
;
26429 -------------------------------------
26430 -- Is_Unconstrained_Or_Tagged_Item --
26431 -------------------------------------
26433 function Is_Unconstrained_Or_Tagged_Item
26434 (Item
: Entity_Id
) return Boolean
26436 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
26437 -- Determine whether record type Typ has at least one unconstrained
26440 ---------------------------------
26441 -- Has_Unconstrained_Component --
26442 ---------------------------------
26444 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
26448 Comp
:= First_Component
(Typ
);
26449 while Present
(Comp
) loop
26450 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
26454 Next_Component
(Comp
);
26458 end Has_Unconstrained_Component
;
26462 Typ
: constant Entity_Id
:= Etype
(Item
);
26464 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
26467 if Is_Tagged_Type
(Typ
) then
26470 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
26473 elsif Is_Record_Type
(Typ
) then
26474 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
26477 return Has_Unconstrained_Component
(Typ
);
26480 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
26486 end Is_Unconstrained_Or_Tagged_Item
;
26488 -----------------------------
26489 -- Is_Valid_Assertion_Kind --
26490 -----------------------------
26492 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
26499 Name_Static_Predicate |
26500 Name_Dynamic_Predicate |
26505 Name_Type_Invariant |
26506 Name_uType_Invariant |
26510 Name_Assert_And_Cut |
26512 Name_Contract_Cases |
26514 Name_Default_Initial_Condition |
26516 Name_Initial_Condition |
26519 Name_Loop_Invariant |
26520 Name_Loop_Variant |
26521 Name_Postcondition |
26522 Name_Precondition |
26524 Name_Refined_Post |
26525 Name_Statement_Assertions
=> return True;
26527 when others => return False;
26529 end Is_Valid_Assertion_Kind
;
26531 --------------------------------------
26532 -- Process_Compilation_Unit_Pragmas --
26533 --------------------------------------
26535 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
26537 -- A special check for pragma Suppress_All, a very strange DEC pragma,
26538 -- strange because it comes at the end of the unit. Rational has the
26539 -- same name for a pragma, but treats it as a program unit pragma, In
26540 -- GNAT we just decide to allow it anywhere at all. If it appeared then
26541 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
26542 -- node, and we insert a pragma Suppress (All_Checks) at the start of
26543 -- the context clause to ensure the correct processing.
26545 if Has_Pragma_Suppress_All
(N
) then
26546 Prepend_To
(Context_Items
(N
),
26547 Make_Pragma
(Sloc
(N
),
26548 Chars
=> Name_Suppress
,
26549 Pragma_Argument_Associations
=> New_List
(
26550 Make_Pragma_Argument_Association
(Sloc
(N
),
26551 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
26554 -- Nothing else to do at the current time
26556 end Process_Compilation_Unit_Pragmas
;
26558 ------------------------------------
26559 -- Record_Possible_Body_Reference --
26560 ------------------------------------
26562 procedure Record_Possible_Body_Reference
26563 (State_Id
: Entity_Id
;
26567 Spec_Id
: Entity_Id
;
26570 -- Ensure that we are dealing with a reference to a state
26572 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
26574 -- Climb the tree starting from the reference looking for a package body
26575 -- whose spec declares the referenced state. This criteria automatically
26576 -- excludes references in package specs which are legal. Note that it is
26577 -- not wise to emit an error now as the package body may lack pragma
26578 -- Refined_State or the referenced state may not be mentioned in the
26579 -- refinement. This approach avoids the generation of misleading errors.
26582 while Present
(Context
) loop
26583 if Nkind
(Context
) = N_Package_Body
then
26584 Spec_Id
:= Corresponding_Spec
(Context
);
26586 if Present
(Abstract_States
(Spec_Id
))
26587 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
26589 if No
(Body_References
(State_Id
)) then
26590 Set_Body_References
(State_Id
, New_Elmt_List
);
26593 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
26598 Context
:= Parent
(Context
);
26600 end Record_Possible_Body_Reference
;
26602 ------------------------------
26603 -- Relocate_Pragmas_To_Body --
26604 ------------------------------
26606 procedure Relocate_Pragmas_To_Body
26607 (Subp_Body
: Node_Id
;
26608 Target_Body
: Node_Id
:= Empty
)
26610 procedure Relocate_Pragma
(Prag
: Node_Id
);
26611 -- Remove a single pragma from its current list and add it to the
26612 -- declarations of the proper body (either Subp_Body or Target_Body).
26614 ---------------------
26615 -- Relocate_Pragma --
26616 ---------------------
26618 procedure Relocate_Pragma
(Prag
: Node_Id
) is
26623 -- When subprogram stubs or expression functions are involves, the
26624 -- destination declaration list belongs to the proper body.
26626 if Present
(Target_Body
) then
26627 Target
:= Target_Body
;
26629 Target
:= Subp_Body
;
26632 Decls
:= Declarations
(Target
);
26636 Set_Declarations
(Target
, Decls
);
26639 -- Unhook the pragma from its current list
26642 Prepend
(Prag
, Decls
);
26643 end Relocate_Pragma
;
26647 Body_Id
: constant Entity_Id
:=
26648 Defining_Unit_Name
(Specification
(Subp_Body
));
26649 Next_Stmt
: Node_Id
;
26652 -- Start of processing for Relocate_Pragmas_To_Body
26655 -- Do not process a body that comes from a separate unit as no construct
26656 -- can possibly follow it.
26658 if not Is_List_Member
(Subp_Body
) then
26661 -- Do not relocate pragmas that follow a stub if the stub does not have
26664 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
26665 and then No
(Target_Body
)
26669 -- Do not process internally generated routine _Postconditions
26671 elsif Ekind
(Body_Id
) = E_Procedure
26672 and then Chars
(Body_Id
) = Name_uPostconditions
26677 -- Look at what is following the body. We are interested in certain kind
26678 -- of pragmas (either from source or byproducts of expansion) that can
26679 -- apply to a body [stub].
26681 Stmt
:= Next
(Subp_Body
);
26682 while Present
(Stmt
) loop
26684 -- Preserve the following statement for iteration purposes due to a
26685 -- possible relocation of a pragma.
26687 Next_Stmt
:= Next
(Stmt
);
26689 -- Move a candidate pragma following the body to the declarations of
26692 if Nkind
(Stmt
) = N_Pragma
26693 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
26695 Relocate_Pragma
(Stmt
);
26697 -- Skip internally generated code
26699 elsif not Comes_From_Source
(Stmt
) then
26702 -- No candidate pragmas are available for relocation
26710 end Relocate_Pragmas_To_Body
;
26712 -------------------
26713 -- Resolve_State --
26714 -------------------
26716 procedure Resolve_State
(N
: Node_Id
) is
26721 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26722 Func
:= Entity
(N
);
26724 -- Handle overloading of state names by functions. Traverse the
26725 -- homonym chain looking for an abstract state.
26727 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
26728 State
:= Homonym
(Func
);
26729 while Present
(State
) loop
26731 -- Resolve the overloading by setting the proper entity of the
26732 -- reference to that of the state.
26734 if Ekind
(State
) = E_Abstract_State
then
26735 Set_Etype
(N
, Standard_Void_Type
);
26736 Set_Entity
(N
, State
);
26737 Set_Associated_Node
(N
, State
);
26741 State
:= Homonym
(State
);
26744 -- A function can never act as a state. If the homonym chain does
26745 -- not contain a corresponding state, then something went wrong in
26746 -- the overloading mechanism.
26748 raise Program_Error
;
26753 ----------------------------
26754 -- Rewrite_Assertion_Kind --
26755 ----------------------------
26757 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
26761 if Nkind
(N
) = N_Attribute_Reference
26762 and then Attribute_Name
(N
) = Name_Class
26763 and then Nkind
(Prefix
(N
)) = N_Identifier
26765 case Chars
(Prefix
(N
)) is
26770 when Name_Type_Invariant
=>
26771 Nam
:= Name_uType_Invariant
;
26772 when Name_Invariant
=>
26773 Nam
:= Name_uInvariant
;
26778 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
26780 end Rewrite_Assertion_Kind
;
26788 Dummy
:= Dummy
+ 1;
26791 --------------------------------
26792 -- Set_Encoded_Interface_Name --
26793 --------------------------------
26795 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
26796 Str
: constant String_Id
:= Strval
(S
);
26797 Len
: constant Int
:= String_Length
(Str
);
26802 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
26805 -- Stores encoded value of character code CC. The encoding we use an
26806 -- underscore followed by four lower case hex digits.
26812 procedure Encode
is
26814 Store_String_Char
(Get_Char_Code
('_'));
26816 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
26818 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
26820 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
26822 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
26825 -- Start of processing for Set_Encoded_Interface_Name
26828 -- If first character is asterisk, this is a link name, and we leave it
26829 -- completely unmodified. We also ignore null strings (the latter case
26830 -- happens only in error cases) and no encoding should occur for Java or
26831 -- AAMP interface names.
26834 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
26835 or else VM_Target
/= No_VM
26836 or else AAMP_On_Target
26838 Set_Interface_Name
(E
, S
);
26843 CC
:= Get_String_Char
(Str
, J
);
26845 exit when not In_Character_Range
(CC
);
26847 C
:= Get_Character
(CC
);
26849 exit when C
/= '_' and then C
/= '$'
26850 and then C
not in '0' .. '9'
26851 and then C
not in 'a' .. 'z'
26852 and then C
not in 'A' .. 'Z';
26855 Set_Interface_Name
(E
, S
);
26863 -- Here we need to encode. The encoding we use as follows:
26864 -- three underscores + four hex digits (lower case)
26868 for J
in 1 .. String_Length
(Str
) loop
26869 CC
:= Get_String_Char
(Str
, J
);
26871 if not In_Character_Range
(CC
) then
26874 C
:= Get_Character
(CC
);
26876 if C
= '_' or else C
= '$'
26877 or else C
in '0' .. '9'
26878 or else C
in 'a' .. 'z'
26879 or else C
in 'A' .. 'Z'
26881 Store_String_Char
(CC
);
26888 Set_Interface_Name
(E
,
26889 Make_String_Literal
(Sloc
(S
),
26890 Strval
=> End_String
));
26892 end Set_Encoded_Interface_Name
;
26894 ------------------------
26895 -- Set_Elab_Unit_Name --
26896 ------------------------
26898 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
26903 if Nkind
(N
) = N_Identifier
26904 and then Nkind
(With_Item
) = N_Identifier
26906 Set_Entity
(N
, Entity
(With_Item
));
26908 elsif Nkind
(N
) = N_Selected_Component
then
26909 Change_Selected_Component_To_Expanded_Name
(N
);
26910 Set_Entity
(N
, Entity
(With_Item
));
26911 Set_Entity
(Selector_Name
(N
), Entity
(N
));
26913 Pref
:= Prefix
(N
);
26914 Scop
:= Scope
(Entity
(N
));
26915 while Nkind
(Pref
) = N_Selected_Component
loop
26916 Change_Selected_Component_To_Expanded_Name
(Pref
);
26917 Set_Entity
(Selector_Name
(Pref
), Scop
);
26918 Set_Entity
(Pref
, Scop
);
26919 Pref
:= Prefix
(Pref
);
26920 Scop
:= Scope
(Scop
);
26923 Set_Entity
(Pref
, Scop
);
26926 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
26927 end Set_Elab_Unit_Name
;
26929 -------------------
26930 -- Test_Case_Arg --
26931 -------------------
26933 function Test_Case_Arg
26936 From_Aspect
: Boolean := False) return Node_Id
26938 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
26943 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
26948 -- The caller requests the aspect argument
26950 if From_Aspect
then
26951 if Present
(Aspect
)
26952 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
26954 Args
:= Expression
(Aspect
);
26956 -- "Name" and "Mode" may appear without an identifier as a
26957 -- positional association.
26959 if Present
(Expressions
(Args
)) then
26960 Arg
:= First
(Expressions
(Args
));
26962 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
26970 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
26975 -- Some or all arguments may appear as component associatons
26977 if Present
(Component_Associations
(Args
)) then
26978 Arg
:= First
(Component_Associations
(Args
));
26979 while Present
(Arg
) loop
26980 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
26989 -- Otherwise retrieve the argument directly from the pragma
26992 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
26994 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
26998 -- Skip argument "Name"
27002 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
27006 -- Skip argument "Mode"
27010 -- Arguments "Requires" and "Ensures" are optional and may not be
27013 while Present
(Arg
) loop
27014 if Chars
(Arg
) = Arg_Nam
then