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 if Prag_Id
= Pragma_Atomic
5915 Prag_Id
= Pragma_Shared
5917 Prag_Id
= Pragma_Volatile_Full_Access
5919 Set_Atomic_Full
(E
);
5920 Set_Atomic_Full
(Underlying_Type
(E
));
5921 Set_Atomic_Full
(Base_Type
(E
));
5924 -- Atomic/Shared/Volatile_Full_Access imply Independent
5926 if Prag_Id
/= Pragma_Volatile
then
5927 Set_Is_Independent
(E
);
5928 Set_Is_Independent
(Underlying_Type
(E
));
5929 Set_Is_Independent
(Base_Type
(E
));
5931 if Prag_Id
= Pragma_Independent
then
5932 Record_Independence_Check
(N
, Base_Type
(E
));
5936 -- Attribute belongs on the base type. If the view of the type is
5937 -- currently private, it also belongs on the underlying type.
5939 if Prag_Id
/= Pragma_Independent
then
5940 if Prag_Id
= Pragma_Volatile_Full_Access
then
5941 Set_Has_Volatile_Full_Access
(Base_Type
(E
));
5942 Set_Has_Volatile_Full_Access
(Underlying_Type
(E
));
5945 Set_Is_Volatile
(Base_Type
(E
));
5946 Set_Is_Volatile
(Underlying_Type
(E
));
5948 Set_Treat_As_Volatile
(E
);
5949 Set_Treat_As_Volatile
(Underlying_Type
(E
));
5952 elsif K
= N_Object_Declaration
5953 or else (K
= N_Component_Declaration
5954 and then Original_Record_Component
(E
) = E
)
5956 if Rep_Item_Too_Late
(E
, N
) then
5960 if Prag_Id
= Pragma_Atomic
5962 Prag_Id
= Pragma_Shared
5964 Prag_Id
= Pragma_Volatile_Full_Access
5966 if Prag_Id
= Pragma_Volatile_Full_Access
then
5967 Set_Has_Volatile_Full_Access
(E
);
5972 -- If the object declaration has an explicit initialization, a
5973 -- temporary may have to be created to hold the expression, to
5974 -- ensure that access to the object remain atomic.
5976 if Nkind
(Parent
(E
)) = N_Object_Declaration
5977 and then Present
(Expression
(Parent
(E
)))
5979 Set_Has_Delayed_Freeze
(E
);
5982 -- An interesting improvement here. If an object of composite
5983 -- type X is declared atomic, and the type X isn't, that's a
5984 -- pity, since it may not have appropriate alignment etc. We
5985 -- can rescue this in the special case where the object and
5986 -- type are in the same unit by just setting the type as
5987 -- atomic, so that the back end will process it as atomic.
5989 -- Note: we used to do this for elementary types as well,
5990 -- but that turns out to be a bad idea and can have unwanted
5991 -- effects, most notably if the type is elementary, the object
5992 -- a simple component within a record, and both are in a spec:
5993 -- every object of this type in the entire program will be
5994 -- treated as atomic, thus incurring a potentially costly
5995 -- synchronization operation for every access.
5997 -- For Volatile_Full_Access we can do this for elementary
5998 -- types too, since there is no issue of atomic sync.
6000 -- Of course it would be best if the back end could just adjust
6001 -- the alignment etc for the specific object, but that's not
6002 -- something we are capable of doing at this point.
6004 Utyp
:= Underlying_Type
(Etype
(E
));
6007 and then (Is_Composite_Type
(Utyp
)
6008 or else Prag_Id
= Pragma_Volatile_Full_Access
)
6009 and then Sloc
(E
) > No_Location
6010 and then Sloc
(Utyp
) > No_Location
6012 Get_Source_File_Index
(Sloc
(E
)) =
6013 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
6015 if Prag_Id
= Pragma_Volatile_Full_Access
then
6016 Set_Has_Volatile_Full_Access
6017 (Underlying_Type
(Etype
(E
)));
6020 (Underlying_Type
(Etype
(E
)));
6025 -- Atomic/Shared imply both Independent and Volatile
6027 if Prag_Id
/= Pragma_Volatile
then
6028 Set_Is_Independent
(E
);
6030 if Prag_Id
= Pragma_Independent
then
6031 Record_Independence_Check
(N
, E
);
6035 if Prag_Id
/= Pragma_Independent
then
6036 Set_Is_Volatile
(E
);
6037 Set_Treat_As_Volatile
(E
);
6041 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6044 -- The following check is only relevant when SPARK_Mode is on as
6045 -- this is not a standard Ada legality rule. Pragma Volatile can
6046 -- only apply to a full type declaration or an object declaration
6047 -- (SPARK RM C.6(1)).
6050 and then Prag_Id
= Pragma_Volatile
6051 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6052 N_Object_Declaration
)
6055 ("argument of pragma % must denote a full type or object "
6056 & "declaration", Arg1
);
6058 end Process_Atomic_Independent_Shared_Volatile
;
6060 -------------------------------------------
6061 -- Process_Compile_Time_Warning_Or_Error --
6062 -------------------------------------------
6064 procedure Process_Compile_Time_Warning_Or_Error
is
6065 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6068 Check_Arg_Count
(2);
6069 Check_No_Identifiers
;
6070 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6071 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6073 if Compile_Time_Known_Value
(Arg1x
) then
6074 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6076 Str
: constant String_Id
:=
6077 Strval
(Get_Pragma_Arg
(Arg2
));
6078 Len
: constant Int
:= String_Length
(Str
);
6083 Cent
: constant Entity_Id
:=
6084 Cunit_Entity
(Current_Sem_Unit
);
6086 Force
: constant Boolean :=
6087 Prag_Id
= Pragma_Compile_Time_Warning
6089 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6090 and then (Ekind
(Cent
) /= E_Package
6091 or else not In_Private_Part
(Cent
));
6092 -- Set True if this is the warning case, and we are in the
6093 -- visible part of a package spec, or in a subprogram spec,
6094 -- in which case we want to force the client to see the
6095 -- warning, even though it is not in the main unit.
6098 -- Loop through segments of message separated by line feeds.
6099 -- We output these segments as separate messages with
6100 -- continuation marks for all but the first.
6105 Error_Msg_Strlen
:= 0;
6107 -- Loop to copy characters from argument to error message
6111 exit when Ptr
> Len
;
6112 CC
:= Get_String_Char
(Str
, Ptr
);
6115 -- Ignore wide chars ??? else store character
6117 if In_Character_Range
(CC
) then
6118 C
:= Get_Character
(CC
);
6119 exit when C
= ASCII
.LF
;
6120 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6121 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6125 -- Here with one line ready to go
6127 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6129 -- If this is a warning in a spec, then we want clients
6130 -- to see the warning, so mark the message with the
6131 -- special sequence !! to force the warning. In the case
6132 -- of a package spec, we do not force this if we are in
6133 -- the private part of the spec.
6136 if Cont
= False then
6137 Error_Msg_N
("<<~!!", Arg1
);
6140 Error_Msg_N
("\<<~!!", Arg1
);
6143 -- Error, rather than warning, or in a body, so we do not
6144 -- need to force visibility for client (error will be
6145 -- output in any case, and this is the situation in which
6146 -- we do not want a client to get a warning, since the
6147 -- warning is in the body or the spec private part).
6150 if Cont
= False then
6151 Error_Msg_N
("<<~", Arg1
);
6154 Error_Msg_N
("\<<~", Arg1
);
6158 exit when Ptr
> Len
;
6163 end Process_Compile_Time_Warning_Or_Error
;
6165 ------------------------
6166 -- Process_Convention --
6167 ------------------------
6169 procedure Process_Convention
6170 (C
: out Convention_Id
;
6171 Ent
: out Entity_Id
)
6175 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6176 -- Called if we have more than one Export/Import/Convention pragma.
6177 -- This is generally illegal, but we have a special case of allowing
6178 -- Import and Interface to coexist if they specify the convention in
6179 -- a consistent manner. We are allowed to do this, since Interface is
6180 -- an implementation defined pragma, and we choose to do it since we
6181 -- know Rational allows this combination. S is the entity id of the
6182 -- subprogram in question. This procedure also sets the special flag
6183 -- Import_Interface_Present in both pragmas in the case where we do
6184 -- have matching Import and Interface pragmas.
6186 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6187 -- Set convention in entity E, and also flag that the entity has a
6188 -- convention pragma. If entity is for a private or incomplete type,
6189 -- also set convention and flag on underlying type. This procedure
6190 -- also deals with the special case of C_Pass_By_Copy convention,
6191 -- and error checks for inappropriate convention specification.
6193 -------------------------------
6194 -- Diagnose_Multiple_Pragmas --
6195 -------------------------------
6197 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6198 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6202 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6203 -- Decl is a pragma node. This function returns True if this
6204 -- pragma has a first argument that is an identifier with a
6205 -- Chars field corresponding to the Convention_Id C.
6207 function Same_Name
(Decl
: Node_Id
) return Boolean;
6208 -- Decl is a pragma node. This function returns True if this
6209 -- pragma has a second argument that is an identifier with a
6210 -- Chars field that matches the Chars of the current subprogram.
6212 ---------------------
6213 -- Same_Convention --
6214 ---------------------
6216 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6217 Arg1
: constant Node_Id
:=
6218 First
(Pragma_Argument_Associations
(Decl
));
6221 if Present
(Arg1
) then
6223 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6225 if Nkind
(Arg
) = N_Identifier
6226 and then Is_Convention_Name
(Chars
(Arg
))
6227 and then Get_Convention_Id
(Chars
(Arg
)) = C
6235 end Same_Convention
;
6241 function Same_Name
(Decl
: Node_Id
) return Boolean is
6242 Arg1
: constant Node_Id
:=
6243 First
(Pragma_Argument_Associations
(Decl
));
6251 Arg2
:= Next
(Arg1
);
6258 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6260 if Nkind
(Arg
) = N_Identifier
6261 and then Chars
(Arg
) = Chars
(S
)
6270 -- Start of processing for Diagnose_Multiple_Pragmas
6275 -- Definitely give message if we have Convention/Export here
6277 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6280 -- If we have an Import or Export, scan back from pragma to
6281 -- find any previous pragma applying to the same procedure.
6282 -- The scan will be terminated by the start of the list, or
6283 -- hitting the subprogram declaration. This won't allow one
6284 -- pragma to appear in the public part and one in the private
6285 -- part, but that seems very unlikely in practice.
6289 while Present
(Decl
) and then Decl
/= Pdec
loop
6291 -- Look for pragma with same name as us
6293 if Nkind
(Decl
) = N_Pragma
6294 and then Same_Name
(Decl
)
6296 -- Give error if same as our pragma or Export/Convention
6298 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6304 -- Case of Import/Interface or the other way round
6306 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6309 -- Here we know that we have Import and Interface. It
6310 -- doesn't matter which way round they are. See if
6311 -- they specify the same convention. If so, all OK,
6312 -- and set special flags to stop other messages
6314 if Same_Convention
(Decl
) then
6315 Set_Import_Interface_Present
(N
);
6316 Set_Import_Interface_Present
(Decl
);
6319 -- If different conventions, special message
6322 Error_Msg_Sloc
:= Sloc
(Decl
);
6324 ("convention differs from that given#", Arg1
);
6334 -- Give message if needed if we fall through those tests
6335 -- except on Relaxed_RM_Semantics where we let go: either this
6336 -- is a case accepted/ignored by other Ada compilers (e.g.
6337 -- a mix of Convention and Import), or another error will be
6338 -- generated later (e.g. using both Import and Export).
6340 if Err
and not Relaxed_RM_Semantics
then
6342 ("at most one Convention/Export/Import pragma is allowed",
6345 end Diagnose_Multiple_Pragmas
;
6347 --------------------------------
6348 -- Set_Convention_From_Pragma --
6349 --------------------------------
6351 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6353 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6354 -- for an overridden dispatching operation. Technically this is
6355 -- an amendment and should only be done in Ada 2005 mode. However,
6356 -- this is clearly a mistake, since the problem that is addressed
6357 -- by this AI is that there is a clear gap in the RM.
6359 if Is_Dispatching_Operation
(E
)
6360 and then Present
(Overridden_Operation
(E
))
6361 and then C
/= Convention
(Overridden_Operation
(E
))
6364 ("cannot change convention for overridden dispatching "
6365 & "operation", Arg1
);
6368 -- Special checks for Convention_Stdcall
6370 if C
= Convention_Stdcall
then
6372 -- A dispatching call is not allowed. A dispatching subprogram
6373 -- cannot be used to interface to the Win32 API, so in fact
6374 -- this check does not impose any effective restriction.
6376 if Is_Dispatching_Operation
(E
) then
6377 Error_Msg_Sloc
:= Sloc
(E
);
6379 -- Note: make this unconditional so that if there is more
6380 -- than one call to which the pragma applies, we get a
6381 -- message for each call. Also don't use Error_Pragma,
6382 -- so that we get multiple messages.
6385 ("dispatching subprogram# cannot use Stdcall convention!",
6388 -- Subprograms are not allowed
6390 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6394 and then Ekind
(E
) /= E_Variable
6396 -- An access to subprogram is also allowed
6400 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6402 -- Allow internal call to set convention of subprogram type
6404 and then not (Ekind
(E
) = E_Subprogram_Type
)
6407 ("second argument of pragma% must be subprogram (type)",
6412 -- Set the convention
6414 Set_Convention
(E
, C
);
6415 Set_Has_Convention_Pragma
(E
);
6417 -- For the case of a record base type, also set the convention of
6418 -- any anonymous access types declared in the record which do not
6419 -- currently have a specified convention.
6421 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6426 Comp
:= First_Component
(E
);
6427 while Present
(Comp
) loop
6428 if Present
(Etype
(Comp
))
6429 and then Ekind_In
(Etype
(Comp
),
6430 E_Anonymous_Access_Type
,
6431 E_Anonymous_Access_Subprogram_Type
)
6432 and then not Has_Convention_Pragma
(Comp
)
6434 Set_Convention
(Comp
, C
);
6437 Next_Component
(Comp
);
6442 -- Deal with incomplete/private type case, where underlying type
6443 -- is available, so set convention of that underlying type.
6445 if Is_Incomplete_Or_Private_Type
(E
)
6446 and then Present
(Underlying_Type
(E
))
6448 Set_Convention
(Underlying_Type
(E
), C
);
6449 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6452 -- A class-wide type should inherit the convention of the specific
6453 -- root type (although this isn't specified clearly by the RM).
6455 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6456 Set_Convention
(Class_Wide_Type
(E
), C
);
6459 -- If the entity is a record type, then check for special case of
6460 -- C_Pass_By_Copy, which is treated the same as C except that the
6461 -- special record flag is set. This convention is only permitted
6462 -- on record types (see AI95-00131).
6464 if Cname
= Name_C_Pass_By_Copy
then
6465 if Is_Record_Type
(E
) then
6466 Set_C_Pass_By_Copy
(Base_Type
(E
));
6467 elsif Is_Incomplete_Or_Private_Type
(E
)
6468 and then Is_Record_Type
(Underlying_Type
(E
))
6470 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6473 ("C_Pass_By_Copy convention allowed only for record type",
6478 -- If the entity is a derived boolean type, check for the special
6479 -- case of convention C, C++, or Fortran, where we consider any
6480 -- nonzero value to represent true.
6482 if Is_Discrete_Type
(E
)
6483 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6489 C
= Convention_Fortran
)
6491 Set_Nonzero_Is_True
(Base_Type
(E
));
6493 end Set_Convention_From_Pragma
;
6497 Comp_Unit
: Unit_Number_Type
;
6502 -- Start of processing for Process_Convention
6505 Check_At_Least_N_Arguments
(2);
6506 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6507 Check_Arg_Is_Identifier
(Arg1
);
6508 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6510 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6511 -- tested again below to set the critical flag).
6513 if Cname
= Name_C_Pass_By_Copy
then
6516 -- Otherwise we must have something in the standard convention list
6518 elsif Is_Convention_Name
(Cname
) then
6519 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6521 -- Otherwise warn on unrecognized convention
6524 if Warn_On_Export_Import
then
6526 ("??unrecognized convention name, C assumed",
6527 Get_Pragma_Arg
(Arg1
));
6533 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6534 Check_Arg_Is_Local_Name
(Arg2
);
6536 Id
:= Get_Pragma_Arg
(Arg2
);
6539 if not Is_Entity_Name
(Id
) then
6540 Error_Pragma_Arg
("entity name required", Arg2
);
6545 -- Set entity to return
6549 -- Ada_Pass_By_Copy special checking
6551 if C
= Convention_Ada_Pass_By_Copy
then
6552 if not Is_First_Subtype
(E
) then
6554 ("convention `Ada_Pass_By_Copy` only allowed for types",
6558 if Is_By_Reference_Type
(E
) then
6560 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6564 -- Ada_Pass_By_Reference special checking
6566 elsif C
= Convention_Ada_Pass_By_Reference
then
6567 if not Is_First_Subtype
(E
) then
6569 ("convention `Ada_Pass_By_Reference` only allowed for types",
6573 if Is_By_Copy_Type
(E
) then
6575 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6580 -- Go to renamed subprogram if present, since convention applies to
6581 -- the actual renamed entity, not to the renaming entity. If the
6582 -- subprogram is inherited, go to parent subprogram.
6584 if Is_Subprogram
(E
)
6585 and then Present
(Alias
(E
))
6587 if Nkind
(Parent
(Declaration_Node
(E
))) =
6588 N_Subprogram_Renaming_Declaration
6590 if Scope
(E
) /= Scope
(Alias
(E
)) then
6592 ("cannot apply pragma% to non-local entity&#", E
);
6597 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6598 N_Private_Extension_Declaration
)
6599 and then Scope
(E
) = Scope
(Alias
(E
))
6603 -- Return the parent subprogram the entity was inherited from
6609 -- Check that we are not applying this to a specless body. Relax this
6610 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
6612 if Is_Subprogram
(E
)
6613 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6614 and then not Relaxed_RM_Semantics
6617 ("pragma% requires separate spec and must come before body");
6620 -- Check that we are not applying this to a named constant
6622 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6623 Error_Msg_Name_1
:= Pname
;
6625 ("cannot apply pragma% to named constant!",
6626 Get_Pragma_Arg
(Arg2
));
6628 ("\supply appropriate type for&!", Arg2
);
6631 if Ekind
(E
) = E_Enumeration_Literal
then
6632 Error_Pragma
("enumeration literal not allowed for pragma%");
6635 -- Check for rep item appearing too early or too late
6637 if Etype
(E
) = Any_Type
6638 or else Rep_Item_Too_Early
(E
, N
)
6642 elsif Present
(Underlying_Type
(E
)) then
6643 E
:= Underlying_Type
(E
);
6646 if Rep_Item_Too_Late
(E
, N
) then
6650 if Has_Convention_Pragma
(E
) then
6651 Diagnose_Multiple_Pragmas
(E
);
6653 elsif Convention
(E
) = Convention_Protected
6654 or else Ekind
(Scope
(E
)) = E_Protected_Type
6657 ("a protected operation cannot be given a different convention",
6661 -- For Intrinsic, a subprogram is required
6663 if C
= Convention_Intrinsic
6664 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
6667 ("second argument of pragma% must be a subprogram", Arg2
);
6670 -- Deal with non-subprogram cases
6672 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
6673 Set_Convention_From_Pragma
(E
);
6677 -- The pragma must apply to a first subtype, but it can also
6678 -- apply to a generic type in a generic formal part, in which
6679 -- case it will also appear in the corresponding instance.
6681 if Is_Generic_Type
(E
) or else In_Instance
then
6684 Check_First_Subtype
(Arg2
);
6687 Set_Convention_From_Pragma
(Base_Type
(E
));
6689 -- For access subprograms, we must set the convention on the
6690 -- internally generated directly designated type as well.
6692 if Ekind
(E
) = E_Access_Subprogram_Type
then
6693 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
6697 -- For the subprogram case, set proper convention for all homonyms
6698 -- in same scope and the same declarative part, i.e. the same
6699 -- compilation unit.
6702 Comp_Unit
:= Get_Source_Unit
(E
);
6703 Set_Convention_From_Pragma
(E
);
6705 -- Treat a pragma Import as an implicit body, and pragma import
6706 -- as implicit reference (for navigation in GPS).
6708 if Prag_Id
= Pragma_Import
then
6709 Generate_Reference
(E
, Id
, 'b');
6711 -- For exported entities we restrict the generation of references
6712 -- to entities exported to foreign languages since entities
6713 -- exported to Ada do not provide further information to GPS and
6714 -- add undesired references to the output of the gnatxref tool.
6716 elsif Prag_Id
= Pragma_Export
6717 and then Convention
(E
) /= Convention_Ada
6719 Generate_Reference
(E
, Id
, 'i');
6722 -- If the pragma comes from from an aspect, it only applies to the
6723 -- given entity, not its homonyms.
6725 if From_Aspect_Specification
(N
) then
6729 -- Otherwise Loop through the homonyms of the pragma argument's
6730 -- entity, an apply convention to those in the current scope.
6736 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
6738 -- Ignore entry for which convention is already set
6740 if Has_Convention_Pragma
(E1
) then
6744 -- Do not set the pragma on inherited operations or on formal
6747 if Comes_From_Source
(E1
)
6748 and then Comp_Unit
= Get_Source_Unit
(E1
)
6749 and then not Is_Formal_Subprogram
(E1
)
6750 and then Nkind
(Original_Node
(Parent
(E1
))) /=
6751 N_Full_Type_Declaration
6753 if Present
(Alias
(E1
))
6754 and then Scope
(E1
) /= Scope
(Alias
(E1
))
6757 ("cannot apply pragma% to non-local entity& declared#",
6761 Set_Convention_From_Pragma
(E1
);
6763 if Prag_Id
= Pragma_Import
then
6764 Generate_Reference
(E1
, Id
, 'b');
6772 end Process_Convention
;
6774 ----------------------------------------
6775 -- Process_Disable_Enable_Atomic_Sync --
6776 ----------------------------------------
6778 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
6780 Check_No_Identifiers
;
6781 Check_At_Most_N_Arguments
(1);
6783 -- Modeled internally as
6784 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
6788 Pragma_Identifier
=>
6789 Make_Identifier
(Loc
, Nam
),
6790 Pragma_Argument_Associations
=> New_List
(
6791 Make_Pragma_Argument_Association
(Loc
,
6793 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
6795 if Present
(Arg1
) then
6796 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
6800 end Process_Disable_Enable_Atomic_Sync
;
6802 -------------------------------------------------
6803 -- Process_Extended_Import_Export_Internal_Arg --
6804 -------------------------------------------------
6806 procedure Process_Extended_Import_Export_Internal_Arg
6807 (Arg_Internal
: Node_Id
:= Empty
)
6810 if No
(Arg_Internal
) then
6811 Error_Pragma
("Internal parameter required for pragma%");
6814 if Nkind
(Arg_Internal
) = N_Identifier
then
6817 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
6818 and then (Prag_Id
= Pragma_Import_Function
6820 Prag_Id
= Pragma_Export_Function
)
6826 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
6829 Check_Arg_Is_Local_Name
(Arg_Internal
);
6830 end Process_Extended_Import_Export_Internal_Arg
;
6832 --------------------------------------------------
6833 -- Process_Extended_Import_Export_Object_Pragma --
6834 --------------------------------------------------
6836 procedure Process_Extended_Import_Export_Object_Pragma
6837 (Arg_Internal
: Node_Id
;
6838 Arg_External
: Node_Id
;
6844 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
6845 Def_Id
:= Entity
(Arg_Internal
);
6847 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
6849 ("pragma% must designate an object", Arg_Internal
);
6852 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
6854 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
6857 ("previous Common/Psect_Object applies, pragma % not permitted",
6861 if Rep_Item_Too_Late
(Def_Id
, N
) then
6865 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
6867 if Present
(Arg_Size
) then
6868 Check_Arg_Is_External_Name
(Arg_Size
);
6871 -- Export_Object case
6873 if Prag_Id
= Pragma_Export_Object
then
6874 if not Is_Library_Level_Entity
(Def_Id
) then
6876 ("argument for pragma% must be library level entity",
6880 if Ekind
(Current_Scope
) = E_Generic_Package
then
6881 Error_Pragma
("pragma& cannot appear in a generic unit");
6884 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
6886 ("exported object must have compile time known size",
6890 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
6891 Error_Msg_N
("??duplicate Export_Object pragma", N
);
6893 Set_Exported
(Def_Id
, Arg_Internal
);
6896 -- Import_Object case
6899 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
6901 ("cannot use pragma% for task/protected object",
6905 if Ekind
(Def_Id
) = E_Constant
then
6907 ("cannot import a constant", Arg_Internal
);
6910 if Warn_On_Export_Import
6911 and then Has_Discriminants
(Etype
(Def_Id
))
6914 ("imported value must be initialized??", Arg_Internal
);
6917 if Warn_On_Export_Import
6918 and then Is_Access_Type
(Etype
(Def_Id
))
6921 ("cannot import object of an access type??", Arg_Internal
);
6924 if Warn_On_Export_Import
6925 and then Is_Imported
(Def_Id
)
6927 Error_Msg_N
("??duplicate Import_Object pragma", N
);
6929 -- Check for explicit initialization present. Note that an
6930 -- initialization generated by the code generator, e.g. for an
6931 -- access type, does not count here.
6933 elsif Present
(Expression
(Parent
(Def_Id
)))
6936 (Original_Node
(Expression
(Parent
(Def_Id
))))
6938 Error_Msg_Sloc
:= Sloc
(Def_Id
);
6940 ("imported entities cannot be initialized (RM B.1(24))",
6941 "\no initialization allowed for & declared#", Arg1
);
6943 Set_Imported
(Def_Id
);
6944 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
6947 end Process_Extended_Import_Export_Object_Pragma
;
6949 ------------------------------------------------------
6950 -- Process_Extended_Import_Export_Subprogram_Pragma --
6951 ------------------------------------------------------
6953 procedure Process_Extended_Import_Export_Subprogram_Pragma
6954 (Arg_Internal
: Node_Id
;
6955 Arg_External
: Node_Id
;
6956 Arg_Parameter_Types
: Node_Id
;
6957 Arg_Result_Type
: Node_Id
:= Empty
;
6958 Arg_Mechanism
: Node_Id
;
6959 Arg_Result_Mechanism
: Node_Id
:= Empty
)
6965 Ambiguous
: Boolean;
6968 function Same_Base_Type
6970 Formal
: Entity_Id
) return Boolean;
6971 -- Determines if Ptype references the type of Formal. Note that only
6972 -- the base types need to match according to the spec. Ptype here is
6973 -- the argument from the pragma, which is either a type name, or an
6974 -- access attribute.
6976 --------------------
6977 -- Same_Base_Type --
6978 --------------------
6980 function Same_Base_Type
6982 Formal
: Entity_Id
) return Boolean
6984 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
6988 -- Case where pragma argument is typ'Access
6990 if Nkind
(Ptype
) = N_Attribute_Reference
6991 and then Attribute_Name
(Ptype
) = Name_Access
6993 Pref
:= Prefix
(Ptype
);
6996 if not Is_Entity_Name
(Pref
)
6997 or else Entity
(Pref
) = Any_Type
7002 -- We have a match if the corresponding argument is of an
7003 -- anonymous access type, and its designated type matches the
7004 -- type of the prefix of the access attribute
7006 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7007 and then Base_Type
(Entity
(Pref
)) =
7008 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7010 -- Case where pragma argument is a type name
7015 if not Is_Entity_Name
(Ptype
)
7016 or else Entity
(Ptype
) = Any_Type
7021 -- We have a match if the corresponding argument is of the type
7022 -- given in the pragma (comparing base types)
7024 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7028 -- Start of processing for
7029 -- Process_Extended_Import_Export_Subprogram_Pragma
7032 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7036 -- Loop through homonyms (overloadings) of the entity
7038 Hom_Id
:= Entity
(Arg_Internal
);
7039 while Present
(Hom_Id
) loop
7040 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7042 -- We need a subprogram in the current scope
7044 if not Is_Subprogram
(Def_Id
)
7045 or else Scope
(Def_Id
) /= Current_Scope
7052 -- Pragma cannot apply to subprogram body
7054 if Is_Subprogram
(Def_Id
)
7055 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7059 ("pragma% requires separate spec"
7060 & " and must come before body");
7063 -- Test result type if given, note that the result type
7064 -- parameter can only be present for the function cases.
7066 if Present
(Arg_Result_Type
)
7067 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7071 elsif Etype
(Def_Id
) /= Standard_Void_Type
7073 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7077 -- Test parameter types if given. Note that this parameter
7078 -- has not been analyzed (and must not be, since it is
7079 -- semantic nonsense), so we get it as the parser left it.
7081 elsif Present
(Arg_Parameter_Types
) then
7082 Check_Matching_Types
: declare
7087 Formal
:= First_Formal
(Def_Id
);
7089 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7090 if Present
(Formal
) then
7094 -- A list of one type, e.g. (List) is parsed as
7095 -- a parenthesized expression.
7097 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7098 and then Paren_Count
(Arg_Parameter_Types
) = 1
7101 or else Present
(Next_Formal
(Formal
))
7106 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7109 -- A list of more than one type is parsed as a aggregate
7111 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7112 and then Paren_Count
(Arg_Parameter_Types
) = 0
7114 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7115 while Present
(Ptype
) or else Present
(Formal
) loop
7118 or else not Same_Base_Type
(Ptype
, Formal
)
7123 Next_Formal
(Formal
);
7128 -- Anything else is of the wrong form
7132 ("wrong form for Parameter_Types parameter",
7133 Arg_Parameter_Types
);
7135 end Check_Matching_Types
;
7138 -- Match is now False if the entry we found did not match
7139 -- either a supplied Parameter_Types or Result_Types argument
7145 -- Ambiguous case, the flag Ambiguous shows if we already
7146 -- detected this and output the initial messages.
7149 if not Ambiguous
then
7151 Error_Msg_Name_1
:= Pname
;
7153 ("pragma% does not uniquely identify subprogram!",
7155 Error_Msg_Sloc
:= Sloc
(Ent
);
7156 Error_Msg_N
("matching subprogram #!", N
);
7160 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7161 Error_Msg_N
("matching subprogram #!", N
);
7166 Hom_Id
:= Homonym
(Hom_Id
);
7169 -- See if we found an entry
7172 if not Ambiguous
then
7173 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7175 ("pragma% cannot be given for generic subprogram");
7178 ("pragma% does not identify local subprogram");
7185 -- Import pragmas must be for imported entities
7187 if Prag_Id
= Pragma_Import_Function
7189 Prag_Id
= Pragma_Import_Procedure
7191 Prag_Id
= Pragma_Import_Valued_Procedure
7193 if not Is_Imported
(Ent
) then
7195 ("pragma Import or Interface must precede pragma%");
7198 -- Here we have the Export case which can set the entity as exported
7200 -- But does not do so if the specified external name is null, since
7201 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7202 -- compatible) to request no external name.
7204 elsif Nkind
(Arg_External
) = N_String_Literal
7205 and then String_Length
(Strval
(Arg_External
)) = 0
7209 -- In all other cases, set entity as exported
7212 Set_Exported
(Ent
, Arg_Internal
);
7215 -- Special processing for Valued_Procedure cases
7217 if Prag_Id
= Pragma_Import_Valued_Procedure
7219 Prag_Id
= Pragma_Export_Valued_Procedure
7221 Formal
:= First_Formal
(Ent
);
7224 Error_Pragma
("at least one parameter required for pragma%");
7226 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7227 Error_Pragma
("first parameter must have mode out for pragma%");
7230 Set_Is_Valued_Procedure
(Ent
);
7234 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7236 -- Process Result_Mechanism argument if present. We have already
7237 -- checked that this is only allowed for the function case.
7239 if Present
(Arg_Result_Mechanism
) then
7240 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7243 -- Process Mechanism parameter if present. Note that this parameter
7244 -- is not analyzed, and must not be analyzed since it is semantic
7245 -- nonsense, so we get it in exactly as the parser left it.
7247 if Present
(Arg_Mechanism
) then
7255 -- A single mechanism association without a formal parameter
7256 -- name is parsed as a parenthesized expression. All other
7257 -- cases are parsed as aggregates, so we rewrite the single
7258 -- parameter case as an aggregate for consistency.
7260 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7261 and then Paren_Count
(Arg_Mechanism
) = 1
7263 Rewrite
(Arg_Mechanism
,
7264 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7265 Expressions
=> New_List
(
7266 Relocate_Node
(Arg_Mechanism
))));
7269 -- Case of only mechanism name given, applies to all formals
7271 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7272 Formal
:= First_Formal
(Ent
);
7273 while Present
(Formal
) loop
7274 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7275 Next_Formal
(Formal
);
7278 -- Case of list of mechanism associations given
7281 if Null_Record_Present
(Arg_Mechanism
) then
7283 ("inappropriate form for Mechanism parameter",
7287 -- Deal with positional ones first
7289 Formal
:= First_Formal
(Ent
);
7291 if Present
(Expressions
(Arg_Mechanism
)) then
7292 Mname
:= First
(Expressions
(Arg_Mechanism
));
7293 while Present
(Mname
) loop
7296 ("too many mechanism associations", Mname
);
7299 Set_Mechanism_Value
(Formal
, Mname
);
7300 Next_Formal
(Formal
);
7305 -- Deal with named entries
7307 if Present
(Component_Associations
(Arg_Mechanism
)) then
7308 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7309 while Present
(Massoc
) loop
7310 Choice
:= First
(Choices
(Massoc
));
7312 if Nkind
(Choice
) /= N_Identifier
7313 or else Present
(Next
(Choice
))
7316 ("incorrect form for mechanism association",
7320 Formal
:= First_Formal
(Ent
);
7324 ("parameter name & not present", Choice
);
7327 if Chars
(Choice
) = Chars
(Formal
) then
7329 (Formal
, Expression
(Massoc
));
7331 -- Set entity on identifier (needed by ASIS)
7333 Set_Entity
(Choice
, Formal
);
7338 Next_Formal
(Formal
);
7347 end Process_Extended_Import_Export_Subprogram_Pragma
;
7349 --------------------------
7350 -- Process_Generic_List --
7351 --------------------------
7353 procedure Process_Generic_List
is
7358 Check_No_Identifiers
;
7359 Check_At_Least_N_Arguments
(1);
7361 -- Check all arguments are names of generic units or instances
7364 while Present
(Arg
) loop
7365 Exp
:= Get_Pragma_Arg
(Arg
);
7368 if not Is_Entity_Name
(Exp
)
7370 (not Is_Generic_Instance
(Entity
(Exp
))
7372 not Is_Generic_Unit
(Entity
(Exp
)))
7375 ("pragma% argument must be name of generic unit/instance",
7381 end Process_Generic_List
;
7383 ------------------------------------
7384 -- Process_Import_Predefined_Type --
7385 ------------------------------------
7387 procedure Process_Import_Predefined_Type
is
7388 Loc
: constant Source_Ptr
:= Sloc
(N
);
7390 Ftyp
: Node_Id
:= Empty
;
7396 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7399 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7400 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7404 Ftyp
:= Node
(Elmt
);
7406 if Present
(Ftyp
) then
7408 -- Don't build a derived type declaration, because predefined C
7409 -- types have no declaration anywhere, so cannot really be named.
7410 -- Instead build a full type declaration, starting with an
7411 -- appropriate type definition is built
7413 if Is_Floating_Point_Type
(Ftyp
) then
7414 Def
:= Make_Floating_Point_Definition
(Loc
,
7415 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7416 Make_Real_Range_Specification
(Loc
,
7417 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7418 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7420 -- Should never have a predefined type we cannot handle
7423 raise Program_Error
;
7426 -- Build and insert a Full_Type_Declaration, which will be
7427 -- analyzed as soon as this list entry has been analyzed.
7429 Decl
:= Make_Full_Type_Declaration
(Loc
,
7430 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7431 Type_Definition
=> Def
);
7433 Insert_After
(N
, Decl
);
7434 Mark_Rewrite_Insertion
(Decl
);
7437 Error_Pragma_Arg
("no matching type found for pragma%",
7440 end Process_Import_Predefined_Type
;
7442 ---------------------------------
7443 -- Process_Import_Or_Interface --
7444 ---------------------------------
7446 procedure Process_Import_Or_Interface
is
7452 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7453 -- pragma Import (Entity, "external name");
7455 if Relaxed_RM_Semantics
7456 and then Arg_Count
= 2
7457 and then Prag_Id
= Pragma_Import
7458 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7461 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7464 if not Is_Entity_Name
(Def_Id
) then
7465 Error_Pragma_Arg
("entity name required", Arg1
);
7468 Def_Id
:= Entity
(Def_Id
);
7469 Kill_Size_Check_Code
(Def_Id
);
7470 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7473 Process_Convention
(C
, Def_Id
);
7474 Kill_Size_Check_Code
(Def_Id
);
7475 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7478 -- Various error checks
7480 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7482 -- We do not permit Import to apply to a renaming declaration
7484 if Present
(Renamed_Object
(Def_Id
)) then
7486 ("pragma% not allowed for object renaming", Arg2
);
7488 -- User initialization is not allowed for imported object, but
7489 -- the object declaration may contain a default initialization,
7490 -- that will be discarded. Note that an explicit initialization
7491 -- only counts if it comes from source, otherwise it is simply
7492 -- the code generator making an implicit initialization explicit.
7494 elsif Present
(Expression
(Parent
(Def_Id
)))
7495 and then Comes_From_Source
7496 (Original_Node
(Expression
(Parent
(Def_Id
))))
7498 -- Set imported flag to prevent cascaded errors
7500 Set_Is_Imported
(Def_Id
);
7502 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7504 ("no initialization allowed for declaration of& #",
7505 "\imported entities cannot be initialized (RM B.1(24))",
7509 -- If the pragma comes from an aspect specification the
7510 -- Is_Imported flag has already been set.
7512 if not From_Aspect_Specification
(N
) then
7513 Set_Imported
(Def_Id
);
7516 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7518 -- Note that we do not set Is_Public here. That's because we
7519 -- only want to set it if there is no address clause, and we
7520 -- don't know that yet, so we delay that processing till
7523 -- pragma Import completes deferred constants
7525 if Ekind
(Def_Id
) = E_Constant
then
7526 Set_Has_Completion
(Def_Id
);
7529 -- It is not possible to import a constant of an unconstrained
7530 -- array type (e.g. string) because there is no simple way to
7531 -- write a meaningful subtype for it.
7533 if Is_Array_Type
(Etype
(Def_Id
))
7534 and then not Is_Constrained
(Etype
(Def_Id
))
7537 ("imported constant& must have a constrained subtype",
7542 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7544 -- If the name is overloaded, pragma applies to all of the denoted
7545 -- entities in the same declarative part, unless the pragma comes
7546 -- from an aspect specification or was generated by the compiler
7547 -- (such as for pragma Provide_Shift_Operators).
7550 while Present
(Hom_Id
) loop
7552 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7554 -- Ignore inherited subprograms because the pragma will apply
7555 -- to the parent operation, which is the one called.
7557 if Is_Overloadable
(Def_Id
)
7558 and then Present
(Alias
(Def_Id
))
7562 -- If it is not a subprogram, it must be in an outer scope and
7563 -- pragma does not apply.
7565 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7568 -- The pragma does not apply to primitives of interfaces
7570 elsif Is_Dispatching_Operation
(Def_Id
)
7571 and then Present
(Find_Dispatching_Type
(Def_Id
))
7572 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
7576 -- Verify that the homonym is in the same declarative part (not
7577 -- just the same scope). If the pragma comes from an aspect
7578 -- specification we know that it is part of the declaration.
7580 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
7581 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
7582 and then not From_Aspect_Specification
(N
)
7587 -- If the pragma comes from an aspect specification the
7588 -- Is_Imported flag has already been set.
7590 if not From_Aspect_Specification
(N
) then
7591 Set_Imported
(Def_Id
);
7594 -- Reject an Import applied to an abstract subprogram
7596 if Is_Subprogram
(Def_Id
)
7597 and then Is_Abstract_Subprogram
(Def_Id
)
7599 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7601 ("cannot import abstract subprogram& declared#",
7605 -- Special processing for Convention_Intrinsic
7607 if C
= Convention_Intrinsic
then
7609 -- Link_Name argument not allowed for intrinsic
7613 Set_Is_Intrinsic_Subprogram
(Def_Id
);
7615 -- If no external name is present, then check that this
7616 -- is a valid intrinsic subprogram. If an external name
7617 -- is present, then this is handled by the back end.
7620 Check_Intrinsic_Subprogram
7621 (Def_Id
, Get_Pragma_Arg
(Arg2
));
7625 -- Verify that the subprogram does not have a completion
7626 -- through a renaming declaration. For other completions the
7627 -- pragma appears as a too late representation.
7630 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
7634 and then Nkind
(Decl
) = N_Subprogram_Declaration
7635 and then Present
(Corresponding_Body
(Decl
))
7636 and then Nkind
(Unit_Declaration_Node
7637 (Corresponding_Body
(Decl
))) =
7638 N_Subprogram_Renaming_Declaration
7640 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7642 ("cannot import&, renaming already provided for "
7643 & "declaration #", N
, Def_Id
);
7647 -- If the pragma comes from an aspect specification, there
7648 -- must be an Import aspect specified as well. In the rare
7649 -- case where Import is set to False, the suprogram needs to
7650 -- have a local completion.
7653 Imp_Aspect
: constant Node_Id
:=
7654 Find_Aspect
(Def_Id
, Aspect_Import
);
7658 if Present
(Imp_Aspect
)
7659 and then Present
(Expression
(Imp_Aspect
))
7661 Expr
:= Expression
(Imp_Aspect
);
7662 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
7664 if Is_Entity_Name
(Expr
)
7665 and then Entity
(Expr
) = Standard_True
7667 Set_Has_Completion
(Def_Id
);
7670 -- If there is no expression, the default is True, as for
7671 -- all boolean aspects. Same for the older pragma.
7674 Set_Has_Completion
(Def_Id
);
7678 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7681 if Is_Compilation_Unit
(Hom_Id
) then
7683 -- Its possible homonyms are not affected by the pragma.
7684 -- Such homonyms might be present in the context of other
7685 -- units being compiled.
7689 elsif From_Aspect_Specification
(N
) then
7692 -- If the pragma was created by the compiler, then we don't
7693 -- want it to apply to other homonyms. This kind of case can
7694 -- occur when using pragma Provide_Shift_Operators, which
7695 -- generates implicit shift and rotate operators with Import
7696 -- pragmas that might apply to earlier explicit or implicit
7697 -- declarations marked with Import (for example, coming from
7698 -- an earlier pragma Provide_Shift_Operators for another type),
7699 -- and we don't generally want other homonyms being treated
7700 -- as imported or the pragma flagged as an illegal duplicate.
7702 elsif not Comes_From_Source
(N
) then
7706 Hom_Id
:= Homonym
(Hom_Id
);
7710 -- When the convention is Java or CIL, we also allow Import to
7711 -- be given for packages, generic packages, exceptions, record
7712 -- components, and access to subprograms.
7714 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
7716 (Is_Package_Or_Generic_Package
(Def_Id
)
7717 or else Ekind
(Def_Id
) = E_Exception
7718 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
7719 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
7721 Set_Imported
(Def_Id
);
7722 Set_Is_Public
(Def_Id
);
7723 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7725 -- Import a CPP class
7727 elsif C
= Convention_CPP
7728 and then (Is_Record_Type
(Def_Id
)
7729 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
7731 if Ekind
(Def_Id
) = E_Incomplete_Type
then
7732 if Present
(Full_View
(Def_Id
)) then
7733 Def_Id
:= Full_View
(Def_Id
);
7737 ("cannot import 'C'P'P type before full declaration seen",
7738 Get_Pragma_Arg
(Arg2
));
7740 -- Although we have reported the error we decorate it as
7741 -- CPP_Class to avoid reporting spurious errors
7743 Set_Is_CPP_Class
(Def_Id
);
7748 -- Types treated as CPP classes must be declared limited (note:
7749 -- this used to be a warning but there is no real benefit to it
7750 -- since we did effectively intend to treat the type as limited
7753 if not Is_Limited_Type
(Def_Id
) then
7755 ("imported 'C'P'P type must be limited",
7756 Get_Pragma_Arg
(Arg2
));
7759 if Etype
(Def_Id
) /= Def_Id
7760 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
7762 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
7765 Set_Is_CPP_Class
(Def_Id
);
7767 -- Imported CPP types must not have discriminants (because C++
7768 -- classes do not have discriminants).
7770 if Has_Discriminants
(Def_Id
) then
7772 ("imported 'C'P'P type cannot have discriminants",
7773 First
(Discriminant_Specifications
7774 (Declaration_Node
(Def_Id
))));
7777 -- Check that components of imported CPP types do not have default
7778 -- expressions. For private types this check is performed when the
7779 -- full view is analyzed (see Process_Full_View).
7781 if not Is_Private_Type
(Def_Id
) then
7782 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
7785 -- Import a CPP exception
7787 elsif C
= Convention_CPP
7788 and then Ekind
(Def_Id
) = E_Exception
7792 ("'External_'Name arguments is required for 'Cpp exception",
7795 -- As only a string is allowed, Check_Arg_Is_External_Name
7798 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
7801 if Present
(Arg4
) then
7803 ("Link_Name argument not allowed for imported Cpp exception",
7807 -- Do not call Set_Interface_Name as the name of the exception
7808 -- shouldn't be modified (and in particular it shouldn't be
7809 -- the External_Name). For exceptions, the External_Name is the
7810 -- name of the RTTI structure.
7812 -- ??? Emit an error if pragma Import/Export_Exception is present
7814 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
7816 Check_Arg_Count
(3);
7817 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
7819 Process_Import_Predefined_Type
;
7823 ("second argument of pragma% must be object, subprogram "
7824 & "or incomplete type",
7828 -- If this pragma applies to a compilation unit, then the unit, which
7829 -- is a subprogram, does not require (or allow) a body. We also do
7830 -- not need to elaborate imported procedures.
7832 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
7834 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
7836 Set_Body_Required
(Cunit
, False);
7839 end Process_Import_Or_Interface
;
7841 --------------------
7842 -- Process_Inline --
7843 --------------------
7845 procedure Process_Inline
(Status
: Inline_Status
) is
7852 procedure Make_Inline
(Subp
: Entity_Id
);
7853 -- Subp is the defining unit name of the subprogram declaration. Set
7854 -- the flag, as well as the flag in the corresponding body, if there
7857 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
7858 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
7859 -- Has_Pragma_Inline_Always for the Inline_Always case.
7861 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
7862 -- Returns True if it can be determined at this stage that inlining
7863 -- is not possible, for example if the body is available and contains
7864 -- exception handlers, we prevent inlining, since otherwise we can
7865 -- get undefined symbols at link time. This function also emits a
7866 -- warning if front-end inlining is enabled and the pragma appears
7869 -- ??? is business with link symbols still valid, or does it relate
7870 -- to front end ZCX which is being phased out ???
7872 ---------------------------
7873 -- Inlining_Not_Possible --
7874 ---------------------------
7876 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
7877 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
7881 if Nkind
(Decl
) = N_Subprogram_Body
then
7882 Stats
:= Handled_Statement_Sequence
(Decl
);
7883 return Present
(Exception_Handlers
(Stats
))
7884 or else Present
(At_End_Proc
(Stats
));
7886 elsif Nkind
(Decl
) = N_Subprogram_Declaration
7887 and then Present
(Corresponding_Body
(Decl
))
7889 if Front_End_Inlining
7890 and then Analyzed
(Corresponding_Body
(Decl
))
7892 Error_Msg_N
("pragma appears too late, ignored??", N
);
7895 -- If the subprogram is a renaming as body, the body is just a
7896 -- call to the renamed subprogram, and inlining is trivially
7900 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
7901 N_Subprogram_Renaming_Declaration
7907 Handled_Statement_Sequence
7908 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
7911 Present
(Exception_Handlers
(Stats
))
7912 or else Present
(At_End_Proc
(Stats
));
7916 -- If body is not available, assume the best, the check is
7917 -- performed again when compiling enclosing package bodies.
7921 end Inlining_Not_Possible
;
7927 procedure Make_Inline
(Subp
: Entity_Id
) is
7928 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
7929 Inner_Subp
: Entity_Id
:= Subp
;
7932 -- Ignore if bad type, avoid cascaded error
7934 if Etype
(Subp
) = Any_Type
then
7938 -- If inlining is not possible, for now do not treat as an error
7940 elsif Status
/= Suppressed
7941 and then Inlining_Not_Possible
(Subp
)
7946 -- Here we have a candidate for inlining, but we must exclude
7947 -- derived operations. Otherwise we would end up trying to inline
7948 -- a phantom declaration, and the result would be to drag in a
7949 -- body which has no direct inlining associated with it. That
7950 -- would not only be inefficient but would also result in the
7951 -- backend doing cross-unit inlining in cases where it was
7952 -- definitely inappropriate to do so.
7954 -- However, a simple Comes_From_Source test is insufficient, since
7955 -- we do want to allow inlining of generic instances which also do
7956 -- not come from source. We also need to recognize specs generated
7957 -- by the front-end for bodies that carry the pragma. Finally,
7958 -- predefined operators do not come from source but are not
7959 -- inlineable either.
7961 elsif Is_Generic_Instance
(Subp
)
7962 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
7966 elsif not Comes_From_Source
(Subp
)
7967 and then Scope
(Subp
) /= Standard_Standard
7973 -- The referenced entity must either be the enclosing entity, or
7974 -- an entity declared within the current open scope.
7976 if Present
(Scope
(Subp
))
7977 and then Scope
(Subp
) /= Current_Scope
7978 and then Subp
/= Current_Scope
7981 ("argument of% must be entity in current scope", Assoc
);
7985 -- Processing for procedure, operator or function. If subprogram
7986 -- is aliased (as for an instance) indicate that the renamed
7987 -- entity (if declared in the same unit) is inlined.
7989 if Is_Subprogram
(Subp
) then
7990 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
7992 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
7993 Set_Inline_Flags
(Inner_Subp
);
7995 Decl
:= Parent
(Parent
(Inner_Subp
));
7997 if Nkind
(Decl
) = N_Subprogram_Declaration
7998 and then Present
(Corresponding_Body
(Decl
))
8000 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8002 elsif Is_Generic_Instance
(Subp
) then
8004 -- Indicate that the body needs to be created for
8005 -- inlining subsequent calls. The instantiation node
8006 -- follows the declaration of the wrapper package
8009 if Scope
(Subp
) /= Standard_Standard
8011 Need_Subprogram_Instance_Body
8012 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8018 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8019 -- appear in a formal part to apply to a formal subprogram.
8020 -- Do not apply check within an instance or a formal package
8021 -- the test will have been applied to the original generic.
8023 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8024 and then List_Containing
(Decl
) = List_Containing
(N
)
8025 and then not In_Instance
8028 ("Inline cannot apply to a formal subprogram", N
);
8030 -- If Subp is a renaming, it is the renamed entity that
8031 -- will appear in any call, and be inlined. However, for
8032 -- ASIS uses it is convenient to indicate that the renaming
8033 -- itself is an inlined subprogram, so that some gnatcheck
8034 -- rules can be applied in the absence of expansion.
8036 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8037 Set_Inline_Flags
(Subp
);
8043 -- For a generic subprogram set flag as well, for use at the point
8044 -- of instantiation, to determine whether the body should be
8047 elsif Is_Generic_Subprogram
(Subp
) then
8048 Set_Inline_Flags
(Subp
);
8051 -- Literals are by definition inlined
8053 elsif Kind
= E_Enumeration_Literal
then
8056 -- Anything else is an error
8060 ("expect subprogram name for pragma%", Assoc
);
8064 ----------------------
8065 -- Set_Inline_Flags --
8066 ----------------------
8068 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8070 -- First set the Has_Pragma_XXX flags and issue the appropriate
8071 -- errors and warnings for suspicious combinations.
8073 if Prag_Id
= Pragma_No_Inline
then
8074 if Has_Pragma_Inline_Always
(Subp
) then
8076 ("Inline_Always and No_Inline are mutually exclusive", N
);
8077 elsif Has_Pragma_Inline
(Subp
) then
8079 ("Inline and No_Inline both specified for& ??",
8080 N
, Entity
(Subp_Id
));
8083 Set_Has_Pragma_No_Inline
(Subp
);
8085 if Prag_Id
= Pragma_Inline_Always
then
8086 if Has_Pragma_No_Inline
(Subp
) then
8088 ("Inline_Always and No_Inline are mutually exclusive",
8092 Set_Has_Pragma_Inline_Always
(Subp
);
8094 if Has_Pragma_No_Inline
(Subp
) then
8096 ("Inline and No_Inline both specified for& ??",
8097 N
, Entity
(Subp_Id
));
8101 if not Has_Pragma_Inline
(Subp
) then
8102 Set_Has_Pragma_Inline
(Subp
);
8106 -- Then adjust the Is_Inlined flag. It can never be set if the
8107 -- subprogram is subject to pragma No_Inline.
8111 Set_Is_Inlined
(Subp
, False);
8115 if not Has_Pragma_No_Inline
(Subp
) then
8116 Set_Is_Inlined
(Subp
, True);
8119 end Set_Inline_Flags
;
8121 -- Start of processing for Process_Inline
8124 Check_No_Identifiers
;
8125 Check_At_Least_N_Arguments
(1);
8127 if Status
= Enabled
then
8128 Inline_Processing_Required
:= True;
8132 while Present
(Assoc
) loop
8133 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8137 if Is_Entity_Name
(Subp_Id
) then
8138 Subp
:= Entity
(Subp_Id
);
8140 if Subp
= Any_Id
then
8142 -- If previous error, avoid cascaded errors
8144 Check_Error_Detected
;
8150 -- For the pragma case, climb homonym chain. This is
8151 -- what implements allowing the pragma in the renaming
8152 -- case, with the result applying to the ancestors, and
8153 -- also allows Inline to apply to all previous homonyms.
8155 if not From_Aspect_Specification
(N
) then
8156 while Present
(Homonym
(Subp
))
8157 and then Scope
(Homonym
(Subp
)) = Current_Scope
8159 Make_Inline
(Homonym
(Subp
));
8160 Subp
:= Homonym
(Subp
);
8167 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
8174 ----------------------------
8175 -- Process_Interface_Name --
8176 ----------------------------
8178 procedure Process_Interface_Name
8179 (Subprogram_Def
: Entity_Id
;
8185 String_Val
: String_Id
;
8187 procedure Check_Form_Of_Interface_Name
8189 Ext_Name_Case
: Boolean);
8190 -- SN is a string literal node for an interface name. This routine
8191 -- performs some minimal checks that the name is reasonable. In
8192 -- particular that no spaces or other obviously incorrect characters
8193 -- appear. This is only a warning, since any characters are allowed.
8194 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8196 ----------------------------------
8197 -- Check_Form_Of_Interface_Name --
8198 ----------------------------------
8200 procedure Check_Form_Of_Interface_Name
8202 Ext_Name_Case
: Boolean)
8204 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8205 SL
: constant Nat
:= String_Length
(S
);
8210 Error_Msg_N
("interface name cannot be null string", SN
);
8213 for J
in 1 .. SL
loop
8214 C
:= Get_String_Char
(S
, J
);
8216 -- Look for dubious character and issue unconditional warning.
8217 -- Definitely dubious if not in character range.
8219 if not In_Character_Range
(C
)
8221 -- For all cases except CLI target,
8222 -- commas, spaces and slashes are dubious (in CLI, we use
8223 -- commas and backslashes in external names to specify
8224 -- assembly version and public key, while slashes and spaces
8225 -- can be used in names to mark nested classes and
8228 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8229 and then (Get_Character
(C
) = ','
8231 Get_Character
(C
) = '\'))
8232 or else (VM_Target
/= CLI_Target
8233 and then (Get_Character
(C
) = ' '
8235 Get_Character
(C
) = '/'))
8238 ("??interface name contains illegal character",
8239 Sloc
(SN
) + Source_Ptr
(J
));
8242 end Check_Form_Of_Interface_Name
;
8244 -- Start of processing for Process_Interface_Name
8247 if No
(Link_Arg
) then
8248 if No
(Ext_Arg
) then
8249 if VM_Target
= CLI_Target
8250 and then Ekind
(Subprogram_Def
) = E_Package
8251 and then Nkind
(Parent
(Subprogram_Def
)) =
8252 N_Package_Specification
8253 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8258 (Generic_Parent
(Parent
(Subprogram_Def
))));
8263 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8265 Link_Nam
:= Expression
(Ext_Arg
);
8268 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8269 Ext_Nam
:= Expression
(Ext_Arg
);
8274 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8275 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8276 Ext_Nam
:= Expression
(Ext_Arg
);
8277 Link_Nam
:= Expression
(Link_Arg
);
8280 -- Check expressions for external name and link name are static
8282 if Present
(Ext_Nam
) then
8283 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8284 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8286 -- Verify that external name is not the name of a local entity,
8287 -- which would hide the imported one and could lead to run-time
8288 -- surprises. The problem can only arise for entities declared in
8289 -- a package body (otherwise the external name is fully qualified
8290 -- and will not conflict).
8298 if Prag_Id
= Pragma_Import
then
8299 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8301 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
8303 if Nam
/= Chars
(Subprogram_Def
)
8304 and then Present
(E
)
8305 and then not Is_Overloadable
(E
)
8306 and then Is_Immediately_Visible
(E
)
8307 and then not Is_Imported
(E
)
8308 and then Ekind
(Scope
(E
)) = E_Package
8311 while Present
(Par
) loop
8312 if Nkind
(Par
) = N_Package_Body
then
8313 Error_Msg_Sloc
:= Sloc
(E
);
8315 ("imported entity is hidden by & declared#",
8320 Par
:= Parent
(Par
);
8327 if Present
(Link_Nam
) then
8328 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8329 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8332 -- If there is no link name, just set the external name
8334 if No
(Link_Nam
) then
8335 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8337 -- For the Link_Name case, the given literal is preceded by an
8338 -- asterisk, which indicates to GCC that the given name should be
8339 -- taken literally, and in particular that no prepending of
8340 -- underlines should occur, even in systems where this is the
8346 if VM_Target
= No_VM
then
8347 Store_String_Char
(Get_Char_Code
('*'));
8350 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8351 Store_String_Chars
(String_Val
);
8353 Make_String_Literal
(Sloc
(Link_Nam
),
8354 Strval
=> End_String
);
8357 -- Set the interface name. If the entity is a generic instance, use
8358 -- its alias, which is the callable entity.
8360 if Is_Generic_Instance
(Subprogram_Def
) then
8361 Set_Encoded_Interface_Name
8362 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8364 Set_Encoded_Interface_Name
8365 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8368 -- We allow duplicated export names in CIL/Java, as they are always
8369 -- enclosed in a namespace that differentiates them, and overloaded
8370 -- entities are supported by the VM.
8372 if Convention
(Subprogram_Def
) /= Convention_CIL
8374 Convention
(Subprogram_Def
) /= Convention_Java
8376 Check_Duplicated_Export_Name
(Link_Nam
);
8378 end Process_Interface_Name
;
8380 -----------------------------------------
8381 -- Process_Interrupt_Or_Attach_Handler --
8382 -----------------------------------------
8384 procedure Process_Interrupt_Or_Attach_Handler
is
8385 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8386 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8387 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8390 Set_Is_Interrupt_Handler
(Handler_Proc
);
8392 -- If the pragma is not associated with a handler procedure within a
8393 -- protected type, then it must be for a nonprotected procedure for
8394 -- the AAMP target, in which case we don't associate a representation
8395 -- item with the procedure's scope.
8397 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8398 if Prag_Id
= Pragma_Interrupt_Handler
8400 Prag_Id
= Pragma_Attach_Handler
8402 Record_Rep_Item
(Proc_Scope
, N
);
8405 end Process_Interrupt_Or_Attach_Handler
;
8407 --------------------------------------------------
8408 -- Process_Restrictions_Or_Restriction_Warnings --
8409 --------------------------------------------------
8411 -- Note: some of the simple identifier cases were handled in par-prag,
8412 -- but it is harmless (and more straightforward) to simply handle all
8413 -- cases here, even if it means we repeat a bit of work in some cases.
8415 procedure Process_Restrictions_Or_Restriction_Warnings
8419 R_Id
: Restriction_Id
;
8425 -- Ignore all Restrictions pragmas in CodePeer mode
8427 if CodePeer_Mode
then
8431 Check_Ada_83_Warning
;
8432 Check_At_Least_N_Arguments
(1);
8433 Check_Valid_Configuration_Pragma
;
8436 while Present
(Arg
) loop
8438 Expr
:= Get_Pragma_Arg
(Arg
);
8440 -- Case of no restriction identifier present
8442 if Id
= No_Name
then
8443 if Nkind
(Expr
) /= N_Identifier
then
8445 ("invalid form for restriction", Arg
);
8450 (Process_Restriction_Synonyms
(Expr
));
8452 if R_Id
not in All_Boolean_Restrictions
then
8453 Error_Msg_Name_1
:= Pname
;
8455 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8457 -- Check for possible misspelling
8459 for J
in Restriction_Id
loop
8461 Rnm
: constant String := Restriction_Id
'Image (J
);
8464 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8465 Name_Len
:= Rnm
'Length;
8466 Set_Casing
(All_Lower_Case
);
8468 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8470 (Identifier_Casing
(Current_Source_File
));
8471 Error_Msg_String
(1 .. Rnm
'Length) :=
8472 Name_Buffer
(1 .. Name_Len
);
8473 Error_Msg_Strlen
:= Rnm
'Length;
8474 Error_Msg_N
-- CODEFIX
8475 ("\possible misspelling of ""~""",
8476 Get_Pragma_Arg
(Arg
));
8485 if Implementation_Restriction
(R_Id
) then
8486 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8489 -- Special processing for No_Elaboration_Code restriction
8491 if R_Id
= No_Elaboration_Code
then
8493 -- Restriction is only recognized within a configuration
8494 -- pragma file, or within a unit of the main extended
8495 -- program. Note: the test for Main_Unit is needed to
8496 -- properly include the case of configuration pragma files.
8498 if not (Current_Sem_Unit
= Main_Unit
8499 or else In_Extended_Main_Source_Unit
(N
))
8503 -- Don't allow in a subunit unless already specified in
8506 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8507 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8508 and then not Restriction_Active
(No_Elaboration_Code
)
8511 ("invalid specification of ""No_Elaboration_Code""",
8514 ("\restriction cannot be specified in a subunit", N
);
8516 ("\unless also specified in body or spec", N
);
8519 -- If we accept a No_Elaboration_Code restriction, then it
8520 -- needs to be added to the configuration restriction set so
8521 -- that we get proper application to other units in the main
8522 -- extended source as required.
8525 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8529 -- If this is a warning, then set the warning unless we already
8530 -- have a real restriction active (we never want a warning to
8531 -- override a real restriction).
8534 if not Restriction_Active
(R_Id
) then
8535 Set_Restriction
(R_Id
, N
);
8536 Restriction_Warnings
(R_Id
) := True;
8539 -- If real restriction case, then set it and make sure that the
8540 -- restriction warning flag is off, since a real restriction
8541 -- always overrides a warning.
8544 Set_Restriction
(R_Id
, N
);
8545 Restriction_Warnings
(R_Id
) := False;
8548 -- Check for obsolescent restrictions in Ada 2005 mode
8551 and then Ada_Version
>= Ada_2005
8552 and then (R_Id
= No_Asynchronous_Control
8554 R_Id
= No_Unchecked_Deallocation
8556 R_Id
= No_Unchecked_Conversion
)
8558 Check_Restriction
(No_Obsolescent_Features
, N
);
8561 -- A very special case that must be processed here: pragma
8562 -- Restrictions (No_Exceptions) turns off all run-time
8563 -- checking. This is a bit dubious in terms of the formal
8564 -- language definition, but it is what is intended by RM
8565 -- H.4(12). Restriction_Warnings never affects generated code
8566 -- so this is done only in the real restriction case.
8568 -- Atomic_Synchronization is not a real check, so it is not
8569 -- affected by this processing).
8571 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8572 -- run-time checks in CodePeer and GNATprove modes: we want to
8573 -- generate checks for analysis purposes, as set respectively
8574 -- by -gnatC and -gnatd.F
8577 and then not (CodePeer_Mode
or GNATprove_Mode
)
8578 and then R_Id
= No_Exceptions
8580 for J
in Scope_Suppress
.Suppress
'Range loop
8581 if J
/= Atomic_Synchronization
then
8582 Scope_Suppress
.Suppress
(J
) := True;
8587 -- Case of No_Dependence => unit-name. Note that the parser
8588 -- already made the necessary entry in the No_Dependence table.
8590 elsif Id
= Name_No_Dependence
then
8591 if not OK_No_Dependence_Unit_Name
(Expr
) then
8595 -- Case of No_Specification_Of_Aspect => aspect-identifier
8597 elsif Id
= Name_No_Specification_Of_Aspect
then
8602 if Nkind
(Expr
) /= N_Identifier
then
8605 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
8608 if A_Id
= No_Aspect
then
8609 Error_Pragma_Arg
("invalid restriction name", Arg
);
8611 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
8615 -- Case of No_Use_Of_Attribute => attribute-identifier
8617 elsif Id
= Name_No_Use_Of_Attribute
then
8618 if Nkind
(Expr
) /= N_Identifier
8619 or else not Is_Attribute_Name
(Chars
(Expr
))
8621 Error_Msg_N
("unknown attribute name??", Expr
);
8624 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
8627 -- Case of No_Use_Of_Entity => fully-qualified-name
8629 elsif Id
= Name_No_Use_Of_Entity
then
8631 -- Restriction is only recognized within a configuration
8632 -- pragma file, or within a unit of the main extended
8633 -- program. Note: the test for Main_Unit is needed to
8634 -- properly include the case of configuration pragma files.
8636 if Current_Sem_Unit
= Main_Unit
8637 or else In_Extended_Main_Source_Unit
(N
)
8639 if not OK_No_Dependence_Unit_Name
(Expr
) then
8640 Error_Msg_N
("wrong form for entity name", Expr
);
8642 Set_Restriction_No_Use_Of_Entity
8643 (Expr
, Warn
, No_Profile
);
8647 -- Case of No_Use_Of_Pragma => pragma-identifier
8649 elsif Id
= Name_No_Use_Of_Pragma
then
8650 if Nkind
(Expr
) /= N_Identifier
8651 or else not Is_Pragma_Name
(Chars
(Expr
))
8653 Error_Msg_N
("unknown pragma name??", Expr
);
8655 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
8658 -- All other cases of restriction identifier present
8661 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
8662 Analyze_And_Resolve
(Expr
, Any_Integer
);
8664 if R_Id
not in All_Parameter_Restrictions
then
8666 ("invalid restriction parameter identifier", Arg
);
8668 elsif not Is_OK_Static_Expression
(Expr
) then
8669 Flag_Non_Static_Expr
8670 ("value must be static expression!", Expr
);
8673 elsif not Is_Integer_Type
(Etype
(Expr
))
8674 or else Expr_Value
(Expr
) < 0
8677 ("value must be non-negative integer", Arg
);
8680 -- Restriction pragma is active
8682 Val
:= Expr_Value
(Expr
);
8684 if not UI_Is_In_Int_Range
(Val
) then
8686 ("pragma ignored, value too large??", Arg
);
8689 -- Warning case. If the real restriction is active, then we
8690 -- ignore the request, since warning never overrides a real
8691 -- restriction. Otherwise we set the proper warning. Note that
8692 -- this circuit sets the warning again if it is already set,
8693 -- which is what we want, since the constant may have changed.
8696 if not Restriction_Active
(R_Id
) then
8698 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
8699 Restriction_Warnings
(R_Id
) := True;
8702 -- Real restriction case, set restriction and make sure warning
8703 -- flag is off since real restriction always overrides warning.
8706 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
8707 Restriction_Warnings
(R_Id
) := False;
8713 end Process_Restrictions_Or_Restriction_Warnings
;
8715 ---------------------------------
8716 -- Process_Suppress_Unsuppress --
8717 ---------------------------------
8719 -- Note: this procedure makes entries in the check suppress data
8720 -- structures managed by Sem. See spec of package Sem for full
8721 -- details on how we handle recording of check suppression.
8723 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
8728 In_Package_Spec
: constant Boolean :=
8729 Is_Package_Or_Generic_Package
(Current_Scope
)
8730 and then not In_Package_Body
(Current_Scope
);
8732 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
8733 -- Used to suppress a single check on the given entity
8735 --------------------------------
8736 -- Suppress_Unsuppress_Echeck --
8737 --------------------------------
8739 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
8741 -- Check for error of trying to set atomic synchronization for
8742 -- a non-atomic variable.
8744 if C
= Atomic_Synchronization
8745 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
8748 ("pragma & requires atomic type or variable",
8749 Pragma_Identifier
(Original_Node
(N
)));
8752 Set_Checks_May_Be_Suppressed
(E
);
8754 if In_Package_Spec
then
8755 Push_Global_Suppress_Stack_Entry
8758 Suppress
=> Suppress_Case
);
8760 Push_Local_Suppress_Stack_Entry
8763 Suppress
=> Suppress_Case
);
8766 -- If this is a first subtype, and the base type is distinct,
8767 -- then also set the suppress flags on the base type.
8769 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
8770 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
8772 end Suppress_Unsuppress_Echeck
;
8774 -- Start of processing for Process_Suppress_Unsuppress
8777 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
8778 -- on user code: we want to generate checks for analysis purposes, as
8779 -- set respectively by -gnatC and -gnatd.F
8781 if (CodePeer_Mode
or GNATprove_Mode
)
8782 and then Comes_From_Source
(N
)
8787 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
8788 -- declarative part or a package spec (RM 11.5(5)).
8790 if not Is_Configuration_Pragma
then
8791 Check_Is_In_Decl_Part_Or_Package_Spec
;
8794 Check_At_Least_N_Arguments
(1);
8795 Check_At_Most_N_Arguments
(2);
8796 Check_No_Identifier
(Arg1
);
8797 Check_Arg_Is_Identifier
(Arg1
);
8799 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
8801 if C
= No_Check_Id
then
8803 ("argument of pragma% is not valid check name", Arg1
);
8806 -- Warn that suppress of Elaboration_Check has no effect in SPARK
8808 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
8810 ("Suppress of Elaboration_Check ignored in SPARK??",
8811 "\elaboration checking rules are statically enforced "
8812 & "(SPARK RM 7.7)", Arg1
);
8815 -- One-argument case
8817 if Arg_Count
= 1 then
8819 -- Make an entry in the local scope suppress table. This is the
8820 -- table that directly shows the current value of the scope
8821 -- suppress check for any check id value.
8823 if C
= All_Checks
then
8825 -- For All_Checks, we set all specific predefined checks with
8826 -- the exception of Elaboration_Check, which is handled
8827 -- specially because of not wanting All_Checks to have the
8828 -- effect of deactivating static elaboration order processing.
8829 -- Atomic_Synchronization is also not affected, since this is
8830 -- not a real check.
8832 for J
in Scope_Suppress
.Suppress
'Range loop
8833 if J
/= Elaboration_Check
8835 J
/= Atomic_Synchronization
8837 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
8841 -- If not All_Checks, and predefined check, then set appropriate
8842 -- scope entry. Note that we will set Elaboration_Check if this
8843 -- is explicitly specified. Atomic_Synchronization is allowed
8844 -- only if internally generated and entity is atomic.
8846 elsif C
in Predefined_Check_Id
8847 and then (not Comes_From_Source
(N
)
8848 or else C
/= Atomic_Synchronization
)
8850 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
8853 -- Also make an entry in the Local_Entity_Suppress table
8855 Push_Local_Suppress_Stack_Entry
8858 Suppress
=> Suppress_Case
);
8860 -- Case of two arguments present, where the check is suppressed for
8861 -- a specified entity (given as the second argument of the pragma)
8864 -- This is obsolescent in Ada 2005 mode
8866 if Ada_Version
>= Ada_2005
then
8867 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
8870 Check_Optional_Identifier
(Arg2
, Name_On
);
8871 E_Id
:= Get_Pragma_Arg
(Arg2
);
8874 if not Is_Entity_Name
(E_Id
) then
8876 ("second argument of pragma% must be entity name", Arg2
);
8885 -- Enforce RM 11.5(7) which requires that for a pragma that
8886 -- appears within a package spec, the named entity must be
8887 -- within the package spec. We allow the package name itself
8888 -- to be mentioned since that makes sense, although it is not
8889 -- strictly allowed by 11.5(7).
8892 and then E
/= Current_Scope
8893 and then Scope
(E
) /= Current_Scope
8896 ("entity in pragma% is not in package spec (RM 11.5(7))",
8900 -- Loop through homonyms. As noted below, in the case of a package
8901 -- spec, only homonyms within the package spec are considered.
8904 Suppress_Unsuppress_Echeck
(E
, C
);
8906 if Is_Generic_Instance
(E
)
8907 and then Is_Subprogram
(E
)
8908 and then Present
(Alias
(E
))
8910 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
8913 -- Move to next homonym if not aspect spec case
8915 exit when From_Aspect_Specification
(N
);
8919 -- If we are within a package specification, the pragma only
8920 -- applies to homonyms in the same scope.
8922 exit when In_Package_Spec
8923 and then Scope
(E
) /= Current_Scope
;
8926 end Process_Suppress_Unsuppress
;
8928 -------------------------------
8929 -- Record_Independence_Check --
8930 -------------------------------
8932 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
8934 -- For GCC back ends the validation is done a priori
8936 if VM_Target
= No_VM
and then not AAMP_On_Target
then
8940 Independence_Checks
.Append
((N
, E
));
8941 end Record_Independence_Check
;
8947 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
8949 if Is_Imported
(E
) then
8951 ("cannot export entity& that was previously imported", Arg
);
8953 elsif Present
(Address_Clause
(E
))
8954 and then not Relaxed_RM_Semantics
8957 ("cannot export entity& that has an address clause", Arg
);
8960 Set_Is_Exported
(E
);
8962 -- Generate a reference for entity explicitly, because the
8963 -- identifier may be overloaded and name resolution will not
8966 Generate_Reference
(E
, Arg
);
8968 -- Deal with exporting non-library level entity
8970 if not Is_Library_Level_Entity
(E
) then
8972 -- Not allowed at all for subprograms
8974 if Is_Subprogram
(E
) then
8975 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
8977 -- Otherwise set public and statically allocated
8981 Set_Is_Statically_Allocated
(E
);
8983 -- Warn if the corresponding W flag is set
8985 if Warn_On_Export_Import
8987 -- Only do this for something that was in the source. Not
8988 -- clear if this can be False now (there used for sure to be
8989 -- cases on some systems where it was False), but anyway the
8990 -- test is harmless if not needed, so it is retained.
8992 and then Comes_From_Source
(Arg
)
8995 ("?x?& has been made static as a result of Export",
8998 ("\?x?this usage is non-standard and non-portable",
9004 if Warn_On_Export_Import
and then Is_Type
(E
) then
9005 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9008 if Warn_On_Export_Import
and Inside_A_Generic
then
9010 ("all instances of& will have the same external name?x?",
9015 ----------------------------------------------
9016 -- Set_Extended_Import_Export_External_Name --
9017 ----------------------------------------------
9019 procedure Set_Extended_Import_Export_External_Name
9020 (Internal_Ent
: Entity_Id
;
9021 Arg_External
: Node_Id
)
9023 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9027 if No
(Arg_External
) then
9031 Check_Arg_Is_External_Name
(Arg_External
);
9033 if Nkind
(Arg_External
) = N_String_Literal
then
9034 if String_Length
(Strval
(Arg_External
)) = 0 then
9037 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9040 elsif Nkind
(Arg_External
) = N_Identifier
then
9041 New_Name
:= Get_Default_External_Name
(Arg_External
);
9043 -- Check_Arg_Is_External_Name should let through only identifiers and
9044 -- string literals or static string expressions (which are folded to
9045 -- string literals).
9048 raise Program_Error
;
9051 -- If we already have an external name set (by a prior normal Import
9052 -- or Export pragma), then the external names must match
9054 if Present
(Interface_Name
(Internal_Ent
)) then
9056 -- Ignore mismatching names in CodePeer mode, to support some
9057 -- old compilers which would export the same procedure under
9058 -- different names, e.g:
9060 -- pragma Export_Procedure (P, "a");
9061 -- pragma Export_Procedure (P, "b");
9063 if CodePeer_Mode
then
9067 Check_Matching_Internal_Names
: declare
9068 S1
: constant String_Id
:= Strval
(Old_Name
);
9069 S2
: constant String_Id
:= Strval
(New_Name
);
9072 pragma No_Return
(Mismatch
);
9073 -- Called if names do not match
9079 procedure Mismatch
is
9081 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9083 ("external name does not match that given #",
9087 -- Start of processing for Check_Matching_Internal_Names
9090 if String_Length
(S1
) /= String_Length
(S2
) then
9094 for J
in 1 .. String_Length
(S1
) loop
9095 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9100 end Check_Matching_Internal_Names
;
9102 -- Otherwise set the given name
9105 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9106 Check_Duplicated_Export_Name
(New_Name
);
9108 end Set_Extended_Import_Export_External_Name
;
9114 procedure Set_Imported
(E
: Entity_Id
) is
9116 -- Error message if already imported or exported
9118 if Is_Exported
(E
) or else Is_Imported
(E
) then
9120 -- Error if being set Exported twice
9122 if Is_Exported
(E
) then
9123 Error_Msg_NE
("entity& was previously exported", N
, E
);
9125 -- Ignore error in CodePeer mode where we treat all imported
9126 -- subprograms as unknown.
9128 elsif CodePeer_Mode
then
9131 -- OK if Import/Interface case
9133 elsif Import_Interface_Present
(N
) then
9136 -- Error if being set Imported twice
9139 Error_Msg_NE
("entity& was previously imported", N
, E
);
9142 Error_Msg_Name_1
:= Pname
;
9144 ("\(pragma% applies to all previous entities)", N
);
9146 Error_Msg_Sloc
:= Sloc
(E
);
9147 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9149 -- Here if not previously imported or exported, OK to import
9152 Set_Is_Imported
(E
);
9154 -- For subprogram, set Import_Pragma field
9156 if Is_Subprogram
(E
) then
9157 Set_Import_Pragma
(E
, N
);
9160 -- If the entity is an object that is not at the library level,
9161 -- then it is statically allocated. We do not worry about objects
9162 -- with address clauses in this context since they are not really
9163 -- imported in the linker sense.
9166 and then not Is_Library_Level_Entity
(E
)
9167 and then No
(Address_Clause
(E
))
9169 Set_Is_Statically_Allocated
(E
);
9176 -------------------------
9177 -- Set_Mechanism_Value --
9178 -------------------------
9180 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9181 -- analyzed, since it is semantic nonsense), so we get it in the exact
9182 -- form created by the parser.
9184 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9185 procedure Bad_Mechanism
;
9186 pragma No_Return
(Bad_Mechanism
);
9187 -- Signal bad mechanism name
9189 -------------------------
9190 -- Bad_Mechanism_Value --
9191 -------------------------
9193 procedure Bad_Mechanism
is
9195 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9198 -- Start of processing for Set_Mechanism_Value
9201 if Mechanism
(Ent
) /= Default_Mechanism
then
9203 ("mechanism for & has already been set", Mech_Name
, Ent
);
9206 -- MECHANISM_NAME ::= value | reference
9208 if Nkind
(Mech_Name
) = N_Identifier
then
9209 if Chars
(Mech_Name
) = Name_Value
then
9210 Set_Mechanism
(Ent
, By_Copy
);
9213 elsif Chars
(Mech_Name
) = Name_Reference
then
9214 Set_Mechanism
(Ent
, By_Reference
);
9217 elsif Chars
(Mech_Name
) = Name_Copy
then
9219 ("bad mechanism name, Value assumed", Mech_Name
);
9228 end Set_Mechanism_Value
;
9230 --------------------------
9231 -- Set_Rational_Profile --
9232 --------------------------
9234 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9235 -- and extension to the semantics of renaming declarations.
9237 procedure Set_Rational_Profile
is
9239 Implicit_Packing
:= True;
9240 Overriding_Renamings
:= True;
9241 Use_VADS_Size
:= True;
9242 end Set_Rational_Profile
;
9244 ---------------------------
9245 -- Set_Ravenscar_Profile --
9246 ---------------------------
9248 -- The tasks to be done here are
9250 -- Set required policies
9252 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9253 -- pragma Locking_Policy (Ceiling_Locking)
9255 -- Set Detect_Blocking mode
9257 -- Set required restrictions (see System.Rident for detailed list)
9259 -- Set the No_Dependence rules
9260 -- No_Dependence => Ada.Asynchronous_Task_Control
9261 -- No_Dependence => Ada.Calendar
9262 -- No_Dependence => Ada.Execution_Time.Group_Budget
9263 -- No_Dependence => Ada.Execution_Time.Timers
9264 -- No_Dependence => Ada.Task_Attributes
9265 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9267 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9268 Prefix_Entity
: Entity_Id
;
9269 Selector_Entity
: Entity_Id
;
9270 Prefix_Node
: Node_Id
;
9274 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9276 if Task_Dispatching_Policy
/= ' '
9277 and then Task_Dispatching_Policy
/= 'F'
9279 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9280 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9282 -- Set the FIFO_Within_Priorities policy, but always preserve
9283 -- System_Location since we like the error message with the run time
9287 Task_Dispatching_Policy
:= 'F';
9289 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9290 Task_Dispatching_Policy_Sloc
:= Loc
;
9294 -- pragma Locking_Policy (Ceiling_Locking)
9296 if Locking_Policy
/= ' '
9297 and then Locking_Policy
/= 'C'
9299 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9300 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9302 -- Set the Ceiling_Locking policy, but preserve System_Location since
9303 -- we like the error message with the run time name.
9306 Locking_Policy
:= 'C';
9308 if Locking_Policy_Sloc
/= System_Location
then
9309 Locking_Policy_Sloc
:= Loc
;
9313 -- pragma Detect_Blocking
9315 Detect_Blocking
:= True;
9317 -- Set the corresponding restrictions
9319 Set_Profile_Restrictions
9320 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9322 -- Set the No_Dependence restrictions
9324 -- The following No_Dependence restrictions:
9325 -- No_Dependence => Ada.Asynchronous_Task_Control
9326 -- No_Dependence => Ada.Calendar
9327 -- No_Dependence => Ada.Task_Attributes
9328 -- are already set by previous call to Set_Profile_Restrictions.
9330 -- Set the following restrictions which were added to Ada 2005:
9331 -- No_Dependence => Ada.Execution_Time.Group_Budget
9332 -- No_Dependence => Ada.Execution_Time.Timers
9334 if Ada_Version
>= Ada_2005
then
9335 Name_Buffer
(1 .. 3) := "ada";
9338 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9340 Name_Buffer
(1 .. 14) := "execution_time";
9343 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9346 Make_Selected_Component
9348 Prefix
=> Prefix_Entity
,
9349 Selector_Name
=> Selector_Entity
);
9351 Name_Buffer
(1 .. 13) := "group_budgets";
9354 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9357 Make_Selected_Component
9359 Prefix
=> Prefix_Node
,
9360 Selector_Name
=> Selector_Entity
);
9362 Set_Restriction_No_Dependence
9364 Warn
=> Treat_Restrictions_As_Warnings
,
9365 Profile
=> Ravenscar
);
9367 Name_Buffer
(1 .. 6) := "timers";
9370 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9373 Make_Selected_Component
9375 Prefix
=> Prefix_Node
,
9376 Selector_Name
=> Selector_Entity
);
9378 Set_Restriction_No_Dependence
9380 Warn
=> Treat_Restrictions_As_Warnings
,
9381 Profile
=> Ravenscar
);
9384 -- Set the following restrictions which was added to Ada 2012 (see
9386 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9388 if Ada_Version
>= Ada_2012
then
9389 Name_Buffer
(1 .. 6) := "system";
9392 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9394 Name_Buffer
(1 .. 15) := "multiprocessors";
9397 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9400 Make_Selected_Component
9402 Prefix
=> Prefix_Entity
,
9403 Selector_Name
=> Selector_Entity
);
9405 Name_Buffer
(1 .. 19) := "dispatching_domains";
9408 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9411 Make_Selected_Component
9413 Prefix
=> Prefix_Node
,
9414 Selector_Name
=> Selector_Entity
);
9416 Set_Restriction_No_Dependence
9418 Warn
=> Treat_Restrictions_As_Warnings
,
9419 Profile
=> Ravenscar
);
9421 end Set_Ravenscar_Profile
;
9423 -- Start of processing for Analyze_Pragma
9426 -- The following code is a defense against recursion. Not clear that
9427 -- this can happen legitimately, but perhaps some error situations
9428 -- can cause it, and we did see this recursion during testing.
9430 if Analyzed
(N
) then
9433 Set_Analyzed
(N
, True);
9436 -- Deal with unrecognized pragma
9438 Pname
:= Pragma_Name
(N
);
9440 if not Is_Pragma_Name
(Pname
) then
9441 if Warn_On_Unrecognized_Pragma
then
9442 Error_Msg_Name_1
:= Pname
;
9443 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9445 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9446 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9447 Error_Msg_Name_1
:= PN
;
9448 Error_Msg_N
-- CODEFIX
9449 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9458 -- Ignore pragma if Ignore_Pragma applies
9460 if Get_Name_Table_Boolean3
(Pname
) then
9464 -- Here to start processing for recognized pragma
9466 Prag_Id
:= Get_Pragma_Id
(Pname
);
9467 Pname
:= Original_Aspect_Pragma_Name
(N
);
9469 -- Capture setting of Opt.Uneval_Old
9471 case Opt
.Uneval_Old
is
9473 Set_Uneval_Old_Accept
(N
);
9477 Set_Uneval_Old_Warn
(N
);
9479 raise Program_Error
;
9482 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9483 -- is already set, indicating that we have already checked the policy
9484 -- at the right point. This happens for example in the case of a pragma
9485 -- that is derived from an Aspect.
9487 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9490 -- For a pragma that is a rewriting of another pragma, copy the
9491 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9493 elsif Is_Rewrite_Substitution
(N
)
9494 and then Nkind
(Original_Node
(N
)) = N_Pragma
9495 and then Original_Node
(N
) /= N
9497 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
9498 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
9500 -- Otherwise query the applicable policy at this point
9503 Check_Applicable_Policy
(N
);
9505 -- If pragma is disabled, rewrite as NULL and skip analysis
9507 if Is_Disabled
(N
) then
9508 Rewrite
(N
, Make_Null_Statement
(Loc
));
9522 if Present
(Pragma_Argument_Associations
(N
)) then
9523 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
9524 Arg1
:= First
(Pragma_Argument_Associations
(N
));
9526 if Present
(Arg1
) then
9527 Arg2
:= Next
(Arg1
);
9529 if Present
(Arg2
) then
9530 Arg3
:= Next
(Arg2
);
9532 if Present
(Arg3
) then
9533 Arg4
:= Next
(Arg3
);
9539 Check_Restriction_No_Use_Of_Pragma
(N
);
9541 -- An enumeration type defines the pragmas that are supported by the
9542 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9543 -- into the corresponding enumeration value for the following case.
9551 -- pragma Abort_Defer;
9553 when Pragma_Abort_Defer
=>
9555 Check_Arg_Count
(0);
9557 -- The only required semantic processing is to check the
9558 -- placement. This pragma must appear at the start of the
9559 -- statement sequence of a handled sequence of statements.
9561 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
9562 or else N
/= First
(Statements
(Parent
(N
)))
9567 --------------------
9568 -- Abstract_State --
9569 --------------------
9571 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9573 -- ABSTRACT_STATE_LIST ::=
9575 -- | STATE_NAME_WITH_OPTIONS
9576 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9578 -- STATE_NAME_WITH_OPTIONS ::=
9580 -- | (STATE_NAME with OPTION_LIST)
9582 -- OPTION_LIST ::= OPTION {, OPTION}
9586 -- | NAME_VALUE_OPTION
9588 -- SIMPLE_OPTION ::= Ghost
9590 -- NAME_VALUE_OPTION ::=
9591 -- Part_Of => ABSTRACT_STATE
9592 -- | External [=> EXTERNAL_PROPERTY_LIST]
9594 -- EXTERNAL_PROPERTY_LIST ::=
9595 -- EXTERNAL_PROPERTY
9596 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9598 -- EXTERNAL_PROPERTY ::=
9599 -- Async_Readers [=> boolean_EXPRESSION]
9600 -- | Async_Writers [=> boolean_EXPRESSION]
9601 -- | Effective_Reads [=> boolean_EXPRESSION]
9602 -- | Effective_Writes [=> boolean_EXPRESSION]
9603 -- others => boolean_EXPRESSION
9605 -- STATE_NAME ::= defining_identifier
9607 -- ABSTRACT_STATE ::= name
9611 -- * Analysis - The annotation is fully analyzed immediately upon
9612 -- elaboration as it cannot forward reference entities.
9614 -- * Expansion - None.
9616 -- * Template - The annotation utilizes the generic template of the
9617 -- related package declaration.
9619 -- * Globals - The annotation cannot reference global entities.
9621 -- * Instance - The annotation is instantiated automatically when
9622 -- the related generic package is instantiated.
9624 when Pragma_Abstract_State
=> Abstract_State
: declare
9625 Missing_Parentheses
: Boolean := False;
9626 -- Flag set when a state declaration with options is not properly
9629 -- Flags used to verify the consistency of states
9631 Non_Null_Seen
: Boolean := False;
9632 Null_Seen
: Boolean := False;
9634 procedure Analyze_Abstract_State
9636 Pack_Id
: Entity_Id
);
9637 -- Verify the legality of a single state declaration. Create and
9638 -- decorate a state abstraction entity and introduce it into the
9639 -- visibility chain. Pack_Id denotes the entity or the related
9640 -- package where pragma Abstract_State appears.
9642 procedure Malformed_State_Error
(State
: Node_Id
);
9643 -- Emit an error concerning the illegal declaration of abstract
9644 -- state State. This routine diagnoses syntax errors that lead to
9645 -- a different parse tree. The error is issued regardless of the
9646 -- SPARK mode in effect.
9648 ----------------------------
9649 -- Analyze_Abstract_State --
9650 ----------------------------
9652 procedure Analyze_Abstract_State
9654 Pack_Id
: Entity_Id
)
9656 -- Flags used to verify the consistency of options
9658 AR_Seen
: Boolean := False;
9659 AW_Seen
: Boolean := False;
9660 ER_Seen
: Boolean := False;
9661 EW_Seen
: Boolean := False;
9662 External_Seen
: Boolean := False;
9663 Others_Seen
: Boolean := False;
9664 Part_Of_Seen
: Boolean := False;
9666 -- Flags used to store the static value of all external states'
9669 AR_Val
: Boolean := False;
9670 AW_Val
: Boolean := False;
9671 ER_Val
: Boolean := False;
9672 EW_Val
: Boolean := False;
9674 State_Id
: Entity_Id
:= Empty
;
9675 -- The entity to be generated for the current state declaration
9677 procedure Analyze_External_Option
(Opt
: Node_Id
);
9678 -- Verify the legality of option External
9680 procedure Analyze_External_Property
9682 Expr
: Node_Id
:= Empty
);
9683 -- Verify the legailty of a single external property. Prop
9684 -- denotes the external property. Expr is the expression used
9685 -- to set the property.
9687 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
9688 -- Verify the legality of option Part_Of
9690 procedure Check_Duplicate_Option
9692 Status
: in out Boolean);
9693 -- Flag Status denotes whether a particular option has been
9694 -- seen while processing a state. This routine verifies that
9695 -- Opt is not a duplicate option and sets the flag Status
9696 -- (SPARK RM 7.1.4(1)).
9698 procedure Check_Duplicate_Property
9700 Status
: in out Boolean);
9701 -- Flag Status denotes whether a particular property has been
9702 -- seen while processing option External. This routine verifies
9703 -- that Prop is not a duplicate property and sets flag Status.
9704 -- Opt is not a duplicate property and sets the flag Status.
9705 -- (SPARK RM 7.1.4(2))
9707 procedure Create_Abstract_State
9712 -- Generate an abstract state entity with name Nam and enter it
9713 -- into visibility. Decl is the "declaration" of the state as
9714 -- it appears in pragma Abstract_State. Loc is the location of
9715 -- the related state "declaration". Flag Is_Null should be set
9716 -- when the associated Abstract_State pragma defines a null
9719 -----------------------------
9720 -- Analyze_External_Option --
9721 -----------------------------
9723 procedure Analyze_External_Option
(Opt
: Node_Id
) is
9724 Errors
: constant Nat
:= Serious_Errors_Detected
;
9726 Props
: Node_Id
:= Empty
;
9729 Check_Duplicate_Option
(Opt
, External_Seen
);
9731 if Nkind
(Opt
) = N_Component_Association
then
9732 Props
:= Expression
(Opt
);
9735 -- External state with properties
9737 if Present
(Props
) then
9739 -- Multiple properties appear as an aggregate
9741 if Nkind
(Props
) = N_Aggregate
then
9743 -- Simple property form
9745 Prop
:= First
(Expressions
(Props
));
9746 while Present
(Prop
) loop
9747 Analyze_External_Property
(Prop
);
9751 -- Property with expression form
9753 Prop
:= First
(Component_Associations
(Props
));
9754 while Present
(Prop
) loop
9755 Analyze_External_Property
9756 (Prop
=> First
(Choices
(Prop
)),
9757 Expr
=> Expression
(Prop
));
9765 Analyze_External_Property
(Props
);
9768 -- An external state defined without any properties defaults
9769 -- all properties to True.
9778 -- Once all external properties have been processed, verify
9779 -- their mutual interaction. Do not perform the check when
9780 -- at least one of the properties is illegal as this will
9781 -- produce a bogus error.
9783 if Errors
= Serious_Errors_Detected
then
9784 Check_External_Properties
9785 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
9787 end Analyze_External_Option
;
9789 -------------------------------
9790 -- Analyze_External_Property --
9791 -------------------------------
9793 procedure Analyze_External_Property
9795 Expr
: Node_Id
:= Empty
)
9800 -- Check the placement of "others" (if available)
9802 if Nkind
(Prop
) = N_Others_Choice
then
9805 ("only one others choice allowed in option External",
9808 Others_Seen
:= True;
9811 elsif Others_Seen
then
9813 ("others must be the last property in option External",
9816 -- The only remaining legal options are the four predefined
9817 -- external properties.
9819 elsif Nkind
(Prop
) = N_Identifier
9820 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
9822 Name_Effective_Reads
,
9823 Name_Effective_Writes
)
9827 -- Otherwise the construct is not a valid property
9830 SPARK_Msg_N
("invalid external state property", Prop
);
9834 -- Ensure that the expression of the external state property
9835 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
9837 if Present
(Expr
) then
9838 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9840 if Is_OK_Static_Expression
(Expr
) then
9841 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
9844 ("expression of external state property must be "
9848 -- The lack of expression defaults the property to True
9856 if Nkind
(Prop
) = N_Identifier
then
9857 if Chars
(Prop
) = Name_Async_Readers
then
9858 Check_Duplicate_Property
(Prop
, AR_Seen
);
9861 elsif Chars
(Prop
) = Name_Async_Writers
then
9862 Check_Duplicate_Property
(Prop
, AW_Seen
);
9865 elsif Chars
(Prop
) = Name_Effective_Reads
then
9866 Check_Duplicate_Property
(Prop
, ER_Seen
);
9870 Check_Duplicate_Property
(Prop
, EW_Seen
);
9874 -- The handling of property "others" must take into account
9875 -- all other named properties that have been encountered so
9876 -- far. Only those that have not been seen are affected by
9896 end Analyze_External_Property
;
9898 ----------------------------
9899 -- Analyze_Part_Of_Option --
9900 ----------------------------
9902 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
9903 Encaps
: constant Node_Id
:= Expression
(Opt
);
9904 Encaps_Id
: Entity_Id
;
9908 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
9911 (Item_Id
=> State_Id
,
9913 Indic
=> First
(Choices
(Opt
)),
9916 -- The Part_Of indicator turns an abstract state into a
9917 -- constituent of the encapsulating state.
9920 Encaps_Id
:= Entity
(Encaps
);
9922 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
9923 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
9925 end Analyze_Part_Of_Option
;
9927 ----------------------------
9928 -- Check_Duplicate_Option --
9929 ----------------------------
9931 procedure Check_Duplicate_Option
9933 Status
: in out Boolean)
9937 SPARK_Msg_N
("duplicate state option", Opt
);
9941 end Check_Duplicate_Option
;
9943 ------------------------------
9944 -- Check_Duplicate_Property --
9945 ------------------------------
9947 procedure Check_Duplicate_Property
9949 Status
: in out Boolean)
9953 SPARK_Msg_N
("duplicate external property", Prop
);
9957 end Check_Duplicate_Property
;
9959 ---------------------------
9960 -- Create_Abstract_State --
9961 ---------------------------
9963 procedure Create_Abstract_State
9970 -- The abstract state may be semi-declared when the related
9971 -- package was withed through a limited with clause. In that
9972 -- case reuse the entity to fully declare the state.
9974 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
9975 State_Id
:= Entity
(Decl
);
9977 -- Otherwise the elaboration of pragma Abstract_State
9978 -- declares the state.
9981 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
9983 if Present
(Decl
) then
9984 Set_Entity
(Decl
, State_Id
);
9988 -- Null states never come from source
9990 Set_Comes_From_Source
(State_Id
, not Is_Null
);
9991 Set_Parent
(State_Id
, State
);
9992 Set_Ekind
(State_Id
, E_Abstract_State
);
9993 Set_Etype
(State_Id
, Standard_Void_Type
);
9994 Set_Encapsulating_State
(State_Id
, Empty
);
9995 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
9996 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
9998 -- An abstract state declared within a Ghost region becomes
9999 -- Ghost (SPARK RM 6.9(2)).
10001 if Ghost_Mode
> None
then
10002 Set_Is_Ghost_Entity
(State_Id
);
10005 -- Establish a link between the state declaration and the
10006 -- abstract state entity. Note that a null state remains as
10007 -- N_Null and does not carry any linkages.
10009 if not Is_Null
then
10010 if Present
(Decl
) then
10011 Set_Entity
(Decl
, State_Id
);
10012 Set_Etype
(Decl
, Standard_Void_Type
);
10015 -- Every non-null state must be defined, nameable and
10018 Push_Scope
(Pack_Id
);
10019 Generate_Definition
(State_Id
);
10020 Enter_Name
(State_Id
);
10023 end Create_Abstract_State
;
10030 -- Start of processing for Analyze_Abstract_State
10033 -- A package with a null abstract state is not allowed to
10034 -- declare additional states.
10038 ("package & has null abstract state", State
, Pack_Id
);
10040 -- Null states appear as internally generated entities
10042 elsif Nkind
(State
) = N_Null
then
10043 Create_Abstract_State
10044 (Nam
=> New_Internal_Name
('S'),
10046 Loc
=> Sloc
(State
),
10050 -- Catch a case where a null state appears in a list of
10051 -- non-null states.
10053 if Non_Null_Seen
then
10055 ("package & has non-null abstract state",
10059 -- Simple state declaration
10061 elsif Nkind
(State
) = N_Identifier
then
10062 Create_Abstract_State
10063 (Nam
=> Chars
(State
),
10065 Loc
=> Sloc
(State
),
10067 Non_Null_Seen
:= True;
10069 -- State declaration with various options. This construct
10070 -- appears as an extension aggregate in the tree.
10072 elsif Nkind
(State
) = N_Extension_Aggregate
then
10073 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10074 Create_Abstract_State
10075 (Nam
=> Chars
(Ancestor_Part
(State
)),
10076 Decl
=> Ancestor_Part
(State
),
10077 Loc
=> Sloc
(Ancestor_Part
(State
)),
10079 Non_Null_Seen
:= True;
10082 ("state name must be an identifier",
10083 Ancestor_Part
(State
));
10086 -- Options External and Ghost appear as expressions
10088 Opt
:= First
(Expressions
(State
));
10089 while Present
(Opt
) loop
10090 if Nkind
(Opt
) = N_Identifier
then
10091 if Chars
(Opt
) = Name_External
then
10092 Analyze_External_Option
(Opt
);
10094 elsif Chars
(Opt
) = Name_Ghost
then
10095 if Present
(State_Id
) then
10096 Set_Is_Ghost_Entity
(State_Id
);
10099 -- Option Part_Of without an encapsulating state is
10100 -- illegal. (SPARK RM 7.1.4(9)).
10102 elsif Chars
(Opt
) = Name_Part_Of
then
10104 ("indicator Part_Of must denote an abstract "
10107 -- Do not emit an error message when a previous state
10108 -- declaration with options was not parenthesized as
10109 -- the option is actually another state declaration.
10111 -- with Abstract_State
10112 -- (State_1 with ..., -- missing parentheses
10113 -- (State_2 with ...),
10114 -- State_3) -- ok state declaration
10116 elsif Missing_Parentheses
then
10119 -- Otherwise the option is not allowed. Note that it
10120 -- is not possible to distinguish between an option
10121 -- and a state declaration when a previous state with
10122 -- options not properly parentheses.
10124 -- with Abstract_State
10125 -- (State_1 with ..., -- missing parentheses
10126 -- State_2); -- could be an option
10130 ("simple option not allowed in state declaration",
10134 -- Catch a case where missing parentheses around a state
10135 -- declaration with options cause a subsequent state
10136 -- declaration with options to be treated as an option.
10138 -- with Abstract_State
10139 -- (State_1 with ..., -- missing parentheses
10140 -- (State_2 with ...))
10142 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10143 Missing_Parentheses
:= True;
10145 ("state declaration must be parenthesized",
10146 Ancestor_Part
(State
));
10148 -- Otherwise the option is malformed
10151 SPARK_Msg_N
("malformed option", Opt
);
10157 -- Options External and Part_Of appear as component
10160 Opt
:= First
(Component_Associations
(State
));
10161 while Present
(Opt
) loop
10162 Opt_Nam
:= First
(Choices
(Opt
));
10164 if Nkind
(Opt_Nam
) = N_Identifier
then
10165 if Chars
(Opt_Nam
) = Name_External
then
10166 Analyze_External_Option
(Opt
);
10168 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10169 Analyze_Part_Of_Option
(Opt
);
10172 SPARK_Msg_N
("invalid state option", Opt
);
10175 SPARK_Msg_N
("invalid state option", Opt
);
10181 -- Any other attempt to declare a state is illegal
10184 Malformed_State_Error
(State
);
10188 -- Guard against a junk state. In such cases no entity is
10189 -- generated and the subsequent checks cannot be applied.
10191 if Present
(State_Id
) then
10193 -- Verify whether the state does not introduce an illegal
10194 -- hidden state within a package subject to a null abstract
10197 Check_No_Hidden_State
(State_Id
);
10199 -- Check whether the lack of option Part_Of agrees with the
10200 -- placement of the abstract state with respect to the state
10203 if not Part_Of_Seen
then
10204 Check_Missing_Part_Of
(State_Id
);
10207 -- Associate the state with its related package
10209 if No
(Abstract_States
(Pack_Id
)) then
10210 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10213 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10215 end Analyze_Abstract_State
;
10217 ---------------------------
10218 -- Malformed_State_Error --
10219 ---------------------------
10221 procedure Malformed_State_Error
(State
: Node_Id
) is
10223 Error_Msg_N
("malformed abstract state declaration", State
);
10225 -- An abstract state with a simple option is being declared
10226 -- with "=>" rather than the legal "with". The state appears
10227 -- as a component association.
10229 if Nkind
(State
) = N_Component_Association
then
10230 Error_Msg_N
("\use WITH to specify simple option", State
);
10232 end Malformed_State_Error
;
10236 Pack_Decl
: Node_Id
;
10237 Pack_Id
: Entity_Id
;
10241 -- Start of processing for Abstract_State
10245 Check_No_Identifiers
;
10246 Check_Arg_Count
(1);
10248 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
10250 -- Ensure the proper placement of the pragma. Abstract states must
10251 -- be associated with a package declaration.
10253 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
10254 N_Package_Declaration
)
10258 -- Otherwise the pragma is associated with an illegal construct
10265 Pack_Id
:= Defining_Entity
(Pack_Decl
);
10267 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
10269 -- Mark the associated package as Ghost if it is subject to aspect
10270 -- or pragma Ghost as this affects the declaration of an abstract
10273 if Is_Subject_To_Ghost
(Unit_Declaration_Node
(Pack_Id
)) then
10274 Set_Is_Ghost_Entity
(Pack_Id
);
10277 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
10279 -- Multiple non-null abstract states appear as an aggregate
10281 if Nkind
(States
) = N_Aggregate
then
10282 State
:= First
(Expressions
(States
));
10283 while Present
(State
) loop
10284 Analyze_Abstract_State
(State
, Pack_Id
);
10288 -- An abstract state with a simple option is being illegaly
10289 -- declared with "=>" rather than "with". In this case the
10290 -- state declaration appears as a component association.
10292 if Present
(Component_Associations
(States
)) then
10293 State
:= First
(Component_Associations
(States
));
10294 while Present
(State
) loop
10295 Malformed_State_Error
(State
);
10300 -- Various forms of a single abstract state. Note that these may
10301 -- include malformed state declarations.
10304 Analyze_Abstract_State
(States
, Pack_Id
);
10307 -- Verify the declaration order of pragmas Abstract_State and
10310 Check_Declaration_Order
10312 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10314 -- Chain the pragma on the contract for completeness
10316 Add_Contract_Item
(N
, Pack_Id
);
10317 end Abstract_State
;
10325 -- Note: this pragma also has some specific processing in Par.Prag
10326 -- because we want to set the Ada version mode during parsing.
10328 when Pragma_Ada_83
=>
10330 Check_Arg_Count
(0);
10332 -- We really should check unconditionally for proper configuration
10333 -- pragma placement, since we really don't want mixed Ada modes
10334 -- within a single unit, and the GNAT reference manual has always
10335 -- said this was a configuration pragma, but we did not check and
10336 -- are hesitant to add the check now.
10338 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10339 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10340 -- or Ada 2012 mode.
10342 if Ada_Version
>= Ada_2005
then
10343 Check_Valid_Configuration_Pragma
;
10346 -- Now set Ada 83 mode
10348 Ada_Version
:= Ada_83
;
10349 Ada_Version_Explicit
:= Ada_83
;
10350 Ada_Version_Pragma
:= N
;
10358 -- Note: this pragma also has some specific processing in Par.Prag
10359 -- because we want to set the Ada 83 version mode during parsing.
10361 when Pragma_Ada_95
=>
10363 Check_Arg_Count
(0);
10365 -- We really should check unconditionally for proper configuration
10366 -- pragma placement, since we really don't want mixed Ada modes
10367 -- within a single unit, and the GNAT reference manual has always
10368 -- said this was a configuration pragma, but we did not check and
10369 -- are hesitant to add the check now.
10371 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10372 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10374 if Ada_Version
>= Ada_2005
then
10375 Check_Valid_Configuration_Pragma
;
10378 -- Now set Ada 95 mode
10380 Ada_Version
:= Ada_95
;
10381 Ada_Version_Explicit
:= Ada_95
;
10382 Ada_Version_Pragma
:= N
;
10384 ---------------------
10385 -- Ada_05/Ada_2005 --
10386 ---------------------
10389 -- pragma Ada_05 (LOCAL_NAME);
10391 -- pragma Ada_2005;
10392 -- pragma Ada_2005 (LOCAL_NAME):
10394 -- Note: these pragmas also have some specific processing in Par.Prag
10395 -- because we want to set the Ada 2005 version mode during parsing.
10397 -- The one argument form is used for managing the transition from
10398 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10399 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10400 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10401 -- mode, a preference rule is established which does not choose
10402 -- such an entity unless it is unambiguously specified. This avoids
10403 -- extra subprograms marked this way from generating ambiguities in
10404 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10405 -- intended for exclusive use in the GNAT run-time library.
10407 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10413 if Arg_Count
= 1 then
10414 Check_Arg_Is_Local_Name
(Arg1
);
10415 E_Id
:= Get_Pragma_Arg
(Arg1
);
10417 if Etype
(E_Id
) = Any_Type
then
10421 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10422 Record_Rep_Item
(Entity
(E_Id
), N
);
10425 Check_Arg_Count
(0);
10427 -- For Ada_2005 we unconditionally enforce the documented
10428 -- configuration pragma placement, since we do not want to
10429 -- tolerate mixed modes in a unit involving Ada 2005. That
10430 -- would cause real difficulties for those cases where there
10431 -- are incompatibilities between Ada 95 and Ada 2005.
10433 Check_Valid_Configuration_Pragma
;
10435 -- Now set appropriate Ada mode
10437 Ada_Version
:= Ada_2005
;
10438 Ada_Version_Explicit
:= Ada_2005
;
10439 Ada_Version_Pragma
:= N
;
10443 ---------------------
10444 -- Ada_12/Ada_2012 --
10445 ---------------------
10448 -- pragma Ada_12 (LOCAL_NAME);
10450 -- pragma Ada_2012;
10451 -- pragma Ada_2012 (LOCAL_NAME):
10453 -- Note: these pragmas also have some specific processing in Par.Prag
10454 -- because we want to set the Ada 2012 version mode during parsing.
10456 -- The one argument form is used for managing the transition from Ada
10457 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10458 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10459 -- mode will generate a warning. In addition, in any pre-Ada_2012
10460 -- mode, a preference rule is established which does not choose
10461 -- such an entity unless it is unambiguously specified. This avoids
10462 -- extra subprograms marked this way from generating ambiguities in
10463 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10464 -- intended for exclusive use in the GNAT run-time library.
10466 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10472 if Arg_Count
= 1 then
10473 Check_Arg_Is_Local_Name
(Arg1
);
10474 E_Id
:= Get_Pragma_Arg
(Arg1
);
10476 if Etype
(E_Id
) = Any_Type
then
10480 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10481 Record_Rep_Item
(Entity
(E_Id
), N
);
10484 Check_Arg_Count
(0);
10486 -- For Ada_2012 we unconditionally enforce the documented
10487 -- configuration pragma placement, since we do not want to
10488 -- tolerate mixed modes in a unit involving Ada 2012. That
10489 -- would cause real difficulties for those cases where there
10490 -- are incompatibilities between Ada 95 and Ada 2012. We could
10491 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10493 Check_Valid_Configuration_Pragma
;
10495 -- Now set appropriate Ada mode
10497 Ada_Version
:= Ada_2012
;
10498 Ada_Version_Explicit
:= Ada_2012
;
10499 Ada_Version_Pragma
:= N
;
10503 ----------------------
10504 -- All_Calls_Remote --
10505 ----------------------
10507 -- pragma All_Calls_Remote [(library_package_NAME)];
10509 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10510 Lib_Entity
: Entity_Id
;
10513 Check_Ada_83_Warning
;
10514 Check_Valid_Library_Unit_Pragma
;
10516 if Nkind
(N
) = N_Null_Statement
then
10520 Lib_Entity
:= Find_Lib_Unit_Name
;
10522 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10524 if Present
(Lib_Entity
)
10525 and then not Debug_Flag_U
10527 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10528 Error_Pragma
("pragma% only apply to rci unit");
10530 -- Set flag for entity of the library unit
10533 Set_Has_All_Calls_Remote
(Lib_Entity
);
10537 end All_Calls_Remote
;
10539 ---------------------------
10540 -- Allow_Integer_Address --
10541 ---------------------------
10543 -- pragma Allow_Integer_Address;
10545 when Pragma_Allow_Integer_Address
=>
10547 Check_Valid_Configuration_Pragma
;
10548 Check_Arg_Count
(0);
10550 -- If Address is a private type, then set the flag to allow
10551 -- integer address values. If Address is not private, then this
10552 -- pragma has no purpose, so it is simply ignored. Not clear if
10553 -- there are any such targets now.
10555 if Opt
.Address_Is_Private
then
10556 Opt
.Allow_Integer_Address
:= True;
10564 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10565 -- ARG ::= NAME | EXPRESSION
10567 -- The first two arguments are by convention intended to refer to an
10568 -- external tool and a tool-specific function. These arguments are
10571 when Pragma_Annotate
=> Annotate
: declare
10577 Check_At_Least_N_Arguments
(1);
10579 -- See if last argument is Entity => local_Name, and if so process
10580 -- and then remove it for remaining processing.
10583 Last_Arg
: constant Node_Id
:=
10584 Last
(Pragma_Argument_Associations
(N
));
10587 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
10588 and then Chars
(Last_Arg
) = Name_Entity
10590 Check_Arg_Is_Local_Name
(Last_Arg
);
10591 Arg_Count
:= Arg_Count
- 1;
10593 -- Not allowed in compiler units (bootstrap issues)
10595 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
10599 -- Continue processing with last argument removed for now
10601 Check_Arg_Is_Identifier
(Arg1
);
10602 Check_No_Identifiers
;
10605 -- Second parameter is optional, it is never analyzed
10610 -- Here if we have a second parameter
10613 -- Second parameter must be identifier
10615 Check_Arg_Is_Identifier
(Arg2
);
10617 -- Process remaining parameters if any
10619 Arg
:= Next
(Arg2
);
10620 while Present
(Arg
) loop
10621 Exp
:= Get_Pragma_Arg
(Arg
);
10624 if Is_Entity_Name
(Exp
) then
10627 -- For string literals, we assume Standard_String as the
10628 -- type, unless the string contains wide or wide_wide
10631 elsif Nkind
(Exp
) = N_String_Literal
then
10632 if Has_Wide_Wide_Character
(Exp
) then
10633 Resolve
(Exp
, Standard_Wide_Wide_String
);
10634 elsif Has_Wide_Character
(Exp
) then
10635 Resolve
(Exp
, Standard_Wide_String
);
10637 Resolve
(Exp
, Standard_String
);
10640 elsif Is_Overloaded
(Exp
) then
10642 ("ambiguous argument for pragma%", Exp
);
10653 -------------------------------------------------
10654 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
10655 -------------------------------------------------
10658 -- ( [Check => ] Boolean_EXPRESSION
10659 -- [, [Message =>] Static_String_EXPRESSION]);
10661 -- pragma Assert_And_Cut
10662 -- ( [Check => ] Boolean_EXPRESSION
10663 -- [, [Message =>] Static_String_EXPRESSION]);
10666 -- ( [Check => ] Boolean_EXPRESSION
10667 -- [, [Message =>] Static_String_EXPRESSION]);
10669 -- pragma Loop_Invariant
10670 -- ( [Check => ] Boolean_EXPRESSION
10671 -- [, [Message =>] Static_String_EXPRESSION]);
10673 when Pragma_Assert |
10674 Pragma_Assert_And_Cut |
10676 Pragma_Loop_Invariant
=>
10678 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
10679 -- Determine whether expression Expr contains a Loop_Entry
10680 -- attribute reference.
10682 -------------------------
10683 -- Contains_Loop_Entry --
10684 -------------------------
10686 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
10687 Has_Loop_Entry
: Boolean := False;
10689 function Process
(N
: Node_Id
) return Traverse_Result
;
10690 -- Process function for traversal to look for Loop_Entry
10696 function Process
(N
: Node_Id
) return Traverse_Result
is
10698 if Nkind
(N
) = N_Attribute_Reference
10699 and then Attribute_Name
(N
) = Name_Loop_Entry
10701 Has_Loop_Entry
:= True;
10708 procedure Traverse
is new Traverse_Proc
(Process
);
10710 -- Start of processing for Contains_Loop_Entry
10714 return Has_Loop_Entry
;
10715 end Contains_Loop_Entry
;
10722 -- Start of processing for Assert
10725 -- Assert is an Ada 2005 RM-defined pragma
10727 if Prag_Id
= Pragma_Assert
then
10730 -- The remaining ones are GNAT pragmas
10736 Check_At_Least_N_Arguments
(1);
10737 Check_At_Most_N_Arguments
(2);
10738 Check_Arg_Order
((Name_Check
, Name_Message
));
10739 Check_Optional_Identifier
(Arg1
, Name_Check
);
10740 Expr
:= Get_Pragma_Arg
(Arg1
);
10742 -- Special processing for Loop_Invariant, Loop_Variant or for
10743 -- other cases where a Loop_Entry attribute is present. If the
10744 -- assertion pragma contains attribute Loop_Entry, ensure that
10745 -- the related pragma is within a loop.
10747 if Prag_Id
= Pragma_Loop_Invariant
10748 or else Prag_Id
= Pragma_Loop_Variant
10749 or else Contains_Loop_Entry
(Expr
)
10751 Check_Loop_Pragma_Placement
;
10753 -- Perform preanalysis to deal with embedded Loop_Entry
10756 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
10759 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
10760 -- a corresponding Check pragma:
10762 -- pragma Check (name, condition [, msg]);
10764 -- Where name is the identifier matching the pragma name. So
10765 -- rewrite pragma in this manner, transfer the message argument
10766 -- if present, and analyze the result
10768 -- Note: When dealing with a semantically analyzed tree, the
10769 -- information that a Check node N corresponds to a source Assert,
10770 -- Assume, or Assert_And_Cut pragma can be retrieved from the
10771 -- pragma kind of Original_Node(N).
10774 Make_Pragma_Argument_Association
(Loc
,
10775 Expression
=> Make_Identifier
(Loc
, Pname
)),
10776 Make_Pragma_Argument_Association
(Sloc
(Expr
),
10777 Expression
=> Expr
));
10779 if Arg_Count
> 1 then
10780 Check_Optional_Identifier
(Arg2
, Name_Message
);
10782 -- Provide semantic annnotations for optional argument, for
10783 -- ASIS use, before rewriting.
10785 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
10786 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
10789 -- Rewrite as Check pragma
10793 Chars
=> Name_Check
,
10794 Pragma_Argument_Associations
=> Newa
));
10798 ----------------------
10799 -- Assertion_Policy --
10800 ----------------------
10802 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
10804 -- The following form is Ada 2012 only, but we allow it in all modes
10806 -- Pragma Assertion_Policy (
10807 -- ASSERTION_KIND => POLICY_IDENTIFIER
10808 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
10810 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
10812 -- RM_ASSERTION_KIND ::= Assert |
10813 -- Static_Predicate |
10814 -- Dynamic_Predicate |
10819 -- Type_Invariant |
10820 -- Type_Invariant'Class
10822 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
10824 -- Contract_Cases |
10826 -- Default_Initial_Condition |
10828 -- Initial_Condition |
10829 -- Loop_Invariant |
10835 -- Statement_Assertions
10837 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
10838 -- ID_ASSERTION_KIND list contains implementation-defined additions
10839 -- recognized by GNAT. The effect is to control the behavior of
10840 -- identically named aspects and pragmas, depending on the specified
10841 -- policy identifier:
10843 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
10845 -- Note: Check and Ignore are language-defined. Disable is a GNAT
10846 -- implementation defined addition that results in totally ignoring
10847 -- the corresponding assertion. If Disable is specified, then the
10848 -- argument of the assertion is not even analyzed. This is useful
10849 -- when the aspect/pragma argument references entities in a with'ed
10850 -- package that is replaced by a dummy package in the final build.
10852 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
10853 -- and Type_Invariant'Class were recognized by the parser and
10854 -- transformed into references to the special internal identifiers
10855 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
10856 -- processing is required here.
10858 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
10867 -- This can always appear as a configuration pragma
10869 if Is_Configuration_Pragma
then
10872 -- It can also appear in a declarative part or package spec in Ada
10873 -- 2012 mode. We allow this in other modes, but in that case we
10874 -- consider that we have an Ada 2012 pragma on our hands.
10877 Check_Is_In_Decl_Part_Or_Package_Spec
;
10881 -- One argument case with no identifier (first form above)
10884 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
10885 or else Chars
(Arg1
) = No_Name
)
10887 Check_Arg_Is_One_Of
10888 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
10890 -- Treat one argument Assertion_Policy as equivalent to:
10892 -- pragma Check_Policy (Assertion, policy)
10894 -- So rewrite pragma in that manner and link on to the chain
10895 -- of Check_Policy pragmas, marking the pragma as analyzed.
10897 Policy
:= Get_Pragma_Arg
(Arg1
);
10901 Chars
=> Name_Check_Policy
,
10902 Pragma_Argument_Associations
=> New_List
(
10903 Make_Pragma_Argument_Association
(Loc
,
10904 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
10906 Make_Pragma_Argument_Association
(Loc
,
10908 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
10911 -- Here if we have two or more arguments
10914 Check_At_Least_N_Arguments
(1);
10917 -- Loop through arguments
10920 while Present
(Arg
) loop
10921 LocP
:= Sloc
(Arg
);
10923 -- Kind must be specified
10925 if Nkind
(Arg
) /= N_Pragma_Argument_Association
10926 or else Chars
(Arg
) = No_Name
10929 ("missing assertion kind for pragma%", Arg
);
10932 -- Check Kind and Policy have allowed forms
10934 Kind
:= Chars
(Arg
);
10936 if not Is_Valid_Assertion_Kind
(Kind
) then
10938 ("invalid assertion kind for pragma%", Arg
);
10941 Check_Arg_Is_One_Of
10942 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
10944 -- Rewrite the Assertion_Policy pragma as a series of
10945 -- Check_Policy pragmas of the form:
10947 -- Check_Policy (Kind, Policy);
10949 -- Note: the insertion of the pragmas cannot be done with
10950 -- Insert_Action because in the configuration case, there
10951 -- are no scopes on the scope stack and the mechanism will
10954 Insert_Before_And_Analyze
(N
,
10956 Chars
=> Name_Check_Policy
,
10957 Pragma_Argument_Associations
=> New_List
(
10958 Make_Pragma_Argument_Association
(LocP
,
10959 Expression
=> Make_Identifier
(LocP
, Kind
)),
10960 Make_Pragma_Argument_Association
(LocP
,
10961 Expression
=> Get_Pragma_Arg
(Arg
)))));
10966 -- Rewrite the Assertion_Policy pragma as null since we have
10967 -- now inserted all the equivalent Check pragmas.
10969 Rewrite
(N
, Make_Null_Statement
(Loc
));
10972 end Assertion_Policy
;
10974 ------------------------------
10975 -- Assume_No_Invalid_Values --
10976 ------------------------------
10978 -- pragma Assume_No_Invalid_Values (On | Off);
10980 when Pragma_Assume_No_Invalid_Values
=>
10982 Check_Valid_Configuration_Pragma
;
10983 Check_Arg_Count
(1);
10984 Check_No_Identifiers
;
10985 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
10987 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
10988 Assume_No_Invalid_Values
:= True;
10990 Assume_No_Invalid_Values
:= False;
10993 --------------------------
10994 -- Attribute_Definition --
10995 --------------------------
10997 -- pragma Attribute_Definition
10998 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
10999 -- [Entity =>] LOCAL_NAME,
11000 -- [Expression =>] EXPRESSION | NAME);
11002 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11003 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11008 Check_Arg_Count
(3);
11009 Check_Optional_Identifier
(Arg1
, "attribute");
11010 Check_Optional_Identifier
(Arg2
, "entity");
11011 Check_Optional_Identifier
(Arg3
, "expression");
11013 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11014 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11018 Check_Arg_Is_Local_Name
(Arg2
);
11020 -- If the attribute is not recognized, then issue a warning (not
11021 -- an error), and ignore the pragma.
11023 Aname
:= Chars
(Attribute_Designator
);
11025 if not Is_Attribute_Name
(Aname
) then
11026 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11030 -- Otherwise, rewrite the pragma as an attribute definition clause
11033 Make_Attribute_Definition_Clause
(Loc
,
11034 Name
=> Get_Pragma_Arg
(Arg2
),
11036 Expression
=> Get_Pragma_Arg
(Arg3
)));
11038 end Attribute_Definition
;
11040 ------------------------------------------------------------------
11041 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11042 ------------------------------------------------------------------
11044 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11045 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11046 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11047 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11049 -- FLAG ::= boolean_EXPRESSION
11051 when Pragma_Async_Readers |
11052 Pragma_Async_Writers |
11053 Pragma_Effective_Reads |
11054 Pragma_Effective_Writes
=>
11055 Async_Effective
: declare
11059 Obj_Id
: Entity_Id
;
11063 Check_No_Identifiers
;
11064 Check_At_Least_N_Arguments
(1);
11065 Check_At_Most_N_Arguments
(2);
11066 Check_Arg_Is_Local_Name
(Arg1
);
11067 Error_Msg_Name_1
:= Pname
;
11069 Obj
:= Get_Pragma_Arg
(Arg1
);
11070 Expr
:= Get_Pragma_Arg
(Arg2
);
11072 -- Perform minimal verification to ensure that the argument is at
11073 -- least a variable. Subsequent finer grained checks will be done
11074 -- at the end of the declarative region the contains the pragma.
11076 if Is_Entity_Name
(Obj
)
11077 and then Present
(Entity
(Obj
))
11078 and then Ekind
(Entity
(Obj
)) = E_Variable
11080 Obj_Id
:= Entity
(Obj
);
11082 -- Detect a duplicate pragma. Note that it is not efficient to
11083 -- examine preceding statements as Boolean aspects may appear
11084 -- anywhere between the related object declaration and its
11085 -- freeze point. As an alternative, inspect the contents of the
11086 -- variable contract.
11088 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
11090 if Present
(Duplic
) then
11091 Error_Msg_Sloc
:= Sloc
(Duplic
);
11092 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
11094 -- No duplicate detected
11097 if Present
(Expr
) then
11098 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
11101 -- Chain the pragma on the contract for further processing
11102 -- by Analyze_External_Property_In_Decl_Part.
11104 Add_Contract_Item
(N
, Obj_Id
);
11107 Error_Pragma
("pragma % must apply to a volatile object");
11109 end Async_Effective
;
11115 -- pragma Asynchronous (LOCAL_NAME);
11117 when Pragma_Asynchronous
=> Asynchronous
: declare
11123 Formal
: Entity_Id
;
11125 procedure Process_Async_Pragma
;
11126 -- Common processing for procedure and access-to-procedure case
11128 --------------------------
11129 -- Process_Async_Pragma --
11130 --------------------------
11132 procedure Process_Async_Pragma
is
11135 Set_Is_Asynchronous
(Nm
);
11139 -- The formals should be of mode IN (RM E.4.1(6))
11142 while Present
(S
) loop
11143 Formal
:= Defining_Identifier
(S
);
11145 if Nkind
(Formal
) = N_Defining_Identifier
11146 and then Ekind
(Formal
) /= E_In_Parameter
11149 ("pragma% procedure can only have IN parameter",
11156 Set_Is_Asynchronous
(Nm
);
11157 end Process_Async_Pragma
;
11159 -- Start of processing for pragma Asynchronous
11162 Check_Ada_83_Warning
;
11163 Check_No_Identifiers
;
11164 Check_Arg_Count
(1);
11165 Check_Arg_Is_Local_Name
(Arg1
);
11167 if Debug_Flag_U
then
11171 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11172 Analyze
(Get_Pragma_Arg
(Arg1
));
11173 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11175 if not Is_Remote_Call_Interface
(C_Ent
)
11176 and then not Is_Remote_Types
(C_Ent
)
11178 -- This pragma should only appear in an RCI or Remote Types
11179 -- unit (RM E.4.1(4)).
11182 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11185 if Ekind
(Nm
) = E_Procedure
11186 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11188 if not Is_Remote_Call_Interface
(Nm
) then
11190 ("pragma% cannot be applied on non-remote procedure",
11194 L
:= Parameter_Specifications
(Parent
(Nm
));
11195 Process_Async_Pragma
;
11198 elsif Ekind
(Nm
) = E_Function
then
11200 ("pragma% cannot be applied to function", Arg1
);
11202 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11203 if Is_Record_Type
(Nm
) then
11205 -- A record type that is the Equivalent_Type for a remote
11206 -- access-to-subprogram type.
11208 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11211 -- A non-expanded RAS type (distribution is not enabled)
11213 N
:= Declaration_Node
(Nm
);
11216 if Nkind
(N
) = N_Full_Type_Declaration
11217 and then Nkind
(Type_Definition
(N
)) =
11218 N_Access_Procedure_Definition
11220 L
:= Parameter_Specifications
(Type_Definition
(N
));
11221 Process_Async_Pragma
;
11223 if Is_Asynchronous
(Nm
)
11224 and then Expander_Active
11225 and then Get_PCS_Name
/= Name_No_DSA
11227 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11232 ("pragma% cannot reference access-to-function type",
11236 -- Only other possibility is Access-to-class-wide type
11238 elsif Is_Access_Type
(Nm
)
11239 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11241 Check_First_Subtype
(Arg1
);
11242 Set_Is_Asynchronous
(Nm
);
11243 if Expander_Active
then
11244 RACW_Type_Is_Asynchronous
(Nm
);
11248 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11256 -- pragma Atomic (LOCAL_NAME);
11258 when Pragma_Atomic
=>
11259 Process_Atomic_Independent_Shared_Volatile
;
11261 -----------------------
11262 -- Atomic_Components --
11263 -----------------------
11265 -- pragma Atomic_Components (array_LOCAL_NAME);
11267 -- This processing is shared by Volatile_Components
11269 when Pragma_Atomic_Components |
11270 Pragma_Volatile_Components
=>
11272 Atomic_Components
: declare
11279 Check_Ada_83_Warning
;
11280 Check_No_Identifiers
;
11281 Check_Arg_Count
(1);
11282 Check_Arg_Is_Local_Name
(Arg1
);
11283 E_Id
:= Get_Pragma_Arg
(Arg1
);
11285 if Etype
(E_Id
) = Any_Type
then
11289 E
:= Entity
(E_Id
);
11291 Check_Duplicate_Pragma
(E
);
11293 if Rep_Item_Too_Early
(E
, N
)
11295 Rep_Item_Too_Late
(E
, N
)
11300 D
:= Declaration_Node
(E
);
11303 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11305 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11306 and then Nkind
(D
) = N_Object_Declaration
11307 and then Nkind
(Object_Definition
(D
)) =
11308 N_Constrained_Array_Definition
)
11310 -- The flag is set on the object, or on the base type
11312 if Nkind
(D
) /= N_Object_Declaration
then
11313 E
:= Base_Type
(E
);
11316 -- Atomic implies both Independent and Volatile
11318 if Prag_Id
= Pragma_Atomic_Components
then
11319 Set_Has_Atomic_Components
(E
);
11320 Set_Has_Independent_Components
(E
);
11323 Set_Has_Volatile_Components
(E
);
11326 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11328 end Atomic_Components
;
11330 --------------------
11331 -- Attach_Handler --
11332 --------------------
11334 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11336 when Pragma_Attach_Handler
=>
11337 Check_Ada_83_Warning
;
11338 Check_No_Identifiers
;
11339 Check_Arg_Count
(2);
11341 if No_Run_Time_Mode
then
11342 Error_Msg_CRT
("Attach_Handler pragma", N
);
11344 Check_Interrupt_Or_Attach_Handler
;
11346 -- The expression that designates the attribute may depend on a
11347 -- discriminant, and is therefore a per-object expression, to
11348 -- be expanded in the init proc. If expansion is enabled, then
11349 -- perform semantic checks on a copy only.
11354 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11357 -- In Relaxed_RM_Semantics mode, we allow any static
11358 -- integer value, for compatibility with other compilers.
11360 if Relaxed_RM_Semantics
11361 and then Nkind
(Parg2
) = N_Integer_Literal
11363 Typ
:= Standard_Integer
;
11365 Typ
:= RTE
(RE_Interrupt_ID
);
11368 if Expander_Active
then
11369 Temp
:= New_Copy_Tree
(Parg2
);
11370 Set_Parent
(Temp
, N
);
11371 Preanalyze_And_Resolve
(Temp
, Typ
);
11374 Resolve
(Parg2
, Typ
);
11378 Process_Interrupt_Or_Attach_Handler
;
11381 --------------------
11382 -- C_Pass_By_Copy --
11383 --------------------
11385 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11387 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11393 Check_Valid_Configuration_Pragma
;
11394 Check_Arg_Count
(1);
11395 Check_Optional_Identifier
(Arg1
, "max_size");
11397 Arg
:= Get_Pragma_Arg
(Arg1
);
11398 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11400 Val
:= Expr_Value
(Arg
);
11404 ("maximum size for pragma% must be positive", Arg1
);
11406 elsif UI_Is_In_Int_Range
(Val
) then
11407 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11409 -- If a giant value is given, Int'Last will do well enough.
11410 -- If sometime someone complains that a record larger than
11411 -- two gigabytes is not copied, we will worry about it then.
11414 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11416 end C_Pass_By_Copy
;
11422 -- pragma Check ([Name =>] CHECK_KIND,
11423 -- [Check =>] Boolean_EXPRESSION
11424 -- [,[Message =>] String_EXPRESSION]);
11426 -- CHECK_KIND ::= IDENTIFIER |
11429 -- Invariant'Class |
11430 -- Type_Invariant'Class
11432 -- The identifiers Assertions and Statement_Assertions are not
11433 -- allowed, since they have special meaning for Check_Policy.
11435 when Pragma_Check
=> Check
: declare
11443 Check_At_Least_N_Arguments
(2);
11444 Check_At_Most_N_Arguments
(3);
11445 Check_Optional_Identifier
(Arg1
, Name_Name
);
11446 Check_Optional_Identifier
(Arg2
, Name_Check
);
11448 if Arg_Count
= 3 then
11449 Check_Optional_Identifier
(Arg3
, Name_Message
);
11450 Str
:= Get_Pragma_Arg
(Arg3
);
11453 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11454 Check_Arg_Is_Identifier
(Arg1
);
11455 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11457 -- Check forbidden name Assertions or Statement_Assertions
11460 when Name_Assertions
=>
11462 ("""Assertions"" is not allowed as a check kind "
11463 & "for pragma%", Arg1
);
11465 when Name_Statement_Assertions
=>
11467 ("""Statement_Assertions"" is not allowed as a check kind "
11468 & "for pragma%", Arg1
);
11474 -- Check applicable policy. We skip this if Checked/Ignored status
11475 -- is already set (e.g. in the case of a pragma from an aspect).
11477 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11480 -- For a non-source pragma that is a rewriting of another pragma,
11481 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11483 elsif Is_Rewrite_Substitution
(N
)
11484 and then Nkind
(Original_Node
(N
)) = N_Pragma
11485 and then Original_Node
(N
) /= N
11487 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11488 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11490 -- Otherwise query the applicable policy at this point
11493 case Check_Kind
(Cname
) is
11494 when Name_Ignore
=>
11495 Set_Is_Ignored
(N
, True);
11496 Set_Is_Checked
(N
, False);
11499 Set_Is_Ignored
(N
, False);
11500 Set_Is_Checked
(N
, True);
11502 -- For disable, rewrite pragma as null statement and skip
11503 -- rest of the analysis of the pragma.
11505 when Name_Disable
=>
11506 Rewrite
(N
, Make_Null_Statement
(Loc
));
11510 -- No other possibilities
11513 raise Program_Error
;
11517 -- If check kind was not Disable, then continue pragma analysis
11519 Expr
:= Get_Pragma_Arg
(Arg2
);
11521 -- Deal with SCO generation
11524 when Name_Predicate |
11527 -- Nothing to do: since checks occur in client units,
11528 -- the SCO for the aspect in the declaration unit is
11529 -- conservatively always enabled.
11535 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11537 -- Mark aspect/pragma SCO as enabled
11539 Set_SCO_Pragma_Enabled
(Loc
);
11543 -- Deal with analyzing the string argument
11545 if Arg_Count
= 3 then
11547 -- If checks are not on we don't want any expansion (since
11548 -- such expansion would not get properly deleted) but
11549 -- we do want to analyze (to get proper references).
11550 -- The Preanalyze_And_Resolve routine does just what we want
11552 if Is_Ignored
(N
) then
11553 Preanalyze_And_Resolve
(Str
, Standard_String
);
11555 -- Otherwise we need a proper analysis and expansion
11558 Analyze_And_Resolve
(Str
, Standard_String
);
11562 -- Now you might think we could just do the same with the Boolean
11563 -- expression if checks are off (and expansion is on) and then
11564 -- rewrite the check as a null statement. This would work but we
11565 -- would lose the useful warnings about an assertion being bound
11566 -- to fail even if assertions are turned off.
11568 -- So instead we wrap the boolean expression in an if statement
11569 -- that looks like:
11571 -- if False and then condition then
11575 -- The reason we do this rewriting during semantic analysis rather
11576 -- than as part of normal expansion is that we cannot analyze and
11577 -- expand the code for the boolean expression directly, or it may
11578 -- cause insertion of actions that would escape the attempt to
11579 -- suppress the check code.
11581 -- Note that the Sloc for the if statement corresponds to the
11582 -- argument condition, not the pragma itself. The reason for
11583 -- this is that we may generate a warning if the condition is
11584 -- False at compile time, and we do not want to delete this
11585 -- warning when we delete the if statement.
11587 if Expander_Active
and Is_Ignored
(N
) then
11588 Eloc
:= Sloc
(Expr
);
11591 Make_If_Statement
(Eloc
,
11593 Make_And_Then
(Eloc
,
11594 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
11595 Right_Opnd
=> Expr
),
11596 Then_Statements
=> New_List
(
11597 Make_Null_Statement
(Eloc
))));
11599 -- Now go ahead and analyze the if statement
11601 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11603 -- One rather special treatment. If we are now in Eliminated
11604 -- overflow mode, then suppress overflow checking since we do
11605 -- not want to drag in the bignum stuff if we are in Ignore
11606 -- mode anyway. This is particularly important if we are using
11607 -- a configurable run time that does not support bignum ops.
11609 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
11611 Svo
: constant Boolean :=
11612 Scope_Suppress
.Suppress
(Overflow_Check
);
11614 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
11615 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
11617 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
11618 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
11621 -- Not that special case!
11627 -- All done with this check
11629 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11631 -- Check is active or expansion not active. In these cases we can
11632 -- just go ahead and analyze the boolean with no worries.
11635 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11636 Analyze_And_Resolve
(Expr
, Any_Boolean
);
11637 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11641 --------------------------
11642 -- Check_Float_Overflow --
11643 --------------------------
11645 -- pragma Check_Float_Overflow;
11647 when Pragma_Check_Float_Overflow
=>
11649 Check_Valid_Configuration_Pragma
;
11650 Check_Arg_Count
(0);
11651 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
11657 -- pragma Check_Name (check_IDENTIFIER);
11659 when Pragma_Check_Name
=>
11661 Check_No_Identifiers
;
11662 Check_Valid_Configuration_Pragma
;
11663 Check_Arg_Count
(1);
11664 Check_Arg_Is_Identifier
(Arg1
);
11667 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
11670 for J
in Check_Names
.First
.. Check_Names
.Last
loop
11671 if Check_Names
.Table
(J
) = Nam
then
11676 Check_Names
.Append
(Nam
);
11683 -- This is the old style syntax, which is still allowed in all modes:
11685 -- pragma Check_Policy ([Name =>] CHECK_KIND
11686 -- [Policy =>] POLICY_IDENTIFIER);
11688 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
11690 -- CHECK_KIND ::= IDENTIFIER |
11693 -- Type_Invariant'Class |
11696 -- This is the new style syntax, compatible with Assertion_Policy
11697 -- and also allowed in all modes.
11699 -- Pragma Check_Policy (
11700 -- CHECK_KIND => POLICY_IDENTIFIER
11701 -- {, CHECK_KIND => POLICY_IDENTIFIER});
11703 -- Note: the identifiers Name and Policy are not allowed as
11704 -- Check_Kind values. This avoids ambiguities between the old and
11705 -- new form syntax.
11707 when Pragma_Check_Policy
=> Check_Policy
: declare
11713 Check_At_Least_N_Arguments
(1);
11715 -- A Check_Policy pragma can appear either as a configuration
11716 -- pragma, or in a declarative part or a package spec (see RM
11717 -- 11.5(5) for rules for Suppress/Unsuppress which are also
11718 -- followed for Check_Policy).
11720 if not Is_Configuration_Pragma
then
11721 Check_Is_In_Decl_Part_Or_Package_Spec
;
11724 -- Figure out if we have the old or new syntax. We have the
11725 -- old syntax if the first argument has no identifier, or the
11726 -- identifier is Name.
11728 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
11729 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
11733 Check_Arg_Count
(2);
11734 Check_Optional_Identifier
(Arg1
, Name_Name
);
11735 Kind
:= Get_Pragma_Arg
(Arg1
);
11736 Rewrite_Assertion_Kind
(Kind
);
11737 Check_Arg_Is_Identifier
(Arg1
);
11739 -- Check forbidden check kind
11741 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
11742 Error_Msg_Name_2
:= Chars
(Kind
);
11744 ("pragma% does not allow% as check name", Arg1
);
11749 Check_Optional_Identifier
(Arg2
, Name_Policy
);
11750 Check_Arg_Is_One_Of
11752 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
11753 Ident
:= Get_Pragma_Arg
(Arg2
);
11755 if Chars
(Kind
) = Name_Ghost
then
11757 -- Pragma Check_Policy specifying a Ghost policy cannot
11758 -- occur within a ghost subprogram or package.
11760 if Ghost_Mode
> None
then
11762 ("pragma % cannot appear within ghost subprogram or "
11765 -- The policy identifier of pragma Ghost must be either
11766 -- Check or Ignore (SPARK RM 6.9(7)).
11768 elsif not Nam_In
(Chars
(Ident
), Name_Check
,
11772 ("argument of pragma % Ghost must be Check or Ignore",
11777 -- And chain pragma on the Check_Policy_List for search
11779 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
11780 Opt
.Check_Policy_List
:= N
;
11782 -- For the new syntax, what we do is to convert each argument to
11783 -- an old syntax equivalent. We do that because we want to chain
11784 -- old style Check_Policy pragmas for the search (we don't want
11785 -- to have to deal with multiple arguments in the search).
11795 while Present
(Arg
) loop
11796 LocP
:= Sloc
(Arg
);
11797 Argx
:= Get_Pragma_Arg
(Arg
);
11799 -- Kind must be specified
11801 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11802 or else Chars
(Arg
) = No_Name
11805 ("missing assertion kind for pragma%", Arg
);
11808 -- Construct equivalent old form syntax Check_Policy
11809 -- pragma and insert it to get remaining checks.
11813 Chars
=> Name_Check_Policy
,
11814 Pragma_Argument_Associations
=> New_List
(
11815 Make_Pragma_Argument_Association
(LocP
,
11817 Make_Identifier
(LocP
, Chars
(Arg
))),
11818 Make_Pragma_Argument_Association
(Sloc
(Argx
),
11819 Expression
=> Argx
))));
11824 -- Rewrite original Check_Policy pragma to null, since we
11825 -- have converted it into a series of old syntax pragmas.
11827 Rewrite
(N
, Make_Null_Statement
(Loc
));
11833 ---------------------
11834 -- CIL_Constructor --
11835 ---------------------
11837 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
11839 -- Processing for this pragma is shared with Java_Constructor
11845 -- pragma Comment (static_string_EXPRESSION)
11847 -- Processing for pragma Comment shares the circuitry for pragma
11848 -- Ident. The only differences are that Ident enforces a limit of 31
11849 -- characters on its argument, and also enforces limitations on
11850 -- placement for DEC compatibility. Pragma Comment shares neither of
11851 -- these restrictions.
11853 -------------------
11854 -- Common_Object --
11855 -------------------
11857 -- pragma Common_Object (
11858 -- [Internal =>] LOCAL_NAME
11859 -- [, [External =>] EXTERNAL_SYMBOL]
11860 -- [, [Size =>] EXTERNAL_SYMBOL]);
11862 -- Processing for this pragma is shared with Psect_Object
11864 ------------------------
11865 -- Compile_Time_Error --
11866 ------------------------
11868 -- pragma Compile_Time_Error
11869 -- (boolean_EXPRESSION, static_string_EXPRESSION);
11871 when Pragma_Compile_Time_Error
=>
11873 Process_Compile_Time_Warning_Or_Error
;
11875 --------------------------
11876 -- Compile_Time_Warning --
11877 --------------------------
11879 -- pragma Compile_Time_Warning
11880 -- (boolean_EXPRESSION, static_string_EXPRESSION);
11882 when Pragma_Compile_Time_Warning
=>
11884 Process_Compile_Time_Warning_Or_Error
;
11886 ---------------------------
11887 -- Compiler_Unit_Warning --
11888 ---------------------------
11890 -- pragma Compiler_Unit_Warning;
11894 -- Originally, we had only pragma Compiler_Unit, and it resulted in
11895 -- errors not warnings. This means that we had introduced a big extra
11896 -- inertia to compiler changes, since even if we implemented a new
11897 -- feature, and even if all versions to be used for bootstrapping
11898 -- implemented this new feature, we could not use it, since old
11899 -- compilers would give errors for using this feature in units
11900 -- having Compiler_Unit pragmas.
11902 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
11903 -- problem. We no longer have any units mentioning Compiler_Unit,
11904 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
11905 -- and thus generates a warning which can be ignored. So that deals
11906 -- with the problem of old compilers not implementing the newer form
11909 -- Newer compilers recognize the new pragma, but generate warning
11910 -- messages instead of errors, which again can be ignored in the
11911 -- case of an old compiler which implements a wanted new feature
11912 -- but at the time felt like warning about it for older compilers.
11914 -- We retain Compiler_Unit so that new compilers can be used to build
11915 -- older run-times that use this pragma. That's an unusual case, but
11916 -- it's easy enough to handle, so why not?
11918 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
11920 Check_Arg_Count
(0);
11922 -- Only recognized in main unit
11924 if Current_Sem_Unit
= Main_Unit
then
11925 Compiler_Unit
:= True;
11928 -----------------------------
11929 -- Complete_Representation --
11930 -----------------------------
11932 -- pragma Complete_Representation;
11934 when Pragma_Complete_Representation
=>
11936 Check_Arg_Count
(0);
11938 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
11940 ("pragma & must appear within record representation clause");
11943 ----------------------------
11944 -- Complex_Representation --
11945 ----------------------------
11947 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
11949 when Pragma_Complex_Representation
=> Complex_Representation
: declare
11956 Check_Arg_Count
(1);
11957 Check_Optional_Identifier
(Arg1
, Name_Entity
);
11958 Check_Arg_Is_Local_Name
(Arg1
);
11959 E_Id
:= Get_Pragma_Arg
(Arg1
);
11961 if Etype
(E_Id
) = Any_Type
then
11965 E
:= Entity
(E_Id
);
11967 if not Is_Record_Type
(E
) then
11969 ("argument for pragma% must be record type", Arg1
);
11972 Ent
:= First_Entity
(E
);
11975 or else No
(Next_Entity
(Ent
))
11976 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
11977 or else not Is_Floating_Point_Type
(Etype
(Ent
))
11978 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
11981 ("record for pragma% must have two fields of the same "
11982 & "floating-point type", Arg1
);
11985 Set_Has_Complex_Representation
(Base_Type
(E
));
11987 -- We need to treat the type has having a non-standard
11988 -- representation, for back-end purposes, even though in
11989 -- general a complex will have the default representation
11990 -- of a record with two real components.
11992 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
11994 end Complex_Representation
;
11996 -------------------------
11997 -- Component_Alignment --
11998 -------------------------
12000 -- pragma Component_Alignment (
12001 -- [Form =>] ALIGNMENT_CHOICE
12002 -- [, [Name =>] type_LOCAL_NAME]);
12004 -- ALIGNMENT_CHOICE ::=
12006 -- | Component_Size_4
12010 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12011 Args
: Args_List
(1 .. 2);
12012 Names
: constant Name_List
(1 .. 2) := (
12016 Form
: Node_Id
renames Args
(1);
12017 Name
: Node_Id
renames Args
(2);
12019 Atype
: Component_Alignment_Kind
;
12024 Gather_Associations
(Names
, Args
);
12027 Error_Pragma
("missing Form argument for pragma%");
12030 Check_Arg_Is_Identifier
(Form
);
12032 -- Get proper alignment, note that Default = Component_Size on all
12033 -- machines we have so far, and we want to set this value rather
12034 -- than the default value to indicate that it has been explicitly
12035 -- set (and thus will not get overridden by the default component
12036 -- alignment for the current scope)
12038 if Chars
(Form
) = Name_Component_Size
then
12039 Atype
:= Calign_Component_Size
;
12041 elsif Chars
(Form
) = Name_Component_Size_4
then
12042 Atype
:= Calign_Component_Size_4
;
12044 elsif Chars
(Form
) = Name_Default
then
12045 Atype
:= Calign_Component_Size
;
12047 elsif Chars
(Form
) = Name_Storage_Unit
then
12048 Atype
:= Calign_Storage_Unit
;
12052 ("invalid Form parameter for pragma%", Form
);
12055 -- Case with no name, supplied, affects scope table entry
12059 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12061 -- Case of name supplied
12064 Check_Arg_Is_Local_Name
(Name
);
12066 Typ
:= Entity
(Name
);
12069 or else Rep_Item_Too_Early
(Typ
, N
)
12073 Typ
:= Underlying_Type
(Typ
);
12076 if not Is_Record_Type
(Typ
)
12077 and then not Is_Array_Type
(Typ
)
12080 ("Name parameter of pragma% must identify record or "
12081 & "array type", Name
);
12084 -- An explicit Component_Alignment pragma overrides an
12085 -- implicit pragma Pack, but not an explicit one.
12087 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12088 Set_Is_Packed
(Base_Type
(Typ
), False);
12089 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12092 end Component_AlignmentP
;
12094 --------------------
12095 -- Contract_Cases --
12096 --------------------
12098 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12100 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12102 -- CASE_GUARD ::= boolean_EXPRESSION | others
12104 -- CONSEQUENCE ::= boolean_EXPRESSION
12106 -- Characteristics:
12108 -- * Analysis - The annotation undergoes initial checks to verify
12109 -- the legal placement and context. Secondary checks preanalyze the
12112 -- Analyze_Contract_Cases_In_Decl_Part
12114 -- * Expansion - The annotation is expanded during the expansion of
12115 -- the related subprogram [body] contract as performed in:
12117 -- Expand_Subprogram_Contract
12119 -- * Template - The annotation utilizes the generic template of the
12120 -- related subprogram [body] when it is:
12122 -- aspect on subprogram declaration
12123 -- aspect on stand alone subprogram body
12124 -- pragma on stand alone subprogram body
12126 -- The annotation must prepare its own template when it is:
12128 -- pragma on subprogram declaration
12130 -- * Globals - Capture of global references must occur after full
12133 -- * Instance - The annotation is instantiated automatically when
12134 -- the related generic subprogram [body] is instantiated except for
12135 -- the "pragma on subprogram declaration" case. In that scenario
12136 -- the annotation must instantiate itself.
12138 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12139 Spec_Id
: Entity_Id
;
12140 Subp_Decl
: Node_Id
;
12144 Check_No_Identifiers
;
12145 Check_Arg_Count
(1);
12147 -- The pragma is analyzed at the end of the declarative part which
12148 -- contains the related subprogram. Reset the analyzed flag.
12150 Set_Analyzed
(N
, False);
12152 -- Ensure the proper placement of the pragma. Contract_Cases must
12153 -- be associated with a subprogram declaration or a body that acts
12157 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12159 -- Generic subprogram
12161 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
12164 -- Body acts as spec
12166 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12167 and then No
(Corresponding_Spec
(Subp_Decl
))
12171 -- Body stub acts as spec
12173 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12174 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12180 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12188 Spec_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
12190 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
12192 -- Fully analyze the pragma when it appears inside a subprogram
12193 -- body because it cannot benefit from forward references.
12195 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12196 Analyze_Contract_Cases_In_Decl_Part
(N
);
12199 -- Chain the pragma on the contract for further processing by
12200 -- Analyze_Contract_Cases_In_Decl_Part.
12202 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12203 end Contract_Cases
;
12209 -- pragma Controlled (first_subtype_LOCAL_NAME);
12211 when Pragma_Controlled
=> Controlled
: declare
12215 Check_No_Identifiers
;
12216 Check_Arg_Count
(1);
12217 Check_Arg_Is_Local_Name
(Arg1
);
12218 Arg
:= Get_Pragma_Arg
(Arg1
);
12220 if not Is_Entity_Name
(Arg
)
12221 or else not Is_Access_Type
(Entity
(Arg
))
12223 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12225 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12233 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12234 -- [Entity =>] LOCAL_NAME);
12236 when Pragma_Convention
=> Convention
: declare
12239 pragma Warnings
(Off
, C
);
12240 pragma Warnings
(Off
, E
);
12242 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12243 Check_Ada_83_Warning
;
12244 Check_Arg_Count
(2);
12245 Process_Convention
(C
, E
);
12248 ---------------------------
12249 -- Convention_Identifier --
12250 ---------------------------
12252 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12253 -- [Convention =>] convention_IDENTIFIER);
12255 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12261 Check_Arg_Order
((Name_Name
, Name_Convention
));
12262 Check_Arg_Count
(2);
12263 Check_Optional_Identifier
(Arg1
, Name_Name
);
12264 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12265 Check_Arg_Is_Identifier
(Arg1
);
12266 Check_Arg_Is_Identifier
(Arg2
);
12267 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12268 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12270 if Is_Convention_Name
(Cname
) then
12271 Record_Convention_Identifier
12272 (Idnam
, Get_Convention_Id
(Cname
));
12275 ("second arg for % pragma must be convention", Arg2
);
12277 end Convention_Identifier
;
12283 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12285 when Pragma_CPP_Class
=> CPP_Class
: declare
12289 if Warn_On_Obsolescent_Feature
then
12291 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12292 & "effect; replace it by pragma import?j?", N
);
12295 Check_Arg_Count
(1);
12299 Chars
=> Name_Import
,
12300 Pragma_Argument_Associations
=> New_List
(
12301 Make_Pragma_Argument_Association
(Loc
,
12302 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12303 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12307 ---------------------
12308 -- CPP_Constructor --
12309 ---------------------
12311 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12312 -- [, [External_Name =>] static_string_EXPRESSION ]
12313 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12315 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12318 Def_Id
: Entity_Id
;
12319 Tag_Typ
: Entity_Id
;
12323 Check_At_Least_N_Arguments
(1);
12324 Check_At_Most_N_Arguments
(3);
12325 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12326 Check_Arg_Is_Local_Name
(Arg1
);
12328 Id
:= Get_Pragma_Arg
(Arg1
);
12329 Find_Program_Unit_Name
(Id
);
12331 -- If we did not find the name, we are done
12333 if Etype
(Id
) = Any_Type
then
12337 Def_Id
:= Entity
(Id
);
12339 -- Check if already defined as constructor
12341 if Is_Constructor
(Def_Id
) then
12343 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12347 if Ekind
(Def_Id
) = E_Function
12348 and then (Is_CPP_Class
(Etype
(Def_Id
))
12349 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12351 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12353 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12355 ("'C'P'P constructor must be defined in the scope of "
12356 & "its returned type", Arg1
);
12359 if Arg_Count
>= 2 then
12360 Set_Imported
(Def_Id
);
12361 Set_Is_Public
(Def_Id
);
12362 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12365 Set_Has_Completion
(Def_Id
);
12366 Set_Is_Constructor
(Def_Id
);
12367 Set_Convention
(Def_Id
, Convention_CPP
);
12369 -- Imported C++ constructors are not dispatching primitives
12370 -- because in C++ they don't have a dispatch table slot.
12371 -- However, in Ada the constructor has the profile of a
12372 -- function that returns a tagged type and therefore it has
12373 -- been treated as a primitive operation during semantic
12374 -- analysis. We now remove it from the list of primitive
12375 -- operations of the type.
12377 if Is_Tagged_Type
(Etype
(Def_Id
))
12378 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12379 and then Is_Dispatching_Operation
(Def_Id
)
12381 Tag_Typ
:= Etype
(Def_Id
);
12383 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12384 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12388 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12389 Set_Is_Dispatching_Operation
(Def_Id
, False);
12392 -- For backward compatibility, if the constructor returns a
12393 -- class wide type, and we internally change the return type to
12394 -- the corresponding root type.
12396 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12397 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12401 ("pragma% requires function returning a 'C'P'P_Class type",
12404 end CPP_Constructor
;
12410 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12414 if Warn_On_Obsolescent_Feature
then
12416 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12425 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12429 if Warn_On_Obsolescent_Feature
then
12431 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12440 -- pragma CPU (EXPRESSION);
12442 when Pragma_CPU
=> CPU
: declare
12443 P
: constant Node_Id
:= Parent
(N
);
12449 Check_No_Identifiers
;
12450 Check_Arg_Count
(1);
12454 if Nkind
(P
) = N_Subprogram_Body
then
12455 Check_In_Main_Program
;
12457 Arg
:= Get_Pragma_Arg
(Arg1
);
12458 Analyze_And_Resolve
(Arg
, Any_Integer
);
12460 Ent
:= Defining_Unit_Name
(Specification
(P
));
12462 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12463 Ent
:= Defining_Identifier
(Ent
);
12468 if not Is_OK_Static_Expression
(Arg
) then
12469 Flag_Non_Static_Expr
12470 ("main subprogram affinity is not static!", Arg
);
12473 -- If constraint error, then we already signalled an error
12475 elsif Raises_Constraint_Error
(Arg
) then
12478 -- Otherwise check in range
12482 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12483 -- This is the entity System.Multiprocessors.CPU_Range;
12485 Val
: constant Uint
:= Expr_Value
(Arg
);
12488 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12490 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12493 ("main subprogram CPU is out of range", Arg1
);
12499 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12503 elsif Nkind
(P
) = N_Task_Definition
then
12504 Arg
:= Get_Pragma_Arg
(Arg1
);
12505 Ent
:= Defining_Identifier
(Parent
(P
));
12507 -- The expression must be analyzed in the special manner
12508 -- described in "Handling of Default and Per-Object
12509 -- Expressions" in sem.ads.
12511 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12513 -- Anything else is incorrect
12519 -- Check duplicate pragma before we chain the pragma in the Rep
12520 -- Item chain of Ent.
12522 Check_Duplicate_Pragma
(Ent
);
12523 Record_Rep_Item
(Ent
, N
);
12530 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12532 when Pragma_Debug
=> Debug
: declare
12539 -- The condition for executing the call is that the expander
12540 -- is active and that we are not ignoring this debug pragma.
12545 (Expander_Active
and then not Is_Ignored
(N
)),
12548 if not Is_Ignored
(N
) then
12549 Set_SCO_Pragma_Enabled
(Loc
);
12552 if Arg_Count
= 2 then
12554 Make_And_Then
(Loc
,
12555 Left_Opnd
=> Relocate_Node
(Cond
),
12556 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12557 Call
:= Get_Pragma_Arg
(Arg2
);
12559 Call
:= Get_Pragma_Arg
(Arg1
);
12563 N_Indexed_Component
,
12567 N_Selected_Component
)
12569 -- If this pragma Debug comes from source, its argument was
12570 -- parsed as a name form (which is syntactically identical).
12571 -- In a generic context a parameterless call will be left as
12572 -- an expanded name (if global) or selected_component if local.
12573 -- Change it to a procedure call statement now.
12575 Change_Name_To_Procedure_Call_Statement
(Call
);
12577 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12579 -- Already in the form of a procedure call statement: nothing
12580 -- to do (could happen in case of an internally generated
12586 -- All other cases: diagnose error
12589 ("argument of pragma ""Debug"" is not procedure call",
12594 -- Rewrite into a conditional with an appropriate condition. We
12595 -- wrap the procedure call in a block so that overhead from e.g.
12596 -- use of the secondary stack does not generate execution overhead
12597 -- for suppressed conditions.
12599 -- Normally the analysis that follows will freeze the subprogram
12600 -- being called. However, if the call is to a null procedure,
12601 -- we want to freeze it before creating the block, because the
12602 -- analysis that follows may be done with expansion disabled, in
12603 -- which case the body will not be generated, leading to spurious
12606 if Nkind
(Call
) = N_Procedure_Call_Statement
12607 and then Is_Entity_Name
(Name
(Call
))
12609 Analyze
(Name
(Call
));
12610 Freeze_Before
(N
, Entity
(Name
(Call
)));
12614 Make_Implicit_If_Statement
(N
,
12616 Then_Statements
=> New_List
(
12617 Make_Block_Statement
(Loc
,
12618 Handled_Statement_Sequence
=>
12619 Make_Handled_Sequence_Of_Statements
(Loc
,
12620 Statements
=> New_List
(Relocate_Node
(Call
)))))));
12623 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12624 -- after analysis of the normally rewritten node, to capture all
12625 -- references to entities, which avoids issuing wrong warnings
12626 -- about unused entities.
12628 if GNATprove_Mode
then
12629 Rewrite
(N
, Make_Null_Statement
(Loc
));
12637 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12639 when Pragma_Debug_Policy
=>
12641 Check_Arg_Count
(1);
12642 Check_No_Identifiers
;
12643 Check_Arg_Is_Identifier
(Arg1
);
12645 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12646 -- rewrite it that way, and let the rest of the checking come
12647 -- from analyzing the rewritten pragma.
12651 Chars
=> Name_Check_Policy
,
12652 Pragma_Argument_Associations
=> New_List
(
12653 Make_Pragma_Argument_Association
(Loc
,
12654 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
12656 Make_Pragma_Argument_Association
(Loc
,
12657 Expression
=> Get_Pragma_Arg
(Arg1
)))));
12660 -------------------------------
12661 -- Default_Initial_Condition --
12662 -------------------------------
12664 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
12666 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
12673 Check_No_Identifiers
;
12674 Check_At_Most_N_Arguments
(1);
12677 while Present
(Stmt
) loop
12679 -- Skip prior pragmas, but check for duplicates
12681 if Nkind
(Stmt
) = N_Pragma
then
12682 if Pragma_Name
(Stmt
) = Pname
then
12683 Error_Msg_Name_1
:= Pname
;
12684 Error_Msg_Sloc
:= Sloc
(Stmt
);
12685 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
12688 -- Skip internally generated code
12690 elsif not Comes_From_Source
(Stmt
) then
12693 -- The associated private type [extension] has been found, stop
12696 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
12697 N_Private_Type_Declaration
)
12699 Typ
:= Defining_Entity
(Stmt
);
12702 -- The pragma does not apply to a legal construct, issue an
12703 -- error and stop the analysis.
12710 Stmt
:= Prev
(Stmt
);
12713 Set_Has_Default_Init_Cond
(Typ
);
12714 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
12716 -- Chain the pragma on the rep item chain for further processing
12718 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
12719 end Default_Init_Cond
;
12721 ----------------------------------
12722 -- Default_Scalar_Storage_Order --
12723 ----------------------------------
12725 -- pragma Default_Scalar_Storage_Order
12726 -- (High_Order_First | Low_Order_First);
12728 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
12729 Default
: Character;
12733 Check_Arg_Count
(1);
12735 -- Default_Scalar_Storage_Order can appear as a configuration
12736 -- pragma, or in a declarative part of a package spec.
12738 if not Is_Configuration_Pragma
then
12739 Check_Is_In_Decl_Part_Or_Package_Spec
;
12742 Check_No_Identifiers
;
12743 Check_Arg_Is_One_Of
12744 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
12745 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12746 Default
:= Fold_Upper
(Name_Buffer
(1));
12748 if not Support_Nondefault_SSO_On_Target
12749 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
12751 if Warn_On_Unrecognized_Pragma
then
12753 ("non-default Scalar_Storage_Order not supported "
12754 & "on target?g?", N
);
12756 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
12759 -- Here set the specified default
12762 Opt
.Default_SSO
:= Default
;
12766 --------------------------
12767 -- Default_Storage_Pool --
12768 --------------------------
12770 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
12772 when Pragma_Default_Storage_Pool
=>
12774 Check_Arg_Count
(1);
12776 -- Default_Storage_Pool can appear as a configuration pragma, or
12777 -- in a declarative part of a package spec.
12779 if not Is_Configuration_Pragma
then
12780 Check_Is_In_Decl_Part_Or_Package_Spec
;
12783 -- Case of Default_Storage_Pool (null);
12785 if Nkind
(Expression
(Arg1
)) = N_Null
then
12786 Analyze
(Expression
(Arg1
));
12788 -- This is an odd case, this is not really an expression, so
12789 -- we don't have a type for it. So just set the type to Empty.
12791 Set_Etype
(Expression
(Arg1
), Empty
);
12793 -- Case of Default_Storage_Pool (storage_pool_NAME);
12796 -- If it's a configuration pragma, then the only allowed
12797 -- argument is "null".
12799 if Is_Configuration_Pragma
then
12800 Error_Pragma_Arg
("NULL expected", Arg1
);
12803 -- The expected type for a non-"null" argument is
12804 -- Root_Storage_Pool'Class, and the pool must be a variable.
12806 Analyze_And_Resolve
12807 (Get_Pragma_Arg
(Arg1
),
12808 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
12810 if not Is_Variable
(Expression
(Arg1
)) then
12812 ("default storage pool must be a variable", Arg1
);
12816 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
12817 -- for an access type will use this information to set the
12818 -- appropriate attributes of the access type.
12820 Default_Pool
:= Expression
(Arg1
);
12826 -- pragma Depends (DEPENDENCY_RELATION);
12828 -- DEPENDENCY_RELATION ::=
12830 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
12832 -- DEPENDENCY_CLAUSE ::=
12833 -- OUTPUT_LIST =>[+] INPUT_LIST
12834 -- | NULL_DEPENDENCY_CLAUSE
12836 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
12838 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
12840 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
12842 -- OUTPUT ::= NAME | FUNCTION_RESULT
12845 -- where FUNCTION_RESULT is a function Result attribute_reference
12847 -- Characteristics:
12849 -- * Analysis - The annotation undergoes initial checks to verify
12850 -- the legal placement and context. Secondary checks fully analyze
12851 -- the dependency clauses in:
12853 -- Analyze_Depends_In_Decl_Part
12855 -- * Expansion - None.
12857 -- * Template - The annotation utilizes the generic template of the
12858 -- related subprogram [body] when it is:
12860 -- aspect on subprogram declaration
12861 -- aspect on stand alone subprogram body
12862 -- pragma on stand alone subprogram body
12864 -- The annotation must prepare its own template when it is:
12866 -- pragma on subprogram declaration
12868 -- * Globals - Capture of global references must occur after full
12871 -- * Instance - The annotation is instantiated automatically when
12872 -- the related generic subprogram [body] is instantiated except for
12873 -- the "pragma on subprogram declaration" case. In that scenario
12874 -- the annotation must instantiate itself.
12876 when Pragma_Depends
=>
12877 Analyze_Depends_Global
;
12879 ---------------------
12880 -- Detect_Blocking --
12881 ---------------------
12883 -- pragma Detect_Blocking;
12885 when Pragma_Detect_Blocking
=>
12887 Check_Arg_Count
(0);
12888 Check_Valid_Configuration_Pragma
;
12889 Detect_Blocking
:= True;
12891 ------------------------------------
12892 -- Disable_Atomic_Synchronization --
12893 ------------------------------------
12895 -- pragma Disable_Atomic_Synchronization [(Entity)];
12897 when Pragma_Disable_Atomic_Synchronization
=>
12899 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
12901 -------------------
12902 -- Discard_Names --
12903 -------------------
12905 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
12907 when Pragma_Discard_Names
=> Discard_Names
: declare
12912 Check_Ada_83_Warning
;
12914 -- Deal with configuration pragma case
12916 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
12917 Global_Discard_Names
:= True;
12920 -- Otherwise, check correct appropriate context
12923 Check_Is_In_Decl_Part_Or_Package_Spec
;
12925 if Arg_Count
= 0 then
12927 -- If there is no parameter, then from now on this pragma
12928 -- applies to any enumeration, exception or tagged type
12929 -- defined in the current declarative part, and recursively
12930 -- to any nested scope.
12932 Set_Discard_Names
(Current_Scope
);
12936 Check_Arg_Count
(1);
12937 Check_Optional_Identifier
(Arg1
, Name_On
);
12938 Check_Arg_Is_Local_Name
(Arg1
);
12940 E_Id
:= Get_Pragma_Arg
(Arg1
);
12942 if Etype
(E_Id
) = Any_Type
then
12945 E
:= Entity
(E_Id
);
12948 if (Is_First_Subtype
(E
)
12950 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
12951 or else Ekind
(E
) = E_Exception
12953 Set_Discard_Names
(E
);
12954 Record_Rep_Item
(E
, N
);
12958 ("inappropriate entity for pragma%", Arg1
);
12965 ------------------------
12966 -- Dispatching_Domain --
12967 ------------------------
12969 -- pragma Dispatching_Domain (EXPRESSION);
12971 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
12972 P
: constant Node_Id
:= Parent
(N
);
12978 Check_No_Identifiers
;
12979 Check_Arg_Count
(1);
12981 -- This pragma is born obsolete, but not the aspect
12983 if not From_Aspect_Specification
(N
) then
12985 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
12988 if Nkind
(P
) = N_Task_Definition
then
12989 Arg
:= Get_Pragma_Arg
(Arg1
);
12990 Ent
:= Defining_Identifier
(Parent
(P
));
12992 -- The expression must be analyzed in the special manner
12993 -- described in "Handling of Default and Per-Object
12994 -- Expressions" in sem.ads.
12996 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
12998 -- Check duplicate pragma before we chain the pragma in the Rep
12999 -- Item chain of Ent.
13001 Check_Duplicate_Pragma
(Ent
);
13002 Record_Rep_Item
(Ent
, N
);
13004 -- Anything else is incorrect
13009 end Dispatching_Domain
;
13015 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13017 when Pragma_Elaborate
=> Elaborate
: declare
13022 -- Pragma must be in context items list of a compilation unit
13024 if not Is_In_Context_Clause
then
13028 -- Must be at least one argument
13030 if Arg_Count
= 0 then
13031 Error_Pragma
("pragma% requires at least one argument");
13034 -- In Ada 83 mode, there can be no items following it in the
13035 -- context list except other pragmas and implicit with clauses
13036 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13037 -- placement rule does not apply.
13039 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13041 while Present
(Citem
) loop
13042 if Nkind
(Citem
) = N_Pragma
13043 or else (Nkind
(Citem
) = N_With_Clause
13044 and then Implicit_With
(Citem
))
13049 ("(Ada 83) pragma% must be at end of context clause");
13056 -- Finally, the arguments must all be units mentioned in a with
13057 -- clause in the same context clause. Note we already checked (in
13058 -- Par.Prag) that the arguments are all identifiers or selected
13062 Outer
: while Present
(Arg
) loop
13063 Citem
:= First
(List_Containing
(N
));
13064 Inner
: while Citem
/= N
loop
13065 if Nkind
(Citem
) = N_With_Clause
13066 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13068 Set_Elaborate_Present
(Citem
, True);
13069 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13071 -- With the pragma present, elaboration calls on
13072 -- subprograms from the named unit need no further
13073 -- checks, as long as the pragma appears in the current
13074 -- compilation unit. If the pragma appears in some unit
13075 -- in the context, there might still be a need for an
13076 -- Elaborate_All_Desirable from the current compilation
13077 -- to the named unit, so we keep the check enabled.
13079 if In_Extended_Main_Source_Unit
(N
) then
13081 -- This does not apply in SPARK mode, where we allow
13082 -- pragma Elaborate, but we don't trust it to be right
13083 -- so we will still insist on the Elaborate_All.
13085 if SPARK_Mode
/= On
then
13086 Set_Suppress_Elaboration_Warnings
13087 (Entity
(Name
(Citem
)));
13099 ("argument of pragma% is not withed unit", Arg
);
13105 -- Give a warning if operating in static mode with one of the
13106 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13109 and not Dynamic_Elaboration_Checks
13111 -- pragma Elaborate not allowed in SPARK mode anyway. We
13112 -- already complained about it, no point in generating any
13113 -- further complaint.
13115 and SPARK_Mode
/= On
13118 ("?l?use of pragma Elaborate may not be safe", N
);
13120 ("?l?use pragma Elaborate_All instead if possible", N
);
13124 -------------------
13125 -- Elaborate_All --
13126 -------------------
13128 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13130 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13135 Check_Ada_83_Warning
;
13137 -- Pragma must be in context items list of a compilation unit
13139 if not Is_In_Context_Clause
then
13143 -- Must be at least one argument
13145 if Arg_Count
= 0 then
13146 Error_Pragma
("pragma% requires at least one argument");
13149 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13150 -- have to appear at the end of the context clause, but may
13151 -- appear mixed in with other items, even in Ada 83 mode.
13153 -- Final check: the arguments must all be units mentioned in
13154 -- a with clause in the same context clause. Note that we
13155 -- already checked (in Par.Prag) that all the arguments are
13156 -- either identifiers or selected components.
13159 Outr
: while Present
(Arg
) loop
13160 Citem
:= First
(List_Containing
(N
));
13161 Innr
: while Citem
/= N
loop
13162 if Nkind
(Citem
) = N_With_Clause
13163 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13165 Set_Elaborate_All_Present
(Citem
, True);
13166 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13168 -- Suppress warnings and elaboration checks on the named
13169 -- unit if the pragma is in the current compilation, as
13170 -- for pragma Elaborate.
13172 if In_Extended_Main_Source_Unit
(N
) then
13173 Set_Suppress_Elaboration_Warnings
13174 (Entity
(Name
(Citem
)));
13183 Set_Error_Posted
(N
);
13185 ("argument of pragma% is not withed unit", Arg
);
13192 --------------------
13193 -- Elaborate_Body --
13194 --------------------
13196 -- pragma Elaborate_Body [( library_unit_NAME )];
13198 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13199 Cunit_Node
: Node_Id
;
13200 Cunit_Ent
: Entity_Id
;
13203 Check_Ada_83_Warning
;
13204 Check_Valid_Library_Unit_Pragma
;
13206 if Nkind
(N
) = N_Null_Statement
then
13210 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13211 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13213 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13216 Error_Pragma
("pragma% must refer to a spec, not a body");
13218 Set_Body_Required
(Cunit_Node
, True);
13219 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13221 -- If we are in dynamic elaboration mode, then we suppress
13222 -- elaboration warnings for the unit, since it is definitely
13223 -- fine NOT to do dynamic checks at the first level (and such
13224 -- checks will be suppressed because no elaboration boolean
13225 -- is created for Elaborate_Body packages).
13227 -- But in the static model of elaboration, Elaborate_Body is
13228 -- definitely NOT good enough to ensure elaboration safety on
13229 -- its own, since the body may WITH other units that are not
13230 -- safe from an elaboration point of view, so a client must
13231 -- still do an Elaborate_All on such units.
13233 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13234 -- Elaborate_Body always suppressed elab warnings.
13236 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13237 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13240 end Elaborate_Body
;
13242 ------------------------
13243 -- Elaboration_Checks --
13244 ------------------------
13246 -- pragma Elaboration_Checks (Static | Dynamic);
13248 when Pragma_Elaboration_Checks
=>
13250 Check_Arg_Count
(1);
13251 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13253 -- Set flag accordingly (ignore attempt at dynamic elaboration
13254 -- checks in SPARK mode).
13256 Dynamic_Elaboration_Checks
:=
13257 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
)
13258 and then SPARK_Mode
/= On
;
13264 -- pragma Eliminate (
13265 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13266 -- [,[Entity =>] IDENTIFIER |
13267 -- SELECTED_COMPONENT |
13269 -- [, OVERLOADING_RESOLUTION]);
13271 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13274 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13275 -- FUNCTION_PROFILE
13277 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13279 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13280 -- Result_Type => result_SUBTYPE_NAME]
13282 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13283 -- SUBTYPE_NAME ::= STRING_LITERAL
13285 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13286 -- SOURCE_TRACE ::= STRING_LITERAL
13288 when Pragma_Eliminate
=> Eliminate
: declare
13289 Args
: Args_List
(1 .. 5);
13290 Names
: constant Name_List
(1 .. 5) := (
13293 Name_Parameter_Types
,
13295 Name_Source_Location
);
13297 Unit_Name
: Node_Id
renames Args
(1);
13298 Entity
: Node_Id
renames Args
(2);
13299 Parameter_Types
: Node_Id
renames Args
(3);
13300 Result_Type
: Node_Id
renames Args
(4);
13301 Source_Location
: Node_Id
renames Args
(5);
13305 Check_Valid_Configuration_Pragma
;
13306 Gather_Associations
(Names
, Args
);
13308 if No
(Unit_Name
) then
13309 Error_Pragma
("missing Unit_Name argument for pragma%");
13313 and then (Present
(Parameter_Types
)
13315 Present
(Result_Type
)
13317 Present
(Source_Location
))
13319 Error_Pragma
("missing Entity argument for pragma%");
13322 if (Present
(Parameter_Types
)
13324 Present
(Result_Type
))
13326 Present
(Source_Location
)
13329 ("parameter profile and source location cannot be used "
13330 & "together in pragma%");
13333 Process_Eliminate_Pragma
13342 -----------------------------------
13343 -- Enable_Atomic_Synchronization --
13344 -----------------------------------
13346 -- pragma Enable_Atomic_Synchronization [(Entity)];
13348 when Pragma_Enable_Atomic_Synchronization
=>
13350 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13357 -- [ Convention =>] convention_IDENTIFIER,
13358 -- [ Entity =>] LOCAL_NAME
13359 -- [, [External_Name =>] static_string_EXPRESSION ]
13360 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13362 when Pragma_Export
=> Export
: declare
13364 Def_Id
: Entity_Id
;
13366 pragma Warnings
(Off
, C
);
13369 Check_Ada_83_Warning
;
13373 Name_External_Name
,
13376 Check_At_Least_N_Arguments
(2);
13377 Check_At_Most_N_Arguments
(4);
13379 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13380 -- pragma Export (Entity, "external name");
13382 if Relaxed_RM_Semantics
13383 and then Arg_Count
= 2
13384 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13387 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13390 if not Is_Entity_Name
(Def_Id
) then
13391 Error_Pragma_Arg
("entity name required", Arg1
);
13394 Def_Id
:= Entity
(Def_Id
);
13395 Set_Exported
(Def_Id
, Arg1
);
13398 Process_Convention
(C
, Def_Id
);
13400 if Ekind
(Def_Id
) /= E_Constant
then
13401 Note_Possible_Modification
13402 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13405 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13406 Set_Exported
(Def_Id
, Arg2
);
13409 -- If the entity is a deferred constant, propagate the information
13410 -- to the full view, because gigi elaborates the full view only.
13412 if Ekind
(Def_Id
) = E_Constant
13413 and then Present
(Full_View
(Def_Id
))
13416 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13418 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13419 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13420 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13425 ---------------------
13426 -- Export_Function --
13427 ---------------------
13429 -- pragma Export_Function (
13430 -- [Internal =>] LOCAL_NAME
13431 -- [, [External =>] EXTERNAL_SYMBOL]
13432 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13433 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13434 -- [, [Mechanism =>] MECHANISM]
13435 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13437 -- EXTERNAL_SYMBOL ::=
13439 -- | static_string_EXPRESSION
13441 -- PARAMETER_TYPES ::=
13443 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13445 -- TYPE_DESIGNATOR ::=
13447 -- | subtype_Name ' Access
13451 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13453 -- MECHANISM_ASSOCIATION ::=
13454 -- [formal_parameter_NAME =>] MECHANISM_NAME
13456 -- MECHANISM_NAME ::=
13460 when Pragma_Export_Function
=> Export_Function
: declare
13461 Args
: Args_List
(1 .. 6);
13462 Names
: constant Name_List
(1 .. 6) := (
13465 Name_Parameter_Types
,
13468 Name_Result_Mechanism
);
13470 Internal
: Node_Id
renames Args
(1);
13471 External
: Node_Id
renames Args
(2);
13472 Parameter_Types
: Node_Id
renames Args
(3);
13473 Result_Type
: Node_Id
renames Args
(4);
13474 Mechanism
: Node_Id
renames Args
(5);
13475 Result_Mechanism
: Node_Id
renames Args
(6);
13479 Gather_Associations
(Names
, Args
);
13480 Process_Extended_Import_Export_Subprogram_Pragma
(
13481 Arg_Internal
=> Internal
,
13482 Arg_External
=> External
,
13483 Arg_Parameter_Types
=> Parameter_Types
,
13484 Arg_Result_Type
=> Result_Type
,
13485 Arg_Mechanism
=> Mechanism
,
13486 Arg_Result_Mechanism
=> Result_Mechanism
);
13487 end Export_Function
;
13489 -------------------
13490 -- Export_Object --
13491 -------------------
13493 -- pragma Export_Object (
13494 -- [Internal =>] LOCAL_NAME
13495 -- [, [External =>] EXTERNAL_SYMBOL]
13496 -- [, [Size =>] EXTERNAL_SYMBOL]);
13498 -- EXTERNAL_SYMBOL ::=
13500 -- | static_string_EXPRESSION
13502 -- PARAMETER_TYPES ::=
13504 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13506 -- TYPE_DESIGNATOR ::=
13508 -- | subtype_Name ' Access
13512 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13514 -- MECHANISM_ASSOCIATION ::=
13515 -- [formal_parameter_NAME =>] MECHANISM_NAME
13517 -- MECHANISM_NAME ::=
13521 when Pragma_Export_Object
=> Export_Object
: declare
13522 Args
: Args_List
(1 .. 3);
13523 Names
: constant Name_List
(1 .. 3) := (
13528 Internal
: Node_Id
renames Args
(1);
13529 External
: Node_Id
renames Args
(2);
13530 Size
: Node_Id
renames Args
(3);
13534 Gather_Associations
(Names
, Args
);
13535 Process_Extended_Import_Export_Object_Pragma
(
13536 Arg_Internal
=> Internal
,
13537 Arg_External
=> External
,
13541 ----------------------
13542 -- Export_Procedure --
13543 ----------------------
13545 -- pragma Export_Procedure (
13546 -- [Internal =>] LOCAL_NAME
13547 -- [, [External =>] EXTERNAL_SYMBOL]
13548 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13549 -- [, [Mechanism =>] MECHANISM]);
13551 -- EXTERNAL_SYMBOL ::=
13553 -- | static_string_EXPRESSION
13555 -- PARAMETER_TYPES ::=
13557 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13559 -- TYPE_DESIGNATOR ::=
13561 -- | subtype_Name ' Access
13565 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13567 -- MECHANISM_ASSOCIATION ::=
13568 -- [formal_parameter_NAME =>] MECHANISM_NAME
13570 -- MECHANISM_NAME ::=
13574 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13575 Args
: Args_List
(1 .. 4);
13576 Names
: constant Name_List
(1 .. 4) := (
13579 Name_Parameter_Types
,
13582 Internal
: Node_Id
renames Args
(1);
13583 External
: Node_Id
renames Args
(2);
13584 Parameter_Types
: Node_Id
renames Args
(3);
13585 Mechanism
: Node_Id
renames Args
(4);
13589 Gather_Associations
(Names
, Args
);
13590 Process_Extended_Import_Export_Subprogram_Pragma
(
13591 Arg_Internal
=> Internal
,
13592 Arg_External
=> External
,
13593 Arg_Parameter_Types
=> Parameter_Types
,
13594 Arg_Mechanism
=> Mechanism
);
13595 end Export_Procedure
;
13601 -- pragma Export_Value (
13602 -- [Value =>] static_integer_EXPRESSION,
13603 -- [Link_Name =>] static_string_EXPRESSION);
13605 when Pragma_Export_Value
=>
13607 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13608 Check_Arg_Count
(2);
13610 Check_Optional_Identifier
(Arg1
, Name_Value
);
13611 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
13613 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13614 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
13616 -----------------------------
13617 -- Export_Valued_Procedure --
13618 -----------------------------
13620 -- pragma Export_Valued_Procedure (
13621 -- [Internal =>] LOCAL_NAME
13622 -- [, [External =>] EXTERNAL_SYMBOL,]
13623 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13624 -- [, [Mechanism =>] MECHANISM]);
13626 -- EXTERNAL_SYMBOL ::=
13628 -- | static_string_EXPRESSION
13630 -- PARAMETER_TYPES ::=
13632 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13634 -- TYPE_DESIGNATOR ::=
13636 -- | subtype_Name ' Access
13640 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13642 -- MECHANISM_ASSOCIATION ::=
13643 -- [formal_parameter_NAME =>] MECHANISM_NAME
13645 -- MECHANISM_NAME ::=
13649 when Pragma_Export_Valued_Procedure
=>
13650 Export_Valued_Procedure
: declare
13651 Args
: Args_List
(1 .. 4);
13652 Names
: constant Name_List
(1 .. 4) := (
13655 Name_Parameter_Types
,
13658 Internal
: Node_Id
renames Args
(1);
13659 External
: Node_Id
renames Args
(2);
13660 Parameter_Types
: Node_Id
renames Args
(3);
13661 Mechanism
: Node_Id
renames Args
(4);
13665 Gather_Associations
(Names
, Args
);
13666 Process_Extended_Import_Export_Subprogram_Pragma
(
13667 Arg_Internal
=> Internal
,
13668 Arg_External
=> External
,
13669 Arg_Parameter_Types
=> Parameter_Types
,
13670 Arg_Mechanism
=> Mechanism
);
13671 end Export_Valued_Procedure
;
13673 -------------------
13674 -- Extend_System --
13675 -------------------
13677 -- pragma Extend_System ([Name =>] Identifier);
13679 when Pragma_Extend_System
=> Extend_System
: declare
13682 Check_Valid_Configuration_Pragma
;
13683 Check_Arg_Count
(1);
13684 Check_Optional_Identifier
(Arg1
, Name_Name
);
13685 Check_Arg_Is_Identifier
(Arg1
);
13687 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13690 and then Name_Buffer
(1 .. 4) = "aux_"
13692 if Present
(System_Extend_Pragma_Arg
) then
13693 if Chars
(Get_Pragma_Arg
(Arg1
)) =
13694 Chars
(Expression
(System_Extend_Pragma_Arg
))
13698 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
13699 Error_Pragma
("pragma% conflicts with that #");
13703 System_Extend_Pragma_Arg
:= Arg1
;
13705 if not GNAT_Mode
then
13706 System_Extend_Unit
:= Arg1
;
13710 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
13714 ------------------------
13715 -- Extensions_Allowed --
13716 ------------------------
13718 -- pragma Extensions_Allowed (ON | OFF);
13720 when Pragma_Extensions_Allowed
=>
13722 Check_Arg_Count
(1);
13723 Check_No_Identifiers
;
13724 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13726 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13727 Extensions_Allowed
:= True;
13728 Ada_Version
:= Ada_Version_Type
'Last;
13731 Extensions_Allowed
:= False;
13732 Ada_Version
:= Ada_Version_Explicit
;
13733 Ada_Version_Pragma
:= Empty
;
13736 ------------------------
13737 -- Extensions_Visible --
13738 ------------------------
13740 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
13742 -- Characteristics:
13744 -- * Analysis - The annotation is fully analyzed immediately upon
13745 -- elaboration as its expression must be static.
13747 -- * Expansion - None.
13749 -- * Template - The annotation utilizes the generic template of the
13750 -- related subprogram [body] when it is:
13752 -- aspect on subprogram declaration
13753 -- aspect on stand alone subprogram body
13754 -- pragma on stand alone subprogram body
13756 -- The annotation must prepare its own template when it is:
13758 -- pragma on subprogram declaration
13760 -- * Globals - Capture of global references must occur after full
13763 -- * Instance - The annotation is instantiated automatically when
13764 -- the related generic subprogram [body] is instantiated except for
13765 -- the "pragma on subprogram declaration" case. In that scenario
13766 -- the annotation must instantiate itself.
13768 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
13770 Formal
: Entity_Id
;
13771 Has_OK_Formal
: Boolean := False;
13772 Spec_Id
: Entity_Id
;
13773 Subp_Decl
: Node_Id
;
13777 Check_No_Identifiers
;
13778 Check_At_Most_N_Arguments
(1);
13781 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
13783 -- Generic subprogram declaration
13785 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
13788 -- Body acts as spec
13790 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13791 and then No
(Corresponding_Spec
(Subp_Decl
))
13795 -- Body stub acts as spec
13797 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13798 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13802 -- Subprogram declaration
13804 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13807 -- Otherwise the pragma is associated with an illegal construct
13810 Error_Pragma
("pragma % must apply to a subprogram");
13814 Spec_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
13816 -- Examine the formals of the related subprogram
13818 Formal
:= First_Formal
(Spec_Id
);
13819 while Present
(Formal
) loop
13821 -- At least one of the formals is of a specific tagged type,
13822 -- the pragma is legal.
13824 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
13825 Has_OK_Formal
:= True;
13828 -- A generic subprogram with at least one formal of a private
13829 -- type ensures the legality of the pragma because the actual
13830 -- may be specifically tagged. Note that this is verified by
13831 -- the check above at instantiation time.
13833 elsif Is_Private_Type
(Etype
(Formal
))
13834 and then Is_Generic_Type
(Etype
(Formal
))
13836 Has_OK_Formal
:= True;
13840 Next_Formal
(Formal
);
13843 if not Has_OK_Formal
then
13844 Error_Msg_Name_1
:= Pname
;
13845 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
13847 ("\subprogram & lacks parameter of specific tagged or "
13848 & "generic private type", N
, Spec_Id
);
13852 -- Analyze the Boolean expression (if any)
13854 if Present
(Arg1
) then
13855 Expr
:= Expression
(Get_Argument
(N
, Spec_Id
));
13857 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
13859 if not Is_OK_Static_Expression
(Expr
) then
13861 ("expression of pragma % must be static", Expr
);
13866 -- Chain the pragma on the contract for completeness
13868 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13869 end Extensions_Visible
;
13875 -- pragma External (
13876 -- [ Convention =>] convention_IDENTIFIER,
13877 -- [ Entity =>] LOCAL_NAME
13878 -- [, [External_Name =>] static_string_EXPRESSION ]
13879 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13881 when Pragma_External
=> External
: declare
13882 Def_Id
: Entity_Id
;
13885 pragma Warnings
(Off
, C
);
13892 Name_External_Name
,
13894 Check_At_Least_N_Arguments
(2);
13895 Check_At_Most_N_Arguments
(4);
13896 Process_Convention
(C
, Def_Id
);
13897 Note_Possible_Modification
13898 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13899 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13900 Set_Exported
(Def_Id
, Arg2
);
13903 --------------------------
13904 -- External_Name_Casing --
13905 --------------------------
13907 -- pragma External_Name_Casing (
13908 -- UPPERCASE | LOWERCASE
13909 -- [, AS_IS | UPPERCASE | LOWERCASE]);
13911 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
13914 Check_No_Identifiers
;
13916 if Arg_Count
= 2 then
13917 Check_Arg_Is_One_Of
13918 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
13920 case Chars
(Get_Pragma_Arg
(Arg2
)) is
13922 Opt
.External_Name_Exp_Casing
:= As_Is
;
13924 when Name_Uppercase
=>
13925 Opt
.External_Name_Exp_Casing
:= Uppercase
;
13927 when Name_Lowercase
=>
13928 Opt
.External_Name_Exp_Casing
:= Lowercase
;
13935 Check_Arg_Count
(1);
13938 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
13940 case Chars
(Get_Pragma_Arg
(Arg1
)) is
13941 when Name_Uppercase
=>
13942 Opt
.External_Name_Imp_Casing
:= Uppercase
;
13944 when Name_Lowercase
=>
13945 Opt
.External_Name_Imp_Casing
:= Lowercase
;
13950 end External_Name_Casing
;
13956 -- pragma Fast_Math;
13958 when Pragma_Fast_Math
=>
13960 Check_No_Identifiers
;
13961 Check_Valid_Configuration_Pragma
;
13964 --------------------------
13965 -- Favor_Top_Level --
13966 --------------------------
13968 -- pragma Favor_Top_Level (type_NAME);
13970 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
13971 Named_Entity
: Entity_Id
;
13975 Check_No_Identifiers
;
13976 Check_Arg_Count
(1);
13977 Check_Arg_Is_Local_Name
(Arg1
);
13978 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
13980 -- If it's an access-to-subprogram type (in particular, not a
13981 -- subtype), set the flag on that type.
13983 if Is_Access_Subprogram_Type
(Named_Entity
) then
13984 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
13986 -- Otherwise it's an error (name denotes the wrong sort of entity)
13990 ("access-to-subprogram type expected",
13991 Get_Pragma_Arg
(Arg1
));
13993 end Favor_Top_Level
;
13995 ---------------------------
13996 -- Finalize_Storage_Only --
13997 ---------------------------
13999 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14001 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14002 Assoc
: constant Node_Id
:= Arg1
;
14003 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14008 Check_No_Identifiers
;
14009 Check_Arg_Count
(1);
14010 Check_Arg_Is_Local_Name
(Arg1
);
14012 Find_Type
(Type_Id
);
14013 Typ
:= Entity
(Type_Id
);
14016 or else Rep_Item_Too_Early
(Typ
, N
)
14020 Typ
:= Underlying_Type
(Typ
);
14023 if not Is_Controlled
(Typ
) then
14024 Error_Pragma
("pragma% must specify controlled type");
14027 Check_First_Subtype
(Arg1
);
14029 if Finalize_Storage_Only
(Typ
) then
14030 Error_Pragma
("duplicate pragma%, only one allowed");
14032 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14033 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14035 end Finalize_Storage
;
14041 -- pragma Ghost [ (boolean_EXPRESSION) ];
14043 when Pragma_Ghost
=> Ghost
: declare
14047 Orig_Stmt
: Node_Id
;
14048 Prev_Id
: Entity_Id
;
14053 Check_No_Identifiers
;
14054 Check_At_Most_N_Arguments
(1);
14056 Context
:= Parent
(N
);
14058 -- Handle compilation units
14060 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
14061 Context
:= Unit
(Parent
(Context
));
14066 while Present
(Stmt
) loop
14068 -- Skip prior pragmas, but check for duplicates
14070 if Nkind
(Stmt
) = N_Pragma
then
14071 if Pragma_Name
(Stmt
) = Pname
then
14072 Error_Msg_Name_1
:= Pname
;
14073 Error_Msg_Sloc
:= Sloc
(Stmt
);
14074 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
14077 -- Protected and task types cannot be subject to pragma Ghost
14079 elsif Nkind
(Stmt
) = N_Protected_Type_Declaration
then
14080 Error_Pragma
("pragma % cannot apply to a protected type");
14083 elsif Nkind
(Stmt
) = N_Task_Type_Declaration
then
14084 Error_Pragma
("pragma % cannot apply to a task type");
14087 -- Skip internally generated code
14089 elsif not Comes_From_Source
(Stmt
) then
14090 Orig_Stmt
:= Original_Node
(Stmt
);
14092 -- When pragma Ghost applies to an untagged derivation, the
14093 -- derivation is transformed into a [sub]type declaration.
14095 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
14096 N_Subtype_Declaration
)
14097 and then Comes_From_Source
(Orig_Stmt
)
14098 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
14099 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
14100 N_Derived_Type_Definition
14102 Id
:= Defining_Entity
(Stmt
);
14105 -- When pragma Ghost applies to an expression function, the
14106 -- expression function is transformed into a subprogram.
14108 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
14109 and then Comes_From_Source
(Orig_Stmt
)
14110 and then Nkind
(Orig_Stmt
) = N_Expression_Function
14112 Id
:= Defining_Entity
(Stmt
);
14116 -- The pragma applies to a legal construct, stop the traversal
14118 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
14119 N_Full_Type_Declaration
,
14120 N_Generic_Subprogram_Declaration
,
14121 N_Object_Declaration
,
14122 N_Private_Extension_Declaration
,
14123 N_Private_Type_Declaration
,
14124 N_Subprogram_Declaration
,
14125 N_Subtype_Declaration
)
14127 Id
:= Defining_Entity
(Stmt
);
14130 -- The pragma does not apply to a legal construct, issue an
14131 -- error and stop the analysis.
14135 ("pragma % must apply to an object, package, subprogram "
14140 Stmt
:= Prev
(Stmt
);
14145 -- When pragma Ghost is associated with a [generic] package, it
14146 -- appears in the visible declarations.
14148 if Nkind
(Context
) = N_Package_Specification
14149 and then Present
(Visible_Declarations
(Context
))
14150 and then List_Containing
(N
) = Visible_Declarations
(Context
)
14152 Id
:= Defining_Entity
(Context
);
14154 -- Pragma Ghost applies to a stand alone subprogram body
14156 elsif Nkind
(Context
) = N_Subprogram_Body
14157 and then No
(Corresponding_Spec
(Context
))
14159 Id
:= Defining_Entity
(Context
);
14165 ("pragma % must apply to an object, package, subprogram or "
14170 -- A derived type or type extension cannot be subject to pragma
14171 -- Ghost if either the parent type or one of the progenitor types
14172 -- is not Ghost (SPARK RM 6.9(9)).
14174 if Is_Derived_Type
(Id
) then
14175 Check_Ghost_Derivation
(Id
);
14178 -- Handle completions of types and constants that are subject to
14181 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
14182 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
14184 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
14185 Error_Msg_Name_1
:= Pname
;
14187 -- The full declaration of a deferred constant cannot be
14188 -- subject to pragma Ghost unless the deferred declaration
14189 -- is also Ghost (SPARK RM 6.9(10)).
14191 if Ekind
(Prev_Id
) = E_Constant
then
14192 Error_Msg_Name_1
:= Pname
;
14193 Error_Msg_NE
(Fix_Error
14194 ("pragma % must apply to declaration of deferred "
14195 & "constant &"), N
, Id
);
14198 -- Pragma Ghost may appear on the full view of an incomplete
14199 -- type because the incomplete declaration lacks aspects and
14200 -- cannot be subject to pragma Ghost.
14202 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
14205 -- The full declaration of a type cannot be subject to
14206 -- pragma Ghost unless the partial view is also Ghost
14207 -- (SPARK RM 6.9(10)).
14210 Error_Msg_NE
(Fix_Error
14211 ("pragma % must apply to partial view of type &"),
14218 -- Analyze the Boolean expression (if any)
14220 if Present
(Arg1
) then
14221 Expr
:= Get_Pragma_Arg
(Arg1
);
14223 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14225 if Is_OK_Static_Expression
(Expr
) then
14227 -- "Ghostness" cannot be turned off once enabled within a
14228 -- region (SPARK RM 6.9(7)).
14230 if Is_False
(Expr_Value
(Expr
))
14231 and then Ghost_Mode
> None
14234 ("pragma % with value False cannot appear in enabled "
14239 -- Otherwie the expression is not static
14243 ("expression of pragma % must be static", Expr
);
14248 Set_Is_Ghost_Entity
(Id
);
14255 -- pragma Global (GLOBAL_SPECIFICATION);
14257 -- GLOBAL_SPECIFICATION ::=
14260 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14262 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14264 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14265 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14266 -- GLOBAL_ITEM ::= NAME
14268 -- Characteristics:
14270 -- * Analysis - The annotation undergoes initial checks to verify
14271 -- the legal placement and context. Secondary checks fully analyze
14272 -- the dependency clauses in:
14274 -- Analyze_Global_In_Decl_Part
14276 -- * Expansion - None.
14278 -- * Template - The annotation utilizes the generic template of the
14279 -- related subprogram [body] when it is:
14281 -- aspect on subprogram declaration
14282 -- aspect on stand alone subprogram body
14283 -- pragma on stand alone subprogram body
14285 -- The annotation must prepare its own template when it is:
14287 -- pragma on subprogram declaration
14289 -- * Globals - Capture of global references must occur after full
14292 -- * Instance - The annotation is instantiated automatically when
14293 -- the related generic subprogram [body] is instantiated except for
14294 -- the "pragma on subprogram declaration" case. In that scenario
14295 -- the annotation must instantiate itself.
14297 when Pragma_Global
=>
14298 Analyze_Depends_Global
;
14304 -- pragma Ident (static_string_EXPRESSION)
14306 -- Note: pragma Comment shares this processing. Pragma Ident is
14307 -- identical in effect to pragma Commment.
14309 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14314 Check_Arg_Count
(1);
14315 Check_No_Identifiers
;
14316 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
14319 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14326 GP
:= Parent
(Parent
(N
));
14328 if Nkind_In
(GP
, N_Package_Declaration
,
14329 N_Generic_Package_Declaration
)
14334 -- If we have a compilation unit, then record the ident value,
14335 -- checking for improper duplication.
14337 if Nkind
(GP
) = N_Compilation_Unit
then
14338 CS
:= Ident_String
(Current_Sem_Unit
);
14340 if Present
(CS
) then
14342 -- If we have multiple instances, concatenate them, but
14343 -- not in ASIS, where we want the original tree.
14345 if not ASIS_Mode
then
14346 Start_String
(Strval
(CS
));
14347 Store_String_Char
(' ');
14348 Store_String_Chars
(Strval
(Str
));
14349 Set_Strval
(CS
, End_String
);
14353 Set_Ident_String
(Current_Sem_Unit
, Str
);
14356 -- For subunits, we just ignore the Ident, since in GNAT these
14357 -- are not separate object files, and hence not separate units
14358 -- in the unit table.
14360 elsif Nkind
(GP
) = N_Subunit
then
14366 -------------------
14367 -- Ignore_Pragma --
14368 -------------------
14370 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
14372 -- Entirely handled in the parser, nothing to do here
14374 when Pragma_Ignore_Pragma
=>
14377 ----------------------------
14378 -- Implementation_Defined --
14379 ----------------------------
14381 -- pragma Implementation_Defined (LOCAL_NAME);
14383 -- Marks previously declared entity as implementation defined. For
14384 -- an overloaded entity, applies to the most recent homonym.
14386 -- pragma Implementation_Defined;
14388 -- The form with no arguments appears anywhere within a scope, most
14389 -- typically a package spec, and indicates that all entities that are
14390 -- defined within the package spec are Implementation_Defined.
14392 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14397 Check_No_Identifiers
;
14399 -- Form with no arguments
14401 if Arg_Count
= 0 then
14402 Set_Is_Implementation_Defined
(Current_Scope
);
14404 -- Form with one argument
14407 Check_Arg_Count
(1);
14408 Check_Arg_Is_Local_Name
(Arg1
);
14409 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14410 Set_Is_Implementation_Defined
(Ent
);
14412 end Implementation_Defined
;
14418 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14420 -- IMPLEMENTATION_KIND ::=
14421 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14423 -- "By_Any" and "Optional" are treated as synonyms in order to
14424 -- support Ada 2012 aspect Synchronization.
14426 when Pragma_Implemented
=> Implemented
: declare
14427 Proc_Id
: Entity_Id
;
14432 Check_Arg_Count
(2);
14433 Check_No_Identifiers
;
14434 Check_Arg_Is_Identifier
(Arg1
);
14435 Check_Arg_Is_Local_Name
(Arg1
);
14436 Check_Arg_Is_One_Of
(Arg2
,
14439 Name_By_Protected_Procedure
,
14442 -- Extract the name of the local procedure
14444 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14446 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14447 -- primitive procedure of a synchronized tagged type.
14449 if Ekind
(Proc_Id
) = E_Procedure
14450 and then Is_Primitive
(Proc_Id
)
14451 and then Present
(First_Formal
(Proc_Id
))
14453 Typ
:= Etype
(First_Formal
(Proc_Id
));
14455 if Is_Tagged_Type
(Typ
)
14458 -- Check for a protected, a synchronized or a task interface
14460 ((Is_Interface
(Typ
)
14461 and then Is_Synchronized_Interface
(Typ
))
14463 -- Check for a protected type or a task type that implements
14467 (Is_Concurrent_Record_Type
(Typ
)
14468 and then Present
(Interfaces
(Typ
)))
14470 -- In analysis-only mode, examine original protected type
14473 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
14474 and then Present
(Interface_List
(Parent
(Typ
))))
14476 -- Check for a private record extension with keyword
14480 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14481 E_Record_Subtype_With_Private
)
14482 and then Synchronized_Present
(Parent
(Typ
))))
14487 ("controlling formal must be of synchronized tagged type",
14492 -- Procedures declared inside a protected type must be accepted
14494 elsif Ekind
(Proc_Id
) = E_Procedure
14495 and then Is_Protected_Type
(Scope
(Proc_Id
))
14499 -- The first argument is not a primitive procedure
14503 ("pragma % must be applied to a primitive procedure", Arg1
);
14507 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14508 -- By_Protected_Procedure to the primitive procedure of a task
14511 if Chars
(Arg2
) = Name_By_Protected_Procedure
14512 and then Is_Interface
(Typ
)
14513 and then Is_Task_Interface
(Typ
)
14516 ("implementation kind By_Protected_Procedure cannot be "
14517 & "applied to a task interface primitive", Arg2
);
14521 Record_Rep_Item
(Proc_Id
, N
);
14524 ----------------------
14525 -- Implicit_Packing --
14526 ----------------------
14528 -- pragma Implicit_Packing;
14530 when Pragma_Implicit_Packing
=>
14532 Check_Arg_Count
(0);
14533 Implicit_Packing
:= True;
14540 -- [Convention =>] convention_IDENTIFIER,
14541 -- [Entity =>] LOCAL_NAME
14542 -- [, [External_Name =>] static_string_EXPRESSION ]
14543 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14545 when Pragma_Import
=>
14546 Check_Ada_83_Warning
;
14550 Name_External_Name
,
14553 Check_At_Least_N_Arguments
(2);
14554 Check_At_Most_N_Arguments
(4);
14555 Process_Import_Or_Interface
;
14557 ---------------------
14558 -- Import_Function --
14559 ---------------------
14561 -- pragma Import_Function (
14562 -- [Internal =>] LOCAL_NAME,
14563 -- [, [External =>] EXTERNAL_SYMBOL]
14564 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14565 -- [, [Result_Type =>] SUBTYPE_MARK]
14566 -- [, [Mechanism =>] MECHANISM]
14567 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14569 -- EXTERNAL_SYMBOL ::=
14571 -- | static_string_EXPRESSION
14573 -- PARAMETER_TYPES ::=
14575 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14577 -- TYPE_DESIGNATOR ::=
14579 -- | subtype_Name ' Access
14583 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14585 -- MECHANISM_ASSOCIATION ::=
14586 -- [formal_parameter_NAME =>] MECHANISM_NAME
14588 -- MECHANISM_NAME ::=
14592 when Pragma_Import_Function
=> Import_Function
: declare
14593 Args
: Args_List
(1 .. 6);
14594 Names
: constant Name_List
(1 .. 6) := (
14597 Name_Parameter_Types
,
14600 Name_Result_Mechanism
);
14602 Internal
: Node_Id
renames Args
(1);
14603 External
: Node_Id
renames Args
(2);
14604 Parameter_Types
: Node_Id
renames Args
(3);
14605 Result_Type
: Node_Id
renames Args
(4);
14606 Mechanism
: Node_Id
renames Args
(5);
14607 Result_Mechanism
: Node_Id
renames Args
(6);
14611 Gather_Associations
(Names
, Args
);
14612 Process_Extended_Import_Export_Subprogram_Pragma
(
14613 Arg_Internal
=> Internal
,
14614 Arg_External
=> External
,
14615 Arg_Parameter_Types
=> Parameter_Types
,
14616 Arg_Result_Type
=> Result_Type
,
14617 Arg_Mechanism
=> Mechanism
,
14618 Arg_Result_Mechanism
=> Result_Mechanism
);
14619 end Import_Function
;
14621 -------------------
14622 -- Import_Object --
14623 -------------------
14625 -- pragma Import_Object (
14626 -- [Internal =>] LOCAL_NAME
14627 -- [, [External =>] EXTERNAL_SYMBOL]
14628 -- [, [Size =>] EXTERNAL_SYMBOL]);
14630 -- EXTERNAL_SYMBOL ::=
14632 -- | static_string_EXPRESSION
14634 when Pragma_Import_Object
=> Import_Object
: declare
14635 Args
: Args_List
(1 .. 3);
14636 Names
: constant Name_List
(1 .. 3) := (
14641 Internal
: Node_Id
renames Args
(1);
14642 External
: Node_Id
renames Args
(2);
14643 Size
: Node_Id
renames Args
(3);
14647 Gather_Associations
(Names
, Args
);
14648 Process_Extended_Import_Export_Object_Pragma
(
14649 Arg_Internal
=> Internal
,
14650 Arg_External
=> External
,
14654 ----------------------
14655 -- Import_Procedure --
14656 ----------------------
14658 -- pragma Import_Procedure (
14659 -- [Internal =>] LOCAL_NAME
14660 -- [, [External =>] EXTERNAL_SYMBOL]
14661 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14662 -- [, [Mechanism =>] MECHANISM]);
14664 -- EXTERNAL_SYMBOL ::=
14666 -- | static_string_EXPRESSION
14668 -- PARAMETER_TYPES ::=
14670 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14672 -- TYPE_DESIGNATOR ::=
14674 -- | subtype_Name ' Access
14678 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14680 -- MECHANISM_ASSOCIATION ::=
14681 -- [formal_parameter_NAME =>] MECHANISM_NAME
14683 -- MECHANISM_NAME ::=
14687 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14688 Args
: Args_List
(1 .. 4);
14689 Names
: constant Name_List
(1 .. 4) := (
14692 Name_Parameter_Types
,
14695 Internal
: Node_Id
renames Args
(1);
14696 External
: Node_Id
renames Args
(2);
14697 Parameter_Types
: Node_Id
renames Args
(3);
14698 Mechanism
: Node_Id
renames Args
(4);
14702 Gather_Associations
(Names
, Args
);
14703 Process_Extended_Import_Export_Subprogram_Pragma
(
14704 Arg_Internal
=> Internal
,
14705 Arg_External
=> External
,
14706 Arg_Parameter_Types
=> Parameter_Types
,
14707 Arg_Mechanism
=> Mechanism
);
14708 end Import_Procedure
;
14710 -----------------------------
14711 -- Import_Valued_Procedure --
14712 -----------------------------
14714 -- pragma Import_Valued_Procedure (
14715 -- [Internal =>] LOCAL_NAME
14716 -- [, [External =>] EXTERNAL_SYMBOL]
14717 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14718 -- [, [Mechanism =>] MECHANISM]);
14720 -- EXTERNAL_SYMBOL ::=
14722 -- | static_string_EXPRESSION
14724 -- PARAMETER_TYPES ::=
14726 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14728 -- TYPE_DESIGNATOR ::=
14730 -- | subtype_Name ' Access
14734 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14736 -- MECHANISM_ASSOCIATION ::=
14737 -- [formal_parameter_NAME =>] MECHANISM_NAME
14739 -- MECHANISM_NAME ::=
14743 when Pragma_Import_Valued_Procedure
=>
14744 Import_Valued_Procedure
: declare
14745 Args
: Args_List
(1 .. 4);
14746 Names
: constant Name_List
(1 .. 4) := (
14749 Name_Parameter_Types
,
14752 Internal
: Node_Id
renames Args
(1);
14753 External
: Node_Id
renames Args
(2);
14754 Parameter_Types
: Node_Id
renames Args
(3);
14755 Mechanism
: Node_Id
renames Args
(4);
14759 Gather_Associations
(Names
, Args
);
14760 Process_Extended_Import_Export_Subprogram_Pragma
(
14761 Arg_Internal
=> Internal
,
14762 Arg_External
=> External
,
14763 Arg_Parameter_Types
=> Parameter_Types
,
14764 Arg_Mechanism
=> Mechanism
);
14765 end Import_Valued_Procedure
;
14771 -- pragma Independent (LOCAL_NAME);
14773 when Pragma_Independent
=>
14774 Process_Atomic_Independent_Shared_Volatile
;
14776 ----------------------------
14777 -- Independent_Components --
14778 ----------------------------
14780 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
14782 when Pragma_Independent_Components
=> Independent_Components
: declare
14790 Check_Ada_83_Warning
;
14792 Check_No_Identifiers
;
14793 Check_Arg_Count
(1);
14794 Check_Arg_Is_Local_Name
(Arg1
);
14795 E_Id
:= Get_Pragma_Arg
(Arg1
);
14797 if Etype
(E_Id
) = Any_Type
then
14801 E
:= Entity
(E_Id
);
14803 -- Check duplicate before we chain ourselves
14805 Check_Duplicate_Pragma
(E
);
14807 -- Check appropriate entity
14809 if Rep_Item_Too_Early
(E
, N
)
14811 Rep_Item_Too_Late
(E
, N
)
14816 D
:= Declaration_Node
(E
);
14819 -- The flag is set on the base type, or on the object
14821 if K
= N_Full_Type_Declaration
14822 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
14824 Set_Has_Independent_Components
(Base_Type
(E
));
14825 Record_Independence_Check
(N
, Base_Type
(E
));
14827 -- For record type, set all components independent
14829 if Is_Record_Type
(E
) then
14830 C
:= First_Component
(E
);
14831 while Present
(C
) loop
14832 Set_Is_Independent
(C
);
14833 Next_Component
(C
);
14837 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
14838 and then Nkind
(D
) = N_Object_Declaration
14839 and then Nkind
(Object_Definition
(D
)) =
14840 N_Constrained_Array_Definition
14842 Set_Has_Independent_Components
(E
);
14843 Record_Independence_Check
(N
, E
);
14846 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
14848 end Independent_Components
;
14850 -----------------------
14851 -- Initial_Condition --
14852 -----------------------
14854 -- pragma Initial_Condition (boolean_EXPRESSION);
14856 -- Characteristics:
14858 -- * Analysis - The annotation undergoes initial checks to verify
14859 -- the legal placement and context. Secondary checks preanalyze the
14862 -- Analyze_Initial_Condition_In_Decl_Part
14864 -- * Expansion - The annotation is expanded during the expansion of
14865 -- the package body whose declaration is subject to the annotation
14868 -- Expand_Pragma_Initial_Condition
14870 -- * Template - The annotation utilizes the generic template of the
14871 -- related package declaration.
14873 -- * Globals - Capture of global references must occur after full
14876 -- * Instance - The annotation is instantiated automatically when
14877 -- the related generic package is instantiated.
14879 when Pragma_Initial_Condition
=> Initial_Condition
: declare
14880 Pack_Decl
: Node_Id
;
14881 Pack_Id
: Entity_Id
;
14885 Check_No_Identifiers
;
14886 Check_Arg_Count
(1);
14888 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
14890 -- Ensure the proper placement of the pragma. Initial_Condition
14891 -- must be associated with a package declaration.
14893 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
14894 N_Package_Declaration
)
14898 -- Otherwise the pragma is associated with an illegal context
14905 -- The pragma must be analyzed at the end of the visible
14906 -- declarations of the related package. Save the pragma for later
14907 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
14908 -- the contract of the package.
14910 Pack_Id
:= Defining_Entity
(Pack_Decl
);
14912 -- Verify the declaration order of pragma Initial_Condition with
14913 -- respect to pragmas Abstract_State and Initializes when SPARK
14914 -- checks are enabled.
14916 if SPARK_Mode
/= Off
then
14917 Check_Declaration_Order
14918 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
14921 Check_Declaration_Order
14922 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
14926 -- Chain the pragma on the contract for further processing by
14927 -- Analyze_Initial_Condition_In_Decl_Part.
14929 Add_Contract_Item
(N
, Pack_Id
);
14930 end Initial_Condition
;
14932 ------------------------
14933 -- Initialize_Scalars --
14934 ------------------------
14936 -- pragma Initialize_Scalars;
14938 when Pragma_Initialize_Scalars
=>
14940 Check_Arg_Count
(0);
14941 Check_Valid_Configuration_Pragma
;
14942 Check_Restriction
(No_Initialize_Scalars
, N
);
14944 -- Initialize_Scalars creates false positives in CodePeer, and
14945 -- incorrect negative results in GNATprove mode, so ignore this
14946 -- pragma in these modes.
14948 if not Restriction_Active
(No_Initialize_Scalars
)
14949 and then not (CodePeer_Mode
or GNATprove_Mode
)
14951 Init_Or_Norm_Scalars
:= True;
14952 Initialize_Scalars
:= True;
14959 -- pragma Initializes (INITIALIZATION_SPEC);
14961 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
14963 -- INITIALIZATION_LIST ::=
14964 -- INITIALIZATION_ITEM
14965 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
14967 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
14972 -- | (INPUT {, INPUT})
14976 -- Characteristics:
14978 -- * Analysis - The annotation undergoes initial checks to verify
14979 -- the legal placement and context. Secondary checks preanalyze the
14982 -- Analyze_Initializes_In_Decl_Part
14984 -- * Expansion - None.
14986 -- * Template - The annotation utilizes the generic template of the
14987 -- related package declaration.
14989 -- * Globals - Capture of global references must occur after full
14992 -- * Instance - The annotation is instantiated automatically when
14993 -- the related generic package is instantiated.
14995 when Pragma_Initializes
=> Initializes
: declare
14996 Pack_Decl
: Node_Id
;
14997 Pack_Id
: Entity_Id
;
15001 Check_No_Identifiers
;
15002 Check_Arg_Count
(1);
15004 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
15006 -- Ensure the proper placement of the pragma. Initializes must be
15007 -- associated with a package declaration.
15009 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
15010 N_Package_Declaration
)
15014 -- Otherwise the pragma is associated with an illegal construc
15021 Pack_Id
:= Defining_Entity
(Pack_Decl
);
15023 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
15025 -- Verify the declaration order of pragmas Abstract_State and
15026 -- Initializes when SPARK checks are enabled.
15028 if SPARK_Mode
/= Off
then
15029 Check_Declaration_Order
15030 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15034 -- Chain the pragma on the contract for further processing by
15035 -- Analyze_Initializes_In_Decl_Part.
15037 Add_Contract_Item
(N
, Pack_Id
);
15044 -- pragma Inline ( NAME {, NAME} );
15046 when Pragma_Inline
=>
15048 -- Pragma always active unless in GNATprove mode. It is disabled
15049 -- in GNATprove mode because frontend inlining is applied
15050 -- independently of pragmas Inline and Inline_Always for
15051 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15054 if not GNATprove_Mode
then
15056 -- Inline status is Enabled if inlining option is active
15058 if Inline_Active
then
15059 Process_Inline
(Enabled
);
15061 Process_Inline
(Disabled
);
15065 -------------------
15066 -- Inline_Always --
15067 -------------------
15069 -- pragma Inline_Always ( NAME {, NAME} );
15071 when Pragma_Inline_Always
=>
15074 -- Pragma always active unless in CodePeer mode or GNATprove
15075 -- mode. It is disabled in CodePeer mode because inlining is
15076 -- not helpful, and enabling it caused walk order issues. It
15077 -- is disabled in GNATprove mode because frontend inlining is
15078 -- applied independently of pragmas Inline and Inline_Always for
15079 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15082 if not CodePeer_Mode
and not GNATprove_Mode
then
15083 Process_Inline
(Enabled
);
15086 --------------------
15087 -- Inline_Generic --
15088 --------------------
15090 -- pragma Inline_Generic (NAME {, NAME});
15092 when Pragma_Inline_Generic
=>
15094 Process_Generic_List
;
15096 ----------------------
15097 -- Inspection_Point --
15098 ----------------------
15100 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15102 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15109 if Arg_Count
> 0 then
15112 Exp
:= Get_Pragma_Arg
(Arg
);
15115 if not Is_Entity_Name
(Exp
)
15116 or else not Is_Object
(Entity
(Exp
))
15118 Error_Pragma_Arg
("object name required", Arg
);
15122 exit when No
(Arg
);
15125 end Inspection_Point
;
15131 -- pragma Interface (
15132 -- [ Convention =>] convention_IDENTIFIER,
15133 -- [ Entity =>] LOCAL_NAME
15134 -- [, [External_Name =>] static_string_EXPRESSION ]
15135 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15137 when Pragma_Interface
=>
15142 Name_External_Name
,
15144 Check_At_Least_N_Arguments
(2);
15145 Check_At_Most_N_Arguments
(4);
15146 Process_Import_Or_Interface
;
15148 -- In Ada 2005, the permission to use Interface (a reserved word)
15149 -- as a pragma name is considered an obsolescent feature, and this
15150 -- pragma was already obsolescent in Ada 95.
15152 if Ada_Version
>= Ada_95
then
15154 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15156 if Warn_On_Obsolescent_Feature
then
15158 ("pragma Interface is an obsolescent feature?j?", N
);
15160 ("|use pragma Import instead?j?", N
);
15164 --------------------
15165 -- Interface_Name --
15166 --------------------
15168 -- pragma Interface_Name (
15169 -- [ Entity =>] LOCAL_NAME
15170 -- [,[External_Name =>] static_string_EXPRESSION ]
15171 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15173 when Pragma_Interface_Name
=> Interface_Name
: declare
15175 Def_Id
: Entity_Id
;
15176 Hom_Id
: Entity_Id
;
15182 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15183 Check_At_Least_N_Arguments
(2);
15184 Check_At_Most_N_Arguments
(3);
15185 Id
:= Get_Pragma_Arg
(Arg1
);
15188 -- This is obsolete from Ada 95 on, but it is an implementation
15189 -- defined pragma, so we do not consider that it violates the
15190 -- restriction (No_Obsolescent_Features).
15192 if Ada_Version
>= Ada_95
then
15193 if Warn_On_Obsolescent_Feature
then
15195 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15197 ("|use pragma Import instead?j?", N
);
15201 if not Is_Entity_Name
(Id
) then
15203 ("first argument for pragma% must be entity name", Arg1
);
15204 elsif Etype
(Id
) = Any_Type
then
15207 Def_Id
:= Entity
(Id
);
15210 -- Special DEC-compatible processing for the object case, forces
15211 -- object to be imported.
15213 if Ekind
(Def_Id
) = E_Variable
then
15214 Kill_Size_Check_Code
(Def_Id
);
15215 Note_Possible_Modification
(Id
, Sure
=> False);
15217 -- Initialization is not allowed for imported variable
15219 if Present
(Expression
(Parent
(Def_Id
)))
15220 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15222 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15224 ("no initialization allowed for declaration of& #",
15228 -- For compatibility, support VADS usage of providing both
15229 -- pragmas Interface and Interface_Name to obtain the effect
15230 -- of a single Import pragma.
15232 if Is_Imported
(Def_Id
)
15233 and then Present
(First_Rep_Item
(Def_Id
))
15234 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15236 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15240 Set_Imported
(Def_Id
);
15243 Set_Is_Public
(Def_Id
);
15244 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15247 -- Otherwise must be subprogram
15249 elsif not Is_Subprogram
(Def_Id
) then
15251 ("argument of pragma% is not subprogram", Arg1
);
15254 Check_At_Most_N_Arguments
(3);
15258 -- Loop through homonyms
15261 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15263 if Is_Imported
(Def_Id
) then
15264 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15268 exit when From_Aspect_Specification
(N
);
15269 Hom_Id
:= Homonym
(Hom_Id
);
15271 exit when No
(Hom_Id
)
15272 or else Scope
(Hom_Id
) /= Current_Scope
;
15277 ("argument of pragma% is not imported subprogram",
15281 end Interface_Name
;
15283 -----------------------
15284 -- Interrupt_Handler --
15285 -----------------------
15287 -- pragma Interrupt_Handler (handler_NAME);
15289 when Pragma_Interrupt_Handler
=>
15290 Check_Ada_83_Warning
;
15291 Check_Arg_Count
(1);
15292 Check_No_Identifiers
;
15294 if No_Run_Time_Mode
then
15295 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15297 Check_Interrupt_Or_Attach_Handler
;
15298 Process_Interrupt_Or_Attach_Handler
;
15301 ------------------------
15302 -- Interrupt_Priority --
15303 ------------------------
15305 -- pragma Interrupt_Priority [(EXPRESSION)];
15307 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15308 P
: constant Node_Id
:= Parent
(N
);
15313 Check_Ada_83_Warning
;
15315 if Arg_Count
/= 0 then
15316 Arg
:= Get_Pragma_Arg
(Arg1
);
15317 Check_Arg_Count
(1);
15318 Check_No_Identifiers
;
15320 -- The expression must be analyzed in the special manner
15321 -- described in "Handling of Default and Per-Object
15322 -- Expressions" in sem.ads.
15324 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15327 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15332 Ent
:= Defining_Identifier
(Parent
(P
));
15334 -- Check duplicate pragma before we chain the pragma in the Rep
15335 -- Item chain of Ent.
15337 Check_Duplicate_Pragma
(Ent
);
15338 Record_Rep_Item
(Ent
, N
);
15340 end Interrupt_Priority
;
15342 ---------------------
15343 -- Interrupt_State --
15344 ---------------------
15346 -- pragma Interrupt_State (
15347 -- [Name =>] INTERRUPT_ID,
15348 -- [State =>] INTERRUPT_STATE);
15350 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15351 -- INTERRUPT_STATE => System | Runtime | User
15353 -- Note: if the interrupt id is given as an identifier, then it must
15354 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15355 -- given as a static integer expression which must be in the range of
15356 -- Ada.Interrupts.Interrupt_ID.
15358 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15359 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15360 -- This is the entity Ada.Interrupts.Interrupt_ID;
15362 State_Type
: Character;
15363 -- Set to 's'/'r'/'u' for System/Runtime/User
15366 -- Index to entry in Interrupt_States table
15369 -- Value of interrupt
15371 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15372 -- The first argument to the pragma
15374 Int_Ent
: Entity_Id
;
15375 -- Interrupt entity in Ada.Interrupts.Names
15379 Check_Arg_Order
((Name_Name
, Name_State
));
15380 Check_Arg_Count
(2);
15382 Check_Optional_Identifier
(Arg1
, Name_Name
);
15383 Check_Optional_Identifier
(Arg2
, Name_State
);
15384 Check_Arg_Is_Identifier
(Arg2
);
15386 -- First argument is identifier
15388 if Nkind
(Arg1X
) = N_Identifier
then
15390 -- Search list of names in Ada.Interrupts.Names
15392 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15394 if No
(Int_Ent
) then
15395 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15397 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15398 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15402 Next_Entity
(Int_Ent
);
15405 -- First argument is not an identifier, so it must be a static
15406 -- expression of type Ada.Interrupts.Interrupt_ID.
15409 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15410 Int_Val
:= Expr_Value
(Arg1X
);
15412 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15414 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15417 ("value not in range of type "
15418 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15424 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15425 when Name_Runtime
=> State_Type
:= 'r';
15426 when Name_System
=> State_Type
:= 's';
15427 when Name_User
=> State_Type
:= 'u';
15430 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15433 -- Check if entry is already stored
15435 IST_Num
:= Interrupt_States
.First
;
15437 -- If entry not found, add it
15439 if IST_Num
> Interrupt_States
.Last
then
15440 Interrupt_States
.Append
15441 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15442 Interrupt_State
=> State_Type
,
15443 Pragma_Loc
=> Loc
));
15446 -- Case of entry for the same entry
15448 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15451 -- If state matches, done, no need to make redundant entry
15454 State_Type
= Interrupt_States
.Table
(IST_Num
).
15457 -- Otherwise if state does not match, error
15460 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15462 ("state conflicts with that given #", Arg2
);
15466 IST_Num
:= IST_Num
+ 1;
15468 end Interrupt_State
;
15474 -- pragma Invariant
15475 -- ([Entity =>] type_LOCAL_NAME,
15476 -- [Check =>] EXPRESSION
15477 -- [,[Message =>] String_Expression]);
15479 when Pragma_Invariant
=> Invariant
: declare
15486 Check_At_Least_N_Arguments
(2);
15487 Check_At_Most_N_Arguments
(3);
15488 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15489 Check_Optional_Identifier
(Arg2
, Name_Check
);
15491 if Arg_Count
= 3 then
15492 Check_Optional_Identifier
(Arg3
, Name_Message
);
15493 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
15496 Check_Arg_Is_Local_Name
(Arg1
);
15498 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15499 Find_Type
(Type_Id
);
15500 Typ
:= Entity
(Type_Id
);
15502 if Typ
= Any_Type
then
15505 -- Invariants allowed in interface types (RM 7.3.2(3/3))
15507 elsif Is_Interface
(Typ
) then
15510 -- An invariant must apply to a private type, or appear in the
15511 -- private part of a package spec and apply to a completion.
15512 -- a class-wide invariant can only appear on a private declaration
15513 -- or private extension, not a completion.
15515 elsif Ekind_In
(Typ
, E_Private_Type
,
15516 E_Record_Type_With_Private
,
15517 E_Limited_Private_Type
)
15521 elsif In_Private_Part
(Current_Scope
)
15522 and then Has_Private_Declaration
(Typ
)
15523 and then not Class_Present
(N
)
15527 elsif In_Private_Part
(Current_Scope
) then
15529 ("pragma% only allowed for private type declared in "
15530 & "visible part", Arg1
);
15534 ("pragma% only allowed for private type", Arg1
);
15537 -- Not allowed for abstract type in the non-class case (it is
15538 -- allowed to use Invariant'Class for abstract types).
15540 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
15542 ("pragma% not allowed for abstract type", Arg1
);
15545 -- Note that the type has at least one invariant, and also that
15546 -- it has inheritable invariants if we have Invariant'Class
15547 -- or Type_Invariant'Class. Build the corresponding invariant
15548 -- procedure declaration, so that calls to it can be generated
15549 -- before the body is built (e.g. within an expression function).
15551 -- Interface types have no invariant procedure; their invariants
15552 -- are propagated to the build invariant procedure of all the
15553 -- types covering the interface type.
15555 if not Is_Interface
(Typ
) then
15556 Insert_After_And_Analyze
15557 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
15560 if Class_Present
(N
) then
15561 Set_Has_Inheritable_Invariants
(Typ
);
15564 -- The remaining processing is simply to link the pragma on to
15565 -- the rep item chain, for processing when the type is frozen.
15566 -- This is accomplished by a call to Rep_Item_Too_Late.
15568 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15571 ----------------------
15572 -- Java_Constructor --
15573 ----------------------
15575 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15577 -- Also handles pragma CIL_Constructor
15579 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15580 Java_Constructor
: declare
15581 Convention
: Convention_Id
;
15582 Def_Id
: Entity_Id
;
15583 Hom_Id
: Entity_Id
;
15585 This_Formal
: Entity_Id
;
15589 Check_Arg_Count
(1);
15590 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15591 Check_Arg_Is_Local_Name
(Arg1
);
15593 Id
:= Get_Pragma_Arg
(Arg1
);
15594 Find_Program_Unit_Name
(Id
);
15596 -- If we did not find the name, we are done
15598 if Etype
(Id
) = Any_Type
then
15602 -- Check wrong use of pragma in wrong VM target
15604 if VM_Target
= No_VM
then
15607 elsif VM_Target
= CLI_Target
15608 and then Prag_Id
= Pragma_Java_Constructor
15610 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15612 elsif VM_Target
= JVM_Target
15613 and then Prag_Id
= Pragma_CIL_Constructor
15615 Error_Pragma
("must use pragma 'Java_'Constructor");
15619 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15620 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15621 when others => null;
15624 Hom_Id
:= Entity
(Id
);
15626 -- Loop through homonyms
15629 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15631 -- The constructor is required to be a function
15633 if Ekind
(Def_Id
) /= E_Function
then
15634 if VM_Target
= JVM_Target
then
15636 ("pragma% requires function returning a 'Java access "
15640 ("pragma% requires function returning a 'C'I'L access "
15645 -- Check arguments: For tagged type the first formal must be
15646 -- named "this" and its type must be a named access type
15647 -- designating a class-wide tagged type that has convention
15648 -- CIL/Java. The first formal must also have a null default
15649 -- value. For example:
15651 -- type Typ is tagged ...
15652 -- type Ref is access all Typ;
15653 -- pragma Convention (CIL, Typ);
15655 -- function New_Typ (This : Ref) return Ref;
15656 -- function New_Typ (This : Ref; I : Integer) return Ref;
15657 -- pragma Cil_Constructor (New_Typ);
15659 -- Reason: The first formal must NOT be a primitive of the
15662 -- This rule also applies to constructors of delegates used
15663 -- to interface with standard target libraries. For example:
15665 -- type Delegate is access procedure ...
15666 -- pragma Import (CIL, Delegate, ...);
15668 -- function new_Delegate
15669 -- (This : Delegate := null; ... ) return Delegate;
15671 -- For value-types this rule does not apply.
15673 if not Is_Value_Type
(Etype
(Def_Id
)) then
15674 if No
(First_Formal
(Def_Id
)) then
15675 Error_Msg_Name_1
:= Pname
;
15676 Error_Msg_N
("% function must have parameters", Def_Id
);
15680 -- In the JRE library we have several occurrences in which
15681 -- the "this" parameter is not the first formal.
15683 This_Formal
:= First_Formal
(Def_Id
);
15685 -- In the JRE library we have several occurrences in which
15686 -- the "this" parameter is not the first formal. Search for
15689 if VM_Target
= JVM_Target
then
15690 while Present
(This_Formal
)
15691 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15693 Next_Formal
(This_Formal
);
15696 if No
(This_Formal
) then
15697 This_Formal
:= First_Formal
(Def_Id
);
15701 -- Warning: The first parameter should be named "this".
15702 -- We temporarily allow it because we have the following
15703 -- case in the Java runtime (file s-osinte.ads) ???
15705 -- function new_Thread
15706 -- (Self_Id : System.Address) return Thread_Id;
15707 -- pragma Java_Constructor (new_Thread);
15709 if VM_Target
= JVM_Target
15710 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15712 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15716 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15717 Error_Msg_Name_1
:= Pname
;
15719 ("first formal of % function must be named `this`",
15720 Parent
(This_Formal
));
15722 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15723 Error_Msg_Name_1
:= Pname
;
15725 ("first formal of % function must be an access type",
15726 Parameter_Type
(Parent
(This_Formal
)));
15728 -- For delegates the type of the first formal must be a
15729 -- named access-to-subprogram type (see previous example)
15731 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15732 and then Ekind
(Etype
(This_Formal
))
15733 /= E_Access_Subprogram_Type
15735 Error_Msg_Name_1
:= Pname
;
15737 ("first formal of % function must be a named access "
15738 & "to subprogram type",
15739 Parameter_Type
(Parent
(This_Formal
)));
15741 -- Warning: We should reject anonymous access types because
15742 -- the constructor must not be handled as a primitive of the
15743 -- tagged type. We temporarily allow it because this profile
15744 -- is currently generated by cil2ada???
15746 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
15747 and then not Ekind_In
(Etype
(This_Formal
),
15749 E_General_Access_Type
,
15750 E_Anonymous_Access_Type
)
15752 Error_Msg_Name_1
:= Pname
;
15754 ("first formal of % function must be a named access "
15755 & "type", Parameter_Type
(Parent
(This_Formal
)));
15757 elsif Atree
.Convention
15758 (Designated_Type
(Etype
(This_Formal
))) /= Convention
15760 Error_Msg_Name_1
:= Pname
;
15762 if Convention
= Convention_Java
then
15764 ("pragma% requires convention 'Cil in designated "
15765 & "type", Parameter_Type
(Parent
(This_Formal
)));
15768 ("pragma% requires convention 'Java in designated "
15769 & "type", Parameter_Type
(Parent
(This_Formal
)));
15772 elsif No
(Expression
(Parent
(This_Formal
)))
15773 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
15775 Error_Msg_Name_1
:= Pname
;
15777 ("pragma% requires first formal with default `null`",
15778 Parameter_Type
(Parent
(This_Formal
)));
15782 -- Check result type: the constructor must be a function
15784 -- * a value type (only allowed in the CIL compiler)
15785 -- * an access-to-subprogram type with convention Java/CIL
15786 -- * an access-type designating a type that has convention
15789 if Is_Value_Type
(Etype
(Def_Id
)) then
15792 -- Access-to-subprogram type with convention Java/CIL
15794 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
15795 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
15796 if Convention
= Convention_Java
then
15798 ("pragma% requires function returning a 'Java "
15799 & "access type", Arg1
);
15801 pragma Assert
(Convention
= Convention_CIL
);
15803 ("pragma% requires function returning a 'C'I'L "
15804 & "access type", Arg1
);
15808 elsif Is_Access_Type
(Etype
(Def_Id
)) then
15809 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
15810 E_General_Access_Type
)
15813 (Designated_Type
(Etype
(Def_Id
))) /= Convention
15815 Error_Msg_Name_1
:= Pname
;
15817 if Convention
= Convention_Java
then
15819 ("pragma% requires function returning a named "
15820 & "'Java access type", Arg1
);
15823 ("pragma% requires function returning a named "
15824 & "'C'I'L access type", Arg1
);
15829 Set_Is_Constructor
(Def_Id
);
15830 Set_Convention
(Def_Id
, Convention
);
15831 Set_Is_Imported
(Def_Id
);
15833 exit when From_Aspect_Specification
(N
);
15834 Hom_Id
:= Homonym
(Hom_Id
);
15836 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
15838 end Java_Constructor
;
15840 ----------------------
15841 -- Java_Interface --
15842 ----------------------
15844 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
15846 when Pragma_Java_Interface
=> Java_Interface
: declare
15852 Check_Arg_Count
(1);
15853 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15854 Check_Arg_Is_Local_Name
(Arg1
);
15856 Arg
:= Get_Pragma_Arg
(Arg1
);
15859 if Etype
(Arg
) = Any_Type
then
15863 if not Is_Entity_Name
(Arg
)
15864 or else not Is_Type
(Entity
(Arg
))
15866 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
15869 Typ
:= Underlying_Type
(Entity
(Arg
));
15871 -- For now simply check some of the semantic constraints on the
15872 -- type. This currently leaves out some restrictions on interface
15873 -- types, namely that the parent type must be java.lang.Object.Typ
15874 -- and that all primitives of the type should be declared
15877 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
15879 ("pragma% requires an abstract tagged type", Arg1
);
15881 elsif not Has_Discriminants
(Typ
)
15882 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
15883 /= E_Anonymous_Access_Type
15885 not Is_Class_Wide_Type
15886 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
15889 ("type must have a class-wide access discriminant", Arg1
);
15891 end Java_Interface
;
15897 -- pragma Keep_Names ([On => ] LOCAL_NAME);
15899 when Pragma_Keep_Names
=> Keep_Names
: declare
15904 Check_Arg_Count
(1);
15905 Check_Optional_Identifier
(Arg1
, Name_On
);
15906 Check_Arg_Is_Local_Name
(Arg1
);
15908 Arg
:= Get_Pragma_Arg
(Arg1
);
15911 if Etype
(Arg
) = Any_Type
then
15915 if not Is_Entity_Name
(Arg
)
15916 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
15919 ("pragma% requires a local enumeration type", Arg1
);
15922 Set_Discard_Names
(Entity
(Arg
), False);
15929 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
15931 when Pragma_License
=>
15934 -- Do not analyze pragma any further in CodePeer mode, to avoid
15935 -- extraneous errors in this implementation-dependent pragma,
15936 -- which has a different profile on other compilers.
15938 if CodePeer_Mode
then
15942 Check_Arg_Count
(1);
15943 Check_No_Identifiers
;
15944 Check_Valid_Configuration_Pragma
;
15945 Check_Arg_Is_Identifier
(Arg1
);
15948 Sind
: constant Source_File_Index
:=
15949 Source_Index
(Current_Sem_Unit
);
15952 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15954 Set_License
(Sind
, GPL
);
15956 when Name_Modified_GPL
=>
15957 Set_License
(Sind
, Modified_GPL
);
15959 when Name_Restricted
=>
15960 Set_License
(Sind
, Restricted
);
15962 when Name_Unrestricted
=>
15963 Set_License
(Sind
, Unrestricted
);
15966 Error_Pragma_Arg
("invalid license name", Arg1
);
15974 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
15976 when Pragma_Link_With
=> Link_With
: declare
15982 if Operating_Mode
= Generate_Code
15983 and then In_Extended_Main_Source_Unit
(N
)
15985 Check_At_Least_N_Arguments
(1);
15986 Check_No_Identifiers
;
15987 Check_Is_In_Decl_Part_Or_Package_Spec
;
15988 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15992 while Present
(Arg
) loop
15993 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
15995 -- Store argument, converting sequences of spaces to a
15996 -- single null character (this is one of the differences
15997 -- in processing between Link_With and Linker_Options).
15999 Arg_Store
: declare
16000 C
: constant Char_Code
:= Get_Char_Code
(' ');
16001 S
: constant String_Id
:=
16002 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16003 L
: constant Nat
:= String_Length
(S
);
16006 procedure Skip_Spaces
;
16007 -- Advance F past any spaces
16013 procedure Skip_Spaces
is
16015 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16020 -- Start of processing for Arg_Store
16023 Skip_Spaces
; -- skip leading spaces
16025 -- Loop through characters, changing any embedded
16026 -- sequence of spaces to a single null character (this
16027 -- is how Link_With/Linker_Options differ)
16030 if Get_String_Char
(S
, F
) = C
then
16033 Store_String_Char
(ASCII
.NUL
);
16036 Store_String_Char
(Get_String_Char
(S
, F
));
16044 if Present
(Arg
) then
16045 Store_String_Char
(ASCII
.NUL
);
16049 Store_Linker_Option_String
(End_String
);
16057 -- pragma Linker_Alias (
16058 -- [Entity =>] LOCAL_NAME
16059 -- [Target =>] static_string_EXPRESSION);
16061 when Pragma_Linker_Alias
=>
16063 Check_Arg_Order
((Name_Entity
, Name_Target
));
16064 Check_Arg_Count
(2);
16065 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16066 Check_Optional_Identifier
(Arg2
, Name_Target
);
16067 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16068 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16070 -- The only processing required is to link this item on to the
16071 -- list of rep items for the given entity. This is accomplished
16072 -- by the call to Rep_Item_Too_Late (when no error is detected
16073 -- and False is returned).
16075 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16078 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16081 ------------------------
16082 -- Linker_Constructor --
16083 ------------------------
16085 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16087 -- Code is shared with Linker_Destructor
16089 -----------------------
16090 -- Linker_Destructor --
16091 -----------------------
16093 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16095 when Pragma_Linker_Constructor |
16096 Pragma_Linker_Destructor
=>
16097 Linker_Constructor
: declare
16103 Check_Arg_Count
(1);
16104 Check_No_Identifiers
;
16105 Check_Arg_Is_Local_Name
(Arg1
);
16106 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16108 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16110 if not Is_Library_Level_Entity
(Proc
) then
16112 ("argument for pragma% must be library level entity", Arg1
);
16115 -- The only processing required is to link this item on to the
16116 -- list of rep items for the given entity. This is accomplished
16117 -- by the call to Rep_Item_Too_Late (when no error is detected
16118 -- and False is returned).
16120 if Rep_Item_Too_Late
(Proc
, N
) then
16123 Set_Has_Gigi_Rep_Item
(Proc
);
16125 end Linker_Constructor
;
16127 --------------------
16128 -- Linker_Options --
16129 --------------------
16131 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16133 when Pragma_Linker_Options
=> Linker_Options
: declare
16137 Check_Ada_83_Warning
;
16138 Check_No_Identifiers
;
16139 Check_Arg_Count
(1);
16140 Check_Is_In_Decl_Part_Or_Package_Spec
;
16141 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16142 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16145 while Present
(Arg
) loop
16146 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16147 Store_String_Char
(ASCII
.NUL
);
16149 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16153 if Operating_Mode
= Generate_Code
16154 and then In_Extended_Main_Source_Unit
(N
)
16156 Store_Linker_Option_String
(End_String
);
16158 end Linker_Options
;
16160 --------------------
16161 -- Linker_Section --
16162 --------------------
16164 -- pragma Linker_Section (
16165 -- [Entity =>] LOCAL_NAME
16166 -- [Section =>] static_string_EXPRESSION);
16168 when Pragma_Linker_Section
=> Linker_Section
: declare
16175 Check_Arg_Order
((Name_Entity
, Name_Section
));
16176 Check_Arg_Count
(2);
16177 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16178 Check_Optional_Identifier
(Arg2
, Name_Section
);
16179 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16180 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16182 -- Check kind of entity
16184 Arg
:= Get_Pragma_Arg
(Arg1
);
16185 Ent
:= Entity
(Arg
);
16187 case Ekind
(Ent
) is
16189 -- Objects (constants and variables) and types. For these cases
16190 -- all we need to do is to set the Linker_Section_pragma field,
16191 -- checking that we do not have a duplicate.
16193 when E_Constant | E_Variable | Type_Kind
=>
16194 LPE
:= Linker_Section_Pragma
(Ent
);
16196 if Present
(LPE
) then
16197 Error_Msg_Sloc
:= Sloc
(LPE
);
16199 ("Linker_Section already specified for &#", Arg1
, Ent
);
16202 Set_Linker_Section_Pragma
(Ent
, N
);
16206 when Subprogram_Kind
=>
16208 -- Aspect case, entity already set
16210 if From_Aspect_Specification
(N
) then
16211 Set_Linker_Section_Pragma
16212 (Entity
(Corresponding_Aspect
(N
)), N
);
16214 -- Pragma case, we must climb the homonym chain, but skip
16215 -- any for which the linker section is already set.
16219 if No
(Linker_Section_Pragma
(Ent
)) then
16220 Set_Linker_Section_Pragma
(Ent
, N
);
16223 Ent
:= Homonym
(Ent
);
16225 or else Scope
(Ent
) /= Current_Scope
;
16229 -- All other cases are illegal
16233 ("pragma% applies only to objects, subprograms, and types",
16236 end Linker_Section
;
16242 -- pragma List (On | Off)
16244 -- There is nothing to do here, since we did all the processing for
16245 -- this pragma in Par.Prag (so that it works properly even in syntax
16248 when Pragma_List
=>
16255 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16257 when Pragma_Lock_Free
=> Lock_Free
: declare
16258 P
: constant Node_Id
:= Parent
(N
);
16264 Check_No_Identifiers
;
16265 Check_At_Most_N_Arguments
(1);
16267 -- Protected definition case
16269 if Nkind
(P
) = N_Protected_Definition
then
16270 Ent
:= Defining_Identifier
(Parent
(P
));
16274 if Arg_Count
= 1 then
16275 Arg
:= Get_Pragma_Arg
(Arg1
);
16276 Val
:= Is_True
(Static_Boolean
(Arg
));
16278 -- No arguments (expression is considered to be True)
16284 -- Check duplicate pragma before we chain the pragma in the Rep
16285 -- Item chain of Ent.
16287 Check_Duplicate_Pragma
(Ent
);
16288 Record_Rep_Item
(Ent
, N
);
16289 Set_Uses_Lock_Free
(Ent
, Val
);
16291 -- Anything else is incorrect placement
16298 --------------------
16299 -- Locking_Policy --
16300 --------------------
16302 -- pragma Locking_Policy (policy_IDENTIFIER);
16304 when Pragma_Locking_Policy
=> declare
16305 subtype LP_Range
is Name_Id
16306 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16311 Check_Ada_83_Warning
;
16312 Check_Arg_Count
(1);
16313 Check_No_Identifiers
;
16314 Check_Arg_Is_Locking_Policy
(Arg1
);
16315 Check_Valid_Configuration_Pragma
;
16316 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16319 when Name_Ceiling_Locking
=>
16321 when Name_Inheritance_Locking
=>
16323 when Name_Concurrent_Readers_Locking
=>
16327 if Locking_Policy
/= ' '
16328 and then Locking_Policy
/= LP
16330 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16331 Error_Pragma
("locking policy incompatible with policy#");
16333 -- Set new policy, but always preserve System_Location since we
16334 -- like the error message with the run time name.
16337 Locking_Policy
:= LP
;
16339 if Locking_Policy_Sloc
/= System_Location
then
16340 Locking_Policy_Sloc
:= Loc
;
16345 -------------------
16346 -- Loop_Optimize --
16347 -------------------
16349 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16351 -- OPTIMIZATION_HINT ::=
16352 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16354 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16359 Check_At_Least_N_Arguments
(1);
16360 Check_No_Identifiers
;
16362 Hint
:= First
(Pragma_Argument_Associations
(N
));
16363 while Present
(Hint
) loop
16364 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16372 Check_Loop_Pragma_Placement
;
16379 -- pragma Loop_Variant
16380 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16382 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16384 -- CHANGE_DIRECTION ::= Increases | Decreases
16386 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16391 Check_At_Least_N_Arguments
(1);
16392 Check_Loop_Pragma_Placement
;
16394 -- Process all increasing / decreasing expressions
16396 Variant
:= First
(Pragma_Argument_Associations
(N
));
16397 while Present
(Variant
) loop
16398 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16401 Error_Pragma_Arg
("wrong change modifier", Variant
);
16404 Preanalyze_Assert_Expression
16405 (Expression
(Variant
), Any_Discrete
);
16411 -----------------------
16412 -- Machine_Attribute --
16413 -----------------------
16415 -- pragma Machine_Attribute (
16416 -- [Entity =>] LOCAL_NAME,
16417 -- [Attribute_Name =>] static_string_EXPRESSION
16418 -- [, [Info =>] static_EXPRESSION] );
16420 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16421 Def_Id
: Entity_Id
;
16425 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16427 if Arg_Count
= 3 then
16428 Check_Optional_Identifier
(Arg3
, Name_Info
);
16429 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16431 Check_Arg_Count
(2);
16434 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16435 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16436 Check_Arg_Is_Local_Name
(Arg1
);
16437 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16438 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16440 if Is_Access_Type
(Def_Id
) then
16441 Def_Id
:= Designated_Type
(Def_Id
);
16444 if Rep_Item_Too_Early
(Def_Id
, N
) then
16448 Def_Id
:= Underlying_Type
(Def_Id
);
16450 -- The only processing required is to link this item on to the
16451 -- list of rep items for the given entity. This is accomplished
16452 -- by the call to Rep_Item_Too_Late (when no error is detected
16453 -- and False is returned).
16455 if Rep_Item_Too_Late
(Def_Id
, N
) then
16458 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16460 end Machine_Attribute
;
16467 -- (MAIN_OPTION [, MAIN_OPTION]);
16470 -- [STACK_SIZE =>] static_integer_EXPRESSION
16471 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16472 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16474 when Pragma_Main
=> Main
: declare
16475 Args
: Args_List
(1 .. 3);
16476 Names
: constant Name_List
(1 .. 3) := (
16478 Name_Task_Stack_Size_Default
,
16479 Name_Time_Slicing_Enabled
);
16485 Gather_Associations
(Names
, Args
);
16487 for J
in 1 .. 2 loop
16488 if Present
(Args
(J
)) then
16489 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16493 if Present
(Args
(3)) then
16494 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
16498 while Present
(Nod
) loop
16499 if Nkind
(Nod
) = N_Pragma
16500 and then Pragma_Name
(Nod
) = Name_Main
16502 Error_Msg_Name_1
:= Pname
;
16503 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16514 -- pragma Main_Storage
16515 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16517 -- MAIN_STORAGE_OPTION ::=
16518 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16519 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16521 when Pragma_Main_Storage
=> Main_Storage
: declare
16522 Args
: Args_List
(1 .. 2);
16523 Names
: constant Name_List
(1 .. 2) := (
16524 Name_Working_Storage
,
16531 Gather_Associations
(Names
, Args
);
16533 for J
in 1 .. 2 loop
16534 if Present
(Args
(J
)) then
16535 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16539 Check_In_Main_Program
;
16542 while Present
(Nod
) loop
16543 if Nkind
(Nod
) = N_Pragma
16544 and then Pragma_Name
(Nod
) = Name_Main_Storage
16546 Error_Msg_Name_1
:= Pname
;
16547 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16558 -- pragma Memory_Size (NUMERIC_LITERAL)
16560 when Pragma_Memory_Size
=>
16563 -- Memory size is simply ignored
16565 Check_No_Identifiers
;
16566 Check_Arg_Count
(1);
16567 Check_Arg_Is_Integer_Literal
(Arg1
);
16575 -- The only correct use of this pragma is on its own in a file, in
16576 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16577 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16578 -- check for a file containing nothing but a No_Body pragma). If we
16579 -- attempt to process it during normal semantics processing, it means
16580 -- it was misplaced.
16582 when Pragma_No_Body
=>
16586 -----------------------------
16587 -- No_Elaboration_Code_All --
16588 -----------------------------
16590 -- pragma No_Elaboration_Code_All;
16592 when Pragma_No_Elaboration_Code_All
=> NECA
: declare
16595 Check_Valid_Library_Unit_Pragma
;
16597 if Nkind
(N
) = N_Null_Statement
then
16601 -- Must appear for a spec or generic spec
16603 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
16604 N_Generic_Package_Declaration
,
16605 N_Generic_Subprogram_Declaration
,
16606 N_Package_Declaration
,
16607 N_Subprogram_Declaration
)
16611 ("pragma% can only occur for package "
16612 & "or subprogram spec"));
16615 -- Set flag in unit table
16617 Set_No_Elab_Code_All
(Current_Sem_Unit
);
16619 -- Set restriction No_Elaboration_Code if this is the main unit
16621 if Current_Sem_Unit
= Main_Unit
then
16622 Set_Restriction
(No_Elaboration_Code
, N
);
16625 -- If we are in the main unit or in an extended main source unit,
16626 -- then we also add it to the configuration restrictions so that
16627 -- it will apply to all units in the extended main source.
16629 if Current_Sem_Unit
= Main_Unit
16630 or else In_Extended_Main_Source_Unit
(N
)
16632 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
16635 -- If in main extended unit, activate transitive with test
16637 if In_Extended_Main_Source_Unit
(N
) then
16638 Opt
.No_Elab_Code_All_Pragma
:= N
;
16646 -- pragma No_Inline ( NAME {, NAME} );
16648 when Pragma_No_Inline
=>
16650 Process_Inline
(Suppressed
);
16656 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16658 when Pragma_No_Return
=> No_Return
: declare
16666 Check_At_Least_N_Arguments
(1);
16668 -- Loop through arguments of pragma
16671 while Present
(Arg
) loop
16672 Check_Arg_Is_Local_Name
(Arg
);
16673 Id
:= Get_Pragma_Arg
(Arg
);
16676 if not Is_Entity_Name
(Id
) then
16677 Error_Pragma_Arg
("entity name required", Arg
);
16680 if Etype
(Id
) = Any_Type
then
16684 -- Loop to find matching procedures
16689 and then Scope
(E
) = Current_Scope
16691 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16694 -- Set flag on any alias as well
16696 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16697 Set_No_Return
(Alias
(E
));
16703 exit when From_Aspect_Specification
(N
);
16707 -- If entity in not in current scope it may be the enclosing
16708 -- suprogram body to which the aspect applies.
16711 if Entity
(Id
) = Current_Scope
16712 and then From_Aspect_Specification
(N
)
16714 Set_No_Return
(Entity
(Id
));
16716 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16728 -- pragma No_Run_Time;
16730 -- Note: this pragma is retained for backwards compatibility. See
16731 -- body of Rtsfind for full details on its handling.
16733 when Pragma_No_Run_Time
=>
16735 Check_Valid_Configuration_Pragma
;
16736 Check_Arg_Count
(0);
16738 No_Run_Time_Mode
:= True;
16739 Configurable_Run_Time_Mode
:= True;
16741 -- Set Duration to 32 bits if word size is 32
16743 if Ttypes
.System_Word_Size
= 32 then
16744 Duration_32_Bits_On_Target
:= True;
16747 -- Set appropriate restrictions
16749 Set_Restriction
(No_Finalization
, N
);
16750 Set_Restriction
(No_Exception_Handlers
, N
);
16751 Set_Restriction
(Max_Tasks
, N
, 0);
16752 Set_Restriction
(No_Tasking
, N
);
16754 -----------------------
16755 -- No_Tagged_Streams --
16756 -----------------------
16758 -- pragma No_Tagged_Streams;
16759 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
16761 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
16767 Check_At_Most_N_Arguments
(1);
16769 -- One argument case
16771 if Arg_Count
= 1 then
16772 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16773 Check_Arg_Is_Local_Name
(Arg1
);
16774 E_Id
:= Get_Pragma_Arg
(Arg1
);
16776 if Etype
(E_Id
) = Any_Type
then
16780 E
:= Entity
(E_Id
);
16782 Check_Duplicate_Pragma
(E
);
16784 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
16786 ("argument for pragma% must be root tagged type", Arg1
);
16789 if Rep_Item_Too_Early
(E
, N
)
16791 Rep_Item_Too_Late
(E
, N
)
16795 Set_No_Tagged_Streams_Pragma
(E
, N
);
16798 -- Zero argument case
16801 Check_Is_In_Decl_Part_Or_Package_Spec
;
16802 No_Tagged_Streams
:= N
;
16804 end No_Tagged_Strms
;
16806 ------------------------
16807 -- No_Strict_Aliasing --
16808 ------------------------
16810 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16812 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
16817 Check_At_Most_N_Arguments
(1);
16819 if Arg_Count
= 0 then
16820 Check_Valid_Configuration_Pragma
;
16821 Opt
.No_Strict_Aliasing
:= True;
16824 Check_Optional_Identifier
(Arg2
, Name_Entity
);
16825 Check_Arg_Is_Local_Name
(Arg1
);
16826 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16828 if E_Id
= Any_Type
then
16830 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
16831 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
16834 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
16836 end No_Strict_Aliasing
;
16838 -----------------------
16839 -- Normalize_Scalars --
16840 -----------------------
16842 -- pragma Normalize_Scalars;
16844 when Pragma_Normalize_Scalars
=>
16845 Check_Ada_83_Warning
;
16846 Check_Arg_Count
(0);
16847 Check_Valid_Configuration_Pragma
;
16849 -- Normalize_Scalars creates false positives in CodePeer, and
16850 -- incorrect negative results in GNATprove mode, so ignore this
16851 -- pragma in these modes.
16853 if not (CodePeer_Mode
or GNATprove_Mode
) then
16854 Normalize_Scalars
:= True;
16855 Init_Or_Norm_Scalars
:= True;
16862 -- pragma Obsolescent;
16864 -- pragma Obsolescent (
16865 -- [Message =>] static_string_EXPRESSION
16866 -- [,[Version =>] Ada_05]]);
16868 -- pragma Obsolescent (
16869 -- [Entity =>] NAME
16870 -- [,[Message =>] static_string_EXPRESSION
16871 -- [,[Version =>] Ada_05]] );
16873 when Pragma_Obsolescent
=> Obsolescent
: declare
16877 procedure Set_Obsolescent
(E
: Entity_Id
);
16878 -- Given an entity Ent, mark it as obsolescent if appropriate
16880 ---------------------
16881 -- Set_Obsolescent --
16882 ---------------------
16884 procedure Set_Obsolescent
(E
: Entity_Id
) is
16893 -- Entity name was given
16895 if Present
(Ename
) then
16897 -- If entity name matches, we are fine. Save entity in
16898 -- pragma argument, for ASIS use.
16900 if Chars
(Ename
) = Chars
(Ent
) then
16901 Set_Entity
(Ename
, Ent
);
16902 Generate_Reference
(Ent
, Ename
);
16904 -- If entity name does not match, only possibility is an
16905 -- enumeration literal from an enumeration type declaration.
16907 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
16909 ("pragma % entity name does not match declaration");
16912 Ent
:= First_Literal
(E
);
16916 ("pragma % entity name does not match any "
16917 & "enumeration literal");
16919 elsif Chars
(Ent
) = Chars
(Ename
) then
16920 Set_Entity
(Ename
, Ent
);
16921 Generate_Reference
(Ent
, Ename
);
16925 Ent
:= Next_Literal
(Ent
);
16931 -- Ent points to entity to be marked
16933 if Arg_Count
>= 1 then
16935 -- Deal with static string argument
16937 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16938 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
16940 for J
in 1 .. String_Length
(S
) loop
16941 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
16943 ("pragma% argument does not allow wide characters",
16948 Obsolescent_Warnings
.Append
16949 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
16951 -- Check for Ada_05 parameter
16953 if Arg_Count
/= 1 then
16954 Check_Arg_Count
(2);
16957 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
16960 Check_Arg_Is_Identifier
(Argx
);
16962 if Chars
(Argx
) /= Name_Ada_05
then
16963 Error_Msg_Name_2
:= Name_Ada_05
;
16965 ("only allowed argument for pragma% is %", Argx
);
16968 if Ada_Version_Explicit
< Ada_2005
16969 or else not Warn_On_Ada_2005_Compatibility
16977 -- Set flag if pragma active
16980 Set_Is_Obsolescent
(Ent
);
16984 end Set_Obsolescent
;
16986 -- Start of processing for pragma Obsolescent
16991 Check_At_Most_N_Arguments
(3);
16993 -- See if first argument specifies an entity name
16997 (Chars
(Arg1
) = Name_Entity
16999 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
17001 N_Operator_Symbol
))
17003 Ename
:= Get_Pragma_Arg
(Arg1
);
17005 -- Eliminate first argument, so we can share processing
17009 Arg_Count
:= Arg_Count
- 1;
17011 -- No Entity name argument given
17017 if Arg_Count
>= 1 then
17018 Check_Optional_Identifier
(Arg1
, Name_Message
);
17020 if Arg_Count
= 2 then
17021 Check_Optional_Identifier
(Arg2
, Name_Version
);
17025 -- Get immediately preceding declaration
17028 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17032 -- Cases where we do not follow anything other than another pragma
17036 -- First case: library level compilation unit declaration with
17037 -- the pragma immediately following the declaration.
17039 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17041 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17044 -- Case 2: library unit placement for package
17048 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17050 if Is_Package_Or_Generic_Package
(Ent
) then
17051 Set_Obsolescent
(Ent
);
17057 -- Cases where we must follow a declaration, including an
17058 -- abstract subprogram declaration, which is not in the
17059 -- other node subtypes.
17062 if Nkind
(Decl
) not in N_Declaration
17063 and then Nkind
(Decl
) not in N_Later_Decl_Item
17064 and then Nkind
(Decl
) not in N_Generic_Declaration
17065 and then Nkind
(Decl
) not in N_Renaming_Declaration
17066 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
17069 ("pragma% misplaced, "
17070 & "must immediately follow a declaration");
17073 Set_Obsolescent
(Defining_Entity
(Decl
));
17083 -- pragma Optimize (Time | Space | Off);
17085 -- The actual check for optimize is done in Gigi. Note that this
17086 -- pragma does not actually change the optimization setting, it
17087 -- simply checks that it is consistent with the pragma.
17089 when Pragma_Optimize
=>
17090 Check_No_Identifiers
;
17091 Check_Arg_Count
(1);
17092 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17094 ------------------------
17095 -- Optimize_Alignment --
17096 ------------------------
17098 -- pragma Optimize_Alignment (Time | Space | Off);
17100 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17102 Check_No_Identifiers
;
17103 Check_Arg_Count
(1);
17104 Check_Valid_Configuration_Pragma
;
17107 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17111 Opt
.Optimize_Alignment
:= 'T';
17113 Opt
.Optimize_Alignment
:= 'S';
17115 Opt
.Optimize_Alignment
:= 'O';
17117 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17121 -- Set indication that mode is set locally. If we are in fact in a
17122 -- configuration pragma file, this setting is harmless since the
17123 -- switch will get reset anyway at the start of each unit.
17125 Optimize_Alignment_Local
:= True;
17126 end Optimize_Alignment
;
17132 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17134 when Pragma_Ordered
=> Ordered
: declare
17135 Assoc
: constant Node_Id
:= Arg1
;
17141 Check_No_Identifiers
;
17142 Check_Arg_Count
(1);
17143 Check_Arg_Is_Local_Name
(Arg1
);
17145 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17146 Find_Type
(Type_Id
);
17147 Typ
:= Entity
(Type_Id
);
17149 if Typ
= Any_Type
then
17152 Typ
:= Underlying_Type
(Typ
);
17155 if not Is_Enumeration_Type
(Typ
) then
17156 Error_Pragma
("pragma% must specify enumeration type");
17159 Check_First_Subtype
(Arg1
);
17160 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17163 -------------------
17164 -- Overflow_Mode --
17165 -------------------
17167 -- pragma Overflow_Mode
17168 -- ([General => ] MODE [, [Assertions => ] MODE]);
17170 -- MODE := STRICT | MINIMIZED | ELIMINATED
17172 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17173 -- since System.Bignums makes this assumption. This is true of nearly
17174 -- all (all?) targets.
17176 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17177 function Get_Overflow_Mode
17179 Arg
: Node_Id
) return Overflow_Mode_Type
;
17180 -- Function to process one pragma argument, Arg. If an identifier
17181 -- is present, it must be Name. Mode type is returned if a valid
17182 -- argument exists, otherwise an error is signalled.
17184 -----------------------
17185 -- Get_Overflow_Mode --
17186 -----------------------
17188 function Get_Overflow_Mode
17190 Arg
: Node_Id
) return Overflow_Mode_Type
17192 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17195 Check_Optional_Identifier
(Arg
, Name
);
17196 Check_Arg_Is_Identifier
(Argx
);
17198 if Chars
(Argx
) = Name_Strict
then
17201 elsif Chars
(Argx
) = Name_Minimized
then
17204 elsif Chars
(Argx
) = Name_Eliminated
then
17205 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17207 ("Eliminated not implemented on this target", Argx
);
17213 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17215 end Get_Overflow_Mode
;
17217 -- Start of processing for Overflow_Mode
17221 Check_At_Least_N_Arguments
(1);
17222 Check_At_Most_N_Arguments
(2);
17224 -- Process first argument
17226 Scope_Suppress
.Overflow_Mode_General
:=
17227 Get_Overflow_Mode
(Name_General
, Arg1
);
17229 -- Case of only one argument
17231 if Arg_Count
= 1 then
17232 Scope_Suppress
.Overflow_Mode_Assertions
:=
17233 Scope_Suppress
.Overflow_Mode_General
;
17235 -- Case of two arguments present
17238 Scope_Suppress
.Overflow_Mode_Assertions
:=
17239 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17243 --------------------------
17244 -- Overriding Renamings --
17245 --------------------------
17247 -- pragma Overriding_Renamings;
17249 when Pragma_Overriding_Renamings
=>
17251 Check_Arg_Count
(0);
17252 Check_Valid_Configuration_Pragma
;
17253 Overriding_Renamings
:= True;
17259 -- pragma Pack (first_subtype_LOCAL_NAME);
17261 when Pragma_Pack
=> Pack
: declare
17262 Assoc
: constant Node_Id
:= Arg1
;
17266 Ignore
: Boolean := False;
17269 Check_No_Identifiers
;
17270 Check_Arg_Count
(1);
17271 Check_Arg_Is_Local_Name
(Arg1
);
17272 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17274 if not Is_Entity_Name
(Type_Id
)
17275 or else not Is_Type
(Entity
(Type_Id
))
17278 ("argument for pragma% must be type or subtype", Arg1
);
17281 Find_Type
(Type_Id
);
17282 Typ
:= Entity
(Type_Id
);
17285 or else Rep_Item_Too_Early
(Typ
, N
)
17289 Typ
:= Underlying_Type
(Typ
);
17292 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17293 Error_Pragma
("pragma% must specify array or record type");
17296 Check_First_Subtype
(Arg1
);
17297 Check_Duplicate_Pragma
(Typ
);
17301 if Is_Array_Type
(Typ
) then
17302 Ctyp
:= Component_Type
(Typ
);
17304 -- Ignore pack that does nothing
17306 if Known_Static_Esize
(Ctyp
)
17307 and then Known_Static_RM_Size
(Ctyp
)
17308 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17309 and then Addressable
(Esize
(Ctyp
))
17314 -- Process OK pragma Pack. Note that if there is a separate
17315 -- component clause present, the Pack will be cancelled. This
17316 -- processing is in Freeze.
17318 if not Rep_Item_Too_Late
(Typ
, N
) then
17320 -- In CodePeer mode, we do not need complex front-end
17321 -- expansions related to pragma Pack, so disable handling
17324 if CodePeer_Mode
then
17327 -- Don't attempt any packing for VM targets. We possibly
17328 -- could deal with some cases of array bit-packing, but we
17329 -- don't bother, since this is not a typical kind of
17330 -- representation in the VM context anyway (and would not
17331 -- for example work nicely with the debugger).
17333 elsif VM_Target
/= No_VM
then
17334 if not GNAT_Mode
then
17336 ("??pragma% ignored in this configuration");
17339 -- Normal case where we do the pack action
17343 Set_Is_Packed
(Base_Type
(Typ
));
17344 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17347 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17351 -- For record types, the pack is always effective
17353 else pragma Assert
(Is_Record_Type
(Typ
));
17354 if not Rep_Item_Too_Late
(Typ
, N
) then
17356 -- Ignore pack request with warning in VM mode (skip warning
17357 -- if we are compiling GNAT run time library).
17359 if VM_Target
/= No_VM
then
17360 if not GNAT_Mode
then
17362 ("??pragma% ignored in this configuration");
17365 -- Normal case of pack request active
17368 Set_Is_Packed
(Base_Type
(Typ
));
17369 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17370 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17382 -- There is nothing to do here, since we did all the processing for
17383 -- this pragma in Par.Prag (so that it works properly even in syntax
17386 when Pragma_Page
=>
17393 -- pragma Part_Of (ABSTRACT_STATE);
17395 -- ABSTRACT_STATE ::= NAME
17397 when Pragma_Part_Of
=> Part_Of
: declare
17398 procedure Propagate_Part_Of
17399 (Pack_Id
: Entity_Id
;
17400 State_Id
: Entity_Id
;
17401 Instance
: Node_Id
);
17402 -- Propagate the Part_Of indicator to all abstract states and
17403 -- objects declared in the visible state space of a package
17404 -- denoted by Pack_Id. State_Id is the encapsulating state.
17405 -- Instance is the package instantiation node.
17407 -----------------------
17408 -- Propagate_Part_Of --
17409 -----------------------
17411 procedure Propagate_Part_Of
17412 (Pack_Id
: Entity_Id
;
17413 State_Id
: Entity_Id
;
17414 Instance
: Node_Id
)
17416 Has_Item
: Boolean := False;
17417 -- Flag set when the visible state space contains at least one
17418 -- abstract state or variable.
17420 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17421 -- Propagate the Part_Of indicator to all abstract states and
17422 -- objects declared in the visible state space of a package
17423 -- denoted by Pack_Id.
17425 -----------------------
17426 -- Propagate_Part_Of --
17427 -----------------------
17429 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17430 Item_Id
: Entity_Id
;
17433 -- Traverse the entity chain of the package and set relevant
17434 -- attributes of abstract states and objects declared in the
17435 -- visible state space of the package.
17437 Item_Id
:= First_Entity
(Pack_Id
);
17438 while Present
(Item_Id
)
17439 and then not In_Private_Part
(Item_Id
)
17441 -- Do not consider internally generated items
17443 if not Comes_From_Source
(Item_Id
) then
17446 -- The Part_Of indicator turns an abstract state or an
17447 -- object into a constituent of the encapsulating state.
17449 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17455 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17456 Set_Encapsulating_State
(Item_Id
, State_Id
);
17458 -- Recursively handle nested packages and instantiations
17460 elsif Ekind
(Item_Id
) = E_Package
then
17461 Propagate_Part_Of
(Item_Id
);
17464 Next_Entity
(Item_Id
);
17466 end Propagate_Part_Of
;
17468 -- Start of processing for Propagate_Part_Of
17471 Propagate_Part_Of
(Pack_Id
);
17473 -- Detect a package instantiation that is subject to a Part_Of
17474 -- indicator, but has no visible state.
17476 if not Has_Item
then
17478 ("package instantiation & has Part_Of indicator but "
17479 & "lacks visible state", Instance
, Pack_Id
);
17481 end Propagate_Part_Of
;
17485 Item_Id
: Entity_Id
;
17488 State_Id
: Entity_Id
;
17491 -- Start of processing for Part_Of
17495 Check_No_Identifiers
;
17496 Check_Arg_Count
(1);
17498 -- Ensure the proper placement of the pragma. Part_Of must appear
17499 -- on an object declaration or a package instantiation.
17502 while Present
(Stmt
) loop
17504 -- Skip prior pragmas, but check for duplicates
17506 if Nkind
(Stmt
) = N_Pragma
then
17507 if Pragma_Name
(Stmt
) = Pname
then
17508 Error_Msg_Name_1
:= Pname
;
17509 Error_Msg_Sloc
:= Sloc
(Stmt
);
17510 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17513 -- Skip internally generated code
17515 elsif not Comes_From_Source
(Stmt
) then
17518 -- The pragma applies to an object declaration (possibly a
17519 -- variable) or a package instantiation. Stop the traversal
17520 -- and continue the analysis.
17522 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17523 N_Package_Instantiation
)
17527 -- The pragma does not apply to a legal construct, issue an
17528 -- error and stop the analysis.
17535 Stmt
:= Prev
(Stmt
);
17538 -- Extract the entity of the related object declaration or package
17539 -- instantiation. In the case of the instantiation, use the entity
17540 -- of the instance spec.
17542 if Nkind
(Stmt
) = N_Package_Instantiation
then
17543 Stmt
:= Instance_Spec
(Stmt
);
17546 Item_Id
:= Defining_Entity
(Stmt
);
17547 State
:= Get_Pragma_Arg
(Arg1
);
17549 -- Detect any discrepancies between the placement of the object
17550 -- or package instantiation with respect to state space and the
17551 -- encapsulating state.
17554 (Item_Id
=> Item_Id
,
17561 -- Constants without "variable input" are not considered part
17562 -- of the hidden state of a package (SPARK RM 7.1.1(2)). As a
17563 -- result such constants do not require a Part_Of indicator.
17565 if Ekind
(Item_Id
) = E_Constant
17566 and then not Has_Variable_Input
(Item_Id
)
17569 ("useless Part_Of indicator, constant & does not have "
17570 & "variable input", N
, Item_Id
);
17574 State_Id
:= Entity
(State
);
17576 -- The Part_Of indicator turns an object into a constituent of
17577 -- the encapsulating state.
17579 if Ekind_In
(Item_Id
, E_Constant
, E_Variable
) then
17580 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17581 Set_Encapsulating_State
(Item_Id
, State_Id
);
17583 -- Propagate the Part_Of indicator to the visible state space
17584 -- of the package instantiation.
17588 (Pack_Id
=> Item_Id
,
17589 State_Id
=> State_Id
,
17593 -- Add the pragma to the contract of the item. This aids with
17594 -- the detection of a missing but required Part_Of indicator.
17596 Add_Contract_Item
(N
, Item_Id
);
17600 ----------------------------------
17601 -- Partition_Elaboration_Policy --
17602 ----------------------------------
17604 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17606 when Pragma_Partition_Elaboration_Policy
=> declare
17607 subtype PEP_Range
is Name_Id
17608 range First_Partition_Elaboration_Policy_Name
17609 .. Last_Partition_Elaboration_Policy_Name
;
17610 PEP_Val
: PEP_Range
;
17615 Check_Arg_Count
(1);
17616 Check_No_Identifiers
;
17617 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17618 Check_Valid_Configuration_Pragma
;
17619 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17622 when Name_Concurrent
=>
17624 when Name_Sequential
=>
17628 if Partition_Elaboration_Policy
/= ' '
17629 and then Partition_Elaboration_Policy
/= PEP
17631 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17633 ("partition elaboration policy incompatible with policy#");
17635 -- Set new policy, but always preserve System_Location since we
17636 -- like the error message with the run time name.
17639 Partition_Elaboration_Policy
:= PEP
;
17641 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17642 Partition_Elaboration_Policy_Sloc
:= Loc
;
17651 -- pragma Passive [(PASSIVE_FORM)];
17653 -- PASSIVE_FORM ::= Semaphore | No
17655 when Pragma_Passive
=>
17658 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17659 Error_Pragma
("pragma% must be within task definition");
17662 if Arg_Count
/= 0 then
17663 Check_Arg_Count
(1);
17664 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17667 ----------------------------------
17668 -- Preelaborable_Initialization --
17669 ----------------------------------
17671 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17673 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17678 Check_Arg_Count
(1);
17679 Check_No_Identifiers
;
17680 Check_Arg_Is_Identifier
(Arg1
);
17681 Check_Arg_Is_Local_Name
(Arg1
);
17682 Check_First_Subtype
(Arg1
);
17683 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17685 -- The pragma may come from an aspect on a private declaration,
17686 -- even if the freeze point at which this is analyzed in the
17687 -- private part after the full view.
17689 if Has_Private_Declaration
(Ent
)
17690 and then From_Aspect_Specification
(N
)
17694 -- Check appropriate type argument
17696 elsif Is_Private_Type
(Ent
)
17697 or else Is_Protected_Type
(Ent
)
17698 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17700 -- AI05-0028: The pragma applies to all composite types. Note
17701 -- that we apply this binding interpretation to earlier versions
17702 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
17703 -- choice since there are other compilers that do the same.
17705 or else Is_Composite_Type
(Ent
)
17711 ("pragma % can only be applied to private, formal derived, "
17712 & "protected, or composite type", Arg1
);
17715 -- Give an error if the pragma is applied to a protected type that
17716 -- does not qualify (due to having entries, or due to components
17717 -- that do not qualify).
17719 if Is_Protected_Type
(Ent
)
17720 and then not Has_Preelaborable_Initialization
(Ent
)
17723 ("protected type & does not have preelaborable "
17724 & "initialization", Ent
);
17726 -- Otherwise mark the type as definitely having preelaborable
17730 Set_Known_To_Have_Preelab_Init
(Ent
);
17733 if Has_Pragma_Preelab_Init
(Ent
)
17734 and then Warn_On_Redundant_Constructs
17736 Error_Pragma
("?r?duplicate pragma%!");
17738 Set_Has_Pragma_Preelab_Init
(Ent
);
17742 --------------------
17743 -- Persistent_BSS --
17744 --------------------
17746 -- pragma Persistent_BSS [(object_NAME)];
17748 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17755 Check_At_Most_N_Arguments
(1);
17757 -- Case of application to specific object (one argument)
17759 if Arg_Count
= 1 then
17760 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17762 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17764 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17767 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17770 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17771 Decl
:= Parent
(Ent
);
17773 -- Check for duplication before inserting in list of
17774 -- representation items.
17776 Check_Duplicate_Pragma
(Ent
);
17778 if Rep_Item_Too_Late
(Ent
, N
) then
17782 if Present
(Expression
(Decl
)) then
17784 ("object for pragma% cannot have initialization", Arg1
);
17787 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17789 ("object type for pragma% is not potentially persistent",
17794 Make_Linker_Section_Pragma
17795 (Ent
, Sloc
(N
), ".persistent.bss");
17796 Insert_After
(N
, Prag
);
17799 -- Case of use as configuration pragma with no arguments
17802 Check_Valid_Configuration_Pragma
;
17803 Persistent_BSS_Mode
:= True;
17805 end Persistent_BSS
;
17811 -- pragma Polling (ON | OFF);
17813 when Pragma_Polling
=>
17815 Check_Arg_Count
(1);
17816 Check_No_Identifiers
;
17817 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17818 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17820 -----------------------------------
17821 -- Post/Post_Class/Postcondition --
17822 -----------------------------------
17824 -- pragma Post (Boolean_EXPRESSION);
17825 -- pragma Post_Class (Boolean_EXPRESSION);
17826 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
17827 -- [,[Message =>] String_EXPRESSION]);
17829 -- Characteristics:
17831 -- * Analysis - The annotation undergoes initial checks to verify
17832 -- the legal placement and context. Secondary checks preanalyze the
17835 -- Analyze_Pre_Post_Condition_In_Decl_Part
17837 -- * Expansion - The annotation is expanded during the expansion of
17838 -- the related subprogram [body] contract as performed in:
17840 -- Expand_Subprogram_Contract
17842 -- * Template - The annotation utilizes the generic template of the
17843 -- related subprogram [body] when it is:
17845 -- aspect on subprogram declaration
17846 -- aspect on stand alone subprogram body
17847 -- pragma on stand alone subprogram body
17849 -- The annotation must prepare its own template when it is:
17851 -- pragma on subprogram declaration
17853 -- * Globals - Capture of global references must occur after full
17856 -- * Instance - The annotation is instantiated automatically when
17857 -- the related generic subprogram [body] is instantiated except for
17858 -- the "pragma on subprogram declaration" case. In that scenario
17859 -- the annotation must instantiate itself.
17862 Pragma_Post_Class |
17863 Pragma_Postcondition
=>
17864 Analyze_Pre_Post_Condition
;
17866 --------------------------------
17867 -- Pre/Pre_Class/Precondition --
17868 --------------------------------
17870 -- pragma Pre (Boolean_EXPRESSION);
17871 -- pragma Pre_Class (Boolean_EXPRESSION);
17872 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
17873 -- [,[Message =>] String_EXPRESSION]);
17875 -- Characteristics:
17877 -- * Analysis - The annotation undergoes initial checks to verify
17878 -- the legal placement and context. Secondary checks preanalyze the
17881 -- Analyze_Pre_Post_Condition_In_Decl_Part
17883 -- * Expansion - The annotation is expanded during the expansion of
17884 -- the related subprogram [body] contract as performed in:
17886 -- Expand_Subprogram_Contract
17888 -- * Template - The annotation utilizes the generic template of the
17889 -- related subprogram [body] when it is:
17891 -- aspect on subprogram declaration
17892 -- aspect on stand alone subprogram body
17893 -- pragma on stand alone subprogram body
17895 -- The annotation must prepare its own template when it is:
17897 -- pragma on subprogram declaration
17899 -- * Globals - Capture of global references must occur after full
17902 -- * Instance - The annotation is instantiated automatically when
17903 -- the related generic subprogram [body] is instantiated except for
17904 -- the "pragma on subprogram declaration" case. In that scenario
17905 -- the annotation must instantiate itself.
17909 Pragma_Precondition
=>
17910 Analyze_Pre_Post_Condition
;
17916 -- pragma Predicate
17917 -- ([Entity =>] type_LOCAL_NAME,
17918 -- [Check =>] boolean_EXPRESSION);
17920 when Pragma_Predicate
=> Predicate
: declare
17927 Check_Arg_Count
(2);
17928 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17929 Check_Optional_Identifier
(Arg2
, Name_Check
);
17931 Check_Arg_Is_Local_Name
(Arg1
);
17933 Type_Id
:= Get_Pragma_Arg
(Arg1
);
17934 Find_Type
(Type_Id
);
17935 Typ
:= Entity
(Type_Id
);
17937 if Typ
= Any_Type
then
17941 -- The remaining processing is simply to link the pragma on to
17942 -- the rep item chain, for processing when the type is frozen.
17943 -- This is accomplished by a call to Rep_Item_Too_Late. We also
17944 -- mark the type as having predicates.
17946 Set_Has_Predicates
(Typ
);
17947 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
17954 -- pragma Preelaborate [(library_unit_NAME)];
17956 -- Set the flag Is_Preelaborated of program unit name entity
17958 when Pragma_Preelaborate
=> Preelaborate
: declare
17959 Pa
: constant Node_Id
:= Parent
(N
);
17960 Pk
: constant Node_Kind
:= Nkind
(Pa
);
17964 Check_Ada_83_Warning
;
17965 Check_Valid_Library_Unit_Pragma
;
17967 if Nkind
(N
) = N_Null_Statement
then
17971 Ent
:= Find_Lib_Unit_Name
;
17972 Check_Duplicate_Pragma
(Ent
);
17974 -- This filters out pragmas inside generic parents that show up
17975 -- inside instantiations. Pragmas that come from aspects in the
17976 -- unit are not ignored.
17978 if Present
(Ent
) then
17979 if Pk
= N_Package_Specification
17980 and then Present
(Generic_Parent
(Pa
))
17981 and then not From_Aspect_Specification
(N
)
17986 if not Debug_Flag_U
then
17987 Set_Is_Preelaborated
(Ent
);
17988 Set_Suppress_Elaboration_Warnings
(Ent
);
17994 -------------------------------
17995 -- Prefix_Exception_Messages --
17996 -------------------------------
17998 -- pragma Prefix_Exception_Messages;
18000 when Pragma_Prefix_Exception_Messages
=>
18002 Check_Valid_Configuration_Pragma
;
18003 Check_Arg_Count
(0);
18004 Prefix_Exception_Messages
:= True;
18010 -- pragma Priority (EXPRESSION);
18012 when Pragma_Priority
=> Priority
: declare
18013 P
: constant Node_Id
:= Parent
(N
);
18018 Check_No_Identifiers
;
18019 Check_Arg_Count
(1);
18023 if Nkind
(P
) = N_Subprogram_Body
then
18024 Check_In_Main_Program
;
18026 Ent
:= Defining_Unit_Name
(Specification
(P
));
18028 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18029 Ent
:= Defining_Identifier
(Ent
);
18032 Arg
:= Get_Pragma_Arg
(Arg1
);
18033 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18037 if not Is_OK_Static_Expression
(Arg
) then
18038 Flag_Non_Static_Expr
18039 ("main subprogram priority is not static!", Arg
);
18042 -- If constraint error, then we already signalled an error
18044 elsif Raises_Constraint_Error
(Arg
) then
18047 -- Otherwise check in range except if Relaxed_RM_Semantics
18048 -- where we ignore the value if out of range.
18052 Val
: constant Uint
:= Expr_Value
(Arg
);
18054 if not Relaxed_RM_Semantics
18057 or else Val
> Expr_Value
(Expression
18058 (Parent
(RTE
(RE_Max_Priority
)))))
18061 ("main subprogram priority is out of range", Arg1
);
18064 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18069 -- Load an arbitrary entity from System.Tasking.Stages or
18070 -- System.Tasking.Restricted.Stages (depending on the
18071 -- supported profile) to make sure that one of these packages
18072 -- is implicitly with'ed, since we need to have the tasking
18073 -- run time active for the pragma Priority to have any effect.
18074 -- Previously we with'ed the package System.Tasking, but this
18075 -- package does not trigger the required initialization of the
18076 -- run-time library.
18079 Discard
: Entity_Id
;
18080 pragma Warnings
(Off
, Discard
);
18082 if Restricted_Profile
then
18083 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18085 Discard
:= RTE
(RE_Activate_Tasks
);
18089 -- Task or Protected, must be of type Integer
18091 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18092 Arg
:= Get_Pragma_Arg
(Arg1
);
18093 Ent
:= Defining_Identifier
(Parent
(P
));
18095 -- The expression must be analyzed in the special manner
18096 -- described in "Handling of Default and Per-Object
18097 -- Expressions" in sem.ads.
18099 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18101 if not Is_OK_Static_Expression
(Arg
) then
18102 Check_Restriction
(Static_Priorities
, Arg
);
18105 -- Anything else is incorrect
18111 -- Check duplicate pragma before we chain the pragma in the Rep
18112 -- Item chain of Ent.
18114 Check_Duplicate_Pragma
(Ent
);
18115 Record_Rep_Item
(Ent
, N
);
18118 -----------------------------------
18119 -- Priority_Specific_Dispatching --
18120 -----------------------------------
18122 -- pragma Priority_Specific_Dispatching (
18123 -- policy_IDENTIFIER,
18124 -- first_priority_EXPRESSION,
18125 -- last_priority_EXPRESSION);
18127 when Pragma_Priority_Specific_Dispatching
=>
18128 Priority_Specific_Dispatching
: declare
18129 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18130 -- This is the entity System.Any_Priority;
18133 Lower_Bound
: Node_Id
;
18134 Upper_Bound
: Node_Id
;
18140 Check_Arg_Count
(3);
18141 Check_No_Identifiers
;
18142 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18143 Check_Valid_Configuration_Pragma
;
18144 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18145 DP
:= Fold_Upper
(Name_Buffer
(1));
18147 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18148 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
18149 Lower_Val
:= Expr_Value
(Lower_Bound
);
18151 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18152 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
18153 Upper_Val
:= Expr_Value
(Upper_Bound
);
18155 -- It is not allowed to use Task_Dispatching_Policy and
18156 -- Priority_Specific_Dispatching in the same partition.
18158 if Task_Dispatching_Policy
/= ' ' then
18159 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18161 ("pragma% incompatible with Task_Dispatching_Policy#");
18163 -- Check lower bound in range
18165 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18167 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18170 ("first_priority is out of range", Arg2
);
18172 -- Check upper bound in range
18174 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18176 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18179 ("last_priority is out of range", Arg3
);
18181 -- Check that the priority range is valid
18183 elsif Lower_Val
> Upper_Val
then
18185 ("last_priority_expression must be greater than or equal to "
18186 & "first_priority_expression");
18188 -- Store the new policy, but always preserve System_Location since
18189 -- we like the error message with the run-time name.
18192 -- Check overlapping in the priority ranges specified in other
18193 -- Priority_Specific_Dispatching pragmas within the same
18194 -- partition. We can only check those we know about.
18197 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18199 if Specific_Dispatching
.Table
(J
).First_Priority
in
18200 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18201 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18202 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18205 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18207 ("priority range overlaps with "
18208 & "Priority_Specific_Dispatching#");
18212 -- The use of Priority_Specific_Dispatching is incompatible
18213 -- with Task_Dispatching_Policy.
18215 if Task_Dispatching_Policy
/= ' ' then
18216 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18218 ("Priority_Specific_Dispatching incompatible "
18219 & "with Task_Dispatching_Policy#");
18222 -- The use of Priority_Specific_Dispatching forces ceiling
18225 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18226 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18228 ("Priority_Specific_Dispatching incompatible "
18229 & "with Locking_Policy#");
18231 -- Set the Ceiling_Locking policy, but preserve System_Location
18232 -- since we like the error message with the run time name.
18235 Locking_Policy
:= 'C';
18237 if Locking_Policy_Sloc
/= System_Location
then
18238 Locking_Policy_Sloc
:= Loc
;
18242 -- Add entry in the table
18244 Specific_Dispatching
.Append
18245 ((Dispatching_Policy
=> DP
,
18246 First_Priority
=> UI_To_Int
(Lower_Val
),
18247 Last_Priority
=> UI_To_Int
(Upper_Val
),
18248 Pragma_Loc
=> Loc
));
18250 end Priority_Specific_Dispatching
;
18256 -- pragma Profile (profile_IDENTIFIER);
18258 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18260 when Pragma_Profile
=>
18262 Check_Arg_Count
(1);
18263 Check_Valid_Configuration_Pragma
;
18264 Check_No_Identifiers
;
18267 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18270 if Chars
(Argx
) = Name_Ravenscar
then
18271 Set_Ravenscar_Profile
(N
);
18273 elsif Chars
(Argx
) = Name_Restricted
then
18274 Set_Profile_Restrictions
18276 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18278 elsif Chars
(Argx
) = Name_Rational
then
18279 Set_Rational_Profile
;
18281 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18282 Set_Profile_Restrictions
18283 (No_Implementation_Extensions
,
18284 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18287 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18291 ----------------------
18292 -- Profile_Warnings --
18293 ----------------------
18295 -- pragma Profile_Warnings (profile_IDENTIFIER);
18297 -- profile_IDENTIFIER => Restricted | Ravenscar
18299 when Pragma_Profile_Warnings
=>
18301 Check_Arg_Count
(1);
18302 Check_Valid_Configuration_Pragma
;
18303 Check_No_Identifiers
;
18306 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18309 if Chars
(Argx
) = Name_Ravenscar
then
18310 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18312 elsif Chars
(Argx
) = Name_Restricted
then
18313 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18315 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18316 Set_Profile_Restrictions
18317 (No_Implementation_Extensions
, N
, Warn
=> True);
18320 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18324 --------------------------
18325 -- Propagate_Exceptions --
18326 --------------------------
18328 -- pragma Propagate_Exceptions;
18330 -- Note: this pragma is obsolete and has no effect
18332 when Pragma_Propagate_Exceptions
=>
18334 Check_Arg_Count
(0);
18336 if Warn_On_Obsolescent_Feature
then
18338 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18339 "and has no effect?j?", N
);
18342 -----------------------------
18343 -- Provide_Shift_Operators --
18344 -----------------------------
18346 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18348 when Pragma_Provide_Shift_Operators
=>
18349 Provide_Shift_Operators
: declare
18352 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18353 -- Insert declaration and pragma Instrinsic for named shift op
18355 ----------------------------
18356 -- Declare_Shift_Operator --
18357 ----------------------------
18359 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18365 Make_Subprogram_Declaration
(Loc
,
18366 Make_Function_Specification
(Loc
,
18367 Defining_Unit_Name
=>
18368 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18370 Result_Definition
=>
18371 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18373 Parameter_Specifications
=> New_List
(
18374 Make_Parameter_Specification
(Loc
,
18375 Defining_Identifier
=>
18376 Make_Defining_Identifier
(Loc
, Name_Value
),
18378 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18380 Make_Parameter_Specification
(Loc
,
18381 Defining_Identifier
=>
18382 Make_Defining_Identifier
(Loc
, Name_Amount
),
18384 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18388 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18389 Pragma_Argument_Associations
=> New_List
(
18390 Make_Pragma_Argument_Association
(Loc
,
18391 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18392 Make_Pragma_Argument_Association
(Loc
,
18393 Expression
=> Make_Identifier
(Loc
, Nam
))));
18395 Insert_After
(N
, Import
);
18396 Insert_After
(N
, Func
);
18397 end Declare_Shift_Operator
;
18399 -- Start of processing for Provide_Shift_Operators
18403 Check_Arg_Count
(1);
18404 Check_Arg_Is_Local_Name
(Arg1
);
18406 Arg1
:= Get_Pragma_Arg
(Arg1
);
18408 -- We must have an entity name
18410 if not Is_Entity_Name
(Arg1
) then
18412 ("pragma % must apply to integer first subtype", Arg1
);
18415 -- If no Entity, means there was a prior error so ignore
18417 if Present
(Entity
(Arg1
)) then
18418 Ent
:= Entity
(Arg1
);
18420 -- Apply error checks
18422 if not Is_First_Subtype
(Ent
) then
18424 ("cannot apply pragma %",
18425 "\& is not a first subtype",
18428 elsif not Is_Integer_Type
(Ent
) then
18430 ("cannot apply pragma %",
18431 "\& is not an integer type",
18434 elsif Has_Shift_Operator
(Ent
) then
18436 ("cannot apply pragma %",
18437 "\& already has declared shift operators",
18440 elsif Is_Frozen
(Ent
) then
18442 ("pragma % appears too late",
18443 "\& is already frozen",
18447 -- Now declare the operators. We do this during analysis rather
18448 -- than expansion, since we want the operators available if we
18449 -- are operating in -gnatc or ASIS mode.
18451 Declare_Shift_Operator
(Name_Rotate_Left
);
18452 Declare_Shift_Operator
(Name_Rotate_Right
);
18453 Declare_Shift_Operator
(Name_Shift_Left
);
18454 Declare_Shift_Operator
(Name_Shift_Right
);
18455 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18457 end Provide_Shift_Operators
;
18463 -- pragma Psect_Object (
18464 -- [Internal =>] LOCAL_NAME,
18465 -- [, [External =>] EXTERNAL_SYMBOL]
18466 -- [, [Size =>] EXTERNAL_SYMBOL]);
18468 when Pragma_Psect_Object | Pragma_Common_Object
=>
18469 Psect_Object
: declare
18470 Args
: Args_List
(1 .. 3);
18471 Names
: constant Name_List
(1 .. 3) := (
18476 Internal
: Node_Id
renames Args
(1);
18477 External
: Node_Id
renames Args
(2);
18478 Size
: Node_Id
renames Args
(3);
18480 Def_Id
: Entity_Id
;
18482 procedure Check_Arg
(Arg
: Node_Id
);
18483 -- Checks that argument is either a string literal or an
18484 -- identifier, and posts error message if not.
18490 procedure Check_Arg
(Arg
: Node_Id
) is
18492 if not Nkind_In
(Original_Node
(Arg
),
18497 ("inappropriate argument for pragma %", Arg
);
18501 -- Start of processing for Common_Object/Psect_Object
18505 Gather_Associations
(Names
, Args
);
18506 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18508 Def_Id
:= Entity
(Internal
);
18510 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18512 ("pragma% must designate an object", Internal
);
18515 Check_Arg
(Internal
);
18517 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18519 ("cannot use pragma% for imported/exported object",
18523 if Is_Concurrent_Type
(Etype
(Internal
)) then
18525 ("cannot specify pragma % for task/protected object",
18529 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18531 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18533 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18536 if Ekind
(Def_Id
) = E_Constant
then
18538 ("cannot specify pragma % for a constant", Internal
);
18541 if Is_Record_Type
(Etype
(Internal
)) then
18547 Ent
:= First_Entity
(Etype
(Internal
));
18548 while Present
(Ent
) loop
18549 Decl
:= Declaration_Node
(Ent
);
18551 if Ekind
(Ent
) = E_Component
18552 and then Nkind
(Decl
) = N_Component_Declaration
18553 and then Present
(Expression
(Decl
))
18554 and then Warn_On_Export_Import
18557 ("?x?object for pragma % has defaults", Internal
);
18567 if Present
(Size
) then
18571 if Present
(External
) then
18572 Check_Arg_Is_External_Name
(External
);
18575 -- If all error tests pass, link pragma on to the rep item chain
18577 Record_Rep_Item
(Def_Id
, N
);
18584 -- pragma Pure [(library_unit_NAME)];
18586 when Pragma_Pure
=> Pure
: declare
18590 Check_Ada_83_Warning
;
18591 Check_Valid_Library_Unit_Pragma
;
18593 if Nkind
(N
) = N_Null_Statement
then
18597 Ent
:= Find_Lib_Unit_Name
;
18599 Set_Has_Pragma_Pure
(Ent
);
18600 Set_Suppress_Elaboration_Warnings
(Ent
);
18603 -------------------
18604 -- Pure_Function --
18605 -------------------
18607 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18609 when Pragma_Pure_Function
=> Pure_Function
: declare
18612 Def_Id
: Entity_Id
;
18613 Effective
: Boolean := False;
18617 Check_Arg_Count
(1);
18618 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18619 Check_Arg_Is_Local_Name
(Arg1
);
18620 E_Id
:= Get_Pragma_Arg
(Arg1
);
18622 if Error_Posted
(E_Id
) then
18626 -- Loop through homonyms (overloadings) of referenced entity
18628 E
:= Entity
(E_Id
);
18630 if Present
(E
) then
18632 Def_Id
:= Get_Base_Subprogram
(E
);
18634 if not Ekind_In
(Def_Id
, E_Function
,
18635 E_Generic_Function
,
18639 ("pragma% requires a function name", Arg1
);
18642 Set_Is_Pure
(Def_Id
);
18644 if not Has_Pragma_Pure_Function
(Def_Id
) then
18645 Set_Has_Pragma_Pure_Function
(Def_Id
);
18649 exit when From_Aspect_Specification
(N
);
18651 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18655 and then Warn_On_Redundant_Constructs
18658 ("pragma Pure_Function on& is redundant?r?",
18664 --------------------
18665 -- Queuing_Policy --
18666 --------------------
18668 -- pragma Queuing_Policy (policy_IDENTIFIER);
18670 when Pragma_Queuing_Policy
=> declare
18674 Check_Ada_83_Warning
;
18675 Check_Arg_Count
(1);
18676 Check_No_Identifiers
;
18677 Check_Arg_Is_Queuing_Policy
(Arg1
);
18678 Check_Valid_Configuration_Pragma
;
18679 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18680 QP
:= Fold_Upper
(Name_Buffer
(1));
18682 if Queuing_Policy
/= ' '
18683 and then Queuing_Policy
/= QP
18685 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18686 Error_Pragma
("queuing policy incompatible with policy#");
18688 -- Set new policy, but always preserve System_Location since we
18689 -- like the error message with the run time name.
18692 Queuing_Policy
:= QP
;
18694 if Queuing_Policy_Sloc
/= System_Location
then
18695 Queuing_Policy_Sloc
:= Loc
;
18704 -- pragma Rational, for compatibility with foreign compiler
18706 when Pragma_Rational
=>
18707 Set_Rational_Profile
;
18709 ------------------------------------
18710 -- Refined_Depends/Refined_Global --
18711 ------------------------------------
18713 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18715 -- DEPENDENCY_RELATION ::=
18717 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18719 -- DEPENDENCY_CLAUSE ::=
18720 -- OUTPUT_LIST =>[+] INPUT_LIST
18721 -- | NULL_DEPENDENCY_CLAUSE
18723 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18725 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18727 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18729 -- OUTPUT ::= NAME | FUNCTION_RESULT
18732 -- where FUNCTION_RESULT is a function Result attribute_reference
18734 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18736 -- GLOBAL_SPECIFICATION ::=
18739 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18741 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18743 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
18744 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
18745 -- GLOBAL_ITEM ::= NAME
18747 -- Characteristics:
18749 -- * Analysis - The annotation undergoes initial checks to verify
18750 -- the legal placement and context. Secondary checks fully analyze
18751 -- the dependency clauses/global list in:
18753 -- Analyze_Refined_Depends_In_Decl_Part
18754 -- Analyze_Refined_Global_In_Decl_Part
18756 -- * Expansion - None.
18758 -- * Template - The annotation utilizes the generic template of the
18759 -- related subprogram body.
18761 -- * Globals - Capture of global references must occur after full
18764 -- * Instance - The annotation is instantiated automatically when
18765 -- the related generic subprogram body is instantiated.
18767 when Pragma_Refined_Depends |
18768 Pragma_Refined_Global
=> Refined_Depends_Global
:
18770 Body_Id
: Entity_Id
;
18772 Spec_Id
: Entity_Id
;
18775 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
18777 -- Chain the pragma on the contract for further processing by
18778 -- Analyze_Refined_[Depends|Global]_In_Decl_Part.
18781 Add_Contract_Item
(N
, Body_Id
);
18783 end Refined_Depends_Global
;
18789 -- pragma Refined_Post (boolean_EXPRESSION);
18791 -- Characteristics:
18793 -- * Analysis - The annotation is fully analyzed immediately upon
18794 -- elaboration as it cannot forward reference entities.
18796 -- * Expansion - The annotation is expanded during the expansion of
18797 -- the related subprogram body contract as performed in:
18799 -- Expand_Subprogram_Contract
18801 -- * Template - The annotation utilizes the generic template of the
18802 -- related subprogram body.
18804 -- * Globals - Capture of global references must occur after full
18807 -- * Instance - The annotation is instantiated automatically when
18808 -- the related generic subprogram body is instantiated.
18810 when Pragma_Refined_Post
=> Refined_Post
: declare
18811 Body_Id
: Entity_Id
;
18813 Spec_Id
: Entity_Id
;
18816 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
18818 -- Fully analyze the pragma when it appears inside a subprogram
18819 -- body because it cannot benefit from forward references.
18822 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
18824 -- Currently it is not possible to inline pre/postconditions on
18825 -- a subprogram subject to pragma Inline_Always.
18827 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
18829 -- Chain the pragma on the contract for completeness
18831 Add_Contract_Item
(N
, Body_Id
);
18835 -------------------
18836 -- Refined_State --
18837 -------------------
18839 -- pragma Refined_State (REFINEMENT_LIST);
18841 -- REFINEMENT_LIST ::=
18842 -- REFINEMENT_CLAUSE
18843 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
18845 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
18847 -- CONSTITUENT_LIST ::=
18850 -- | (CONSTITUENT {, CONSTITUENT})
18852 -- CONSTITUENT ::= object_NAME | state_NAME
18854 -- Characteristics:
18856 -- * Analysis - The annotation undergoes initial checks to verify
18857 -- the legal placement and context. Secondary checks preanalyze the
18858 -- refinement clauses in:
18860 -- Analyze_Refined_State_In_Decl_Part
18862 -- * Expansion - None.
18864 -- * Template - The annotation utilizes the template of the related
18867 -- * Globals - Capture of global references must occur after full
18870 -- * Instance - The annotation is instantiated automatically when
18871 -- the related generic package body is instantiated.
18873 when Pragma_Refined_State
=> Refined_State
: declare
18874 Pack_Decl
: Node_Id
;
18875 Spec_Id
: Entity_Id
;
18879 Check_No_Identifiers
;
18880 Check_Arg_Count
(1);
18882 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18884 -- Ensure the proper placement of the pragma. Refined states must
18885 -- be associated with a package body.
18887 if Nkind
(Pack_Decl
) = N_Package_Body
then
18890 -- Otherwise the pragma is associated with an illegal construct
18897 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
18899 -- State refinement is allowed only when the corresponding package
18900 -- declaration has non-null pragma Abstract_State. Refinement not
18901 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
18903 if SPARK_Mode
/= Off
18905 (No
(Abstract_States
(Spec_Id
))
18906 or else Has_Null_Abstract_State
(Spec_Id
))
18909 ("useless refinement, package & does not define abstract "
18910 & "states", N
, Spec_Id
);
18914 -- Chain the pragma on the contract for further processing by
18915 -- Analyze_Refined_State_In_Decl_Part.
18917 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
18920 -----------------------
18921 -- Relative_Deadline --
18922 -----------------------
18924 -- pragma Relative_Deadline (time_span_EXPRESSION);
18926 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
18927 P
: constant Node_Id
:= Parent
(N
);
18932 Check_No_Identifiers
;
18933 Check_Arg_Count
(1);
18935 Arg
:= Get_Pragma_Arg
(Arg1
);
18937 -- The expression must be analyzed in the special manner described
18938 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
18940 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
18944 if Nkind
(P
) = N_Subprogram_Body
then
18945 Check_In_Main_Program
;
18947 -- Only Task and subprogram cases allowed
18949 elsif Nkind
(P
) /= N_Task_Definition
then
18953 -- Check duplicate pragma before we set the corresponding flag
18955 if Has_Relative_Deadline_Pragma
(P
) then
18956 Error_Pragma
("duplicate pragma% not allowed");
18959 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
18960 -- Relative_Deadline pragma node cannot be inserted in the Rep
18961 -- Item chain of Ent since it is rewritten by the expander as a
18962 -- procedure call statement that will break the chain.
18964 Set_Has_Relative_Deadline_Pragma
(P
, True);
18965 end Relative_Deadline
;
18967 ------------------------
18968 -- Remote_Access_Type --
18969 ------------------------
18971 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
18973 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
18978 Check_Arg_Count
(1);
18979 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18980 Check_Arg_Is_Local_Name
(Arg1
);
18982 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
18984 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
18985 and then Ekind
(E
) = E_General_Access_Type
18986 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
18987 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
18989 and then Is_Valid_Remote_Object_Type
18990 (Root_Type
(Directly_Designated_Type
(E
)))
18992 Set_Is_Remote_Types
(E
);
18996 ("pragma% applies only to formal access to classwide types",
18999 end Remote_Access_Type
;
19001 ---------------------------
19002 -- Remote_Call_Interface --
19003 ---------------------------
19005 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19007 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19008 Cunit_Node
: Node_Id
;
19009 Cunit_Ent
: Entity_Id
;
19013 Check_Ada_83_Warning
;
19014 Check_Valid_Library_Unit_Pragma
;
19016 if Nkind
(N
) = N_Null_Statement
then
19020 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19021 K
:= Nkind
(Unit
(Cunit_Node
));
19022 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19024 if K
= N_Package_Declaration
19025 or else K
= N_Generic_Package_Declaration
19026 or else K
= N_Subprogram_Declaration
19027 or else K
= N_Generic_Subprogram_Declaration
19028 or else (K
= N_Subprogram_Body
19029 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19034 "pragma% must apply to package or subprogram declaration");
19037 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19038 end Remote_Call_Interface
;
19044 -- pragma Remote_Types [(library_unit_NAME)];
19046 when Pragma_Remote_Types
=> Remote_Types
: declare
19047 Cunit_Node
: Node_Id
;
19048 Cunit_Ent
: Entity_Id
;
19051 Check_Ada_83_Warning
;
19052 Check_Valid_Library_Unit_Pragma
;
19054 if Nkind
(N
) = N_Null_Statement
then
19058 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19059 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19061 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19062 N_Generic_Package_Declaration
)
19065 ("pragma% can only apply to a package declaration");
19068 Set_Is_Remote_Types
(Cunit_Ent
);
19075 -- pragma Ravenscar;
19077 when Pragma_Ravenscar
=>
19079 Check_Arg_Count
(0);
19080 Check_Valid_Configuration_Pragma
;
19081 Set_Ravenscar_Profile
(N
);
19083 if Warn_On_Obsolescent_Feature
then
19085 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19087 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19090 -------------------------
19091 -- Restricted_Run_Time --
19092 -------------------------
19094 -- pragma Restricted_Run_Time;
19096 when Pragma_Restricted_Run_Time
=>
19098 Check_Arg_Count
(0);
19099 Check_Valid_Configuration_Pragma
;
19100 Set_Profile_Restrictions
19101 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19103 if Warn_On_Obsolescent_Feature
then
19105 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19108 ("|use pragma Profile (Restricted) instead?j?", N
);
19115 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19118 -- restriction_IDENTIFIER
19119 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19121 when Pragma_Restrictions
=>
19122 Process_Restrictions_Or_Restriction_Warnings
19123 (Warn
=> Treat_Restrictions_As_Warnings
);
19125 --------------------------
19126 -- Restriction_Warnings --
19127 --------------------------
19129 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19132 -- restriction_IDENTIFIER
19133 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19135 when Pragma_Restriction_Warnings
=>
19137 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19143 -- pragma Reviewable;
19145 when Pragma_Reviewable
=>
19146 Check_Ada_83_Warning
;
19147 Check_Arg_Count
(0);
19149 -- Call dummy debugging function rv. This is done to assist front
19150 -- end debugging. By placing a Reviewable pragma in the source
19151 -- program, a breakpoint on rv catches this place in the source,
19152 -- allowing convenient stepping to the point of interest.
19156 --------------------------
19157 -- Short_Circuit_And_Or --
19158 --------------------------
19160 -- pragma Short_Circuit_And_Or;
19162 when Pragma_Short_Circuit_And_Or
=>
19164 Check_Arg_Count
(0);
19165 Check_Valid_Configuration_Pragma
;
19166 Short_Circuit_And_Or
:= True;
19168 -------------------
19169 -- Share_Generic --
19170 -------------------
19172 -- pragma Share_Generic (GNAME {, GNAME});
19174 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19176 when Pragma_Share_Generic
=>
19178 Process_Generic_List
;
19184 -- pragma Shared (LOCAL_NAME);
19186 when Pragma_Shared
=>
19188 Process_Atomic_Independent_Shared_Volatile
;
19190 --------------------
19191 -- Shared_Passive --
19192 --------------------
19194 -- pragma Shared_Passive [(library_unit_NAME)];
19196 -- Set the flag Is_Shared_Passive of program unit name entity
19198 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19199 Cunit_Node
: Node_Id
;
19200 Cunit_Ent
: Entity_Id
;
19203 Check_Ada_83_Warning
;
19204 Check_Valid_Library_Unit_Pragma
;
19206 if Nkind
(N
) = N_Null_Statement
then
19210 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19211 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19213 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19214 N_Generic_Package_Declaration
)
19217 ("pragma% can only apply to a package declaration");
19220 Set_Is_Shared_Passive
(Cunit_Ent
);
19221 end Shared_Passive
;
19223 -----------------------
19224 -- Short_Descriptors --
19225 -----------------------
19227 -- pragma Short_Descriptors;
19229 -- Recognize and validate, but otherwise ignore
19231 when Pragma_Short_Descriptors
=>
19233 Check_Arg_Count
(0);
19234 Check_Valid_Configuration_Pragma
;
19236 ------------------------------
19237 -- Simple_Storage_Pool_Type --
19238 ------------------------------
19240 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19242 when Pragma_Simple_Storage_Pool_Type
=>
19243 Simple_Storage_Pool_Type
: declare
19249 Check_Arg_Count
(1);
19250 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19252 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19253 Find_Type
(Type_Id
);
19254 Typ
:= Entity
(Type_Id
);
19256 if Typ
= Any_Type
then
19260 -- We require the pragma to apply to a type declared in a package
19261 -- declaration, but not (immediately) within a package body.
19263 if Ekind
(Current_Scope
) /= E_Package
19264 or else In_Package_Body
(Current_Scope
)
19267 ("pragma% can only apply to type declared immediately "
19268 & "within a package declaration");
19271 -- A simple storage pool type must be an immutably limited record
19272 -- or private type. If the pragma is given for a private type,
19273 -- the full type is similarly restricted (which is checked later
19274 -- in Freeze_Entity).
19276 if Is_Record_Type
(Typ
)
19277 and then not Is_Limited_View
(Typ
)
19280 ("pragma% can only apply to explicitly limited record type");
19282 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19284 ("pragma% can only apply to a private type that is limited");
19286 elsif not Is_Record_Type
(Typ
)
19287 and then not Is_Private_Type
(Typ
)
19290 ("pragma% can only apply to limited record or private type");
19293 Record_Rep_Item
(Typ
, N
);
19294 end Simple_Storage_Pool_Type
;
19296 ----------------------
19297 -- Source_File_Name --
19298 ----------------------
19300 -- There are five forms for this pragma:
19302 -- pragma Source_File_Name (
19303 -- [UNIT_NAME =>] unit_NAME,
19304 -- BODY_FILE_NAME => STRING_LITERAL
19305 -- [, [INDEX =>] INTEGER_LITERAL]);
19307 -- pragma Source_File_Name (
19308 -- [UNIT_NAME =>] unit_NAME,
19309 -- SPEC_FILE_NAME => STRING_LITERAL
19310 -- [, [INDEX =>] INTEGER_LITERAL]);
19312 -- pragma Source_File_Name (
19313 -- BODY_FILE_NAME => STRING_LITERAL
19314 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19315 -- [, CASING => CASING_SPEC]);
19317 -- pragma Source_File_Name (
19318 -- SPEC_FILE_NAME => STRING_LITERAL
19319 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19320 -- [, CASING => CASING_SPEC]);
19322 -- pragma Source_File_Name (
19323 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19324 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19325 -- [, CASING => CASING_SPEC]);
19327 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19329 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19330 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19331 -- only be used when no project file is used, while SFNP can only be
19332 -- used when a project file is used.
19334 -- No processing here. Processing was completed during parsing, since
19335 -- we need to have file names set as early as possible. Units are
19336 -- loaded well before semantic processing starts.
19338 -- The only processing we defer to this point is the check for
19339 -- correct placement.
19341 when Pragma_Source_File_Name
=>
19343 Check_Valid_Configuration_Pragma
;
19345 ------------------------------
19346 -- Source_File_Name_Project --
19347 ------------------------------
19349 -- See Source_File_Name for syntax
19351 -- No processing here. Processing was completed during parsing, since
19352 -- we need to have file names set as early as possible. Units are
19353 -- loaded well before semantic processing starts.
19355 -- The only processing we defer to this point is the check for
19356 -- correct placement.
19358 when Pragma_Source_File_Name_Project
=>
19360 Check_Valid_Configuration_Pragma
;
19362 -- Check that a pragma Source_File_Name_Project is used only in a
19363 -- configuration pragmas file.
19365 -- Pragmas Source_File_Name_Project should only be generated by
19366 -- the Project Manager in configuration pragmas files.
19368 -- This is really an ugly test. It seems to depend on some
19369 -- accidental and undocumented property. At the very least it
19370 -- needs to be documented, but it would be better to have a
19371 -- clean way of testing if we are in a configuration file???
19373 if Present
(Parent
(N
)) then
19375 ("pragma% can only appear in a configuration pragmas file");
19378 ----------------------
19379 -- Source_Reference --
19380 ----------------------
19382 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19384 -- Nothing to do, all processing completed in Par.Prag, since we need
19385 -- the information for possible parser messages that are output.
19387 when Pragma_Source_Reference
=>
19394 -- pragma SPARK_Mode [(On | Off)];
19396 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19397 Mode_Id
: SPARK_Mode_Type
;
19399 procedure Check_Pragma_Conformance
19400 (Context_Pragma
: Node_Id
;
19401 Entity_Pragma
: Node_Id
;
19402 Entity
: Entity_Id
);
19403 -- If Context_Pragma is not Empty, verify that the new pragma N
19404 -- is compatible with the pragma Context_Pragma that was inherited
19405 -- from the context:
19406 -- . if Context_Pragma is ON, then the new mode can be anything
19407 -- . if Context_Pragma is OFF, then the only allowed new mode is
19410 -- If Entity is not Empty, verify that the new pragma N is
19411 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19412 -- for Entity (which may be Empty):
19413 -- . if Entity_Pragma is ON, then the new mode can be anything
19414 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19416 -- . if Entity_Pragma is Empty, we always issue an error, as this
19417 -- corresponds to a case where a previous section of Entity
19418 -- had no SPARK_Mode set.
19420 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19421 -- Verify that pragma is applied to library-level entity E
19423 procedure Set_SPARK_Flags
;
19424 -- Sets SPARK_Mode from Mode_Id and SPARK_Mode_Pragma from N,
19425 -- and ensures that Dynamic_Elaboration_Checks are off if the
19426 -- call sets SPARK_Mode On.
19428 ------------------------------
19429 -- Check_Pragma_Conformance --
19430 ------------------------------
19432 procedure Check_Pragma_Conformance
19433 (Context_Pragma
: Node_Id
;
19434 Entity_Pragma
: Node_Id
;
19435 Entity
: Entity_Id
)
19437 Arg
: Node_Id
:= Arg1
;
19440 -- The current pragma may appear without an argument. If this
19441 -- is the case, associate all error messages with the pragma
19448 -- The mode of the current pragma is compared against that of
19449 -- an enclosing context.
19451 if Present
(Context_Pragma
) then
19452 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19454 -- Issue an error if the new mode is less restrictive than
19455 -- that of the context.
19457 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19458 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19461 ("cannot change SPARK_Mode from Off to On", Arg
);
19462 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19463 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg
);
19468 -- The mode of the current pragma is compared against that of
19469 -- an initial package/subprogram declaration.
19471 if Present
(Entity
) then
19473 -- Both the initial declaration and the completion carry
19474 -- SPARK_Mode pragmas.
19476 if Present
(Entity_Pragma
) then
19477 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
19479 -- Issue an error if the new mode is less restrictive
19480 -- than that of the initial declaration.
19482 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19483 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19485 Error_Msg_N
("incorrect use of SPARK_Mode", Arg
);
19486 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19488 ("\value Off was set for SPARK_Mode on&#",
19493 -- Otherwise the initial declaration lacks a SPARK_Mode
19494 -- pragma in which case the current pragma is illegal as
19495 -- it cannot "complete".
19498 Error_Msg_N
("incorrect use of SPARK_Mode", Arg
);
19499 Error_Msg_Sloc
:= Sloc
(Entity
);
19501 ("\no value was set for SPARK_Mode on&#",
19506 end Check_Pragma_Conformance
;
19508 --------------------------------
19509 -- Check_Library_Level_Entity --
19510 --------------------------------
19512 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19513 MsgF
: constant String := "incorrect placement of pragma%";
19516 if not Is_Library_Level_Entity
(E
) then
19517 Error_Msg_Name_1
:= Pname
;
19518 Error_Msg_N
(Fix_Error
(MsgF
), N
);
19520 if Ekind_In
(E
, E_Generic_Package
,
19525 ("\& is not a library-level package", N
, E
);
19528 ("\& is not a library-level subprogram", N
, E
);
19533 end Check_Library_Level_Entity
;
19535 ---------------------
19536 -- Set_SPARK_Flags --
19537 ---------------------
19539 procedure Set_SPARK_Flags
is
19541 SPARK_Mode
:= Mode_Id
;
19542 SPARK_Mode_Pragma
:= N
;
19544 if SPARK_Mode
= On
then
19545 Dynamic_Elaboration_Checks
:= False;
19547 end Set_SPARK_Flags
;
19551 Body_Id
: Entity_Id
;
19554 Spec_Id
: Entity_Id
;
19557 -- Start of processing for Do_SPARK_Mode
19560 -- When a SPARK_Mode pragma appears inside an instantiation whose
19561 -- enclosing context has SPARK_Mode set to "off", the pragma has
19562 -- no semantic effect.
19564 if Ignore_Pragma_SPARK_Mode
then
19565 Rewrite
(N
, Make_Null_Statement
(Loc
));
19571 Check_No_Identifiers
;
19572 Check_At_Most_N_Arguments
(1);
19574 -- Check the legality of the mode (no argument = ON)
19576 if Arg_Count
= 1 then
19577 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19578 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19583 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19584 Context
:= Parent
(N
);
19586 -- The pragma appears in a configuration pragmas file
19588 if No
(Context
) then
19589 Check_Valid_Configuration_Pragma
;
19591 if Present
(SPARK_Mode_Pragma
) then
19592 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19593 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19599 -- The pragma acts as a configuration pragma in a compilation unit
19601 -- pragma SPARK_Mode ...;
19602 -- package Pack is ...;
19604 elsif Nkind
(Context
) = N_Compilation_Unit
19605 and then List_Containing
(N
) = Context_Items
(Context
)
19607 Check_Valid_Configuration_Pragma
;
19610 -- Otherwise the placement of the pragma within the tree dictates
19611 -- its associated construct. Inspect the declarative list where
19612 -- the pragma resides to find a potential construct.
19616 while Present
(Stmt
) loop
19618 -- Skip prior pragmas, but check for duplicates
19620 if Nkind
(Stmt
) = N_Pragma
then
19621 if Pragma_Name
(Stmt
) = Pname
then
19622 Error_Msg_Name_1
:= Pname
;
19623 Error_Msg_Sloc
:= Sloc
(Stmt
);
19624 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19628 -- The pragma applies to a [generic] subprogram declaration.
19629 -- Note that this case covers an internally generated spec
19630 -- for a stand alone body.
19633 -- procedure Proc ...;
19634 -- pragma SPARK_Mode ..;
19636 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
19637 N_Subprogram_Declaration
)
19639 Spec_Id
:= Defining_Entity
(Stmt
);
19640 Check_Library_Level_Entity
(Spec_Id
);
19641 Check_Pragma_Conformance
19642 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19643 Entity_Pragma
=> Empty
,
19646 Set_SPARK_Pragma
(Spec_Id
, N
);
19647 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19650 -- Skip internally generated code
19652 elsif not Comes_From_Source
(Stmt
) then
19655 -- Otherwise the pragma does not apply to a legal construct
19656 -- or it does not appear at the top of a declarative or a
19657 -- statement list. Issue an error and stop the analysis.
19667 -- The pragma applies to a package or a subprogram that acts as
19668 -- a compilation unit.
19670 -- procedure Proc ...;
19671 -- pragma SPARK_Mode ...;
19673 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19674 Context
:= Unit
(Parent
(Context
));
19677 -- The pragma appears within package declarations
19679 if Nkind
(Context
) = N_Package_Specification
then
19680 Spec_Id
:= Defining_Entity
(Context
);
19681 Check_Library_Level_Entity
(Spec_Id
);
19683 -- The pragma is at the top of the visible declarations
19686 -- pragma SPARK_Mode ...;
19688 if List_Containing
(N
) = Visible_Declarations
(Context
) then
19689 Check_Pragma_Conformance
19690 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19691 Entity_Pragma
=> Empty
,
19695 Set_SPARK_Pragma
(Spec_Id
, N
);
19696 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19697 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19698 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19700 -- The pragma is at the top of the private declarations
19704 -- pragma SPARK_Mode ...;
19707 Check_Pragma_Conformance
19708 (Context_Pragma
=> Empty
,
19709 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19710 Entity
=> Spec_Id
);
19713 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19714 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19717 -- The pragma appears at the top of package body declarations
19719 -- package body Pack is
19720 -- pragma SPARK_Mode ...;
19722 elsif Nkind
(Context
) = N_Package_Body
then
19723 Spec_Id
:= Corresponding_Spec
(Context
);
19724 Body_Id
:= Defining_Entity
(Context
);
19725 Check_Library_Level_Entity
(Body_Id
);
19726 Check_Pragma_Conformance
19727 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19728 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19729 Entity
=> Spec_Id
);
19732 Set_SPARK_Pragma
(Body_Id
, N
);
19733 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19734 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19735 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19737 -- The pragma appears at the top of package body statements
19739 -- package body Pack is
19741 -- pragma SPARK_Mode;
19743 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
19744 and then Nkind
(Parent
(Context
)) = N_Package_Body
19746 Context
:= Parent
(Context
);
19747 Spec_Id
:= Corresponding_Spec
(Context
);
19748 Body_Id
:= Defining_Entity
(Context
);
19749 Check_Library_Level_Entity
(Body_Id
);
19750 Check_Pragma_Conformance
19751 (Context_Pragma
=> Empty
,
19752 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
19753 Entity
=> Body_Id
);
19756 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19757 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
19759 -- The pragma appeared as an aspect of a [generic] subprogram
19760 -- declaration that acts as a compilation unit.
19763 -- procedure Proc ...;
19764 -- pragma SPARK_Mode ...;
19766 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
19767 N_Subprogram_Declaration
)
19769 Spec_Id
:= Defining_Entity
(Context
);
19770 Check_Library_Level_Entity
(Spec_Id
);
19771 Check_Pragma_Conformance
19772 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19773 Entity_Pragma
=> Empty
,
19776 Set_SPARK_Pragma
(Spec_Id
, N
);
19777 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19779 -- The pragma appears at the top of subprogram body
19782 -- procedure Proc ... is
19783 -- pragma SPARK_Mode;
19785 elsif Nkind
(Context
) = N_Subprogram_Body
then
19786 Spec_Id
:= Corresponding_Spec
(Context
);
19787 Context
:= Specification
(Context
);
19788 Body_Id
:= Defining_Entity
(Context
);
19790 -- Ignore pragma when applied to the special body created
19791 -- for inlining, recognized by its internal name _Parent.
19793 if Chars
(Body_Id
) = Name_uParent
then
19797 Check_Library_Level_Entity
(Body_Id
);
19799 -- The body is a completion of a previous declaration
19801 if Present
(Spec_Id
) then
19802 Check_Pragma_Conformance
19803 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19804 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19805 Entity
=> Spec_Id
);
19807 -- The body acts as spec
19810 Check_Pragma_Conformance
19811 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19812 Entity_Pragma
=> Empty
,
19818 Set_SPARK_Pragma
(Body_Id
, N
);
19819 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19821 -- The pragma does not apply to a legal construct, issue error
19829 --------------------------------
19830 -- Static_Elaboration_Desired --
19831 --------------------------------
19833 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
19835 when Pragma_Static_Elaboration_Desired
=>
19837 Check_At_Most_N_Arguments
(1);
19839 if Is_Compilation_Unit
(Current_Scope
)
19840 and then Ekind
(Current_Scope
) = E_Package
19842 Set_Static_Elaboration_Desired
(Current_Scope
, True);
19844 Error_Pragma
("pragma% must apply to a library-level package");
19851 -- pragma Storage_Size (EXPRESSION);
19853 when Pragma_Storage_Size
=> Storage_Size
: declare
19854 P
: constant Node_Id
:= Parent
(N
);
19858 Check_No_Identifiers
;
19859 Check_Arg_Count
(1);
19861 -- The expression must be analyzed in the special manner described
19862 -- in "Handling of Default Expressions" in sem.ads.
19864 Arg
:= Get_Pragma_Arg
(Arg1
);
19865 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
19867 if not Is_OK_Static_Expression
(Arg
) then
19868 Check_Restriction
(Static_Storage_Size
, Arg
);
19871 if Nkind
(P
) /= N_Task_Definition
then
19876 if Has_Storage_Size_Pragma
(P
) then
19877 Error_Pragma
("duplicate pragma% not allowed");
19879 Set_Has_Storage_Size_Pragma
(P
, True);
19882 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
19890 -- pragma Storage_Unit (NUMERIC_LITERAL);
19892 -- Only permitted argument is System'Storage_Unit value
19894 when Pragma_Storage_Unit
=>
19895 Check_No_Identifiers
;
19896 Check_Arg_Count
(1);
19897 Check_Arg_Is_Integer_Literal
(Arg1
);
19899 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
19900 UI_From_Int
(Ttypes
.System_Storage_Unit
)
19902 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
19904 ("the only allowed argument for pragma% is ^", Arg1
);
19907 --------------------
19908 -- Stream_Convert --
19909 --------------------
19911 -- pragma Stream_Convert (
19912 -- [Entity =>] type_LOCAL_NAME,
19913 -- [Read =>] function_NAME,
19914 -- [Write =>] function NAME);
19916 when Pragma_Stream_Convert
=> Stream_Convert
: declare
19918 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
19919 -- Check that the given argument is the name of a local function
19920 -- of one argument that is not overloaded earlier in the current
19921 -- local scope. A check is also made that the argument is a
19922 -- function with one parameter.
19924 --------------------------------------
19925 -- Check_OK_Stream_Convert_Function --
19926 --------------------------------------
19928 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
19932 Check_Arg_Is_Local_Name
(Arg
);
19933 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
19935 if Has_Homonym
(Ent
) then
19937 ("argument for pragma% may not be overloaded", Arg
);
19940 if Ekind
(Ent
) /= E_Function
19941 or else No
(First_Formal
(Ent
))
19942 or else Present
(Next_Formal
(First_Formal
(Ent
)))
19945 ("argument for pragma% must be function of one argument",
19948 end Check_OK_Stream_Convert_Function
;
19950 -- Start of processing for Stream_Convert
19954 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
19955 Check_Arg_Count
(3);
19956 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19957 Check_Optional_Identifier
(Arg2
, Name_Read
);
19958 Check_Optional_Identifier
(Arg3
, Name_Write
);
19959 Check_Arg_Is_Local_Name
(Arg1
);
19960 Check_OK_Stream_Convert_Function
(Arg2
);
19961 Check_OK_Stream_Convert_Function
(Arg3
);
19964 Typ
: constant Entity_Id
:=
19965 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
19966 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
19967 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
19970 Check_First_Subtype
(Arg1
);
19972 -- Check for too early or too late. Note that we don't enforce
19973 -- the rule about primitive operations in this case, since, as
19974 -- is the case for explicit stream attributes themselves, these
19975 -- restrictions are not appropriate. Note that the chaining of
19976 -- the pragma by Rep_Item_Too_Late is actually the critical
19977 -- processing done for this pragma.
19979 if Rep_Item_Too_Early
(Typ
, N
)
19981 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
19986 -- Return if previous error
19988 if Etype
(Typ
) = Any_Type
19990 Etype
(Read
) = Any_Type
19992 Etype
(Write
) = Any_Type
19999 if Underlying_Type
(Etype
(Read
)) /= Typ
then
20001 ("incorrect return type for function&", Arg2
);
20004 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
20006 ("incorrect parameter type for function&", Arg3
);
20009 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
20010 Underlying_Type
(Etype
(Write
))
20013 ("result type of & does not match Read parameter type",
20017 end Stream_Convert
;
20023 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20025 -- This is processed by the parser since some of the style checks
20026 -- take place during source scanning and parsing. This means that
20027 -- we don't need to issue error messages here.
20029 when Pragma_Style_Checks
=> Style_Checks
: declare
20030 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20036 Check_No_Identifiers
;
20038 -- Two argument form
20040 if Arg_Count
= 2 then
20041 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20048 E_Id
:= Get_Pragma_Arg
(Arg2
);
20051 if not Is_Entity_Name
(E_Id
) then
20053 ("second argument of pragma% must be entity name",
20057 E
:= Entity
(E_Id
);
20059 if not Ignore_Style_Checks_Pragmas
then
20064 Set_Suppress_Style_Checks
20065 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
20066 exit when No
(Homonym
(E
));
20073 -- One argument form
20076 Check_Arg_Count
(1);
20078 if Nkind
(A
) = N_String_Literal
then
20082 Slen
: constant Natural := Natural (String_Length
(S
));
20083 Options
: String (1 .. Slen
);
20089 C
:= Get_String_Char
(S
, Int
(J
));
20090 exit when not In_Character_Range
(C
);
20091 Options
(J
) := Get_Character
(C
);
20093 -- If at end of string, set options. As per discussion
20094 -- above, no need to check for errors, since we issued
20095 -- them in the parser.
20098 if not Ignore_Style_Checks_Pragmas
then
20099 Set_Style_Check_Options
(Options
);
20109 elsif Nkind
(A
) = N_Identifier
then
20110 if Chars
(A
) = Name_All_Checks
then
20111 if not Ignore_Style_Checks_Pragmas
then
20113 Set_GNAT_Style_Check_Options
;
20115 Set_Default_Style_Check_Options
;
20119 elsif Chars
(A
) = Name_On
then
20120 if not Ignore_Style_Checks_Pragmas
then
20121 Style_Check
:= True;
20124 elsif Chars
(A
) = Name_Off
then
20125 if not Ignore_Style_Checks_Pragmas
then
20126 Style_Check
:= False;
20137 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20139 when Pragma_Subtitle
=>
20141 Check_Arg_Count
(1);
20142 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
20143 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20150 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20152 when Pragma_Suppress
=>
20153 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
20159 -- pragma Suppress_All;
20161 -- The only check made here is that the pragma has no arguments.
20162 -- There are no placement rules, and the processing required (setting
20163 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20164 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20165 -- then creates and inserts a pragma Suppress (All_Checks).
20167 when Pragma_Suppress_All
=>
20169 Check_Arg_Count
(0);
20171 -------------------------
20172 -- Suppress_Debug_Info --
20173 -------------------------
20175 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20177 when Pragma_Suppress_Debug_Info
=>
20179 Check_Arg_Count
(1);
20180 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20181 Check_Arg_Is_Local_Name
(Arg1
);
20182 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
20184 ----------------------------------
20185 -- Suppress_Exception_Locations --
20186 ----------------------------------
20188 -- pragma Suppress_Exception_Locations;
20190 when Pragma_Suppress_Exception_Locations
=>
20192 Check_Arg_Count
(0);
20193 Check_Valid_Configuration_Pragma
;
20194 Exception_Locations_Suppressed
:= True;
20196 -----------------------------
20197 -- Suppress_Initialization --
20198 -----------------------------
20200 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20202 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
20208 Check_Arg_Count
(1);
20209 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20210 Check_Arg_Is_Local_Name
(Arg1
);
20212 E_Id
:= Get_Pragma_Arg
(Arg1
);
20214 if Etype
(E_Id
) = Any_Type
then
20218 E
:= Entity
(E_Id
);
20220 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
20222 ("pragma% requires variable, type or subtype", Arg1
);
20225 if Rep_Item_Too_Early
(E
, N
)
20227 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
20232 -- For incomplete/private type, set flag on full view
20234 if Is_Incomplete_Or_Private_Type
(E
) then
20235 if No
(Full_View
(Base_Type
(E
))) then
20237 ("argument of pragma% cannot be an incomplete type", Arg1
);
20239 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
20242 -- For first subtype, set flag on base type
20244 elsif Is_First_Subtype
(E
) then
20245 Set_Suppress_Initialization
(Base_Type
(E
));
20247 -- For other than first subtype, set flag on subtype or variable
20250 Set_Suppress_Initialization
(E
);
20258 -- pragma System_Name (DIRECT_NAME);
20260 -- Syntax check: one argument, which must be the identifier GNAT or
20261 -- the identifier GCC, no other identifiers are acceptable.
20263 when Pragma_System_Name
=>
20265 Check_No_Identifiers
;
20266 Check_Arg_Count
(1);
20267 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
20269 -----------------------------
20270 -- Task_Dispatching_Policy --
20271 -----------------------------
20273 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20275 when Pragma_Task_Dispatching_Policy
=> declare
20279 Check_Ada_83_Warning
;
20280 Check_Arg_Count
(1);
20281 Check_No_Identifiers
;
20282 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20283 Check_Valid_Configuration_Pragma
;
20284 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20285 DP
:= Fold_Upper
(Name_Buffer
(1));
20287 if Task_Dispatching_Policy
/= ' '
20288 and then Task_Dispatching_Policy
/= DP
20290 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20292 ("task dispatching policy incompatible with policy#");
20294 -- Set new policy, but always preserve System_Location since we
20295 -- like the error message with the run time name.
20298 Task_Dispatching_Policy
:= DP
;
20300 if Task_Dispatching_Policy_Sloc
/= System_Location
then
20301 Task_Dispatching_Policy_Sloc
:= Loc
;
20310 -- pragma Task_Info (EXPRESSION);
20312 when Pragma_Task_Info
=> Task_Info
: declare
20313 P
: constant Node_Id
:= Parent
(N
);
20319 if Warn_On_Obsolescent_Feature
then
20321 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20322 & "instead?j?", N
);
20325 if Nkind
(P
) /= N_Task_Definition
then
20326 Error_Pragma
("pragma% must appear in task definition");
20329 Check_No_Identifiers
;
20330 Check_Arg_Count
(1);
20332 Analyze_And_Resolve
20333 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
20335 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
20339 Ent
:= Defining_Identifier
(Parent
(P
));
20341 -- Check duplicate pragma before we chain the pragma in the Rep
20342 -- Item chain of Ent.
20345 (Ent
, Name_Task_Info
, Check_Parents
=> False)
20347 Error_Pragma
("duplicate pragma% not allowed");
20350 Record_Rep_Item
(Ent
, N
);
20357 -- pragma Task_Name (string_EXPRESSION);
20359 when Pragma_Task_Name
=> Task_Name
: declare
20360 P
: constant Node_Id
:= Parent
(N
);
20365 Check_No_Identifiers
;
20366 Check_Arg_Count
(1);
20368 Arg
:= Get_Pragma_Arg
(Arg1
);
20370 -- The expression is used in the call to Create_Task, and must be
20371 -- expanded there, not in the context of the current spec. It must
20372 -- however be analyzed to capture global references, in case it
20373 -- appears in a generic context.
20375 Preanalyze_And_Resolve
(Arg
, Standard_String
);
20377 if Nkind
(P
) /= N_Task_Definition
then
20381 Ent
:= Defining_Identifier
(Parent
(P
));
20383 -- Check duplicate pragma before we chain the pragma in the Rep
20384 -- Item chain of Ent.
20387 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20389 Error_Pragma
("duplicate pragma% not allowed");
20392 Record_Rep_Item
(Ent
, N
);
20399 -- pragma Task_Storage (
20400 -- [Task_Type =>] LOCAL_NAME,
20401 -- [Top_Guard =>] static_integer_EXPRESSION);
20403 when Pragma_Task_Storage
=> Task_Storage
: declare
20404 Args
: Args_List
(1 .. 2);
20405 Names
: constant Name_List
(1 .. 2) := (
20409 Task_Type
: Node_Id
renames Args
(1);
20410 Top_Guard
: Node_Id
renames Args
(2);
20416 Gather_Associations
(Names
, Args
);
20418 if No
(Task_Type
) then
20420 ("missing task_type argument for pragma%");
20423 Check_Arg_Is_Local_Name
(Task_Type
);
20425 Ent
:= Entity
(Task_Type
);
20427 if not Is_Task_Type
(Ent
) then
20429 ("argument for pragma% must be task type", Task_Type
);
20432 if No
(Top_Guard
) then
20434 ("pragma% takes two arguments", Task_Type
);
20436 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
20439 Check_First_Subtype
(Task_Type
);
20441 if Rep_Item_Too_Late
(Ent
, N
) then
20450 -- pragma Test_Case
20451 -- ([Name =>] Static_String_EXPRESSION
20452 -- ,[Mode =>] MODE_TYPE
20453 -- [, Requires => Boolean_EXPRESSION]
20454 -- [, Ensures => Boolean_EXPRESSION]);
20456 -- MODE_TYPE ::= Nominal | Robustness
20458 -- Characteristics:
20460 -- * Analysis - The annotation undergoes initial checks to verify
20461 -- the legal placement and context. Secondary checks preanalyze the
20464 -- Analyze_Test_Case_In_Decl_Part
20466 -- * Expansion - None.
20468 -- * Template - The annotation utilizes the generic template of the
20469 -- related subprogram when it is:
20471 -- aspect on subprogram declaration
20473 -- The annotation must prepare its own template when it is:
20475 -- pragma on subprogram declaration
20477 -- * Globals - Capture of global references must occur after full
20480 -- * Instance - The annotation is instantiated automatically when
20481 -- the related generic subprogram is instantiated except for the
20482 -- "pragma on subprogram declaration" case. In that scenario the
20483 -- annotation must instantiate itself.
20485 when Pragma_Test_Case
=> Test_Case
: declare
20486 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
20487 -- Ensure that the contract of subprogram Subp_Id does not contain
20488 -- another Test_Case pragma with the same Name as the current one.
20490 -------------------------
20491 -- Check_Distinct_Name --
20492 -------------------------
20494 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
20495 Items
: constant Node_Id
:= Contract
(Subp_Id
);
20496 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
20500 -- Inspect all Test_Case pragma of the related subprogram
20501 -- looking for one with a duplicate "Name" argument.
20503 if Present
(Items
) then
20504 Prag
:= Contract_Test_Cases
(Items
);
20505 while Present
(Prag
) loop
20506 if Pragma_Name
(Prag
) = Name_Test_Case
20507 and then String_Equal
20508 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
20510 Error_Msg_Sloc
:= Sloc
(Prag
);
20511 Error_Pragma
("name for pragma % is already used #");
20514 Prag
:= Next_Pragma
(Prag
);
20517 end Check_Distinct_Name
;
20521 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
20524 Subp_Decl
: Node_Id
;
20525 Subp_Id
: Entity_Id
;
20527 -- Start of processing for Test_Case
20531 Check_At_Least_N_Arguments
(2);
20532 Check_At_Most_N_Arguments
(4);
20534 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
20538 Check_Optional_Identifier
(Arg1
, Name_Name
);
20539 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20543 Check_Optional_Identifier
(Arg2
, Name_Mode
);
20544 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
20546 -- Arguments "Requires" and "Ensures"
20548 if Present
(Arg3
) then
20549 if Present
(Arg4
) then
20550 Check_Identifier
(Arg3
, Name_Requires
);
20551 Check_Identifier
(Arg4
, Name_Ensures
);
20553 Check_Identifier_Is_One_Of
20554 (Arg3
, Name_Requires
, Name_Ensures
);
20558 -- Pragma Test_Case must be associated with a subprogram declared
20559 -- in a library-level package. First determine whether the current
20560 -- compilation unit is a legal context.
20562 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
20563 N_Generic_Package_Declaration
)
20567 -- Otherwise the placement is illegal
20574 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
20576 -- Find the enclosing context
20578 Context
:= Parent
(Subp_Decl
);
20580 if Present
(Context
) then
20581 Context
:= Parent
(Context
);
20584 -- Verify the placement of the pragma
20586 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
20588 ("pragma % cannot be applied to abstract subprogram");
20591 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
20592 Error_Pragma
("pragma % cannot be applied to entry");
20595 -- The context is a [generic] subprogram declared at the top level
20596 -- of the [generic] package unit.
20598 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
20599 N_Subprogram_Declaration
)
20600 and then Present
(Context
)
20601 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
20602 N_Package_Declaration
)
20604 Subp_Id
:= Defining_Entity
(Subp_Decl
);
20606 -- Otherwise the placement is illegal
20613 -- Preanalyze the original aspect argument "Name" for ASIS or for
20614 -- a generic subprogram to properly capture global references.
20616 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
20617 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
20619 if Present
(Asp_Arg
) then
20621 -- The argument appears with an identifier in association
20624 if Nkind
(Asp_Arg
) = N_Component_Association
then
20625 Asp_Arg
:= Expression
(Asp_Arg
);
20628 Check_Expr_Is_OK_Static_Expression
20629 (Asp_Arg
, Standard_String
);
20633 -- Ensure that the all Test_Case pragmas of the related subprogram
20634 -- have distinct names.
20636 Check_Distinct_Name
(Subp_Id
);
20638 -- Fully analyze the pragma when it appears inside a subprogram
20639 -- body because it cannot benefit from forward references.
20641 if Nkind_In
(Subp_Decl
, N_Subprogram_Body
,
20642 N_Subprogram_Body_Stub
)
20644 Analyze_Test_Case_In_Decl_Part
(N
);
20647 -- Chain the pragma on the contract for further processing by
20648 -- Analyze_Test_Case_In_Decl_Part.
20650 Add_Contract_Item
(N
, Subp_Id
);
20653 --------------------------
20654 -- Thread_Local_Storage --
20655 --------------------------
20657 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20659 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20665 Check_Arg_Count
(1);
20666 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20667 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20669 Id
:= Get_Pragma_Arg
(Arg1
);
20672 if not Is_Entity_Name
(Id
)
20673 or else Ekind
(Entity
(Id
)) /= E_Variable
20675 Error_Pragma_Arg
("local variable name required", Arg1
);
20680 if Rep_Item_Too_Early
(E
, N
)
20681 or else Rep_Item_Too_Late
(E
, N
)
20686 Set_Has_Pragma_Thread_Local_Storage
(E
);
20687 Set_Has_Gigi_Rep_Item
(E
);
20688 end Thread_Local_Storage
;
20694 -- pragma Time_Slice (static_duration_EXPRESSION);
20696 when Pragma_Time_Slice
=> Time_Slice
: declare
20702 Check_Arg_Count
(1);
20703 Check_No_Identifiers
;
20704 Check_In_Main_Program
;
20705 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
20707 if not Error_Posted
(Arg1
) then
20709 while Present
(Nod
) loop
20710 if Nkind
(Nod
) = N_Pragma
20711 and then Pragma_Name
(Nod
) = Name_Time_Slice
20713 Error_Msg_Name_1
:= Pname
;
20714 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20721 -- Process only if in main unit
20723 if Get_Source_Unit
(Loc
) = Main_Unit
then
20724 Opt
.Time_Slice_Set
:= True;
20725 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20727 if Val
<= Ureal_0
then
20728 Opt
.Time_Slice_Value
:= 0;
20730 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20731 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20734 Opt
.Time_Slice_Value
:=
20735 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20744 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20746 -- TITLING_OPTION ::=
20747 -- [Title =>] STRING_LITERAL
20748 -- | [Subtitle =>] STRING_LITERAL
20750 when Pragma_Title
=> Title
: declare
20751 Args
: Args_List
(1 .. 2);
20752 Names
: constant Name_List
(1 .. 2) := (
20758 Gather_Associations
(Names
, Args
);
20761 for J
in 1 .. 2 loop
20762 if Present
(Args
(J
)) then
20763 Check_Arg_Is_OK_Static_Expression
20764 (Args
(J
), Standard_String
);
20769 ----------------------------
20770 -- Type_Invariant[_Class] --
20771 ----------------------------
20773 -- pragma Type_Invariant[_Class]
20774 -- ([Entity =>] type_LOCAL_NAME,
20775 -- [Check =>] EXPRESSION);
20777 when Pragma_Type_Invariant |
20778 Pragma_Type_Invariant_Class
=>
20779 Type_Invariant
: declare
20780 I_Pragma
: Node_Id
;
20783 Check_Arg_Count
(2);
20785 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20786 -- setting Class_Present for the Type_Invariant_Class case.
20788 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20789 I_Pragma
:= New_Copy
(N
);
20790 Set_Pragma_Identifier
20791 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20792 Rewrite
(N
, I_Pragma
);
20793 Set_Analyzed
(N
, False);
20795 end Type_Invariant
;
20797 ---------------------
20798 -- Unchecked_Union --
20799 ---------------------
20801 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20803 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20804 Assoc
: constant Node_Id
:= Arg1
;
20805 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20815 Check_No_Identifiers
;
20816 Check_Arg_Count
(1);
20817 Check_Arg_Is_Local_Name
(Arg1
);
20819 Find_Type
(Type_Id
);
20821 Typ
:= Entity
(Type_Id
);
20824 or else Rep_Item_Too_Early
(Typ
, N
)
20828 Typ
:= Underlying_Type
(Typ
);
20831 if Rep_Item_Too_Late
(Typ
, N
) then
20835 Check_First_Subtype
(Arg1
);
20837 -- Note remaining cases are references to a type in the current
20838 -- declarative part. If we find an error, we post the error on
20839 -- the relevant type declaration at an appropriate point.
20841 if not Is_Record_Type
(Typ
) then
20842 Error_Msg_N
("unchecked union must be record type", Typ
);
20845 elsif Is_Tagged_Type
(Typ
) then
20846 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20849 elsif not Has_Discriminants
(Typ
) then
20851 ("unchecked union must have one discriminant", Typ
);
20854 -- Note: in previous versions of GNAT we used to check for limited
20855 -- types and give an error, but in fact the standard does allow
20856 -- Unchecked_Union on limited types, so this check was removed.
20858 -- Similarly, GNAT used to require that all discriminants have
20859 -- default values, but this is not mandated by the RM.
20861 -- Proceed with basic error checks completed
20864 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20865 Clist
:= Component_List
(Tdef
);
20867 -- Check presence of component list and variant part
20869 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20871 ("unchecked union must have variant part", Tdef
);
20875 -- Check components
20877 Comp
:= First
(Component_Items
(Clist
));
20878 while Present
(Comp
) loop
20879 Check_Component
(Comp
, Typ
);
20883 -- Check variant part
20885 Vpart
:= Variant_Part
(Clist
);
20887 Variant
:= First
(Variants
(Vpart
));
20888 while Present
(Variant
) loop
20889 Check_Variant
(Variant
, Typ
);
20894 Set_Is_Unchecked_Union
(Typ
);
20895 Set_Convention
(Typ
, Convention_C
);
20896 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20897 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20898 end Unchecked_Union
;
20900 ------------------------
20901 -- Unimplemented_Unit --
20902 ------------------------
20904 -- pragma Unimplemented_Unit;
20906 -- Note: this only gives an error if we are generating code, or if
20907 -- we are in a generic library unit (where the pragma appears in the
20908 -- body, not in the spec).
20910 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20911 Cunitent
: constant Entity_Id
:=
20912 Cunit_Entity
(Get_Source_Unit
(Loc
));
20913 Ent_Kind
: constant Entity_Kind
:=
20918 Check_Arg_Count
(0);
20920 if Operating_Mode
= Generate_Code
20921 or else Ent_Kind
= E_Generic_Function
20922 or else Ent_Kind
= E_Generic_Procedure
20923 or else Ent_Kind
= E_Generic_Package
20925 Get_Name_String
(Chars
(Cunitent
));
20926 Set_Casing
(Mixed_Case
);
20927 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20928 Write_Str
(" is not supported in this configuration");
20930 raise Unrecoverable_Error
;
20932 end Unimplemented_Unit
;
20934 ------------------------
20935 -- Universal_Aliasing --
20936 ------------------------
20938 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20940 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20945 Check_Arg_Count
(1);
20946 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20947 Check_Arg_Is_Local_Name
(Arg1
);
20948 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20950 if E_Id
= Any_Type
then
20952 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20953 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20956 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20957 Record_Rep_Item
(E_Id
, N
);
20958 end Universal_Alias
;
20960 --------------------
20961 -- Universal_Data --
20962 --------------------
20964 -- pragma Universal_Data [(library_unit_NAME)];
20966 when Pragma_Universal_Data
=>
20969 -- If this is a configuration pragma, then set the universal
20970 -- addressing option, otherwise confirm that the pragma satisfies
20971 -- the requirements of library unit pragma placement and leave it
20972 -- to the GNAAMP back end to detect the pragma (avoids transitive
20973 -- setting of the option due to withed units).
20975 if Is_Configuration_Pragma
then
20976 Universal_Addressing_On_AAMP
:= True;
20978 Check_Valid_Library_Unit_Pragma
;
20981 if not AAMP_On_Target
then
20982 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
20989 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
20991 when Pragma_Unmodified
=> Unmodified
: declare
20992 Arg_Node
: Node_Id
;
20993 Arg_Expr
: Node_Id
;
20994 Arg_Ent
: Entity_Id
;
20998 Check_At_Least_N_Arguments
(1);
21000 -- Loop through arguments
21003 while Present
(Arg_Node
) loop
21004 Check_No_Identifier
(Arg_Node
);
21006 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
21007 -- in fact generate reference, so that the entity will have a
21008 -- reference, which will inhibit any warnings about it not
21009 -- being referenced, and also properly show up in the ali file
21010 -- as a reference. But this reference is recorded before the
21011 -- Has_Pragma_Unreferenced flag is set, so that no warning is
21012 -- generated for this reference.
21014 Check_Arg_Is_Local_Name
(Arg_Node
);
21015 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21017 if Is_Entity_Name
(Arg_Expr
) then
21018 Arg_Ent
:= Entity
(Arg_Expr
);
21020 if not Is_Assignable
(Arg_Ent
) then
21022 ("pragma% can only be applied to a variable",
21025 Set_Has_Pragma_Unmodified
(Arg_Ent
);
21037 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
21039 -- or when used in a context clause:
21041 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21043 when Pragma_Unreferenced
=> Unreferenced
: declare
21044 Arg_Node
: Node_Id
;
21045 Arg_Expr
: Node_Id
;
21046 Arg_Ent
: Entity_Id
;
21051 Check_At_Least_N_Arguments
(1);
21053 -- Check case of appearing within context clause
21055 if Is_In_Context_Clause
then
21057 -- The arguments must all be units mentioned in a with clause
21058 -- in the same context clause. Note we already checked (in
21059 -- Par.Prag) that the arguments are either identifiers or
21060 -- selected components.
21063 while Present
(Arg_Node
) loop
21064 Citem
:= First
(List_Containing
(N
));
21065 while Citem
/= N
loop
21066 if Nkind
(Citem
) = N_With_Clause
21068 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
21070 Set_Has_Pragma_Unreferenced
21073 (Library_Unit
(Citem
))));
21075 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
21084 ("argument of pragma% is not withed unit", Arg_Node
);
21090 -- Case of not in list of context items
21094 while Present
(Arg_Node
) loop
21095 Check_No_Identifier
(Arg_Node
);
21097 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21098 -- will in fact generate reference, so that the entity will
21099 -- have a reference, which will inhibit any warnings about
21100 -- it not being referenced, and also properly show up in the
21101 -- ali file as a reference. But this reference is recorded
21102 -- before the Has_Pragma_Unreferenced flag is set, so that
21103 -- no warning is generated for this reference.
21105 Check_Arg_Is_Local_Name
(Arg_Node
);
21106 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21108 if Is_Entity_Name
(Arg_Expr
) then
21109 Arg_Ent
:= Entity
(Arg_Expr
);
21111 -- If the entity is overloaded, the pragma applies to the
21112 -- most recent overloading, as documented. In this case,
21113 -- name resolution does not generate a reference, so it
21114 -- must be done here explicitly.
21116 if Is_Overloaded
(Arg_Expr
) then
21117 Generate_Reference
(Arg_Ent
, N
);
21120 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
21128 --------------------------
21129 -- Unreferenced_Objects --
21130 --------------------------
21132 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
21134 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
21135 Arg_Node
: Node_Id
;
21136 Arg_Expr
: Node_Id
;
21140 Check_At_Least_N_Arguments
(1);
21143 while Present
(Arg_Node
) loop
21144 Check_No_Identifier
(Arg_Node
);
21145 Check_Arg_Is_Local_Name
(Arg_Node
);
21146 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21148 if not Is_Entity_Name
(Arg_Expr
)
21149 or else not Is_Type
(Entity
(Arg_Expr
))
21152 ("argument for pragma% must be type or subtype", Arg_Node
);
21155 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
21158 end Unreferenced_Objects
;
21160 ------------------------------
21161 -- Unreserve_All_Interrupts --
21162 ------------------------------
21164 -- pragma Unreserve_All_Interrupts;
21166 when Pragma_Unreserve_All_Interrupts
=>
21168 Check_Arg_Count
(0);
21170 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
21171 Unreserve_All_Interrupts
:= True;
21178 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21180 when Pragma_Unsuppress
=>
21182 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
21184 ----------------------------
21185 -- Unevaluated_Use_Of_Old --
21186 ----------------------------
21188 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
21190 when Pragma_Unevaluated_Use_Of_Old
=>
21192 Check_Arg_Count
(1);
21193 Check_No_Identifiers
;
21194 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
21196 -- Suppress/Unsuppress can appear as a configuration pragma, or in
21197 -- a declarative part or a package spec.
21199 if not Is_Configuration_Pragma
then
21200 Check_Is_In_Decl_Part_Or_Package_Spec
;
21203 -- Store proper setting of Uneval_Old
21205 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21206 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
21208 -------------------
21209 -- Use_VADS_Size --
21210 -------------------
21212 -- pragma Use_VADS_Size;
21214 when Pragma_Use_VADS_Size
=>
21216 Check_Arg_Count
(0);
21217 Check_Valid_Configuration_Pragma
;
21218 Use_VADS_Size
:= True;
21220 ---------------------
21221 -- Validity_Checks --
21222 ---------------------
21224 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21226 when Pragma_Validity_Checks
=> Validity_Checks
: declare
21227 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21233 Check_Arg_Count
(1);
21234 Check_No_Identifiers
;
21236 -- Pragma always active unless in CodePeer or GNATprove modes,
21237 -- which use a fixed configuration of validity checks.
21239 if not (CodePeer_Mode
or GNATprove_Mode
) then
21240 if Nkind
(A
) = N_String_Literal
then
21244 Slen
: constant Natural := Natural (String_Length
(S
));
21245 Options
: String (1 .. Slen
);
21249 -- Couldn't we use a for loop here over Options'Range???
21253 C
:= Get_String_Char
(S
, Int
(J
));
21255 -- This is a weird test, it skips setting validity
21256 -- checks entirely if any element of S is out of
21257 -- range of Character, what is that about ???
21259 exit when not In_Character_Range
(C
);
21260 Options
(J
) := Get_Character
(C
);
21263 Set_Validity_Check_Options
(Options
);
21271 elsif Nkind
(A
) = N_Identifier
then
21272 if Chars
(A
) = Name_All_Checks
then
21273 Set_Validity_Check_Options
("a");
21274 elsif Chars
(A
) = Name_On
then
21275 Validity_Checks_On
:= True;
21276 elsif Chars
(A
) = Name_Off
then
21277 Validity_Checks_On
:= False;
21281 end Validity_Checks
;
21287 -- pragma Volatile (LOCAL_NAME);
21289 when Pragma_Volatile
=>
21290 Process_Atomic_Independent_Shared_Volatile
;
21292 --------------------------
21293 -- Volatile_Full_Access --
21294 --------------------------
21296 -- pragma Volatile_Full_Access (LOCAL_NAME);
21298 when Pragma_Volatile_Full_Access
=>
21300 Process_Atomic_Independent_Shared_Volatile
;
21302 -------------------------
21303 -- Volatile_Components --
21304 -------------------------
21306 -- pragma Volatile_Components (array_LOCAL_NAME);
21308 -- Volatile is handled by the same circuit as Atomic_Components
21310 ----------------------
21311 -- Warning_As_Error --
21312 ----------------------
21314 -- pragma Warning_As_Error (static_string_EXPRESSION);
21316 when Pragma_Warning_As_Error
=>
21318 Check_Arg_Count
(1);
21319 Check_No_Identifiers
;
21320 Check_Valid_Configuration_Pragma
;
21322 if not Is_Static_String_Expression
(Arg1
) then
21324 ("argument of pragma% must be static string expression",
21327 -- OK static string expression
21330 Acquire_Warning_Match_String
(Arg1
);
21331 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
21332 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
21333 new String'(Name_Buffer (1 .. Name_Len));
21340 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
21342 -- DETAILS ::= On | Off
21343 -- DETAILS ::= On | Off, local_NAME
21344 -- DETAILS ::= static_string_EXPRESSION
21345 -- DETAILS ::= On | Off, static_string_EXPRESSION
21347 -- TOOL_NAME ::= GNAT | GNATProve
21349 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
21351 -- Note: If the first argument matches an allowed tool name, it is
21352 -- always considered to be a tool name, even if there is a string
21353 -- variable of that name.
21355 -- Note if the second argument of DETAILS is a local_NAME then the
21356 -- second form is always understood. If the intention is to use
21357 -- the fourth form, then you can write NAME & "" to force the
21358 -- intepretation as a static_string_EXPRESSION.
21360 when Pragma_Warnings => Warnings : declare
21361 Reason : String_Id;
21365 Check_At_Least_N_Arguments (1);
21367 -- See if last argument is labeled Reason. If so, make sure we
21368 -- have a string literal or a concatenation of string literals,
21369 -- and acquire the REASON string. Then remove the REASON argument
21370 -- by decreasing Num_Args by one; Remaining processing looks only
21371 -- at first Num_Args arguments).
21374 Last_Arg : constant Node_Id :=
21375 Last (Pragma_Argument_Associations (N));
21378 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21379 and then Chars (Last_Arg) = Name_Reason
21382 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21383 Reason := End_String;
21384 Arg_Count := Arg_Count - 1;
21386 -- Not allowed in compiler units (bootstrap issues)
21388 Check_Compiler_Unit ("Reason for pragma Warnings", N);
21390 -- No REASON string, set null string as reason
21393 Reason := Null_String_Id;
21397 -- Now proceed with REASON taken care of and eliminated
21399 Check_No_Identifiers;
21401 -- If debug flag -gnatd.i is set, pragma is ignored
21403 if Debug_Flag_Dot_I then
21407 -- Process various forms of the pragma
21410 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21411 Shifted_Args : List_Id;
21414 -- See if first argument is a tool name, currently either
21415 -- GNAT or GNATprove. If so, either ignore the pragma if the
21416 -- tool used does not match, or continue as if no tool name
21417 -- was given otherwise, by shifting the arguments.
21419 if Nkind (Argx) = N_Identifier
21420 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
21422 if Chars (Argx) = Name_Gnat then
21423 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
21424 Rewrite (N, Make_Null_Statement (Loc));
21429 elsif Chars (Argx) = Name_Gnatprove then
21430 if not GNATprove_Mode then
21431 Rewrite (N, Make_Null_Statement (Loc));
21437 raise Program_Error;
21440 -- At this point, the pragma Warnings applies to the tool,
21441 -- so continue with shifted arguments.
21443 Arg_Count := Arg_Count - 1;
21445 if Arg_Count = 1 then
21446 Shifted_Args := New_List (New_Copy (Arg2));
21447 elsif Arg_Count = 2 then
21448 Shifted_Args := New_List (New_Copy (Arg2),
21450 elsif Arg_Count = 3 then
21451 Shifted_Args := New_List (New_Copy (Arg2),
21455 raise Program_Error;
21460 Chars => Name_Warnings,
21461 Pragma_Argument_Associations => Shifted_Args));
21466 -- One argument case
21468 if Arg_Count = 1 then
21470 -- On/Off one argument case was processed by parser
21472 if Nkind (Argx) = N_Identifier
21473 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21477 -- One argument case must be ON/OFF or static string expr
21479 elsif not Is_Static_String_Expression (Arg1) then
21481 ("argument of pragma% must be On/Off or static string "
21482 & "expression", Arg1);
21484 -- One argument string expression case
21488 Lit : constant Node_Id := Expr_Value_S (Argx);
21489 Str : constant String_Id := Strval (Lit);
21490 Len : constant Nat := String_Length (Str);
21498 while J <= Len loop
21499 C := Get_String_Char (Str, J);
21500 OK := In_Character_Range (C);
21503 Chr := Get_Character (C);
21505 -- Dash case: only -Wxxx is accepted
21512 C := Get_String_Char (Str, J);
21513 Chr := Get_Character (C);
21514 exit when Chr = 'W
';
21519 elsif J < Len and then Chr = '.' then
21521 C := Get_String_Char (Str, J);
21522 Chr := Get_Character (C);
21524 if not Set_Dot_Warning_Switch (Chr) then
21526 ("invalid warning switch character "
21527 & '.' & Chr, Arg1);
21533 OK := Set_Warning_Switch (Chr);
21539 ("invalid warning switch character " & Chr,
21548 -- Two or more arguments (must be two)
21551 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21552 Check_Arg_Count (2);
21560 E_Id := Get_Pragma_Arg (Arg2);
21563 -- In the expansion of an inlined body, a reference to
21564 -- the formal may be wrapped in a conversion if the
21565 -- actual is a conversion. Retrieve the real entity name.
21567 if (In_Instance_Body or In_Inlined_Body)
21568 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21570 E_Id := Expression (E_Id);
21573 -- Entity name case
21575 if Is_Entity_Name (E_Id) then
21576 E := Entity (E_Id);
21583 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21586 -- For OFF case, make entry in warnings off
21587 -- pragma table for later processing. But we do
21588 -- not do that within an instance, since these
21589 -- warnings are about what is needed in the
21590 -- template, not an instance of it.
21592 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21593 and then Warn_On_Warnings_Off
21594 and then not In_Instance
21596 Warnings_Off_Pragmas.Append ((N, E, Reason));
21599 if Is_Enumeration_Type (E) then
21603 Lit := First_Literal (E);
21604 while Present (Lit) loop
21605 Set_Warnings_Off (Lit);
21606 Next_Literal (Lit);
21611 exit when No (Homonym (E));
21616 -- Error if not entity or static string expression case
21618 elsif not Is_Static_String_Expression (Arg2) then
21620 ("second argument of pragma% must be entity name "
21621 & "or static string expression", Arg2);
21623 -- Static string expression case
21626 Acquire_Warning_Match_String (Arg2);
21628 -- Note on configuration pragma case: If this is a
21629 -- configuration pragma, then for an OFF pragma, we
21630 -- just set Config True in the call, which is all
21631 -- that needs to be done. For the case of ON, this
21632 -- is normally an error, unless it is canceling the
21633 -- effect of a previous OFF pragma in the same file.
21634 -- In any other case, an error will be signalled (ON
21635 -- with no matching OFF).
21637 -- Note: We set Used if we are inside a generic to
21638 -- disable the test that the non-config case actually
21639 -- cancels a warning. That's because we can't be sure
21640 -- there isn't an instantiation in some other unit
21641 -- where a warning is suppressed.
21643 -- We could do a little better here by checking if the
21644 -- generic unit we are inside is public, but for now
21645 -- we don't bother with that refinement.
21647 if Chars (Argx) = Name_Off then
21648 Set_Specific_Warning_Off
21649 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21650 Config => Is_Configuration_Pragma,
21651 Used => Inside_A_Generic or else In_Instance);
21653 elsif Chars (Argx) = Name_On then
21654 Set_Specific_Warning_On
21655 (Loc, Name_Buffer (1 .. Name_Len), Err);
21659 ("??pragma Warnings On with no matching "
21660 & "Warnings Off", Loc);
21669 -------------------
21670 -- Weak_External --
21671 -------------------
21673 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21675 when Pragma_Weak_External => Weak_External : declare
21680 Check_Arg_Count (1);
21681 Check_Optional_Identifier (Arg1, Name_Entity);
21682 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21683 Ent := Entity (Get_Pragma_Arg (Arg1));
21685 if Rep_Item_Too_Early (Ent, N) then
21688 Ent := Underlying_Type (Ent);
21691 -- The only processing required is to link this item on to the
21692 -- list of rep items for the given entity. This is accomplished
21693 -- by the call to Rep_Item_Too_Late (when no error is detected
21694 -- and False is returned).
21696 if Rep_Item_Too_Late (Ent, N) then
21699 Set_Has_Gigi_Rep_Item (Ent);
21703 -----------------------------
21704 -- Wide_Character_Encoding --
21705 -----------------------------
21707 -- pragma Wide_Character_Encoding (IDENTIFIER);
21709 when Pragma_Wide_Character_Encoding =>
21712 -- Nothing to do, handled in parser. Note that we do not enforce
21713 -- configuration pragma placement, this pragma can appear at any
21714 -- place in the source, allowing mixed encodings within a single
21719 --------------------
21720 -- Unknown_Pragma --
21721 --------------------
21723 -- Should be impossible, since the case of an unknown pragma is
21724 -- separately processed before the case statement is entered.
21726 when Unknown_Pragma =>
21727 raise Program_Error;
21730 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21731 -- until AI is formally approved.
21733 -- Check_Order_Dependence;
21736 when Pragma_Exit => null;
21737 end Analyze_Pragma;
21739 ---------------------------------------------
21740 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21741 ---------------------------------------------
21743 procedure Analyze_Pre_Post_Condition_In_Decl_Part (N : Node_Id) is
21744 procedure Process_Class_Wide_Condition
21746 Spec_Id : Entity_Id;
21747 Subp_Decl : Node_Id);
21748 -- Replace the type of all references to the controlling formal of
21749 -- subprogram Spec_Id found in expression Expr with the corresponding
21750 -- class-wide type. Subp_Decl is the subprogram [body] declaration
21751 -- where the pragma resides.
21753 ----------------------------------
21754 -- Process_Class_Wide_Condition --
21755 ----------------------------------
21757 procedure Process_Class_Wide_Condition
21759 Spec_Id : Entity_Id;
21760 Subp_Decl : Node_Id)
21762 Disp_Typ : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
21764 ACW : Entity_Id := Empty;
21765 -- Access to Disp_Typ'Class, created if there is a controlling formal
21766 -- that is an access parameter.
21768 function Access_Class_Wide_Type return Entity_Id;
21769 -- If expression Expr contains a reference to a controlling access
21770 -- parameter, create an access to Disp_Typ'Class for the necessary
21771 -- conversions if one does not exist.
21773 function Replace_Type (N : Node_Id) return Traverse_Result;
21774 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21775 -- aspect for a primitive subprogram of a tagged type Disp_Typ, a
21776 -- name that denotes a formal parameter of type Disp_Typ is treated
21777 -- as having type Disp_Typ'Class. Similarly, a name that denotes a
21778 -- formal access parameter of type access-to-Disp_Typ is interpreted
21779 -- as with type access-to-Disp_Typ'Class. This ensures the expression
21780 -- is well defined for a primitive subprogram of a type descended
21783 ----------------------------
21784 -- Access_Class_Wide_Type --
21785 ----------------------------
21787 function Access_Class_Wide_Type return Entity_Id is
21788 Loc : constant Source_Ptr := Sloc (N);
21792 ACW := Make_Temporary (Loc, 'T
');
21794 Insert_Before_And_Analyze (Subp_Decl,
21795 Make_Full_Type_Declaration (Loc,
21796 Defining_Identifier => ACW,
21798 Make_Access_To_Object_Definition (Loc,
21799 Subtype_Indication =>
21800 New_Occurrence_Of (Class_Wide_Type (Disp_Typ), Loc),
21801 All_Present => True)));
21803 Freeze_Before (Subp_Decl, ACW);
21807 end Access_Class_Wide_Type;
21813 function Replace_Type (N : Node_Id) return Traverse_Result is
21814 Context : constant Node_Id := Parent (N);
21815 Loc : constant Source_Ptr := Sloc (N);
21816 CW_Typ : Entity_Id := Empty;
21821 if Is_Entity_Name (N)
21822 and then Present (Entity (N))
21823 and then Is_Formal (Entity (N))
21826 Typ := Etype (Ent);
21828 -- Do not perform the type replacement for selector names in
21829 -- parameter associations. These carry an entity for reference
21830 -- purposes, but semantically they are just identifiers.
21832 if Nkind (Context) = N_Type_Conversion then
21835 elsif Nkind (Context) = N_Parameter_Association
21836 and then Selector_Name (Context) = N
21840 elsif Typ = Disp_Typ then
21841 CW_Typ := Class_Wide_Type (Typ);
21843 elsif Is_Access_Type (Typ)
21844 and then Designated_Type (Typ) = Disp_Typ
21846 CW_Typ := Access_Class_Wide_Type;
21849 if Present (CW_Typ) then
21851 Make_Type_Conversion (Loc,
21852 Subtype_Mark => New_Occurrence_Of (CW_Typ, Loc),
21853 Expression => New_Occurrence_Of (Ent, Loc)));
21854 Set_Etype (N, CW_Typ);
21861 procedure Replace_Types is new Traverse_Proc (Replace_Type);
21863 -- Start of processing for Process_Class_Wide_Condition
21866 -- The subprogram subject to Pre'Class/Post'Class does not have a
21867 -- dispatching type, therefore the aspect/pragma is illegal.
21869 if No (Disp_Typ) then
21870 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
21872 if From_Aspect_Specification (N) then
21874 ("aspect % can only be specified for a primitive operation "
21875 & "of a tagged type", Corresponding_Aspect (N));
21877 -- The pragma is a source construct
21881 ("pragma % can only be specified for a primitive operation "
21882 & "of a tagged type", N);
21886 Replace_Types (Expr);
21887 end Process_Class_Wide_Condition;
21891 Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
21892 Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl);
21893 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
21895 Restore_Scope : Boolean := False;
21897 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
21900 -- Ensure that the subprogram and its formals are visible when analyzing
21901 -- the expression of the pragma.
21903 if not In_Open_Scopes (Spec_Id) then
21904 Restore_Scope := True;
21905 Push_Scope (Spec_Id);
21907 if Is_Generic_Subprogram (Spec_Id) then
21908 Install_Generic_Formals (Spec_Id);
21910 Install_Formals (Spec_Id);
21914 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21916 -- For a class-wide condition, a reference to a controlling formal must
21917 -- be interpreted as having the class-wide type (or an access to such)
21918 -- so that the inherited condition can be properly applied to any
21919 -- overriding operation (see ARM12 6.6.1 (7)).
21921 if Class_Present (N) then
21922 Process_Class_Wide_Condition (Expr, Spec_Id, Subp_Decl);
21925 if Restore_Scope then
21929 -- Currently it is not possible to inline pre/postconditions on a
21930 -- subprogram subject to pragma Inline_Always.
21932 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
21933 end Analyze_Pre_Post_Condition_In_Decl_Part;
21935 ------------------------------------------
21936 -- Analyze_Refined_Depends_In_Decl_Part --
21937 ------------------------------------------
21939 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21940 Body_Inputs : Elist_Id := No_Elist;
21941 Body_Outputs : Elist_Id := No_Elist;
21942 -- The inputs and outputs of the subprogram body synthesized from pragma
21943 -- Refined_Depends.
21945 Dependencies : List_Id := No_List;
21947 -- The corresponding Depends pragma along with its clauses
21949 Matched_Items : Elist_Id := No_Elist;
21950 -- A list containing the entities of all successfully matched items
21951 -- found in pragma Depends.
21953 Refinements : List_Id := No_List;
21954 -- The clauses of pragma Refined_Depends
21956 Spec_Id : Entity_Id;
21957 -- The entity of the subprogram subject to pragma Refined_Depends
21959 Spec_Inputs : Elist_Id := No_Elist;
21960 Spec_Outputs : Elist_Id := No_Elist;
21961 -- The inputs and outputs of the subprogram spec synthesized from pragma
21964 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21965 -- Try to match a single dependency clause Dep_Clause against one or
21966 -- more refinement clauses found in list Refinements. Each successful
21967 -- match eliminates at least one refinement clause from Refinements.
21969 procedure Check_Output_States;
21970 -- Determine whether pragma Depends contains an output state with a
21971 -- visible refinement and if so, ensure that pragma Refined_Depends
21972 -- mentions all its constituents as outputs.
21974 procedure Normalize_Clauses (Clauses : List_Id);
21975 -- Given a list of dependence or refinement clauses Clauses, normalize
21976 -- each clause by creating multiple dependencies with exactly one input
21979 procedure Report_Extra_Clauses;
21980 -- Emit an error for each extra clause found in list Refinements
21982 -----------------------------
21983 -- Check_Dependency_Clause --
21984 -----------------------------
21986 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21987 Dep_Input : constant Node_Id := Expression (Dep_Clause);
21988 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21990 function Is_In_Out_State_Clause return Boolean;
21991 -- Determine whether dependence clause Dep_Clause denotes an abstract
21992 -- state that depends on itself (State => State).
21994 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
21995 -- Determine whether item Item denotes an abstract state with visible
21996 -- null refinement.
21998 procedure Match_Items
21999 (Dep_Item : Node_Id;
22000 Ref_Item : Node_Id;
22001 Matched : out Boolean);
22002 -- Try to match dependence item Dep_Item against refinement item
22003 -- Ref_Item. To match against a possible null refinement (see 2, 7),
22004 -- set Ref_Item to Empty. Flag Matched is set to True when one of
22005 -- the following conformance scenarios is in effect:
22006 -- 1) Both items denote null
22007 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
22008 -- 3) Both items denote attribute 'Result
22009 -- 4) Both items denote the same formal parameter
22010 -- 5) Both items denote the same object
22011 -- 6) Dep_Item is an abstract state with visible null refinement
22012 -- and Ref_Item denotes null.
22013 -- 7) Dep_Item is an abstract state with visible null refinement
22014 -- and Ref_Item is Empty (special case).
22015 -- 8) Dep_Item is an abstract state with visible non-null
22016 -- refinement and Ref_Item denotes one of its constituents.
22017 -- 9) Dep_Item is an abstract state without a visible refinement
22018 -- and Ref_Item denotes the same state.
22019 -- When scenario 8 is in effect, the entity of the abstract state
22020 -- denoted by Dep_Item is added to list Refined_States.
22022 procedure Record_Item
(Item_Id
: Entity_Id
);
22023 -- Store the entity of an item denoted by Item_Id in Matched_Items
22025 ----------------------------
22026 -- Is_In_Out_State_Clause --
22027 ----------------------------
22029 function Is_In_Out_State_Clause
return Boolean is
22030 Dep_Input_Id
: Entity_Id
;
22031 Dep_Output_Id
: Entity_Id
;
22034 -- Detect the following clause:
22037 if Is_Entity_Name
(Dep_Input
)
22038 and then Is_Entity_Name
(Dep_Output
)
22040 -- Handle abstract views generated for limited with clauses
22042 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
22043 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
22046 Ekind
(Dep_Input_Id
) = E_Abstract_State
22047 and then Dep_Input_Id
= Dep_Output_Id
;
22051 end Is_In_Out_State_Clause
;
22053 ---------------------------
22054 -- Is_Null_Refined_State --
22055 ---------------------------
22057 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
22058 Item_Id
: Entity_Id
;
22061 if Is_Entity_Name
(Item
) then
22063 -- Handle abstract views generated for limited with clauses
22065 Item_Id
:= Available_View
(Entity_Of
(Item
));
22067 return Ekind
(Item_Id
) = E_Abstract_State
22068 and then Has_Null_Refinement
(Item_Id
);
22073 end Is_Null_Refined_State
;
22079 procedure Match_Items
22080 (Dep_Item
: Node_Id
;
22081 Ref_Item
: Node_Id
;
22082 Matched
: out Boolean)
22084 Dep_Item_Id
: Entity_Id
;
22085 Ref_Item_Id
: Entity_Id
;
22088 -- Assume that the two items do not match
22092 -- A null matches null or Empty (special case)
22094 if Nkind
(Dep_Item
) = N_Null
22095 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
22099 -- Attribute 'Result matches attribute 'Result
22101 elsif Is_Attribute_Result
(Dep_Item
)
22102 and then Is_Attribute_Result
(Dep_Item
)
22106 -- Abstract states, formal parameters and objects
22108 elsif Is_Entity_Name
(Dep_Item
) then
22110 -- Handle abstract views generated for limited with clauses
22112 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
22114 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
22116 -- An abstract state with visible null refinement matches
22117 -- null or Empty (special case).
22119 if Has_Null_Refinement
(Dep_Item_Id
)
22120 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
22122 Record_Item
(Dep_Item_Id
);
22125 -- An abstract state with visible non-null refinement
22126 -- matches one of its constituents.
22128 elsif Has_Non_Null_Refinement
(Dep_Item_Id
) then
22129 if Is_Entity_Name
(Ref_Item
) then
22130 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
22132 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
22135 and then Present
(Encapsulating_State
(Ref_Item_Id
))
22136 and then Encapsulating_State
(Ref_Item_Id
) =
22139 Record_Item
(Dep_Item_Id
);
22144 -- An abstract state without a visible refinement matches
22147 elsif Is_Entity_Name
(Ref_Item
)
22148 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22150 Record_Item
(Dep_Item_Id
);
22154 -- A formal parameter or an object matches itself
22156 elsif Is_Entity_Name
(Ref_Item
)
22157 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22159 Record_Item
(Dep_Item_Id
);
22169 procedure Record_Item
(Item_Id
: Entity_Id
) is
22171 if not Contains
(Matched_Items
, Item_Id
) then
22172 Add_Item
(Item_Id
, Matched_Items
);
22178 Clause_Matched
: Boolean := False;
22179 Dummy
: Boolean := False;
22180 Inputs_Match
: Boolean;
22181 Next_Ref_Clause
: Node_Id
;
22182 Outputs_Match
: Boolean;
22183 Ref_Clause
: Node_Id
;
22184 Ref_Input
: Node_Id
;
22185 Ref_Output
: Node_Id
;
22187 -- Start of processing for Check_Dependency_Clause
22190 -- Do not perform this check in an instance because it was already
22191 -- performed successfully in the generic template.
22193 if Is_Generic_Instance
(Spec_Id
) then
22197 -- Examine all refinement clauses and compare them against the
22198 -- dependence clause.
22200 Ref_Clause
:= First
(Refinements
);
22201 while Present
(Ref_Clause
) loop
22202 Next_Ref_Clause
:= Next
(Ref_Clause
);
22204 -- Obtain the attributes of the current refinement clause
22206 Ref_Input
:= Expression
(Ref_Clause
);
22207 Ref_Output
:= First
(Choices
(Ref_Clause
));
22209 -- The current refinement clause matches the dependence clause
22210 -- when both outputs match and both inputs match. See routine
22211 -- Match_Items for all possible conformance scenarios.
22213 -- Depends Dep_Output => Dep_Input
22217 -- Refined_Depends Ref_Output => Ref_Input
22220 (Dep_Item
=> Dep_Input
,
22221 Ref_Item
=> Ref_Input
,
22222 Matched
=> Inputs_Match
);
22225 (Dep_Item
=> Dep_Output
,
22226 Ref_Item
=> Ref_Output
,
22227 Matched
=> Outputs_Match
);
22229 -- An In_Out state clause may be matched against a refinement with
22230 -- a null input or null output as long as the non-null side of the
22231 -- relation contains a valid constituent of the In_Out_State.
22233 if Is_In_Out_State_Clause
then
22235 -- Depends => (State => State)
22236 -- Refined_Depends => (null => Constit) -- OK
22239 and then not Outputs_Match
22240 and then Nkind
(Ref_Output
) = N_Null
22242 Outputs_Match
:= True;
22245 -- Depends => (State => State)
22246 -- Refined_Depends => (Constit => null) -- OK
22248 if not Inputs_Match
22249 and then Outputs_Match
22250 and then Nkind
(Ref_Input
) = N_Null
22252 Inputs_Match
:= True;
22256 -- The current refinement clause is legally constructed following
22257 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
22258 -- the pool of candidates. The seach continues because a single
22259 -- dependence clause may have multiple matching refinements.
22261 if Inputs_Match
and then Outputs_Match
then
22262 Clause_Matched
:= True;
22263 Remove
(Ref_Clause
);
22266 Ref_Clause
:= Next_Ref_Clause
;
22269 -- Depending on the order or composition of refinement clauses, an
22270 -- In_Out state clause may not be directly refinable.
22272 -- Depends => ((Output, State) => (Input, State))
22273 -- Refined_State => (State => (Constit_1, Constit_2))
22274 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
22276 -- Matching normalized clause (State => State) fails because there is
22277 -- no direct refinement capable of satisfying this relation. Another
22278 -- similar case arises when clauses (Constit_1 => Input) and (Output
22279 -- => Constit_2) are matched first, leaving no candidates for clause
22280 -- (State => State). Both scenarios are legal as long as one of the
22281 -- previous clauses mentioned a valid constituent of State.
22283 if not Clause_Matched
22284 and then Is_In_Out_State_Clause
22286 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22288 Clause_Matched
:= True;
22291 -- A clause where the input is an abstract state with visible null
22292 -- refinement is implicitly matched when the output has already been
22293 -- matched in a previous clause.
22295 -- Depends => (Output => State) -- implicitly OK
22296 -- Refined_State => (State => null)
22297 -- Refined_Depends => (Output => ...)
22299 if not Clause_Matched
22300 and then Is_Null_Refined_State
(Dep_Input
)
22301 and then Is_Entity_Name
(Dep_Output
)
22303 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
22305 Clause_Matched
:= True;
22308 -- A clause where the output is an abstract state with visible null
22309 -- refinement is implicitly matched when the input has already been
22310 -- matched in a previous clause.
22312 -- Depends => (State => Input) -- implicitly OK
22313 -- Refined_State => (State => null)
22314 -- Refined_Depends => (... => Input)
22316 if not Clause_Matched
22317 and then Is_Null_Refined_State
(Dep_Output
)
22318 and then Is_Entity_Name
(Dep_Input
)
22320 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22322 Clause_Matched
:= True;
22325 -- At this point either all refinement clauses have been examined or
22326 -- pragma Refined_Depends contains a solitary null. Only an abstract
22327 -- state with null refinement can possibly match these cases.
22329 -- Depends => (State => null)
22330 -- Refined_State => (State => null)
22331 -- Refined_Depends => null -- OK
22333 if not Clause_Matched
then
22335 (Dep_Item
=> Dep_Input
,
22337 Matched
=> Inputs_Match
);
22340 (Dep_Item
=> Dep_Output
,
22342 Matched
=> Outputs_Match
);
22344 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
22347 -- If the contents of Refined_Depends are legal, then the current
22348 -- dependence clause should be satisfied either by an explicit match
22349 -- or by one of the special cases.
22351 if not Clause_Matched
then
22353 ("dependence clause of subprogram & has no matching refinement "
22354 & "in body", Dep_Clause
, Spec_Id
);
22356 end Check_Dependency_Clause
;
22358 -------------------------
22359 -- Check_Output_States --
22360 -------------------------
22362 procedure Check_Output_States
is
22363 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22364 -- Determine whether all constituents of state State_Id with visible
22365 -- refinement are used as outputs in pragma Refined_Depends. Emit an
22366 -- error if this is not the case.
22368 -----------------------------
22369 -- Check_Constituent_Usage --
22370 -----------------------------
22372 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22373 Constit_Elmt
: Elmt_Id
;
22374 Constit_Id
: Entity_Id
;
22375 Posted
: Boolean := False;
22378 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22379 while Present
(Constit_Elmt
) loop
22380 Constit_Id
:= Node
(Constit_Elmt
);
22382 -- The constituent acts as an input (SPARK RM 7.2.5(3))
22384 if Present
(Body_Inputs
)
22385 and then Appears_In
(Body_Inputs
, Constit_Id
)
22387 Error_Msg_Name_1
:= Chars
(State_Id
);
22389 ("constituent & of state % must act as output in "
22390 & "dependence refinement", N
, Constit_Id
);
22392 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22394 elsif No
(Body_Outputs
)
22395 or else not Appears_In
(Body_Outputs
, Constit_Id
)
22400 ("output state & must be replaced by all its "
22401 & "constituents in dependence refinement",
22406 ("\constituent & is missing in output list",
22410 Next_Elmt
(Constit_Elmt
);
22412 end Check_Constituent_Usage
;
22417 Item_Elmt
: Elmt_Id
;
22418 Item_Id
: Entity_Id
;
22420 -- Start of processing for Check_Output_States
22423 -- Do not perform this check in an instance because it was already
22424 -- performed successfully in the generic template.
22426 if Is_Generic_Instance
(Spec_Id
) then
22429 -- Inspect the outputs of pragma Depends looking for a state with a
22430 -- visible refinement.
22432 elsif Present
(Spec_Outputs
) then
22433 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
22434 while Present
(Item_Elmt
) loop
22435 Item
:= Node
(Item_Elmt
);
22437 -- Deal with the mixed nature of the input and output lists
22439 if Nkind
(Item
) = N_Defining_Identifier
then
22442 Item_Id
:= Available_View
(Entity_Of
(Item
));
22445 if Ekind
(Item_Id
) = E_Abstract_State
then
22447 -- The state acts as an input-output, skip it
22449 if Present
(Spec_Inputs
)
22450 and then Appears_In
(Spec_Inputs
, Item_Id
)
22454 -- Ensure that all of the constituents are utilized as
22455 -- outputs in pragma Refined_Depends.
22457 elsif Has_Non_Null_Refinement
(Item_Id
) then
22458 Check_Constituent_Usage
(Item_Id
);
22462 Next_Elmt
(Item_Elmt
);
22465 end Check_Output_States
;
22467 -----------------------
22468 -- Normalize_Clauses --
22469 -----------------------
22471 procedure Normalize_Clauses
(Clauses
: List_Id
) is
22472 procedure Normalize_Inputs
(Clause
: Node_Id
);
22473 -- Normalize clause Clause by creating multiple clauses for each
22474 -- input item of Clause. It is assumed that Clause has exactly one
22475 -- output. The transformation is as follows:
22477 -- Output => (Input_1, Input_2) -- original
22479 -- Output => Input_1 -- normalizations
22480 -- Output => Input_2
22482 procedure Normalize_Outputs
(Clause
: Node_Id
);
22483 -- Normalize clause Clause by creating multiple clause for each
22484 -- output item of Clause. The transformation is as follows:
22486 -- (Output_1, Output_2) => Input -- original
22488 -- Output_1 => Input -- normalization
22489 -- Output_2 => Input
22491 ----------------------
22492 -- Normalize_Inputs --
22493 ----------------------
22495 procedure Normalize_Inputs
(Clause
: Node_Id
) is
22496 Inputs
: constant Node_Id
:= Expression
(Clause
);
22497 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22498 Output
: constant List_Id
:= Choices
(Clause
);
22499 Last_Input
: Node_Id
;
22501 New_Clause
: Node_Id
;
22502 Next_Input
: Node_Id
;
22505 -- Normalization is performed only when the original clause has
22506 -- more than one input. Multiple inputs appear as an aggregate.
22508 if Nkind
(Inputs
) = N_Aggregate
then
22509 Last_Input
:= Last
(Expressions
(Inputs
));
22511 -- Create a new clause for each input
22513 Input
:= First
(Expressions
(Inputs
));
22514 while Present
(Input
) loop
22515 Next_Input
:= Next
(Input
);
22517 -- Unhook the current input from the original input list
22518 -- because it will be relocated to a new clause.
22522 -- Special processing for the last input. At this point the
22523 -- original aggregate has been stripped down to one element.
22524 -- Replace the aggregate by the element itself.
22526 if Input
= Last_Input
then
22527 Rewrite
(Inputs
, Input
);
22529 -- Generate a clause of the form:
22534 Make_Component_Association
(Loc
,
22535 Choices
=> New_Copy_List_Tree
(Output
),
22536 Expression
=> Input
);
22538 -- The new clause contains replicated content that has
22539 -- already been analyzed, mark the clause as analyzed.
22541 Set_Analyzed
(New_Clause
);
22542 Insert_After
(Clause
, New_Clause
);
22545 Input
:= Next_Input
;
22548 end Normalize_Inputs
;
22550 -----------------------
22551 -- Normalize_Outputs --
22552 -----------------------
22554 procedure Normalize_Outputs
(Clause
: Node_Id
) is
22555 Inputs
: constant Node_Id
:= Expression
(Clause
);
22556 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22557 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
22558 Last_Output
: Node_Id
;
22559 New_Clause
: Node_Id
;
22560 Next_Output
: Node_Id
;
22564 -- Multiple outputs appear as an aggregate. Nothing to do when
22565 -- the clause has exactly one output.
22567 if Nkind
(Outputs
) = N_Aggregate
then
22568 Last_Output
:= Last
(Expressions
(Outputs
));
22570 -- Create a clause for each output. Note that each time a new
22571 -- clause is created, the original output list slowly shrinks
22572 -- until there is one item left.
22574 Output
:= First
(Expressions
(Outputs
));
22575 while Present
(Output
) loop
22576 Next_Output
:= Next
(Output
);
22578 -- Unhook the output from the original output list as it
22579 -- will be relocated to a new clause.
22583 -- Special processing for the last output. At this point
22584 -- the original aggregate has been stripped down to one
22585 -- element. Replace the aggregate by the element itself.
22587 if Output
= Last_Output
then
22588 Rewrite
(Outputs
, Output
);
22591 -- Generate a clause of the form:
22592 -- (Output => Inputs)
22595 Make_Component_Association
(Loc
,
22596 Choices
=> New_List
(Output
),
22597 Expression
=> New_Copy_Tree
(Inputs
));
22599 -- The new clause contains replicated content that has
22600 -- already been analyzed. There is not need to reanalyze
22603 Set_Analyzed
(New_Clause
);
22604 Insert_After
(Clause
, New_Clause
);
22607 Output
:= Next_Output
;
22610 end Normalize_Outputs
;
22616 -- Start of processing for Normalize_Clauses
22619 Clause
:= First
(Clauses
);
22620 while Present
(Clause
) loop
22621 Normalize_Outputs
(Clause
);
22625 Clause
:= First
(Clauses
);
22626 while Present
(Clause
) loop
22627 Normalize_Inputs
(Clause
);
22630 end Normalize_Clauses
;
22632 --------------------------
22633 -- Report_Extra_Clauses --
22634 --------------------------
22636 procedure Report_Extra_Clauses
is
22640 -- Do not perform this check in an instance because it was already
22641 -- performed successfully in the generic template.
22643 if Is_Generic_Instance
(Spec_Id
) then
22646 elsif Present
(Refinements
) then
22647 Clause
:= First
(Refinements
);
22648 while Present
(Clause
) loop
22650 -- Do not complain about a null input refinement, since a null
22651 -- input legitimately matches anything.
22653 if Nkind
(Clause
) = N_Component_Association
22654 and then Nkind
(Expression
(Clause
)) = N_Null
22660 ("unmatched or extra clause in dependence refinement",
22667 end Report_Extra_Clauses
;
22671 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22672 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
22673 Errors
: constant Nat
:= Serious_Errors_Detected
;
22679 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22682 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22683 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22685 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22688 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
22690 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22691 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22693 if No
(Depends
) then
22695 ("useless refinement, declaration of subprogram & lacks aspect or "
22696 & "pragma Depends", N
, Spec_Id
);
22700 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
22702 -- A null dependency relation renders the refinement useless because it
22703 -- cannot possibly mention abstract states with visible refinement. Note
22704 -- that the inverse is not true as states may be refined to null
22705 -- (SPARK RM 7.2.5(2)).
22707 if Nkind
(Deps
) = N_Null
then
22709 ("useless refinement, subprogram & does not depend on abstract "
22710 & "state with visible refinement", N
, Spec_Id
);
22714 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22715 -- This ensures that the categorization of all refined dependency items
22716 -- is consistent with their role.
22718 Analyze_Depends_In_Decl_Part
(N
);
22720 -- Do not match dependencies against refinements if Refined_Depends is
22721 -- illegal to avoid emitting misleading error.
22723 if Serious_Errors_Detected
= Errors
then
22725 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
22726 -- the inputs and outputs of the subprogram spec and body to verify
22727 -- the use of states with visible refinement and their constituents.
22729 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
22730 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
22732 Collect_Subprogram_Inputs_Outputs
22733 (Subp_Id
=> Spec_Id
,
22734 Synthesize
=> True,
22735 Subp_Inputs
=> Spec_Inputs
,
22736 Subp_Outputs
=> Spec_Outputs
,
22737 Global_Seen
=> Dummy
);
22739 Collect_Subprogram_Inputs_Outputs
22740 (Subp_Id
=> Body_Id
,
22741 Synthesize
=> True,
22742 Subp_Inputs
=> Body_Inputs
,
22743 Subp_Outputs
=> Body_Outputs
,
22744 Global_Seen
=> Dummy
);
22746 -- For an output state with a visible refinement, ensure that all
22747 -- constituents appear as outputs in the dependency refinement.
22749 Check_Output_States
;
22752 -- Matching is disabled in ASIS because clauses are not normalized as
22753 -- this is a tree altering activity similar to expansion.
22759 -- Multiple dependency clauses appear as component associations of an
22760 -- aggregate. Note that the clauses are copied because the algorithm
22761 -- modifies them and this should not be visible in Depends.
22763 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
22764 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
22765 Normalize_Clauses
(Dependencies
);
22767 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
22769 if Nkind
(Refs
) = N_Null
then
22770 Refinements
:= No_List
;
22772 -- Multiple dependency clauses appear as component associations of an
22773 -- aggregate. Note that the clauses are copied because the algorithm
22774 -- modifies them and this should not be visible in Refined_Depends.
22776 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
22777 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
22778 Normalize_Clauses
(Refinements
);
22781 -- At this point the clauses of pragmas Depends and Refined_Depends
22782 -- have been normalized into simple dependencies between one output
22783 -- and one input. Examine all clauses of pragma Depends looking for
22784 -- matching clauses in pragma Refined_Depends.
22786 Clause
:= First
(Dependencies
);
22787 while Present
(Clause
) loop
22788 Check_Dependency_Clause
(Clause
);
22792 if Serious_Errors_Detected
= Errors
then
22793 Report_Extra_Clauses
;
22796 end Analyze_Refined_Depends_In_Decl_Part
;
22798 -----------------------------------------
22799 -- Analyze_Refined_Global_In_Decl_Part --
22800 -----------------------------------------
22802 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
22804 -- The corresponding Global pragma
22806 Has_In_State
: Boolean := False;
22807 Has_In_Out_State
: Boolean := False;
22808 Has_Out_State
: Boolean := False;
22809 Has_Proof_In_State
: Boolean := False;
22810 -- These flags are set when the corresponding Global pragma has a state
22811 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22814 Has_Null_State
: Boolean := False;
22815 -- This flag is set when the corresponding Global pragma has at least
22816 -- one state with a null refinement.
22818 In_Constits
: Elist_Id
:= No_Elist
;
22819 In_Out_Constits
: Elist_Id
:= No_Elist
;
22820 Out_Constits
: Elist_Id
:= No_Elist
;
22821 Proof_In_Constits
: Elist_Id
:= No_Elist
;
22822 -- These lists contain the entities of all Input, In_Out, Output and
22823 -- Proof_In constituents that appear in Refined_Global and participate
22824 -- in state refinement.
22826 In_Items
: Elist_Id
:= No_Elist
;
22827 In_Out_Items
: Elist_Id
:= No_Elist
;
22828 Out_Items
: Elist_Id
:= No_Elist
;
22829 Proof_In_Items
: Elist_Id
:= No_Elist
;
22830 -- These list contain the entities of all Input, In_Out, Output and
22831 -- Proof_In items defined in the corresponding Global pragma.
22833 Spec_Id
: Entity_Id
;
22834 -- The entity of the subprogram subject to pragma Refined_Global
22836 procedure Check_In_Out_States
;
22837 -- Determine whether the corresponding Global pragma mentions In_Out
22838 -- states with visible refinement and if so, ensure that one of the
22839 -- following completions apply to the constituents of the state:
22840 -- 1) there is at least one constituent of mode In_Out
22841 -- 2) there is at least one Input and one Output constituent
22842 -- 3) not all constituents are present and one of them is of mode
22844 -- This routine may remove elements from In_Constits, In_Out_Constits,
22845 -- Out_Constits and Proof_In_Constits.
22847 procedure Check_Input_States
;
22848 -- Determine whether the corresponding Global pragma mentions Input
22849 -- states with visible refinement and if so, ensure that at least one of
22850 -- its constituents appears as an Input item in Refined_Global.
22851 -- This routine may remove elements from In_Constits, In_Out_Constits,
22852 -- Out_Constits and Proof_In_Constits.
22854 procedure Check_Output_States
;
22855 -- Determine whether the corresponding Global pragma mentions Output
22856 -- states with visible refinement and if so, ensure that all of its
22857 -- constituents appear as Output items in Refined_Global.
22858 -- This routine may remove elements from In_Constits, In_Out_Constits,
22859 -- Out_Constits and Proof_In_Constits.
22861 procedure Check_Proof_In_States
;
22862 -- Determine whether the corresponding Global pragma mentions Proof_In
22863 -- states with visible refinement and if so, ensure that at least one of
22864 -- its constituents appears as a Proof_In item in Refined_Global.
22865 -- This routine may remove elements from In_Constits, In_Out_Constits,
22866 -- Out_Constits and Proof_In_Constits.
22868 procedure Check_Refined_Global_List
22870 Global_Mode
: Name_Id
:= Name_Input
);
22871 -- Verify the legality of a single global list declaration. Global_Mode
22872 -- denotes the current mode in effect.
22874 procedure Collect_Global_Items
22876 Mode
: Name_Id
:= Name_Input
);
22877 -- Gather all input, in out, output and Proof_In items from node List
22878 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
22879 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
22880 -- and Has_Proof_In_State are set when there is at least one abstract
22881 -- state with visible refinement available in the corresponding mode.
22882 -- Flag Has_Null_State is set when at least state has a null refinement.
22883 -- Mode enotes the current global mode in effect.
22885 function Present_Then_Remove
22887 Item
: Entity_Id
) return Boolean;
22888 -- Search List for a particular entity Item. If Item has been found,
22889 -- remove it from List. This routine is used to strip lists In_Constits,
22890 -- In_Out_Constits and Out_Constits of valid constituents.
22892 procedure Report_Extra_Constituents
;
22893 -- Emit an error for each constituent found in lists In_Constits,
22894 -- In_Out_Constits and Out_Constits.
22896 -------------------------
22897 -- Check_In_Out_States --
22898 -------------------------
22900 procedure Check_In_Out_States
is
22901 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22902 -- Determine whether one of the following coverage scenarios is in
22904 -- 1) there is at least one constituent of mode In_Out
22905 -- 2) there is at least one Input and one Output constituent
22906 -- 3) not all constituents are present and one of them is of mode
22908 -- If this is not the case, emit an error.
22910 -----------------------------
22911 -- Check_Constituent_Usage --
22912 -----------------------------
22914 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22915 Constit_Elmt
: Elmt_Id
;
22916 Constit_Id
: Entity_Id
;
22917 Has_Missing
: Boolean := False;
22918 In_Out_Seen
: Boolean := False;
22919 In_Seen
: Boolean := False;
22920 Out_Seen
: Boolean := False;
22923 -- Process all the constituents of the state and note their modes
22924 -- within the global refinement.
22926 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22927 while Present
(Constit_Elmt
) loop
22928 Constit_Id
:= Node
(Constit_Elmt
);
22930 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22933 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22934 In_Out_Seen
:= True;
22936 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22939 -- A Proof_In constituent cannot participate in the completion
22940 -- of an Output state (SPARK RM 7.2.4(5)).
22942 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22943 Error_Msg_Name_1
:= Chars
(State_Id
);
22945 ("constituent & of state % must have mode Input, In_Out "
22946 & "or Output in global refinement", N
, Constit_Id
);
22949 Has_Missing
:= True;
22952 Next_Elmt
(Constit_Elmt
);
22955 -- A single In_Out constituent is a valid completion
22957 if In_Out_Seen
then
22960 -- A pair of one Input and one Output constituent is a valid
22963 elsif In_Seen
and then Out_Seen
then
22966 -- A single Output constituent is a valid completion only when
22967 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22969 elsif Has_Missing
and then Out_Seen
then
22974 ("global refinement of state & redefines the mode of its "
22975 & "constituents", N
, State_Id
);
22977 end Check_Constituent_Usage
;
22981 Item_Elmt
: Elmt_Id
;
22982 Item_Id
: Entity_Id
;
22984 -- Start of processing for Check_In_Out_States
22987 -- Do not perform this check in an instance because it was already
22988 -- performed successfully in the generic template.
22990 if Is_Generic_Instance
(Spec_Id
) then
22993 -- Inspect the In_Out items of the corresponding Global pragma
22994 -- looking for a state with a visible refinement.
22996 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
22997 Item_Elmt
:= First_Elmt
(In_Out_Items
);
22998 while Present
(Item_Elmt
) loop
22999 Item_Id
:= Node
(Item_Elmt
);
23001 -- Ensure that one of the three coverage variants is satisfied
23003 if Ekind
(Item_Id
) = E_Abstract_State
23004 and then Has_Non_Null_Refinement
(Item_Id
)
23006 Check_Constituent_Usage
(Item_Id
);
23009 Next_Elmt
(Item_Elmt
);
23012 end Check_In_Out_States
;
23014 ------------------------
23015 -- Check_Input_States --
23016 ------------------------
23018 procedure Check_Input_States
is
23019 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23020 -- Determine whether at least one constituent of state State_Id with
23021 -- visible refinement is used and has mode Input. Ensure that the
23022 -- remaining constituents do not have In_Out, Output or Proof_In
23025 -----------------------------
23026 -- Check_Constituent_Usage --
23027 -----------------------------
23029 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23030 Constit_Elmt
: Elmt_Id
;
23031 Constit_Id
: Entity_Id
;
23032 In_Seen
: Boolean := False;
23035 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23036 while Present
(Constit_Elmt
) loop
23037 Constit_Id
:= Node
(Constit_Elmt
);
23039 -- At least one of the constituents appears as an Input
23041 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
23044 -- The constituent appears in the global refinement, but has
23045 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
23047 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23048 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
23049 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
23051 Error_Msg_Name_1
:= Chars
(State_Id
);
23053 ("constituent & of state % must have mode Input in global "
23054 & "refinement", N
, Constit_Id
);
23057 Next_Elmt
(Constit_Elmt
);
23060 -- Not one of the constituents appeared as Input
23062 if not In_Seen
then
23064 ("global refinement of state & must include at least one "
23065 & "constituent of mode Input", N
, State_Id
);
23067 end Check_Constituent_Usage
;
23071 Item_Elmt
: Elmt_Id
;
23072 Item_Id
: Entity_Id
;
23074 -- Start of processing for Check_Input_States
23077 -- Do not perform this check in an instance because it was already
23078 -- performed successfully in the generic template.
23080 if Is_Generic_Instance
(Spec_Id
) then
23083 -- Inspect the Input items of the corresponding Global pragma looking
23084 -- for a state with a visible refinement.
23086 elsif Has_In_State
and then Present
(In_Items
) then
23087 Item_Elmt
:= First_Elmt
(In_Items
);
23088 while Present
(Item_Elmt
) loop
23089 Item_Id
:= Node
(Item_Elmt
);
23091 -- Ensure that at least one of the constituents is utilized and
23092 -- is of mode Input.
23094 if Ekind
(Item_Id
) = E_Abstract_State
23095 and then Has_Non_Null_Refinement
(Item_Id
)
23097 Check_Constituent_Usage
(Item_Id
);
23100 Next_Elmt
(Item_Elmt
);
23103 end Check_Input_States
;
23105 -------------------------
23106 -- Check_Output_States --
23107 -------------------------
23109 procedure Check_Output_States
is
23110 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23111 -- Determine whether all constituents of state State_Id with visible
23112 -- refinement are used and have mode Output. Emit an error if this is
23115 -----------------------------
23116 -- Check_Constituent_Usage --
23117 -----------------------------
23119 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23120 Constit_Elmt
: Elmt_Id
;
23121 Constit_Id
: Entity_Id
;
23122 Posted
: Boolean := False;
23125 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23126 while Present
(Constit_Elmt
) loop
23127 Constit_Id
:= Node
(Constit_Elmt
);
23129 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
23132 -- The constituent appears in the global refinement, but has
23133 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
23135 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23136 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23137 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
23139 Error_Msg_Name_1
:= Chars
(State_Id
);
23141 ("constituent & of state % must have mode Output in "
23142 & "global refinement", N
, Constit_Id
);
23144 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23150 ("output state & must be replaced by all its "
23151 & "constituents in global refinement", N
, State_Id
);
23155 ("\constituent & is missing in output list",
23159 Next_Elmt
(Constit_Elmt
);
23161 end Check_Constituent_Usage
;
23165 Item_Elmt
: Elmt_Id
;
23166 Item_Id
: Entity_Id
;
23168 -- Start of processing for Check_Output_States
23171 -- Do not perform this check in an instance because it was already
23172 -- performed successfully in the generic template.
23174 if Is_Generic_Instance
(Spec_Id
) then
23177 -- Inspect the Output items of the corresponding Global pragma
23178 -- looking for a state with a visible refinement.
23180 elsif Has_Out_State
and then Present
(Out_Items
) then
23181 Item_Elmt
:= First_Elmt
(Out_Items
);
23182 while Present
(Item_Elmt
) loop
23183 Item_Id
:= Node
(Item_Elmt
);
23185 -- Ensure that all of the constituents are utilized and they
23186 -- have mode Output.
23188 if Ekind
(Item_Id
) = E_Abstract_State
23189 and then Has_Non_Null_Refinement
(Item_Id
)
23191 Check_Constituent_Usage
(Item_Id
);
23194 Next_Elmt
(Item_Elmt
);
23197 end Check_Output_States
;
23199 ---------------------------
23200 -- Check_Proof_In_States --
23201 ---------------------------
23203 procedure Check_Proof_In_States
is
23204 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23205 -- Determine whether at least one constituent of state State_Id with
23206 -- visible refinement is used and has mode Proof_In. Ensure that the
23207 -- remaining constituents do not have Input, In_Out or Output modes.
23209 -----------------------------
23210 -- Check_Constituent_Usage --
23211 -----------------------------
23213 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23214 Constit_Elmt
: Elmt_Id
;
23215 Constit_Id
: Entity_Id
;
23216 Proof_In_Seen
: Boolean := False;
23219 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23220 while Present
(Constit_Elmt
) loop
23221 Constit_Id
:= Node
(Constit_Elmt
);
23223 -- At least one of the constituents appears as Proof_In
23225 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
23226 Proof_In_Seen
:= True;
23228 -- The constituent appears in the global refinement, but has
23229 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
23231 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23232 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23233 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
23235 Error_Msg_Name_1
:= Chars
(State_Id
);
23237 ("constituent & of state % must have mode Proof_In in "
23238 & "global refinement", N
, Constit_Id
);
23241 Next_Elmt
(Constit_Elmt
);
23244 -- Not one of the constituents appeared as Proof_In
23246 if not Proof_In_Seen
then
23248 ("global refinement of state & must include at least one "
23249 & "constituent of mode Proof_In", N
, State_Id
);
23251 end Check_Constituent_Usage
;
23255 Item_Elmt
: Elmt_Id
;
23256 Item_Id
: Entity_Id
;
23258 -- Start of processing for Check_Proof_In_States
23261 -- Do not perform this check in an instance because it was already
23262 -- performed successfully in the generic template.
23264 if Is_Generic_Instance
(Spec_Id
) then
23267 -- Inspect the Proof_In items of the corresponding Global pragma
23268 -- looking for a state with a visible refinement.
23270 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
23271 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
23272 while Present
(Item_Elmt
) loop
23273 Item_Id
:= Node
(Item_Elmt
);
23275 -- Ensure that at least one of the constituents is utilized and
23276 -- is of mode Proof_In
23278 if Ekind
(Item_Id
) = E_Abstract_State
23279 and then Has_Non_Null_Refinement
(Item_Id
)
23281 Check_Constituent_Usage
(Item_Id
);
23284 Next_Elmt
(Item_Elmt
);
23287 end Check_Proof_In_States
;
23289 -------------------------------
23290 -- Check_Refined_Global_List --
23291 -------------------------------
23293 procedure Check_Refined_Global_List
23295 Global_Mode
: Name_Id
:= Name_Input
)
23297 procedure Check_Refined_Global_Item
23299 Global_Mode
: Name_Id
);
23300 -- Verify the legality of a single global item declaration. Parameter
23301 -- Global_Mode denotes the current mode in effect.
23303 -------------------------------
23304 -- Check_Refined_Global_Item --
23305 -------------------------------
23307 procedure Check_Refined_Global_Item
23309 Global_Mode
: Name_Id
)
23311 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
23313 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
23314 -- Issue a common error message for all mode mismatches. Expect
23315 -- denotes the expected mode.
23317 -----------------------------
23318 -- Inconsistent_Mode_Error --
23319 -----------------------------
23321 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
23324 ("global item & has inconsistent modes", Item
, Item_Id
);
23326 Error_Msg_Name_1
:= Global_Mode
;
23327 Error_Msg_Name_2
:= Expect
;
23328 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
23329 end Inconsistent_Mode_Error
;
23331 -- Start of processing for Check_Refined_Global_Item
23334 -- When the state or object acts as a constituent of another
23335 -- state with a visible refinement, collect it for the state
23336 -- completeness checks performed later on.
23338 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
23339 and then Present
(Encapsulating_State
(Item_Id
))
23340 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
23342 if Global_Mode
= Name_Input
then
23343 Add_Item
(Item_Id
, In_Constits
);
23345 elsif Global_Mode
= Name_In_Out
then
23346 Add_Item
(Item_Id
, In_Out_Constits
);
23348 elsif Global_Mode
= Name_Output
then
23349 Add_Item
(Item_Id
, Out_Constits
);
23351 elsif Global_Mode
= Name_Proof_In
then
23352 Add_Item
(Item_Id
, Proof_In_Constits
);
23355 -- When not a constituent, ensure that both occurrences of the
23356 -- item in pragmas Global and Refined_Global match.
23358 elsif Contains
(In_Items
, Item_Id
) then
23359 if Global_Mode
/= Name_Input
then
23360 Inconsistent_Mode_Error
(Name_Input
);
23363 elsif Contains
(In_Out_Items
, Item_Id
) then
23364 if Global_Mode
/= Name_In_Out
then
23365 Inconsistent_Mode_Error
(Name_In_Out
);
23368 elsif Contains
(Out_Items
, Item_Id
) then
23369 if Global_Mode
/= Name_Output
then
23370 Inconsistent_Mode_Error
(Name_Output
);
23373 elsif Contains
(Proof_In_Items
, Item_Id
) then
23376 -- The item does not appear in the corresponding Global pragma,
23377 -- it must be an extra (SPARK RM 7.2.4(3)).
23380 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
23382 end Check_Refined_Global_Item
;
23388 -- Start of processing for Check_Refined_Global_List
23391 -- Do not perform this check in an instance because it was already
23392 -- performed successfully in the generic template.
23394 if Is_Generic_Instance
(Spec_Id
) then
23397 elsif Nkind
(List
) = N_Null
then
23400 -- Single global item declaration
23402 elsif Nkind_In
(List
, N_Expanded_Name
,
23404 N_Selected_Component
)
23406 Check_Refined_Global_Item
(List
, Global_Mode
);
23408 -- Simple global list or moded global list declaration
23410 elsif Nkind
(List
) = N_Aggregate
then
23412 -- The declaration of a simple global list appear as a collection
23415 if Present
(Expressions
(List
)) then
23416 Item
:= First
(Expressions
(List
));
23417 while Present
(Item
) loop
23418 Check_Refined_Global_Item
(Item
, Global_Mode
);
23422 -- The declaration of a moded global list appears as a collection
23423 -- of component associations where individual choices denote
23426 elsif Present
(Component_Associations
(List
)) then
23427 Item
:= First
(Component_Associations
(List
));
23428 while Present
(Item
) loop
23429 Check_Refined_Global_List
23430 (List
=> Expression
(Item
),
23431 Global_Mode
=> Chars
(First
(Choices
(Item
))));
23439 raise Program_Error
;
23445 raise Program_Error
;
23447 end Check_Refined_Global_List
;
23449 --------------------------
23450 -- Collect_Global_Items --
23451 --------------------------
23453 procedure Collect_Global_Items
23455 Mode
: Name_Id
:= Name_Input
)
23457 procedure Collect_Global_Item
23459 Item_Mode
: Name_Id
);
23460 -- Add a single item to the appropriate list. Item_Mode denotes the
23461 -- current mode in effect.
23463 -------------------------
23464 -- Collect_Global_Item --
23465 -------------------------
23467 procedure Collect_Global_Item
23469 Item_Mode
: Name_Id
)
23471 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
23472 -- The above handles abstract views of variables and states built
23473 -- for limited with clauses.
23476 -- Signal that the global list contains at least one abstract
23477 -- state with a visible refinement. Note that the refinement may
23478 -- be null in which case there are no constituents.
23480 if Ekind
(Item_Id
) = E_Abstract_State
then
23481 if Has_Null_Refinement
(Item_Id
) then
23482 Has_Null_State
:= True;
23484 elsif Has_Non_Null_Refinement
(Item_Id
) then
23485 if Item_Mode
= Name_Input
then
23486 Has_In_State
:= True;
23487 elsif Item_Mode
= Name_In_Out
then
23488 Has_In_Out_State
:= True;
23489 elsif Item_Mode
= Name_Output
then
23490 Has_Out_State
:= True;
23491 elsif Item_Mode
= Name_Proof_In
then
23492 Has_Proof_In_State
:= True;
23497 -- Add the item to the proper list
23499 if Item_Mode
= Name_Input
then
23500 Add_Item
(Item_Id
, In_Items
);
23501 elsif Item_Mode
= Name_In_Out
then
23502 Add_Item
(Item_Id
, In_Out_Items
);
23503 elsif Item_Mode
= Name_Output
then
23504 Add_Item
(Item_Id
, Out_Items
);
23505 elsif Item_Mode
= Name_Proof_In
then
23506 Add_Item
(Item_Id
, Proof_In_Items
);
23508 end Collect_Global_Item
;
23514 -- Start of processing for Collect_Global_Items
23517 if Nkind
(List
) = N_Null
then
23520 -- Single global item declaration
23522 elsif Nkind_In
(List
, N_Expanded_Name
,
23524 N_Selected_Component
)
23526 Collect_Global_Item
(List
, Mode
);
23528 -- Single global list or moded global list declaration
23530 elsif Nkind
(List
) = N_Aggregate
then
23532 -- The declaration of a simple global list appear as a collection
23535 if Present
(Expressions
(List
)) then
23536 Item
:= First
(Expressions
(List
));
23537 while Present
(Item
) loop
23538 Collect_Global_Item
(Item
, Mode
);
23542 -- The declaration of a moded global list appears as a collection
23543 -- of component associations where individual choices denote mode.
23545 elsif Present
(Component_Associations
(List
)) then
23546 Item
:= First
(Component_Associations
(List
));
23547 while Present
(Item
) loop
23548 Collect_Global_Items
23549 (List
=> Expression
(Item
),
23550 Mode
=> Chars
(First
(Choices
(Item
))));
23558 raise Program_Error
;
23561 -- To accomodate partial decoration of disabled SPARK features, this
23562 -- routine may be called with illegal input. If this is the case, do
23563 -- not raise Program_Error.
23568 end Collect_Global_Items
;
23570 -------------------------
23571 -- Present_Then_Remove --
23572 -------------------------
23574 function Present_Then_Remove
23576 Item
: Entity_Id
) return Boolean
23581 if Present
(List
) then
23582 Elmt
:= First_Elmt
(List
);
23583 while Present
(Elmt
) loop
23584 if Node
(Elmt
) = Item
then
23585 Remove_Elmt
(List
, Elmt
);
23594 end Present_Then_Remove
;
23596 -------------------------------
23597 -- Report_Extra_Constituents --
23598 -------------------------------
23600 procedure Report_Extra_Constituents
is
23601 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
23602 -- Emit an error for every element of List
23604 ---------------------------------------
23605 -- Report_Extra_Constituents_In_List --
23606 ---------------------------------------
23608 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
23609 Constit_Elmt
: Elmt_Id
;
23612 if Present
(List
) then
23613 Constit_Elmt
:= First_Elmt
(List
);
23614 while Present
(Constit_Elmt
) loop
23615 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
23616 Next_Elmt
(Constit_Elmt
);
23619 end Report_Extra_Constituents_In_List
;
23621 -- Start of processing for Report_Extra_Constituents
23624 -- Do not perform this check in an instance because it was already
23625 -- performed successfully in the generic template.
23627 if Is_Generic_Instance
(Spec_Id
) then
23631 Report_Extra_Constituents_In_List
(In_Constits
);
23632 Report_Extra_Constituents_In_List
(In_Out_Constits
);
23633 Report_Extra_Constituents_In_List
(Out_Constits
);
23634 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
23636 end Report_Extra_Constituents
;
23640 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
23641 Errors
: constant Nat
:= Serious_Errors_Detected
;
23644 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23647 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
23648 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
23650 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
23653 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
23654 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
23656 -- The subprogram declaration lacks pragma Global. This renders
23657 -- Refined_Global useless as there is nothing to refine.
23659 if No
(Global
) then
23661 ("useless refinement, declaration of subprogram & lacks aspect or "
23662 & "pragma Global", N
, Spec_Id
);
23666 -- Extract all relevant items from the corresponding Global pragma
23668 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
23670 -- Package and subprogram bodies are instantiated individually in
23671 -- a separate compiler pass. Due to this mode of instantiation, the
23672 -- refinement of a state may no longer be visible when a subprogram
23673 -- body contract is instantiated. Since the generic template is legal,
23674 -- do not perform this check in the instance to circumvent this oddity.
23676 if Is_Generic_Instance
(Spec_Id
) then
23679 -- Non-instance case
23682 -- The corresponding Global pragma must mention at least one state
23683 -- witha visible refinement at the point Refined_Global is processed.
23684 -- States with null refinements need Refined_Global pragma
23685 -- (SPARK RM 7.2.4(2)).
23687 if not Has_In_State
23688 and then not Has_In_Out_State
23689 and then not Has_Out_State
23690 and then not Has_Proof_In_State
23691 and then not Has_Null_State
23694 ("useless refinement, subprogram & does not depend on abstract "
23695 & "state with visible refinement", N
, Spec_Id
);
23698 -- The global refinement of inputs and outputs cannot be null when
23699 -- the corresponding Global pragma contains at least one item except
23700 -- in the case where we have states with null refinements.
23702 elsif Nkind
(Items
) = N_Null
23704 (Present
(In_Items
)
23705 or else Present
(In_Out_Items
)
23706 or else Present
(Out_Items
)
23707 or else Present
(Proof_In_Items
))
23708 and then not Has_Null_State
23711 ("refinement cannot be null, subprogram & has global items",
23717 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23718 -- This ensures that the categorization of all refined global items is
23719 -- consistent with their role.
23721 Analyze_Global_In_Decl_Part
(N
);
23723 -- Perform all refinement checks with respect to completeness and mode
23726 if Serious_Errors_Detected
= Errors
then
23727 Check_Refined_Global_List
(Items
);
23730 -- For Input states with visible refinement, at least one constituent
23731 -- must be used as an Input in the global refinement.
23733 if Serious_Errors_Detected
= Errors
then
23734 Check_Input_States
;
23737 -- Verify all possible completion variants for In_Out states with
23738 -- visible refinement.
23740 if Serious_Errors_Detected
= Errors
then
23741 Check_In_Out_States
;
23744 -- For Output states with visible refinement, all constituents must be
23745 -- used as Outputs in the global refinement.
23747 if Serious_Errors_Detected
= Errors
then
23748 Check_Output_States
;
23751 -- For Proof_In states with visible refinement, at least one constituent
23752 -- must be used as Proof_In in the global refinement.
23754 if Serious_Errors_Detected
= Errors
then
23755 Check_Proof_In_States
;
23758 -- Emit errors for all constituents that belong to other states with
23759 -- visible refinement that do not appear in Global.
23761 if Serious_Errors_Detected
= Errors
then
23762 Report_Extra_Constituents
;
23764 end Analyze_Refined_Global_In_Decl_Part
;
23766 ----------------------------------------
23767 -- Analyze_Refined_State_In_Decl_Part --
23768 ----------------------------------------
23770 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
23771 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
23772 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
23773 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
23775 Available_States
: Elist_Id
:= No_Elist
;
23776 -- A list of all abstract states defined in the package declaration that
23777 -- are available for refinement. The list is used to report unrefined
23780 Body_States
: Elist_Id
:= No_Elist
;
23781 -- A list of all hidden states that appear in the body of the related
23782 -- package. The list is used to report unused hidden states.
23784 Constituents_Seen
: Elist_Id
:= No_Elist
;
23785 -- A list that contains all constituents processed so far. The list is
23786 -- used to detect multiple uses of the same constituent.
23788 Refined_States_Seen
: Elist_Id
:= No_Elist
;
23789 -- A list that contains all refined states processed so far. The list is
23790 -- used to detect duplicate refinements.
23792 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
23793 -- Perform full analysis of a single refinement clause
23795 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
23796 -- Gather the entities of all abstract states and objects declared in
23797 -- the body state space of package Pack_Id.
23799 procedure Report_Unrefined_States
(States
: Elist_Id
);
23800 -- Emit errors for all unrefined abstract states found in list States
23802 procedure Report_Unused_States
(States
: Elist_Id
);
23803 -- Emit errors for all unused states found in list States
23805 -------------------------------
23806 -- Analyze_Refinement_Clause --
23807 -------------------------------
23809 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
23810 AR_Constit
: Entity_Id
:= Empty
;
23811 AW_Constit
: Entity_Id
:= Empty
;
23812 ER_Constit
: Entity_Id
:= Empty
;
23813 EW_Constit
: Entity_Id
:= Empty
;
23814 -- The entities of external constituents that contain one of the
23815 -- following enabled properties: Async_Readers, Async_Writers,
23816 -- Effective_Reads and Effective_Writes.
23818 External_Constit_Seen
: Boolean := False;
23819 -- Flag used to mark when at least one external constituent is part
23820 -- of the state refinement.
23822 Non_Null_Seen
: Boolean := False;
23823 Null_Seen
: Boolean := False;
23824 -- Flags used to detect multiple uses of null in a single clause or a
23825 -- mixture of null and non-null constituents.
23827 Part_Of_Constits
: Elist_Id
:= No_Elist
;
23828 -- A list of all candidate constituents subject to indicator Part_Of
23829 -- where the encapsulating state is the current state.
23832 State_Id
: Entity_Id
;
23833 -- The current state being refined
23835 procedure Analyze_Constituent
(Constit
: Node_Id
);
23836 -- Perform full analysis of a single constituent
23838 procedure Check_External_Property
23839 (Prop_Nam
: Name_Id
;
23841 Constit
: Entity_Id
);
23842 -- Determine whether a property denoted by name Prop_Nam is present
23843 -- in both the refined state and constituent Constit. Flag Enabled
23844 -- should be set when the property applies to the refined state. If
23845 -- this is not the case, emit an error message.
23847 procedure Check_Matching_State
;
23848 -- Determine whether the state being refined appears in list
23849 -- Available_States. Emit an error when attempting to re-refine the
23850 -- state or when the state is not defined in the package declaration,
23851 -- otherwise remove the state from Available_States.
23853 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
23854 -- Emit errors for all unused Part_Of constituents in list Constits
23856 -------------------------
23857 -- Analyze_Constituent --
23858 -------------------------
23860 procedure Analyze_Constituent
(Constit
: Node_Id
) is
23861 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
);
23862 -- Verify that the constituent Constit_Id is a Ghost entity if the
23863 -- abstract state being refined is also Ghost. If this is the case
23864 -- verify that the Ghost policy in effect at the point of state
23865 -- and constituent declaration is the same.
23867 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
23868 -- Determine whether constituent Constit denoted by its entity
23869 -- Constit_Id appears in Hidden_States. Emit an error when the
23870 -- constituent is not a valid hidden state of the related package
23871 -- or when it is used more than once. Otherwise remove the
23872 -- constituent from Hidden_States.
23874 --------------------------------
23875 -- Check_Matching_Constituent --
23876 --------------------------------
23878 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
23879 procedure Collect_Constituent
;
23880 -- Add constituent Constit_Id to the refinements of State_Id
23882 -------------------------
23883 -- Collect_Constituent --
23884 -------------------------
23886 procedure Collect_Constituent
is
23888 -- Add the constituent to the list of processed items to aid
23889 -- with the detection of duplicates.
23891 Add_Item
(Constit_Id
, Constituents_Seen
);
23893 -- Collect the constituent in the list of refinement items
23894 -- and establish a relation between the refined state and
23897 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
23898 Set_Encapsulating_State
(Constit_Id
, State_Id
);
23900 -- The state has at least one legal constituent, mark the
23901 -- start of the refinement region. The region ends when the
23902 -- body declarations end (see routine Analyze_Declarations).
23904 Set_Has_Visible_Refinement
(State_Id
);
23906 -- When the constituent is external, save its relevant
23907 -- property for further checks.
23909 if Async_Readers_Enabled
(Constit_Id
) then
23910 AR_Constit
:= Constit_Id
;
23911 External_Constit_Seen
:= True;
23914 if Async_Writers_Enabled
(Constit_Id
) then
23915 AW_Constit
:= Constit_Id
;
23916 External_Constit_Seen
:= True;
23919 if Effective_Reads_Enabled
(Constit_Id
) then
23920 ER_Constit
:= Constit_Id
;
23921 External_Constit_Seen
:= True;
23924 if Effective_Writes_Enabled
(Constit_Id
) then
23925 EW_Constit
:= Constit_Id
;
23926 External_Constit_Seen
:= True;
23928 end Collect_Constituent
;
23932 State_Elmt
: Elmt_Id
;
23934 -- Start of processing for Check_Matching_Constituent
23937 -- Detect a duplicate use of a constituent
23939 if Contains
(Constituents_Seen
, Constit_Id
) then
23941 ("duplicate use of constituent &", Constit
, Constit_Id
);
23945 -- The constituent is subject to a Part_Of indicator
23947 if Present
(Encapsulating_State
(Constit_Id
)) then
23948 if Encapsulating_State
(Constit_Id
) = State_Id
then
23949 Check_Ghost_Constituent
(Constit_Id
);
23950 Remove
(Part_Of_Constits
, Constit_Id
);
23951 Collect_Constituent
;
23953 -- The constituent is part of another state and is used
23954 -- incorrectly in the refinement of the current state.
23957 Error_Msg_Name_1
:= Chars
(State_Id
);
23959 ("& cannot act as constituent of state %",
23960 Constit
, Constit_Id
);
23962 ("\Part_Of indicator specifies & as encapsulating "
23963 & "state", Constit
, Encapsulating_State
(Constit_Id
));
23966 -- The only other source of legal constituents is the body
23967 -- state space of the related package.
23970 if Present
(Body_States
) then
23971 State_Elmt
:= First_Elmt
(Body_States
);
23972 while Present
(State_Elmt
) loop
23974 -- Consume a valid constituent to signal that it has
23975 -- been encountered.
23977 if Node
(State_Elmt
) = Constit_Id
then
23978 Check_Ghost_Constituent
(Constit_Id
);
23979 Remove_Elmt
(Body_States
, State_Elmt
);
23980 Collect_Constituent
;
23984 Next_Elmt
(State_Elmt
);
23988 -- If we get here, then the constituent is not a hidden
23989 -- state of the related package and may not be used in a
23990 -- refinement (SPARK RM 7.2.2(9)).
23992 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23994 ("cannot use & in refinement, constituent is not a hidden "
23995 & "state of package %", Constit
, Constit_Id
);
23997 end Check_Matching_Constituent
;
23999 -----------------------------
24000 -- Check_Ghost_Constituent --
24001 -----------------------------
24003 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
) is
24005 if Is_Ghost_Entity
(State_Id
) then
24006 if Is_Ghost_Entity
(Constit_Id
) then
24008 -- The Ghost policy in effect at the point of abstract
24009 -- state declaration and constituent must match
24010 -- (SPARK RM 6.9(16)).
24012 if Is_Checked_Ghost_Entity
(State_Id
)
24013 and then Is_Ignored_Ghost_Entity
(Constit_Id
)
24015 Error_Msg_Sloc
:= Sloc
(Constit
);
24018 ("incompatible ghost policies in effect", State
);
24020 ("\abstract state & declared with ghost policy "
24021 & "Check", State
, State_Id
);
24023 ("\constituent & declared # with ghost policy "
24024 & "Ignore", State
, Constit_Id
);
24026 elsif Is_Ignored_Ghost_Entity
(State_Id
)
24027 and then Is_Checked_Ghost_Entity
(Constit_Id
)
24029 Error_Msg_Sloc
:= Sloc
(Constit
);
24032 ("incompatible ghost policies in effect", State
);
24034 ("\abstract state & declared with ghost policy "
24035 & "Ignore", State
, State_Id
);
24037 ("\constituent & declared # with ghost policy "
24038 & "Check", State
, Constit_Id
);
24041 -- A constituent of a Ghost abstract state must be a Ghost
24042 -- entity (SPARK RM 7.2.2(12)).
24046 ("constituent of ghost state & must be ghost",
24047 Constit
, State_Id
);
24050 end Check_Ghost_Constituent
;
24054 Constit_Id
: Entity_Id
;
24056 -- Start of processing for Analyze_Constituent
24059 -- Detect multiple uses of null in a single refinement clause or a
24060 -- mixture of null and non-null constituents.
24062 if Nkind
(Constit
) = N_Null
then
24065 ("multiple null constituents not allowed", Constit
);
24067 elsif Non_Null_Seen
then
24069 ("cannot mix null and non-null constituents", Constit
);
24074 -- Collect the constituent in the list of refinement items
24076 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
24078 -- The state has at least one legal constituent, mark the
24079 -- start of the refinement region. The region ends when the
24080 -- body declarations end (see Analyze_Declarations).
24082 Set_Has_Visible_Refinement
(State_Id
);
24085 -- Non-null constituents
24088 Non_Null_Seen
:= True;
24092 ("cannot mix null and non-null constituents", Constit
);
24096 Resolve_State
(Constit
);
24098 -- Ensure that the constituent denotes a valid state or a
24099 -- whole object (SPARK RM 7.2.2(5)).
24101 if Is_Entity_Name
(Constit
) then
24102 Constit_Id
:= Entity_Of
(Constit
);
24104 if Ekind_In
(Constit_Id
, E_Abstract_State
,
24108 Check_Matching_Constituent
(Constit_Id
);
24112 ("constituent & must denote object or state",
24113 Constit
, Constit_Id
);
24116 -- The constituent is illegal
24119 SPARK_Msg_N
("malformed constituent", Constit
);
24122 end Analyze_Constituent
;
24124 -----------------------------
24125 -- Check_External_Property --
24126 -----------------------------
24128 procedure Check_External_Property
24129 (Prop_Nam
: Name_Id
;
24131 Constit
: Entity_Id
)
24134 Error_Msg_Name_1
:= Prop_Nam
;
24136 -- The property is enabled in the related Abstract_State pragma
24137 -- that defines the state (SPARK RM 7.2.8(3)).
24140 if No
(Constit
) then
24142 ("external state & requires at least one constituent with "
24143 & "property %", State
, State_Id
);
24146 -- The property is missing in the declaration of the state, but
24147 -- a constituent is introducing it in the state refinement
24148 -- (SPARK RM 7.2.8(3)).
24150 elsif Present
(Constit
) then
24151 Error_Msg_Name_2
:= Chars
(Constit
);
24153 ("external state & lacks property % set by constituent %",
24156 end Check_External_Property
;
24158 --------------------------
24159 -- Check_Matching_State --
24160 --------------------------
24162 procedure Check_Matching_State
is
24163 State_Elmt
: Elmt_Id
;
24166 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
24168 if Contains
(Refined_States_Seen
, State_Id
) then
24170 ("duplicate refinement of state &", State
, State_Id
);
24174 -- Inspect the abstract states defined in the package declaration
24175 -- looking for a match.
24177 State_Elmt
:= First_Elmt
(Available_States
);
24178 while Present
(State_Elmt
) loop
24180 -- A valid abstract state is being refined in the body. Add
24181 -- the state to the list of processed refined states to aid
24182 -- with the detection of duplicate refinements. Remove the
24183 -- state from Available_States to signal that it has already
24186 if Node
(State_Elmt
) = State_Id
then
24187 Add_Item
(State_Id
, Refined_States_Seen
);
24188 Remove_Elmt
(Available_States
, State_Elmt
);
24192 Next_Elmt
(State_Elmt
);
24195 -- If we get here, we are refining a state that is not defined in
24196 -- the package declaration.
24198 Error_Msg_Name_1
:= Chars
(Spec_Id
);
24200 ("cannot refine state, & is not defined in package %",
24202 end Check_Matching_State
;
24204 --------------------------------
24205 -- Report_Unused_Constituents --
24206 --------------------------------
24208 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
24209 Constit_Elmt
: Elmt_Id
;
24210 Constit_Id
: Entity_Id
;
24211 Posted
: Boolean := False;
24214 if Present
(Constits
) then
24215 Constit_Elmt
:= First_Elmt
(Constits
);
24216 while Present
(Constit_Elmt
) loop
24217 Constit_Id
:= Node
(Constit_Elmt
);
24219 -- Generate an error message of the form:
24221 -- state ... has unused Part_Of constituents
24222 -- abstract state ... defined at ...
24223 -- constant ... defined at ...
24224 -- variable ... defined at ...
24229 ("state & has unused Part_Of constituents",
24233 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
24235 if Ekind
(Constit_Id
) = E_Abstract_State
then
24237 ("\abstract state & defined #", State
, Constit_Id
);
24239 elsif Ekind
(Constit_Id
) = E_Constant
then
24241 ("\constant & defined #", State
, Constit_Id
);
24244 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
24245 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
24248 Next_Elmt
(Constit_Elmt
);
24251 end Report_Unused_Constituents
;
24253 -- Local declarations
24255 Body_Ref
: Node_Id
;
24256 Body_Ref_Elmt
: Elmt_Id
;
24258 Extra_State
: Node_Id
;
24260 -- Start of processing for Analyze_Refinement_Clause
24263 -- A refinement clause appears as a component association where the
24264 -- sole choice is the state and the expressions are the constituents.
24265 -- This is a syntax error, always report.
24267 if Nkind
(Clause
) /= N_Component_Association
then
24268 Error_Msg_N
("malformed state refinement clause", Clause
);
24272 -- Analyze the state name of a refinement clause
24274 State
:= First
(Choices
(Clause
));
24277 Resolve_State
(State
);
24279 -- Ensure that the state name denotes a valid abstract state that is
24280 -- defined in the spec of the related package.
24282 if Is_Entity_Name
(State
) then
24283 State_Id
:= Entity_Of
(State
);
24285 -- Catch any attempts to re-refine a state or refine a state that
24286 -- is not defined in the package declaration.
24288 if Ekind
(State_Id
) = E_Abstract_State
then
24289 Check_Matching_State
;
24292 ("& must denote an abstract state", State
, State_Id
);
24296 -- References to a state with visible refinement are illegal.
24297 -- When nested packages are involved, detecting such references is
24298 -- tricky because pragma Refined_State is analyzed later than the
24299 -- offending pragma Depends or Global. References that occur in
24300 -- such nested context are stored in a list. Emit errors for all
24301 -- references found in Body_References (SPARK RM 6.1.4(8)).
24303 if Present
(Body_References
(State_Id
)) then
24304 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
24305 while Present
(Body_Ref_Elmt
) loop
24306 Body_Ref
:= Node
(Body_Ref_Elmt
);
24308 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
24309 Error_Msg_Sloc
:= Sloc
(State
);
24310 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
24312 Next_Elmt
(Body_Ref_Elmt
);
24316 -- The state name is illegal. This is a syntax error, always report.
24319 Error_Msg_N
("malformed state name in refinement clause", State
);
24323 -- A refinement clause may only refine one state at a time
24325 Extra_State
:= Next
(State
);
24327 if Present
(Extra_State
) then
24329 ("refinement clause cannot cover multiple states", Extra_State
);
24332 -- Replicate the Part_Of constituents of the refined state because
24333 -- the algorithm will consume items.
24335 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
24337 -- Analyze all constituents of the refinement. Multiple constituents
24338 -- appear as an aggregate.
24340 Constit
:= Expression
(Clause
);
24342 if Nkind
(Constit
) = N_Aggregate
then
24343 if Present
(Component_Associations
(Constit
)) then
24345 ("constituents of refinement clause must appear in "
24346 & "positional form", Constit
);
24348 else pragma Assert
(Present
(Expressions
(Constit
)));
24349 Constit
:= First
(Expressions
(Constit
));
24350 while Present
(Constit
) loop
24351 Analyze_Constituent
(Constit
);
24356 -- Various forms of a single constituent. Note that these may include
24357 -- malformed constituents.
24360 Analyze_Constituent
(Constit
);
24363 -- A refined external state is subject to special rules with respect
24364 -- to its properties and constituents.
24366 if Is_External_State
(State_Id
) then
24368 -- The set of properties that all external constituents yield must
24369 -- match that of the refined state. There are two cases to detect:
24370 -- the refined state lacks a property or has an extra property.
24372 if External_Constit_Seen
then
24373 Check_External_Property
24374 (Prop_Nam
=> Name_Async_Readers
,
24375 Enabled
=> Async_Readers_Enabled
(State_Id
),
24376 Constit
=> AR_Constit
);
24378 Check_External_Property
24379 (Prop_Nam
=> Name_Async_Writers
,
24380 Enabled
=> Async_Writers_Enabled
(State_Id
),
24381 Constit
=> AW_Constit
);
24383 Check_External_Property
24384 (Prop_Nam
=> Name_Effective_Reads
,
24385 Enabled
=> Effective_Reads_Enabled
(State_Id
),
24386 Constit
=> ER_Constit
);
24388 Check_External_Property
24389 (Prop_Nam
=> Name_Effective_Writes
,
24390 Enabled
=> Effective_Writes_Enabled
(State_Id
),
24391 Constit
=> EW_Constit
);
24393 -- An external state may be refined to null (SPARK RM 7.2.8(2))
24395 elsif Null_Seen
then
24398 -- The external state has constituents, but none of them are
24399 -- external (SPARK RM 7.2.8(2)).
24403 ("external state & requires at least one external "
24404 & "constituent or null refinement", State
, State_Id
);
24407 -- When a refined state is not external, it should not have external
24408 -- constituents (SPARK RM 7.2.8(1)).
24410 elsif External_Constit_Seen
then
24412 ("non-external state & cannot contain external constituents in "
24413 & "refinement", State
, State_Id
);
24416 -- Ensure that all Part_Of candidate constituents have been mentioned
24417 -- in the refinement clause.
24419 Report_Unused_Constituents
(Part_Of_Constits
);
24420 end Analyze_Refinement_Clause
;
24422 -------------------------
24423 -- Collect_Body_States --
24424 -------------------------
24426 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
24427 Result
: Elist_Id
:= No_Elist
;
24428 -- A list containing all body states of Pack_Id
24430 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
24431 -- Gather the entities of all abstract states and objects declared in
24432 -- the visible state space of package Pack_Id.
24434 ----------------------------
24435 -- Collect_Visible_States --
24436 ----------------------------
24438 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
24440 Item_Id
: Entity_Id
;
24443 -- Traverse the entity chain of the package and inspect all
24446 Item_Id
:= First_Entity
(Pack_Id
);
24447 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
24449 -- Do not consider internally generated items as those cannot
24450 -- be named and participate in refinement.
24452 if not Comes_From_Source
(Item_Id
) then
24455 elsif Ekind
(Item_Id
) = E_Abstract_State
then
24456 Add_Item
(Item_Id
, Result
);
24458 elsif Ekind_In
(Item_Id
, E_Constant
, E_Variable
) then
24459 Decl
:= Declaration_Node
(Item_Id
);
24461 -- Do not consider constants or variables that map generic
24462 -- formals to their actuals as the formals cannot be named
24463 -- from the outside and participate in refinement.
24465 if Present
(Corresponding_Generic_Association
(Decl
)) then
24468 -- Constants without "variable input" are not considered a
24469 -- hidden state of a package (SPARK RM 7.1.1(2)).
24471 elsif Ekind
(Item_Id
) = E_Constant
24472 and then not Has_Variable_Input
(Item_Id
)
24477 Add_Item
(Item_Id
, Result
);
24480 -- Recursively gather the visible states of a nested package
24482 elsif Ekind
(Item_Id
) = E_Package
then
24483 Collect_Visible_States
(Item_Id
);
24486 Next_Entity
(Item_Id
);
24488 end Collect_Visible_States
;
24492 Pack_Body
: constant Node_Id
:=
24493 Declaration_Node
(Body_Entity
(Pack_Id
));
24495 Item_Id
: Entity_Id
;
24497 -- Start of processing for Collect_Body_States
24500 -- Inspect the declarations of the body looking for source objects,
24501 -- packages and package instantiations.
24503 Decl
:= First
(Declarations
(Pack_Body
));
24504 while Present
(Decl
) loop
24506 -- Capture source objects as internally generated temporaries
24507 -- cannot be named and participate in refinement.
24509 if Nkind
(Decl
) = N_Object_Declaration
then
24510 Item_Id
:= Defining_Entity
(Decl
);
24512 if Comes_From_Source
(Item_Id
) then
24513 Add_Item
(Item_Id
, Result
);
24516 -- Capture the visible abstract states and objects of a source
24517 -- package [instantiation].
24519 elsif Nkind
(Decl
) = N_Package_Declaration
then
24520 Item_Id
:= Defining_Entity
(Decl
);
24522 if Comes_From_Source
(Item_Id
) then
24523 Collect_Visible_States
(Item_Id
);
24531 end Collect_Body_States
;
24533 -----------------------------
24534 -- Report_Unrefined_States --
24535 -----------------------------
24537 procedure Report_Unrefined_States
(States
: Elist_Id
) is
24538 State_Elmt
: Elmt_Id
;
24541 if Present
(States
) then
24542 State_Elmt
:= First_Elmt
(States
);
24543 while Present
(State_Elmt
) loop
24545 ("abstract state & must be refined", Node
(State_Elmt
));
24547 Next_Elmt
(State_Elmt
);
24550 end Report_Unrefined_States
;
24552 --------------------------
24553 -- Report_Unused_States --
24554 --------------------------
24556 procedure Report_Unused_States
(States
: Elist_Id
) is
24557 Posted
: Boolean := False;
24558 State_Elmt
: Elmt_Id
;
24559 State_Id
: Entity_Id
;
24562 if Present
(States
) then
24563 State_Elmt
:= First_Elmt
(States
);
24564 while Present
(State_Elmt
) loop
24565 State_Id
:= Node
(State_Elmt
);
24567 -- Generate an error message of the form:
24569 -- body of package ... has unused hidden states
24570 -- abstract state ... defined at ...
24571 -- constant ... defined at ...
24572 -- variable ... defined at ...
24577 ("body of package & has unused hidden states", Body_Id
);
24580 Error_Msg_Sloc
:= Sloc
(State_Id
);
24582 if Ekind
(State_Id
) = E_Abstract_State
then
24584 ("\abstract state & defined #", Body_Id
, State_Id
);
24586 elsif Ekind
(State_Id
) = E_Constant
then
24587 SPARK_Msg_NE
("\constant & defined #", Body_Id
, State_Id
);
24590 pragma Assert
(Ekind
(State_Id
) = E_Variable
);
24591 SPARK_Msg_NE
("\variable & defined #", Body_Id
, State_Id
);
24594 Next_Elmt
(State_Elmt
);
24597 end Report_Unused_States
;
24599 -- Local declarations
24601 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
24604 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24609 -- Replicate the abstract states declared by the package because the
24610 -- matching algorithm will consume states.
24612 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
24614 -- Gather all abstract states and objects declared in the visible
24615 -- state space of the package body. These items must be utilized as
24616 -- constituents in a state refinement.
24618 Body_States
:= Collect_Body_States
(Spec_Id
);
24620 -- Multiple non-null state refinements appear as an aggregate
24622 if Nkind
(Clauses
) = N_Aggregate
then
24623 if Present
(Expressions
(Clauses
)) then
24625 ("state refinements must appear as component associations",
24628 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
24629 Clause
:= First
(Component_Associations
(Clauses
));
24630 while Present
(Clause
) loop
24631 Analyze_Refinement_Clause
(Clause
);
24636 -- Various forms of a single state refinement. Note that these may
24637 -- include malformed refinements.
24640 Analyze_Refinement_Clause
(Clauses
);
24643 -- List all abstract states that were left unrefined
24645 Report_Unrefined_States
(Available_States
);
24647 -- Ensure that all abstract states and objects declared in the body
24648 -- state space of the related package are utilized as constituents.
24650 Report_Unused_States
(Body_States
);
24651 end Analyze_Refined_State_In_Decl_Part
;
24653 ------------------------------------
24654 -- Analyze_Test_Case_In_Decl_Part --
24655 ------------------------------------
24657 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
24658 Subp_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
24659 Spec_Id
: constant Entity_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
24661 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
24662 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
24663 -- denoted by Arg_Nam.
24665 ------------------------------
24666 -- Preanalyze_Test_Case_Arg --
24667 ------------------------------
24669 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
24673 -- Preanalyze the original aspect argument for ASIS or for a generic
24674 -- subprogram to properly capture global references.
24676 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
24680 Arg_Nam
=> Arg_Nam
,
24681 From_Aspect
=> True);
24683 if Present
(Arg
) then
24684 Preanalyze_Assert_Expression
24685 (Expression
(Arg
), Standard_Boolean
);
24689 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
24691 if Present
(Arg
) then
24692 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
24694 end Preanalyze_Test_Case_Arg
;
24698 Restore_Scope
: Boolean := False;
24700 -- Start of processing for Analyze_Test_Case_In_Decl_Part
24703 -- Ensure that the formal parameters are visible when analyzing all
24704 -- clauses. This falls out of the general rule of aspects pertaining
24705 -- to subprogram declarations.
24707 if not In_Open_Scopes
(Spec_Id
) then
24708 Restore_Scope
:= True;
24709 Push_Scope
(Spec_Id
);
24711 if Is_Generic_Subprogram
(Spec_Id
) then
24712 Install_Generic_Formals
(Spec_Id
);
24714 Install_Formals
(Spec_Id
);
24718 Preanalyze_Test_Case_Arg
(Name_Requires
);
24719 Preanalyze_Test_Case_Arg
(Name_Ensures
);
24721 if Restore_Scope
then
24725 -- Currently it is not possible to inline pre/postconditions on a
24726 -- subprogram subject to pragma Inline_Always.
24728 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
24729 end Analyze_Test_Case_In_Decl_Part
;
24735 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
24740 if Present
(List
) then
24741 Elmt
:= First_Elmt
(List
);
24742 while Present
(Elmt
) loop
24743 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
24746 Id
:= Entity_Of
(Node
(Elmt
));
24749 if Id
= Item_Id
then
24760 -----------------------------
24761 -- Check_Applicable_Policy --
24762 -----------------------------
24764 procedure Check_Applicable_Policy
(N
: Node_Id
) is
24768 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
24771 -- No effect if not valid assertion kind name
24773 if not Is_Valid_Assertion_Kind
(Ename
) then
24777 -- Loop through entries in check policy list
24779 PP
:= Opt
.Check_Policy_List
;
24780 while Present
(PP
) loop
24782 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24783 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24787 or else Pnm
= Name_Assertion
24788 or else (Pnm
= Name_Statement_Assertions
24789 and then Nam_In
(Ename
, Name_Assert
,
24790 Name_Assert_And_Cut
,
24792 Name_Loop_Invariant
,
24793 Name_Loop_Variant
))
24795 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
24798 when Name_Off | Name_Ignore
=>
24799 Set_Is_Ignored
(N
, True);
24800 Set_Is_Checked
(N
, False);
24802 when Name_On | Name_Check
=>
24803 Set_Is_Checked
(N
, True);
24804 Set_Is_Ignored
(N
, False);
24806 when Name_Disable
=>
24807 Set_Is_Ignored
(N
, True);
24808 Set_Is_Checked
(N
, False);
24809 Set_Is_Disabled
(N
, True);
24811 -- That should be exhaustive, the null here is a defence
24812 -- against a malformed tree from previous errors.
24821 PP
:= Next_Pragma
(PP
);
24825 -- If there are no specific entries that matched, then we let the
24826 -- setting of assertions govern. Note that this provides the needed
24827 -- compatibility with the RM for the cases of assertion, invariant,
24828 -- precondition, predicate, and postcondition.
24830 if Assertions_Enabled
then
24831 Set_Is_Checked
(N
, True);
24832 Set_Is_Ignored
(N
, False);
24834 Set_Is_Checked
(N
, False);
24835 Set_Is_Ignored
(N
, True);
24837 end Check_Applicable_Policy
;
24839 -------------------------------
24840 -- Check_External_Properties --
24841 -------------------------------
24843 procedure Check_External_Properties
24851 -- All properties enabled
24853 if AR
and AW
and ER
and EW
then
24856 -- Async_Readers + Effective_Writes
24857 -- Async_Readers + Async_Writers + Effective_Writes
24859 elsif AR
and EW
and not ER
then
24862 -- Async_Writers + Effective_Reads
24863 -- Async_Readers + Async_Writers + Effective_Reads
24865 elsif AW
and ER
and not EW
then
24868 -- Async_Readers + Async_Writers
24870 elsif AR
and AW
and not ER
and not EW
then
24875 elsif AR
and not AW
and not ER
and not EW
then
24880 elsif AW
and not AR
and not ER
and not EW
then
24885 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24888 end Check_External_Properties
;
24894 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
24898 -- Loop through entries in check policy list
24900 PP
:= Opt
.Check_Policy_List
;
24901 while Present
(PP
) loop
24903 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24904 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24908 or else (Pnm
= Name_Assertion
24909 and then Is_Valid_Assertion_Kind
(Nam
))
24910 or else (Pnm
= Name_Statement_Assertions
24911 and then Nam_In
(Nam
, Name_Assert
,
24912 Name_Assert_And_Cut
,
24914 Name_Loop_Invariant
,
24915 Name_Loop_Variant
))
24917 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
24918 when Name_On | Name_Check
=>
24920 when Name_Off | Name_Ignore
=>
24921 return Name_Ignore
;
24922 when Name_Disable
=>
24923 return Name_Disable
;
24925 raise Program_Error
;
24929 PP
:= Next_Pragma
(PP
);
24934 -- If there are no specific entries that matched, then we let the
24935 -- setting of assertions govern. Note that this provides the needed
24936 -- compatibility with the RM for the cases of assertion, invariant,
24937 -- precondition, predicate, and postcondition.
24939 if Assertions_Enabled
then
24942 return Name_Ignore
;
24946 ---------------------------
24947 -- Check_Missing_Part_Of --
24948 ---------------------------
24950 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
24951 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
24952 -- Determine whether a package denoted by Pack_Id declares at least one
24955 -----------------------
24956 -- Has_Visible_State --
24957 -----------------------
24959 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
24960 Item_Id
: Entity_Id
;
24963 -- Traverse the entity chain of the package trying to find at least
24964 -- one visible abstract state, variable or a package [instantiation]
24965 -- that declares a visible state.
24967 Item_Id
:= First_Entity
(Pack_Id
);
24968 while Present
(Item_Id
)
24969 and then not In_Private_Part
(Item_Id
)
24971 -- Do not consider internally generated items
24973 if not Comes_From_Source
(Item_Id
) then
24976 -- A visible state has been found
24978 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24981 -- Recursively peek into nested packages and instantiations
24983 elsif Ekind
(Item_Id
) = E_Package
24984 and then Has_Visible_State
(Item_Id
)
24989 Next_Entity
(Item_Id
);
24993 end Has_Visible_State
;
24997 Pack_Id
: Entity_Id
;
24998 Placement
: State_Space_Kind
;
25000 -- Start of processing for Check_Missing_Part_Of
25003 -- Do not consider abstract states, variables or package instantiations
25004 -- coming from an instance as those always inherit the Part_Of indicator
25005 -- of the instance itself.
25007 if In_Instance
then
25010 -- Do not consider internally generated entities as these can never
25011 -- have a Part_Of indicator.
25013 elsif not Comes_From_Source
(Item_Id
) then
25016 -- Perform these checks only when SPARK_Mode is enabled as they will
25017 -- interfere with standard Ada rules and produce false positives.
25019 elsif SPARK_Mode
/= On
then
25022 -- Do not consider constants without variable input because those are
25023 -- not part of the hidden state of a package (SPARK RM 7.1.1(2)).
25025 elsif Ekind
(Item_Id
) = E_Constant
25026 and then not Has_Variable_Input
(Item_Id
)
25031 -- Find where the abstract state, variable or package instantiation
25032 -- lives with respect to the state space.
25034 Find_Placement_In_State_Space
25035 (Item_Id
=> Item_Id
,
25036 Placement
=> Placement
,
25037 Pack_Id
=> Pack_Id
);
25039 -- Items that appear in a non-package construct (subprogram, block, etc)
25040 -- do not require a Part_Of indicator because they can never act as a
25043 if Placement
= Not_In_Package
then
25046 -- An item declared in the body state space of a package always act as a
25047 -- constituent and does not need explicit Part_Of indicator.
25049 elsif Placement
= Body_State_Space
then
25052 -- In general an item declared in the visible state space of a package
25053 -- does not require a Part_Of indicator. The only exception is when the
25054 -- related package is a private child unit in which case Part_Of must
25055 -- denote a state in the parent unit or in one of its descendants.
25057 elsif Placement
= Visible_State_Space
then
25058 if Is_Child_Unit
(Pack_Id
)
25059 and then Is_Private_Descendant
(Pack_Id
)
25061 -- A package instantiation does not need a Part_Of indicator when
25062 -- the related generic template has no visible state.
25064 if Ekind
(Item_Id
) = E_Package
25065 and then Is_Generic_Instance
(Item_Id
)
25066 and then not Has_Visible_State
(Item_Id
)
25070 -- All other cases require Part_Of
25074 ("indicator Part_Of is required in this context "
25075 & "(SPARK RM 7.2.6(3))", Item_Id
);
25076 Error_Msg_Name_1
:= Chars
(Pack_Id
);
25078 ("\& is declared in the visible part of private child "
25079 & "unit %", Item_Id
);
25083 -- When the item appears in the private state space of a packge, it must
25084 -- be a part of some state declared by the said package.
25086 else pragma Assert
(Placement
= Private_State_Space
);
25088 -- The related package does not declare a state, the item cannot act
25089 -- as a Part_Of constituent.
25091 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
25094 -- A package instantiation does not need a Part_Of indicator when the
25095 -- related generic template has no visible state.
25097 elsif Ekind
(Pack_Id
) = E_Package
25098 and then Is_Generic_Instance
(Pack_Id
)
25099 and then not Has_Visible_State
(Pack_Id
)
25103 -- All other cases require Part_Of
25107 ("indicator Part_Of is required in this context "
25108 & "(SPARK RM 7.2.6(2))", Item_Id
);
25109 Error_Msg_Name_1
:= Chars
(Pack_Id
);
25111 ("\& is declared in the private part of package %", Item_Id
);
25114 end Check_Missing_Part_Of
;
25116 ---------------------------------------------------
25117 -- Check_Postcondition_Use_In_Inlined_Subprogram --
25118 ---------------------------------------------------
25120 procedure Check_Postcondition_Use_In_Inlined_Subprogram
25122 Spec_Id
: Entity_Id
)
25125 if Warn_On_Redundant_Constructs
25126 and then Has_Pragma_Inline_Always
(Spec_Id
)
25128 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
25130 if From_Aspect_Specification
(Prag
) then
25132 ("aspect % not enforced on inlined subprogram &?r?",
25133 Corresponding_Aspect
(Prag
), Spec_Id
);
25136 ("pragma % not enforced on inlined subprogram &?r?",
25140 end Check_Postcondition_Use_In_Inlined_Subprogram
;
25142 -------------------------------------
25143 -- Check_State_And_Constituent_Use --
25144 -------------------------------------
25146 procedure Check_State_And_Constituent_Use
25147 (States
: Elist_Id
;
25148 Constits
: Elist_Id
;
25151 function Find_Encapsulating_State
25152 (Constit_Id
: Entity_Id
) return Entity_Id
;
25153 -- Given the entity of a constituent, try to find a corresponding
25154 -- encapsulating state that appears in the same context. The routine
25155 -- returns Empty is no such state is found.
25157 ------------------------------
25158 -- Find_Encapsulating_State --
25159 ------------------------------
25161 function Find_Encapsulating_State
25162 (Constit_Id
: Entity_Id
) return Entity_Id
25164 State_Id
: Entity_Id
;
25167 -- Since a constituent may be part of a larger constituent set, climb
25168 -- the encapsulated state chain looking for a state that appears in
25169 -- the same context.
25171 State_Id
:= Encapsulating_State
(Constit_Id
);
25172 while Present
(State_Id
) loop
25173 if Contains
(States
, State_Id
) then
25177 State_Id
:= Encapsulating_State
(State_Id
);
25181 end Find_Encapsulating_State
;
25185 Constit_Elmt
: Elmt_Id
;
25186 Constit_Id
: Entity_Id
;
25187 State_Id
: Entity_Id
;
25189 -- Start of processing for Check_State_And_Constituent_Use
25192 -- Nothing to do if there are no states or constituents
25194 if No
(States
) or else No
(Constits
) then
25198 -- Inspect the list of constituents and try to determine whether its
25199 -- encapsulating state is in list States.
25201 Constit_Elmt
:= First_Elmt
(Constits
);
25202 while Present
(Constit_Elmt
) loop
25203 Constit_Id
:= Node
(Constit_Elmt
);
25205 -- Determine whether the constituent is part of an encapsulating
25206 -- state that appears in the same context and if this is the case,
25207 -- emit an error (SPARK RM 7.2.6(7)).
25209 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
25211 if Present
(State_Id
) then
25212 Error_Msg_Name_1
:= Chars
(Constit_Id
);
25214 ("cannot mention state & and its constituent % in the same "
25215 & "context", Context
, State_Id
);
25219 Next_Elmt
(Constit_Elmt
);
25221 end Check_State_And_Constituent_Use
;
25223 ---------------------------------------
25224 -- Collect_Subprogram_Inputs_Outputs --
25225 ---------------------------------------
25227 procedure Collect_Subprogram_Inputs_Outputs
25228 (Subp_Id
: Entity_Id
;
25229 Synthesize
: Boolean := False;
25230 Subp_Inputs
: in out Elist_Id
;
25231 Subp_Outputs
: in out Elist_Id
;
25232 Global_Seen
: out Boolean)
25234 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
25235 -- Collect all relevant items from a dependency clause
25237 procedure Collect_Global_List
25239 Mode
: Name_Id
:= Name_Input
);
25240 -- Collect all relevant items from a global list
25242 -------------------------------
25243 -- Collect_Dependency_Clause --
25244 -------------------------------
25246 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
25247 procedure Collect_Dependency_Item
25249 Is_Input
: Boolean);
25250 -- Add an item to the proper subprogram input or output collection
25252 -----------------------------
25253 -- Collect_Dependency_Item --
25254 -----------------------------
25256 procedure Collect_Dependency_Item
25258 Is_Input
: Boolean)
25263 -- Nothing to collect when the item is null
25265 if Nkind
(Item
) = N_Null
then
25268 -- Ditto for attribute 'Result
25270 elsif Is_Attribute_Result
(Item
) then
25273 -- Multiple items appear as an aggregate
25275 elsif Nkind
(Item
) = N_Aggregate
then
25276 Extra
:= First
(Expressions
(Item
));
25277 while Present
(Extra
) loop
25278 Collect_Dependency_Item
(Extra
, Is_Input
);
25282 -- Otherwise this is a solitary item
25286 Add_Item
(Item
, Subp_Inputs
);
25288 Add_Item
(Item
, Subp_Outputs
);
25291 end Collect_Dependency_Item
;
25293 -- Start of processing for Collect_Dependency_Clause
25296 if Nkind
(Clause
) = N_Null
then
25299 -- A dependency cause appears as component association
25301 elsif Nkind
(Clause
) = N_Component_Association
then
25302 Collect_Dependency_Item
25303 (Item
=> Expression
(Clause
),
25306 Collect_Dependency_Item
25307 (Item
=> First
(Choices
(Clause
)),
25308 Is_Input
=> False);
25310 -- To accomodate partial decoration of disabled SPARK features, this
25311 -- routine may be called with illegal input. If this is the case, do
25312 -- not raise Program_Error.
25317 end Collect_Dependency_Clause
;
25319 -------------------------
25320 -- Collect_Global_List --
25321 -------------------------
25323 procedure Collect_Global_List
25325 Mode
: Name_Id
:= Name_Input
)
25327 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
25328 -- Add an item to the proper subprogram input or output collection
25330 -------------------------
25331 -- Collect_Global_Item --
25332 -------------------------
25334 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
25336 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
25337 Add_Item
(Item
, Subp_Inputs
);
25340 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
25341 Add_Item
(Item
, Subp_Outputs
);
25343 end Collect_Global_Item
;
25350 -- Start of processing for Collect_Global_List
25353 if Nkind
(List
) = N_Null
then
25356 -- Single global item declaration
25358 elsif Nkind_In
(List
, N_Expanded_Name
,
25360 N_Selected_Component
)
25362 Collect_Global_Item
(List
, Mode
);
25364 -- Simple global list or moded global list declaration
25366 elsif Nkind
(List
) = N_Aggregate
then
25367 if Present
(Expressions
(List
)) then
25368 Item
:= First
(Expressions
(List
));
25369 while Present
(Item
) loop
25370 Collect_Global_Item
(Item
, Mode
);
25375 Assoc
:= First
(Component_Associations
(List
));
25376 while Present
(Assoc
) loop
25377 Collect_Global_List
25378 (List
=> Expression
(Assoc
),
25379 Mode
=> Chars
(First
(Choices
(Assoc
))));
25384 -- To accomodate partial decoration of disabled SPARK features, this
25385 -- routine may be called with illegal input. If this is the case, do
25386 -- not raise Program_Error.
25391 end Collect_Global_List
;
25395 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
25396 Spec_Id
: constant Entity_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
25400 Formal
: Entity_Id
;
25404 -- Start of processing for Collect_Subprogram_Inputs_Outputs
25407 Global_Seen
:= False;
25409 -- Process all [generic] formal parameters
25411 Formal
:= First_Entity
(Spec_Id
);
25412 while Present
(Formal
) loop
25413 if Ekind_In
(Formal
, E_Generic_In_Parameter
,
25414 E_In_Out_Parameter
,
25417 Add_Item
(Formal
, Subp_Inputs
);
25420 if Ekind_In
(Formal
, E_Generic_In_Out_Parameter
,
25421 E_In_Out_Parameter
,
25424 Add_Item
(Formal
, Subp_Outputs
);
25426 -- Out parameters can act as inputs when the related type is
25427 -- tagged, unconstrained array, unconstrained record or record
25428 -- with unconstrained components.
25430 if Ekind
(Formal
) = E_Out_Parameter
25431 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
25433 Add_Item
(Formal
, Subp_Inputs
);
25437 Next_Entity
(Formal
);
25440 -- When processing a subprogram body, look for pragmas Refined_Depends
25441 -- and Refined_Global as they specify the inputs and outputs.
25443 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
25444 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
25445 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
25447 -- Subprogram declaration or stand alone body case, look for pragmas
25448 -- Depends and Global
25451 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
25452 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25455 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
25456 -- because it provides finer granularity of inputs and outputs.
25458 if Present
(Global
) then
25459 Global_Seen
:= True;
25460 List
:= Expression
(Get_Argument
(Global
, Spec_Id
));
25462 -- The pragma may not have been analyzed because of the arbitrary
25463 -- declaration order of aspects. Make sure that it is analyzed for
25464 -- the purposes of item extraction.
25466 if not Analyzed
(List
) then
25467 if Pragma_Name
(Global
) = Name_Refined_Global
then
25468 Analyze_Refined_Global_In_Decl_Part
(Global
);
25470 Analyze_Global_In_Decl_Part
(Global
);
25474 Collect_Global_List
(List
);
25476 -- When the related subprogram lacks pragma [Refined_]Global, fall back
25477 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
25478 -- the inputs and outputs from [Refined_]Depends.
25480 elsif Synthesize
and then Present
(Depends
) then
25481 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
25483 -- Multiple dependency clauses appear as an aggregate
25485 if Nkind
(Clauses
) = N_Aggregate
then
25486 Clause
:= First
(Component_Associations
(Clauses
));
25487 while Present
(Clause
) loop
25488 Collect_Dependency_Clause
(Clause
);
25492 -- Otherwise this is a single dependency clause
25495 Collect_Dependency_Clause
(Clauses
);
25498 end Collect_Subprogram_Inputs_Outputs
;
25500 ---------------------------------
25501 -- Delay_Config_Pragma_Analyze --
25502 ---------------------------------
25504 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
25506 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
25507 Name_Priority_Specific_Dispatching
);
25508 end Delay_Config_Pragma_Analyze
;
25510 -----------------------
25511 -- Duplication_Error --
25512 -----------------------
25514 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
25515 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
25516 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
25519 Error_Msg_Sloc
:= Sloc
(Prev
);
25520 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
25522 -- Emit a precise message to distinguish between source pragmas and
25523 -- pragmas generated from aspects. The ordering of the two pragmas is
25527 -- Prag -- duplicate
25529 -- No error is emitted when both pragmas come from aspects because this
25530 -- is already detected by the general aspect analysis mechanism.
25532 if Prag_From_Asp
and Prev_From_Asp
then
25534 elsif Prag_From_Asp
then
25535 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
25536 elsif Prev_From_Asp
then
25537 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
25539 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
25541 end Duplication_Error
;
25543 ----------------------------------
25544 -- Find_Related_Package_Or_Body --
25545 ----------------------------------
25547 function Find_Related_Package_Or_Body
25549 Do_Checks
: Boolean := False) return Node_Id
25551 Context
: constant Node_Id
:= Parent
(Prag
);
25552 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
25556 Stmt
:= Prev
(Prag
);
25557 while Present
(Stmt
) loop
25559 -- Skip prior pragmas, but check for duplicates
25561 if Nkind
(Stmt
) = N_Pragma
then
25562 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
25568 -- Skip internally generated code
25570 elsif not Comes_From_Source
(Stmt
) then
25571 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
25573 -- The subprogram declaration is an internally generated spec
25574 -- for an expression function.
25576 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
25579 -- The subprogram is actually an instance housed within an
25580 -- anonymous wrapper package.
25582 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
25587 -- Return the current source construct which is illegal
25596 -- If we fall through, then the pragma was either the first declaration
25597 -- or it was preceded by other pragmas and no source constructs.
25599 -- The pragma is associated with a package. The immediate context in
25600 -- this case is the specification of the package.
25602 if Nkind
(Context
) = N_Package_Specification
then
25603 return Parent
(Context
);
25605 -- The pragma appears in the declarations of a package body
25607 elsif Nkind
(Context
) = N_Package_Body
then
25610 -- The pragma appears in the statements of a package body
25612 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
25613 and then Nkind
(Parent
(Context
)) = N_Package_Body
25615 return Parent
(Context
);
25617 -- The pragma is a byproduct of aspect expansion, return the related
25618 -- context of the original aspect. This case has a lower priority as
25619 -- the above circuitry pinpoints precisely the related context.
25621 elsif Present
(Corresponding_Aspect
(Prag
)) then
25622 return Parent
(Corresponding_Aspect
(Prag
));
25624 -- No candidate packge [body] found
25629 end Find_Related_Package_Or_Body
;
25631 -------------------------------------
25632 -- Find_Related_Subprogram_Or_Body --
25633 -------------------------------------
25635 function Find_Related_Subprogram_Or_Body
25637 Do_Checks
: Boolean := False) return Node_Id
25639 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
25641 procedure Expression_Function_Error
;
25642 -- Emit an error concerning pragma Prag that illegaly applies to an
25643 -- expression function.
25645 -------------------------------
25646 -- Expression_Function_Error --
25647 -------------------------------
25649 procedure Expression_Function_Error
is
25651 Error_Msg_Name_1
:= Prag_Nam
;
25653 -- Emit a precise message to distinguish between source pragmas and
25654 -- pragmas generated from aspects.
25656 if From_Aspect_Specification
(Prag
) then
25658 ("aspect % cannot apply to a stand alone expression function",
25662 ("pragma % cannot apply to a stand alone expression function",
25665 end Expression_Function_Error
;
25669 Context
: constant Node_Id
:= Parent
(Prag
);
25672 Look_For_Body
: constant Boolean :=
25673 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
25674 Name_Refined_Global
,
25675 Name_Refined_Post
);
25676 -- Refinement pragmas must be associated with a subprogram body [stub]
25678 -- Start of processing for Find_Related_Subprogram_Or_Body
25681 Stmt
:= Prev
(Prag
);
25682 while Present
(Stmt
) loop
25684 -- Skip prior pragmas, but check for duplicates. Pragmas produced
25685 -- by splitting a complex pre/postcondition are not considered to
25688 if Nkind
(Stmt
) = N_Pragma
then
25690 and then not Split_PPC
(Stmt
)
25691 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
25698 -- Emit an error when a refinement pragma appears on an expression
25699 -- function without a completion.
25702 and then Look_For_Body
25703 and then Nkind
(Stmt
) = N_Subprogram_Declaration
25704 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
25705 and then not Has_Completion
(Defining_Entity
(Stmt
))
25707 Expression_Function_Error
;
25710 -- The refinement pragma applies to a subprogram body stub
25712 elsif Look_For_Body
25713 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
25717 -- Skip internally generated code
25719 elsif not Comes_From_Source
(Stmt
) then
25720 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
25722 -- The subprogram declaration is an internally generated spec
25723 -- for an expression function.
25725 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
25728 -- The subprogram is actually an instance housed within an
25729 -- anonymous wrapper package.
25731 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
25736 -- Return the current construct which is either a subprogram body,
25737 -- a subprogram declaration or is illegal.
25746 -- If we fall through, then the pragma was either the first declaration
25747 -- or it was preceded by other pragmas and no source constructs.
25749 -- The pragma is associated with a library-level subprogram
25751 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
25752 return Unit
(Parent
(Context
));
25754 -- The pragma appears inside the statements of a subprogram body. This
25755 -- placement is the result of subprogram contract expansion.
25757 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
25758 return Parent
(Context
);
25760 -- The pragma appears inside the declarative part of a subprogram body
25762 elsif Nkind
(Context
) = N_Subprogram_Body
then
25765 -- The pragma is a byproduct of aspect expansion, return the related
25766 -- context of the original aspect. This case has a lower priority as
25767 -- the above circuitry pinpoints precisely the related context.
25769 elsif Present
(Corresponding_Aspect
(Prag
)) then
25770 return Parent
(Corresponding_Aspect
(Prag
));
25772 -- No candidate subprogram [body] found
25777 end Find_Related_Subprogram_Or_Body
;
25783 function Get_Argument
25785 Context_Id
: Entity_Id
:= Empty
) return Node_Id
25787 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
25790 -- Use the expression of the original aspect when compiling for ASIS or
25791 -- when analyzing the template of a generic unit. In both cases the
25792 -- aspect's tree must be decorated to allow for ASIS queries or to save
25793 -- the global references in the generic context.
25795 if From_Aspect_Specification
(Prag
)
25796 and then (ASIS_Mode
or else (Present
(Context_Id
)
25797 and then Is_Generic_Unit
(Context_Id
)))
25799 return Corresponding_Aspect
(Prag
);
25801 -- Otherwise use the expression of the pragma
25803 elsif Present
(Args
) then
25804 return First
(Args
);
25811 -------------------------
25812 -- Get_Base_Subprogram --
25813 -------------------------
25815 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
25816 Result
: Entity_Id
;
25819 -- Follow subprogram renaming chain
25823 if Is_Subprogram
(Result
)
25825 Nkind
(Parent
(Declaration_Node
(Result
))) =
25826 N_Subprogram_Renaming_Declaration
25827 and then Present
(Alias
(Result
))
25829 Result
:= Alias
(Result
);
25833 end Get_Base_Subprogram
;
25835 -----------------------
25836 -- Get_SPARK_Mode_Type --
25837 -----------------------
25839 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
25841 if N
= Name_On
then
25843 elsif N
= Name_Off
then
25846 -- Any other argument is illegal
25849 raise Program_Error
;
25851 end Get_SPARK_Mode_Type
;
25853 --------------------------------
25854 -- Get_SPARK_Mode_From_Pragma --
25855 --------------------------------
25857 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
25862 pragma Assert
(Nkind
(N
) = N_Pragma
);
25863 Args
:= Pragma_Argument_Associations
(N
);
25865 -- Extract the mode from the argument list
25867 if Present
(Args
) then
25868 Mode
:= First
(Pragma_Argument_Associations
(N
));
25869 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
25871 -- If SPARK_Mode pragma has no argument, default is ON
25876 end Get_SPARK_Mode_From_Pragma
;
25878 ---------------------------
25879 -- Has_Extra_Parentheses --
25880 ---------------------------
25882 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
25886 -- The aggregate should not have an expression list because a clause
25887 -- is always interpreted as a component association. The only way an
25888 -- expression list can sneak in is by adding extra parentheses around
25889 -- the individual clauses:
25891 -- Depends (Output => Input) -- proper form
25892 -- Depends ((Output => Input)) -- extra parentheses
25894 -- Since the extra parentheses are not allowed by the syntax of the
25895 -- pragma, flag them now to avoid emitting misleading errors down the
25898 if Nkind
(Clause
) = N_Aggregate
25899 and then Present
(Expressions
(Clause
))
25901 Expr
:= First
(Expressions
(Clause
));
25902 while Present
(Expr
) loop
25904 -- A dependency clause surrounded by extra parentheses appears
25905 -- as an aggregate of component associations with an optional
25906 -- Paren_Count set.
25908 if Nkind
(Expr
) = N_Aggregate
25909 and then Present
(Component_Associations
(Expr
))
25912 ("dependency clause contains extra parentheses", Expr
);
25914 -- Otherwise the expression is a malformed construct
25917 SPARK_Msg_N
("malformed dependency clause", Expr
);
25927 end Has_Extra_Parentheses
;
25933 procedure Initialize
is
25944 Dummy
:= Dummy
+ 1;
25947 -----------------------------
25948 -- Is_Config_Static_String --
25949 -----------------------------
25951 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25953 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
25954 -- This is an internal recursive function that is just like the outer
25955 -- function except that it adds the string to the name buffer rather
25956 -- than placing the string in the name buffer.
25958 ------------------------------
25959 -- Add_Config_Static_String --
25960 ------------------------------
25962 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25969 if Nkind
(N
) = N_Op_Concat
then
25970 if Add_Config_Static_String
(Left_Opnd
(N
)) then
25971 N
:= Right_Opnd
(N
);
25977 if Nkind
(N
) /= N_String_Literal
then
25978 Error_Msg_N
("string literal expected for pragma argument", N
);
25982 for J
in 1 .. String_Length
(Strval
(N
)) loop
25983 C
:= Get_String_Char
(Strval
(N
), J
);
25985 if not In_Character_Range
(C
) then
25987 ("string literal contains invalid wide character",
25988 Sloc
(N
) + 1 + Source_Ptr
(J
));
25992 Add_Char_To_Name_Buffer
(Get_Character
(C
));
25997 end Add_Config_Static_String
;
25999 -- Start of processing for Is_Config_Static_String
26004 return Add_Config_Static_String
(Arg
);
26005 end Is_Config_Static_String
;
26007 -------------------------------
26008 -- Is_Elaboration_SPARK_Mode --
26009 -------------------------------
26011 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
26014 (Nkind
(N
) = N_Pragma
26015 and then Pragma_Name
(N
) = Name_SPARK_Mode
26016 and then Is_List_Member
(N
));
26018 -- Pragma SPARK_Mode affects the elaboration of a package body when it
26019 -- appears in the statement part of the body.
26022 Present
(Parent
(N
))
26023 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
26024 and then List_Containing
(N
) = Statements
(Parent
(N
))
26025 and then Present
(Parent
(Parent
(N
)))
26026 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
26027 end Is_Elaboration_SPARK_Mode
;
26029 -----------------------------------------
26030 -- Is_Non_Significant_Pragma_Reference --
26031 -----------------------------------------
26033 -- This function makes use of the following static table which indicates
26034 -- whether appearance of some name in a given pragma is to be considered
26035 -- as a reference for the purposes of warnings about unreferenced objects.
26037 -- -1 indicates that appearence in any argument is significant
26038 -- 0 indicates that appearance in any argument is not significant
26039 -- +n indicates that appearance as argument n is significant, but all
26040 -- other arguments are not significant
26041 -- 9n arguments from n on are significant, before n inisignificant
26043 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
26044 (Pragma_Abort_Defer
=> -1,
26045 Pragma_Abstract_State
=> -1,
26046 Pragma_Ada_83
=> -1,
26047 Pragma_Ada_95
=> -1,
26048 Pragma_Ada_05
=> -1,
26049 Pragma_Ada_2005
=> -1,
26050 Pragma_Ada_12
=> -1,
26051 Pragma_Ada_2012
=> -1,
26052 Pragma_All_Calls_Remote
=> -1,
26053 Pragma_Allow_Integer_Address
=> -1,
26054 Pragma_Annotate
=> 93,
26055 Pragma_Assert
=> -1,
26056 Pragma_Assert_And_Cut
=> -1,
26057 Pragma_Assertion_Policy
=> 0,
26058 Pragma_Assume
=> -1,
26059 Pragma_Assume_No_Invalid_Values
=> 0,
26060 Pragma_Async_Readers
=> 0,
26061 Pragma_Async_Writers
=> 0,
26062 Pragma_Asynchronous
=> 0,
26063 Pragma_Atomic
=> 0,
26064 Pragma_Atomic_Components
=> 0,
26065 Pragma_Attach_Handler
=> -1,
26066 Pragma_Attribute_Definition
=> 92,
26067 Pragma_Check
=> -1,
26068 Pragma_Check_Float_Overflow
=> 0,
26069 Pragma_Check_Name
=> 0,
26070 Pragma_Check_Policy
=> 0,
26071 Pragma_CIL_Constructor
=> 0,
26072 Pragma_CPP_Class
=> 0,
26073 Pragma_CPP_Constructor
=> 0,
26074 Pragma_CPP_Virtual
=> 0,
26075 Pragma_CPP_Vtable
=> 0,
26077 Pragma_C_Pass_By_Copy
=> 0,
26078 Pragma_Comment
=> -1,
26079 Pragma_Common_Object
=> 0,
26080 Pragma_Compile_Time_Error
=> -1,
26081 Pragma_Compile_Time_Warning
=> -1,
26082 Pragma_Compiler_Unit
=> -1,
26083 Pragma_Compiler_Unit_Warning
=> -1,
26084 Pragma_Complete_Representation
=> 0,
26085 Pragma_Complex_Representation
=> 0,
26086 Pragma_Component_Alignment
=> 0,
26087 Pragma_Contract_Cases
=> -1,
26088 Pragma_Controlled
=> 0,
26089 Pragma_Convention
=> 0,
26090 Pragma_Convention_Identifier
=> 0,
26091 Pragma_Debug
=> -1,
26092 Pragma_Debug_Policy
=> 0,
26093 Pragma_Detect_Blocking
=> 0,
26094 Pragma_Default_Initial_Condition
=> -1,
26095 Pragma_Default_Scalar_Storage_Order
=> 0,
26096 Pragma_Default_Storage_Pool
=> 0,
26097 Pragma_Depends
=> -1,
26098 Pragma_Disable_Atomic_Synchronization
=> 0,
26099 Pragma_Discard_Names
=> 0,
26100 Pragma_Dispatching_Domain
=> -1,
26101 Pragma_Effective_Reads
=> 0,
26102 Pragma_Effective_Writes
=> 0,
26103 Pragma_Elaborate
=> 0,
26104 Pragma_Elaborate_All
=> 0,
26105 Pragma_Elaborate_Body
=> 0,
26106 Pragma_Elaboration_Checks
=> 0,
26107 Pragma_Eliminate
=> 0,
26108 Pragma_Enable_Atomic_Synchronization
=> 0,
26109 Pragma_Export
=> -1,
26110 Pragma_Export_Function
=> -1,
26111 Pragma_Export_Object
=> -1,
26112 Pragma_Export_Procedure
=> -1,
26113 Pragma_Export_Value
=> -1,
26114 Pragma_Export_Valued_Procedure
=> -1,
26115 Pragma_Extend_System
=> -1,
26116 Pragma_Extensions_Allowed
=> 0,
26117 Pragma_Extensions_Visible
=> 0,
26118 Pragma_External
=> -1,
26119 Pragma_Favor_Top_Level
=> 0,
26120 Pragma_External_Name_Casing
=> 0,
26121 Pragma_Fast_Math
=> 0,
26122 Pragma_Finalize_Storage_Only
=> 0,
26124 Pragma_Global
=> -1,
26125 Pragma_Ident
=> -1,
26126 Pragma_Ignore_Pragma
=> 0,
26127 Pragma_Implementation_Defined
=> -1,
26128 Pragma_Implemented
=> -1,
26129 Pragma_Implicit_Packing
=> 0,
26130 Pragma_Import
=> 93,
26131 Pragma_Import_Function
=> 0,
26132 Pragma_Import_Object
=> 0,
26133 Pragma_Import_Procedure
=> 0,
26134 Pragma_Import_Valued_Procedure
=> 0,
26135 Pragma_Independent
=> 0,
26136 Pragma_Independent_Components
=> 0,
26137 Pragma_Initial_Condition
=> -1,
26138 Pragma_Initialize_Scalars
=> 0,
26139 Pragma_Initializes
=> -1,
26140 Pragma_Inline
=> 0,
26141 Pragma_Inline_Always
=> 0,
26142 Pragma_Inline_Generic
=> 0,
26143 Pragma_Inspection_Point
=> -1,
26144 Pragma_Interface
=> 92,
26145 Pragma_Interface_Name
=> 0,
26146 Pragma_Interrupt_Handler
=> -1,
26147 Pragma_Interrupt_Priority
=> -1,
26148 Pragma_Interrupt_State
=> -1,
26149 Pragma_Invariant
=> -1,
26150 Pragma_Java_Constructor
=> -1,
26151 Pragma_Java_Interface
=> -1,
26152 Pragma_Keep_Names
=> 0,
26153 Pragma_License
=> 0,
26154 Pragma_Link_With
=> -1,
26155 Pragma_Linker_Alias
=> -1,
26156 Pragma_Linker_Constructor
=> -1,
26157 Pragma_Linker_Destructor
=> -1,
26158 Pragma_Linker_Options
=> -1,
26159 Pragma_Linker_Section
=> 0,
26161 Pragma_Lock_Free
=> 0,
26162 Pragma_Locking_Policy
=> 0,
26163 Pragma_Loop_Invariant
=> -1,
26164 Pragma_Loop_Optimize
=> 0,
26165 Pragma_Loop_Variant
=> -1,
26166 Pragma_Machine_Attribute
=> -1,
26168 Pragma_Main_Storage
=> -1,
26169 Pragma_Memory_Size
=> 0,
26170 Pragma_No_Return
=> 0,
26171 Pragma_No_Body
=> 0,
26172 Pragma_No_Elaboration_Code_All
=> 0,
26173 Pragma_No_Inline
=> 0,
26174 Pragma_No_Run_Time
=> -1,
26175 Pragma_No_Strict_Aliasing
=> -1,
26176 Pragma_No_Tagged_Streams
=> 0,
26177 Pragma_Normalize_Scalars
=> 0,
26178 Pragma_Obsolescent
=> 0,
26179 Pragma_Optimize
=> 0,
26180 Pragma_Optimize_Alignment
=> 0,
26181 Pragma_Overflow_Mode
=> 0,
26182 Pragma_Overriding_Renamings
=> 0,
26183 Pragma_Ordered
=> 0,
26186 Pragma_Part_Of
=> 0,
26187 Pragma_Partition_Elaboration_Policy
=> 0,
26188 Pragma_Passive
=> 0,
26189 Pragma_Persistent_BSS
=> 0,
26190 Pragma_Polling
=> 0,
26191 Pragma_Prefix_Exception_Messages
=> 0,
26193 Pragma_Postcondition
=> -1,
26194 Pragma_Post_Class
=> -1,
26196 Pragma_Precondition
=> -1,
26197 Pragma_Predicate
=> -1,
26198 Pragma_Preelaborable_Initialization
=> -1,
26199 Pragma_Preelaborate
=> 0,
26200 Pragma_Pre_Class
=> -1,
26201 Pragma_Priority
=> -1,
26202 Pragma_Priority_Specific_Dispatching
=> 0,
26203 Pragma_Profile
=> 0,
26204 Pragma_Profile_Warnings
=> 0,
26205 Pragma_Propagate_Exceptions
=> 0,
26206 Pragma_Provide_Shift_Operators
=> 0,
26207 Pragma_Psect_Object
=> 0,
26209 Pragma_Pure_Function
=> 0,
26210 Pragma_Queuing_Policy
=> 0,
26211 Pragma_Rational
=> 0,
26212 Pragma_Ravenscar
=> 0,
26213 Pragma_Refined_Depends
=> -1,
26214 Pragma_Refined_Global
=> -1,
26215 Pragma_Refined_Post
=> -1,
26216 Pragma_Refined_State
=> -1,
26217 Pragma_Relative_Deadline
=> 0,
26218 Pragma_Remote_Access_Type
=> -1,
26219 Pragma_Remote_Call_Interface
=> -1,
26220 Pragma_Remote_Types
=> -1,
26221 Pragma_Restricted_Run_Time
=> 0,
26222 Pragma_Restriction_Warnings
=> 0,
26223 Pragma_Restrictions
=> 0,
26224 Pragma_Reviewable
=> -1,
26225 Pragma_Short_Circuit_And_Or
=> 0,
26226 Pragma_Share_Generic
=> 0,
26227 Pragma_Shared
=> 0,
26228 Pragma_Shared_Passive
=> 0,
26229 Pragma_Short_Descriptors
=> 0,
26230 Pragma_Simple_Storage_Pool_Type
=> 0,
26231 Pragma_Source_File_Name
=> 0,
26232 Pragma_Source_File_Name_Project
=> 0,
26233 Pragma_Source_Reference
=> 0,
26234 Pragma_SPARK_Mode
=> 0,
26235 Pragma_Storage_Size
=> -1,
26236 Pragma_Storage_Unit
=> 0,
26237 Pragma_Static_Elaboration_Desired
=> 0,
26238 Pragma_Stream_Convert
=> 0,
26239 Pragma_Style_Checks
=> 0,
26240 Pragma_Subtitle
=> 0,
26241 Pragma_Suppress
=> 0,
26242 Pragma_Suppress_Exception_Locations
=> 0,
26243 Pragma_Suppress_All
=> 0,
26244 Pragma_Suppress_Debug_Info
=> 0,
26245 Pragma_Suppress_Initialization
=> 0,
26246 Pragma_System_Name
=> 0,
26247 Pragma_Task_Dispatching_Policy
=> 0,
26248 Pragma_Task_Info
=> -1,
26249 Pragma_Task_Name
=> -1,
26250 Pragma_Task_Storage
=> -1,
26251 Pragma_Test_Case
=> -1,
26252 Pragma_Thread_Local_Storage
=> -1,
26253 Pragma_Time_Slice
=> -1,
26255 Pragma_Type_Invariant
=> -1,
26256 Pragma_Type_Invariant_Class
=> -1,
26257 Pragma_Unchecked_Union
=> 0,
26258 Pragma_Unimplemented_Unit
=> 0,
26259 Pragma_Universal_Aliasing
=> 0,
26260 Pragma_Universal_Data
=> 0,
26261 Pragma_Unmodified
=> 0,
26262 Pragma_Unreferenced
=> 0,
26263 Pragma_Unreferenced_Objects
=> 0,
26264 Pragma_Unreserve_All_Interrupts
=> 0,
26265 Pragma_Unsuppress
=> 0,
26266 Pragma_Unevaluated_Use_Of_Old
=> 0,
26267 Pragma_Use_VADS_Size
=> 0,
26268 Pragma_Validity_Checks
=> 0,
26269 Pragma_Volatile
=> 0,
26270 Pragma_Volatile_Components
=> 0,
26271 Pragma_Volatile_Full_Access
=> 0,
26272 Pragma_Warning_As_Error
=> 0,
26273 Pragma_Warnings
=> 0,
26274 Pragma_Weak_External
=> 0,
26275 Pragma_Wide_Character_Encoding
=> 0,
26276 Unknown_Pragma
=> 0);
26278 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
26284 function Arg_No
return Nat
;
26285 -- Returns an integer showing what argument we are in. A value of
26286 -- zero means we are not in any of the arguments.
26292 function Arg_No
return Nat
is
26297 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
26311 -- Start of processing for Non_Significant_Pragma_Reference
26316 if Nkind
(P
) /= N_Pragma_Argument_Association
then
26320 Id
:= Get_Pragma_Id
(Parent
(P
));
26321 C
:= Sig_Flags
(Id
);
26336 return AN
< (C
- 90);
26342 end Is_Non_Significant_Pragma_Reference
;
26344 ------------------------------
26345 -- Is_Pragma_String_Literal --
26346 ------------------------------
26348 -- This function returns true if the corresponding pragma argument is a
26349 -- static string expression. These are the only cases in which string
26350 -- literals can appear as pragma arguments. We also allow a string literal
26351 -- as the first argument to pragma Assert (although it will of course
26352 -- always generate a type error).
26354 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
26355 Pragn
: constant Node_Id
:= Parent
(Par
);
26356 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
26357 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
26363 N
:= First
(Assoc
);
26370 if Pname
= Name_Assert
then
26373 elsif Pname
= Name_Export
then
26376 elsif Pname
= Name_Ident
then
26379 elsif Pname
= Name_Import
then
26382 elsif Pname
= Name_Interface_Name
then
26385 elsif Pname
= Name_Linker_Alias
then
26388 elsif Pname
= Name_Linker_Section
then
26391 elsif Pname
= Name_Machine_Attribute
then
26394 elsif Pname
= Name_Source_File_Name
then
26397 elsif Pname
= Name_Source_Reference
then
26400 elsif Pname
= Name_Title
then
26403 elsif Pname
= Name_Subtitle
then
26409 end Is_Pragma_String_Literal
;
26411 ---------------------------
26412 -- Is_Private_SPARK_Mode --
26413 ---------------------------
26415 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
26418 (Nkind
(N
) = N_Pragma
26419 and then Pragma_Name
(N
) = Name_SPARK_Mode
26420 and then Is_List_Member
(N
));
26422 -- For pragma SPARK_Mode to be private, it has to appear in the private
26423 -- declarations of a package.
26426 Present
(Parent
(N
))
26427 and then Nkind
(Parent
(N
)) = N_Package_Specification
26428 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
26429 end Is_Private_SPARK_Mode
;
26431 -------------------------------------
26432 -- Is_Unconstrained_Or_Tagged_Item --
26433 -------------------------------------
26435 function Is_Unconstrained_Or_Tagged_Item
26436 (Item
: Entity_Id
) return Boolean
26438 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
26439 -- Determine whether record type Typ has at least one unconstrained
26442 ---------------------------------
26443 -- Has_Unconstrained_Component --
26444 ---------------------------------
26446 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
26450 Comp
:= First_Component
(Typ
);
26451 while Present
(Comp
) loop
26452 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
26456 Next_Component
(Comp
);
26460 end Has_Unconstrained_Component
;
26464 Typ
: constant Entity_Id
:= Etype
(Item
);
26466 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
26469 if Is_Tagged_Type
(Typ
) then
26472 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
26475 elsif Is_Record_Type
(Typ
) then
26476 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
26479 return Has_Unconstrained_Component
(Typ
);
26482 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
26488 end Is_Unconstrained_Or_Tagged_Item
;
26490 -----------------------------
26491 -- Is_Valid_Assertion_Kind --
26492 -----------------------------
26494 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
26501 Name_Static_Predicate |
26502 Name_Dynamic_Predicate |
26507 Name_Type_Invariant |
26508 Name_uType_Invariant |
26512 Name_Assert_And_Cut |
26514 Name_Contract_Cases |
26516 Name_Default_Initial_Condition |
26518 Name_Initial_Condition |
26521 Name_Loop_Invariant |
26522 Name_Loop_Variant |
26523 Name_Postcondition |
26524 Name_Precondition |
26526 Name_Refined_Post |
26527 Name_Statement_Assertions
=> return True;
26529 when others => return False;
26531 end Is_Valid_Assertion_Kind
;
26533 --------------------------------------
26534 -- Process_Compilation_Unit_Pragmas --
26535 --------------------------------------
26537 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
26539 -- A special check for pragma Suppress_All, a very strange DEC pragma,
26540 -- strange because it comes at the end of the unit. Rational has the
26541 -- same name for a pragma, but treats it as a program unit pragma, In
26542 -- GNAT we just decide to allow it anywhere at all. If it appeared then
26543 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
26544 -- node, and we insert a pragma Suppress (All_Checks) at the start of
26545 -- the context clause to ensure the correct processing.
26547 if Has_Pragma_Suppress_All
(N
) then
26548 Prepend_To
(Context_Items
(N
),
26549 Make_Pragma
(Sloc
(N
),
26550 Chars
=> Name_Suppress
,
26551 Pragma_Argument_Associations
=> New_List
(
26552 Make_Pragma_Argument_Association
(Sloc
(N
),
26553 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
26556 -- Nothing else to do at the current time
26558 end Process_Compilation_Unit_Pragmas
;
26560 ------------------------------------
26561 -- Record_Possible_Body_Reference --
26562 ------------------------------------
26564 procedure Record_Possible_Body_Reference
26565 (State_Id
: Entity_Id
;
26569 Spec_Id
: Entity_Id
;
26572 -- Ensure that we are dealing with a reference to a state
26574 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
26576 -- Climb the tree starting from the reference looking for a package body
26577 -- whose spec declares the referenced state. This criteria automatically
26578 -- excludes references in package specs which are legal. Note that it is
26579 -- not wise to emit an error now as the package body may lack pragma
26580 -- Refined_State or the referenced state may not be mentioned in the
26581 -- refinement. This approach avoids the generation of misleading errors.
26584 while Present
(Context
) loop
26585 if Nkind
(Context
) = N_Package_Body
then
26586 Spec_Id
:= Corresponding_Spec
(Context
);
26588 if Present
(Abstract_States
(Spec_Id
))
26589 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
26591 if No
(Body_References
(State_Id
)) then
26592 Set_Body_References
(State_Id
, New_Elmt_List
);
26595 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
26600 Context
:= Parent
(Context
);
26602 end Record_Possible_Body_Reference
;
26604 ------------------------------
26605 -- Relocate_Pragmas_To_Body --
26606 ------------------------------
26608 procedure Relocate_Pragmas_To_Body
26609 (Subp_Body
: Node_Id
;
26610 Target_Body
: Node_Id
:= Empty
)
26612 procedure Relocate_Pragma
(Prag
: Node_Id
);
26613 -- Remove a single pragma from its current list and add it to the
26614 -- declarations of the proper body (either Subp_Body or Target_Body).
26616 ---------------------
26617 -- Relocate_Pragma --
26618 ---------------------
26620 procedure Relocate_Pragma
(Prag
: Node_Id
) is
26625 -- When subprogram stubs or expression functions are involves, the
26626 -- destination declaration list belongs to the proper body.
26628 if Present
(Target_Body
) then
26629 Target
:= Target_Body
;
26631 Target
:= Subp_Body
;
26634 Decls
:= Declarations
(Target
);
26638 Set_Declarations
(Target
, Decls
);
26641 -- Unhook the pragma from its current list
26644 Prepend
(Prag
, Decls
);
26645 end Relocate_Pragma
;
26649 Body_Id
: constant Entity_Id
:=
26650 Defining_Unit_Name
(Specification
(Subp_Body
));
26651 Next_Stmt
: Node_Id
;
26654 -- Start of processing for Relocate_Pragmas_To_Body
26657 -- Do not process a body that comes from a separate unit as no construct
26658 -- can possibly follow it.
26660 if not Is_List_Member
(Subp_Body
) then
26663 -- Do not relocate pragmas that follow a stub if the stub does not have
26666 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
26667 and then No
(Target_Body
)
26671 -- Do not process internally generated routine _Postconditions
26673 elsif Ekind
(Body_Id
) = E_Procedure
26674 and then Chars
(Body_Id
) = Name_uPostconditions
26679 -- Look at what is following the body. We are interested in certain kind
26680 -- of pragmas (either from source or byproducts of expansion) that can
26681 -- apply to a body [stub].
26683 Stmt
:= Next
(Subp_Body
);
26684 while Present
(Stmt
) loop
26686 -- Preserve the following statement for iteration purposes due to a
26687 -- possible relocation of a pragma.
26689 Next_Stmt
:= Next
(Stmt
);
26691 -- Move a candidate pragma following the body to the declarations of
26694 if Nkind
(Stmt
) = N_Pragma
26695 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
26697 Relocate_Pragma
(Stmt
);
26699 -- Skip internally generated code
26701 elsif not Comes_From_Source
(Stmt
) then
26704 -- No candidate pragmas are available for relocation
26712 end Relocate_Pragmas_To_Body
;
26714 -------------------
26715 -- Resolve_State --
26716 -------------------
26718 procedure Resolve_State
(N
: Node_Id
) is
26723 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26724 Func
:= Entity
(N
);
26726 -- Handle overloading of state names by functions. Traverse the
26727 -- homonym chain looking for an abstract state.
26729 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
26730 State
:= Homonym
(Func
);
26731 while Present
(State
) loop
26733 -- Resolve the overloading by setting the proper entity of the
26734 -- reference to that of the state.
26736 if Ekind
(State
) = E_Abstract_State
then
26737 Set_Etype
(N
, Standard_Void_Type
);
26738 Set_Entity
(N
, State
);
26739 Set_Associated_Node
(N
, State
);
26743 State
:= Homonym
(State
);
26746 -- A function can never act as a state. If the homonym chain does
26747 -- not contain a corresponding state, then something went wrong in
26748 -- the overloading mechanism.
26750 raise Program_Error
;
26755 ----------------------------
26756 -- Rewrite_Assertion_Kind --
26757 ----------------------------
26759 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
26763 if Nkind
(N
) = N_Attribute_Reference
26764 and then Attribute_Name
(N
) = Name_Class
26765 and then Nkind
(Prefix
(N
)) = N_Identifier
26767 case Chars
(Prefix
(N
)) is
26772 when Name_Type_Invariant
=>
26773 Nam
:= Name_uType_Invariant
;
26774 when Name_Invariant
=>
26775 Nam
:= Name_uInvariant
;
26780 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
26782 end Rewrite_Assertion_Kind
;
26790 Dummy
:= Dummy
+ 1;
26793 --------------------------------
26794 -- Set_Encoded_Interface_Name --
26795 --------------------------------
26797 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
26798 Str
: constant String_Id
:= Strval
(S
);
26799 Len
: constant Int
:= String_Length
(Str
);
26804 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
26807 -- Stores encoded value of character code CC. The encoding we use an
26808 -- underscore followed by four lower case hex digits.
26814 procedure Encode
is
26816 Store_String_Char
(Get_Char_Code
('_'));
26818 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
26820 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
26822 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
26824 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
26827 -- Start of processing for Set_Encoded_Interface_Name
26830 -- If first character is asterisk, this is a link name, and we leave it
26831 -- completely unmodified. We also ignore null strings (the latter case
26832 -- happens only in error cases) and no encoding should occur for Java or
26833 -- AAMP interface names.
26836 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
26837 or else VM_Target
/= No_VM
26838 or else AAMP_On_Target
26840 Set_Interface_Name
(E
, S
);
26845 CC
:= Get_String_Char
(Str
, J
);
26847 exit when not In_Character_Range
(CC
);
26849 C
:= Get_Character
(CC
);
26851 exit when C
/= '_' and then C
/= '$'
26852 and then C
not in '0' .. '9'
26853 and then C
not in 'a' .. 'z'
26854 and then C
not in 'A' .. 'Z';
26857 Set_Interface_Name
(E
, S
);
26865 -- Here we need to encode. The encoding we use as follows:
26866 -- three underscores + four hex digits (lower case)
26870 for J
in 1 .. String_Length
(Str
) loop
26871 CC
:= Get_String_Char
(Str
, J
);
26873 if not In_Character_Range
(CC
) then
26876 C
:= Get_Character
(CC
);
26878 if C
= '_' or else C
= '$'
26879 or else C
in '0' .. '9'
26880 or else C
in 'a' .. 'z'
26881 or else C
in 'A' .. 'Z'
26883 Store_String_Char
(CC
);
26890 Set_Interface_Name
(E
,
26891 Make_String_Literal
(Sloc
(S
),
26892 Strval
=> End_String
));
26894 end Set_Encoded_Interface_Name
;
26896 ------------------------
26897 -- Set_Elab_Unit_Name --
26898 ------------------------
26900 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
26905 if Nkind
(N
) = N_Identifier
26906 and then Nkind
(With_Item
) = N_Identifier
26908 Set_Entity
(N
, Entity
(With_Item
));
26910 elsif Nkind
(N
) = N_Selected_Component
then
26911 Change_Selected_Component_To_Expanded_Name
(N
);
26912 Set_Entity
(N
, Entity
(With_Item
));
26913 Set_Entity
(Selector_Name
(N
), Entity
(N
));
26915 Pref
:= Prefix
(N
);
26916 Scop
:= Scope
(Entity
(N
));
26917 while Nkind
(Pref
) = N_Selected_Component
loop
26918 Change_Selected_Component_To_Expanded_Name
(Pref
);
26919 Set_Entity
(Selector_Name
(Pref
), Scop
);
26920 Set_Entity
(Pref
, Scop
);
26921 Pref
:= Prefix
(Pref
);
26922 Scop
:= Scope
(Scop
);
26925 Set_Entity
(Pref
, Scop
);
26928 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
26929 end Set_Elab_Unit_Name
;
26931 -------------------
26932 -- Test_Case_Arg --
26933 -------------------
26935 function Test_Case_Arg
26938 From_Aspect
: Boolean := False) return Node_Id
26940 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
26945 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
26950 -- The caller requests the aspect argument
26952 if From_Aspect
then
26953 if Present
(Aspect
)
26954 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
26956 Args
:= Expression
(Aspect
);
26958 -- "Name" and "Mode" may appear without an identifier as a
26959 -- positional association.
26961 if Present
(Expressions
(Args
)) then
26962 Arg
:= First
(Expressions
(Args
));
26964 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
26972 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
26977 -- Some or all arguments may appear as component associatons
26979 if Present
(Component_Associations
(Args
)) then
26980 Arg
:= First
(Component_Associations
(Args
));
26981 while Present
(Arg
) loop
26982 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
26991 -- Otherwise retrieve the argument directly from the pragma
26994 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
26996 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
27000 -- Skip argument "Name"
27004 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
27008 -- Skip argument "Mode"
27012 -- Arguments "Requires" and "Ensures" are optional and may not be
27015 while Present
(Arg
) loop
27016 if Chars
(Arg
) = Arg_Nam
then