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 -- Check for applying VFA to an entity which has volatile component
5903 if Prag_Id
= Pragma_Volatile_Full_Access
then
5906 Aliased_Comp
: Boolean := False;
5907 -- Set True if aliased component present
5910 if Is_Array_Type
(Etype
(E
)) then
5911 Aliased_Comp
:= Has_Aliased_Components
(Etype
(E
));
5913 -- Record case, too bad Has_Aliased_Components is not also
5914 -- set for records, should it be ???
5916 elsif Is_Record_Type
(Etype
(E
)) then
5917 Comp
:= First_Component_Or_Discriminant
(Etype
(E
));
5918 while Present
(Comp
) loop
5919 if Is_Aliased
(Comp
)
5920 or else Is_Aliased
(Etype
(Comp
))
5922 Aliased_Comp
:= True;
5926 Next_Component_Or_Discriminant
(Comp
);
5930 if Aliased_Comp
then
5932 ("cannot apply Volatile_Full_Access (aliased component "
5938 -- Now check appropriateness of the entity
5941 if Rep_Item_Too_Early
(E
, N
)
5943 Rep_Item_Too_Late
(E
, N
)
5947 Check_First_Subtype
(Arg1
);
5950 -- Attribute belongs on the base type. If the view of the type is
5951 -- currently private, it also belongs on the underlying type.
5953 if Prag_Id
= Pragma_Atomic
5955 Prag_Id
= Pragma_Shared
5957 Prag_Id
= Pragma_Volatile_Full_Access
5959 Set_Atomic_Full
(E
);
5960 Set_Atomic_Full
(Base_Type
(E
));
5961 Set_Atomic_Full
(Underlying_Type
(E
));
5964 -- Atomic/Shared/Volatile_Full_Access imply Independent
5966 if Prag_Id
/= Pragma_Volatile
then
5967 Set_Is_Independent
(E
);
5968 Set_Is_Independent
(Base_Type
(E
));
5969 Set_Is_Independent
(Underlying_Type
(E
));
5971 if Prag_Id
= Pragma_Independent
then
5972 Record_Independence_Check
(N
, Base_Type
(E
));
5976 -- Atomic/Shared/Volatile_Full_Access imply Volatile
5978 if Prag_Id
/= Pragma_Independent
then
5979 Set_Is_Volatile
(E
);
5980 Set_Is_Volatile
(Base_Type
(E
));
5981 Set_Is_Volatile
(Underlying_Type
(E
));
5983 Set_Treat_As_Volatile
(E
);
5984 Set_Treat_As_Volatile
(Underlying_Type
(E
));
5987 elsif K
= N_Object_Declaration
5988 or else (K
= N_Component_Declaration
5989 and then Original_Record_Component
(E
) = E
)
5991 if Rep_Item_Too_Late
(E
, N
) then
5995 if Prag_Id
= Pragma_Atomic
5997 Prag_Id
= Pragma_Shared
5999 Prag_Id
= Pragma_Volatile_Full_Access
6001 if Prag_Id
= Pragma_Volatile_Full_Access
then
6002 Set_Has_Volatile_Full_Access
(E
);
6007 -- If the object declaration has an explicit initialization, a
6008 -- temporary may have to be created to hold the expression, to
6009 -- ensure that access to the object remain atomic.
6011 if Nkind
(Parent
(E
)) = N_Object_Declaration
6012 and then Present
(Expression
(Parent
(E
)))
6014 Set_Has_Delayed_Freeze
(E
);
6017 -- An interesting improvement here. If an object of composite
6018 -- type X is declared atomic, and the type X isn't, that's a
6019 -- pity, since it may not have appropriate alignment etc. We
6020 -- can rescue this in the special case where the object and
6021 -- type are in the same unit by just setting the type as
6022 -- atomic, so that the back end will process it as atomic.
6024 -- Note: we used to do this for elementary types as well,
6025 -- but that turns out to be a bad idea and can have unwanted
6026 -- effects, most notably if the type is elementary, the object
6027 -- a simple component within a record, and both are in a spec:
6028 -- every object of this type in the entire program will be
6029 -- treated as atomic, thus incurring a potentially costly
6030 -- synchronization operation for every access.
6032 -- For Volatile_Full_Access we can do this for elementary types
6033 -- too, since there is no issue of atomic synchronization.
6035 -- Of course it would be best if the back end could just adjust
6036 -- the alignment etc for the specific object, but that's not
6037 -- something we are capable of doing at this point.
6039 Utyp
:= Underlying_Type
(Etype
(E
));
6042 and then (Is_Composite_Type
(Utyp
)
6043 or else Prag_Id
= Pragma_Volatile_Full_Access
)
6044 and then Sloc
(E
) > No_Location
6045 and then Sloc
(Utyp
) > No_Location
6047 Get_Source_File_Index
(Sloc
(E
)) =
6048 Get_Source_File_Index
(Sloc
(Utyp
))
6050 if Prag_Id
= Pragma_Volatile_Full_Access
then
6051 Set_Has_Volatile_Full_Access
(Utyp
);
6053 Set_Is_Atomic
(Utyp
);
6058 -- Atomic/Shared/Volatile_Full_Access imply Independent
6060 if Prag_Id
/= Pragma_Volatile
then
6061 Set_Is_Independent
(E
);
6063 if Prag_Id
= Pragma_Independent
then
6064 Record_Independence_Check
(N
, E
);
6068 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6070 if Prag_Id
/= Pragma_Independent
then
6071 Set_Is_Volatile
(E
);
6072 Set_Treat_As_Volatile
(E
);
6076 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6079 -- The following check is only relevant when SPARK_Mode is on as
6080 -- this is not a standard Ada legality rule. Pragma Volatile can
6081 -- only apply to a full type declaration or an object declaration
6082 -- (SPARK RM C.6(1)).
6085 and then Prag_Id
= Pragma_Volatile
6086 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
6087 N_Object_Declaration
)
6090 ("argument of pragma % must denote a full type or object "
6091 & "declaration", Arg1
);
6093 end Process_Atomic_Independent_Shared_Volatile
;
6095 -------------------------------------------
6096 -- Process_Compile_Time_Warning_Or_Error --
6097 -------------------------------------------
6099 procedure Process_Compile_Time_Warning_Or_Error
is
6100 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6103 Check_Arg_Count
(2);
6104 Check_No_Identifiers
;
6105 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6106 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6108 if Compile_Time_Known_Value
(Arg1x
) then
6109 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6111 Str
: constant String_Id
:=
6112 Strval
(Get_Pragma_Arg
(Arg2
));
6113 Len
: constant Int
:= String_Length
(Str
);
6118 Cent
: constant Entity_Id
:=
6119 Cunit_Entity
(Current_Sem_Unit
);
6121 Force
: constant Boolean :=
6122 Prag_Id
= Pragma_Compile_Time_Warning
6124 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6125 and then (Ekind
(Cent
) /= E_Package
6126 or else not In_Private_Part
(Cent
));
6127 -- Set True if this is the warning case, and we are in the
6128 -- visible part of a package spec, or in a subprogram spec,
6129 -- in which case we want to force the client to see the
6130 -- warning, even though it is not in the main unit.
6133 -- Loop through segments of message separated by line feeds.
6134 -- We output these segments as separate messages with
6135 -- continuation marks for all but the first.
6140 Error_Msg_Strlen
:= 0;
6142 -- Loop to copy characters from argument to error message
6146 exit when Ptr
> Len
;
6147 CC
:= Get_String_Char
(Str
, Ptr
);
6150 -- Ignore wide chars ??? else store character
6152 if In_Character_Range
(CC
) then
6153 C
:= Get_Character
(CC
);
6154 exit when C
= ASCII
.LF
;
6155 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6156 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6160 -- Here with one line ready to go
6162 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6164 -- If this is a warning in a spec, then we want clients
6165 -- to see the warning, so mark the message with the
6166 -- special sequence !! to force the warning. In the case
6167 -- of a package spec, we do not force this if we are in
6168 -- the private part of the spec.
6171 if Cont
= False then
6172 Error_Msg_N
("<<~!!", Arg1
);
6175 Error_Msg_N
("\<<~!!", Arg1
);
6178 -- Error, rather than warning, or in a body, so we do not
6179 -- need to force visibility for client (error will be
6180 -- output in any case, and this is the situation in which
6181 -- we do not want a client to get a warning, since the
6182 -- warning is in the body or the spec private part).
6185 if Cont
= False then
6186 Error_Msg_N
("<<~", Arg1
);
6189 Error_Msg_N
("\<<~", Arg1
);
6193 exit when Ptr
> Len
;
6198 end Process_Compile_Time_Warning_Or_Error
;
6200 ------------------------
6201 -- Process_Convention --
6202 ------------------------
6204 procedure Process_Convention
6205 (C
: out Convention_Id
;
6206 Ent
: out Entity_Id
)
6210 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6211 -- Called if we have more than one Export/Import/Convention pragma.
6212 -- This is generally illegal, but we have a special case of allowing
6213 -- Import and Interface to coexist if they specify the convention in
6214 -- a consistent manner. We are allowed to do this, since Interface is
6215 -- an implementation defined pragma, and we choose to do it since we
6216 -- know Rational allows this combination. S is the entity id of the
6217 -- subprogram in question. This procedure also sets the special flag
6218 -- Import_Interface_Present in both pragmas in the case where we do
6219 -- have matching Import and Interface pragmas.
6221 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6222 -- Set convention in entity E, and also flag that the entity has a
6223 -- convention pragma. If entity is for a private or incomplete type,
6224 -- also set convention and flag on underlying type. This procedure
6225 -- also deals with the special case of C_Pass_By_Copy convention,
6226 -- and error checks for inappropriate convention specification.
6228 -------------------------------
6229 -- Diagnose_Multiple_Pragmas --
6230 -------------------------------
6232 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6233 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6237 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6238 -- Decl is a pragma node. This function returns True if this
6239 -- pragma has a first argument that is an identifier with a
6240 -- Chars field corresponding to the Convention_Id C.
6242 function Same_Name
(Decl
: Node_Id
) return Boolean;
6243 -- Decl is a pragma node. This function returns True if this
6244 -- pragma has a second argument that is an identifier with a
6245 -- Chars field that matches the Chars of the current subprogram.
6247 ---------------------
6248 -- Same_Convention --
6249 ---------------------
6251 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6252 Arg1
: constant Node_Id
:=
6253 First
(Pragma_Argument_Associations
(Decl
));
6256 if Present
(Arg1
) then
6258 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6260 if Nkind
(Arg
) = N_Identifier
6261 and then Is_Convention_Name
(Chars
(Arg
))
6262 and then Get_Convention_Id
(Chars
(Arg
)) = C
6270 end Same_Convention
;
6276 function Same_Name
(Decl
: Node_Id
) return Boolean is
6277 Arg1
: constant Node_Id
:=
6278 First
(Pragma_Argument_Associations
(Decl
));
6286 Arg2
:= Next
(Arg1
);
6293 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6295 if Nkind
(Arg
) = N_Identifier
6296 and then Chars
(Arg
) = Chars
(S
)
6305 -- Start of processing for Diagnose_Multiple_Pragmas
6310 -- Definitely give message if we have Convention/Export here
6312 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6315 -- If we have an Import or Export, scan back from pragma to
6316 -- find any previous pragma applying to the same procedure.
6317 -- The scan will be terminated by the start of the list, or
6318 -- hitting the subprogram declaration. This won't allow one
6319 -- pragma to appear in the public part and one in the private
6320 -- part, but that seems very unlikely in practice.
6324 while Present
(Decl
) and then Decl
/= Pdec
loop
6326 -- Look for pragma with same name as us
6328 if Nkind
(Decl
) = N_Pragma
6329 and then Same_Name
(Decl
)
6331 -- Give error if same as our pragma or Export/Convention
6333 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6339 -- Case of Import/Interface or the other way round
6341 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6344 -- Here we know that we have Import and Interface. It
6345 -- doesn't matter which way round they are. See if
6346 -- they specify the same convention. If so, all OK,
6347 -- and set special flags to stop other messages
6349 if Same_Convention
(Decl
) then
6350 Set_Import_Interface_Present
(N
);
6351 Set_Import_Interface_Present
(Decl
);
6354 -- If different conventions, special message
6357 Error_Msg_Sloc
:= Sloc
(Decl
);
6359 ("convention differs from that given#", Arg1
);
6369 -- Give message if needed if we fall through those tests
6370 -- except on Relaxed_RM_Semantics where we let go: either this
6371 -- is a case accepted/ignored by other Ada compilers (e.g.
6372 -- a mix of Convention and Import), or another error will be
6373 -- generated later (e.g. using both Import and Export).
6375 if Err
and not Relaxed_RM_Semantics
then
6377 ("at most one Convention/Export/Import pragma is allowed",
6380 end Diagnose_Multiple_Pragmas
;
6382 --------------------------------
6383 -- Set_Convention_From_Pragma --
6384 --------------------------------
6386 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6388 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6389 -- for an overridden dispatching operation. Technically this is
6390 -- an amendment and should only be done in Ada 2005 mode. However,
6391 -- this is clearly a mistake, since the problem that is addressed
6392 -- by this AI is that there is a clear gap in the RM.
6394 if Is_Dispatching_Operation
(E
)
6395 and then Present
(Overridden_Operation
(E
))
6396 and then C
/= Convention
(Overridden_Operation
(E
))
6399 ("cannot change convention for overridden dispatching "
6400 & "operation", Arg1
);
6403 -- Special checks for Convention_Stdcall
6405 if C
= Convention_Stdcall
then
6407 -- A dispatching call is not allowed. A dispatching subprogram
6408 -- cannot be used to interface to the Win32 API, so in fact
6409 -- this check does not impose any effective restriction.
6411 if Is_Dispatching_Operation
(E
) then
6412 Error_Msg_Sloc
:= Sloc
(E
);
6414 -- Note: make this unconditional so that if there is more
6415 -- than one call to which the pragma applies, we get a
6416 -- message for each call. Also don't use Error_Pragma,
6417 -- so that we get multiple messages.
6420 ("dispatching subprogram# cannot use Stdcall convention!",
6423 -- Subprograms are not allowed
6425 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6429 and then Ekind
(E
) /= E_Variable
6431 -- An access to subprogram is also allowed
6435 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6437 -- Allow internal call to set convention of subprogram type
6439 and then not (Ekind
(E
) = E_Subprogram_Type
)
6442 ("second argument of pragma% must be subprogram (type)",
6447 -- Set the convention
6449 Set_Convention
(E
, C
);
6450 Set_Has_Convention_Pragma
(E
);
6452 -- For the case of a record base type, also set the convention of
6453 -- any anonymous access types declared in the record which do not
6454 -- currently have a specified convention.
6456 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6461 Comp
:= First_Component
(E
);
6462 while Present
(Comp
) loop
6463 if Present
(Etype
(Comp
))
6464 and then Ekind_In
(Etype
(Comp
),
6465 E_Anonymous_Access_Type
,
6466 E_Anonymous_Access_Subprogram_Type
)
6467 and then not Has_Convention_Pragma
(Comp
)
6469 Set_Convention
(Comp
, C
);
6472 Next_Component
(Comp
);
6477 -- Deal with incomplete/private type case, where underlying type
6478 -- is available, so set convention of that underlying type.
6480 if Is_Incomplete_Or_Private_Type
(E
)
6481 and then Present
(Underlying_Type
(E
))
6483 Set_Convention
(Underlying_Type
(E
), C
);
6484 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6487 -- A class-wide type should inherit the convention of the specific
6488 -- root type (although this isn't specified clearly by the RM).
6490 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6491 Set_Convention
(Class_Wide_Type
(E
), C
);
6494 -- If the entity is a record type, then check for special case of
6495 -- C_Pass_By_Copy, which is treated the same as C except that the
6496 -- special record flag is set. This convention is only permitted
6497 -- on record types (see AI95-00131).
6499 if Cname
= Name_C_Pass_By_Copy
then
6500 if Is_Record_Type
(E
) then
6501 Set_C_Pass_By_Copy
(Base_Type
(E
));
6502 elsif Is_Incomplete_Or_Private_Type
(E
)
6503 and then Is_Record_Type
(Underlying_Type
(E
))
6505 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6508 ("C_Pass_By_Copy convention allowed only for record type",
6513 -- If the entity is a derived boolean type, check for the special
6514 -- case of convention C, C++, or Fortran, where we consider any
6515 -- nonzero value to represent true.
6517 if Is_Discrete_Type
(E
)
6518 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6524 C
= Convention_Fortran
)
6526 Set_Nonzero_Is_True
(Base_Type
(E
));
6528 end Set_Convention_From_Pragma
;
6532 Comp_Unit
: Unit_Number_Type
;
6537 -- Start of processing for Process_Convention
6540 Check_At_Least_N_Arguments
(2);
6541 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6542 Check_Arg_Is_Identifier
(Arg1
);
6543 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6545 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6546 -- tested again below to set the critical flag).
6548 if Cname
= Name_C_Pass_By_Copy
then
6551 -- Otherwise we must have something in the standard convention list
6553 elsif Is_Convention_Name
(Cname
) then
6554 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6556 -- Otherwise warn on unrecognized convention
6559 if Warn_On_Export_Import
then
6561 ("??unrecognized convention name, C assumed",
6562 Get_Pragma_Arg
(Arg1
));
6568 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6569 Check_Arg_Is_Local_Name
(Arg2
);
6571 Id
:= Get_Pragma_Arg
(Arg2
);
6574 if not Is_Entity_Name
(Id
) then
6575 Error_Pragma_Arg
("entity name required", Arg2
);
6580 -- Set entity to return
6584 -- Ada_Pass_By_Copy special checking
6586 if C
= Convention_Ada_Pass_By_Copy
then
6587 if not Is_First_Subtype
(E
) then
6589 ("convention `Ada_Pass_By_Copy` only allowed for types",
6593 if Is_By_Reference_Type
(E
) then
6595 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6599 -- Ada_Pass_By_Reference special checking
6601 elsif C
= Convention_Ada_Pass_By_Reference
then
6602 if not Is_First_Subtype
(E
) then
6604 ("convention `Ada_Pass_By_Reference` only allowed for types",
6608 if Is_By_Copy_Type
(E
) then
6610 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6615 -- Go to renamed subprogram if present, since convention applies to
6616 -- the actual renamed entity, not to the renaming entity. If the
6617 -- subprogram is inherited, go to parent subprogram.
6619 if Is_Subprogram
(E
)
6620 and then Present
(Alias
(E
))
6622 if Nkind
(Parent
(Declaration_Node
(E
))) =
6623 N_Subprogram_Renaming_Declaration
6625 if Scope
(E
) /= Scope
(Alias
(E
)) then
6627 ("cannot apply pragma% to non-local entity&#", E
);
6632 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6633 N_Private_Extension_Declaration
)
6634 and then Scope
(E
) = Scope
(Alias
(E
))
6638 -- Return the parent subprogram the entity was inherited from
6644 -- Check that we are not applying this to a specless body. Relax this
6645 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
6647 if Is_Subprogram
(E
)
6648 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6649 and then not Relaxed_RM_Semantics
6652 ("pragma% requires separate spec and must come before body");
6655 -- Check that we are not applying this to a named constant
6657 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6658 Error_Msg_Name_1
:= Pname
;
6660 ("cannot apply pragma% to named constant!",
6661 Get_Pragma_Arg
(Arg2
));
6663 ("\supply appropriate type for&!", Arg2
);
6666 if Ekind
(E
) = E_Enumeration_Literal
then
6667 Error_Pragma
("enumeration literal not allowed for pragma%");
6670 -- Check for rep item appearing too early or too late
6672 if Etype
(E
) = Any_Type
6673 or else Rep_Item_Too_Early
(E
, N
)
6677 elsif Present
(Underlying_Type
(E
)) then
6678 E
:= Underlying_Type
(E
);
6681 if Rep_Item_Too_Late
(E
, N
) then
6685 if Has_Convention_Pragma
(E
) then
6686 Diagnose_Multiple_Pragmas
(E
);
6688 elsif Convention
(E
) = Convention_Protected
6689 or else Ekind
(Scope
(E
)) = E_Protected_Type
6692 ("a protected operation cannot be given a different convention",
6696 -- For Intrinsic, a subprogram is required
6698 if C
= Convention_Intrinsic
6699 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
6702 ("second argument of pragma% must be a subprogram", Arg2
);
6705 -- Deal with non-subprogram cases
6707 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
6708 Set_Convention_From_Pragma
(E
);
6712 -- The pragma must apply to a first subtype, but it can also
6713 -- apply to a generic type in a generic formal part, in which
6714 -- case it will also appear in the corresponding instance.
6716 if Is_Generic_Type
(E
) or else In_Instance
then
6719 Check_First_Subtype
(Arg2
);
6722 Set_Convention_From_Pragma
(Base_Type
(E
));
6724 -- For access subprograms, we must set the convention on the
6725 -- internally generated directly designated type as well.
6727 if Ekind
(E
) = E_Access_Subprogram_Type
then
6728 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
6732 -- For the subprogram case, set proper convention for all homonyms
6733 -- in same scope and the same declarative part, i.e. the same
6734 -- compilation unit.
6737 Comp_Unit
:= Get_Source_Unit
(E
);
6738 Set_Convention_From_Pragma
(E
);
6740 -- Treat a pragma Import as an implicit body, and pragma import
6741 -- as implicit reference (for navigation in GPS).
6743 if Prag_Id
= Pragma_Import
then
6744 Generate_Reference
(E
, Id
, 'b');
6746 -- For exported entities we restrict the generation of references
6747 -- to entities exported to foreign languages since entities
6748 -- exported to Ada do not provide further information to GPS and
6749 -- add undesired references to the output of the gnatxref tool.
6751 elsif Prag_Id
= Pragma_Export
6752 and then Convention
(E
) /= Convention_Ada
6754 Generate_Reference
(E
, Id
, 'i');
6757 -- If the pragma comes from from an aspect, it only applies to the
6758 -- given entity, not its homonyms.
6760 if From_Aspect_Specification
(N
) then
6764 -- Otherwise Loop through the homonyms of the pragma argument's
6765 -- entity, an apply convention to those in the current scope.
6771 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
6773 -- Ignore entry for which convention is already set
6775 if Has_Convention_Pragma
(E1
) then
6779 -- Do not set the pragma on inherited operations or on formal
6782 if Comes_From_Source
(E1
)
6783 and then Comp_Unit
= Get_Source_Unit
(E1
)
6784 and then not Is_Formal_Subprogram
(E1
)
6785 and then Nkind
(Original_Node
(Parent
(E1
))) /=
6786 N_Full_Type_Declaration
6788 if Present
(Alias
(E1
))
6789 and then Scope
(E1
) /= Scope
(Alias
(E1
))
6792 ("cannot apply pragma% to non-local entity& declared#",
6796 Set_Convention_From_Pragma
(E1
);
6798 if Prag_Id
= Pragma_Import
then
6799 Generate_Reference
(E1
, Id
, 'b');
6807 end Process_Convention
;
6809 ----------------------------------------
6810 -- Process_Disable_Enable_Atomic_Sync --
6811 ----------------------------------------
6813 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
6815 Check_No_Identifiers
;
6816 Check_At_Most_N_Arguments
(1);
6818 -- Modeled internally as
6819 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
6823 Pragma_Identifier
=>
6824 Make_Identifier
(Loc
, Nam
),
6825 Pragma_Argument_Associations
=> New_List
(
6826 Make_Pragma_Argument_Association
(Loc
,
6828 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
6830 if Present
(Arg1
) then
6831 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
6835 end Process_Disable_Enable_Atomic_Sync
;
6837 -------------------------------------------------
6838 -- Process_Extended_Import_Export_Internal_Arg --
6839 -------------------------------------------------
6841 procedure Process_Extended_Import_Export_Internal_Arg
6842 (Arg_Internal
: Node_Id
:= Empty
)
6845 if No
(Arg_Internal
) then
6846 Error_Pragma
("Internal parameter required for pragma%");
6849 if Nkind
(Arg_Internal
) = N_Identifier
then
6852 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
6853 and then (Prag_Id
= Pragma_Import_Function
6855 Prag_Id
= Pragma_Export_Function
)
6861 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
6864 Check_Arg_Is_Local_Name
(Arg_Internal
);
6865 end Process_Extended_Import_Export_Internal_Arg
;
6867 --------------------------------------------------
6868 -- Process_Extended_Import_Export_Object_Pragma --
6869 --------------------------------------------------
6871 procedure Process_Extended_Import_Export_Object_Pragma
6872 (Arg_Internal
: Node_Id
;
6873 Arg_External
: Node_Id
;
6879 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
6880 Def_Id
:= Entity
(Arg_Internal
);
6882 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
6884 ("pragma% must designate an object", Arg_Internal
);
6887 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
6889 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
6892 ("previous Common/Psect_Object applies, pragma % not permitted",
6896 if Rep_Item_Too_Late
(Def_Id
, N
) then
6900 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
6902 if Present
(Arg_Size
) then
6903 Check_Arg_Is_External_Name
(Arg_Size
);
6906 -- Export_Object case
6908 if Prag_Id
= Pragma_Export_Object
then
6909 if not Is_Library_Level_Entity
(Def_Id
) then
6911 ("argument for pragma% must be library level entity",
6915 if Ekind
(Current_Scope
) = E_Generic_Package
then
6916 Error_Pragma
("pragma& cannot appear in a generic unit");
6919 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
6921 ("exported object must have compile time known size",
6925 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
6926 Error_Msg_N
("??duplicate Export_Object pragma", N
);
6928 Set_Exported
(Def_Id
, Arg_Internal
);
6931 -- Import_Object case
6934 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
6936 ("cannot use pragma% for task/protected object",
6940 if Ekind
(Def_Id
) = E_Constant
then
6942 ("cannot import a constant", Arg_Internal
);
6945 if Warn_On_Export_Import
6946 and then Has_Discriminants
(Etype
(Def_Id
))
6949 ("imported value must be initialized??", Arg_Internal
);
6952 if Warn_On_Export_Import
6953 and then Is_Access_Type
(Etype
(Def_Id
))
6956 ("cannot import object of an access type??", Arg_Internal
);
6959 if Warn_On_Export_Import
6960 and then Is_Imported
(Def_Id
)
6962 Error_Msg_N
("??duplicate Import_Object pragma", N
);
6964 -- Check for explicit initialization present. Note that an
6965 -- initialization generated by the code generator, e.g. for an
6966 -- access type, does not count here.
6968 elsif Present
(Expression
(Parent
(Def_Id
)))
6971 (Original_Node
(Expression
(Parent
(Def_Id
))))
6973 Error_Msg_Sloc
:= Sloc
(Def_Id
);
6975 ("imported entities cannot be initialized (RM B.1(24))",
6976 "\no initialization allowed for & declared#", Arg1
);
6978 Set_Imported
(Def_Id
);
6979 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
6982 end Process_Extended_Import_Export_Object_Pragma
;
6984 ------------------------------------------------------
6985 -- Process_Extended_Import_Export_Subprogram_Pragma --
6986 ------------------------------------------------------
6988 procedure Process_Extended_Import_Export_Subprogram_Pragma
6989 (Arg_Internal
: Node_Id
;
6990 Arg_External
: Node_Id
;
6991 Arg_Parameter_Types
: Node_Id
;
6992 Arg_Result_Type
: Node_Id
:= Empty
;
6993 Arg_Mechanism
: Node_Id
;
6994 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7000 Ambiguous
: Boolean;
7003 function Same_Base_Type
7005 Formal
: Entity_Id
) return Boolean;
7006 -- Determines if Ptype references the type of Formal. Note that only
7007 -- the base types need to match according to the spec. Ptype here is
7008 -- the argument from the pragma, which is either a type name, or an
7009 -- access attribute.
7011 --------------------
7012 -- Same_Base_Type --
7013 --------------------
7015 function Same_Base_Type
7017 Formal
: Entity_Id
) return Boolean
7019 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7023 -- Case where pragma argument is typ'Access
7025 if Nkind
(Ptype
) = N_Attribute_Reference
7026 and then Attribute_Name
(Ptype
) = Name_Access
7028 Pref
:= Prefix
(Ptype
);
7031 if not Is_Entity_Name
(Pref
)
7032 or else Entity
(Pref
) = Any_Type
7037 -- We have a match if the corresponding argument is of an
7038 -- anonymous access type, and its designated type matches the
7039 -- type of the prefix of the access attribute
7041 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7042 and then Base_Type
(Entity
(Pref
)) =
7043 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7045 -- Case where pragma argument is a type name
7050 if not Is_Entity_Name
(Ptype
)
7051 or else Entity
(Ptype
) = Any_Type
7056 -- We have a match if the corresponding argument is of the type
7057 -- given in the pragma (comparing base types)
7059 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7063 -- Start of processing for
7064 -- Process_Extended_Import_Export_Subprogram_Pragma
7067 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7071 -- Loop through homonyms (overloadings) of the entity
7073 Hom_Id
:= Entity
(Arg_Internal
);
7074 while Present
(Hom_Id
) loop
7075 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7077 -- We need a subprogram in the current scope
7079 if not Is_Subprogram
(Def_Id
)
7080 or else Scope
(Def_Id
) /= Current_Scope
7087 -- Pragma cannot apply to subprogram body
7089 if Is_Subprogram
(Def_Id
)
7090 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7094 ("pragma% requires separate spec"
7095 & " and must come before body");
7098 -- Test result type if given, note that the result type
7099 -- parameter can only be present for the function cases.
7101 if Present
(Arg_Result_Type
)
7102 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7106 elsif Etype
(Def_Id
) /= Standard_Void_Type
7108 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7112 -- Test parameter types if given. Note that this parameter
7113 -- has not been analyzed (and must not be, since it is
7114 -- semantic nonsense), so we get it as the parser left it.
7116 elsif Present
(Arg_Parameter_Types
) then
7117 Check_Matching_Types
: declare
7122 Formal
:= First_Formal
(Def_Id
);
7124 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7125 if Present
(Formal
) then
7129 -- A list of one type, e.g. (List) is parsed as
7130 -- a parenthesized expression.
7132 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7133 and then Paren_Count
(Arg_Parameter_Types
) = 1
7136 or else Present
(Next_Formal
(Formal
))
7141 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7144 -- A list of more than one type is parsed as a aggregate
7146 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7147 and then Paren_Count
(Arg_Parameter_Types
) = 0
7149 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7150 while Present
(Ptype
) or else Present
(Formal
) loop
7153 or else not Same_Base_Type
(Ptype
, Formal
)
7158 Next_Formal
(Formal
);
7163 -- Anything else is of the wrong form
7167 ("wrong form for Parameter_Types parameter",
7168 Arg_Parameter_Types
);
7170 end Check_Matching_Types
;
7173 -- Match is now False if the entry we found did not match
7174 -- either a supplied Parameter_Types or Result_Types argument
7180 -- Ambiguous case, the flag Ambiguous shows if we already
7181 -- detected this and output the initial messages.
7184 if not Ambiguous
then
7186 Error_Msg_Name_1
:= Pname
;
7188 ("pragma% does not uniquely identify subprogram!",
7190 Error_Msg_Sloc
:= Sloc
(Ent
);
7191 Error_Msg_N
("matching subprogram #!", N
);
7195 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7196 Error_Msg_N
("matching subprogram #!", N
);
7201 Hom_Id
:= Homonym
(Hom_Id
);
7204 -- See if we found an entry
7207 if not Ambiguous
then
7208 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7210 ("pragma% cannot be given for generic subprogram");
7213 ("pragma% does not identify local subprogram");
7220 -- Import pragmas must be for imported entities
7222 if Prag_Id
= Pragma_Import_Function
7224 Prag_Id
= Pragma_Import_Procedure
7226 Prag_Id
= Pragma_Import_Valued_Procedure
7228 if not Is_Imported
(Ent
) then
7230 ("pragma Import or Interface must precede pragma%");
7233 -- Here we have the Export case which can set the entity as exported
7235 -- But does not do so if the specified external name is null, since
7236 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7237 -- compatible) to request no external name.
7239 elsif Nkind
(Arg_External
) = N_String_Literal
7240 and then String_Length
(Strval
(Arg_External
)) = 0
7244 -- In all other cases, set entity as exported
7247 Set_Exported
(Ent
, Arg_Internal
);
7250 -- Special processing for Valued_Procedure cases
7252 if Prag_Id
= Pragma_Import_Valued_Procedure
7254 Prag_Id
= Pragma_Export_Valued_Procedure
7256 Formal
:= First_Formal
(Ent
);
7259 Error_Pragma
("at least one parameter required for pragma%");
7261 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7262 Error_Pragma
("first parameter must have mode out for pragma%");
7265 Set_Is_Valued_Procedure
(Ent
);
7269 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7271 -- Process Result_Mechanism argument if present. We have already
7272 -- checked that this is only allowed for the function case.
7274 if Present
(Arg_Result_Mechanism
) then
7275 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7278 -- Process Mechanism parameter if present. Note that this parameter
7279 -- is not analyzed, and must not be analyzed since it is semantic
7280 -- nonsense, so we get it in exactly as the parser left it.
7282 if Present
(Arg_Mechanism
) then
7290 -- A single mechanism association without a formal parameter
7291 -- name is parsed as a parenthesized expression. All other
7292 -- cases are parsed as aggregates, so we rewrite the single
7293 -- parameter case as an aggregate for consistency.
7295 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7296 and then Paren_Count
(Arg_Mechanism
) = 1
7298 Rewrite
(Arg_Mechanism
,
7299 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7300 Expressions
=> New_List
(
7301 Relocate_Node
(Arg_Mechanism
))));
7304 -- Case of only mechanism name given, applies to all formals
7306 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7307 Formal
:= First_Formal
(Ent
);
7308 while Present
(Formal
) loop
7309 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7310 Next_Formal
(Formal
);
7313 -- Case of list of mechanism associations given
7316 if Null_Record_Present
(Arg_Mechanism
) then
7318 ("inappropriate form for Mechanism parameter",
7322 -- Deal with positional ones first
7324 Formal
:= First_Formal
(Ent
);
7326 if Present
(Expressions
(Arg_Mechanism
)) then
7327 Mname
:= First
(Expressions
(Arg_Mechanism
));
7328 while Present
(Mname
) loop
7331 ("too many mechanism associations", Mname
);
7334 Set_Mechanism_Value
(Formal
, Mname
);
7335 Next_Formal
(Formal
);
7340 -- Deal with named entries
7342 if Present
(Component_Associations
(Arg_Mechanism
)) then
7343 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7344 while Present
(Massoc
) loop
7345 Choice
:= First
(Choices
(Massoc
));
7347 if Nkind
(Choice
) /= N_Identifier
7348 or else Present
(Next
(Choice
))
7351 ("incorrect form for mechanism association",
7355 Formal
:= First_Formal
(Ent
);
7359 ("parameter name & not present", Choice
);
7362 if Chars
(Choice
) = Chars
(Formal
) then
7364 (Formal
, Expression
(Massoc
));
7366 -- Set entity on identifier (needed by ASIS)
7368 Set_Entity
(Choice
, Formal
);
7373 Next_Formal
(Formal
);
7382 end Process_Extended_Import_Export_Subprogram_Pragma
;
7384 --------------------------
7385 -- Process_Generic_List --
7386 --------------------------
7388 procedure Process_Generic_List
is
7393 Check_No_Identifiers
;
7394 Check_At_Least_N_Arguments
(1);
7396 -- Check all arguments are names of generic units or instances
7399 while Present
(Arg
) loop
7400 Exp
:= Get_Pragma_Arg
(Arg
);
7403 if not Is_Entity_Name
(Exp
)
7405 (not Is_Generic_Instance
(Entity
(Exp
))
7407 not Is_Generic_Unit
(Entity
(Exp
)))
7410 ("pragma% argument must be name of generic unit/instance",
7416 end Process_Generic_List
;
7418 ------------------------------------
7419 -- Process_Import_Predefined_Type --
7420 ------------------------------------
7422 procedure Process_Import_Predefined_Type
is
7423 Loc
: constant Source_Ptr
:= Sloc
(N
);
7425 Ftyp
: Node_Id
:= Empty
;
7431 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7434 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7435 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7439 Ftyp
:= Node
(Elmt
);
7441 if Present
(Ftyp
) then
7443 -- Don't build a derived type declaration, because predefined C
7444 -- types have no declaration anywhere, so cannot really be named.
7445 -- Instead build a full type declaration, starting with an
7446 -- appropriate type definition is built
7448 if Is_Floating_Point_Type
(Ftyp
) then
7449 Def
:= Make_Floating_Point_Definition
(Loc
,
7450 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7451 Make_Real_Range_Specification
(Loc
,
7452 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7453 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7455 -- Should never have a predefined type we cannot handle
7458 raise Program_Error
;
7461 -- Build and insert a Full_Type_Declaration, which will be
7462 -- analyzed as soon as this list entry has been analyzed.
7464 Decl
:= Make_Full_Type_Declaration
(Loc
,
7465 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7466 Type_Definition
=> Def
);
7468 Insert_After
(N
, Decl
);
7469 Mark_Rewrite_Insertion
(Decl
);
7472 Error_Pragma_Arg
("no matching type found for pragma%",
7475 end Process_Import_Predefined_Type
;
7477 ---------------------------------
7478 -- Process_Import_Or_Interface --
7479 ---------------------------------
7481 procedure Process_Import_Or_Interface
is
7487 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7488 -- pragma Import (Entity, "external name");
7490 if Relaxed_RM_Semantics
7491 and then Arg_Count
= 2
7492 and then Prag_Id
= Pragma_Import
7493 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7496 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7499 if not Is_Entity_Name
(Def_Id
) then
7500 Error_Pragma_Arg
("entity name required", Arg1
);
7503 Def_Id
:= Entity
(Def_Id
);
7504 Kill_Size_Check_Code
(Def_Id
);
7505 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7508 Process_Convention
(C
, Def_Id
);
7509 Kill_Size_Check_Code
(Def_Id
);
7510 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7513 -- Various error checks
7515 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7517 -- We do not permit Import to apply to a renaming declaration
7519 if Present
(Renamed_Object
(Def_Id
)) then
7521 ("pragma% not allowed for object renaming", Arg2
);
7523 -- User initialization is not allowed for imported object, but
7524 -- the object declaration may contain a default initialization,
7525 -- that will be discarded. Note that an explicit initialization
7526 -- only counts if it comes from source, otherwise it is simply
7527 -- the code generator making an implicit initialization explicit.
7529 elsif Present
(Expression
(Parent
(Def_Id
)))
7530 and then Comes_From_Source
7531 (Original_Node
(Expression
(Parent
(Def_Id
))))
7533 -- Set imported flag to prevent cascaded errors
7535 Set_Is_Imported
(Def_Id
);
7537 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7539 ("no initialization allowed for declaration of& #",
7540 "\imported entities cannot be initialized (RM B.1(24))",
7544 -- If the pragma comes from an aspect specification the
7545 -- Is_Imported flag has already been set.
7547 if not From_Aspect_Specification
(N
) then
7548 Set_Imported
(Def_Id
);
7551 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7553 -- Note that we do not set Is_Public here. That's because we
7554 -- only want to set it if there is no address clause, and we
7555 -- don't know that yet, so we delay that processing till
7558 -- pragma Import completes deferred constants
7560 if Ekind
(Def_Id
) = E_Constant
then
7561 Set_Has_Completion
(Def_Id
);
7564 -- It is not possible to import a constant of an unconstrained
7565 -- array type (e.g. string) because there is no simple way to
7566 -- write a meaningful subtype for it.
7568 if Is_Array_Type
(Etype
(Def_Id
))
7569 and then not Is_Constrained
(Etype
(Def_Id
))
7572 ("imported constant& must have a constrained subtype",
7577 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7579 -- If the name is overloaded, pragma applies to all of the denoted
7580 -- entities in the same declarative part, unless the pragma comes
7581 -- from an aspect specification or was generated by the compiler
7582 -- (such as for pragma Provide_Shift_Operators).
7585 while Present
(Hom_Id
) loop
7587 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7589 -- Ignore inherited subprograms because the pragma will apply
7590 -- to the parent operation, which is the one called.
7592 if Is_Overloadable
(Def_Id
)
7593 and then Present
(Alias
(Def_Id
))
7597 -- If it is not a subprogram, it must be in an outer scope and
7598 -- pragma does not apply.
7600 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7603 -- The pragma does not apply to primitives of interfaces
7605 elsif Is_Dispatching_Operation
(Def_Id
)
7606 and then Present
(Find_Dispatching_Type
(Def_Id
))
7607 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
7611 -- Verify that the homonym is in the same declarative part (not
7612 -- just the same scope). If the pragma comes from an aspect
7613 -- specification we know that it is part of the declaration.
7615 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
7616 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
7617 and then not From_Aspect_Specification
(N
)
7622 -- If the pragma comes from an aspect specification the
7623 -- Is_Imported flag has already been set.
7625 if not From_Aspect_Specification
(N
) then
7626 Set_Imported
(Def_Id
);
7629 -- Reject an Import applied to an abstract subprogram
7631 if Is_Subprogram
(Def_Id
)
7632 and then Is_Abstract_Subprogram
(Def_Id
)
7634 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7636 ("cannot import abstract subprogram& declared#",
7640 -- Special processing for Convention_Intrinsic
7642 if C
= Convention_Intrinsic
then
7644 -- Link_Name argument not allowed for intrinsic
7648 Set_Is_Intrinsic_Subprogram
(Def_Id
);
7650 -- If no external name is present, then check that this
7651 -- is a valid intrinsic subprogram. If an external name
7652 -- is present, then this is handled by the back end.
7655 Check_Intrinsic_Subprogram
7656 (Def_Id
, Get_Pragma_Arg
(Arg2
));
7660 -- Verify that the subprogram does not have a completion
7661 -- through a renaming declaration. For other completions the
7662 -- pragma appears as a too late representation.
7665 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
7669 and then Nkind
(Decl
) = N_Subprogram_Declaration
7670 and then Present
(Corresponding_Body
(Decl
))
7671 and then Nkind
(Unit_Declaration_Node
7672 (Corresponding_Body
(Decl
))) =
7673 N_Subprogram_Renaming_Declaration
7675 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7677 ("cannot import&, renaming already provided for "
7678 & "declaration #", N
, Def_Id
);
7682 -- If the pragma comes from an aspect specification, there
7683 -- must be an Import aspect specified as well. In the rare
7684 -- case where Import is set to False, the suprogram needs to
7685 -- have a local completion.
7688 Imp_Aspect
: constant Node_Id
:=
7689 Find_Aspect
(Def_Id
, Aspect_Import
);
7693 if Present
(Imp_Aspect
)
7694 and then Present
(Expression
(Imp_Aspect
))
7696 Expr
:= Expression
(Imp_Aspect
);
7697 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
7699 if Is_Entity_Name
(Expr
)
7700 and then Entity
(Expr
) = Standard_True
7702 Set_Has_Completion
(Def_Id
);
7705 -- If there is no expression, the default is True, as for
7706 -- all boolean aspects. Same for the older pragma.
7709 Set_Has_Completion
(Def_Id
);
7713 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7716 if Is_Compilation_Unit
(Hom_Id
) then
7718 -- Its possible homonyms are not affected by the pragma.
7719 -- Such homonyms might be present in the context of other
7720 -- units being compiled.
7724 elsif From_Aspect_Specification
(N
) then
7727 -- If the pragma was created by the compiler, then we don't
7728 -- want it to apply to other homonyms. This kind of case can
7729 -- occur when using pragma Provide_Shift_Operators, which
7730 -- generates implicit shift and rotate operators with Import
7731 -- pragmas that might apply to earlier explicit or implicit
7732 -- declarations marked with Import (for example, coming from
7733 -- an earlier pragma Provide_Shift_Operators for another type),
7734 -- and we don't generally want other homonyms being treated
7735 -- as imported or the pragma flagged as an illegal duplicate.
7737 elsif not Comes_From_Source
(N
) then
7741 Hom_Id
:= Homonym
(Hom_Id
);
7745 -- When the convention is Java or CIL, we also allow Import to
7746 -- be given for packages, generic packages, exceptions, record
7747 -- components, and access to subprograms.
7749 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
7751 (Is_Package_Or_Generic_Package
(Def_Id
)
7752 or else Ekind
(Def_Id
) = E_Exception
7753 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
7754 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
7756 Set_Imported
(Def_Id
);
7757 Set_Is_Public
(Def_Id
);
7758 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7760 -- Import a CPP class
7762 elsif C
= Convention_CPP
7763 and then (Is_Record_Type
(Def_Id
)
7764 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
7766 if Ekind
(Def_Id
) = E_Incomplete_Type
then
7767 if Present
(Full_View
(Def_Id
)) then
7768 Def_Id
:= Full_View
(Def_Id
);
7772 ("cannot import 'C'P'P type before full declaration seen",
7773 Get_Pragma_Arg
(Arg2
));
7775 -- Although we have reported the error we decorate it as
7776 -- CPP_Class to avoid reporting spurious errors
7778 Set_Is_CPP_Class
(Def_Id
);
7783 -- Types treated as CPP classes must be declared limited (note:
7784 -- this used to be a warning but there is no real benefit to it
7785 -- since we did effectively intend to treat the type as limited
7788 if not Is_Limited_Type
(Def_Id
) then
7790 ("imported 'C'P'P type must be limited",
7791 Get_Pragma_Arg
(Arg2
));
7794 if Etype
(Def_Id
) /= Def_Id
7795 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
7797 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
7800 Set_Is_CPP_Class
(Def_Id
);
7802 -- Imported CPP types must not have discriminants (because C++
7803 -- classes do not have discriminants).
7805 if Has_Discriminants
(Def_Id
) then
7807 ("imported 'C'P'P type cannot have discriminants",
7808 First
(Discriminant_Specifications
7809 (Declaration_Node
(Def_Id
))));
7812 -- Check that components of imported CPP types do not have default
7813 -- expressions. For private types this check is performed when the
7814 -- full view is analyzed (see Process_Full_View).
7816 if not Is_Private_Type
(Def_Id
) then
7817 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
7820 -- Import a CPP exception
7822 elsif C
= Convention_CPP
7823 and then Ekind
(Def_Id
) = E_Exception
7827 ("'External_'Name arguments is required for 'Cpp exception",
7830 -- As only a string is allowed, Check_Arg_Is_External_Name
7833 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
7836 if Present
(Arg4
) then
7838 ("Link_Name argument not allowed for imported Cpp exception",
7842 -- Do not call Set_Interface_Name as the name of the exception
7843 -- shouldn't be modified (and in particular it shouldn't be
7844 -- the External_Name). For exceptions, the External_Name is the
7845 -- name of the RTTI structure.
7847 -- ??? Emit an error if pragma Import/Export_Exception is present
7849 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
7851 Check_Arg_Count
(3);
7852 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
7854 Process_Import_Predefined_Type
;
7858 ("second argument of pragma% must be object, subprogram "
7859 & "or incomplete type",
7863 -- If this pragma applies to a compilation unit, then the unit, which
7864 -- is a subprogram, does not require (or allow) a body. We also do
7865 -- not need to elaborate imported procedures.
7867 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
7869 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
7871 Set_Body_Required
(Cunit
, False);
7874 end Process_Import_Or_Interface
;
7876 --------------------
7877 -- Process_Inline --
7878 --------------------
7880 procedure Process_Inline
(Status
: Inline_Status
) is
7887 procedure Make_Inline
(Subp
: Entity_Id
);
7888 -- Subp is the defining unit name of the subprogram declaration. Set
7889 -- the flag, as well as the flag in the corresponding body, if there
7892 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
7893 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
7894 -- Has_Pragma_Inline_Always for the Inline_Always case.
7896 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
7897 -- Returns True if it can be determined at this stage that inlining
7898 -- is not possible, for example if the body is available and contains
7899 -- exception handlers, we prevent inlining, since otherwise we can
7900 -- get undefined symbols at link time. This function also emits a
7901 -- warning if front-end inlining is enabled and the pragma appears
7904 -- ??? is business with link symbols still valid, or does it relate
7905 -- to front end ZCX which is being phased out ???
7907 ---------------------------
7908 -- Inlining_Not_Possible --
7909 ---------------------------
7911 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
7912 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
7916 if Nkind
(Decl
) = N_Subprogram_Body
then
7917 Stats
:= Handled_Statement_Sequence
(Decl
);
7918 return Present
(Exception_Handlers
(Stats
))
7919 or else Present
(At_End_Proc
(Stats
));
7921 elsif Nkind
(Decl
) = N_Subprogram_Declaration
7922 and then Present
(Corresponding_Body
(Decl
))
7924 if Front_End_Inlining
7925 and then Analyzed
(Corresponding_Body
(Decl
))
7927 Error_Msg_N
("pragma appears too late, ignored??", N
);
7930 -- If the subprogram is a renaming as body, the body is just a
7931 -- call to the renamed subprogram, and inlining is trivially
7935 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
7936 N_Subprogram_Renaming_Declaration
7942 Handled_Statement_Sequence
7943 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
7946 Present
(Exception_Handlers
(Stats
))
7947 or else Present
(At_End_Proc
(Stats
));
7951 -- If body is not available, assume the best, the check is
7952 -- performed again when compiling enclosing package bodies.
7956 end Inlining_Not_Possible
;
7962 procedure Make_Inline
(Subp
: Entity_Id
) is
7963 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
7964 Inner_Subp
: Entity_Id
:= Subp
;
7967 -- Ignore if bad type, avoid cascaded error
7969 if Etype
(Subp
) = Any_Type
then
7973 -- If inlining is not possible, for now do not treat as an error
7975 elsif Status
/= Suppressed
7976 and then Inlining_Not_Possible
(Subp
)
7981 -- Here we have a candidate for inlining, but we must exclude
7982 -- derived operations. Otherwise we would end up trying to inline
7983 -- a phantom declaration, and the result would be to drag in a
7984 -- body which has no direct inlining associated with it. That
7985 -- would not only be inefficient but would also result in the
7986 -- backend doing cross-unit inlining in cases where it was
7987 -- definitely inappropriate to do so.
7989 -- However, a simple Comes_From_Source test is insufficient, since
7990 -- we do want to allow inlining of generic instances which also do
7991 -- not come from source. We also need to recognize specs generated
7992 -- by the front-end for bodies that carry the pragma. Finally,
7993 -- predefined operators do not come from source but are not
7994 -- inlineable either.
7996 elsif Is_Generic_Instance
(Subp
)
7997 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8001 elsif not Comes_From_Source
(Subp
)
8002 and then Scope
(Subp
) /= Standard_Standard
8008 -- The referenced entity must either be the enclosing entity, or
8009 -- an entity declared within the current open scope.
8011 if Present
(Scope
(Subp
))
8012 and then Scope
(Subp
) /= Current_Scope
8013 and then Subp
/= Current_Scope
8016 ("argument of% must be entity in current scope", Assoc
);
8020 -- Processing for procedure, operator or function. If subprogram
8021 -- is aliased (as for an instance) indicate that the renamed
8022 -- entity (if declared in the same unit) is inlined.
8024 if Is_Subprogram
(Subp
) then
8025 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8027 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8028 Set_Inline_Flags
(Inner_Subp
);
8030 Decl
:= Parent
(Parent
(Inner_Subp
));
8032 if Nkind
(Decl
) = N_Subprogram_Declaration
8033 and then Present
(Corresponding_Body
(Decl
))
8035 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8037 elsif Is_Generic_Instance
(Subp
) then
8039 -- Indicate that the body needs to be created for
8040 -- inlining subsequent calls. The instantiation node
8041 -- follows the declaration of the wrapper package
8044 if Scope
(Subp
) /= Standard_Standard
8046 Need_Subprogram_Instance_Body
8047 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
8053 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8054 -- appear in a formal part to apply to a formal subprogram.
8055 -- Do not apply check within an instance or a formal package
8056 -- the test will have been applied to the original generic.
8058 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8059 and then List_Containing
(Decl
) = List_Containing
(N
)
8060 and then not In_Instance
8063 ("Inline cannot apply to a formal subprogram", N
);
8065 -- If Subp is a renaming, it is the renamed entity that
8066 -- will appear in any call, and be inlined. However, for
8067 -- ASIS uses it is convenient to indicate that the renaming
8068 -- itself is an inlined subprogram, so that some gnatcheck
8069 -- rules can be applied in the absence of expansion.
8071 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8072 Set_Inline_Flags
(Subp
);
8078 -- For a generic subprogram set flag as well, for use at the point
8079 -- of instantiation, to determine whether the body should be
8082 elsif Is_Generic_Subprogram
(Subp
) then
8083 Set_Inline_Flags
(Subp
);
8086 -- Literals are by definition inlined
8088 elsif Kind
= E_Enumeration_Literal
then
8091 -- Anything else is an error
8095 ("expect subprogram name for pragma%", Assoc
);
8099 ----------------------
8100 -- Set_Inline_Flags --
8101 ----------------------
8103 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8105 -- First set the Has_Pragma_XXX flags and issue the appropriate
8106 -- errors and warnings for suspicious combinations.
8108 if Prag_Id
= Pragma_No_Inline
then
8109 if Has_Pragma_Inline_Always
(Subp
) then
8111 ("Inline_Always and No_Inline are mutually exclusive", N
);
8112 elsif Has_Pragma_Inline
(Subp
) then
8114 ("Inline and No_Inline both specified for& ??",
8115 N
, Entity
(Subp_Id
));
8118 Set_Has_Pragma_No_Inline
(Subp
);
8120 if Prag_Id
= Pragma_Inline_Always
then
8121 if Has_Pragma_No_Inline
(Subp
) then
8123 ("Inline_Always and No_Inline are mutually exclusive",
8127 Set_Has_Pragma_Inline_Always
(Subp
);
8129 if Has_Pragma_No_Inline
(Subp
) then
8131 ("Inline and No_Inline both specified for& ??",
8132 N
, Entity
(Subp_Id
));
8136 if not Has_Pragma_Inline
(Subp
) then
8137 Set_Has_Pragma_Inline
(Subp
);
8141 -- Then adjust the Is_Inlined flag. It can never be set if the
8142 -- subprogram is subject to pragma No_Inline.
8146 Set_Is_Inlined
(Subp
, False);
8150 if not Has_Pragma_No_Inline
(Subp
) then
8151 Set_Is_Inlined
(Subp
, True);
8154 end Set_Inline_Flags
;
8156 -- Start of processing for Process_Inline
8159 Check_No_Identifiers
;
8160 Check_At_Least_N_Arguments
(1);
8162 if Status
= Enabled
then
8163 Inline_Processing_Required
:= True;
8167 while Present
(Assoc
) loop
8168 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8172 if Is_Entity_Name
(Subp_Id
) then
8173 Subp
:= Entity
(Subp_Id
);
8175 if Subp
= Any_Id
then
8177 -- If previous error, avoid cascaded errors
8179 Check_Error_Detected
;
8185 -- For the pragma case, climb homonym chain. This is
8186 -- what implements allowing the pragma in the renaming
8187 -- case, with the result applying to the ancestors, and
8188 -- also allows Inline to apply to all previous homonyms.
8190 if not From_Aspect_Specification
(N
) then
8191 while Present
(Homonym
(Subp
))
8192 and then Scope
(Homonym
(Subp
)) = Current_Scope
8194 Make_Inline
(Homonym
(Subp
));
8195 Subp
:= Homonym
(Subp
);
8202 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
8209 ----------------------------
8210 -- Process_Interface_Name --
8211 ----------------------------
8213 procedure Process_Interface_Name
8214 (Subprogram_Def
: Entity_Id
;
8220 String_Val
: String_Id
;
8222 procedure Check_Form_Of_Interface_Name
8224 Ext_Name_Case
: Boolean);
8225 -- SN is a string literal node for an interface name. This routine
8226 -- performs some minimal checks that the name is reasonable. In
8227 -- particular that no spaces or other obviously incorrect characters
8228 -- appear. This is only a warning, since any characters are allowed.
8229 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8231 ----------------------------------
8232 -- Check_Form_Of_Interface_Name --
8233 ----------------------------------
8235 procedure Check_Form_Of_Interface_Name
8237 Ext_Name_Case
: Boolean)
8239 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8240 SL
: constant Nat
:= String_Length
(S
);
8245 Error_Msg_N
("interface name cannot be null string", SN
);
8248 for J
in 1 .. SL
loop
8249 C
:= Get_String_Char
(S
, J
);
8251 -- Look for dubious character and issue unconditional warning.
8252 -- Definitely dubious if not in character range.
8254 if not In_Character_Range
(C
)
8256 -- For all cases except CLI target,
8257 -- commas, spaces and slashes are dubious (in CLI, we use
8258 -- commas and backslashes in external names to specify
8259 -- assembly version and public key, while slashes and spaces
8260 -- can be used in names to mark nested classes and
8263 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8264 and then (Get_Character
(C
) = ','
8266 Get_Character
(C
) = '\'))
8267 or else (VM_Target
/= CLI_Target
8268 and then (Get_Character
(C
) = ' '
8270 Get_Character
(C
) = '/'))
8273 ("??interface name contains illegal character",
8274 Sloc
(SN
) + Source_Ptr
(J
));
8277 end Check_Form_Of_Interface_Name
;
8279 -- Start of processing for Process_Interface_Name
8282 if No
(Link_Arg
) then
8283 if No
(Ext_Arg
) then
8284 if VM_Target
= CLI_Target
8285 and then Ekind
(Subprogram_Def
) = E_Package
8286 and then Nkind
(Parent
(Subprogram_Def
)) =
8287 N_Package_Specification
8288 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8293 (Generic_Parent
(Parent
(Subprogram_Def
))));
8298 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8300 Link_Nam
:= Expression
(Ext_Arg
);
8303 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8304 Ext_Nam
:= Expression
(Ext_Arg
);
8309 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8310 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8311 Ext_Nam
:= Expression
(Ext_Arg
);
8312 Link_Nam
:= Expression
(Link_Arg
);
8315 -- Check expressions for external name and link name are static
8317 if Present
(Ext_Nam
) then
8318 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8319 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8321 -- Verify that external name is not the name of a local entity,
8322 -- which would hide the imported one and could lead to run-time
8323 -- surprises. The problem can only arise for entities declared in
8324 -- a package body (otherwise the external name is fully qualified
8325 -- and will not conflict).
8333 if Prag_Id
= Pragma_Import
then
8334 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8336 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
8338 if Nam
/= Chars
(Subprogram_Def
)
8339 and then Present
(E
)
8340 and then not Is_Overloadable
(E
)
8341 and then Is_Immediately_Visible
(E
)
8342 and then not Is_Imported
(E
)
8343 and then Ekind
(Scope
(E
)) = E_Package
8346 while Present
(Par
) loop
8347 if Nkind
(Par
) = N_Package_Body
then
8348 Error_Msg_Sloc
:= Sloc
(E
);
8350 ("imported entity is hidden by & declared#",
8355 Par
:= Parent
(Par
);
8362 if Present
(Link_Nam
) then
8363 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8364 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8367 -- If there is no link name, just set the external name
8369 if No
(Link_Nam
) then
8370 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8372 -- For the Link_Name case, the given literal is preceded by an
8373 -- asterisk, which indicates to GCC that the given name should be
8374 -- taken literally, and in particular that no prepending of
8375 -- underlines should occur, even in systems where this is the
8381 if VM_Target
= No_VM
then
8382 Store_String_Char
(Get_Char_Code
('*'));
8385 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8386 Store_String_Chars
(String_Val
);
8388 Make_String_Literal
(Sloc
(Link_Nam
),
8389 Strval
=> End_String
);
8392 -- Set the interface name. If the entity is a generic instance, use
8393 -- its alias, which is the callable entity.
8395 if Is_Generic_Instance
(Subprogram_Def
) then
8396 Set_Encoded_Interface_Name
8397 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8399 Set_Encoded_Interface_Name
8400 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8403 -- We allow duplicated export names in CIL/Java, as they are always
8404 -- enclosed in a namespace that differentiates them, and overloaded
8405 -- entities are supported by the VM.
8407 if Convention
(Subprogram_Def
) /= Convention_CIL
8409 Convention
(Subprogram_Def
) /= Convention_Java
8411 Check_Duplicated_Export_Name
(Link_Nam
);
8413 end Process_Interface_Name
;
8415 -----------------------------------------
8416 -- Process_Interrupt_Or_Attach_Handler --
8417 -----------------------------------------
8419 procedure Process_Interrupt_Or_Attach_Handler
is
8420 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8421 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8422 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8425 Set_Is_Interrupt_Handler
(Handler_Proc
);
8427 -- If the pragma is not associated with a handler procedure within a
8428 -- protected type, then it must be for a nonprotected procedure for
8429 -- the AAMP target, in which case we don't associate a representation
8430 -- item with the procedure's scope.
8432 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8433 if Prag_Id
= Pragma_Interrupt_Handler
8435 Prag_Id
= Pragma_Attach_Handler
8437 Record_Rep_Item
(Proc_Scope
, N
);
8440 end Process_Interrupt_Or_Attach_Handler
;
8442 --------------------------------------------------
8443 -- Process_Restrictions_Or_Restriction_Warnings --
8444 --------------------------------------------------
8446 -- Note: some of the simple identifier cases were handled in par-prag,
8447 -- but it is harmless (and more straightforward) to simply handle all
8448 -- cases here, even if it means we repeat a bit of work in some cases.
8450 procedure Process_Restrictions_Or_Restriction_Warnings
8454 R_Id
: Restriction_Id
;
8460 -- Ignore all Restrictions pragmas in CodePeer mode
8462 if CodePeer_Mode
then
8466 Check_Ada_83_Warning
;
8467 Check_At_Least_N_Arguments
(1);
8468 Check_Valid_Configuration_Pragma
;
8471 while Present
(Arg
) loop
8473 Expr
:= Get_Pragma_Arg
(Arg
);
8475 -- Case of no restriction identifier present
8477 if Id
= No_Name
then
8478 if Nkind
(Expr
) /= N_Identifier
then
8480 ("invalid form for restriction", Arg
);
8485 (Process_Restriction_Synonyms
(Expr
));
8487 if R_Id
not in All_Boolean_Restrictions
then
8488 Error_Msg_Name_1
:= Pname
;
8490 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8492 -- Check for possible misspelling
8494 for J
in Restriction_Id
loop
8496 Rnm
: constant String := Restriction_Id
'Image (J
);
8499 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8500 Name_Len
:= Rnm
'Length;
8501 Set_Casing
(All_Lower_Case
);
8503 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8505 (Identifier_Casing
(Current_Source_File
));
8506 Error_Msg_String
(1 .. Rnm
'Length) :=
8507 Name_Buffer
(1 .. Name_Len
);
8508 Error_Msg_Strlen
:= Rnm
'Length;
8509 Error_Msg_N
-- CODEFIX
8510 ("\possible misspelling of ""~""",
8511 Get_Pragma_Arg
(Arg
));
8520 if Implementation_Restriction
(R_Id
) then
8521 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8524 -- Special processing for No_Elaboration_Code restriction
8526 if R_Id
= No_Elaboration_Code
then
8528 -- Restriction is only recognized within a configuration
8529 -- pragma file, or within a unit of the main extended
8530 -- program. Note: the test for Main_Unit is needed to
8531 -- properly include the case of configuration pragma files.
8533 if not (Current_Sem_Unit
= Main_Unit
8534 or else In_Extended_Main_Source_Unit
(N
))
8538 -- Don't allow in a subunit unless already specified in
8541 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8542 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8543 and then not Restriction_Active
(No_Elaboration_Code
)
8546 ("invalid specification of ""No_Elaboration_Code""",
8549 ("\restriction cannot be specified in a subunit", N
);
8551 ("\unless also specified in body or spec", N
);
8554 -- If we accept a No_Elaboration_Code restriction, then it
8555 -- needs to be added to the configuration restriction set so
8556 -- that we get proper application to other units in the main
8557 -- extended source as required.
8560 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8564 -- If this is a warning, then set the warning unless we already
8565 -- have a real restriction active (we never want a warning to
8566 -- override a real restriction).
8569 if not Restriction_Active
(R_Id
) then
8570 Set_Restriction
(R_Id
, N
);
8571 Restriction_Warnings
(R_Id
) := True;
8574 -- If real restriction case, then set it and make sure that the
8575 -- restriction warning flag is off, since a real restriction
8576 -- always overrides a warning.
8579 Set_Restriction
(R_Id
, N
);
8580 Restriction_Warnings
(R_Id
) := False;
8583 -- Check for obsolescent restrictions in Ada 2005 mode
8586 and then Ada_Version
>= Ada_2005
8587 and then (R_Id
= No_Asynchronous_Control
8589 R_Id
= No_Unchecked_Deallocation
8591 R_Id
= No_Unchecked_Conversion
)
8593 Check_Restriction
(No_Obsolescent_Features
, N
);
8596 -- A very special case that must be processed here: pragma
8597 -- Restrictions (No_Exceptions) turns off all run-time
8598 -- checking. This is a bit dubious in terms of the formal
8599 -- language definition, but it is what is intended by RM
8600 -- H.4(12). Restriction_Warnings never affects generated code
8601 -- so this is done only in the real restriction case.
8603 -- Atomic_Synchronization is not a real check, so it is not
8604 -- affected by this processing).
8606 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8607 -- run-time checks in CodePeer and GNATprove modes: we want to
8608 -- generate checks for analysis purposes, as set respectively
8609 -- by -gnatC and -gnatd.F
8612 and then not (CodePeer_Mode
or GNATprove_Mode
)
8613 and then R_Id
= No_Exceptions
8615 for J
in Scope_Suppress
.Suppress
'Range loop
8616 if J
/= Atomic_Synchronization
then
8617 Scope_Suppress
.Suppress
(J
) := True;
8622 -- Case of No_Dependence => unit-name. Note that the parser
8623 -- already made the necessary entry in the No_Dependence table.
8625 elsif Id
= Name_No_Dependence
then
8626 if not OK_No_Dependence_Unit_Name
(Expr
) then
8630 -- Case of No_Specification_Of_Aspect => aspect-identifier
8632 elsif Id
= Name_No_Specification_Of_Aspect
then
8637 if Nkind
(Expr
) /= N_Identifier
then
8640 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
8643 if A_Id
= No_Aspect
then
8644 Error_Pragma_Arg
("invalid restriction name", Arg
);
8646 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
8650 -- Case of No_Use_Of_Attribute => attribute-identifier
8652 elsif Id
= Name_No_Use_Of_Attribute
then
8653 if Nkind
(Expr
) /= N_Identifier
8654 or else not Is_Attribute_Name
(Chars
(Expr
))
8656 Error_Msg_N
("unknown attribute name??", Expr
);
8659 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
8662 -- Case of No_Use_Of_Entity => fully-qualified-name
8664 elsif Id
= Name_No_Use_Of_Entity
then
8666 -- Restriction is only recognized within a configuration
8667 -- pragma file, or within a unit of the main extended
8668 -- program. Note: the test for Main_Unit is needed to
8669 -- properly include the case of configuration pragma files.
8671 if Current_Sem_Unit
= Main_Unit
8672 or else In_Extended_Main_Source_Unit
(N
)
8674 if not OK_No_Dependence_Unit_Name
(Expr
) then
8675 Error_Msg_N
("wrong form for entity name", Expr
);
8677 Set_Restriction_No_Use_Of_Entity
8678 (Expr
, Warn
, No_Profile
);
8682 -- Case of No_Use_Of_Pragma => pragma-identifier
8684 elsif Id
= Name_No_Use_Of_Pragma
then
8685 if Nkind
(Expr
) /= N_Identifier
8686 or else not Is_Pragma_Name
(Chars
(Expr
))
8688 Error_Msg_N
("unknown pragma name??", Expr
);
8690 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
8693 -- All other cases of restriction identifier present
8696 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
8697 Analyze_And_Resolve
(Expr
, Any_Integer
);
8699 if R_Id
not in All_Parameter_Restrictions
then
8701 ("invalid restriction parameter identifier", Arg
);
8703 elsif not Is_OK_Static_Expression
(Expr
) then
8704 Flag_Non_Static_Expr
8705 ("value must be static expression!", Expr
);
8708 elsif not Is_Integer_Type
(Etype
(Expr
))
8709 or else Expr_Value
(Expr
) < 0
8712 ("value must be non-negative integer", Arg
);
8715 -- Restriction pragma is active
8717 Val
:= Expr_Value
(Expr
);
8719 if not UI_Is_In_Int_Range
(Val
) then
8721 ("pragma ignored, value too large??", Arg
);
8724 -- Warning case. If the real restriction is active, then we
8725 -- ignore the request, since warning never overrides a real
8726 -- restriction. Otherwise we set the proper warning. Note that
8727 -- this circuit sets the warning again if it is already set,
8728 -- which is what we want, since the constant may have changed.
8731 if not Restriction_Active
(R_Id
) then
8733 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
8734 Restriction_Warnings
(R_Id
) := True;
8737 -- Real restriction case, set restriction and make sure warning
8738 -- flag is off since real restriction always overrides warning.
8741 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
8742 Restriction_Warnings
(R_Id
) := False;
8748 end Process_Restrictions_Or_Restriction_Warnings
;
8750 ---------------------------------
8751 -- Process_Suppress_Unsuppress --
8752 ---------------------------------
8754 -- Note: this procedure makes entries in the check suppress data
8755 -- structures managed by Sem. See spec of package Sem for full
8756 -- details on how we handle recording of check suppression.
8758 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
8763 In_Package_Spec
: constant Boolean :=
8764 Is_Package_Or_Generic_Package
(Current_Scope
)
8765 and then not In_Package_Body
(Current_Scope
);
8767 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
8768 -- Used to suppress a single check on the given entity
8770 --------------------------------
8771 -- Suppress_Unsuppress_Echeck --
8772 --------------------------------
8774 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
8776 -- Check for error of trying to set atomic synchronization for
8777 -- a non-atomic variable.
8779 if C
= Atomic_Synchronization
8780 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
8783 ("pragma & requires atomic type or variable",
8784 Pragma_Identifier
(Original_Node
(N
)));
8787 Set_Checks_May_Be_Suppressed
(E
);
8789 if In_Package_Spec
then
8790 Push_Global_Suppress_Stack_Entry
8793 Suppress
=> Suppress_Case
);
8795 Push_Local_Suppress_Stack_Entry
8798 Suppress
=> Suppress_Case
);
8801 -- If this is a first subtype, and the base type is distinct,
8802 -- then also set the suppress flags on the base type.
8804 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
8805 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
8807 end Suppress_Unsuppress_Echeck
;
8809 -- Start of processing for Process_Suppress_Unsuppress
8812 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
8813 -- on user code: we want to generate checks for analysis purposes, as
8814 -- set respectively by -gnatC and -gnatd.F
8816 if (CodePeer_Mode
or GNATprove_Mode
)
8817 and then Comes_From_Source
(N
)
8822 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
8823 -- declarative part or a package spec (RM 11.5(5)).
8825 if not Is_Configuration_Pragma
then
8826 Check_Is_In_Decl_Part_Or_Package_Spec
;
8829 Check_At_Least_N_Arguments
(1);
8830 Check_At_Most_N_Arguments
(2);
8831 Check_No_Identifier
(Arg1
);
8832 Check_Arg_Is_Identifier
(Arg1
);
8834 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
8836 if C
= No_Check_Id
then
8838 ("argument of pragma% is not valid check name", Arg1
);
8841 -- Warn that suppress of Elaboration_Check has no effect in SPARK
8843 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
8845 ("Suppress of Elaboration_Check ignored in SPARK??",
8846 "\elaboration checking rules are statically enforced "
8847 & "(SPARK RM 7.7)", Arg1
);
8850 -- One-argument case
8852 if Arg_Count
= 1 then
8854 -- Make an entry in the local scope suppress table. This is the
8855 -- table that directly shows the current value of the scope
8856 -- suppress check for any check id value.
8858 if C
= All_Checks
then
8860 -- For All_Checks, we set all specific predefined checks with
8861 -- the exception of Elaboration_Check, which is handled
8862 -- specially because of not wanting All_Checks to have the
8863 -- effect of deactivating static elaboration order processing.
8864 -- Atomic_Synchronization is also not affected, since this is
8865 -- not a real check.
8867 for J
in Scope_Suppress
.Suppress
'Range loop
8868 if J
/= Elaboration_Check
8870 J
/= Atomic_Synchronization
8872 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
8876 -- If not All_Checks, and predefined check, then set appropriate
8877 -- scope entry. Note that we will set Elaboration_Check if this
8878 -- is explicitly specified. Atomic_Synchronization is allowed
8879 -- only if internally generated and entity is atomic.
8881 elsif C
in Predefined_Check_Id
8882 and then (not Comes_From_Source
(N
)
8883 or else C
/= Atomic_Synchronization
)
8885 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
8888 -- Also make an entry in the Local_Entity_Suppress table
8890 Push_Local_Suppress_Stack_Entry
8893 Suppress
=> Suppress_Case
);
8895 -- Case of two arguments present, where the check is suppressed for
8896 -- a specified entity (given as the second argument of the pragma)
8899 -- This is obsolescent in Ada 2005 mode
8901 if Ada_Version
>= Ada_2005
then
8902 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
8905 Check_Optional_Identifier
(Arg2
, Name_On
);
8906 E_Id
:= Get_Pragma_Arg
(Arg2
);
8909 if not Is_Entity_Name
(E_Id
) then
8911 ("second argument of pragma% must be entity name", Arg2
);
8920 -- Enforce RM 11.5(7) which requires that for a pragma that
8921 -- appears within a package spec, the named entity must be
8922 -- within the package spec. We allow the package name itself
8923 -- to be mentioned since that makes sense, although it is not
8924 -- strictly allowed by 11.5(7).
8927 and then E
/= Current_Scope
8928 and then Scope
(E
) /= Current_Scope
8931 ("entity in pragma% is not in package spec (RM 11.5(7))",
8935 -- Loop through homonyms. As noted below, in the case of a package
8936 -- spec, only homonyms within the package spec are considered.
8939 Suppress_Unsuppress_Echeck
(E
, C
);
8941 if Is_Generic_Instance
(E
)
8942 and then Is_Subprogram
(E
)
8943 and then Present
(Alias
(E
))
8945 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
8948 -- Move to next homonym if not aspect spec case
8950 exit when From_Aspect_Specification
(N
);
8954 -- If we are within a package specification, the pragma only
8955 -- applies to homonyms in the same scope.
8957 exit when In_Package_Spec
8958 and then Scope
(E
) /= Current_Scope
;
8961 end Process_Suppress_Unsuppress
;
8963 -------------------------------
8964 -- Record_Independence_Check --
8965 -------------------------------
8967 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
8969 -- For GCC back ends the validation is done a priori
8971 if VM_Target
= No_VM
and then not AAMP_On_Target
then
8975 Independence_Checks
.Append
((N
, E
));
8976 end Record_Independence_Check
;
8982 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
8984 if Is_Imported
(E
) then
8986 ("cannot export entity& that was previously imported", Arg
);
8988 elsif Present
(Address_Clause
(E
))
8989 and then not Relaxed_RM_Semantics
8992 ("cannot export entity& that has an address clause", Arg
);
8995 Set_Is_Exported
(E
);
8997 -- Generate a reference for entity explicitly, because the
8998 -- identifier may be overloaded and name resolution will not
9001 Generate_Reference
(E
, Arg
);
9003 -- Deal with exporting non-library level entity
9005 if not Is_Library_Level_Entity
(E
) then
9007 -- Not allowed at all for subprograms
9009 if Is_Subprogram
(E
) then
9010 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9012 -- Otherwise set public and statically allocated
9016 Set_Is_Statically_Allocated
(E
);
9018 -- Warn if the corresponding W flag is set
9020 if Warn_On_Export_Import
9022 -- Only do this for something that was in the source. Not
9023 -- clear if this can be False now (there used for sure to be
9024 -- cases on some systems where it was False), but anyway the
9025 -- test is harmless if not needed, so it is retained.
9027 and then Comes_From_Source
(Arg
)
9030 ("?x?& has been made static as a result of Export",
9033 ("\?x?this usage is non-standard and non-portable",
9039 if Warn_On_Export_Import
and then Is_Type
(E
) then
9040 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9043 if Warn_On_Export_Import
and Inside_A_Generic
then
9045 ("all instances of& will have the same external name?x?",
9050 ----------------------------------------------
9051 -- Set_Extended_Import_Export_External_Name --
9052 ----------------------------------------------
9054 procedure Set_Extended_Import_Export_External_Name
9055 (Internal_Ent
: Entity_Id
;
9056 Arg_External
: Node_Id
)
9058 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9062 if No
(Arg_External
) then
9066 Check_Arg_Is_External_Name
(Arg_External
);
9068 if Nkind
(Arg_External
) = N_String_Literal
then
9069 if String_Length
(Strval
(Arg_External
)) = 0 then
9072 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9075 elsif Nkind
(Arg_External
) = N_Identifier
then
9076 New_Name
:= Get_Default_External_Name
(Arg_External
);
9078 -- Check_Arg_Is_External_Name should let through only identifiers and
9079 -- string literals or static string expressions (which are folded to
9080 -- string literals).
9083 raise Program_Error
;
9086 -- If we already have an external name set (by a prior normal Import
9087 -- or Export pragma), then the external names must match
9089 if Present
(Interface_Name
(Internal_Ent
)) then
9091 -- Ignore mismatching names in CodePeer mode, to support some
9092 -- old compilers which would export the same procedure under
9093 -- different names, e.g:
9095 -- pragma Export_Procedure (P, "a");
9096 -- pragma Export_Procedure (P, "b");
9098 if CodePeer_Mode
then
9102 Check_Matching_Internal_Names
: declare
9103 S1
: constant String_Id
:= Strval
(Old_Name
);
9104 S2
: constant String_Id
:= Strval
(New_Name
);
9107 pragma No_Return
(Mismatch
);
9108 -- Called if names do not match
9114 procedure Mismatch
is
9116 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9118 ("external name does not match that given #",
9122 -- Start of processing for Check_Matching_Internal_Names
9125 if String_Length
(S1
) /= String_Length
(S2
) then
9129 for J
in 1 .. String_Length
(S1
) loop
9130 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9135 end Check_Matching_Internal_Names
;
9137 -- Otherwise set the given name
9140 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9141 Check_Duplicated_Export_Name
(New_Name
);
9143 end Set_Extended_Import_Export_External_Name
;
9149 procedure Set_Imported
(E
: Entity_Id
) is
9151 -- Error message if already imported or exported
9153 if Is_Exported
(E
) or else Is_Imported
(E
) then
9155 -- Error if being set Exported twice
9157 if Is_Exported
(E
) then
9158 Error_Msg_NE
("entity& was previously exported", N
, E
);
9160 -- Ignore error in CodePeer mode where we treat all imported
9161 -- subprograms as unknown.
9163 elsif CodePeer_Mode
then
9166 -- OK if Import/Interface case
9168 elsif Import_Interface_Present
(N
) then
9171 -- Error if being set Imported twice
9174 Error_Msg_NE
("entity& was previously imported", N
, E
);
9177 Error_Msg_Name_1
:= Pname
;
9179 ("\(pragma% applies to all previous entities)", N
);
9181 Error_Msg_Sloc
:= Sloc
(E
);
9182 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9184 -- Here if not previously imported or exported, OK to import
9187 Set_Is_Imported
(E
);
9189 -- For subprogram, set Import_Pragma field
9191 if Is_Subprogram
(E
) then
9192 Set_Import_Pragma
(E
, N
);
9195 -- If the entity is an object that is not at the library level,
9196 -- then it is statically allocated. We do not worry about objects
9197 -- with address clauses in this context since they are not really
9198 -- imported in the linker sense.
9201 and then not Is_Library_Level_Entity
(E
)
9202 and then No
(Address_Clause
(E
))
9204 Set_Is_Statically_Allocated
(E
);
9211 -------------------------
9212 -- Set_Mechanism_Value --
9213 -------------------------
9215 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9216 -- analyzed, since it is semantic nonsense), so we get it in the exact
9217 -- form created by the parser.
9219 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9220 procedure Bad_Mechanism
;
9221 pragma No_Return
(Bad_Mechanism
);
9222 -- Signal bad mechanism name
9224 -------------------------
9225 -- Bad_Mechanism_Value --
9226 -------------------------
9228 procedure Bad_Mechanism
is
9230 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9233 -- Start of processing for Set_Mechanism_Value
9236 if Mechanism
(Ent
) /= Default_Mechanism
then
9238 ("mechanism for & has already been set", Mech_Name
, Ent
);
9241 -- MECHANISM_NAME ::= value | reference
9243 if Nkind
(Mech_Name
) = N_Identifier
then
9244 if Chars
(Mech_Name
) = Name_Value
then
9245 Set_Mechanism
(Ent
, By_Copy
);
9248 elsif Chars
(Mech_Name
) = Name_Reference
then
9249 Set_Mechanism
(Ent
, By_Reference
);
9252 elsif Chars
(Mech_Name
) = Name_Copy
then
9254 ("bad mechanism name, Value assumed", Mech_Name
);
9263 end Set_Mechanism_Value
;
9265 --------------------------
9266 -- Set_Rational_Profile --
9267 --------------------------
9269 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9270 -- and extension to the semantics of renaming declarations.
9272 procedure Set_Rational_Profile
is
9274 Implicit_Packing
:= True;
9275 Overriding_Renamings
:= True;
9276 Use_VADS_Size
:= True;
9277 end Set_Rational_Profile
;
9279 ---------------------------
9280 -- Set_Ravenscar_Profile --
9281 ---------------------------
9283 -- The tasks to be done here are
9285 -- Set required policies
9287 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9288 -- pragma Locking_Policy (Ceiling_Locking)
9290 -- Set Detect_Blocking mode
9292 -- Set required restrictions (see System.Rident for detailed list)
9294 -- Set the No_Dependence rules
9295 -- No_Dependence => Ada.Asynchronous_Task_Control
9296 -- No_Dependence => Ada.Calendar
9297 -- No_Dependence => Ada.Execution_Time.Group_Budget
9298 -- No_Dependence => Ada.Execution_Time.Timers
9299 -- No_Dependence => Ada.Task_Attributes
9300 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9302 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9303 Prefix_Entity
: Entity_Id
;
9304 Selector_Entity
: Entity_Id
;
9305 Prefix_Node
: Node_Id
;
9309 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9311 if Task_Dispatching_Policy
/= ' '
9312 and then Task_Dispatching_Policy
/= 'F'
9314 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9315 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9317 -- Set the FIFO_Within_Priorities policy, but always preserve
9318 -- System_Location since we like the error message with the run time
9322 Task_Dispatching_Policy
:= 'F';
9324 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9325 Task_Dispatching_Policy_Sloc
:= Loc
;
9329 -- pragma Locking_Policy (Ceiling_Locking)
9331 if Locking_Policy
/= ' '
9332 and then Locking_Policy
/= 'C'
9334 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9335 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9337 -- Set the Ceiling_Locking policy, but preserve System_Location since
9338 -- we like the error message with the run time name.
9341 Locking_Policy
:= 'C';
9343 if Locking_Policy_Sloc
/= System_Location
then
9344 Locking_Policy_Sloc
:= Loc
;
9348 -- pragma Detect_Blocking
9350 Detect_Blocking
:= True;
9352 -- Set the corresponding restrictions
9354 Set_Profile_Restrictions
9355 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9357 -- Set the No_Dependence restrictions
9359 -- The following No_Dependence restrictions:
9360 -- No_Dependence => Ada.Asynchronous_Task_Control
9361 -- No_Dependence => Ada.Calendar
9362 -- No_Dependence => Ada.Task_Attributes
9363 -- are already set by previous call to Set_Profile_Restrictions.
9365 -- Set the following restrictions which were added to Ada 2005:
9366 -- No_Dependence => Ada.Execution_Time.Group_Budget
9367 -- No_Dependence => Ada.Execution_Time.Timers
9369 if Ada_Version
>= Ada_2005
then
9370 Name_Buffer
(1 .. 3) := "ada";
9373 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9375 Name_Buffer
(1 .. 14) := "execution_time";
9378 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9381 Make_Selected_Component
9383 Prefix
=> Prefix_Entity
,
9384 Selector_Name
=> Selector_Entity
);
9386 Name_Buffer
(1 .. 13) := "group_budgets";
9389 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9392 Make_Selected_Component
9394 Prefix
=> Prefix_Node
,
9395 Selector_Name
=> Selector_Entity
);
9397 Set_Restriction_No_Dependence
9399 Warn
=> Treat_Restrictions_As_Warnings
,
9400 Profile
=> Ravenscar
);
9402 Name_Buffer
(1 .. 6) := "timers";
9405 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9408 Make_Selected_Component
9410 Prefix
=> Prefix_Node
,
9411 Selector_Name
=> Selector_Entity
);
9413 Set_Restriction_No_Dependence
9415 Warn
=> Treat_Restrictions_As_Warnings
,
9416 Profile
=> Ravenscar
);
9419 -- Set the following restrictions which was added to Ada 2012 (see
9421 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9423 if Ada_Version
>= Ada_2012
then
9424 Name_Buffer
(1 .. 6) := "system";
9427 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9429 Name_Buffer
(1 .. 15) := "multiprocessors";
9432 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9435 Make_Selected_Component
9437 Prefix
=> Prefix_Entity
,
9438 Selector_Name
=> Selector_Entity
);
9440 Name_Buffer
(1 .. 19) := "dispatching_domains";
9443 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9446 Make_Selected_Component
9448 Prefix
=> Prefix_Node
,
9449 Selector_Name
=> Selector_Entity
);
9451 Set_Restriction_No_Dependence
9453 Warn
=> Treat_Restrictions_As_Warnings
,
9454 Profile
=> Ravenscar
);
9456 end Set_Ravenscar_Profile
;
9458 -- Start of processing for Analyze_Pragma
9461 -- The following code is a defense against recursion. Not clear that
9462 -- this can happen legitimately, but perhaps some error situations
9463 -- can cause it, and we did see this recursion during testing.
9465 if Analyzed
(N
) then
9468 Set_Analyzed
(N
, True);
9471 -- Deal with unrecognized pragma
9473 Pname
:= Pragma_Name
(N
);
9475 if not Is_Pragma_Name
(Pname
) then
9476 if Warn_On_Unrecognized_Pragma
then
9477 Error_Msg_Name_1
:= Pname
;
9478 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9480 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9481 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9482 Error_Msg_Name_1
:= PN
;
9483 Error_Msg_N
-- CODEFIX
9484 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9493 -- Ignore pragma if Ignore_Pragma applies
9495 if Get_Name_Table_Boolean3
(Pname
) then
9499 -- Here to start processing for recognized pragma
9501 Prag_Id
:= Get_Pragma_Id
(Pname
);
9502 Pname
:= Original_Aspect_Pragma_Name
(N
);
9504 -- Capture setting of Opt.Uneval_Old
9506 case Opt
.Uneval_Old
is
9508 Set_Uneval_Old_Accept
(N
);
9512 Set_Uneval_Old_Warn
(N
);
9514 raise Program_Error
;
9517 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9518 -- is already set, indicating that we have already checked the policy
9519 -- at the right point. This happens for example in the case of a pragma
9520 -- that is derived from an Aspect.
9522 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9525 -- For a pragma that is a rewriting of another pragma, copy the
9526 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9528 elsif Is_Rewrite_Substitution
(N
)
9529 and then Nkind
(Original_Node
(N
)) = N_Pragma
9530 and then Original_Node
(N
) /= N
9532 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
9533 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
9535 -- Otherwise query the applicable policy at this point
9538 Check_Applicable_Policy
(N
);
9540 -- If pragma is disabled, rewrite as NULL and skip analysis
9542 if Is_Disabled
(N
) then
9543 Rewrite
(N
, Make_Null_Statement
(Loc
));
9557 if Present
(Pragma_Argument_Associations
(N
)) then
9558 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
9559 Arg1
:= First
(Pragma_Argument_Associations
(N
));
9561 if Present
(Arg1
) then
9562 Arg2
:= Next
(Arg1
);
9564 if Present
(Arg2
) then
9565 Arg3
:= Next
(Arg2
);
9567 if Present
(Arg3
) then
9568 Arg4
:= Next
(Arg3
);
9574 Check_Restriction_No_Use_Of_Pragma
(N
);
9576 -- An enumeration type defines the pragmas that are supported by the
9577 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9578 -- into the corresponding enumeration value for the following case.
9586 -- pragma Abort_Defer;
9588 when Pragma_Abort_Defer
=>
9590 Check_Arg_Count
(0);
9592 -- The only required semantic processing is to check the
9593 -- placement. This pragma must appear at the start of the
9594 -- statement sequence of a handled sequence of statements.
9596 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
9597 or else N
/= First
(Statements
(Parent
(N
)))
9602 --------------------
9603 -- Abstract_State --
9604 --------------------
9606 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9608 -- ABSTRACT_STATE_LIST ::=
9610 -- | STATE_NAME_WITH_OPTIONS
9611 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9613 -- STATE_NAME_WITH_OPTIONS ::=
9615 -- | (STATE_NAME with OPTION_LIST)
9617 -- OPTION_LIST ::= OPTION {, OPTION}
9621 -- | NAME_VALUE_OPTION
9623 -- SIMPLE_OPTION ::= Ghost
9625 -- NAME_VALUE_OPTION ::=
9626 -- Part_Of => ABSTRACT_STATE
9627 -- | External [=> EXTERNAL_PROPERTY_LIST]
9629 -- EXTERNAL_PROPERTY_LIST ::=
9630 -- EXTERNAL_PROPERTY
9631 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9633 -- EXTERNAL_PROPERTY ::=
9634 -- Async_Readers [=> boolean_EXPRESSION]
9635 -- | Async_Writers [=> boolean_EXPRESSION]
9636 -- | Effective_Reads [=> boolean_EXPRESSION]
9637 -- | Effective_Writes [=> boolean_EXPRESSION]
9638 -- others => boolean_EXPRESSION
9640 -- STATE_NAME ::= defining_identifier
9642 -- ABSTRACT_STATE ::= name
9646 -- * Analysis - The annotation is fully analyzed immediately upon
9647 -- elaboration as it cannot forward reference entities.
9649 -- * Expansion - None.
9651 -- * Template - The annotation utilizes the generic template of the
9652 -- related package declaration.
9654 -- * Globals - The annotation cannot reference global entities.
9656 -- * Instance - The annotation is instantiated automatically when
9657 -- the related generic package is instantiated.
9659 when Pragma_Abstract_State
=> Abstract_State
: declare
9660 Missing_Parentheses
: Boolean := False;
9661 -- Flag set when a state declaration with options is not properly
9664 -- Flags used to verify the consistency of states
9666 Non_Null_Seen
: Boolean := False;
9667 Null_Seen
: Boolean := False;
9669 procedure Analyze_Abstract_State
9671 Pack_Id
: Entity_Id
);
9672 -- Verify the legality of a single state declaration. Create and
9673 -- decorate a state abstraction entity and introduce it into the
9674 -- visibility chain. Pack_Id denotes the entity or the related
9675 -- package where pragma Abstract_State appears.
9677 procedure Malformed_State_Error
(State
: Node_Id
);
9678 -- Emit an error concerning the illegal declaration of abstract
9679 -- state State. This routine diagnoses syntax errors that lead to
9680 -- a different parse tree. The error is issued regardless of the
9681 -- SPARK mode in effect.
9683 ----------------------------
9684 -- Analyze_Abstract_State --
9685 ----------------------------
9687 procedure Analyze_Abstract_State
9689 Pack_Id
: Entity_Id
)
9691 -- Flags used to verify the consistency of options
9693 AR_Seen
: Boolean := False;
9694 AW_Seen
: Boolean := False;
9695 ER_Seen
: Boolean := False;
9696 EW_Seen
: Boolean := False;
9697 External_Seen
: Boolean := False;
9698 Others_Seen
: Boolean := False;
9699 Part_Of_Seen
: Boolean := False;
9701 -- Flags used to store the static value of all external states'
9704 AR_Val
: Boolean := False;
9705 AW_Val
: Boolean := False;
9706 ER_Val
: Boolean := False;
9707 EW_Val
: Boolean := False;
9709 State_Id
: Entity_Id
:= Empty
;
9710 -- The entity to be generated for the current state declaration
9712 procedure Analyze_External_Option
(Opt
: Node_Id
);
9713 -- Verify the legality of option External
9715 procedure Analyze_External_Property
9717 Expr
: Node_Id
:= Empty
);
9718 -- Verify the legailty of a single external property. Prop
9719 -- denotes the external property. Expr is the expression used
9720 -- to set the property.
9722 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
9723 -- Verify the legality of option Part_Of
9725 procedure Check_Duplicate_Option
9727 Status
: in out Boolean);
9728 -- Flag Status denotes whether a particular option has been
9729 -- seen while processing a state. This routine verifies that
9730 -- Opt is not a duplicate option and sets the flag Status
9731 -- (SPARK RM 7.1.4(1)).
9733 procedure Check_Duplicate_Property
9735 Status
: in out Boolean);
9736 -- Flag Status denotes whether a particular property has been
9737 -- seen while processing option External. This routine verifies
9738 -- that Prop is not a duplicate property and sets flag Status.
9739 -- Opt is not a duplicate property and sets the flag Status.
9740 -- (SPARK RM 7.1.4(2))
9742 procedure Create_Abstract_State
9747 -- Generate an abstract state entity with name Nam and enter it
9748 -- into visibility. Decl is the "declaration" of the state as
9749 -- it appears in pragma Abstract_State. Loc is the location of
9750 -- the related state "declaration". Flag Is_Null should be set
9751 -- when the associated Abstract_State pragma defines a null
9754 -----------------------------
9755 -- Analyze_External_Option --
9756 -----------------------------
9758 procedure Analyze_External_Option
(Opt
: Node_Id
) is
9759 Errors
: constant Nat
:= Serious_Errors_Detected
;
9761 Props
: Node_Id
:= Empty
;
9764 Check_Duplicate_Option
(Opt
, External_Seen
);
9766 if Nkind
(Opt
) = N_Component_Association
then
9767 Props
:= Expression
(Opt
);
9770 -- External state with properties
9772 if Present
(Props
) then
9774 -- Multiple properties appear as an aggregate
9776 if Nkind
(Props
) = N_Aggregate
then
9778 -- Simple property form
9780 Prop
:= First
(Expressions
(Props
));
9781 while Present
(Prop
) loop
9782 Analyze_External_Property
(Prop
);
9786 -- Property with expression form
9788 Prop
:= First
(Component_Associations
(Props
));
9789 while Present
(Prop
) loop
9790 Analyze_External_Property
9791 (Prop
=> First
(Choices
(Prop
)),
9792 Expr
=> Expression
(Prop
));
9800 Analyze_External_Property
(Props
);
9803 -- An external state defined without any properties defaults
9804 -- all properties to True.
9813 -- Once all external properties have been processed, verify
9814 -- their mutual interaction. Do not perform the check when
9815 -- at least one of the properties is illegal as this will
9816 -- produce a bogus error.
9818 if Errors
= Serious_Errors_Detected
then
9819 Check_External_Properties
9820 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
9822 end Analyze_External_Option
;
9824 -------------------------------
9825 -- Analyze_External_Property --
9826 -------------------------------
9828 procedure Analyze_External_Property
9830 Expr
: Node_Id
:= Empty
)
9835 -- Check the placement of "others" (if available)
9837 if Nkind
(Prop
) = N_Others_Choice
then
9840 ("only one others choice allowed in option External",
9843 Others_Seen
:= True;
9846 elsif Others_Seen
then
9848 ("others must be the last property in option External",
9851 -- The only remaining legal options are the four predefined
9852 -- external properties.
9854 elsif Nkind
(Prop
) = N_Identifier
9855 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
9857 Name_Effective_Reads
,
9858 Name_Effective_Writes
)
9862 -- Otherwise the construct is not a valid property
9865 SPARK_Msg_N
("invalid external state property", Prop
);
9869 -- Ensure that the expression of the external state property
9870 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
9872 if Present
(Expr
) then
9873 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9875 if Is_OK_Static_Expression
(Expr
) then
9876 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
9879 ("expression of external state property must be "
9883 -- The lack of expression defaults the property to True
9891 if Nkind
(Prop
) = N_Identifier
then
9892 if Chars
(Prop
) = Name_Async_Readers
then
9893 Check_Duplicate_Property
(Prop
, AR_Seen
);
9896 elsif Chars
(Prop
) = Name_Async_Writers
then
9897 Check_Duplicate_Property
(Prop
, AW_Seen
);
9900 elsif Chars
(Prop
) = Name_Effective_Reads
then
9901 Check_Duplicate_Property
(Prop
, ER_Seen
);
9905 Check_Duplicate_Property
(Prop
, EW_Seen
);
9909 -- The handling of property "others" must take into account
9910 -- all other named properties that have been encountered so
9911 -- far. Only those that have not been seen are affected by
9931 end Analyze_External_Property
;
9933 ----------------------------
9934 -- Analyze_Part_Of_Option --
9935 ----------------------------
9937 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
9938 Encaps
: constant Node_Id
:= Expression
(Opt
);
9939 Encaps_Id
: Entity_Id
;
9943 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
9946 (Item_Id
=> State_Id
,
9948 Indic
=> First
(Choices
(Opt
)),
9951 -- The Part_Of indicator turns an abstract state into a
9952 -- constituent of the encapsulating state.
9955 Encaps_Id
:= Entity
(Encaps
);
9957 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
9958 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
9960 end Analyze_Part_Of_Option
;
9962 ----------------------------
9963 -- Check_Duplicate_Option --
9964 ----------------------------
9966 procedure Check_Duplicate_Option
9968 Status
: in out Boolean)
9972 SPARK_Msg_N
("duplicate state option", Opt
);
9976 end Check_Duplicate_Option
;
9978 ------------------------------
9979 -- Check_Duplicate_Property --
9980 ------------------------------
9982 procedure Check_Duplicate_Property
9984 Status
: in out Boolean)
9988 SPARK_Msg_N
("duplicate external property", Prop
);
9992 end Check_Duplicate_Property
;
9994 ---------------------------
9995 -- Create_Abstract_State --
9996 ---------------------------
9998 procedure Create_Abstract_State
10005 -- The abstract state may be semi-declared when the related
10006 -- package was withed through a limited with clause. In that
10007 -- case reuse the entity to fully declare the state.
10009 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10010 State_Id
:= Entity
(Decl
);
10012 -- Otherwise the elaboration of pragma Abstract_State
10013 -- declares the state.
10016 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10018 if Present
(Decl
) then
10019 Set_Entity
(Decl
, State_Id
);
10023 -- Null states never come from source
10025 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10026 Set_Parent
(State_Id
, State
);
10027 Set_Ekind
(State_Id
, E_Abstract_State
);
10028 Set_Etype
(State_Id
, Standard_Void_Type
);
10029 Set_Encapsulating_State
(State_Id
, Empty
);
10030 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
10031 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
10033 -- An abstract state declared within a Ghost region becomes
10034 -- Ghost (SPARK RM 6.9(2)).
10036 if Ghost_Mode
> None
then
10037 Set_Is_Ghost_Entity
(State_Id
);
10040 -- Establish a link between the state declaration and the
10041 -- abstract state entity. Note that a null state remains as
10042 -- N_Null and does not carry any linkages.
10044 if not Is_Null
then
10045 if Present
(Decl
) then
10046 Set_Entity
(Decl
, State_Id
);
10047 Set_Etype
(Decl
, Standard_Void_Type
);
10050 -- Every non-null state must be defined, nameable and
10053 Push_Scope
(Pack_Id
);
10054 Generate_Definition
(State_Id
);
10055 Enter_Name
(State_Id
);
10058 end Create_Abstract_State
;
10065 -- Start of processing for Analyze_Abstract_State
10068 -- A package with a null abstract state is not allowed to
10069 -- declare additional states.
10073 ("package & has null abstract state", State
, Pack_Id
);
10075 -- Null states appear as internally generated entities
10077 elsif Nkind
(State
) = N_Null
then
10078 Create_Abstract_State
10079 (Nam
=> New_Internal_Name
('S'),
10081 Loc
=> Sloc
(State
),
10085 -- Catch a case where a null state appears in a list of
10086 -- non-null states.
10088 if Non_Null_Seen
then
10090 ("package & has non-null abstract state",
10094 -- Simple state declaration
10096 elsif Nkind
(State
) = N_Identifier
then
10097 Create_Abstract_State
10098 (Nam
=> Chars
(State
),
10100 Loc
=> Sloc
(State
),
10102 Non_Null_Seen
:= True;
10104 -- State declaration with various options. This construct
10105 -- appears as an extension aggregate in the tree.
10107 elsif Nkind
(State
) = N_Extension_Aggregate
then
10108 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10109 Create_Abstract_State
10110 (Nam
=> Chars
(Ancestor_Part
(State
)),
10111 Decl
=> Ancestor_Part
(State
),
10112 Loc
=> Sloc
(Ancestor_Part
(State
)),
10114 Non_Null_Seen
:= True;
10117 ("state name must be an identifier",
10118 Ancestor_Part
(State
));
10121 -- Options External and Ghost appear as expressions
10123 Opt
:= First
(Expressions
(State
));
10124 while Present
(Opt
) loop
10125 if Nkind
(Opt
) = N_Identifier
then
10126 if Chars
(Opt
) = Name_External
then
10127 Analyze_External_Option
(Opt
);
10129 elsif Chars
(Opt
) = Name_Ghost
then
10130 if Present
(State_Id
) then
10131 Set_Is_Ghost_Entity
(State_Id
);
10134 -- Option Part_Of without an encapsulating state is
10135 -- illegal. (SPARK RM 7.1.4(9)).
10137 elsif Chars
(Opt
) = Name_Part_Of
then
10139 ("indicator Part_Of must denote an abstract "
10142 -- Do not emit an error message when a previous state
10143 -- declaration with options was not parenthesized as
10144 -- the option is actually another state declaration.
10146 -- with Abstract_State
10147 -- (State_1 with ..., -- missing parentheses
10148 -- (State_2 with ...),
10149 -- State_3) -- ok state declaration
10151 elsif Missing_Parentheses
then
10154 -- Otherwise the option is not allowed. Note that it
10155 -- is not possible to distinguish between an option
10156 -- and a state declaration when a previous state with
10157 -- options not properly parentheses.
10159 -- with Abstract_State
10160 -- (State_1 with ..., -- missing parentheses
10161 -- State_2); -- could be an option
10165 ("simple option not allowed in state declaration",
10169 -- Catch a case where missing parentheses around a state
10170 -- declaration with options cause a subsequent state
10171 -- declaration with options to be treated as an option.
10173 -- with Abstract_State
10174 -- (State_1 with ..., -- missing parentheses
10175 -- (State_2 with ...))
10177 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10178 Missing_Parentheses
:= True;
10180 ("state declaration must be parenthesized",
10181 Ancestor_Part
(State
));
10183 -- Otherwise the option is malformed
10186 SPARK_Msg_N
("malformed option", Opt
);
10192 -- Options External and Part_Of appear as component
10195 Opt
:= First
(Component_Associations
(State
));
10196 while Present
(Opt
) loop
10197 Opt_Nam
:= First
(Choices
(Opt
));
10199 if Nkind
(Opt_Nam
) = N_Identifier
then
10200 if Chars
(Opt_Nam
) = Name_External
then
10201 Analyze_External_Option
(Opt
);
10203 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10204 Analyze_Part_Of_Option
(Opt
);
10207 SPARK_Msg_N
("invalid state option", Opt
);
10210 SPARK_Msg_N
("invalid state option", Opt
);
10216 -- Any other attempt to declare a state is illegal
10219 Malformed_State_Error
(State
);
10223 -- Guard against a junk state. In such cases no entity is
10224 -- generated and the subsequent checks cannot be applied.
10226 if Present
(State_Id
) then
10228 -- Verify whether the state does not introduce an illegal
10229 -- hidden state within a package subject to a null abstract
10232 Check_No_Hidden_State
(State_Id
);
10234 -- Check whether the lack of option Part_Of agrees with the
10235 -- placement of the abstract state with respect to the state
10238 if not Part_Of_Seen
then
10239 Check_Missing_Part_Of
(State_Id
);
10242 -- Associate the state with its related package
10244 if No
(Abstract_States
(Pack_Id
)) then
10245 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10248 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10250 end Analyze_Abstract_State
;
10252 ---------------------------
10253 -- Malformed_State_Error --
10254 ---------------------------
10256 procedure Malformed_State_Error
(State
: Node_Id
) is
10258 Error_Msg_N
("malformed abstract state declaration", State
);
10260 -- An abstract state with a simple option is being declared
10261 -- with "=>" rather than the legal "with". The state appears
10262 -- as a component association.
10264 if Nkind
(State
) = N_Component_Association
then
10265 Error_Msg_N
("\use WITH to specify simple option", State
);
10267 end Malformed_State_Error
;
10271 Pack_Decl
: Node_Id
;
10272 Pack_Id
: Entity_Id
;
10276 -- Start of processing for Abstract_State
10280 Check_No_Identifiers
;
10281 Check_Arg_Count
(1);
10283 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
10285 -- Ensure the proper placement of the pragma. Abstract states must
10286 -- be associated with a package declaration.
10288 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
10289 N_Package_Declaration
)
10293 -- Otherwise the pragma is associated with an illegal construct
10300 Pack_Id
:= Defining_Entity
(Pack_Decl
);
10302 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
10304 -- Mark the associated package as Ghost if it is subject to aspect
10305 -- or pragma Ghost as this affects the declaration of an abstract
10308 if Is_Subject_To_Ghost
(Unit_Declaration_Node
(Pack_Id
)) then
10309 Set_Is_Ghost_Entity
(Pack_Id
);
10312 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
10314 -- Multiple non-null abstract states appear as an aggregate
10316 if Nkind
(States
) = N_Aggregate
then
10317 State
:= First
(Expressions
(States
));
10318 while Present
(State
) loop
10319 Analyze_Abstract_State
(State
, Pack_Id
);
10323 -- An abstract state with a simple option is being illegaly
10324 -- declared with "=>" rather than "with". In this case the
10325 -- state declaration appears as a component association.
10327 if Present
(Component_Associations
(States
)) then
10328 State
:= First
(Component_Associations
(States
));
10329 while Present
(State
) loop
10330 Malformed_State_Error
(State
);
10335 -- Various forms of a single abstract state. Note that these may
10336 -- include malformed state declarations.
10339 Analyze_Abstract_State
(States
, Pack_Id
);
10342 -- Verify the declaration order of pragmas Abstract_State and
10345 Check_Declaration_Order
10347 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10349 -- Chain the pragma on the contract for completeness
10351 Add_Contract_Item
(N
, Pack_Id
);
10352 end Abstract_State
;
10360 -- Note: this pragma also has some specific processing in Par.Prag
10361 -- because we want to set the Ada version mode during parsing.
10363 when Pragma_Ada_83
=>
10365 Check_Arg_Count
(0);
10367 -- We really should check unconditionally for proper configuration
10368 -- pragma placement, since we really don't want mixed Ada modes
10369 -- within a single unit, and the GNAT reference manual has always
10370 -- said this was a configuration pragma, but we did not check and
10371 -- are hesitant to add the check now.
10373 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10374 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10375 -- or Ada 2012 mode.
10377 if Ada_Version
>= Ada_2005
then
10378 Check_Valid_Configuration_Pragma
;
10381 -- Now set Ada 83 mode
10383 Ada_Version
:= Ada_83
;
10384 Ada_Version_Explicit
:= Ada_83
;
10385 Ada_Version_Pragma
:= N
;
10393 -- Note: this pragma also has some specific processing in Par.Prag
10394 -- because we want to set the Ada 83 version mode during parsing.
10396 when Pragma_Ada_95
=>
10398 Check_Arg_Count
(0);
10400 -- We really should check unconditionally for proper configuration
10401 -- pragma placement, since we really don't want mixed Ada modes
10402 -- within a single unit, and the GNAT reference manual has always
10403 -- said this was a configuration pragma, but we did not check and
10404 -- are hesitant to add the check now.
10406 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10407 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10409 if Ada_Version
>= Ada_2005
then
10410 Check_Valid_Configuration_Pragma
;
10413 -- Now set Ada 95 mode
10415 Ada_Version
:= Ada_95
;
10416 Ada_Version_Explicit
:= Ada_95
;
10417 Ada_Version_Pragma
:= N
;
10419 ---------------------
10420 -- Ada_05/Ada_2005 --
10421 ---------------------
10424 -- pragma Ada_05 (LOCAL_NAME);
10426 -- pragma Ada_2005;
10427 -- pragma Ada_2005 (LOCAL_NAME):
10429 -- Note: these pragmas also have some specific processing in Par.Prag
10430 -- because we want to set the Ada 2005 version mode during parsing.
10432 -- The one argument form is used for managing the transition from
10433 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10434 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10435 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10436 -- mode, a preference rule is established which does not choose
10437 -- such an entity unless it is unambiguously specified. This avoids
10438 -- extra subprograms marked this way from generating ambiguities in
10439 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10440 -- intended for exclusive use in the GNAT run-time library.
10442 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10448 if Arg_Count
= 1 then
10449 Check_Arg_Is_Local_Name
(Arg1
);
10450 E_Id
:= Get_Pragma_Arg
(Arg1
);
10452 if Etype
(E_Id
) = Any_Type
then
10456 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10457 Record_Rep_Item
(Entity
(E_Id
), N
);
10460 Check_Arg_Count
(0);
10462 -- For Ada_2005 we unconditionally enforce the documented
10463 -- configuration pragma placement, since we do not want to
10464 -- tolerate mixed modes in a unit involving Ada 2005. That
10465 -- would cause real difficulties for those cases where there
10466 -- are incompatibilities between Ada 95 and Ada 2005.
10468 Check_Valid_Configuration_Pragma
;
10470 -- Now set appropriate Ada mode
10472 Ada_Version
:= Ada_2005
;
10473 Ada_Version_Explicit
:= Ada_2005
;
10474 Ada_Version_Pragma
:= N
;
10478 ---------------------
10479 -- Ada_12/Ada_2012 --
10480 ---------------------
10483 -- pragma Ada_12 (LOCAL_NAME);
10485 -- pragma Ada_2012;
10486 -- pragma Ada_2012 (LOCAL_NAME):
10488 -- Note: these pragmas also have some specific processing in Par.Prag
10489 -- because we want to set the Ada 2012 version mode during parsing.
10491 -- The one argument form is used for managing the transition from Ada
10492 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10493 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10494 -- mode will generate a warning. In addition, in any pre-Ada_2012
10495 -- mode, a preference rule is established which does not choose
10496 -- such an entity unless it is unambiguously specified. This avoids
10497 -- extra subprograms marked this way from generating ambiguities in
10498 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10499 -- intended for exclusive use in the GNAT run-time library.
10501 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10507 if Arg_Count
= 1 then
10508 Check_Arg_Is_Local_Name
(Arg1
);
10509 E_Id
:= Get_Pragma_Arg
(Arg1
);
10511 if Etype
(E_Id
) = Any_Type
then
10515 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10516 Record_Rep_Item
(Entity
(E_Id
), N
);
10519 Check_Arg_Count
(0);
10521 -- For Ada_2012 we unconditionally enforce the documented
10522 -- configuration pragma placement, since we do not want to
10523 -- tolerate mixed modes in a unit involving Ada 2012. That
10524 -- would cause real difficulties for those cases where there
10525 -- are incompatibilities between Ada 95 and Ada 2012. We could
10526 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10528 Check_Valid_Configuration_Pragma
;
10530 -- Now set appropriate Ada mode
10532 Ada_Version
:= Ada_2012
;
10533 Ada_Version_Explicit
:= Ada_2012
;
10534 Ada_Version_Pragma
:= N
;
10538 ----------------------
10539 -- All_Calls_Remote --
10540 ----------------------
10542 -- pragma All_Calls_Remote [(library_package_NAME)];
10544 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10545 Lib_Entity
: Entity_Id
;
10548 Check_Ada_83_Warning
;
10549 Check_Valid_Library_Unit_Pragma
;
10551 if Nkind
(N
) = N_Null_Statement
then
10555 Lib_Entity
:= Find_Lib_Unit_Name
;
10557 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10559 if Present
(Lib_Entity
)
10560 and then not Debug_Flag_U
10562 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10563 Error_Pragma
("pragma% only apply to rci unit");
10565 -- Set flag for entity of the library unit
10568 Set_Has_All_Calls_Remote
(Lib_Entity
);
10572 end All_Calls_Remote
;
10574 ---------------------------
10575 -- Allow_Integer_Address --
10576 ---------------------------
10578 -- pragma Allow_Integer_Address;
10580 when Pragma_Allow_Integer_Address
=>
10582 Check_Valid_Configuration_Pragma
;
10583 Check_Arg_Count
(0);
10585 -- If Address is a private type, then set the flag to allow
10586 -- integer address values. If Address is not private, then this
10587 -- pragma has no purpose, so it is simply ignored. Not clear if
10588 -- there are any such targets now.
10590 if Opt
.Address_Is_Private
then
10591 Opt
.Allow_Integer_Address
:= True;
10599 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10600 -- ARG ::= NAME | EXPRESSION
10602 -- The first two arguments are by convention intended to refer to an
10603 -- external tool and a tool-specific function. These arguments are
10606 when Pragma_Annotate
=> Annotate
: declare
10612 Check_At_Least_N_Arguments
(1);
10614 -- See if last argument is Entity => local_Name, and if so process
10615 -- and then remove it for remaining processing.
10618 Last_Arg
: constant Node_Id
:=
10619 Last
(Pragma_Argument_Associations
(N
));
10622 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
10623 and then Chars
(Last_Arg
) = Name_Entity
10625 Check_Arg_Is_Local_Name
(Last_Arg
);
10626 Arg_Count
:= Arg_Count
- 1;
10628 -- Not allowed in compiler units (bootstrap issues)
10630 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
10634 -- Continue processing with last argument removed for now
10636 Check_Arg_Is_Identifier
(Arg1
);
10637 Check_No_Identifiers
;
10640 -- Second parameter is optional, it is never analyzed
10645 -- Here if we have a second parameter
10648 -- Second parameter must be identifier
10650 Check_Arg_Is_Identifier
(Arg2
);
10652 -- Process remaining parameters if any
10654 Arg
:= Next
(Arg2
);
10655 while Present
(Arg
) loop
10656 Exp
:= Get_Pragma_Arg
(Arg
);
10659 if Is_Entity_Name
(Exp
) then
10662 -- For string literals, we assume Standard_String as the
10663 -- type, unless the string contains wide or wide_wide
10666 elsif Nkind
(Exp
) = N_String_Literal
then
10667 if Has_Wide_Wide_Character
(Exp
) then
10668 Resolve
(Exp
, Standard_Wide_Wide_String
);
10669 elsif Has_Wide_Character
(Exp
) then
10670 Resolve
(Exp
, Standard_Wide_String
);
10672 Resolve
(Exp
, Standard_String
);
10675 elsif Is_Overloaded
(Exp
) then
10677 ("ambiguous argument for pragma%", Exp
);
10688 -------------------------------------------------
10689 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
10690 -------------------------------------------------
10693 -- ( [Check => ] Boolean_EXPRESSION
10694 -- [, [Message =>] Static_String_EXPRESSION]);
10696 -- pragma Assert_And_Cut
10697 -- ( [Check => ] Boolean_EXPRESSION
10698 -- [, [Message =>] Static_String_EXPRESSION]);
10701 -- ( [Check => ] Boolean_EXPRESSION
10702 -- [, [Message =>] Static_String_EXPRESSION]);
10704 -- pragma Loop_Invariant
10705 -- ( [Check => ] Boolean_EXPRESSION
10706 -- [, [Message =>] Static_String_EXPRESSION]);
10708 when Pragma_Assert |
10709 Pragma_Assert_And_Cut |
10711 Pragma_Loop_Invariant
=>
10713 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
10714 -- Determine whether expression Expr contains a Loop_Entry
10715 -- attribute reference.
10717 -------------------------
10718 -- Contains_Loop_Entry --
10719 -------------------------
10721 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
10722 Has_Loop_Entry
: Boolean := False;
10724 function Process
(N
: Node_Id
) return Traverse_Result
;
10725 -- Process function for traversal to look for Loop_Entry
10731 function Process
(N
: Node_Id
) return Traverse_Result
is
10733 if Nkind
(N
) = N_Attribute_Reference
10734 and then Attribute_Name
(N
) = Name_Loop_Entry
10736 Has_Loop_Entry
:= True;
10743 procedure Traverse
is new Traverse_Proc
(Process
);
10745 -- Start of processing for Contains_Loop_Entry
10749 return Has_Loop_Entry
;
10750 end Contains_Loop_Entry
;
10757 -- Start of processing for Assert
10760 -- Assert is an Ada 2005 RM-defined pragma
10762 if Prag_Id
= Pragma_Assert
then
10765 -- The remaining ones are GNAT pragmas
10771 Check_At_Least_N_Arguments
(1);
10772 Check_At_Most_N_Arguments
(2);
10773 Check_Arg_Order
((Name_Check
, Name_Message
));
10774 Check_Optional_Identifier
(Arg1
, Name_Check
);
10775 Expr
:= Get_Pragma_Arg
(Arg1
);
10777 -- Special processing for Loop_Invariant, Loop_Variant or for
10778 -- other cases where a Loop_Entry attribute is present. If the
10779 -- assertion pragma contains attribute Loop_Entry, ensure that
10780 -- the related pragma is within a loop.
10782 if Prag_Id
= Pragma_Loop_Invariant
10783 or else Prag_Id
= Pragma_Loop_Variant
10784 or else Contains_Loop_Entry
(Expr
)
10786 Check_Loop_Pragma_Placement
;
10788 -- Perform preanalysis to deal with embedded Loop_Entry
10791 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
10794 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
10795 -- a corresponding Check pragma:
10797 -- pragma Check (name, condition [, msg]);
10799 -- Where name is the identifier matching the pragma name. So
10800 -- rewrite pragma in this manner, transfer the message argument
10801 -- if present, and analyze the result
10803 -- Note: When dealing with a semantically analyzed tree, the
10804 -- information that a Check node N corresponds to a source Assert,
10805 -- Assume, or Assert_And_Cut pragma can be retrieved from the
10806 -- pragma kind of Original_Node(N).
10809 Make_Pragma_Argument_Association
(Loc
,
10810 Expression
=> Make_Identifier
(Loc
, Pname
)),
10811 Make_Pragma_Argument_Association
(Sloc
(Expr
),
10812 Expression
=> Expr
));
10814 if Arg_Count
> 1 then
10815 Check_Optional_Identifier
(Arg2
, Name_Message
);
10817 -- Provide semantic annnotations for optional argument, for
10818 -- ASIS use, before rewriting.
10820 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
10821 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
10824 -- Rewrite as Check pragma
10828 Chars
=> Name_Check
,
10829 Pragma_Argument_Associations
=> Newa
));
10833 ----------------------
10834 -- Assertion_Policy --
10835 ----------------------
10837 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
10839 -- The following form is Ada 2012 only, but we allow it in all modes
10841 -- Pragma Assertion_Policy (
10842 -- ASSERTION_KIND => POLICY_IDENTIFIER
10843 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
10845 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
10847 -- RM_ASSERTION_KIND ::= Assert |
10848 -- Static_Predicate |
10849 -- Dynamic_Predicate |
10854 -- Type_Invariant |
10855 -- Type_Invariant'Class
10857 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
10859 -- Contract_Cases |
10861 -- Default_Initial_Condition |
10863 -- Initial_Condition |
10864 -- Loop_Invariant |
10870 -- Statement_Assertions
10872 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
10873 -- ID_ASSERTION_KIND list contains implementation-defined additions
10874 -- recognized by GNAT. The effect is to control the behavior of
10875 -- identically named aspects and pragmas, depending on the specified
10876 -- policy identifier:
10878 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
10880 -- Note: Check and Ignore are language-defined. Disable is a GNAT
10881 -- implementation defined addition that results in totally ignoring
10882 -- the corresponding assertion. If Disable is specified, then the
10883 -- argument of the assertion is not even analyzed. This is useful
10884 -- when the aspect/pragma argument references entities in a with'ed
10885 -- package that is replaced by a dummy package in the final build.
10887 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
10888 -- and Type_Invariant'Class were recognized by the parser and
10889 -- transformed into references to the special internal identifiers
10890 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
10891 -- processing is required here.
10893 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
10902 -- This can always appear as a configuration pragma
10904 if Is_Configuration_Pragma
then
10907 -- It can also appear in a declarative part or package spec in Ada
10908 -- 2012 mode. We allow this in other modes, but in that case we
10909 -- consider that we have an Ada 2012 pragma on our hands.
10912 Check_Is_In_Decl_Part_Or_Package_Spec
;
10916 -- One argument case with no identifier (first form above)
10919 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
10920 or else Chars
(Arg1
) = No_Name
)
10922 Check_Arg_Is_One_Of
10923 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
10925 -- Treat one argument Assertion_Policy as equivalent to:
10927 -- pragma Check_Policy (Assertion, policy)
10929 -- So rewrite pragma in that manner and link on to the chain
10930 -- of Check_Policy pragmas, marking the pragma as analyzed.
10932 Policy
:= Get_Pragma_Arg
(Arg1
);
10936 Chars
=> Name_Check_Policy
,
10937 Pragma_Argument_Associations
=> New_List
(
10938 Make_Pragma_Argument_Association
(Loc
,
10939 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
10941 Make_Pragma_Argument_Association
(Loc
,
10943 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
10946 -- Here if we have two or more arguments
10949 Check_At_Least_N_Arguments
(1);
10952 -- Loop through arguments
10955 while Present
(Arg
) loop
10956 LocP
:= Sloc
(Arg
);
10958 -- Kind must be specified
10960 if Nkind
(Arg
) /= N_Pragma_Argument_Association
10961 or else Chars
(Arg
) = No_Name
10964 ("missing assertion kind for pragma%", Arg
);
10967 -- Check Kind and Policy have allowed forms
10969 Kind
:= Chars
(Arg
);
10971 if not Is_Valid_Assertion_Kind
(Kind
) then
10973 ("invalid assertion kind for pragma%", Arg
);
10976 Check_Arg_Is_One_Of
10977 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
10979 -- Rewrite the Assertion_Policy pragma as a series of
10980 -- Check_Policy pragmas of the form:
10982 -- Check_Policy (Kind, Policy);
10984 -- Note: the insertion of the pragmas cannot be done with
10985 -- Insert_Action because in the configuration case, there
10986 -- are no scopes on the scope stack and the mechanism will
10989 Insert_Before_And_Analyze
(N
,
10991 Chars
=> Name_Check_Policy
,
10992 Pragma_Argument_Associations
=> New_List
(
10993 Make_Pragma_Argument_Association
(LocP
,
10994 Expression
=> Make_Identifier
(LocP
, Kind
)),
10995 Make_Pragma_Argument_Association
(LocP
,
10996 Expression
=> Get_Pragma_Arg
(Arg
)))));
11001 -- Rewrite the Assertion_Policy pragma as null since we have
11002 -- now inserted all the equivalent Check pragmas.
11004 Rewrite
(N
, Make_Null_Statement
(Loc
));
11007 end Assertion_Policy
;
11009 ------------------------------
11010 -- Assume_No_Invalid_Values --
11011 ------------------------------
11013 -- pragma Assume_No_Invalid_Values (On | Off);
11015 when Pragma_Assume_No_Invalid_Values
=>
11017 Check_Valid_Configuration_Pragma
;
11018 Check_Arg_Count
(1);
11019 Check_No_Identifiers
;
11020 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11022 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11023 Assume_No_Invalid_Values
:= True;
11025 Assume_No_Invalid_Values
:= False;
11028 --------------------------
11029 -- Attribute_Definition --
11030 --------------------------
11032 -- pragma Attribute_Definition
11033 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11034 -- [Entity =>] LOCAL_NAME,
11035 -- [Expression =>] EXPRESSION | NAME);
11037 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11038 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11043 Check_Arg_Count
(3);
11044 Check_Optional_Identifier
(Arg1
, "attribute");
11045 Check_Optional_Identifier
(Arg2
, "entity");
11046 Check_Optional_Identifier
(Arg3
, "expression");
11048 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11049 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11053 Check_Arg_Is_Local_Name
(Arg2
);
11055 -- If the attribute is not recognized, then issue a warning (not
11056 -- an error), and ignore the pragma.
11058 Aname
:= Chars
(Attribute_Designator
);
11060 if not Is_Attribute_Name
(Aname
) then
11061 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11065 -- Otherwise, rewrite the pragma as an attribute definition clause
11068 Make_Attribute_Definition_Clause
(Loc
,
11069 Name
=> Get_Pragma_Arg
(Arg2
),
11071 Expression
=> Get_Pragma_Arg
(Arg3
)));
11073 end Attribute_Definition
;
11075 ------------------------------------------------------------------
11076 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11077 ------------------------------------------------------------------
11079 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
11080 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
11081 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
11082 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
11084 -- FLAG ::= boolean_EXPRESSION
11086 when Pragma_Async_Readers |
11087 Pragma_Async_Writers |
11088 Pragma_Effective_Reads |
11089 Pragma_Effective_Writes
=>
11090 Async_Effective
: declare
11094 Obj_Id
: Entity_Id
;
11098 Check_No_Identifiers
;
11099 Check_At_Least_N_Arguments
(1);
11100 Check_At_Most_N_Arguments
(2);
11101 Check_Arg_Is_Local_Name
(Arg1
);
11102 Error_Msg_Name_1
:= Pname
;
11104 Obj
:= Get_Pragma_Arg
(Arg1
);
11105 Expr
:= Get_Pragma_Arg
(Arg2
);
11107 -- Perform minimal verification to ensure that the argument is at
11108 -- least a variable. Subsequent finer grained checks will be done
11109 -- at the end of the declarative region the contains the pragma.
11111 if Is_Entity_Name
(Obj
)
11112 and then Present
(Entity
(Obj
))
11113 and then Ekind
(Entity
(Obj
)) = E_Variable
11115 Obj_Id
:= Entity
(Obj
);
11117 -- Detect a duplicate pragma. Note that it is not efficient to
11118 -- examine preceding statements as Boolean aspects may appear
11119 -- anywhere between the related object declaration and its
11120 -- freeze point. As an alternative, inspect the contents of the
11121 -- variable contract.
11123 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
11125 if Present
(Duplic
) then
11126 Error_Msg_Sloc
:= Sloc
(Duplic
);
11127 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
11129 -- No duplicate detected
11132 if Present
(Expr
) then
11133 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
11136 -- Chain the pragma on the contract for further processing
11137 -- by Analyze_External_Property_In_Decl_Part.
11139 Add_Contract_Item
(N
, Obj_Id
);
11142 Error_Pragma
("pragma % must apply to a volatile object");
11144 end Async_Effective
;
11150 -- pragma Asynchronous (LOCAL_NAME);
11152 when Pragma_Asynchronous
=> Asynchronous
: declare
11158 Formal
: Entity_Id
;
11160 procedure Process_Async_Pragma
;
11161 -- Common processing for procedure and access-to-procedure case
11163 --------------------------
11164 -- Process_Async_Pragma --
11165 --------------------------
11167 procedure Process_Async_Pragma
is
11170 Set_Is_Asynchronous
(Nm
);
11174 -- The formals should be of mode IN (RM E.4.1(6))
11177 while Present
(S
) loop
11178 Formal
:= Defining_Identifier
(S
);
11180 if Nkind
(Formal
) = N_Defining_Identifier
11181 and then Ekind
(Formal
) /= E_In_Parameter
11184 ("pragma% procedure can only have IN parameter",
11191 Set_Is_Asynchronous
(Nm
);
11192 end Process_Async_Pragma
;
11194 -- Start of processing for pragma Asynchronous
11197 Check_Ada_83_Warning
;
11198 Check_No_Identifiers
;
11199 Check_Arg_Count
(1);
11200 Check_Arg_Is_Local_Name
(Arg1
);
11202 if Debug_Flag_U
then
11206 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11207 Analyze
(Get_Pragma_Arg
(Arg1
));
11208 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11210 if not Is_Remote_Call_Interface
(C_Ent
)
11211 and then not Is_Remote_Types
(C_Ent
)
11213 -- This pragma should only appear in an RCI or Remote Types
11214 -- unit (RM E.4.1(4)).
11217 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11220 if Ekind
(Nm
) = E_Procedure
11221 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11223 if not Is_Remote_Call_Interface
(Nm
) then
11225 ("pragma% cannot be applied on non-remote procedure",
11229 L
:= Parameter_Specifications
(Parent
(Nm
));
11230 Process_Async_Pragma
;
11233 elsif Ekind
(Nm
) = E_Function
then
11235 ("pragma% cannot be applied to function", Arg1
);
11237 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11238 if Is_Record_Type
(Nm
) then
11240 -- A record type that is the Equivalent_Type for a remote
11241 -- access-to-subprogram type.
11243 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11246 -- A non-expanded RAS type (distribution is not enabled)
11248 N
:= Declaration_Node
(Nm
);
11251 if Nkind
(N
) = N_Full_Type_Declaration
11252 and then Nkind
(Type_Definition
(N
)) =
11253 N_Access_Procedure_Definition
11255 L
:= Parameter_Specifications
(Type_Definition
(N
));
11256 Process_Async_Pragma
;
11258 if Is_Asynchronous
(Nm
)
11259 and then Expander_Active
11260 and then Get_PCS_Name
/= Name_No_DSA
11262 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11267 ("pragma% cannot reference access-to-function type",
11271 -- Only other possibility is Access-to-class-wide type
11273 elsif Is_Access_Type
(Nm
)
11274 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11276 Check_First_Subtype
(Arg1
);
11277 Set_Is_Asynchronous
(Nm
);
11278 if Expander_Active
then
11279 RACW_Type_Is_Asynchronous
(Nm
);
11283 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11291 -- pragma Atomic (LOCAL_NAME);
11293 when Pragma_Atomic
=>
11294 Process_Atomic_Independent_Shared_Volatile
;
11296 -----------------------
11297 -- Atomic_Components --
11298 -----------------------
11300 -- pragma Atomic_Components (array_LOCAL_NAME);
11302 -- This processing is shared by Volatile_Components
11304 when Pragma_Atomic_Components |
11305 Pragma_Volatile_Components
=>
11307 Atomic_Components
: declare
11314 Check_Ada_83_Warning
;
11315 Check_No_Identifiers
;
11316 Check_Arg_Count
(1);
11317 Check_Arg_Is_Local_Name
(Arg1
);
11318 E_Id
:= Get_Pragma_Arg
(Arg1
);
11320 if Etype
(E_Id
) = Any_Type
then
11324 E
:= Entity
(E_Id
);
11326 Check_Duplicate_Pragma
(E
);
11328 if Rep_Item_Too_Early
(E
, N
)
11330 Rep_Item_Too_Late
(E
, N
)
11335 D
:= Declaration_Node
(E
);
11338 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11340 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11341 and then Nkind
(D
) = N_Object_Declaration
11342 and then Nkind
(Object_Definition
(D
)) =
11343 N_Constrained_Array_Definition
)
11345 -- The flag is set on the object, or on the base type
11347 if Nkind
(D
) /= N_Object_Declaration
then
11348 E
:= Base_Type
(E
);
11351 -- Atomic implies both Independent and Volatile
11353 if Prag_Id
= Pragma_Atomic_Components
then
11354 Set_Has_Atomic_Components
(E
);
11355 Set_Has_Independent_Components
(E
);
11358 Set_Has_Volatile_Components
(E
);
11361 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11363 end Atomic_Components
;
11365 --------------------
11366 -- Attach_Handler --
11367 --------------------
11369 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11371 when Pragma_Attach_Handler
=>
11372 Check_Ada_83_Warning
;
11373 Check_No_Identifiers
;
11374 Check_Arg_Count
(2);
11376 if No_Run_Time_Mode
then
11377 Error_Msg_CRT
("Attach_Handler pragma", N
);
11379 Check_Interrupt_Or_Attach_Handler
;
11381 -- The expression that designates the attribute may depend on a
11382 -- discriminant, and is therefore a per-object expression, to
11383 -- be expanded in the init proc. If expansion is enabled, then
11384 -- perform semantic checks on a copy only.
11389 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11392 -- In Relaxed_RM_Semantics mode, we allow any static
11393 -- integer value, for compatibility with other compilers.
11395 if Relaxed_RM_Semantics
11396 and then Nkind
(Parg2
) = N_Integer_Literal
11398 Typ
:= Standard_Integer
;
11400 Typ
:= RTE
(RE_Interrupt_ID
);
11403 if Expander_Active
then
11404 Temp
:= New_Copy_Tree
(Parg2
);
11405 Set_Parent
(Temp
, N
);
11406 Preanalyze_And_Resolve
(Temp
, Typ
);
11409 Resolve
(Parg2
, Typ
);
11413 Process_Interrupt_Or_Attach_Handler
;
11416 --------------------
11417 -- C_Pass_By_Copy --
11418 --------------------
11420 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11422 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11428 Check_Valid_Configuration_Pragma
;
11429 Check_Arg_Count
(1);
11430 Check_Optional_Identifier
(Arg1
, "max_size");
11432 Arg
:= Get_Pragma_Arg
(Arg1
);
11433 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11435 Val
:= Expr_Value
(Arg
);
11439 ("maximum size for pragma% must be positive", Arg1
);
11441 elsif UI_Is_In_Int_Range
(Val
) then
11442 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11444 -- If a giant value is given, Int'Last will do well enough.
11445 -- If sometime someone complains that a record larger than
11446 -- two gigabytes is not copied, we will worry about it then.
11449 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11451 end C_Pass_By_Copy
;
11457 -- pragma Check ([Name =>] CHECK_KIND,
11458 -- [Check =>] Boolean_EXPRESSION
11459 -- [,[Message =>] String_EXPRESSION]);
11461 -- CHECK_KIND ::= IDENTIFIER |
11464 -- Invariant'Class |
11465 -- Type_Invariant'Class
11467 -- The identifiers Assertions and Statement_Assertions are not
11468 -- allowed, since they have special meaning for Check_Policy.
11470 when Pragma_Check
=> Check
: declare
11478 Check_At_Least_N_Arguments
(2);
11479 Check_At_Most_N_Arguments
(3);
11480 Check_Optional_Identifier
(Arg1
, Name_Name
);
11481 Check_Optional_Identifier
(Arg2
, Name_Check
);
11483 if Arg_Count
= 3 then
11484 Check_Optional_Identifier
(Arg3
, Name_Message
);
11485 Str
:= Get_Pragma_Arg
(Arg3
);
11488 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11489 Check_Arg_Is_Identifier
(Arg1
);
11490 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11492 -- Check forbidden name Assertions or Statement_Assertions
11495 when Name_Assertions
=>
11497 ("""Assertions"" is not allowed as a check kind "
11498 & "for pragma%", Arg1
);
11500 when Name_Statement_Assertions
=>
11502 ("""Statement_Assertions"" is not allowed as a check kind "
11503 & "for pragma%", Arg1
);
11509 -- Check applicable policy. We skip this if Checked/Ignored status
11510 -- is already set (e.g. in the case of a pragma from an aspect).
11512 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11515 -- For a non-source pragma that is a rewriting of another pragma,
11516 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11518 elsif Is_Rewrite_Substitution
(N
)
11519 and then Nkind
(Original_Node
(N
)) = N_Pragma
11520 and then Original_Node
(N
) /= N
11522 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11523 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11525 -- Otherwise query the applicable policy at this point
11528 case Check_Kind
(Cname
) is
11529 when Name_Ignore
=>
11530 Set_Is_Ignored
(N
, True);
11531 Set_Is_Checked
(N
, False);
11534 Set_Is_Ignored
(N
, False);
11535 Set_Is_Checked
(N
, True);
11537 -- For disable, rewrite pragma as null statement and skip
11538 -- rest of the analysis of the pragma.
11540 when Name_Disable
=>
11541 Rewrite
(N
, Make_Null_Statement
(Loc
));
11545 -- No other possibilities
11548 raise Program_Error
;
11552 -- If check kind was not Disable, then continue pragma analysis
11554 Expr
:= Get_Pragma_Arg
(Arg2
);
11556 -- Deal with SCO generation
11559 when Name_Predicate |
11562 -- Nothing to do: since checks occur in client units,
11563 -- the SCO for the aspect in the declaration unit is
11564 -- conservatively always enabled.
11570 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11572 -- Mark aspect/pragma SCO as enabled
11574 Set_SCO_Pragma_Enabled
(Loc
);
11578 -- Deal with analyzing the string argument
11580 if Arg_Count
= 3 then
11582 -- If checks are not on we don't want any expansion (since
11583 -- such expansion would not get properly deleted) but
11584 -- we do want to analyze (to get proper references).
11585 -- The Preanalyze_And_Resolve routine does just what we want
11587 if Is_Ignored
(N
) then
11588 Preanalyze_And_Resolve
(Str
, Standard_String
);
11590 -- Otherwise we need a proper analysis and expansion
11593 Analyze_And_Resolve
(Str
, Standard_String
);
11597 -- Now you might think we could just do the same with the Boolean
11598 -- expression if checks are off (and expansion is on) and then
11599 -- rewrite the check as a null statement. This would work but we
11600 -- would lose the useful warnings about an assertion being bound
11601 -- to fail even if assertions are turned off.
11603 -- So instead we wrap the boolean expression in an if statement
11604 -- that looks like:
11606 -- if False and then condition then
11610 -- The reason we do this rewriting during semantic analysis rather
11611 -- than as part of normal expansion is that we cannot analyze and
11612 -- expand the code for the boolean expression directly, or it may
11613 -- cause insertion of actions that would escape the attempt to
11614 -- suppress the check code.
11616 -- Note that the Sloc for the if statement corresponds to the
11617 -- argument condition, not the pragma itself. The reason for
11618 -- this is that we may generate a warning if the condition is
11619 -- False at compile time, and we do not want to delete this
11620 -- warning when we delete the if statement.
11622 if Expander_Active
and Is_Ignored
(N
) then
11623 Eloc
:= Sloc
(Expr
);
11626 Make_If_Statement
(Eloc
,
11628 Make_And_Then
(Eloc
,
11629 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
11630 Right_Opnd
=> Expr
),
11631 Then_Statements
=> New_List
(
11632 Make_Null_Statement
(Eloc
))));
11634 -- Now go ahead and analyze the if statement
11636 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11638 -- One rather special treatment. If we are now in Eliminated
11639 -- overflow mode, then suppress overflow checking since we do
11640 -- not want to drag in the bignum stuff if we are in Ignore
11641 -- mode anyway. This is particularly important if we are using
11642 -- a configurable run time that does not support bignum ops.
11644 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
11646 Svo
: constant Boolean :=
11647 Scope_Suppress
.Suppress
(Overflow_Check
);
11649 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
11650 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
11652 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
11653 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
11656 -- Not that special case!
11662 -- All done with this check
11664 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11666 -- Check is active or expansion not active. In these cases we can
11667 -- just go ahead and analyze the boolean with no worries.
11670 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11671 Analyze_And_Resolve
(Expr
, Any_Boolean
);
11672 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11676 --------------------------
11677 -- Check_Float_Overflow --
11678 --------------------------
11680 -- pragma Check_Float_Overflow;
11682 when Pragma_Check_Float_Overflow
=>
11684 Check_Valid_Configuration_Pragma
;
11685 Check_Arg_Count
(0);
11686 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
11692 -- pragma Check_Name (check_IDENTIFIER);
11694 when Pragma_Check_Name
=>
11696 Check_No_Identifiers
;
11697 Check_Valid_Configuration_Pragma
;
11698 Check_Arg_Count
(1);
11699 Check_Arg_Is_Identifier
(Arg1
);
11702 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
11705 for J
in Check_Names
.First
.. Check_Names
.Last
loop
11706 if Check_Names
.Table
(J
) = Nam
then
11711 Check_Names
.Append
(Nam
);
11718 -- This is the old style syntax, which is still allowed in all modes:
11720 -- pragma Check_Policy ([Name =>] CHECK_KIND
11721 -- [Policy =>] POLICY_IDENTIFIER);
11723 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
11725 -- CHECK_KIND ::= IDENTIFIER |
11728 -- Type_Invariant'Class |
11731 -- This is the new style syntax, compatible with Assertion_Policy
11732 -- and also allowed in all modes.
11734 -- Pragma Check_Policy (
11735 -- CHECK_KIND => POLICY_IDENTIFIER
11736 -- {, CHECK_KIND => POLICY_IDENTIFIER});
11738 -- Note: the identifiers Name and Policy are not allowed as
11739 -- Check_Kind values. This avoids ambiguities between the old and
11740 -- new form syntax.
11742 when Pragma_Check_Policy
=> Check_Policy
: declare
11748 Check_At_Least_N_Arguments
(1);
11750 -- A Check_Policy pragma can appear either as a configuration
11751 -- pragma, or in a declarative part or a package spec (see RM
11752 -- 11.5(5) for rules for Suppress/Unsuppress which are also
11753 -- followed for Check_Policy).
11755 if not Is_Configuration_Pragma
then
11756 Check_Is_In_Decl_Part_Or_Package_Spec
;
11759 -- Figure out if we have the old or new syntax. We have the
11760 -- old syntax if the first argument has no identifier, or the
11761 -- identifier is Name.
11763 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
11764 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
11768 Check_Arg_Count
(2);
11769 Check_Optional_Identifier
(Arg1
, Name_Name
);
11770 Kind
:= Get_Pragma_Arg
(Arg1
);
11771 Rewrite_Assertion_Kind
(Kind
);
11772 Check_Arg_Is_Identifier
(Arg1
);
11774 -- Check forbidden check kind
11776 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
11777 Error_Msg_Name_2
:= Chars
(Kind
);
11779 ("pragma% does not allow% as check name", Arg1
);
11784 Check_Optional_Identifier
(Arg2
, Name_Policy
);
11785 Check_Arg_Is_One_Of
11787 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
11788 Ident
:= Get_Pragma_Arg
(Arg2
);
11790 if Chars
(Kind
) = Name_Ghost
then
11792 -- Pragma Check_Policy specifying a Ghost policy cannot
11793 -- occur within a ghost subprogram or package.
11795 if Ghost_Mode
> None
then
11797 ("pragma % cannot appear within ghost subprogram or "
11800 -- The policy identifier of pragma Ghost must be either
11801 -- Check or Ignore (SPARK RM 6.9(7)).
11803 elsif not Nam_In
(Chars
(Ident
), Name_Check
,
11807 ("argument of pragma % Ghost must be Check or Ignore",
11812 -- And chain pragma on the Check_Policy_List for search
11814 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
11815 Opt
.Check_Policy_List
:= N
;
11817 -- For the new syntax, what we do is to convert each argument to
11818 -- an old syntax equivalent. We do that because we want to chain
11819 -- old style Check_Policy pragmas for the search (we don't want
11820 -- to have to deal with multiple arguments in the search).
11830 while Present
(Arg
) loop
11831 LocP
:= Sloc
(Arg
);
11832 Argx
:= Get_Pragma_Arg
(Arg
);
11834 -- Kind must be specified
11836 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11837 or else Chars
(Arg
) = No_Name
11840 ("missing assertion kind for pragma%", Arg
);
11843 -- Construct equivalent old form syntax Check_Policy
11844 -- pragma and insert it to get remaining checks.
11848 Chars
=> Name_Check_Policy
,
11849 Pragma_Argument_Associations
=> New_List
(
11850 Make_Pragma_Argument_Association
(LocP
,
11852 Make_Identifier
(LocP
, Chars
(Arg
))),
11853 Make_Pragma_Argument_Association
(Sloc
(Argx
),
11854 Expression
=> Argx
))));
11859 -- Rewrite original Check_Policy pragma to null, since we
11860 -- have converted it into a series of old syntax pragmas.
11862 Rewrite
(N
, Make_Null_Statement
(Loc
));
11868 ---------------------
11869 -- CIL_Constructor --
11870 ---------------------
11872 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
11874 -- Processing for this pragma is shared with Java_Constructor
11880 -- pragma Comment (static_string_EXPRESSION)
11882 -- Processing for pragma Comment shares the circuitry for pragma
11883 -- Ident. The only differences are that Ident enforces a limit of 31
11884 -- characters on its argument, and also enforces limitations on
11885 -- placement for DEC compatibility. Pragma Comment shares neither of
11886 -- these restrictions.
11888 -------------------
11889 -- Common_Object --
11890 -------------------
11892 -- pragma Common_Object (
11893 -- [Internal =>] LOCAL_NAME
11894 -- [, [External =>] EXTERNAL_SYMBOL]
11895 -- [, [Size =>] EXTERNAL_SYMBOL]);
11897 -- Processing for this pragma is shared with Psect_Object
11899 ------------------------
11900 -- Compile_Time_Error --
11901 ------------------------
11903 -- pragma Compile_Time_Error
11904 -- (boolean_EXPRESSION, static_string_EXPRESSION);
11906 when Pragma_Compile_Time_Error
=>
11908 Process_Compile_Time_Warning_Or_Error
;
11910 --------------------------
11911 -- Compile_Time_Warning --
11912 --------------------------
11914 -- pragma Compile_Time_Warning
11915 -- (boolean_EXPRESSION, static_string_EXPRESSION);
11917 when Pragma_Compile_Time_Warning
=>
11919 Process_Compile_Time_Warning_Or_Error
;
11921 ---------------------------
11922 -- Compiler_Unit_Warning --
11923 ---------------------------
11925 -- pragma Compiler_Unit_Warning;
11929 -- Originally, we had only pragma Compiler_Unit, and it resulted in
11930 -- errors not warnings. This means that we had introduced a big extra
11931 -- inertia to compiler changes, since even if we implemented a new
11932 -- feature, and even if all versions to be used for bootstrapping
11933 -- implemented this new feature, we could not use it, since old
11934 -- compilers would give errors for using this feature in units
11935 -- having Compiler_Unit pragmas.
11937 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
11938 -- problem. We no longer have any units mentioning Compiler_Unit,
11939 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
11940 -- and thus generates a warning which can be ignored. So that deals
11941 -- with the problem of old compilers not implementing the newer form
11944 -- Newer compilers recognize the new pragma, but generate warning
11945 -- messages instead of errors, which again can be ignored in the
11946 -- case of an old compiler which implements a wanted new feature
11947 -- but at the time felt like warning about it for older compilers.
11949 -- We retain Compiler_Unit so that new compilers can be used to build
11950 -- older run-times that use this pragma. That's an unusual case, but
11951 -- it's easy enough to handle, so why not?
11953 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
11955 Check_Arg_Count
(0);
11957 -- Only recognized in main unit
11959 if Current_Sem_Unit
= Main_Unit
then
11960 Compiler_Unit
:= True;
11963 -----------------------------
11964 -- Complete_Representation --
11965 -----------------------------
11967 -- pragma Complete_Representation;
11969 when Pragma_Complete_Representation
=>
11971 Check_Arg_Count
(0);
11973 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
11975 ("pragma & must appear within record representation clause");
11978 ----------------------------
11979 -- Complex_Representation --
11980 ----------------------------
11982 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
11984 when Pragma_Complex_Representation
=> Complex_Representation
: declare
11991 Check_Arg_Count
(1);
11992 Check_Optional_Identifier
(Arg1
, Name_Entity
);
11993 Check_Arg_Is_Local_Name
(Arg1
);
11994 E_Id
:= Get_Pragma_Arg
(Arg1
);
11996 if Etype
(E_Id
) = Any_Type
then
12000 E
:= Entity
(E_Id
);
12002 if not Is_Record_Type
(E
) then
12004 ("argument for pragma% must be record type", Arg1
);
12007 Ent
:= First_Entity
(E
);
12010 or else No
(Next_Entity
(Ent
))
12011 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12012 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12013 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12016 ("record for pragma% must have two fields of the same "
12017 & "floating-point type", Arg1
);
12020 Set_Has_Complex_Representation
(Base_Type
(E
));
12022 -- We need to treat the type has having a non-standard
12023 -- representation, for back-end purposes, even though in
12024 -- general a complex will have the default representation
12025 -- of a record with two real components.
12027 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12029 end Complex_Representation
;
12031 -------------------------
12032 -- Component_Alignment --
12033 -------------------------
12035 -- pragma Component_Alignment (
12036 -- [Form =>] ALIGNMENT_CHOICE
12037 -- [, [Name =>] type_LOCAL_NAME]);
12039 -- ALIGNMENT_CHOICE ::=
12041 -- | Component_Size_4
12045 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12046 Args
: Args_List
(1 .. 2);
12047 Names
: constant Name_List
(1 .. 2) := (
12051 Form
: Node_Id
renames Args
(1);
12052 Name
: Node_Id
renames Args
(2);
12054 Atype
: Component_Alignment_Kind
;
12059 Gather_Associations
(Names
, Args
);
12062 Error_Pragma
("missing Form argument for pragma%");
12065 Check_Arg_Is_Identifier
(Form
);
12067 -- Get proper alignment, note that Default = Component_Size on all
12068 -- machines we have so far, and we want to set this value rather
12069 -- than the default value to indicate that it has been explicitly
12070 -- set (and thus will not get overridden by the default component
12071 -- alignment for the current scope)
12073 if Chars
(Form
) = Name_Component_Size
then
12074 Atype
:= Calign_Component_Size
;
12076 elsif Chars
(Form
) = Name_Component_Size_4
then
12077 Atype
:= Calign_Component_Size_4
;
12079 elsif Chars
(Form
) = Name_Default
then
12080 Atype
:= Calign_Component_Size
;
12082 elsif Chars
(Form
) = Name_Storage_Unit
then
12083 Atype
:= Calign_Storage_Unit
;
12087 ("invalid Form parameter for pragma%", Form
);
12090 -- Case with no name, supplied, affects scope table entry
12094 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12096 -- Case of name supplied
12099 Check_Arg_Is_Local_Name
(Name
);
12101 Typ
:= Entity
(Name
);
12104 or else Rep_Item_Too_Early
(Typ
, N
)
12108 Typ
:= Underlying_Type
(Typ
);
12111 if not Is_Record_Type
(Typ
)
12112 and then not Is_Array_Type
(Typ
)
12115 ("Name parameter of pragma% must identify record or "
12116 & "array type", Name
);
12119 -- An explicit Component_Alignment pragma overrides an
12120 -- implicit pragma Pack, but not an explicit one.
12122 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12123 Set_Is_Packed
(Base_Type
(Typ
), False);
12124 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12127 end Component_AlignmentP
;
12129 --------------------
12130 -- Contract_Cases --
12131 --------------------
12133 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12135 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12137 -- CASE_GUARD ::= boolean_EXPRESSION | others
12139 -- CONSEQUENCE ::= boolean_EXPRESSION
12141 -- Characteristics:
12143 -- * Analysis - The annotation undergoes initial checks to verify
12144 -- the legal placement and context. Secondary checks preanalyze the
12147 -- Analyze_Contract_Cases_In_Decl_Part
12149 -- * Expansion - The annotation is expanded during the expansion of
12150 -- the related subprogram [body] contract as performed in:
12152 -- Expand_Subprogram_Contract
12154 -- * Template - The annotation utilizes the generic template of the
12155 -- related subprogram [body] when it is:
12157 -- aspect on subprogram declaration
12158 -- aspect on stand alone subprogram body
12159 -- pragma on stand alone subprogram body
12161 -- The annotation must prepare its own template when it is:
12163 -- pragma on subprogram declaration
12165 -- * Globals - Capture of global references must occur after full
12168 -- * Instance - The annotation is instantiated automatically when
12169 -- the related generic subprogram [body] is instantiated except for
12170 -- the "pragma on subprogram declaration" case. In that scenario
12171 -- the annotation must instantiate itself.
12173 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12174 Spec_Id
: Entity_Id
;
12175 Subp_Decl
: Node_Id
;
12179 Check_No_Identifiers
;
12180 Check_Arg_Count
(1);
12182 -- The pragma is analyzed at the end of the declarative part which
12183 -- contains the related subprogram. Reset the analyzed flag.
12185 Set_Analyzed
(N
, False);
12187 -- Ensure the proper placement of the pragma. Contract_Cases must
12188 -- be associated with a subprogram declaration or a body that acts
12192 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12194 -- Generic subprogram
12196 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
12199 -- Body acts as spec
12201 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12202 and then No
(Corresponding_Spec
(Subp_Decl
))
12206 -- Body stub acts as spec
12208 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12209 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12215 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12223 Spec_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
12225 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
12227 -- Fully analyze the pragma when it appears inside a subprogram
12228 -- body because it cannot benefit from forward references.
12230 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12231 Analyze_Contract_Cases_In_Decl_Part
(N
);
12234 -- Chain the pragma on the contract for further processing by
12235 -- Analyze_Contract_Cases_In_Decl_Part.
12237 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
12238 end Contract_Cases
;
12244 -- pragma Controlled (first_subtype_LOCAL_NAME);
12246 when Pragma_Controlled
=> Controlled
: declare
12250 Check_No_Identifiers
;
12251 Check_Arg_Count
(1);
12252 Check_Arg_Is_Local_Name
(Arg1
);
12253 Arg
:= Get_Pragma_Arg
(Arg1
);
12255 if not Is_Entity_Name
(Arg
)
12256 or else not Is_Access_Type
(Entity
(Arg
))
12258 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12260 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12268 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12269 -- [Entity =>] LOCAL_NAME);
12271 when Pragma_Convention
=> Convention
: declare
12274 pragma Warnings
(Off
, C
);
12275 pragma Warnings
(Off
, E
);
12277 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12278 Check_Ada_83_Warning
;
12279 Check_Arg_Count
(2);
12280 Process_Convention
(C
, E
);
12283 ---------------------------
12284 -- Convention_Identifier --
12285 ---------------------------
12287 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12288 -- [Convention =>] convention_IDENTIFIER);
12290 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12296 Check_Arg_Order
((Name_Name
, Name_Convention
));
12297 Check_Arg_Count
(2);
12298 Check_Optional_Identifier
(Arg1
, Name_Name
);
12299 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12300 Check_Arg_Is_Identifier
(Arg1
);
12301 Check_Arg_Is_Identifier
(Arg2
);
12302 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12303 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12305 if Is_Convention_Name
(Cname
) then
12306 Record_Convention_Identifier
12307 (Idnam
, Get_Convention_Id
(Cname
));
12310 ("second arg for % pragma must be convention", Arg2
);
12312 end Convention_Identifier
;
12318 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12320 when Pragma_CPP_Class
=> CPP_Class
: declare
12324 if Warn_On_Obsolescent_Feature
then
12326 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12327 & "effect; replace it by pragma import?j?", N
);
12330 Check_Arg_Count
(1);
12334 Chars
=> Name_Import
,
12335 Pragma_Argument_Associations
=> New_List
(
12336 Make_Pragma_Argument_Association
(Loc
,
12337 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12338 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12342 ---------------------
12343 -- CPP_Constructor --
12344 ---------------------
12346 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12347 -- [, [External_Name =>] static_string_EXPRESSION ]
12348 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12350 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12353 Def_Id
: Entity_Id
;
12354 Tag_Typ
: Entity_Id
;
12358 Check_At_Least_N_Arguments
(1);
12359 Check_At_Most_N_Arguments
(3);
12360 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12361 Check_Arg_Is_Local_Name
(Arg1
);
12363 Id
:= Get_Pragma_Arg
(Arg1
);
12364 Find_Program_Unit_Name
(Id
);
12366 -- If we did not find the name, we are done
12368 if Etype
(Id
) = Any_Type
then
12372 Def_Id
:= Entity
(Id
);
12374 -- Check if already defined as constructor
12376 if Is_Constructor
(Def_Id
) then
12378 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12382 if Ekind
(Def_Id
) = E_Function
12383 and then (Is_CPP_Class
(Etype
(Def_Id
))
12384 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12386 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12388 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12390 ("'C'P'P constructor must be defined in the scope of "
12391 & "its returned type", Arg1
);
12394 if Arg_Count
>= 2 then
12395 Set_Imported
(Def_Id
);
12396 Set_Is_Public
(Def_Id
);
12397 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12400 Set_Has_Completion
(Def_Id
);
12401 Set_Is_Constructor
(Def_Id
);
12402 Set_Convention
(Def_Id
, Convention_CPP
);
12404 -- Imported C++ constructors are not dispatching primitives
12405 -- because in C++ they don't have a dispatch table slot.
12406 -- However, in Ada the constructor has the profile of a
12407 -- function that returns a tagged type and therefore it has
12408 -- been treated as a primitive operation during semantic
12409 -- analysis. We now remove it from the list of primitive
12410 -- operations of the type.
12412 if Is_Tagged_Type
(Etype
(Def_Id
))
12413 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12414 and then Is_Dispatching_Operation
(Def_Id
)
12416 Tag_Typ
:= Etype
(Def_Id
);
12418 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12419 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12423 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12424 Set_Is_Dispatching_Operation
(Def_Id
, False);
12427 -- For backward compatibility, if the constructor returns a
12428 -- class wide type, and we internally change the return type to
12429 -- the corresponding root type.
12431 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12432 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12436 ("pragma% requires function returning a 'C'P'P_Class type",
12439 end CPP_Constructor
;
12445 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12449 if Warn_On_Obsolescent_Feature
then
12451 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12460 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12464 if Warn_On_Obsolescent_Feature
then
12466 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12475 -- pragma CPU (EXPRESSION);
12477 when Pragma_CPU
=> CPU
: declare
12478 P
: constant Node_Id
:= Parent
(N
);
12484 Check_No_Identifiers
;
12485 Check_Arg_Count
(1);
12489 if Nkind
(P
) = N_Subprogram_Body
then
12490 Check_In_Main_Program
;
12492 Arg
:= Get_Pragma_Arg
(Arg1
);
12493 Analyze_And_Resolve
(Arg
, Any_Integer
);
12495 Ent
:= Defining_Unit_Name
(Specification
(P
));
12497 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12498 Ent
:= Defining_Identifier
(Ent
);
12503 if not Is_OK_Static_Expression
(Arg
) then
12504 Flag_Non_Static_Expr
12505 ("main subprogram affinity is not static!", Arg
);
12508 -- If constraint error, then we already signalled an error
12510 elsif Raises_Constraint_Error
(Arg
) then
12513 -- Otherwise check in range
12517 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12518 -- This is the entity System.Multiprocessors.CPU_Range;
12520 Val
: constant Uint
:= Expr_Value
(Arg
);
12523 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12525 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12528 ("main subprogram CPU is out of range", Arg1
);
12534 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12538 elsif Nkind
(P
) = N_Task_Definition
then
12539 Arg
:= Get_Pragma_Arg
(Arg1
);
12540 Ent
:= Defining_Identifier
(Parent
(P
));
12542 -- The expression must be analyzed in the special manner
12543 -- described in "Handling of Default and Per-Object
12544 -- Expressions" in sem.ads.
12546 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12548 -- Anything else is incorrect
12554 -- Check duplicate pragma before we chain the pragma in the Rep
12555 -- Item chain of Ent.
12557 Check_Duplicate_Pragma
(Ent
);
12558 Record_Rep_Item
(Ent
, N
);
12565 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12567 when Pragma_Debug
=> Debug
: declare
12574 -- The condition for executing the call is that the expander
12575 -- is active and that we are not ignoring this debug pragma.
12580 (Expander_Active
and then not Is_Ignored
(N
)),
12583 if not Is_Ignored
(N
) then
12584 Set_SCO_Pragma_Enabled
(Loc
);
12587 if Arg_Count
= 2 then
12589 Make_And_Then
(Loc
,
12590 Left_Opnd
=> Relocate_Node
(Cond
),
12591 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12592 Call
:= Get_Pragma_Arg
(Arg2
);
12594 Call
:= Get_Pragma_Arg
(Arg1
);
12598 N_Indexed_Component
,
12602 N_Selected_Component
)
12604 -- If this pragma Debug comes from source, its argument was
12605 -- parsed as a name form (which is syntactically identical).
12606 -- In a generic context a parameterless call will be left as
12607 -- an expanded name (if global) or selected_component if local.
12608 -- Change it to a procedure call statement now.
12610 Change_Name_To_Procedure_Call_Statement
(Call
);
12612 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12614 -- Already in the form of a procedure call statement: nothing
12615 -- to do (could happen in case of an internally generated
12621 -- All other cases: diagnose error
12624 ("argument of pragma ""Debug"" is not procedure call",
12629 -- Rewrite into a conditional with an appropriate condition. We
12630 -- wrap the procedure call in a block so that overhead from e.g.
12631 -- use of the secondary stack does not generate execution overhead
12632 -- for suppressed conditions.
12634 -- Normally the analysis that follows will freeze the subprogram
12635 -- being called. However, if the call is to a null procedure,
12636 -- we want to freeze it before creating the block, because the
12637 -- analysis that follows may be done with expansion disabled, in
12638 -- which case the body will not be generated, leading to spurious
12641 if Nkind
(Call
) = N_Procedure_Call_Statement
12642 and then Is_Entity_Name
(Name
(Call
))
12644 Analyze
(Name
(Call
));
12645 Freeze_Before
(N
, Entity
(Name
(Call
)));
12649 Make_Implicit_If_Statement
(N
,
12651 Then_Statements
=> New_List
(
12652 Make_Block_Statement
(Loc
,
12653 Handled_Statement_Sequence
=>
12654 Make_Handled_Sequence_Of_Statements
(Loc
,
12655 Statements
=> New_List
(Relocate_Node
(Call
)))))));
12658 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12659 -- after analysis of the normally rewritten node, to capture all
12660 -- references to entities, which avoids issuing wrong warnings
12661 -- about unused entities.
12663 if GNATprove_Mode
then
12664 Rewrite
(N
, Make_Null_Statement
(Loc
));
12672 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12674 when Pragma_Debug_Policy
=>
12676 Check_Arg_Count
(1);
12677 Check_No_Identifiers
;
12678 Check_Arg_Is_Identifier
(Arg1
);
12680 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12681 -- rewrite it that way, and let the rest of the checking come
12682 -- from analyzing the rewritten pragma.
12686 Chars
=> Name_Check_Policy
,
12687 Pragma_Argument_Associations
=> New_List
(
12688 Make_Pragma_Argument_Association
(Loc
,
12689 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
12691 Make_Pragma_Argument_Association
(Loc
,
12692 Expression
=> Get_Pragma_Arg
(Arg1
)))));
12695 -------------------------------
12696 -- Default_Initial_Condition --
12697 -------------------------------
12699 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
12701 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
12708 Check_No_Identifiers
;
12709 Check_At_Most_N_Arguments
(1);
12712 while Present
(Stmt
) loop
12714 -- Skip prior pragmas, but check for duplicates
12716 if Nkind
(Stmt
) = N_Pragma
then
12717 if Pragma_Name
(Stmt
) = Pname
then
12718 Error_Msg_Name_1
:= Pname
;
12719 Error_Msg_Sloc
:= Sloc
(Stmt
);
12720 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
12723 -- Skip internally generated code
12725 elsif not Comes_From_Source
(Stmt
) then
12728 -- The associated private type [extension] has been found, stop
12731 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
12732 N_Private_Type_Declaration
)
12734 Typ
:= Defining_Entity
(Stmt
);
12737 -- The pragma does not apply to a legal construct, issue an
12738 -- error and stop the analysis.
12745 Stmt
:= Prev
(Stmt
);
12748 Set_Has_Default_Init_Cond
(Typ
);
12749 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
12751 -- Chain the pragma on the rep item chain for further processing
12753 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
12754 end Default_Init_Cond
;
12756 ----------------------------------
12757 -- Default_Scalar_Storage_Order --
12758 ----------------------------------
12760 -- pragma Default_Scalar_Storage_Order
12761 -- (High_Order_First | Low_Order_First);
12763 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
12764 Default
: Character;
12768 Check_Arg_Count
(1);
12770 -- Default_Scalar_Storage_Order can appear as a configuration
12771 -- pragma, or in a declarative part of a package spec.
12773 if not Is_Configuration_Pragma
then
12774 Check_Is_In_Decl_Part_Or_Package_Spec
;
12777 Check_No_Identifiers
;
12778 Check_Arg_Is_One_Of
12779 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
12780 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12781 Default
:= Fold_Upper
(Name_Buffer
(1));
12783 if not Support_Nondefault_SSO_On_Target
12784 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
12786 if Warn_On_Unrecognized_Pragma
then
12788 ("non-default Scalar_Storage_Order not supported "
12789 & "on target?g?", N
);
12791 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
12794 -- Here set the specified default
12797 Opt
.Default_SSO
:= Default
;
12801 --------------------------
12802 -- Default_Storage_Pool --
12803 --------------------------
12805 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
12807 when Pragma_Default_Storage_Pool
=>
12809 Check_Arg_Count
(1);
12811 -- Default_Storage_Pool can appear as a configuration pragma, or
12812 -- in a declarative part of a package spec.
12814 if not Is_Configuration_Pragma
then
12815 Check_Is_In_Decl_Part_Or_Package_Spec
;
12818 -- Case of Default_Storage_Pool (null);
12820 if Nkind
(Expression
(Arg1
)) = N_Null
then
12821 Analyze
(Expression
(Arg1
));
12823 -- This is an odd case, this is not really an expression, so
12824 -- we don't have a type for it. So just set the type to Empty.
12826 Set_Etype
(Expression
(Arg1
), Empty
);
12828 -- Case of Default_Storage_Pool (storage_pool_NAME);
12831 -- If it's a configuration pragma, then the only allowed
12832 -- argument is "null".
12834 if Is_Configuration_Pragma
then
12835 Error_Pragma_Arg
("NULL expected", Arg1
);
12838 -- The expected type for a non-"null" argument is
12839 -- Root_Storage_Pool'Class, and the pool must be a variable.
12841 Analyze_And_Resolve
12842 (Get_Pragma_Arg
(Arg1
),
12843 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
12845 if not Is_Variable
(Expression
(Arg1
)) then
12847 ("default storage pool must be a variable", Arg1
);
12851 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
12852 -- for an access type will use this information to set the
12853 -- appropriate attributes of the access type.
12855 Default_Pool
:= Expression
(Arg1
);
12861 -- pragma Depends (DEPENDENCY_RELATION);
12863 -- DEPENDENCY_RELATION ::=
12865 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
12867 -- DEPENDENCY_CLAUSE ::=
12868 -- OUTPUT_LIST =>[+] INPUT_LIST
12869 -- | NULL_DEPENDENCY_CLAUSE
12871 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
12873 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
12875 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
12877 -- OUTPUT ::= NAME | FUNCTION_RESULT
12880 -- where FUNCTION_RESULT is a function Result attribute_reference
12882 -- Characteristics:
12884 -- * Analysis - The annotation undergoes initial checks to verify
12885 -- the legal placement and context. Secondary checks fully analyze
12886 -- the dependency clauses in:
12888 -- Analyze_Depends_In_Decl_Part
12890 -- * Expansion - None.
12892 -- * Template - The annotation utilizes the generic template of the
12893 -- related subprogram [body] when it is:
12895 -- aspect on subprogram declaration
12896 -- aspect on stand alone subprogram body
12897 -- pragma on stand alone subprogram body
12899 -- The annotation must prepare its own template when it is:
12901 -- pragma on subprogram declaration
12903 -- * Globals - Capture of global references must occur after full
12906 -- * Instance - The annotation is instantiated automatically when
12907 -- the related generic subprogram [body] is instantiated except for
12908 -- the "pragma on subprogram declaration" case. In that scenario
12909 -- the annotation must instantiate itself.
12911 when Pragma_Depends
=>
12912 Analyze_Depends_Global
;
12914 ---------------------
12915 -- Detect_Blocking --
12916 ---------------------
12918 -- pragma Detect_Blocking;
12920 when Pragma_Detect_Blocking
=>
12922 Check_Arg_Count
(0);
12923 Check_Valid_Configuration_Pragma
;
12924 Detect_Blocking
:= True;
12926 ------------------------------------
12927 -- Disable_Atomic_Synchronization --
12928 ------------------------------------
12930 -- pragma Disable_Atomic_Synchronization [(Entity)];
12932 when Pragma_Disable_Atomic_Synchronization
=>
12934 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
12936 -------------------
12937 -- Discard_Names --
12938 -------------------
12940 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
12942 when Pragma_Discard_Names
=> Discard_Names
: declare
12947 Check_Ada_83_Warning
;
12949 -- Deal with configuration pragma case
12951 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
12952 Global_Discard_Names
:= True;
12955 -- Otherwise, check correct appropriate context
12958 Check_Is_In_Decl_Part_Or_Package_Spec
;
12960 if Arg_Count
= 0 then
12962 -- If there is no parameter, then from now on this pragma
12963 -- applies to any enumeration, exception or tagged type
12964 -- defined in the current declarative part, and recursively
12965 -- to any nested scope.
12967 Set_Discard_Names
(Current_Scope
);
12971 Check_Arg_Count
(1);
12972 Check_Optional_Identifier
(Arg1
, Name_On
);
12973 Check_Arg_Is_Local_Name
(Arg1
);
12975 E_Id
:= Get_Pragma_Arg
(Arg1
);
12977 if Etype
(E_Id
) = Any_Type
then
12980 E
:= Entity
(E_Id
);
12983 if (Is_First_Subtype
(E
)
12985 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
12986 or else Ekind
(E
) = E_Exception
12988 Set_Discard_Names
(E
);
12989 Record_Rep_Item
(E
, N
);
12993 ("inappropriate entity for pragma%", Arg1
);
13000 ------------------------
13001 -- Dispatching_Domain --
13002 ------------------------
13004 -- pragma Dispatching_Domain (EXPRESSION);
13006 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13007 P
: constant Node_Id
:= Parent
(N
);
13013 Check_No_Identifiers
;
13014 Check_Arg_Count
(1);
13016 -- This pragma is born obsolete, but not the aspect
13018 if not From_Aspect_Specification
(N
) then
13020 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13023 if Nkind
(P
) = N_Task_Definition
then
13024 Arg
:= Get_Pragma_Arg
(Arg1
);
13025 Ent
:= Defining_Identifier
(Parent
(P
));
13027 -- The expression must be analyzed in the special manner
13028 -- described in "Handling of Default and Per-Object
13029 -- Expressions" in sem.ads.
13031 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13033 -- Check duplicate pragma before we chain the pragma in the Rep
13034 -- Item chain of Ent.
13036 Check_Duplicate_Pragma
(Ent
);
13037 Record_Rep_Item
(Ent
, N
);
13039 -- Anything else is incorrect
13044 end Dispatching_Domain
;
13050 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13052 when Pragma_Elaborate
=> Elaborate
: declare
13057 -- Pragma must be in context items list of a compilation unit
13059 if not Is_In_Context_Clause
then
13063 -- Must be at least one argument
13065 if Arg_Count
= 0 then
13066 Error_Pragma
("pragma% requires at least one argument");
13069 -- In Ada 83 mode, there can be no items following it in the
13070 -- context list except other pragmas and implicit with clauses
13071 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13072 -- placement rule does not apply.
13074 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13076 while Present
(Citem
) loop
13077 if Nkind
(Citem
) = N_Pragma
13078 or else (Nkind
(Citem
) = N_With_Clause
13079 and then Implicit_With
(Citem
))
13084 ("(Ada 83) pragma% must be at end of context clause");
13091 -- Finally, the arguments must all be units mentioned in a with
13092 -- clause in the same context clause. Note we already checked (in
13093 -- Par.Prag) that the arguments are all identifiers or selected
13097 Outer
: while Present
(Arg
) loop
13098 Citem
:= First
(List_Containing
(N
));
13099 Inner
: while Citem
/= N
loop
13100 if Nkind
(Citem
) = N_With_Clause
13101 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13103 Set_Elaborate_Present
(Citem
, True);
13104 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13106 -- With the pragma present, elaboration calls on
13107 -- subprograms from the named unit need no further
13108 -- checks, as long as the pragma appears in the current
13109 -- compilation unit. If the pragma appears in some unit
13110 -- in the context, there might still be a need for an
13111 -- Elaborate_All_Desirable from the current compilation
13112 -- to the named unit, so we keep the check enabled.
13114 if In_Extended_Main_Source_Unit
(N
) then
13116 -- This does not apply in SPARK mode, where we allow
13117 -- pragma Elaborate, but we don't trust it to be right
13118 -- so we will still insist on the Elaborate_All.
13120 if SPARK_Mode
/= On
then
13121 Set_Suppress_Elaboration_Warnings
13122 (Entity
(Name
(Citem
)));
13134 ("argument of pragma% is not withed unit", Arg
);
13140 -- Give a warning if operating in static mode with one of the
13141 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
13144 and not Dynamic_Elaboration_Checks
13146 -- pragma Elaborate not allowed in SPARK mode anyway. We
13147 -- already complained about it, no point in generating any
13148 -- further complaint.
13150 and SPARK_Mode
/= On
13153 ("?l?use of pragma Elaborate may not be safe", N
);
13155 ("?l?use pragma Elaborate_All instead if possible", N
);
13159 -------------------
13160 -- Elaborate_All --
13161 -------------------
13163 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
13165 when Pragma_Elaborate_All
=> Elaborate_All
: declare
13170 Check_Ada_83_Warning
;
13172 -- Pragma must be in context items list of a compilation unit
13174 if not Is_In_Context_Clause
then
13178 -- Must be at least one argument
13180 if Arg_Count
= 0 then
13181 Error_Pragma
("pragma% requires at least one argument");
13184 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
13185 -- have to appear at the end of the context clause, but may
13186 -- appear mixed in with other items, even in Ada 83 mode.
13188 -- Final check: the arguments must all be units mentioned in
13189 -- a with clause in the same context clause. Note that we
13190 -- already checked (in Par.Prag) that all the arguments are
13191 -- either identifiers or selected components.
13194 Outr
: while Present
(Arg
) loop
13195 Citem
:= First
(List_Containing
(N
));
13196 Innr
: while Citem
/= N
loop
13197 if Nkind
(Citem
) = N_With_Clause
13198 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13200 Set_Elaborate_All_Present
(Citem
, True);
13201 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13203 -- Suppress warnings and elaboration checks on the named
13204 -- unit if the pragma is in the current compilation, as
13205 -- for pragma Elaborate.
13207 if In_Extended_Main_Source_Unit
(N
) then
13208 Set_Suppress_Elaboration_Warnings
13209 (Entity
(Name
(Citem
)));
13218 Set_Error_Posted
(N
);
13220 ("argument of pragma% is not withed unit", Arg
);
13227 --------------------
13228 -- Elaborate_Body --
13229 --------------------
13231 -- pragma Elaborate_Body [( library_unit_NAME )];
13233 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13234 Cunit_Node
: Node_Id
;
13235 Cunit_Ent
: Entity_Id
;
13238 Check_Ada_83_Warning
;
13239 Check_Valid_Library_Unit_Pragma
;
13241 if Nkind
(N
) = N_Null_Statement
then
13245 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13246 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13248 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13251 Error_Pragma
("pragma% must refer to a spec, not a body");
13253 Set_Body_Required
(Cunit_Node
, True);
13254 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13256 -- If we are in dynamic elaboration mode, then we suppress
13257 -- elaboration warnings for the unit, since it is definitely
13258 -- fine NOT to do dynamic checks at the first level (and such
13259 -- checks will be suppressed because no elaboration boolean
13260 -- is created for Elaborate_Body packages).
13262 -- But in the static model of elaboration, Elaborate_Body is
13263 -- definitely NOT good enough to ensure elaboration safety on
13264 -- its own, since the body may WITH other units that are not
13265 -- safe from an elaboration point of view, so a client must
13266 -- still do an Elaborate_All on such units.
13268 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13269 -- Elaborate_Body always suppressed elab warnings.
13271 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13272 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13275 end Elaborate_Body
;
13277 ------------------------
13278 -- Elaboration_Checks --
13279 ------------------------
13281 -- pragma Elaboration_Checks (Static | Dynamic);
13283 when Pragma_Elaboration_Checks
=>
13285 Check_Arg_Count
(1);
13286 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13288 -- Set flag accordingly (ignore attempt at dynamic elaboration
13289 -- checks in SPARK mode).
13291 Dynamic_Elaboration_Checks
:=
13292 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
)
13293 and then SPARK_Mode
/= On
;
13299 -- pragma Eliminate (
13300 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13301 -- [,[Entity =>] IDENTIFIER |
13302 -- SELECTED_COMPONENT |
13304 -- [, OVERLOADING_RESOLUTION]);
13306 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13309 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13310 -- FUNCTION_PROFILE
13312 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13314 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13315 -- Result_Type => result_SUBTYPE_NAME]
13317 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13318 -- SUBTYPE_NAME ::= STRING_LITERAL
13320 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13321 -- SOURCE_TRACE ::= STRING_LITERAL
13323 when Pragma_Eliminate
=> Eliminate
: declare
13324 Args
: Args_List
(1 .. 5);
13325 Names
: constant Name_List
(1 .. 5) := (
13328 Name_Parameter_Types
,
13330 Name_Source_Location
);
13332 Unit_Name
: Node_Id
renames Args
(1);
13333 Entity
: Node_Id
renames Args
(2);
13334 Parameter_Types
: Node_Id
renames Args
(3);
13335 Result_Type
: Node_Id
renames Args
(4);
13336 Source_Location
: Node_Id
renames Args
(5);
13340 Check_Valid_Configuration_Pragma
;
13341 Gather_Associations
(Names
, Args
);
13343 if No
(Unit_Name
) then
13344 Error_Pragma
("missing Unit_Name argument for pragma%");
13348 and then (Present
(Parameter_Types
)
13350 Present
(Result_Type
)
13352 Present
(Source_Location
))
13354 Error_Pragma
("missing Entity argument for pragma%");
13357 if (Present
(Parameter_Types
)
13359 Present
(Result_Type
))
13361 Present
(Source_Location
)
13364 ("parameter profile and source location cannot be used "
13365 & "together in pragma%");
13368 Process_Eliminate_Pragma
13377 -----------------------------------
13378 -- Enable_Atomic_Synchronization --
13379 -----------------------------------
13381 -- pragma Enable_Atomic_Synchronization [(Entity)];
13383 when Pragma_Enable_Atomic_Synchronization
=>
13385 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13392 -- [ Convention =>] convention_IDENTIFIER,
13393 -- [ Entity =>] LOCAL_NAME
13394 -- [, [External_Name =>] static_string_EXPRESSION ]
13395 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13397 when Pragma_Export
=> Export
: declare
13399 Def_Id
: Entity_Id
;
13401 pragma Warnings
(Off
, C
);
13404 Check_Ada_83_Warning
;
13408 Name_External_Name
,
13411 Check_At_Least_N_Arguments
(2);
13412 Check_At_Most_N_Arguments
(4);
13414 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13415 -- pragma Export (Entity, "external name");
13417 if Relaxed_RM_Semantics
13418 and then Arg_Count
= 2
13419 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13422 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13425 if not Is_Entity_Name
(Def_Id
) then
13426 Error_Pragma_Arg
("entity name required", Arg1
);
13429 Def_Id
:= Entity
(Def_Id
);
13430 Set_Exported
(Def_Id
, Arg1
);
13433 Process_Convention
(C
, Def_Id
);
13435 if Ekind
(Def_Id
) /= E_Constant
then
13436 Note_Possible_Modification
13437 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13440 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13441 Set_Exported
(Def_Id
, Arg2
);
13444 -- If the entity is a deferred constant, propagate the information
13445 -- to the full view, because gigi elaborates the full view only.
13447 if Ekind
(Def_Id
) = E_Constant
13448 and then Present
(Full_View
(Def_Id
))
13451 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13453 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13454 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13455 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13460 ---------------------
13461 -- Export_Function --
13462 ---------------------
13464 -- pragma Export_Function (
13465 -- [Internal =>] LOCAL_NAME
13466 -- [, [External =>] EXTERNAL_SYMBOL]
13467 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13468 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13469 -- [, [Mechanism =>] MECHANISM]
13470 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13472 -- EXTERNAL_SYMBOL ::=
13474 -- | static_string_EXPRESSION
13476 -- PARAMETER_TYPES ::=
13478 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13480 -- TYPE_DESIGNATOR ::=
13482 -- | subtype_Name ' Access
13486 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13488 -- MECHANISM_ASSOCIATION ::=
13489 -- [formal_parameter_NAME =>] MECHANISM_NAME
13491 -- MECHANISM_NAME ::=
13495 when Pragma_Export_Function
=> Export_Function
: declare
13496 Args
: Args_List
(1 .. 6);
13497 Names
: constant Name_List
(1 .. 6) := (
13500 Name_Parameter_Types
,
13503 Name_Result_Mechanism
);
13505 Internal
: Node_Id
renames Args
(1);
13506 External
: Node_Id
renames Args
(2);
13507 Parameter_Types
: Node_Id
renames Args
(3);
13508 Result_Type
: Node_Id
renames Args
(4);
13509 Mechanism
: Node_Id
renames Args
(5);
13510 Result_Mechanism
: Node_Id
renames Args
(6);
13514 Gather_Associations
(Names
, Args
);
13515 Process_Extended_Import_Export_Subprogram_Pragma
(
13516 Arg_Internal
=> Internal
,
13517 Arg_External
=> External
,
13518 Arg_Parameter_Types
=> Parameter_Types
,
13519 Arg_Result_Type
=> Result_Type
,
13520 Arg_Mechanism
=> Mechanism
,
13521 Arg_Result_Mechanism
=> Result_Mechanism
);
13522 end Export_Function
;
13524 -------------------
13525 -- Export_Object --
13526 -------------------
13528 -- pragma Export_Object (
13529 -- [Internal =>] LOCAL_NAME
13530 -- [, [External =>] EXTERNAL_SYMBOL]
13531 -- [, [Size =>] EXTERNAL_SYMBOL]);
13533 -- EXTERNAL_SYMBOL ::=
13535 -- | static_string_EXPRESSION
13537 -- PARAMETER_TYPES ::=
13539 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13541 -- TYPE_DESIGNATOR ::=
13543 -- | subtype_Name ' Access
13547 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13549 -- MECHANISM_ASSOCIATION ::=
13550 -- [formal_parameter_NAME =>] MECHANISM_NAME
13552 -- MECHANISM_NAME ::=
13556 when Pragma_Export_Object
=> Export_Object
: declare
13557 Args
: Args_List
(1 .. 3);
13558 Names
: constant Name_List
(1 .. 3) := (
13563 Internal
: Node_Id
renames Args
(1);
13564 External
: Node_Id
renames Args
(2);
13565 Size
: Node_Id
renames Args
(3);
13569 Gather_Associations
(Names
, Args
);
13570 Process_Extended_Import_Export_Object_Pragma
(
13571 Arg_Internal
=> Internal
,
13572 Arg_External
=> External
,
13576 ----------------------
13577 -- Export_Procedure --
13578 ----------------------
13580 -- pragma Export_Procedure (
13581 -- [Internal =>] LOCAL_NAME
13582 -- [, [External =>] EXTERNAL_SYMBOL]
13583 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13584 -- [, [Mechanism =>] MECHANISM]);
13586 -- EXTERNAL_SYMBOL ::=
13588 -- | static_string_EXPRESSION
13590 -- PARAMETER_TYPES ::=
13592 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13594 -- TYPE_DESIGNATOR ::=
13596 -- | subtype_Name ' Access
13600 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13602 -- MECHANISM_ASSOCIATION ::=
13603 -- [formal_parameter_NAME =>] MECHANISM_NAME
13605 -- MECHANISM_NAME ::=
13609 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13610 Args
: Args_List
(1 .. 4);
13611 Names
: constant Name_List
(1 .. 4) := (
13614 Name_Parameter_Types
,
13617 Internal
: Node_Id
renames Args
(1);
13618 External
: Node_Id
renames Args
(2);
13619 Parameter_Types
: Node_Id
renames Args
(3);
13620 Mechanism
: Node_Id
renames Args
(4);
13624 Gather_Associations
(Names
, Args
);
13625 Process_Extended_Import_Export_Subprogram_Pragma
(
13626 Arg_Internal
=> Internal
,
13627 Arg_External
=> External
,
13628 Arg_Parameter_Types
=> Parameter_Types
,
13629 Arg_Mechanism
=> Mechanism
);
13630 end Export_Procedure
;
13636 -- pragma Export_Value (
13637 -- [Value =>] static_integer_EXPRESSION,
13638 -- [Link_Name =>] static_string_EXPRESSION);
13640 when Pragma_Export_Value
=>
13642 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13643 Check_Arg_Count
(2);
13645 Check_Optional_Identifier
(Arg1
, Name_Value
);
13646 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
13648 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13649 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
13651 -----------------------------
13652 -- Export_Valued_Procedure --
13653 -----------------------------
13655 -- pragma Export_Valued_Procedure (
13656 -- [Internal =>] LOCAL_NAME
13657 -- [, [External =>] EXTERNAL_SYMBOL,]
13658 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13659 -- [, [Mechanism =>] MECHANISM]);
13661 -- EXTERNAL_SYMBOL ::=
13663 -- | static_string_EXPRESSION
13665 -- PARAMETER_TYPES ::=
13667 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13669 -- TYPE_DESIGNATOR ::=
13671 -- | subtype_Name ' Access
13675 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13677 -- MECHANISM_ASSOCIATION ::=
13678 -- [formal_parameter_NAME =>] MECHANISM_NAME
13680 -- MECHANISM_NAME ::=
13684 when Pragma_Export_Valued_Procedure
=>
13685 Export_Valued_Procedure
: declare
13686 Args
: Args_List
(1 .. 4);
13687 Names
: constant Name_List
(1 .. 4) := (
13690 Name_Parameter_Types
,
13693 Internal
: Node_Id
renames Args
(1);
13694 External
: Node_Id
renames Args
(2);
13695 Parameter_Types
: Node_Id
renames Args
(3);
13696 Mechanism
: Node_Id
renames Args
(4);
13700 Gather_Associations
(Names
, Args
);
13701 Process_Extended_Import_Export_Subprogram_Pragma
(
13702 Arg_Internal
=> Internal
,
13703 Arg_External
=> External
,
13704 Arg_Parameter_Types
=> Parameter_Types
,
13705 Arg_Mechanism
=> Mechanism
);
13706 end Export_Valued_Procedure
;
13708 -------------------
13709 -- Extend_System --
13710 -------------------
13712 -- pragma Extend_System ([Name =>] Identifier);
13714 when Pragma_Extend_System
=> Extend_System
: declare
13717 Check_Valid_Configuration_Pragma
;
13718 Check_Arg_Count
(1);
13719 Check_Optional_Identifier
(Arg1
, Name_Name
);
13720 Check_Arg_Is_Identifier
(Arg1
);
13722 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13725 and then Name_Buffer
(1 .. 4) = "aux_"
13727 if Present
(System_Extend_Pragma_Arg
) then
13728 if Chars
(Get_Pragma_Arg
(Arg1
)) =
13729 Chars
(Expression
(System_Extend_Pragma_Arg
))
13733 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
13734 Error_Pragma
("pragma% conflicts with that #");
13738 System_Extend_Pragma_Arg
:= Arg1
;
13740 if not GNAT_Mode
then
13741 System_Extend_Unit
:= Arg1
;
13745 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
13749 ------------------------
13750 -- Extensions_Allowed --
13751 ------------------------
13753 -- pragma Extensions_Allowed (ON | OFF);
13755 when Pragma_Extensions_Allowed
=>
13757 Check_Arg_Count
(1);
13758 Check_No_Identifiers
;
13759 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13761 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13762 Extensions_Allowed
:= True;
13763 Ada_Version
:= Ada_Version_Type
'Last;
13766 Extensions_Allowed
:= False;
13767 Ada_Version
:= Ada_Version_Explicit
;
13768 Ada_Version_Pragma
:= Empty
;
13771 ------------------------
13772 -- Extensions_Visible --
13773 ------------------------
13775 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
13777 -- Characteristics:
13779 -- * Analysis - The annotation is fully analyzed immediately upon
13780 -- elaboration as its expression must be static.
13782 -- * Expansion - None.
13784 -- * Template - The annotation utilizes the generic template of the
13785 -- related subprogram [body] when it is:
13787 -- aspect on subprogram declaration
13788 -- aspect on stand alone subprogram body
13789 -- pragma on stand alone subprogram body
13791 -- The annotation must prepare its own template when it is:
13793 -- pragma on subprogram declaration
13795 -- * Globals - Capture of global references must occur after full
13798 -- * Instance - The annotation is instantiated automatically when
13799 -- the related generic subprogram [body] is instantiated except for
13800 -- the "pragma on subprogram declaration" case. In that scenario
13801 -- the annotation must instantiate itself.
13803 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
13805 Formal
: Entity_Id
;
13806 Has_OK_Formal
: Boolean := False;
13807 Spec_Id
: Entity_Id
;
13808 Subp_Decl
: Node_Id
;
13812 Check_No_Identifiers
;
13813 Check_At_Most_N_Arguments
(1);
13816 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
13818 -- Generic subprogram declaration
13820 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
13823 -- Body acts as spec
13825 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13826 and then No
(Corresponding_Spec
(Subp_Decl
))
13830 -- Body stub acts as spec
13832 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13833 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13837 -- Subprogram declaration
13839 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13842 -- Otherwise the pragma is associated with an illegal construct
13845 Error_Pragma
("pragma % must apply to a subprogram");
13849 Spec_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
13851 -- Examine the formals of the related subprogram
13853 Formal
:= First_Formal
(Spec_Id
);
13854 while Present
(Formal
) loop
13856 -- At least one of the formals is of a specific tagged type,
13857 -- the pragma is legal.
13859 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
13860 Has_OK_Formal
:= True;
13863 -- A generic subprogram with at least one formal of a private
13864 -- type ensures the legality of the pragma because the actual
13865 -- may be specifically tagged. Note that this is verified by
13866 -- the check above at instantiation time.
13868 elsif Is_Private_Type
(Etype
(Formal
))
13869 and then Is_Generic_Type
(Etype
(Formal
))
13871 Has_OK_Formal
:= True;
13875 Next_Formal
(Formal
);
13878 if not Has_OK_Formal
then
13879 Error_Msg_Name_1
:= Pname
;
13880 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
13882 ("\subprogram & lacks parameter of specific tagged or "
13883 & "generic private type", N
, Spec_Id
);
13887 -- Analyze the Boolean expression (if any)
13889 if Present
(Arg1
) then
13890 Expr
:= Expression
(Get_Argument
(N
, Spec_Id
));
13892 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
13894 if not Is_OK_Static_Expression
(Expr
) then
13896 ("expression of pragma % must be static", Expr
);
13901 -- Chain the pragma on the contract for completeness
13903 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13904 end Extensions_Visible
;
13910 -- pragma External (
13911 -- [ Convention =>] convention_IDENTIFIER,
13912 -- [ Entity =>] LOCAL_NAME
13913 -- [, [External_Name =>] static_string_EXPRESSION ]
13914 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13916 when Pragma_External
=> External
: declare
13917 Def_Id
: Entity_Id
;
13920 pragma Warnings
(Off
, C
);
13927 Name_External_Name
,
13929 Check_At_Least_N_Arguments
(2);
13930 Check_At_Most_N_Arguments
(4);
13931 Process_Convention
(C
, Def_Id
);
13932 Note_Possible_Modification
13933 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13934 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13935 Set_Exported
(Def_Id
, Arg2
);
13938 --------------------------
13939 -- External_Name_Casing --
13940 --------------------------
13942 -- pragma External_Name_Casing (
13943 -- UPPERCASE | LOWERCASE
13944 -- [, AS_IS | UPPERCASE | LOWERCASE]);
13946 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
13949 Check_No_Identifiers
;
13951 if Arg_Count
= 2 then
13952 Check_Arg_Is_One_Of
13953 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
13955 case Chars
(Get_Pragma_Arg
(Arg2
)) is
13957 Opt
.External_Name_Exp_Casing
:= As_Is
;
13959 when Name_Uppercase
=>
13960 Opt
.External_Name_Exp_Casing
:= Uppercase
;
13962 when Name_Lowercase
=>
13963 Opt
.External_Name_Exp_Casing
:= Lowercase
;
13970 Check_Arg_Count
(1);
13973 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
13975 case Chars
(Get_Pragma_Arg
(Arg1
)) is
13976 when Name_Uppercase
=>
13977 Opt
.External_Name_Imp_Casing
:= Uppercase
;
13979 when Name_Lowercase
=>
13980 Opt
.External_Name_Imp_Casing
:= Lowercase
;
13985 end External_Name_Casing
;
13991 -- pragma Fast_Math;
13993 when Pragma_Fast_Math
=>
13995 Check_No_Identifiers
;
13996 Check_Valid_Configuration_Pragma
;
13999 --------------------------
14000 -- Favor_Top_Level --
14001 --------------------------
14003 -- pragma Favor_Top_Level (type_NAME);
14005 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
14006 Named_Entity
: Entity_Id
;
14010 Check_No_Identifiers
;
14011 Check_Arg_Count
(1);
14012 Check_Arg_Is_Local_Name
(Arg1
);
14013 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
14015 -- If it's an access-to-subprogram type (in particular, not a
14016 -- subtype), set the flag on that type.
14018 if Is_Access_Subprogram_Type
(Named_Entity
) then
14019 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
14021 -- Otherwise it's an error (name denotes the wrong sort of entity)
14025 ("access-to-subprogram type expected",
14026 Get_Pragma_Arg
(Arg1
));
14028 end Favor_Top_Level
;
14030 ---------------------------
14031 -- Finalize_Storage_Only --
14032 ---------------------------
14034 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14036 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14037 Assoc
: constant Node_Id
:= Arg1
;
14038 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14043 Check_No_Identifiers
;
14044 Check_Arg_Count
(1);
14045 Check_Arg_Is_Local_Name
(Arg1
);
14047 Find_Type
(Type_Id
);
14048 Typ
:= Entity
(Type_Id
);
14051 or else Rep_Item_Too_Early
(Typ
, N
)
14055 Typ
:= Underlying_Type
(Typ
);
14058 if not Is_Controlled
(Typ
) then
14059 Error_Pragma
("pragma% must specify controlled type");
14062 Check_First_Subtype
(Arg1
);
14064 if Finalize_Storage_Only
(Typ
) then
14065 Error_Pragma
("duplicate pragma%, only one allowed");
14067 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14068 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14070 end Finalize_Storage
;
14076 -- pragma Ghost [ (boolean_EXPRESSION) ];
14078 when Pragma_Ghost
=> Ghost
: declare
14082 Orig_Stmt
: Node_Id
;
14083 Prev_Id
: Entity_Id
;
14088 Check_No_Identifiers
;
14089 Check_At_Most_N_Arguments
(1);
14091 Context
:= Parent
(N
);
14093 -- Handle compilation units
14095 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
14096 Context
:= Unit
(Parent
(Context
));
14101 while Present
(Stmt
) loop
14103 -- Skip prior pragmas, but check for duplicates
14105 if Nkind
(Stmt
) = N_Pragma
then
14106 if Pragma_Name
(Stmt
) = Pname
then
14107 Error_Msg_Name_1
:= Pname
;
14108 Error_Msg_Sloc
:= Sloc
(Stmt
);
14109 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
14112 -- Protected and task types cannot be subject to pragma Ghost
14114 elsif Nkind
(Stmt
) = N_Protected_Type_Declaration
then
14115 Error_Pragma
("pragma % cannot apply to a protected type");
14118 elsif Nkind
(Stmt
) = N_Task_Type_Declaration
then
14119 Error_Pragma
("pragma % cannot apply to a task type");
14122 -- Skip internally generated code
14124 elsif not Comes_From_Source
(Stmt
) then
14125 Orig_Stmt
:= Original_Node
(Stmt
);
14127 -- When pragma Ghost applies to an untagged derivation, the
14128 -- derivation is transformed into a [sub]type declaration.
14130 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
14131 N_Subtype_Declaration
)
14132 and then Comes_From_Source
(Orig_Stmt
)
14133 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
14134 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
14135 N_Derived_Type_Definition
14137 Id
:= Defining_Entity
(Stmt
);
14140 -- When pragma Ghost applies to an expression function, the
14141 -- expression function is transformed into a subprogram.
14143 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
14144 and then Comes_From_Source
(Orig_Stmt
)
14145 and then Nkind
(Orig_Stmt
) = N_Expression_Function
14147 Id
:= Defining_Entity
(Stmt
);
14151 -- The pragma applies to a legal construct, stop the traversal
14153 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
14154 N_Full_Type_Declaration
,
14155 N_Generic_Subprogram_Declaration
,
14156 N_Object_Declaration
,
14157 N_Private_Extension_Declaration
,
14158 N_Private_Type_Declaration
,
14159 N_Subprogram_Declaration
,
14160 N_Subtype_Declaration
)
14162 Id
:= Defining_Entity
(Stmt
);
14165 -- The pragma does not apply to a legal construct, issue an
14166 -- error and stop the analysis.
14170 ("pragma % must apply to an object, package, subprogram "
14175 Stmt
:= Prev
(Stmt
);
14180 -- When pragma Ghost is associated with a [generic] package, it
14181 -- appears in the visible declarations.
14183 if Nkind
(Context
) = N_Package_Specification
14184 and then Present
(Visible_Declarations
(Context
))
14185 and then List_Containing
(N
) = Visible_Declarations
(Context
)
14187 Id
:= Defining_Entity
(Context
);
14189 -- Pragma Ghost applies to a stand alone subprogram body
14191 elsif Nkind
(Context
) = N_Subprogram_Body
14192 and then No
(Corresponding_Spec
(Context
))
14194 Id
:= Defining_Entity
(Context
);
14200 ("pragma % must apply to an object, package, subprogram or "
14205 -- A derived type or type extension cannot be subject to pragma
14206 -- Ghost if either the parent type or one of the progenitor types
14207 -- is not Ghost (SPARK RM 6.9(9)).
14209 if Is_Derived_Type
(Id
) then
14210 Check_Ghost_Derivation
(Id
);
14213 -- Handle completions of types and constants that are subject to
14216 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
14217 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
14219 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
14220 Error_Msg_Name_1
:= Pname
;
14222 -- The full declaration of a deferred constant cannot be
14223 -- subject to pragma Ghost unless the deferred declaration
14224 -- is also Ghost (SPARK RM 6.9(10)).
14226 if Ekind
(Prev_Id
) = E_Constant
then
14227 Error_Msg_Name_1
:= Pname
;
14228 Error_Msg_NE
(Fix_Error
14229 ("pragma % must apply to declaration of deferred "
14230 & "constant &"), N
, Id
);
14233 -- Pragma Ghost may appear on the full view of an incomplete
14234 -- type because the incomplete declaration lacks aspects and
14235 -- cannot be subject to pragma Ghost.
14237 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
14240 -- The full declaration of a type cannot be subject to
14241 -- pragma Ghost unless the partial view is also Ghost
14242 -- (SPARK RM 6.9(10)).
14245 Error_Msg_NE
(Fix_Error
14246 ("pragma % must apply to partial view of type &"),
14253 -- Analyze the Boolean expression (if any)
14255 if Present
(Arg1
) then
14256 Expr
:= Get_Pragma_Arg
(Arg1
);
14258 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14260 if Is_OK_Static_Expression
(Expr
) then
14262 -- "Ghostness" cannot be turned off once enabled within a
14263 -- region (SPARK RM 6.9(7)).
14265 if Is_False
(Expr_Value
(Expr
))
14266 and then Ghost_Mode
> None
14269 ("pragma % with value False cannot appear in enabled "
14274 -- Otherwie the expression is not static
14278 ("expression of pragma % must be static", Expr
);
14283 Set_Is_Ghost_Entity
(Id
);
14290 -- pragma Global (GLOBAL_SPECIFICATION);
14292 -- GLOBAL_SPECIFICATION ::=
14295 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14297 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14299 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14300 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14301 -- GLOBAL_ITEM ::= NAME
14303 -- Characteristics:
14305 -- * Analysis - The annotation undergoes initial checks to verify
14306 -- the legal placement and context. Secondary checks fully analyze
14307 -- the dependency clauses in:
14309 -- Analyze_Global_In_Decl_Part
14311 -- * Expansion - None.
14313 -- * Template - The annotation utilizes the generic template of the
14314 -- related subprogram [body] when it is:
14316 -- aspect on subprogram declaration
14317 -- aspect on stand alone subprogram body
14318 -- pragma on stand alone subprogram body
14320 -- The annotation must prepare its own template when it is:
14322 -- pragma on subprogram declaration
14324 -- * Globals - Capture of global references must occur after full
14327 -- * Instance - The annotation is instantiated automatically when
14328 -- the related generic subprogram [body] is instantiated except for
14329 -- the "pragma on subprogram declaration" case. In that scenario
14330 -- the annotation must instantiate itself.
14332 when Pragma_Global
=>
14333 Analyze_Depends_Global
;
14339 -- pragma Ident (static_string_EXPRESSION)
14341 -- Note: pragma Comment shares this processing. Pragma Ident is
14342 -- identical in effect to pragma Commment.
14344 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14349 Check_Arg_Count
(1);
14350 Check_No_Identifiers
;
14351 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
14354 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14361 GP
:= Parent
(Parent
(N
));
14363 if Nkind_In
(GP
, N_Package_Declaration
,
14364 N_Generic_Package_Declaration
)
14369 -- If we have a compilation unit, then record the ident value,
14370 -- checking for improper duplication.
14372 if Nkind
(GP
) = N_Compilation_Unit
then
14373 CS
:= Ident_String
(Current_Sem_Unit
);
14375 if Present
(CS
) then
14377 -- If we have multiple instances, concatenate them, but
14378 -- not in ASIS, where we want the original tree.
14380 if not ASIS_Mode
then
14381 Start_String
(Strval
(CS
));
14382 Store_String_Char
(' ');
14383 Store_String_Chars
(Strval
(Str
));
14384 Set_Strval
(CS
, End_String
);
14388 Set_Ident_String
(Current_Sem_Unit
, Str
);
14391 -- For subunits, we just ignore the Ident, since in GNAT these
14392 -- are not separate object files, and hence not separate units
14393 -- in the unit table.
14395 elsif Nkind
(GP
) = N_Subunit
then
14401 -------------------
14402 -- Ignore_Pragma --
14403 -------------------
14405 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
14407 -- Entirely handled in the parser, nothing to do here
14409 when Pragma_Ignore_Pragma
=>
14412 ----------------------------
14413 -- Implementation_Defined --
14414 ----------------------------
14416 -- pragma Implementation_Defined (LOCAL_NAME);
14418 -- Marks previously declared entity as implementation defined. For
14419 -- an overloaded entity, applies to the most recent homonym.
14421 -- pragma Implementation_Defined;
14423 -- The form with no arguments appears anywhere within a scope, most
14424 -- typically a package spec, and indicates that all entities that are
14425 -- defined within the package spec are Implementation_Defined.
14427 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14432 Check_No_Identifiers
;
14434 -- Form with no arguments
14436 if Arg_Count
= 0 then
14437 Set_Is_Implementation_Defined
(Current_Scope
);
14439 -- Form with one argument
14442 Check_Arg_Count
(1);
14443 Check_Arg_Is_Local_Name
(Arg1
);
14444 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14445 Set_Is_Implementation_Defined
(Ent
);
14447 end Implementation_Defined
;
14453 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14455 -- IMPLEMENTATION_KIND ::=
14456 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14458 -- "By_Any" and "Optional" are treated as synonyms in order to
14459 -- support Ada 2012 aspect Synchronization.
14461 when Pragma_Implemented
=> Implemented
: declare
14462 Proc_Id
: Entity_Id
;
14467 Check_Arg_Count
(2);
14468 Check_No_Identifiers
;
14469 Check_Arg_Is_Identifier
(Arg1
);
14470 Check_Arg_Is_Local_Name
(Arg1
);
14471 Check_Arg_Is_One_Of
(Arg2
,
14474 Name_By_Protected_Procedure
,
14477 -- Extract the name of the local procedure
14479 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14481 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14482 -- primitive procedure of a synchronized tagged type.
14484 if Ekind
(Proc_Id
) = E_Procedure
14485 and then Is_Primitive
(Proc_Id
)
14486 and then Present
(First_Formal
(Proc_Id
))
14488 Typ
:= Etype
(First_Formal
(Proc_Id
));
14490 if Is_Tagged_Type
(Typ
)
14493 -- Check for a protected, a synchronized or a task interface
14495 ((Is_Interface
(Typ
)
14496 and then Is_Synchronized_Interface
(Typ
))
14498 -- Check for a protected type or a task type that implements
14502 (Is_Concurrent_Record_Type
(Typ
)
14503 and then Present
(Interfaces
(Typ
)))
14505 -- In analysis-only mode, examine original protected type
14508 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
14509 and then Present
(Interface_List
(Parent
(Typ
))))
14511 -- Check for a private record extension with keyword
14515 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14516 E_Record_Subtype_With_Private
)
14517 and then Synchronized_Present
(Parent
(Typ
))))
14522 ("controlling formal must be of synchronized tagged type",
14527 -- Procedures declared inside a protected type must be accepted
14529 elsif Ekind
(Proc_Id
) = E_Procedure
14530 and then Is_Protected_Type
(Scope
(Proc_Id
))
14534 -- The first argument is not a primitive procedure
14538 ("pragma % must be applied to a primitive procedure", Arg1
);
14542 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14543 -- By_Protected_Procedure to the primitive procedure of a task
14546 if Chars
(Arg2
) = Name_By_Protected_Procedure
14547 and then Is_Interface
(Typ
)
14548 and then Is_Task_Interface
(Typ
)
14551 ("implementation kind By_Protected_Procedure cannot be "
14552 & "applied to a task interface primitive", Arg2
);
14556 Record_Rep_Item
(Proc_Id
, N
);
14559 ----------------------
14560 -- Implicit_Packing --
14561 ----------------------
14563 -- pragma Implicit_Packing;
14565 when Pragma_Implicit_Packing
=>
14567 Check_Arg_Count
(0);
14568 Implicit_Packing
:= True;
14575 -- [Convention =>] convention_IDENTIFIER,
14576 -- [Entity =>] LOCAL_NAME
14577 -- [, [External_Name =>] static_string_EXPRESSION ]
14578 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14580 when Pragma_Import
=>
14581 Check_Ada_83_Warning
;
14585 Name_External_Name
,
14588 Check_At_Least_N_Arguments
(2);
14589 Check_At_Most_N_Arguments
(4);
14590 Process_Import_Or_Interface
;
14592 ---------------------
14593 -- Import_Function --
14594 ---------------------
14596 -- pragma Import_Function (
14597 -- [Internal =>] LOCAL_NAME,
14598 -- [, [External =>] EXTERNAL_SYMBOL]
14599 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14600 -- [, [Result_Type =>] SUBTYPE_MARK]
14601 -- [, [Mechanism =>] MECHANISM]
14602 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14604 -- EXTERNAL_SYMBOL ::=
14606 -- | static_string_EXPRESSION
14608 -- PARAMETER_TYPES ::=
14610 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14612 -- TYPE_DESIGNATOR ::=
14614 -- | subtype_Name ' Access
14618 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14620 -- MECHANISM_ASSOCIATION ::=
14621 -- [formal_parameter_NAME =>] MECHANISM_NAME
14623 -- MECHANISM_NAME ::=
14627 when Pragma_Import_Function
=> Import_Function
: declare
14628 Args
: Args_List
(1 .. 6);
14629 Names
: constant Name_List
(1 .. 6) := (
14632 Name_Parameter_Types
,
14635 Name_Result_Mechanism
);
14637 Internal
: Node_Id
renames Args
(1);
14638 External
: Node_Id
renames Args
(2);
14639 Parameter_Types
: Node_Id
renames Args
(3);
14640 Result_Type
: Node_Id
renames Args
(4);
14641 Mechanism
: Node_Id
renames Args
(5);
14642 Result_Mechanism
: Node_Id
renames Args
(6);
14646 Gather_Associations
(Names
, Args
);
14647 Process_Extended_Import_Export_Subprogram_Pragma
(
14648 Arg_Internal
=> Internal
,
14649 Arg_External
=> External
,
14650 Arg_Parameter_Types
=> Parameter_Types
,
14651 Arg_Result_Type
=> Result_Type
,
14652 Arg_Mechanism
=> Mechanism
,
14653 Arg_Result_Mechanism
=> Result_Mechanism
);
14654 end Import_Function
;
14656 -------------------
14657 -- Import_Object --
14658 -------------------
14660 -- pragma Import_Object (
14661 -- [Internal =>] LOCAL_NAME
14662 -- [, [External =>] EXTERNAL_SYMBOL]
14663 -- [, [Size =>] EXTERNAL_SYMBOL]);
14665 -- EXTERNAL_SYMBOL ::=
14667 -- | static_string_EXPRESSION
14669 when Pragma_Import_Object
=> Import_Object
: declare
14670 Args
: Args_List
(1 .. 3);
14671 Names
: constant Name_List
(1 .. 3) := (
14676 Internal
: Node_Id
renames Args
(1);
14677 External
: Node_Id
renames Args
(2);
14678 Size
: Node_Id
renames Args
(3);
14682 Gather_Associations
(Names
, Args
);
14683 Process_Extended_Import_Export_Object_Pragma
(
14684 Arg_Internal
=> Internal
,
14685 Arg_External
=> External
,
14689 ----------------------
14690 -- Import_Procedure --
14691 ----------------------
14693 -- pragma Import_Procedure (
14694 -- [Internal =>] LOCAL_NAME
14695 -- [, [External =>] EXTERNAL_SYMBOL]
14696 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14697 -- [, [Mechanism =>] MECHANISM]);
14699 -- EXTERNAL_SYMBOL ::=
14701 -- | static_string_EXPRESSION
14703 -- PARAMETER_TYPES ::=
14705 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14707 -- TYPE_DESIGNATOR ::=
14709 -- | subtype_Name ' Access
14713 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14715 -- MECHANISM_ASSOCIATION ::=
14716 -- [formal_parameter_NAME =>] MECHANISM_NAME
14718 -- MECHANISM_NAME ::=
14722 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14723 Args
: Args_List
(1 .. 4);
14724 Names
: constant Name_List
(1 .. 4) := (
14727 Name_Parameter_Types
,
14730 Internal
: Node_Id
renames Args
(1);
14731 External
: Node_Id
renames Args
(2);
14732 Parameter_Types
: Node_Id
renames Args
(3);
14733 Mechanism
: Node_Id
renames Args
(4);
14737 Gather_Associations
(Names
, Args
);
14738 Process_Extended_Import_Export_Subprogram_Pragma
(
14739 Arg_Internal
=> Internal
,
14740 Arg_External
=> External
,
14741 Arg_Parameter_Types
=> Parameter_Types
,
14742 Arg_Mechanism
=> Mechanism
);
14743 end Import_Procedure
;
14745 -----------------------------
14746 -- Import_Valued_Procedure --
14747 -----------------------------
14749 -- pragma Import_Valued_Procedure (
14750 -- [Internal =>] LOCAL_NAME
14751 -- [, [External =>] EXTERNAL_SYMBOL]
14752 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14753 -- [, [Mechanism =>] MECHANISM]);
14755 -- EXTERNAL_SYMBOL ::=
14757 -- | static_string_EXPRESSION
14759 -- PARAMETER_TYPES ::=
14761 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14763 -- TYPE_DESIGNATOR ::=
14765 -- | subtype_Name ' Access
14769 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14771 -- MECHANISM_ASSOCIATION ::=
14772 -- [formal_parameter_NAME =>] MECHANISM_NAME
14774 -- MECHANISM_NAME ::=
14778 when Pragma_Import_Valued_Procedure
=>
14779 Import_Valued_Procedure
: declare
14780 Args
: Args_List
(1 .. 4);
14781 Names
: constant Name_List
(1 .. 4) := (
14784 Name_Parameter_Types
,
14787 Internal
: Node_Id
renames Args
(1);
14788 External
: Node_Id
renames Args
(2);
14789 Parameter_Types
: Node_Id
renames Args
(3);
14790 Mechanism
: Node_Id
renames Args
(4);
14794 Gather_Associations
(Names
, Args
);
14795 Process_Extended_Import_Export_Subprogram_Pragma
(
14796 Arg_Internal
=> Internal
,
14797 Arg_External
=> External
,
14798 Arg_Parameter_Types
=> Parameter_Types
,
14799 Arg_Mechanism
=> Mechanism
);
14800 end Import_Valued_Procedure
;
14806 -- pragma Independent (LOCAL_NAME);
14808 when Pragma_Independent
=>
14809 Process_Atomic_Independent_Shared_Volatile
;
14811 ----------------------------
14812 -- Independent_Components --
14813 ----------------------------
14815 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
14817 when Pragma_Independent_Components
=> Independent_Components
: declare
14825 Check_Ada_83_Warning
;
14827 Check_No_Identifiers
;
14828 Check_Arg_Count
(1);
14829 Check_Arg_Is_Local_Name
(Arg1
);
14830 E_Id
:= Get_Pragma_Arg
(Arg1
);
14832 if Etype
(E_Id
) = Any_Type
then
14836 E
:= Entity
(E_Id
);
14838 -- Check duplicate before we chain ourselves
14840 Check_Duplicate_Pragma
(E
);
14842 -- Check appropriate entity
14844 if Rep_Item_Too_Early
(E
, N
)
14846 Rep_Item_Too_Late
(E
, N
)
14851 D
:= Declaration_Node
(E
);
14854 -- The flag is set on the base type, or on the object
14856 if K
= N_Full_Type_Declaration
14857 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
14859 Set_Has_Independent_Components
(Base_Type
(E
));
14860 Record_Independence_Check
(N
, Base_Type
(E
));
14862 -- For record type, set all components independent
14864 if Is_Record_Type
(E
) then
14865 C
:= First_Component
(E
);
14866 while Present
(C
) loop
14867 Set_Is_Independent
(C
);
14868 Next_Component
(C
);
14872 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
14873 and then Nkind
(D
) = N_Object_Declaration
14874 and then Nkind
(Object_Definition
(D
)) =
14875 N_Constrained_Array_Definition
14877 Set_Has_Independent_Components
(E
);
14878 Record_Independence_Check
(N
, E
);
14881 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
14883 end Independent_Components
;
14885 -----------------------
14886 -- Initial_Condition --
14887 -----------------------
14889 -- pragma Initial_Condition (boolean_EXPRESSION);
14891 -- Characteristics:
14893 -- * Analysis - The annotation undergoes initial checks to verify
14894 -- the legal placement and context. Secondary checks preanalyze the
14897 -- Analyze_Initial_Condition_In_Decl_Part
14899 -- * Expansion - The annotation is expanded during the expansion of
14900 -- the package body whose declaration is subject to the annotation
14903 -- Expand_Pragma_Initial_Condition
14905 -- * Template - The annotation utilizes the generic template of the
14906 -- related package declaration.
14908 -- * Globals - Capture of global references must occur after full
14911 -- * Instance - The annotation is instantiated automatically when
14912 -- the related generic package is instantiated.
14914 when Pragma_Initial_Condition
=> Initial_Condition
: declare
14915 Pack_Decl
: Node_Id
;
14916 Pack_Id
: Entity_Id
;
14920 Check_No_Identifiers
;
14921 Check_Arg_Count
(1);
14923 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
14925 -- Ensure the proper placement of the pragma. Initial_Condition
14926 -- must be associated with a package declaration.
14928 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
14929 N_Package_Declaration
)
14933 -- Otherwise the pragma is associated with an illegal context
14940 -- The pragma must be analyzed at the end of the visible
14941 -- declarations of the related package. Save the pragma for later
14942 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
14943 -- the contract of the package.
14945 Pack_Id
:= Defining_Entity
(Pack_Decl
);
14947 -- Verify the declaration order of pragma Initial_Condition with
14948 -- respect to pragmas Abstract_State and Initializes when SPARK
14949 -- checks are enabled.
14951 if SPARK_Mode
/= Off
then
14952 Check_Declaration_Order
14953 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
14956 Check_Declaration_Order
14957 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
14961 -- Chain the pragma on the contract for further processing by
14962 -- Analyze_Initial_Condition_In_Decl_Part.
14964 Add_Contract_Item
(N
, Pack_Id
);
14965 end Initial_Condition
;
14967 ------------------------
14968 -- Initialize_Scalars --
14969 ------------------------
14971 -- pragma Initialize_Scalars;
14973 when Pragma_Initialize_Scalars
=>
14975 Check_Arg_Count
(0);
14976 Check_Valid_Configuration_Pragma
;
14977 Check_Restriction
(No_Initialize_Scalars
, N
);
14979 -- Initialize_Scalars creates false positives in CodePeer, and
14980 -- incorrect negative results in GNATprove mode, so ignore this
14981 -- pragma in these modes.
14983 if not Restriction_Active
(No_Initialize_Scalars
)
14984 and then not (CodePeer_Mode
or GNATprove_Mode
)
14986 Init_Or_Norm_Scalars
:= True;
14987 Initialize_Scalars
:= True;
14994 -- pragma Initializes (INITIALIZATION_SPEC);
14996 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
14998 -- INITIALIZATION_LIST ::=
14999 -- INITIALIZATION_ITEM
15000 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15002 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15007 -- | (INPUT {, INPUT})
15011 -- Characteristics:
15013 -- * Analysis - The annotation undergoes initial checks to verify
15014 -- the legal placement and context. Secondary checks preanalyze the
15017 -- Analyze_Initializes_In_Decl_Part
15019 -- * Expansion - None.
15021 -- * Template - The annotation utilizes the generic template of the
15022 -- related package declaration.
15024 -- * Globals - Capture of global references must occur after full
15027 -- * Instance - The annotation is instantiated automatically when
15028 -- the related generic package is instantiated.
15030 when Pragma_Initializes
=> Initializes
: declare
15031 Pack_Decl
: Node_Id
;
15032 Pack_Id
: Entity_Id
;
15036 Check_No_Identifiers
;
15037 Check_Arg_Count
(1);
15039 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
15041 -- Ensure the proper placement of the pragma. Initializes must be
15042 -- associated with a package declaration.
15044 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
15045 N_Package_Declaration
)
15049 -- Otherwise the pragma is associated with an illegal construc
15056 Pack_Id
:= Defining_Entity
(Pack_Decl
);
15058 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
15060 -- Verify the declaration order of pragmas Abstract_State and
15061 -- Initializes when SPARK checks are enabled.
15063 if SPARK_Mode
/= Off
then
15064 Check_Declaration_Order
15065 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
15069 -- Chain the pragma on the contract for further processing by
15070 -- Analyze_Initializes_In_Decl_Part.
15072 Add_Contract_Item
(N
, Pack_Id
);
15079 -- pragma Inline ( NAME {, NAME} );
15081 when Pragma_Inline
=>
15083 -- Pragma always active unless in GNATprove mode. It is disabled
15084 -- in GNATprove mode because frontend inlining is applied
15085 -- independently of pragmas Inline and Inline_Always for
15086 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
15089 if not GNATprove_Mode
then
15091 -- Inline status is Enabled if inlining option is active
15093 if Inline_Active
then
15094 Process_Inline
(Enabled
);
15096 Process_Inline
(Disabled
);
15100 -------------------
15101 -- Inline_Always --
15102 -------------------
15104 -- pragma Inline_Always ( NAME {, NAME} );
15106 when Pragma_Inline_Always
=>
15109 -- Pragma always active unless in CodePeer mode or GNATprove
15110 -- mode. It is disabled in CodePeer mode because inlining is
15111 -- not helpful, and enabling it caused walk order issues. It
15112 -- is disabled in GNATprove mode because frontend inlining is
15113 -- applied independently of pragmas Inline and Inline_Always for
15114 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
15117 if not CodePeer_Mode
and not GNATprove_Mode
then
15118 Process_Inline
(Enabled
);
15121 --------------------
15122 -- Inline_Generic --
15123 --------------------
15125 -- pragma Inline_Generic (NAME {, NAME});
15127 when Pragma_Inline_Generic
=>
15129 Process_Generic_List
;
15131 ----------------------
15132 -- Inspection_Point --
15133 ----------------------
15135 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
15137 when Pragma_Inspection_Point
=> Inspection_Point
: declare
15144 if Arg_Count
> 0 then
15147 Exp
:= Get_Pragma_Arg
(Arg
);
15150 if not Is_Entity_Name
(Exp
)
15151 or else not Is_Object
(Entity
(Exp
))
15153 Error_Pragma_Arg
("object name required", Arg
);
15157 exit when No
(Arg
);
15160 end Inspection_Point
;
15166 -- pragma Interface (
15167 -- [ Convention =>] convention_IDENTIFIER,
15168 -- [ Entity =>] LOCAL_NAME
15169 -- [, [External_Name =>] static_string_EXPRESSION ]
15170 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15172 when Pragma_Interface
=>
15177 Name_External_Name
,
15179 Check_At_Least_N_Arguments
(2);
15180 Check_At_Most_N_Arguments
(4);
15181 Process_Import_Or_Interface
;
15183 -- In Ada 2005, the permission to use Interface (a reserved word)
15184 -- as a pragma name is considered an obsolescent feature, and this
15185 -- pragma was already obsolescent in Ada 95.
15187 if Ada_Version
>= Ada_95
then
15189 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15191 if Warn_On_Obsolescent_Feature
then
15193 ("pragma Interface is an obsolescent feature?j?", N
);
15195 ("|use pragma Import instead?j?", N
);
15199 --------------------
15200 -- Interface_Name --
15201 --------------------
15203 -- pragma Interface_Name (
15204 -- [ Entity =>] LOCAL_NAME
15205 -- [,[External_Name =>] static_string_EXPRESSION ]
15206 -- [,[Link_Name =>] static_string_EXPRESSION ]);
15208 when Pragma_Interface_Name
=> Interface_Name
: declare
15210 Def_Id
: Entity_Id
;
15211 Hom_Id
: Entity_Id
;
15217 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
15218 Check_At_Least_N_Arguments
(2);
15219 Check_At_Most_N_Arguments
(3);
15220 Id
:= Get_Pragma_Arg
(Arg1
);
15223 -- This is obsolete from Ada 95 on, but it is an implementation
15224 -- defined pragma, so we do not consider that it violates the
15225 -- restriction (No_Obsolescent_Features).
15227 if Ada_Version
>= Ada_95
then
15228 if Warn_On_Obsolescent_Feature
then
15230 ("pragma Interface_Name is an obsolescent feature?j?", N
);
15232 ("|use pragma Import instead?j?", N
);
15236 if not Is_Entity_Name
(Id
) then
15238 ("first argument for pragma% must be entity name", Arg1
);
15239 elsif Etype
(Id
) = Any_Type
then
15242 Def_Id
:= Entity
(Id
);
15245 -- Special DEC-compatible processing for the object case, forces
15246 -- object to be imported.
15248 if Ekind
(Def_Id
) = E_Variable
then
15249 Kill_Size_Check_Code
(Def_Id
);
15250 Note_Possible_Modification
(Id
, Sure
=> False);
15252 -- Initialization is not allowed for imported variable
15254 if Present
(Expression
(Parent
(Def_Id
)))
15255 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
15257 Error_Msg_Sloc
:= Sloc
(Def_Id
);
15259 ("no initialization allowed for declaration of& #",
15263 -- For compatibility, support VADS usage of providing both
15264 -- pragmas Interface and Interface_Name to obtain the effect
15265 -- of a single Import pragma.
15267 if Is_Imported
(Def_Id
)
15268 and then Present
(First_Rep_Item
(Def_Id
))
15269 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
15271 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
15275 Set_Imported
(Def_Id
);
15278 Set_Is_Public
(Def_Id
);
15279 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15282 -- Otherwise must be subprogram
15284 elsif not Is_Subprogram
(Def_Id
) then
15286 ("argument of pragma% is not subprogram", Arg1
);
15289 Check_At_Most_N_Arguments
(3);
15293 -- Loop through homonyms
15296 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15298 if Is_Imported
(Def_Id
) then
15299 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15303 exit when From_Aspect_Specification
(N
);
15304 Hom_Id
:= Homonym
(Hom_Id
);
15306 exit when No
(Hom_Id
)
15307 or else Scope
(Hom_Id
) /= Current_Scope
;
15312 ("argument of pragma% is not imported subprogram",
15316 end Interface_Name
;
15318 -----------------------
15319 -- Interrupt_Handler --
15320 -----------------------
15322 -- pragma Interrupt_Handler (handler_NAME);
15324 when Pragma_Interrupt_Handler
=>
15325 Check_Ada_83_Warning
;
15326 Check_Arg_Count
(1);
15327 Check_No_Identifiers
;
15329 if No_Run_Time_Mode
then
15330 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15332 Check_Interrupt_Or_Attach_Handler
;
15333 Process_Interrupt_Or_Attach_Handler
;
15336 ------------------------
15337 -- Interrupt_Priority --
15338 ------------------------
15340 -- pragma Interrupt_Priority [(EXPRESSION)];
15342 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15343 P
: constant Node_Id
:= Parent
(N
);
15348 Check_Ada_83_Warning
;
15350 if Arg_Count
/= 0 then
15351 Arg
:= Get_Pragma_Arg
(Arg1
);
15352 Check_Arg_Count
(1);
15353 Check_No_Identifiers
;
15355 -- The expression must be analyzed in the special manner
15356 -- described in "Handling of Default and Per-Object
15357 -- Expressions" in sem.ads.
15359 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15362 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15367 Ent
:= Defining_Identifier
(Parent
(P
));
15369 -- Check duplicate pragma before we chain the pragma in the Rep
15370 -- Item chain of Ent.
15372 Check_Duplicate_Pragma
(Ent
);
15373 Record_Rep_Item
(Ent
, N
);
15375 end Interrupt_Priority
;
15377 ---------------------
15378 -- Interrupt_State --
15379 ---------------------
15381 -- pragma Interrupt_State (
15382 -- [Name =>] INTERRUPT_ID,
15383 -- [State =>] INTERRUPT_STATE);
15385 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15386 -- INTERRUPT_STATE => System | Runtime | User
15388 -- Note: if the interrupt id is given as an identifier, then it must
15389 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15390 -- given as a static integer expression which must be in the range of
15391 -- Ada.Interrupts.Interrupt_ID.
15393 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15394 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15395 -- This is the entity Ada.Interrupts.Interrupt_ID;
15397 State_Type
: Character;
15398 -- Set to 's'/'r'/'u' for System/Runtime/User
15401 -- Index to entry in Interrupt_States table
15404 -- Value of interrupt
15406 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15407 -- The first argument to the pragma
15409 Int_Ent
: Entity_Id
;
15410 -- Interrupt entity in Ada.Interrupts.Names
15414 Check_Arg_Order
((Name_Name
, Name_State
));
15415 Check_Arg_Count
(2);
15417 Check_Optional_Identifier
(Arg1
, Name_Name
);
15418 Check_Optional_Identifier
(Arg2
, Name_State
);
15419 Check_Arg_Is_Identifier
(Arg2
);
15421 -- First argument is identifier
15423 if Nkind
(Arg1X
) = N_Identifier
then
15425 -- Search list of names in Ada.Interrupts.Names
15427 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15429 if No
(Int_Ent
) then
15430 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15432 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15433 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15437 Next_Entity
(Int_Ent
);
15440 -- First argument is not an identifier, so it must be a static
15441 -- expression of type Ada.Interrupts.Interrupt_ID.
15444 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15445 Int_Val
:= Expr_Value
(Arg1X
);
15447 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15449 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15452 ("value not in range of type "
15453 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15459 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15460 when Name_Runtime
=> State_Type
:= 'r';
15461 when Name_System
=> State_Type
:= 's';
15462 when Name_User
=> State_Type
:= 'u';
15465 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15468 -- Check if entry is already stored
15470 IST_Num
:= Interrupt_States
.First
;
15472 -- If entry not found, add it
15474 if IST_Num
> Interrupt_States
.Last
then
15475 Interrupt_States
.Append
15476 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15477 Interrupt_State
=> State_Type
,
15478 Pragma_Loc
=> Loc
));
15481 -- Case of entry for the same entry
15483 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15486 -- If state matches, done, no need to make redundant entry
15489 State_Type
= Interrupt_States
.Table
(IST_Num
).
15492 -- Otherwise if state does not match, error
15495 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15497 ("state conflicts with that given #", Arg2
);
15501 IST_Num
:= IST_Num
+ 1;
15503 end Interrupt_State
;
15509 -- pragma Invariant
15510 -- ([Entity =>] type_LOCAL_NAME,
15511 -- [Check =>] EXPRESSION
15512 -- [,[Message =>] String_Expression]);
15514 when Pragma_Invariant
=> Invariant
: declare
15521 Check_At_Least_N_Arguments
(2);
15522 Check_At_Most_N_Arguments
(3);
15523 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15524 Check_Optional_Identifier
(Arg2
, Name_Check
);
15526 if Arg_Count
= 3 then
15527 Check_Optional_Identifier
(Arg3
, Name_Message
);
15528 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
15531 Check_Arg_Is_Local_Name
(Arg1
);
15533 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15534 Find_Type
(Type_Id
);
15535 Typ
:= Entity
(Type_Id
);
15537 if Typ
= Any_Type
then
15540 -- Invariants allowed in interface types (RM 7.3.2(3/3))
15542 elsif Is_Interface
(Typ
) then
15545 -- An invariant must apply to a private type, or appear in the
15546 -- private part of a package spec and apply to a completion.
15547 -- a class-wide invariant can only appear on a private declaration
15548 -- or private extension, not a completion.
15550 elsif Ekind_In
(Typ
, E_Private_Type
,
15551 E_Record_Type_With_Private
,
15552 E_Limited_Private_Type
)
15556 elsif In_Private_Part
(Current_Scope
)
15557 and then Has_Private_Declaration
(Typ
)
15558 and then not Class_Present
(N
)
15562 elsif In_Private_Part
(Current_Scope
) then
15564 ("pragma% only allowed for private type declared in "
15565 & "visible part", Arg1
);
15569 ("pragma% only allowed for private type", Arg1
);
15572 -- Not allowed for abstract type in the non-class case (it is
15573 -- allowed to use Invariant'Class for abstract types).
15575 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
15577 ("pragma% not allowed for abstract type", Arg1
);
15580 -- Note that the type has at least one invariant, and also that
15581 -- it has inheritable invariants if we have Invariant'Class
15582 -- or Type_Invariant'Class. Build the corresponding invariant
15583 -- procedure declaration, so that calls to it can be generated
15584 -- before the body is built (e.g. within an expression function).
15586 -- Interface types have no invariant procedure; their invariants
15587 -- are propagated to the build invariant procedure of all the
15588 -- types covering the interface type.
15590 if not Is_Interface
(Typ
) then
15591 Insert_After_And_Analyze
15592 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
15595 if Class_Present
(N
) then
15596 Set_Has_Inheritable_Invariants
(Typ
);
15599 -- The remaining processing is simply to link the pragma on to
15600 -- the rep item chain, for processing when the type is frozen.
15601 -- This is accomplished by a call to Rep_Item_Too_Late.
15603 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15606 ----------------------
15607 -- Java_Constructor --
15608 ----------------------
15610 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15612 -- Also handles pragma CIL_Constructor
15614 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15615 Java_Constructor
: declare
15616 Convention
: Convention_Id
;
15617 Def_Id
: Entity_Id
;
15618 Hom_Id
: Entity_Id
;
15620 This_Formal
: Entity_Id
;
15624 Check_Arg_Count
(1);
15625 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15626 Check_Arg_Is_Local_Name
(Arg1
);
15628 Id
:= Get_Pragma_Arg
(Arg1
);
15629 Find_Program_Unit_Name
(Id
);
15631 -- If we did not find the name, we are done
15633 if Etype
(Id
) = Any_Type
then
15637 -- Check wrong use of pragma in wrong VM target
15639 if VM_Target
= No_VM
then
15642 elsif VM_Target
= CLI_Target
15643 and then Prag_Id
= Pragma_Java_Constructor
15645 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15647 elsif VM_Target
= JVM_Target
15648 and then Prag_Id
= Pragma_CIL_Constructor
15650 Error_Pragma
("must use pragma 'Java_'Constructor");
15654 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15655 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15656 when others => null;
15659 Hom_Id
:= Entity
(Id
);
15661 -- Loop through homonyms
15664 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15666 -- The constructor is required to be a function
15668 if Ekind
(Def_Id
) /= E_Function
then
15669 if VM_Target
= JVM_Target
then
15671 ("pragma% requires function returning a 'Java access "
15675 ("pragma% requires function returning a 'C'I'L access "
15680 -- Check arguments: For tagged type the first formal must be
15681 -- named "this" and its type must be a named access type
15682 -- designating a class-wide tagged type that has convention
15683 -- CIL/Java. The first formal must also have a null default
15684 -- value. For example:
15686 -- type Typ is tagged ...
15687 -- type Ref is access all Typ;
15688 -- pragma Convention (CIL, Typ);
15690 -- function New_Typ (This : Ref) return Ref;
15691 -- function New_Typ (This : Ref; I : Integer) return Ref;
15692 -- pragma Cil_Constructor (New_Typ);
15694 -- Reason: The first formal must NOT be a primitive of the
15697 -- This rule also applies to constructors of delegates used
15698 -- to interface with standard target libraries. For example:
15700 -- type Delegate is access procedure ...
15701 -- pragma Import (CIL, Delegate, ...);
15703 -- function new_Delegate
15704 -- (This : Delegate := null; ... ) return Delegate;
15706 -- For value-types this rule does not apply.
15708 if not Is_Value_Type
(Etype
(Def_Id
)) then
15709 if No
(First_Formal
(Def_Id
)) then
15710 Error_Msg_Name_1
:= Pname
;
15711 Error_Msg_N
("% function must have parameters", Def_Id
);
15715 -- In the JRE library we have several occurrences in which
15716 -- the "this" parameter is not the first formal.
15718 This_Formal
:= First_Formal
(Def_Id
);
15720 -- In the JRE library we have several occurrences in which
15721 -- the "this" parameter is not the first formal. Search for
15724 if VM_Target
= JVM_Target
then
15725 while Present
(This_Formal
)
15726 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15728 Next_Formal
(This_Formal
);
15731 if No
(This_Formal
) then
15732 This_Formal
:= First_Formal
(Def_Id
);
15736 -- Warning: The first parameter should be named "this".
15737 -- We temporarily allow it because we have the following
15738 -- case in the Java runtime (file s-osinte.ads) ???
15740 -- function new_Thread
15741 -- (Self_Id : System.Address) return Thread_Id;
15742 -- pragma Java_Constructor (new_Thread);
15744 if VM_Target
= JVM_Target
15745 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15747 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15751 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15752 Error_Msg_Name_1
:= Pname
;
15754 ("first formal of % function must be named `this`",
15755 Parent
(This_Formal
));
15757 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15758 Error_Msg_Name_1
:= Pname
;
15760 ("first formal of % function must be an access type",
15761 Parameter_Type
(Parent
(This_Formal
)));
15763 -- For delegates the type of the first formal must be a
15764 -- named access-to-subprogram type (see previous example)
15766 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15767 and then Ekind
(Etype
(This_Formal
))
15768 /= E_Access_Subprogram_Type
15770 Error_Msg_Name_1
:= Pname
;
15772 ("first formal of % function must be a named access "
15773 & "to subprogram type",
15774 Parameter_Type
(Parent
(This_Formal
)));
15776 -- Warning: We should reject anonymous access types because
15777 -- the constructor must not be handled as a primitive of the
15778 -- tagged type. We temporarily allow it because this profile
15779 -- is currently generated by cil2ada???
15781 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
15782 and then not Ekind_In
(Etype
(This_Formal
),
15784 E_General_Access_Type
,
15785 E_Anonymous_Access_Type
)
15787 Error_Msg_Name_1
:= Pname
;
15789 ("first formal of % function must be a named access "
15790 & "type", Parameter_Type
(Parent
(This_Formal
)));
15792 elsif Atree
.Convention
15793 (Designated_Type
(Etype
(This_Formal
))) /= Convention
15795 Error_Msg_Name_1
:= Pname
;
15797 if Convention
= Convention_Java
then
15799 ("pragma% requires convention 'Cil in designated "
15800 & "type", Parameter_Type
(Parent
(This_Formal
)));
15803 ("pragma% requires convention 'Java in designated "
15804 & "type", Parameter_Type
(Parent
(This_Formal
)));
15807 elsif No
(Expression
(Parent
(This_Formal
)))
15808 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
15810 Error_Msg_Name_1
:= Pname
;
15812 ("pragma% requires first formal with default `null`",
15813 Parameter_Type
(Parent
(This_Formal
)));
15817 -- Check result type: the constructor must be a function
15819 -- * a value type (only allowed in the CIL compiler)
15820 -- * an access-to-subprogram type with convention Java/CIL
15821 -- * an access-type designating a type that has convention
15824 if Is_Value_Type
(Etype
(Def_Id
)) then
15827 -- Access-to-subprogram type with convention Java/CIL
15829 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
15830 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
15831 if Convention
= Convention_Java
then
15833 ("pragma% requires function returning a 'Java "
15834 & "access type", Arg1
);
15836 pragma Assert
(Convention
= Convention_CIL
);
15838 ("pragma% requires function returning a 'C'I'L "
15839 & "access type", Arg1
);
15843 elsif Is_Access_Type
(Etype
(Def_Id
)) then
15844 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
15845 E_General_Access_Type
)
15848 (Designated_Type
(Etype
(Def_Id
))) /= Convention
15850 Error_Msg_Name_1
:= Pname
;
15852 if Convention
= Convention_Java
then
15854 ("pragma% requires function returning a named "
15855 & "'Java access type", Arg1
);
15858 ("pragma% requires function returning a named "
15859 & "'C'I'L access type", Arg1
);
15864 Set_Is_Constructor
(Def_Id
);
15865 Set_Convention
(Def_Id
, Convention
);
15866 Set_Is_Imported
(Def_Id
);
15868 exit when From_Aspect_Specification
(N
);
15869 Hom_Id
:= Homonym
(Hom_Id
);
15871 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
15873 end Java_Constructor
;
15875 ----------------------
15876 -- Java_Interface --
15877 ----------------------
15879 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
15881 when Pragma_Java_Interface
=> Java_Interface
: declare
15887 Check_Arg_Count
(1);
15888 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15889 Check_Arg_Is_Local_Name
(Arg1
);
15891 Arg
:= Get_Pragma_Arg
(Arg1
);
15894 if Etype
(Arg
) = Any_Type
then
15898 if not Is_Entity_Name
(Arg
)
15899 or else not Is_Type
(Entity
(Arg
))
15901 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
15904 Typ
:= Underlying_Type
(Entity
(Arg
));
15906 -- For now simply check some of the semantic constraints on the
15907 -- type. This currently leaves out some restrictions on interface
15908 -- types, namely that the parent type must be java.lang.Object.Typ
15909 -- and that all primitives of the type should be declared
15912 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
15914 ("pragma% requires an abstract tagged type", Arg1
);
15916 elsif not Has_Discriminants
(Typ
)
15917 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
15918 /= E_Anonymous_Access_Type
15920 not Is_Class_Wide_Type
15921 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
15924 ("type must have a class-wide access discriminant", Arg1
);
15926 end Java_Interface
;
15932 -- pragma Keep_Names ([On => ] LOCAL_NAME);
15934 when Pragma_Keep_Names
=> Keep_Names
: declare
15939 Check_Arg_Count
(1);
15940 Check_Optional_Identifier
(Arg1
, Name_On
);
15941 Check_Arg_Is_Local_Name
(Arg1
);
15943 Arg
:= Get_Pragma_Arg
(Arg1
);
15946 if Etype
(Arg
) = Any_Type
then
15950 if not Is_Entity_Name
(Arg
)
15951 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
15954 ("pragma% requires a local enumeration type", Arg1
);
15957 Set_Discard_Names
(Entity
(Arg
), False);
15964 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
15966 when Pragma_License
=>
15969 -- Do not analyze pragma any further in CodePeer mode, to avoid
15970 -- extraneous errors in this implementation-dependent pragma,
15971 -- which has a different profile on other compilers.
15973 if CodePeer_Mode
then
15977 Check_Arg_Count
(1);
15978 Check_No_Identifiers
;
15979 Check_Valid_Configuration_Pragma
;
15980 Check_Arg_Is_Identifier
(Arg1
);
15983 Sind
: constant Source_File_Index
:=
15984 Source_Index
(Current_Sem_Unit
);
15987 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15989 Set_License
(Sind
, GPL
);
15991 when Name_Modified_GPL
=>
15992 Set_License
(Sind
, Modified_GPL
);
15994 when Name_Restricted
=>
15995 Set_License
(Sind
, Restricted
);
15997 when Name_Unrestricted
=>
15998 Set_License
(Sind
, Unrestricted
);
16001 Error_Pragma_Arg
("invalid license name", Arg1
);
16009 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16011 when Pragma_Link_With
=> Link_With
: declare
16017 if Operating_Mode
= Generate_Code
16018 and then In_Extended_Main_Source_Unit
(N
)
16020 Check_At_Least_N_Arguments
(1);
16021 Check_No_Identifiers
;
16022 Check_Is_In_Decl_Part_Or_Package_Spec
;
16023 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16027 while Present
(Arg
) loop
16028 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16030 -- Store argument, converting sequences of spaces to a
16031 -- single null character (this is one of the differences
16032 -- in processing between Link_With and Linker_Options).
16034 Arg_Store
: declare
16035 C
: constant Char_Code
:= Get_Char_Code
(' ');
16036 S
: constant String_Id
:=
16037 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16038 L
: constant Nat
:= String_Length
(S
);
16041 procedure Skip_Spaces
;
16042 -- Advance F past any spaces
16048 procedure Skip_Spaces
is
16050 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16055 -- Start of processing for Arg_Store
16058 Skip_Spaces
; -- skip leading spaces
16060 -- Loop through characters, changing any embedded
16061 -- sequence of spaces to a single null character (this
16062 -- is how Link_With/Linker_Options differ)
16065 if Get_String_Char
(S
, F
) = C
then
16068 Store_String_Char
(ASCII
.NUL
);
16071 Store_String_Char
(Get_String_Char
(S
, F
));
16079 if Present
(Arg
) then
16080 Store_String_Char
(ASCII
.NUL
);
16084 Store_Linker_Option_String
(End_String
);
16092 -- pragma Linker_Alias (
16093 -- [Entity =>] LOCAL_NAME
16094 -- [Target =>] static_string_EXPRESSION);
16096 when Pragma_Linker_Alias
=>
16098 Check_Arg_Order
((Name_Entity
, Name_Target
));
16099 Check_Arg_Count
(2);
16100 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16101 Check_Optional_Identifier
(Arg2
, Name_Target
);
16102 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16103 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16105 -- The only processing required is to link this item on to the
16106 -- list of rep items for the given entity. This is accomplished
16107 -- by the call to Rep_Item_Too_Late (when no error is detected
16108 -- and False is returned).
16110 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16113 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16116 ------------------------
16117 -- Linker_Constructor --
16118 ------------------------
16120 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16122 -- Code is shared with Linker_Destructor
16124 -----------------------
16125 -- Linker_Destructor --
16126 -----------------------
16128 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16130 when Pragma_Linker_Constructor |
16131 Pragma_Linker_Destructor
=>
16132 Linker_Constructor
: declare
16138 Check_Arg_Count
(1);
16139 Check_No_Identifiers
;
16140 Check_Arg_Is_Local_Name
(Arg1
);
16141 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16143 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16145 if not Is_Library_Level_Entity
(Proc
) then
16147 ("argument for pragma% must be library level entity", Arg1
);
16150 -- The only processing required is to link this item on to the
16151 -- list of rep items for the given entity. This is accomplished
16152 -- by the call to Rep_Item_Too_Late (when no error is detected
16153 -- and False is returned).
16155 if Rep_Item_Too_Late
(Proc
, N
) then
16158 Set_Has_Gigi_Rep_Item
(Proc
);
16160 end Linker_Constructor
;
16162 --------------------
16163 -- Linker_Options --
16164 --------------------
16166 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16168 when Pragma_Linker_Options
=> Linker_Options
: declare
16172 Check_Ada_83_Warning
;
16173 Check_No_Identifiers
;
16174 Check_Arg_Count
(1);
16175 Check_Is_In_Decl_Part_Or_Package_Spec
;
16176 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16177 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16180 while Present
(Arg
) loop
16181 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16182 Store_String_Char
(ASCII
.NUL
);
16184 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16188 if Operating_Mode
= Generate_Code
16189 and then In_Extended_Main_Source_Unit
(N
)
16191 Store_Linker_Option_String
(End_String
);
16193 end Linker_Options
;
16195 --------------------
16196 -- Linker_Section --
16197 --------------------
16199 -- pragma Linker_Section (
16200 -- [Entity =>] LOCAL_NAME
16201 -- [Section =>] static_string_EXPRESSION);
16203 when Pragma_Linker_Section
=> Linker_Section
: declare
16210 Check_Arg_Order
((Name_Entity
, Name_Section
));
16211 Check_Arg_Count
(2);
16212 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16213 Check_Optional_Identifier
(Arg2
, Name_Section
);
16214 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16215 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16217 -- Check kind of entity
16219 Arg
:= Get_Pragma_Arg
(Arg1
);
16220 Ent
:= Entity
(Arg
);
16222 case Ekind
(Ent
) is
16224 -- Objects (constants and variables) and types. For these cases
16225 -- all we need to do is to set the Linker_Section_pragma field,
16226 -- checking that we do not have a duplicate.
16228 when E_Constant | E_Variable | Type_Kind
=>
16229 LPE
:= Linker_Section_Pragma
(Ent
);
16231 if Present
(LPE
) then
16232 Error_Msg_Sloc
:= Sloc
(LPE
);
16234 ("Linker_Section already specified for &#", Arg1
, Ent
);
16237 Set_Linker_Section_Pragma
(Ent
, N
);
16241 when Subprogram_Kind
=>
16243 -- Aspect case, entity already set
16245 if From_Aspect_Specification
(N
) then
16246 Set_Linker_Section_Pragma
16247 (Entity
(Corresponding_Aspect
(N
)), N
);
16249 -- Pragma case, we must climb the homonym chain, but skip
16250 -- any for which the linker section is already set.
16254 if No
(Linker_Section_Pragma
(Ent
)) then
16255 Set_Linker_Section_Pragma
(Ent
, N
);
16258 Ent
:= Homonym
(Ent
);
16260 or else Scope
(Ent
) /= Current_Scope
;
16264 -- All other cases are illegal
16268 ("pragma% applies only to objects, subprograms, and types",
16271 end Linker_Section
;
16277 -- pragma List (On | Off)
16279 -- There is nothing to do here, since we did all the processing for
16280 -- this pragma in Par.Prag (so that it works properly even in syntax
16283 when Pragma_List
=>
16290 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16292 when Pragma_Lock_Free
=> Lock_Free
: declare
16293 P
: constant Node_Id
:= Parent
(N
);
16299 Check_No_Identifiers
;
16300 Check_At_Most_N_Arguments
(1);
16302 -- Protected definition case
16304 if Nkind
(P
) = N_Protected_Definition
then
16305 Ent
:= Defining_Identifier
(Parent
(P
));
16309 if Arg_Count
= 1 then
16310 Arg
:= Get_Pragma_Arg
(Arg1
);
16311 Val
:= Is_True
(Static_Boolean
(Arg
));
16313 -- No arguments (expression is considered to be True)
16319 -- Check duplicate pragma before we chain the pragma in the Rep
16320 -- Item chain of Ent.
16322 Check_Duplicate_Pragma
(Ent
);
16323 Record_Rep_Item
(Ent
, N
);
16324 Set_Uses_Lock_Free
(Ent
, Val
);
16326 -- Anything else is incorrect placement
16333 --------------------
16334 -- Locking_Policy --
16335 --------------------
16337 -- pragma Locking_Policy (policy_IDENTIFIER);
16339 when Pragma_Locking_Policy
=> declare
16340 subtype LP_Range
is Name_Id
16341 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16346 Check_Ada_83_Warning
;
16347 Check_Arg_Count
(1);
16348 Check_No_Identifiers
;
16349 Check_Arg_Is_Locking_Policy
(Arg1
);
16350 Check_Valid_Configuration_Pragma
;
16351 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16354 when Name_Ceiling_Locking
=>
16356 when Name_Inheritance_Locking
=>
16358 when Name_Concurrent_Readers_Locking
=>
16362 if Locking_Policy
/= ' '
16363 and then Locking_Policy
/= LP
16365 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16366 Error_Pragma
("locking policy incompatible with policy#");
16368 -- Set new policy, but always preserve System_Location since we
16369 -- like the error message with the run time name.
16372 Locking_Policy
:= LP
;
16374 if Locking_Policy_Sloc
/= System_Location
then
16375 Locking_Policy_Sloc
:= Loc
;
16380 -------------------
16381 -- Loop_Optimize --
16382 -------------------
16384 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16386 -- OPTIMIZATION_HINT ::=
16387 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16389 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16394 Check_At_Least_N_Arguments
(1);
16395 Check_No_Identifiers
;
16397 Hint
:= First
(Pragma_Argument_Associations
(N
));
16398 while Present
(Hint
) loop
16399 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16407 Check_Loop_Pragma_Placement
;
16414 -- pragma Loop_Variant
16415 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16417 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16419 -- CHANGE_DIRECTION ::= Increases | Decreases
16421 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16426 Check_At_Least_N_Arguments
(1);
16427 Check_Loop_Pragma_Placement
;
16429 -- Process all increasing / decreasing expressions
16431 Variant
:= First
(Pragma_Argument_Associations
(N
));
16432 while Present
(Variant
) loop
16433 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16436 Error_Pragma_Arg
("wrong change modifier", Variant
);
16439 Preanalyze_Assert_Expression
16440 (Expression
(Variant
), Any_Discrete
);
16446 -----------------------
16447 -- Machine_Attribute --
16448 -----------------------
16450 -- pragma Machine_Attribute (
16451 -- [Entity =>] LOCAL_NAME,
16452 -- [Attribute_Name =>] static_string_EXPRESSION
16453 -- [, [Info =>] static_EXPRESSION] );
16455 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16456 Def_Id
: Entity_Id
;
16460 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16462 if Arg_Count
= 3 then
16463 Check_Optional_Identifier
(Arg3
, Name_Info
);
16464 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16466 Check_Arg_Count
(2);
16469 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16470 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16471 Check_Arg_Is_Local_Name
(Arg1
);
16472 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16473 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16475 if Is_Access_Type
(Def_Id
) then
16476 Def_Id
:= Designated_Type
(Def_Id
);
16479 if Rep_Item_Too_Early
(Def_Id
, N
) then
16483 Def_Id
:= Underlying_Type
(Def_Id
);
16485 -- The only processing required is to link this item on to the
16486 -- list of rep items for the given entity. This is accomplished
16487 -- by the call to Rep_Item_Too_Late (when no error is detected
16488 -- and False is returned).
16490 if Rep_Item_Too_Late
(Def_Id
, N
) then
16493 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16495 end Machine_Attribute
;
16502 -- (MAIN_OPTION [, MAIN_OPTION]);
16505 -- [STACK_SIZE =>] static_integer_EXPRESSION
16506 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16507 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16509 when Pragma_Main
=> Main
: declare
16510 Args
: Args_List
(1 .. 3);
16511 Names
: constant Name_List
(1 .. 3) := (
16513 Name_Task_Stack_Size_Default
,
16514 Name_Time_Slicing_Enabled
);
16520 Gather_Associations
(Names
, Args
);
16522 for J
in 1 .. 2 loop
16523 if Present
(Args
(J
)) then
16524 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16528 if Present
(Args
(3)) then
16529 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
16533 while Present
(Nod
) loop
16534 if Nkind
(Nod
) = N_Pragma
16535 and then Pragma_Name
(Nod
) = Name_Main
16537 Error_Msg_Name_1
:= Pname
;
16538 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16549 -- pragma Main_Storage
16550 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16552 -- MAIN_STORAGE_OPTION ::=
16553 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16554 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16556 when Pragma_Main_Storage
=> Main_Storage
: declare
16557 Args
: Args_List
(1 .. 2);
16558 Names
: constant Name_List
(1 .. 2) := (
16559 Name_Working_Storage
,
16566 Gather_Associations
(Names
, Args
);
16568 for J
in 1 .. 2 loop
16569 if Present
(Args
(J
)) then
16570 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16574 Check_In_Main_Program
;
16577 while Present
(Nod
) loop
16578 if Nkind
(Nod
) = N_Pragma
16579 and then Pragma_Name
(Nod
) = Name_Main_Storage
16581 Error_Msg_Name_1
:= Pname
;
16582 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16593 -- pragma Memory_Size (NUMERIC_LITERAL)
16595 when Pragma_Memory_Size
=>
16598 -- Memory size is simply ignored
16600 Check_No_Identifiers
;
16601 Check_Arg_Count
(1);
16602 Check_Arg_Is_Integer_Literal
(Arg1
);
16610 -- The only correct use of this pragma is on its own in a file, in
16611 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16612 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16613 -- check for a file containing nothing but a No_Body pragma). If we
16614 -- attempt to process it during normal semantics processing, it means
16615 -- it was misplaced.
16617 when Pragma_No_Body
=>
16621 -----------------------------
16622 -- No_Elaboration_Code_All --
16623 -----------------------------
16625 -- pragma No_Elaboration_Code_All;
16627 when Pragma_No_Elaboration_Code_All
=> NECA
: declare
16630 Check_Valid_Library_Unit_Pragma
;
16632 if Nkind
(N
) = N_Null_Statement
then
16636 -- Must appear for a spec or generic spec
16638 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
16639 N_Generic_Package_Declaration
,
16640 N_Generic_Subprogram_Declaration
,
16641 N_Package_Declaration
,
16642 N_Subprogram_Declaration
)
16646 ("pragma% can only occur for package "
16647 & "or subprogram spec"));
16650 -- Set flag in unit table
16652 Set_No_Elab_Code_All
(Current_Sem_Unit
);
16654 -- Set restriction No_Elaboration_Code if this is the main unit
16656 if Current_Sem_Unit
= Main_Unit
then
16657 Set_Restriction
(No_Elaboration_Code
, N
);
16660 -- If we are in the main unit or in an extended main source unit,
16661 -- then we also add it to the configuration restrictions so that
16662 -- it will apply to all units in the extended main source.
16664 if Current_Sem_Unit
= Main_Unit
16665 or else In_Extended_Main_Source_Unit
(N
)
16667 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
16670 -- If in main extended unit, activate transitive with test
16672 if In_Extended_Main_Source_Unit
(N
) then
16673 Opt
.No_Elab_Code_All_Pragma
:= N
;
16681 -- pragma No_Inline ( NAME {, NAME} );
16683 when Pragma_No_Inline
=>
16685 Process_Inline
(Suppressed
);
16691 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16693 when Pragma_No_Return
=> No_Return
: declare
16701 Check_At_Least_N_Arguments
(1);
16703 -- Loop through arguments of pragma
16706 while Present
(Arg
) loop
16707 Check_Arg_Is_Local_Name
(Arg
);
16708 Id
:= Get_Pragma_Arg
(Arg
);
16711 if not Is_Entity_Name
(Id
) then
16712 Error_Pragma_Arg
("entity name required", Arg
);
16715 if Etype
(Id
) = Any_Type
then
16719 -- Loop to find matching procedures
16724 and then Scope
(E
) = Current_Scope
16726 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16729 -- Set flag on any alias as well
16731 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16732 Set_No_Return
(Alias
(E
));
16738 exit when From_Aspect_Specification
(N
);
16742 -- If entity in not in current scope it may be the enclosing
16743 -- suprogram body to which the aspect applies.
16746 if Entity
(Id
) = Current_Scope
16747 and then From_Aspect_Specification
(N
)
16749 Set_No_Return
(Entity
(Id
));
16751 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16763 -- pragma No_Run_Time;
16765 -- Note: this pragma is retained for backwards compatibility. See
16766 -- body of Rtsfind for full details on its handling.
16768 when Pragma_No_Run_Time
=>
16770 Check_Valid_Configuration_Pragma
;
16771 Check_Arg_Count
(0);
16773 No_Run_Time_Mode
:= True;
16774 Configurable_Run_Time_Mode
:= True;
16776 -- Set Duration to 32 bits if word size is 32
16778 if Ttypes
.System_Word_Size
= 32 then
16779 Duration_32_Bits_On_Target
:= True;
16782 -- Set appropriate restrictions
16784 Set_Restriction
(No_Finalization
, N
);
16785 Set_Restriction
(No_Exception_Handlers
, N
);
16786 Set_Restriction
(Max_Tasks
, N
, 0);
16787 Set_Restriction
(No_Tasking
, N
);
16789 -----------------------
16790 -- No_Tagged_Streams --
16791 -----------------------
16793 -- pragma No_Tagged_Streams;
16794 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
16796 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
16802 Check_At_Most_N_Arguments
(1);
16804 -- One argument case
16806 if Arg_Count
= 1 then
16807 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16808 Check_Arg_Is_Local_Name
(Arg1
);
16809 E_Id
:= Get_Pragma_Arg
(Arg1
);
16811 if Etype
(E_Id
) = Any_Type
then
16815 E
:= Entity
(E_Id
);
16817 Check_Duplicate_Pragma
(E
);
16819 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
16821 ("argument for pragma% must be root tagged type", Arg1
);
16824 if Rep_Item_Too_Early
(E
, N
)
16826 Rep_Item_Too_Late
(E
, N
)
16830 Set_No_Tagged_Streams_Pragma
(E
, N
);
16833 -- Zero argument case
16836 Check_Is_In_Decl_Part_Or_Package_Spec
;
16837 No_Tagged_Streams
:= N
;
16839 end No_Tagged_Strms
;
16841 ------------------------
16842 -- No_Strict_Aliasing --
16843 ------------------------
16845 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16847 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
16852 Check_At_Most_N_Arguments
(1);
16854 if Arg_Count
= 0 then
16855 Check_Valid_Configuration_Pragma
;
16856 Opt
.No_Strict_Aliasing
:= True;
16859 Check_Optional_Identifier
(Arg2
, Name_Entity
);
16860 Check_Arg_Is_Local_Name
(Arg1
);
16861 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16863 if E_Id
= Any_Type
then
16865 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
16866 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
16869 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
16871 end No_Strict_Aliasing
;
16873 -----------------------
16874 -- Normalize_Scalars --
16875 -----------------------
16877 -- pragma Normalize_Scalars;
16879 when Pragma_Normalize_Scalars
=>
16880 Check_Ada_83_Warning
;
16881 Check_Arg_Count
(0);
16882 Check_Valid_Configuration_Pragma
;
16884 -- Normalize_Scalars creates false positives in CodePeer, and
16885 -- incorrect negative results in GNATprove mode, so ignore this
16886 -- pragma in these modes.
16888 if not (CodePeer_Mode
or GNATprove_Mode
) then
16889 Normalize_Scalars
:= True;
16890 Init_Or_Norm_Scalars
:= True;
16897 -- pragma Obsolescent;
16899 -- pragma Obsolescent (
16900 -- [Message =>] static_string_EXPRESSION
16901 -- [,[Version =>] Ada_05]]);
16903 -- pragma Obsolescent (
16904 -- [Entity =>] NAME
16905 -- [,[Message =>] static_string_EXPRESSION
16906 -- [,[Version =>] Ada_05]] );
16908 when Pragma_Obsolescent
=> Obsolescent
: declare
16912 procedure Set_Obsolescent
(E
: Entity_Id
);
16913 -- Given an entity Ent, mark it as obsolescent if appropriate
16915 ---------------------
16916 -- Set_Obsolescent --
16917 ---------------------
16919 procedure Set_Obsolescent
(E
: Entity_Id
) is
16928 -- Entity name was given
16930 if Present
(Ename
) then
16932 -- If entity name matches, we are fine. Save entity in
16933 -- pragma argument, for ASIS use.
16935 if Chars
(Ename
) = Chars
(Ent
) then
16936 Set_Entity
(Ename
, Ent
);
16937 Generate_Reference
(Ent
, Ename
);
16939 -- If entity name does not match, only possibility is an
16940 -- enumeration literal from an enumeration type declaration.
16942 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
16944 ("pragma % entity name does not match declaration");
16947 Ent
:= First_Literal
(E
);
16951 ("pragma % entity name does not match any "
16952 & "enumeration literal");
16954 elsif Chars
(Ent
) = Chars
(Ename
) then
16955 Set_Entity
(Ename
, Ent
);
16956 Generate_Reference
(Ent
, Ename
);
16960 Ent
:= Next_Literal
(Ent
);
16966 -- Ent points to entity to be marked
16968 if Arg_Count
>= 1 then
16970 -- Deal with static string argument
16972 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16973 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
16975 for J
in 1 .. String_Length
(S
) loop
16976 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
16978 ("pragma% argument does not allow wide characters",
16983 Obsolescent_Warnings
.Append
16984 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
16986 -- Check for Ada_05 parameter
16988 if Arg_Count
/= 1 then
16989 Check_Arg_Count
(2);
16992 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
16995 Check_Arg_Is_Identifier
(Argx
);
16997 if Chars
(Argx
) /= Name_Ada_05
then
16998 Error_Msg_Name_2
:= Name_Ada_05
;
17000 ("only allowed argument for pragma% is %", Argx
);
17003 if Ada_Version_Explicit
< Ada_2005
17004 or else not Warn_On_Ada_2005_Compatibility
17012 -- Set flag if pragma active
17015 Set_Is_Obsolescent
(Ent
);
17019 end Set_Obsolescent
;
17021 -- Start of processing for pragma Obsolescent
17026 Check_At_Most_N_Arguments
(3);
17028 -- See if first argument specifies an entity name
17032 (Chars
(Arg1
) = Name_Entity
17034 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
17036 N_Operator_Symbol
))
17038 Ename
:= Get_Pragma_Arg
(Arg1
);
17040 -- Eliminate first argument, so we can share processing
17044 Arg_Count
:= Arg_Count
- 1;
17046 -- No Entity name argument given
17052 if Arg_Count
>= 1 then
17053 Check_Optional_Identifier
(Arg1
, Name_Message
);
17055 if Arg_Count
= 2 then
17056 Check_Optional_Identifier
(Arg2
, Name_Version
);
17060 -- Get immediately preceding declaration
17063 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17067 -- Cases where we do not follow anything other than another pragma
17071 -- First case: library level compilation unit declaration with
17072 -- the pragma immediately following the declaration.
17074 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17076 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17079 -- Case 2: library unit placement for package
17083 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17085 if Is_Package_Or_Generic_Package
(Ent
) then
17086 Set_Obsolescent
(Ent
);
17092 -- Cases where we must follow a declaration, including an
17093 -- abstract subprogram declaration, which is not in the
17094 -- other node subtypes.
17097 if Nkind
(Decl
) not in N_Declaration
17098 and then Nkind
(Decl
) not in N_Later_Decl_Item
17099 and then Nkind
(Decl
) not in N_Generic_Declaration
17100 and then Nkind
(Decl
) not in N_Renaming_Declaration
17101 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
17104 ("pragma% misplaced, "
17105 & "must immediately follow a declaration");
17108 Set_Obsolescent
(Defining_Entity
(Decl
));
17118 -- pragma Optimize (Time | Space | Off);
17120 -- The actual check for optimize is done in Gigi. Note that this
17121 -- pragma does not actually change the optimization setting, it
17122 -- simply checks that it is consistent with the pragma.
17124 when Pragma_Optimize
=>
17125 Check_No_Identifiers
;
17126 Check_Arg_Count
(1);
17127 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17129 ------------------------
17130 -- Optimize_Alignment --
17131 ------------------------
17133 -- pragma Optimize_Alignment (Time | Space | Off);
17135 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17137 Check_No_Identifiers
;
17138 Check_Arg_Count
(1);
17139 Check_Valid_Configuration_Pragma
;
17142 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17146 Opt
.Optimize_Alignment
:= 'T';
17148 Opt
.Optimize_Alignment
:= 'S';
17150 Opt
.Optimize_Alignment
:= 'O';
17152 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17156 -- Set indication that mode is set locally. If we are in fact in a
17157 -- configuration pragma file, this setting is harmless since the
17158 -- switch will get reset anyway at the start of each unit.
17160 Optimize_Alignment_Local
:= True;
17161 end Optimize_Alignment
;
17167 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17169 when Pragma_Ordered
=> Ordered
: declare
17170 Assoc
: constant Node_Id
:= Arg1
;
17176 Check_No_Identifiers
;
17177 Check_Arg_Count
(1);
17178 Check_Arg_Is_Local_Name
(Arg1
);
17180 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17181 Find_Type
(Type_Id
);
17182 Typ
:= Entity
(Type_Id
);
17184 if Typ
= Any_Type
then
17187 Typ
:= Underlying_Type
(Typ
);
17190 if not Is_Enumeration_Type
(Typ
) then
17191 Error_Pragma
("pragma% must specify enumeration type");
17194 Check_First_Subtype
(Arg1
);
17195 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17198 -------------------
17199 -- Overflow_Mode --
17200 -------------------
17202 -- pragma Overflow_Mode
17203 -- ([General => ] MODE [, [Assertions => ] MODE]);
17205 -- MODE := STRICT | MINIMIZED | ELIMINATED
17207 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17208 -- since System.Bignums makes this assumption. This is true of nearly
17209 -- all (all?) targets.
17211 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17212 function Get_Overflow_Mode
17214 Arg
: Node_Id
) return Overflow_Mode_Type
;
17215 -- Function to process one pragma argument, Arg. If an identifier
17216 -- is present, it must be Name. Mode type is returned if a valid
17217 -- argument exists, otherwise an error is signalled.
17219 -----------------------
17220 -- Get_Overflow_Mode --
17221 -----------------------
17223 function Get_Overflow_Mode
17225 Arg
: Node_Id
) return Overflow_Mode_Type
17227 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
17230 Check_Optional_Identifier
(Arg
, Name
);
17231 Check_Arg_Is_Identifier
(Argx
);
17233 if Chars
(Argx
) = Name_Strict
then
17236 elsif Chars
(Argx
) = Name_Minimized
then
17239 elsif Chars
(Argx
) = Name_Eliminated
then
17240 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
17242 ("Eliminated not implemented on this target", Argx
);
17248 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
17250 end Get_Overflow_Mode
;
17252 -- Start of processing for Overflow_Mode
17256 Check_At_Least_N_Arguments
(1);
17257 Check_At_Most_N_Arguments
(2);
17259 -- Process first argument
17261 Scope_Suppress
.Overflow_Mode_General
:=
17262 Get_Overflow_Mode
(Name_General
, Arg1
);
17264 -- Case of only one argument
17266 if Arg_Count
= 1 then
17267 Scope_Suppress
.Overflow_Mode_Assertions
:=
17268 Scope_Suppress
.Overflow_Mode_General
;
17270 -- Case of two arguments present
17273 Scope_Suppress
.Overflow_Mode_Assertions
:=
17274 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
17278 --------------------------
17279 -- Overriding Renamings --
17280 --------------------------
17282 -- pragma Overriding_Renamings;
17284 when Pragma_Overriding_Renamings
=>
17286 Check_Arg_Count
(0);
17287 Check_Valid_Configuration_Pragma
;
17288 Overriding_Renamings
:= True;
17294 -- pragma Pack (first_subtype_LOCAL_NAME);
17296 when Pragma_Pack
=> Pack
: declare
17297 Assoc
: constant Node_Id
:= Arg1
;
17301 Ignore
: Boolean := False;
17304 Check_No_Identifiers
;
17305 Check_Arg_Count
(1);
17306 Check_Arg_Is_Local_Name
(Arg1
);
17307 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17309 if not Is_Entity_Name
(Type_Id
)
17310 or else not Is_Type
(Entity
(Type_Id
))
17313 ("argument for pragma% must be type or subtype", Arg1
);
17316 Find_Type
(Type_Id
);
17317 Typ
:= Entity
(Type_Id
);
17320 or else Rep_Item_Too_Early
(Typ
, N
)
17324 Typ
:= Underlying_Type
(Typ
);
17327 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17328 Error_Pragma
("pragma% must specify array or record type");
17331 Check_First_Subtype
(Arg1
);
17332 Check_Duplicate_Pragma
(Typ
);
17336 if Is_Array_Type
(Typ
) then
17337 Ctyp
:= Component_Type
(Typ
);
17339 -- Ignore pack that does nothing
17341 if Known_Static_Esize
(Ctyp
)
17342 and then Known_Static_RM_Size
(Ctyp
)
17343 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17344 and then Addressable
(Esize
(Ctyp
))
17349 -- Process OK pragma Pack. Note that if there is a separate
17350 -- component clause present, the Pack will be cancelled. This
17351 -- processing is in Freeze.
17353 if not Rep_Item_Too_Late
(Typ
, N
) then
17355 -- In CodePeer mode, we do not need complex front-end
17356 -- expansions related to pragma Pack, so disable handling
17359 if CodePeer_Mode
then
17362 -- Don't attempt any packing for VM targets. We possibly
17363 -- could deal with some cases of array bit-packing, but we
17364 -- don't bother, since this is not a typical kind of
17365 -- representation in the VM context anyway (and would not
17366 -- for example work nicely with the debugger).
17368 elsif VM_Target
/= No_VM
then
17369 if not GNAT_Mode
then
17371 ("??pragma% ignored in this configuration");
17374 -- Normal case where we do the pack action
17378 Set_Is_Packed
(Base_Type
(Typ
));
17379 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17382 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17386 -- For record types, the pack is always effective
17388 else pragma Assert
(Is_Record_Type
(Typ
));
17389 if not Rep_Item_Too_Late
(Typ
, N
) then
17391 -- Ignore pack request with warning in VM mode (skip warning
17392 -- if we are compiling GNAT run time library).
17394 if VM_Target
/= No_VM
then
17395 if not GNAT_Mode
then
17397 ("??pragma% ignored in this configuration");
17400 -- Normal case of pack request active
17403 Set_Is_Packed
(Base_Type
(Typ
));
17404 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17405 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17417 -- There is nothing to do here, since we did all the processing for
17418 -- this pragma in Par.Prag (so that it works properly even in syntax
17421 when Pragma_Page
=>
17428 -- pragma Part_Of (ABSTRACT_STATE);
17430 -- ABSTRACT_STATE ::= NAME
17432 when Pragma_Part_Of
=> Part_Of
: declare
17433 procedure Propagate_Part_Of
17434 (Pack_Id
: Entity_Id
;
17435 State_Id
: Entity_Id
;
17436 Instance
: Node_Id
);
17437 -- Propagate the Part_Of indicator to all abstract states and
17438 -- objects declared in the visible state space of a package
17439 -- denoted by Pack_Id. State_Id is the encapsulating state.
17440 -- Instance is the package instantiation node.
17442 -----------------------
17443 -- Propagate_Part_Of --
17444 -----------------------
17446 procedure Propagate_Part_Of
17447 (Pack_Id
: Entity_Id
;
17448 State_Id
: Entity_Id
;
17449 Instance
: Node_Id
)
17451 Has_Item
: Boolean := False;
17452 -- Flag set when the visible state space contains at least one
17453 -- abstract state or variable.
17455 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17456 -- Propagate the Part_Of indicator to all abstract states and
17457 -- objects declared in the visible state space of a package
17458 -- denoted by Pack_Id.
17460 -----------------------
17461 -- Propagate_Part_Of --
17462 -----------------------
17464 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17465 Item_Id
: Entity_Id
;
17468 -- Traverse the entity chain of the package and set relevant
17469 -- attributes of abstract states and objects declared in the
17470 -- visible state space of the package.
17472 Item_Id
:= First_Entity
(Pack_Id
);
17473 while Present
(Item_Id
)
17474 and then not In_Private_Part
(Item_Id
)
17476 -- Do not consider internally generated items
17478 if not Comes_From_Source
(Item_Id
) then
17481 -- The Part_Of indicator turns an abstract state or an
17482 -- object into a constituent of the encapsulating state.
17484 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17490 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17491 Set_Encapsulating_State
(Item_Id
, State_Id
);
17493 -- Recursively handle nested packages and instantiations
17495 elsif Ekind
(Item_Id
) = E_Package
then
17496 Propagate_Part_Of
(Item_Id
);
17499 Next_Entity
(Item_Id
);
17501 end Propagate_Part_Of
;
17503 -- Start of processing for Propagate_Part_Of
17506 Propagate_Part_Of
(Pack_Id
);
17508 -- Detect a package instantiation that is subject to a Part_Of
17509 -- indicator, but has no visible state.
17511 if not Has_Item
then
17513 ("package instantiation & has Part_Of indicator but "
17514 & "lacks visible state", Instance
, Pack_Id
);
17516 end Propagate_Part_Of
;
17520 Item_Id
: Entity_Id
;
17523 State_Id
: Entity_Id
;
17526 -- Start of processing for Part_Of
17530 Check_No_Identifiers
;
17531 Check_Arg_Count
(1);
17533 -- Ensure the proper placement of the pragma. Part_Of must appear
17534 -- on an object declaration or a package instantiation.
17537 while Present
(Stmt
) loop
17539 -- Skip prior pragmas, but check for duplicates
17541 if Nkind
(Stmt
) = N_Pragma
then
17542 if Pragma_Name
(Stmt
) = Pname
then
17543 Error_Msg_Name_1
:= Pname
;
17544 Error_Msg_Sloc
:= Sloc
(Stmt
);
17545 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17548 -- Skip internally generated code
17550 elsif not Comes_From_Source
(Stmt
) then
17553 -- The pragma applies to an object declaration (possibly a
17554 -- variable) or a package instantiation. Stop the traversal
17555 -- and continue the analysis.
17557 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17558 N_Package_Instantiation
)
17562 -- The pragma does not apply to a legal construct, issue an
17563 -- error and stop the analysis.
17570 Stmt
:= Prev
(Stmt
);
17573 -- Extract the entity of the related object declaration or package
17574 -- instantiation. In the case of the instantiation, use the entity
17575 -- of the instance spec.
17577 if Nkind
(Stmt
) = N_Package_Instantiation
then
17578 Stmt
:= Instance_Spec
(Stmt
);
17581 Item_Id
:= Defining_Entity
(Stmt
);
17582 State
:= Get_Pragma_Arg
(Arg1
);
17584 -- Detect any discrepancies between the placement of the object
17585 -- or package instantiation with respect to state space and the
17586 -- encapsulating state.
17589 (Item_Id
=> Item_Id
,
17595 State_Id
:= Entity
(State
);
17597 -- The Part_Of indicator turns an object into a constituent of
17598 -- the encapsulating state.
17600 if Ekind_In
(Item_Id
, E_Constant
, E_Variable
) then
17601 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17602 Set_Encapsulating_State
(Item_Id
, State_Id
);
17604 -- Propagate the Part_Of indicator to the visible state space
17605 -- of the package instantiation.
17609 (Pack_Id
=> Item_Id
,
17610 State_Id
=> State_Id
,
17614 -- Add the pragma to the contract of the item. This aids with
17615 -- the detection of a missing but required Part_Of indicator.
17617 Add_Contract_Item
(N
, Item_Id
);
17621 ----------------------------------
17622 -- Partition_Elaboration_Policy --
17623 ----------------------------------
17625 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17627 when Pragma_Partition_Elaboration_Policy
=> declare
17628 subtype PEP_Range
is Name_Id
17629 range First_Partition_Elaboration_Policy_Name
17630 .. Last_Partition_Elaboration_Policy_Name
;
17631 PEP_Val
: PEP_Range
;
17636 Check_Arg_Count
(1);
17637 Check_No_Identifiers
;
17638 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17639 Check_Valid_Configuration_Pragma
;
17640 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17643 when Name_Concurrent
=>
17645 when Name_Sequential
=>
17649 if Partition_Elaboration_Policy
/= ' '
17650 and then Partition_Elaboration_Policy
/= PEP
17652 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17654 ("partition elaboration policy incompatible with policy#");
17656 -- Set new policy, but always preserve System_Location since we
17657 -- like the error message with the run time name.
17660 Partition_Elaboration_Policy
:= PEP
;
17662 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17663 Partition_Elaboration_Policy_Sloc
:= Loc
;
17672 -- pragma Passive [(PASSIVE_FORM)];
17674 -- PASSIVE_FORM ::= Semaphore | No
17676 when Pragma_Passive
=>
17679 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17680 Error_Pragma
("pragma% must be within task definition");
17683 if Arg_Count
/= 0 then
17684 Check_Arg_Count
(1);
17685 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17688 ----------------------------------
17689 -- Preelaborable_Initialization --
17690 ----------------------------------
17692 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17694 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17699 Check_Arg_Count
(1);
17700 Check_No_Identifiers
;
17701 Check_Arg_Is_Identifier
(Arg1
);
17702 Check_Arg_Is_Local_Name
(Arg1
);
17703 Check_First_Subtype
(Arg1
);
17704 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17706 -- The pragma may come from an aspect on a private declaration,
17707 -- even if the freeze point at which this is analyzed in the
17708 -- private part after the full view.
17710 if Has_Private_Declaration
(Ent
)
17711 and then From_Aspect_Specification
(N
)
17715 -- Check appropriate type argument
17717 elsif Is_Private_Type
(Ent
)
17718 or else Is_Protected_Type
(Ent
)
17719 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17721 -- AI05-0028: The pragma applies to all composite types. Note
17722 -- that we apply this binding interpretation to earlier versions
17723 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
17724 -- choice since there are other compilers that do the same.
17726 or else Is_Composite_Type
(Ent
)
17732 ("pragma % can only be applied to private, formal derived, "
17733 & "protected, or composite type", Arg1
);
17736 -- Give an error if the pragma is applied to a protected type that
17737 -- does not qualify (due to having entries, or due to components
17738 -- that do not qualify).
17740 if Is_Protected_Type
(Ent
)
17741 and then not Has_Preelaborable_Initialization
(Ent
)
17744 ("protected type & does not have preelaborable "
17745 & "initialization", Ent
);
17747 -- Otherwise mark the type as definitely having preelaborable
17751 Set_Known_To_Have_Preelab_Init
(Ent
);
17754 if Has_Pragma_Preelab_Init
(Ent
)
17755 and then Warn_On_Redundant_Constructs
17757 Error_Pragma
("?r?duplicate pragma%!");
17759 Set_Has_Pragma_Preelab_Init
(Ent
);
17763 --------------------
17764 -- Persistent_BSS --
17765 --------------------
17767 -- pragma Persistent_BSS [(object_NAME)];
17769 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17776 Check_At_Most_N_Arguments
(1);
17778 -- Case of application to specific object (one argument)
17780 if Arg_Count
= 1 then
17781 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17783 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17785 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17788 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17791 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17792 Decl
:= Parent
(Ent
);
17794 -- Check for duplication before inserting in list of
17795 -- representation items.
17797 Check_Duplicate_Pragma
(Ent
);
17799 if Rep_Item_Too_Late
(Ent
, N
) then
17803 if Present
(Expression
(Decl
)) then
17805 ("object for pragma% cannot have initialization", Arg1
);
17808 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17810 ("object type for pragma% is not potentially persistent",
17815 Make_Linker_Section_Pragma
17816 (Ent
, Sloc
(N
), ".persistent.bss");
17817 Insert_After
(N
, Prag
);
17820 -- Case of use as configuration pragma with no arguments
17823 Check_Valid_Configuration_Pragma
;
17824 Persistent_BSS_Mode
:= True;
17826 end Persistent_BSS
;
17832 -- pragma Polling (ON | OFF);
17834 when Pragma_Polling
=>
17836 Check_Arg_Count
(1);
17837 Check_No_Identifiers
;
17838 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17839 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17841 -----------------------------------
17842 -- Post/Post_Class/Postcondition --
17843 -----------------------------------
17845 -- pragma Post (Boolean_EXPRESSION);
17846 -- pragma Post_Class (Boolean_EXPRESSION);
17847 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
17848 -- [,[Message =>] String_EXPRESSION]);
17850 -- Characteristics:
17852 -- * Analysis - The annotation undergoes initial checks to verify
17853 -- the legal placement and context. Secondary checks preanalyze the
17856 -- Analyze_Pre_Post_Condition_In_Decl_Part
17858 -- * Expansion - The annotation is expanded during the expansion of
17859 -- the related subprogram [body] contract as performed in:
17861 -- Expand_Subprogram_Contract
17863 -- * Template - The annotation utilizes the generic template of the
17864 -- related subprogram [body] when it is:
17866 -- aspect on subprogram declaration
17867 -- aspect on stand alone subprogram body
17868 -- pragma on stand alone subprogram body
17870 -- The annotation must prepare its own template when it is:
17872 -- pragma on subprogram declaration
17874 -- * Globals - Capture of global references must occur after full
17877 -- * Instance - The annotation is instantiated automatically when
17878 -- the related generic subprogram [body] is instantiated except for
17879 -- the "pragma on subprogram declaration" case. In that scenario
17880 -- the annotation must instantiate itself.
17883 Pragma_Post_Class |
17884 Pragma_Postcondition
=>
17885 Analyze_Pre_Post_Condition
;
17887 --------------------------------
17888 -- Pre/Pre_Class/Precondition --
17889 --------------------------------
17891 -- pragma Pre (Boolean_EXPRESSION);
17892 -- pragma Pre_Class (Boolean_EXPRESSION);
17893 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
17894 -- [,[Message =>] String_EXPRESSION]);
17896 -- Characteristics:
17898 -- * Analysis - The annotation undergoes initial checks to verify
17899 -- the legal placement and context. Secondary checks preanalyze the
17902 -- Analyze_Pre_Post_Condition_In_Decl_Part
17904 -- * Expansion - The annotation is expanded during the expansion of
17905 -- the related subprogram [body] contract as performed in:
17907 -- Expand_Subprogram_Contract
17909 -- * Template - The annotation utilizes the generic template of the
17910 -- related subprogram [body] when it is:
17912 -- aspect on subprogram declaration
17913 -- aspect on stand alone subprogram body
17914 -- pragma on stand alone subprogram body
17916 -- The annotation must prepare its own template when it is:
17918 -- pragma on subprogram declaration
17920 -- * Globals - Capture of global references must occur after full
17923 -- * Instance - The annotation is instantiated automatically when
17924 -- the related generic subprogram [body] is instantiated except for
17925 -- the "pragma on subprogram declaration" case. In that scenario
17926 -- the annotation must instantiate itself.
17930 Pragma_Precondition
=>
17931 Analyze_Pre_Post_Condition
;
17937 -- pragma Predicate
17938 -- ([Entity =>] type_LOCAL_NAME,
17939 -- [Check =>] boolean_EXPRESSION);
17941 when Pragma_Predicate
=> Predicate
: declare
17948 Check_Arg_Count
(2);
17949 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17950 Check_Optional_Identifier
(Arg2
, Name_Check
);
17952 Check_Arg_Is_Local_Name
(Arg1
);
17954 Type_Id
:= Get_Pragma_Arg
(Arg1
);
17955 Find_Type
(Type_Id
);
17956 Typ
:= Entity
(Type_Id
);
17958 if Typ
= Any_Type
then
17962 -- The remaining processing is simply to link the pragma on to
17963 -- the rep item chain, for processing when the type is frozen.
17964 -- This is accomplished by a call to Rep_Item_Too_Late. We also
17965 -- mark the type as having predicates.
17967 Set_Has_Predicates
(Typ
);
17968 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
17975 -- pragma Preelaborate [(library_unit_NAME)];
17977 -- Set the flag Is_Preelaborated of program unit name entity
17979 when Pragma_Preelaborate
=> Preelaborate
: declare
17980 Pa
: constant Node_Id
:= Parent
(N
);
17981 Pk
: constant Node_Kind
:= Nkind
(Pa
);
17985 Check_Ada_83_Warning
;
17986 Check_Valid_Library_Unit_Pragma
;
17988 if Nkind
(N
) = N_Null_Statement
then
17992 Ent
:= Find_Lib_Unit_Name
;
17993 Check_Duplicate_Pragma
(Ent
);
17995 -- This filters out pragmas inside generic parents that show up
17996 -- inside instantiations. Pragmas that come from aspects in the
17997 -- unit are not ignored.
17999 if Present
(Ent
) then
18000 if Pk
= N_Package_Specification
18001 and then Present
(Generic_Parent
(Pa
))
18002 and then not From_Aspect_Specification
(N
)
18007 if not Debug_Flag_U
then
18008 Set_Is_Preelaborated
(Ent
);
18009 Set_Suppress_Elaboration_Warnings
(Ent
);
18015 -------------------------------
18016 -- Prefix_Exception_Messages --
18017 -------------------------------
18019 -- pragma Prefix_Exception_Messages;
18021 when Pragma_Prefix_Exception_Messages
=>
18023 Check_Valid_Configuration_Pragma
;
18024 Check_Arg_Count
(0);
18025 Prefix_Exception_Messages
:= True;
18031 -- pragma Priority (EXPRESSION);
18033 when Pragma_Priority
=> Priority
: declare
18034 P
: constant Node_Id
:= Parent
(N
);
18039 Check_No_Identifiers
;
18040 Check_Arg_Count
(1);
18044 if Nkind
(P
) = N_Subprogram_Body
then
18045 Check_In_Main_Program
;
18047 Ent
:= Defining_Unit_Name
(Specification
(P
));
18049 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18050 Ent
:= Defining_Identifier
(Ent
);
18053 Arg
:= Get_Pragma_Arg
(Arg1
);
18054 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18058 if not Is_OK_Static_Expression
(Arg
) then
18059 Flag_Non_Static_Expr
18060 ("main subprogram priority is not static!", Arg
);
18063 -- If constraint error, then we already signalled an error
18065 elsif Raises_Constraint_Error
(Arg
) then
18068 -- Otherwise check in range except if Relaxed_RM_Semantics
18069 -- where we ignore the value if out of range.
18073 Val
: constant Uint
:= Expr_Value
(Arg
);
18075 if not Relaxed_RM_Semantics
18078 or else Val
> Expr_Value
(Expression
18079 (Parent
(RTE
(RE_Max_Priority
)))))
18082 ("main subprogram priority is out of range", Arg1
);
18085 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18090 -- Load an arbitrary entity from System.Tasking.Stages or
18091 -- System.Tasking.Restricted.Stages (depending on the
18092 -- supported profile) to make sure that one of these packages
18093 -- is implicitly with'ed, since we need to have the tasking
18094 -- run time active for the pragma Priority to have any effect.
18095 -- Previously we with'ed the package System.Tasking, but this
18096 -- package does not trigger the required initialization of the
18097 -- run-time library.
18100 Discard
: Entity_Id
;
18101 pragma Warnings
(Off
, Discard
);
18103 if Restricted_Profile
then
18104 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18106 Discard
:= RTE
(RE_Activate_Tasks
);
18110 -- Task or Protected, must be of type Integer
18112 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18113 Arg
:= Get_Pragma_Arg
(Arg1
);
18114 Ent
:= Defining_Identifier
(Parent
(P
));
18116 -- The expression must be analyzed in the special manner
18117 -- described in "Handling of Default and Per-Object
18118 -- Expressions" in sem.ads.
18120 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18122 if not Is_OK_Static_Expression
(Arg
) then
18123 Check_Restriction
(Static_Priorities
, Arg
);
18126 -- Anything else is incorrect
18132 -- Check duplicate pragma before we chain the pragma in the Rep
18133 -- Item chain of Ent.
18135 Check_Duplicate_Pragma
(Ent
);
18136 Record_Rep_Item
(Ent
, N
);
18139 -----------------------------------
18140 -- Priority_Specific_Dispatching --
18141 -----------------------------------
18143 -- pragma Priority_Specific_Dispatching (
18144 -- policy_IDENTIFIER,
18145 -- first_priority_EXPRESSION,
18146 -- last_priority_EXPRESSION);
18148 when Pragma_Priority_Specific_Dispatching
=>
18149 Priority_Specific_Dispatching
: declare
18150 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18151 -- This is the entity System.Any_Priority;
18154 Lower_Bound
: Node_Id
;
18155 Upper_Bound
: Node_Id
;
18161 Check_Arg_Count
(3);
18162 Check_No_Identifiers
;
18163 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
18164 Check_Valid_Configuration_Pragma
;
18165 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18166 DP
:= Fold_Upper
(Name_Buffer
(1));
18168 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
18169 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
18170 Lower_Val
:= Expr_Value
(Lower_Bound
);
18172 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
18173 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
18174 Upper_Val
:= Expr_Value
(Upper_Bound
);
18176 -- It is not allowed to use Task_Dispatching_Policy and
18177 -- Priority_Specific_Dispatching in the same partition.
18179 if Task_Dispatching_Policy
/= ' ' then
18180 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18182 ("pragma% incompatible with Task_Dispatching_Policy#");
18184 -- Check lower bound in range
18186 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18188 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18191 ("first_priority is out of range", Arg2
);
18193 -- Check upper bound in range
18195 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
18197 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
18200 ("last_priority is out of range", Arg3
);
18202 -- Check that the priority range is valid
18204 elsif Lower_Val
> Upper_Val
then
18206 ("last_priority_expression must be greater than or equal to "
18207 & "first_priority_expression");
18209 -- Store the new policy, but always preserve System_Location since
18210 -- we like the error message with the run-time name.
18213 -- Check overlapping in the priority ranges specified in other
18214 -- Priority_Specific_Dispatching pragmas within the same
18215 -- partition. We can only check those we know about.
18218 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
18220 if Specific_Dispatching
.Table
(J
).First_Priority
in
18221 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18222 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
18223 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
18226 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
18228 ("priority range overlaps with "
18229 & "Priority_Specific_Dispatching#");
18233 -- The use of Priority_Specific_Dispatching is incompatible
18234 -- with Task_Dispatching_Policy.
18236 if Task_Dispatching_Policy
/= ' ' then
18237 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
18239 ("Priority_Specific_Dispatching incompatible "
18240 & "with Task_Dispatching_Policy#");
18243 -- The use of Priority_Specific_Dispatching forces ceiling
18246 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
18247 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18249 ("Priority_Specific_Dispatching incompatible "
18250 & "with Locking_Policy#");
18252 -- Set the Ceiling_Locking policy, but preserve System_Location
18253 -- since we like the error message with the run time name.
18256 Locking_Policy
:= 'C';
18258 if Locking_Policy_Sloc
/= System_Location
then
18259 Locking_Policy_Sloc
:= Loc
;
18263 -- Add entry in the table
18265 Specific_Dispatching
.Append
18266 ((Dispatching_Policy
=> DP
,
18267 First_Priority
=> UI_To_Int
(Lower_Val
),
18268 Last_Priority
=> UI_To_Int
(Upper_Val
),
18269 Pragma_Loc
=> Loc
));
18271 end Priority_Specific_Dispatching
;
18277 -- pragma Profile (profile_IDENTIFIER);
18279 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
18281 when Pragma_Profile
=>
18283 Check_Arg_Count
(1);
18284 Check_Valid_Configuration_Pragma
;
18285 Check_No_Identifiers
;
18288 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18291 if Chars
(Argx
) = Name_Ravenscar
then
18292 Set_Ravenscar_Profile
(N
);
18294 elsif Chars
(Argx
) = Name_Restricted
then
18295 Set_Profile_Restrictions
18297 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18299 elsif Chars
(Argx
) = Name_Rational
then
18300 Set_Rational_Profile
;
18302 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18303 Set_Profile_Restrictions
18304 (No_Implementation_Extensions
,
18305 N
, Warn
=> Treat_Restrictions_As_Warnings
);
18308 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18312 ----------------------
18313 -- Profile_Warnings --
18314 ----------------------
18316 -- pragma Profile_Warnings (profile_IDENTIFIER);
18318 -- profile_IDENTIFIER => Restricted | Ravenscar
18320 when Pragma_Profile_Warnings
=>
18322 Check_Arg_Count
(1);
18323 Check_Valid_Configuration_Pragma
;
18324 Check_No_Identifiers
;
18327 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18330 if Chars
(Argx
) = Name_Ravenscar
then
18331 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
18333 elsif Chars
(Argx
) = Name_Restricted
then
18334 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
18336 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
18337 Set_Profile_Restrictions
18338 (No_Implementation_Extensions
, N
, Warn
=> True);
18341 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18345 --------------------------
18346 -- Propagate_Exceptions --
18347 --------------------------
18349 -- pragma Propagate_Exceptions;
18351 -- Note: this pragma is obsolete and has no effect
18353 when Pragma_Propagate_Exceptions
=>
18355 Check_Arg_Count
(0);
18357 if Warn_On_Obsolescent_Feature
then
18359 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18360 "and has no effect?j?", N
);
18363 -----------------------------
18364 -- Provide_Shift_Operators --
18365 -----------------------------
18367 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18369 when Pragma_Provide_Shift_Operators
=>
18370 Provide_Shift_Operators
: declare
18373 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18374 -- Insert declaration and pragma Instrinsic for named shift op
18376 ----------------------------
18377 -- Declare_Shift_Operator --
18378 ----------------------------
18380 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18386 Make_Subprogram_Declaration
(Loc
,
18387 Make_Function_Specification
(Loc
,
18388 Defining_Unit_Name
=>
18389 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18391 Result_Definition
=>
18392 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18394 Parameter_Specifications
=> New_List
(
18395 Make_Parameter_Specification
(Loc
,
18396 Defining_Identifier
=>
18397 Make_Defining_Identifier
(Loc
, Name_Value
),
18399 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18401 Make_Parameter_Specification
(Loc
,
18402 Defining_Identifier
=>
18403 Make_Defining_Identifier
(Loc
, Name_Amount
),
18405 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18409 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18410 Pragma_Argument_Associations
=> New_List
(
18411 Make_Pragma_Argument_Association
(Loc
,
18412 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18413 Make_Pragma_Argument_Association
(Loc
,
18414 Expression
=> Make_Identifier
(Loc
, Nam
))));
18416 Insert_After
(N
, Import
);
18417 Insert_After
(N
, Func
);
18418 end Declare_Shift_Operator
;
18420 -- Start of processing for Provide_Shift_Operators
18424 Check_Arg_Count
(1);
18425 Check_Arg_Is_Local_Name
(Arg1
);
18427 Arg1
:= Get_Pragma_Arg
(Arg1
);
18429 -- We must have an entity name
18431 if not Is_Entity_Name
(Arg1
) then
18433 ("pragma % must apply to integer first subtype", Arg1
);
18436 -- If no Entity, means there was a prior error so ignore
18438 if Present
(Entity
(Arg1
)) then
18439 Ent
:= Entity
(Arg1
);
18441 -- Apply error checks
18443 if not Is_First_Subtype
(Ent
) then
18445 ("cannot apply pragma %",
18446 "\& is not a first subtype",
18449 elsif not Is_Integer_Type
(Ent
) then
18451 ("cannot apply pragma %",
18452 "\& is not an integer type",
18455 elsif Has_Shift_Operator
(Ent
) then
18457 ("cannot apply pragma %",
18458 "\& already has declared shift operators",
18461 elsif Is_Frozen
(Ent
) then
18463 ("pragma % appears too late",
18464 "\& is already frozen",
18468 -- Now declare the operators. We do this during analysis rather
18469 -- than expansion, since we want the operators available if we
18470 -- are operating in -gnatc or ASIS mode.
18472 Declare_Shift_Operator
(Name_Rotate_Left
);
18473 Declare_Shift_Operator
(Name_Rotate_Right
);
18474 Declare_Shift_Operator
(Name_Shift_Left
);
18475 Declare_Shift_Operator
(Name_Shift_Right
);
18476 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18478 end Provide_Shift_Operators
;
18484 -- pragma Psect_Object (
18485 -- [Internal =>] LOCAL_NAME,
18486 -- [, [External =>] EXTERNAL_SYMBOL]
18487 -- [, [Size =>] EXTERNAL_SYMBOL]);
18489 when Pragma_Psect_Object | Pragma_Common_Object
=>
18490 Psect_Object
: declare
18491 Args
: Args_List
(1 .. 3);
18492 Names
: constant Name_List
(1 .. 3) := (
18497 Internal
: Node_Id
renames Args
(1);
18498 External
: Node_Id
renames Args
(2);
18499 Size
: Node_Id
renames Args
(3);
18501 Def_Id
: Entity_Id
;
18503 procedure Check_Arg
(Arg
: Node_Id
);
18504 -- Checks that argument is either a string literal or an
18505 -- identifier, and posts error message if not.
18511 procedure Check_Arg
(Arg
: Node_Id
) is
18513 if not Nkind_In
(Original_Node
(Arg
),
18518 ("inappropriate argument for pragma %", Arg
);
18522 -- Start of processing for Common_Object/Psect_Object
18526 Gather_Associations
(Names
, Args
);
18527 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18529 Def_Id
:= Entity
(Internal
);
18531 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18533 ("pragma% must designate an object", Internal
);
18536 Check_Arg
(Internal
);
18538 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18540 ("cannot use pragma% for imported/exported object",
18544 if Is_Concurrent_Type
(Etype
(Internal
)) then
18546 ("cannot specify pragma % for task/protected object",
18550 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18552 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18554 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18557 if Ekind
(Def_Id
) = E_Constant
then
18559 ("cannot specify pragma % for a constant", Internal
);
18562 if Is_Record_Type
(Etype
(Internal
)) then
18568 Ent
:= First_Entity
(Etype
(Internal
));
18569 while Present
(Ent
) loop
18570 Decl
:= Declaration_Node
(Ent
);
18572 if Ekind
(Ent
) = E_Component
18573 and then Nkind
(Decl
) = N_Component_Declaration
18574 and then Present
(Expression
(Decl
))
18575 and then Warn_On_Export_Import
18578 ("?x?object for pragma % has defaults", Internal
);
18588 if Present
(Size
) then
18592 if Present
(External
) then
18593 Check_Arg_Is_External_Name
(External
);
18596 -- If all error tests pass, link pragma on to the rep item chain
18598 Record_Rep_Item
(Def_Id
, N
);
18605 -- pragma Pure [(library_unit_NAME)];
18607 when Pragma_Pure
=> Pure
: declare
18611 Check_Ada_83_Warning
;
18612 Check_Valid_Library_Unit_Pragma
;
18614 if Nkind
(N
) = N_Null_Statement
then
18618 Ent
:= Find_Lib_Unit_Name
;
18620 Set_Has_Pragma_Pure
(Ent
);
18621 Set_Suppress_Elaboration_Warnings
(Ent
);
18624 -------------------
18625 -- Pure_Function --
18626 -------------------
18628 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18630 when Pragma_Pure_Function
=> Pure_Function
: declare
18633 Def_Id
: Entity_Id
;
18634 Effective
: Boolean := False;
18638 Check_Arg_Count
(1);
18639 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18640 Check_Arg_Is_Local_Name
(Arg1
);
18641 E_Id
:= Get_Pragma_Arg
(Arg1
);
18643 if Error_Posted
(E_Id
) then
18647 -- Loop through homonyms (overloadings) of referenced entity
18649 E
:= Entity
(E_Id
);
18651 if Present
(E
) then
18653 Def_Id
:= Get_Base_Subprogram
(E
);
18655 if not Ekind_In
(Def_Id
, E_Function
,
18656 E_Generic_Function
,
18660 ("pragma% requires a function name", Arg1
);
18663 Set_Is_Pure
(Def_Id
);
18665 if not Has_Pragma_Pure_Function
(Def_Id
) then
18666 Set_Has_Pragma_Pure_Function
(Def_Id
);
18670 exit when From_Aspect_Specification
(N
);
18672 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18676 and then Warn_On_Redundant_Constructs
18679 ("pragma Pure_Function on& is redundant?r?",
18685 --------------------
18686 -- Queuing_Policy --
18687 --------------------
18689 -- pragma Queuing_Policy (policy_IDENTIFIER);
18691 when Pragma_Queuing_Policy
=> declare
18695 Check_Ada_83_Warning
;
18696 Check_Arg_Count
(1);
18697 Check_No_Identifiers
;
18698 Check_Arg_Is_Queuing_Policy
(Arg1
);
18699 Check_Valid_Configuration_Pragma
;
18700 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18701 QP
:= Fold_Upper
(Name_Buffer
(1));
18703 if Queuing_Policy
/= ' '
18704 and then Queuing_Policy
/= QP
18706 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18707 Error_Pragma
("queuing policy incompatible with policy#");
18709 -- Set new policy, but always preserve System_Location since we
18710 -- like the error message with the run time name.
18713 Queuing_Policy
:= QP
;
18715 if Queuing_Policy_Sloc
/= System_Location
then
18716 Queuing_Policy_Sloc
:= Loc
;
18725 -- pragma Rational, for compatibility with foreign compiler
18727 when Pragma_Rational
=>
18728 Set_Rational_Profile
;
18730 ------------------------------------
18731 -- Refined_Depends/Refined_Global --
18732 ------------------------------------
18734 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18736 -- DEPENDENCY_RELATION ::=
18738 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18740 -- DEPENDENCY_CLAUSE ::=
18741 -- OUTPUT_LIST =>[+] INPUT_LIST
18742 -- | NULL_DEPENDENCY_CLAUSE
18744 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18746 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18748 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18750 -- OUTPUT ::= NAME | FUNCTION_RESULT
18753 -- where FUNCTION_RESULT is a function Result attribute_reference
18755 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18757 -- GLOBAL_SPECIFICATION ::=
18760 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18762 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18764 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
18765 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
18766 -- GLOBAL_ITEM ::= NAME
18768 -- Characteristics:
18770 -- * Analysis - The annotation undergoes initial checks to verify
18771 -- the legal placement and context. Secondary checks fully analyze
18772 -- the dependency clauses/global list in:
18774 -- Analyze_Refined_Depends_In_Decl_Part
18775 -- Analyze_Refined_Global_In_Decl_Part
18777 -- * Expansion - None.
18779 -- * Template - The annotation utilizes the generic template of the
18780 -- related subprogram body.
18782 -- * Globals - Capture of global references must occur after full
18785 -- * Instance - The annotation is instantiated automatically when
18786 -- the related generic subprogram body is instantiated.
18788 when Pragma_Refined_Depends |
18789 Pragma_Refined_Global
=> Refined_Depends_Global
:
18791 Body_Id
: Entity_Id
;
18793 Spec_Id
: Entity_Id
;
18796 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
18798 -- Chain the pragma on the contract for further processing by
18799 -- Analyze_Refined_[Depends|Global]_In_Decl_Part.
18802 Add_Contract_Item
(N
, Body_Id
);
18804 end Refined_Depends_Global
;
18810 -- pragma Refined_Post (boolean_EXPRESSION);
18812 -- Characteristics:
18814 -- * Analysis - The annotation is fully analyzed immediately upon
18815 -- elaboration as it cannot forward reference entities.
18817 -- * Expansion - The annotation is expanded during the expansion of
18818 -- the related subprogram body contract as performed in:
18820 -- Expand_Subprogram_Contract
18822 -- * Template - The annotation utilizes the generic template of the
18823 -- related subprogram body.
18825 -- * Globals - Capture of global references must occur after full
18828 -- * Instance - The annotation is instantiated automatically when
18829 -- the related generic subprogram body is instantiated.
18831 when Pragma_Refined_Post
=> Refined_Post
: declare
18832 Body_Id
: Entity_Id
;
18834 Spec_Id
: Entity_Id
;
18837 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
18839 -- Fully analyze the pragma when it appears inside a subprogram
18840 -- body because it cannot benefit from forward references.
18843 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
18845 -- Currently it is not possible to inline pre/postconditions on
18846 -- a subprogram subject to pragma Inline_Always.
18848 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
18850 -- Chain the pragma on the contract for completeness
18852 Add_Contract_Item
(N
, Body_Id
);
18856 -------------------
18857 -- Refined_State --
18858 -------------------
18860 -- pragma Refined_State (REFINEMENT_LIST);
18862 -- REFINEMENT_LIST ::=
18863 -- REFINEMENT_CLAUSE
18864 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
18866 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
18868 -- CONSTITUENT_LIST ::=
18871 -- | (CONSTITUENT {, CONSTITUENT})
18873 -- CONSTITUENT ::= object_NAME | state_NAME
18875 -- Characteristics:
18877 -- * Analysis - The annotation undergoes initial checks to verify
18878 -- the legal placement and context. Secondary checks preanalyze the
18879 -- refinement clauses in:
18881 -- Analyze_Refined_State_In_Decl_Part
18883 -- * Expansion - None.
18885 -- * Template - The annotation utilizes the template of the related
18888 -- * Globals - Capture of global references must occur after full
18891 -- * Instance - The annotation is instantiated automatically when
18892 -- the related generic package body is instantiated.
18894 when Pragma_Refined_State
=> Refined_State
: declare
18895 Pack_Decl
: Node_Id
;
18896 Spec_Id
: Entity_Id
;
18900 Check_No_Identifiers
;
18901 Check_Arg_Count
(1);
18903 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18905 -- Ensure the proper placement of the pragma. Refined states must
18906 -- be associated with a package body.
18908 if Nkind
(Pack_Decl
) = N_Package_Body
then
18911 -- Otherwise the pragma is associated with an illegal construct
18918 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
18920 -- State refinement is allowed only when the corresponding package
18921 -- declaration has non-null pragma Abstract_State. Refinement not
18922 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
18924 if SPARK_Mode
/= Off
18926 (No
(Abstract_States
(Spec_Id
))
18927 or else Has_Null_Abstract_State
(Spec_Id
))
18930 ("useless refinement, package & does not define abstract "
18931 & "states", N
, Spec_Id
);
18935 -- Chain the pragma on the contract for further processing by
18936 -- Analyze_Refined_State_In_Decl_Part.
18938 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
18941 -----------------------
18942 -- Relative_Deadline --
18943 -----------------------
18945 -- pragma Relative_Deadline (time_span_EXPRESSION);
18947 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
18948 P
: constant Node_Id
:= Parent
(N
);
18953 Check_No_Identifiers
;
18954 Check_Arg_Count
(1);
18956 Arg
:= Get_Pragma_Arg
(Arg1
);
18958 -- The expression must be analyzed in the special manner described
18959 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
18961 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
18965 if Nkind
(P
) = N_Subprogram_Body
then
18966 Check_In_Main_Program
;
18968 -- Only Task and subprogram cases allowed
18970 elsif Nkind
(P
) /= N_Task_Definition
then
18974 -- Check duplicate pragma before we set the corresponding flag
18976 if Has_Relative_Deadline_Pragma
(P
) then
18977 Error_Pragma
("duplicate pragma% not allowed");
18980 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
18981 -- Relative_Deadline pragma node cannot be inserted in the Rep
18982 -- Item chain of Ent since it is rewritten by the expander as a
18983 -- procedure call statement that will break the chain.
18985 Set_Has_Relative_Deadline_Pragma
(P
, True);
18986 end Relative_Deadline
;
18988 ------------------------
18989 -- Remote_Access_Type --
18990 ------------------------
18992 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
18994 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
18999 Check_Arg_Count
(1);
19000 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19001 Check_Arg_Is_Local_Name
(Arg1
);
19003 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
19005 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
19006 and then Ekind
(E
) = E_General_Access_Type
19007 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
19008 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
19010 and then Is_Valid_Remote_Object_Type
19011 (Root_Type
(Directly_Designated_Type
(E
)))
19013 Set_Is_Remote_Types
(E
);
19017 ("pragma% applies only to formal access to classwide types",
19020 end Remote_Access_Type
;
19022 ---------------------------
19023 -- Remote_Call_Interface --
19024 ---------------------------
19026 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19028 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19029 Cunit_Node
: Node_Id
;
19030 Cunit_Ent
: Entity_Id
;
19034 Check_Ada_83_Warning
;
19035 Check_Valid_Library_Unit_Pragma
;
19037 if Nkind
(N
) = N_Null_Statement
then
19041 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19042 K
:= Nkind
(Unit
(Cunit_Node
));
19043 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19045 if K
= N_Package_Declaration
19046 or else K
= N_Generic_Package_Declaration
19047 or else K
= N_Subprogram_Declaration
19048 or else K
= N_Generic_Subprogram_Declaration
19049 or else (K
= N_Subprogram_Body
19050 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
19055 "pragma% must apply to package or subprogram declaration");
19058 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
19059 end Remote_Call_Interface
;
19065 -- pragma Remote_Types [(library_unit_NAME)];
19067 when Pragma_Remote_Types
=> Remote_Types
: declare
19068 Cunit_Node
: Node_Id
;
19069 Cunit_Ent
: Entity_Id
;
19072 Check_Ada_83_Warning
;
19073 Check_Valid_Library_Unit_Pragma
;
19075 if Nkind
(N
) = N_Null_Statement
then
19079 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19080 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19082 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19083 N_Generic_Package_Declaration
)
19086 ("pragma% can only apply to a package declaration");
19089 Set_Is_Remote_Types
(Cunit_Ent
);
19096 -- pragma Ravenscar;
19098 when Pragma_Ravenscar
=>
19100 Check_Arg_Count
(0);
19101 Check_Valid_Configuration_Pragma
;
19102 Set_Ravenscar_Profile
(N
);
19104 if Warn_On_Obsolescent_Feature
then
19106 ("pragma Ravenscar is an obsolescent feature?j?", N
);
19108 ("|use pragma Profile (Ravenscar) instead?j?", N
);
19111 -------------------------
19112 -- Restricted_Run_Time --
19113 -------------------------
19115 -- pragma Restricted_Run_Time;
19117 when Pragma_Restricted_Run_Time
=>
19119 Check_Arg_Count
(0);
19120 Check_Valid_Configuration_Pragma
;
19121 Set_Profile_Restrictions
19122 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
19124 if Warn_On_Obsolescent_Feature
then
19126 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
19129 ("|use pragma Profile (Restricted) instead?j?", N
);
19136 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
19139 -- restriction_IDENTIFIER
19140 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19142 when Pragma_Restrictions
=>
19143 Process_Restrictions_Or_Restriction_Warnings
19144 (Warn
=> Treat_Restrictions_As_Warnings
);
19146 --------------------------
19147 -- Restriction_Warnings --
19148 --------------------------
19150 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
19153 -- restriction_IDENTIFIER
19154 -- | restriction_parameter_IDENTIFIER => EXPRESSION
19156 when Pragma_Restriction_Warnings
=>
19158 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
19164 -- pragma Reviewable;
19166 when Pragma_Reviewable
=>
19167 Check_Ada_83_Warning
;
19168 Check_Arg_Count
(0);
19170 -- Call dummy debugging function rv. This is done to assist front
19171 -- end debugging. By placing a Reviewable pragma in the source
19172 -- program, a breakpoint on rv catches this place in the source,
19173 -- allowing convenient stepping to the point of interest.
19177 --------------------------
19178 -- Short_Circuit_And_Or --
19179 --------------------------
19181 -- pragma Short_Circuit_And_Or;
19183 when Pragma_Short_Circuit_And_Or
=>
19185 Check_Arg_Count
(0);
19186 Check_Valid_Configuration_Pragma
;
19187 Short_Circuit_And_Or
:= True;
19189 -------------------
19190 -- Share_Generic --
19191 -------------------
19193 -- pragma Share_Generic (GNAME {, GNAME});
19195 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
19197 when Pragma_Share_Generic
=>
19199 Process_Generic_List
;
19205 -- pragma Shared (LOCAL_NAME);
19207 when Pragma_Shared
=>
19209 Process_Atomic_Independent_Shared_Volatile
;
19211 --------------------
19212 -- Shared_Passive --
19213 --------------------
19215 -- pragma Shared_Passive [(library_unit_NAME)];
19217 -- Set the flag Is_Shared_Passive of program unit name entity
19219 when Pragma_Shared_Passive
=> Shared_Passive
: declare
19220 Cunit_Node
: Node_Id
;
19221 Cunit_Ent
: Entity_Id
;
19224 Check_Ada_83_Warning
;
19225 Check_Valid_Library_Unit_Pragma
;
19227 if Nkind
(N
) = N_Null_Statement
then
19231 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19232 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19234 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
19235 N_Generic_Package_Declaration
)
19238 ("pragma% can only apply to a package declaration");
19241 Set_Is_Shared_Passive
(Cunit_Ent
);
19242 end Shared_Passive
;
19244 -----------------------
19245 -- Short_Descriptors --
19246 -----------------------
19248 -- pragma Short_Descriptors;
19250 -- Recognize and validate, but otherwise ignore
19252 when Pragma_Short_Descriptors
=>
19254 Check_Arg_Count
(0);
19255 Check_Valid_Configuration_Pragma
;
19257 ------------------------------
19258 -- Simple_Storage_Pool_Type --
19259 ------------------------------
19261 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
19263 when Pragma_Simple_Storage_Pool_Type
=>
19264 Simple_Storage_Pool_Type
: declare
19270 Check_Arg_Count
(1);
19271 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19273 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19274 Find_Type
(Type_Id
);
19275 Typ
:= Entity
(Type_Id
);
19277 if Typ
= Any_Type
then
19281 -- We require the pragma to apply to a type declared in a package
19282 -- declaration, but not (immediately) within a package body.
19284 if Ekind
(Current_Scope
) /= E_Package
19285 or else In_Package_Body
(Current_Scope
)
19288 ("pragma% can only apply to type declared immediately "
19289 & "within a package declaration");
19292 -- A simple storage pool type must be an immutably limited record
19293 -- or private type. If the pragma is given for a private type,
19294 -- the full type is similarly restricted (which is checked later
19295 -- in Freeze_Entity).
19297 if Is_Record_Type
(Typ
)
19298 and then not Is_Limited_View
(Typ
)
19301 ("pragma% can only apply to explicitly limited record type");
19303 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
19305 ("pragma% can only apply to a private type that is limited");
19307 elsif not Is_Record_Type
(Typ
)
19308 and then not Is_Private_Type
(Typ
)
19311 ("pragma% can only apply to limited record or private type");
19314 Record_Rep_Item
(Typ
, N
);
19315 end Simple_Storage_Pool_Type
;
19317 ----------------------
19318 -- Source_File_Name --
19319 ----------------------
19321 -- There are five forms for this pragma:
19323 -- pragma Source_File_Name (
19324 -- [UNIT_NAME =>] unit_NAME,
19325 -- BODY_FILE_NAME => STRING_LITERAL
19326 -- [, [INDEX =>] INTEGER_LITERAL]);
19328 -- pragma Source_File_Name (
19329 -- [UNIT_NAME =>] unit_NAME,
19330 -- SPEC_FILE_NAME => STRING_LITERAL
19331 -- [, [INDEX =>] INTEGER_LITERAL]);
19333 -- pragma Source_File_Name (
19334 -- BODY_FILE_NAME => STRING_LITERAL
19335 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19336 -- [, CASING => CASING_SPEC]);
19338 -- pragma Source_File_Name (
19339 -- SPEC_FILE_NAME => STRING_LITERAL
19340 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19341 -- [, CASING => CASING_SPEC]);
19343 -- pragma Source_File_Name (
19344 -- SUBUNIT_FILE_NAME => STRING_LITERAL
19345 -- [, DOT_REPLACEMENT => STRING_LITERAL]
19346 -- [, CASING => CASING_SPEC]);
19348 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
19350 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
19351 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
19352 -- only be used when no project file is used, while SFNP can only be
19353 -- used when a project file is used.
19355 -- No processing here. Processing was completed during parsing, since
19356 -- we need to have file names set as early as possible. Units are
19357 -- loaded well before semantic processing starts.
19359 -- The only processing we defer to this point is the check for
19360 -- correct placement.
19362 when Pragma_Source_File_Name
=>
19364 Check_Valid_Configuration_Pragma
;
19366 ------------------------------
19367 -- Source_File_Name_Project --
19368 ------------------------------
19370 -- See Source_File_Name for syntax
19372 -- No processing here. Processing was completed during parsing, since
19373 -- we need to have file names set as early as possible. Units are
19374 -- loaded well before semantic processing starts.
19376 -- The only processing we defer to this point is the check for
19377 -- correct placement.
19379 when Pragma_Source_File_Name_Project
=>
19381 Check_Valid_Configuration_Pragma
;
19383 -- Check that a pragma Source_File_Name_Project is used only in a
19384 -- configuration pragmas file.
19386 -- Pragmas Source_File_Name_Project should only be generated by
19387 -- the Project Manager in configuration pragmas files.
19389 -- This is really an ugly test. It seems to depend on some
19390 -- accidental and undocumented property. At the very least it
19391 -- needs to be documented, but it would be better to have a
19392 -- clean way of testing if we are in a configuration file???
19394 if Present
(Parent
(N
)) then
19396 ("pragma% can only appear in a configuration pragmas file");
19399 ----------------------
19400 -- Source_Reference --
19401 ----------------------
19403 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19405 -- Nothing to do, all processing completed in Par.Prag, since we need
19406 -- the information for possible parser messages that are output.
19408 when Pragma_Source_Reference
=>
19415 -- pragma SPARK_Mode [(On | Off)];
19417 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19418 Mode_Id
: SPARK_Mode_Type
;
19420 procedure Check_Pragma_Conformance
19421 (Context_Pragma
: Node_Id
;
19422 Entity_Pragma
: Node_Id
;
19423 Entity
: Entity_Id
);
19424 -- If Context_Pragma is not Empty, verify that the new pragma N
19425 -- is compatible with the pragma Context_Pragma that was inherited
19426 -- from the context:
19427 -- . if Context_Pragma is ON, then the new mode can be anything
19428 -- . if Context_Pragma is OFF, then the only allowed new mode is
19431 -- If Entity is not Empty, verify that the new pragma N is
19432 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19433 -- for Entity (which may be Empty):
19434 -- . if Entity_Pragma is ON, then the new mode can be anything
19435 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19437 -- . if Entity_Pragma is Empty, we always issue an error, as this
19438 -- corresponds to a case where a previous section of Entity
19439 -- had no SPARK_Mode set.
19441 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19442 -- Verify that pragma is applied to library-level entity E
19444 procedure Set_SPARK_Flags
;
19445 -- Sets SPARK_Mode from Mode_Id and SPARK_Mode_Pragma from N,
19446 -- and ensures that Dynamic_Elaboration_Checks are off if the
19447 -- call sets SPARK_Mode On.
19449 ------------------------------
19450 -- Check_Pragma_Conformance --
19451 ------------------------------
19453 procedure Check_Pragma_Conformance
19454 (Context_Pragma
: Node_Id
;
19455 Entity_Pragma
: Node_Id
;
19456 Entity
: Entity_Id
)
19458 Arg
: Node_Id
:= Arg1
;
19461 -- The current pragma may appear without an argument. If this
19462 -- is the case, associate all error messages with the pragma
19469 -- The mode of the current pragma is compared against that of
19470 -- an enclosing context.
19472 if Present
(Context_Pragma
) then
19473 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19475 -- Issue an error if the new mode is less restrictive than
19476 -- that of the context.
19478 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19479 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19482 ("cannot change SPARK_Mode from Off to On", Arg
);
19483 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19484 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg
);
19489 -- The mode of the current pragma is compared against that of
19490 -- an initial package/subprogram declaration.
19492 if Present
(Entity
) then
19494 -- Both the initial declaration and the completion carry
19495 -- SPARK_Mode pragmas.
19497 if Present
(Entity_Pragma
) then
19498 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
19500 -- Issue an error if the new mode is less restrictive
19501 -- than that of the initial declaration.
19503 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19504 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19506 Error_Msg_N
("incorrect use of SPARK_Mode", Arg
);
19507 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19509 ("\value Off was set for SPARK_Mode on&#",
19514 -- Otherwise the initial declaration lacks a SPARK_Mode
19515 -- pragma in which case the current pragma is illegal as
19516 -- it cannot "complete".
19519 Error_Msg_N
("incorrect use of SPARK_Mode", Arg
);
19520 Error_Msg_Sloc
:= Sloc
(Entity
);
19522 ("\no value was set for SPARK_Mode on&#",
19527 end Check_Pragma_Conformance
;
19529 --------------------------------
19530 -- Check_Library_Level_Entity --
19531 --------------------------------
19533 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19534 MsgF
: constant String := "incorrect placement of pragma%";
19537 if not Is_Library_Level_Entity
(E
) then
19538 Error_Msg_Name_1
:= Pname
;
19539 Error_Msg_N
(Fix_Error
(MsgF
), N
);
19541 if Ekind_In
(E
, E_Generic_Package
,
19546 ("\& is not a library-level package", N
, E
);
19549 ("\& is not a library-level subprogram", N
, E
);
19554 end Check_Library_Level_Entity
;
19556 ---------------------
19557 -- Set_SPARK_Flags --
19558 ---------------------
19560 procedure Set_SPARK_Flags
is
19562 SPARK_Mode
:= Mode_Id
;
19563 SPARK_Mode_Pragma
:= N
;
19565 if SPARK_Mode
= On
then
19566 Dynamic_Elaboration_Checks
:= False;
19568 end Set_SPARK_Flags
;
19572 Body_Id
: Entity_Id
;
19575 Spec_Id
: Entity_Id
;
19578 -- Start of processing for Do_SPARK_Mode
19581 -- When a SPARK_Mode pragma appears inside an instantiation whose
19582 -- enclosing context has SPARK_Mode set to "off", the pragma has
19583 -- no semantic effect.
19585 if Ignore_Pragma_SPARK_Mode
then
19586 Rewrite
(N
, Make_Null_Statement
(Loc
));
19592 Check_No_Identifiers
;
19593 Check_At_Most_N_Arguments
(1);
19595 -- Check the legality of the mode (no argument = ON)
19597 if Arg_Count
= 1 then
19598 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19599 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19604 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19605 Context
:= Parent
(N
);
19607 -- The pragma appears in a configuration pragmas file
19609 if No
(Context
) then
19610 Check_Valid_Configuration_Pragma
;
19612 if Present
(SPARK_Mode_Pragma
) then
19613 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19614 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19620 -- The pragma acts as a configuration pragma in a compilation unit
19622 -- pragma SPARK_Mode ...;
19623 -- package Pack is ...;
19625 elsif Nkind
(Context
) = N_Compilation_Unit
19626 and then List_Containing
(N
) = Context_Items
(Context
)
19628 Check_Valid_Configuration_Pragma
;
19631 -- Otherwise the placement of the pragma within the tree dictates
19632 -- its associated construct. Inspect the declarative list where
19633 -- the pragma resides to find a potential construct.
19637 while Present
(Stmt
) loop
19639 -- Skip prior pragmas, but check for duplicates
19641 if Nkind
(Stmt
) = N_Pragma
then
19642 if Pragma_Name
(Stmt
) = Pname
then
19643 Error_Msg_Name_1
:= Pname
;
19644 Error_Msg_Sloc
:= Sloc
(Stmt
);
19645 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19649 -- The pragma applies to a [generic] subprogram declaration.
19650 -- Note that this case covers an internally generated spec
19651 -- for a stand alone body.
19654 -- procedure Proc ...;
19655 -- pragma SPARK_Mode ..;
19657 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
19658 N_Subprogram_Declaration
)
19660 Spec_Id
:= Defining_Entity
(Stmt
);
19661 Check_Library_Level_Entity
(Spec_Id
);
19662 Check_Pragma_Conformance
19663 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19664 Entity_Pragma
=> Empty
,
19667 Set_SPARK_Pragma
(Spec_Id
, N
);
19668 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19671 -- Skip internally generated code
19673 elsif not Comes_From_Source
(Stmt
) then
19676 -- Otherwise the pragma does not apply to a legal construct
19677 -- or it does not appear at the top of a declarative or a
19678 -- statement list. Issue an error and stop the analysis.
19688 -- The pragma applies to a package or a subprogram that acts as
19689 -- a compilation unit.
19691 -- procedure Proc ...;
19692 -- pragma SPARK_Mode ...;
19694 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19695 Context
:= Unit
(Parent
(Context
));
19698 -- The pragma appears within package declarations
19700 if Nkind
(Context
) = N_Package_Specification
then
19701 Spec_Id
:= Defining_Entity
(Context
);
19702 Check_Library_Level_Entity
(Spec_Id
);
19704 -- The pragma is at the top of the visible declarations
19707 -- pragma SPARK_Mode ...;
19709 if List_Containing
(N
) = Visible_Declarations
(Context
) then
19710 Check_Pragma_Conformance
19711 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19712 Entity_Pragma
=> Empty
,
19716 Set_SPARK_Pragma
(Spec_Id
, N
);
19717 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19718 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19719 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19721 -- The pragma is at the top of the private declarations
19725 -- pragma SPARK_Mode ...;
19728 Check_Pragma_Conformance
19729 (Context_Pragma
=> Empty
,
19730 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19731 Entity
=> Spec_Id
);
19734 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19735 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19738 -- The pragma appears at the top of package body declarations
19740 -- package body Pack is
19741 -- pragma SPARK_Mode ...;
19743 elsif Nkind
(Context
) = N_Package_Body
then
19744 Spec_Id
:= Corresponding_Spec
(Context
);
19745 Body_Id
:= Defining_Entity
(Context
);
19746 Check_Library_Level_Entity
(Body_Id
);
19747 Check_Pragma_Conformance
19748 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19749 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19750 Entity
=> Spec_Id
);
19753 Set_SPARK_Pragma
(Body_Id
, N
);
19754 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19755 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19756 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19758 -- The pragma appears at the top of package body statements
19760 -- package body Pack is
19762 -- pragma SPARK_Mode;
19764 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
19765 and then Nkind
(Parent
(Context
)) = N_Package_Body
19767 Context
:= Parent
(Context
);
19768 Spec_Id
:= Corresponding_Spec
(Context
);
19769 Body_Id
:= Defining_Entity
(Context
);
19770 Check_Library_Level_Entity
(Body_Id
);
19771 Check_Pragma_Conformance
19772 (Context_Pragma
=> Empty
,
19773 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
19774 Entity
=> Body_Id
);
19777 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19778 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
19780 -- The pragma appeared as an aspect of a [generic] subprogram
19781 -- declaration that acts as a compilation unit.
19784 -- procedure Proc ...;
19785 -- pragma SPARK_Mode ...;
19787 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
19788 N_Subprogram_Declaration
)
19790 Spec_Id
:= Defining_Entity
(Context
);
19791 Check_Library_Level_Entity
(Spec_Id
);
19792 Check_Pragma_Conformance
19793 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19794 Entity_Pragma
=> Empty
,
19797 Set_SPARK_Pragma
(Spec_Id
, N
);
19798 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19800 -- The pragma appears at the top of subprogram body
19803 -- procedure Proc ... is
19804 -- pragma SPARK_Mode;
19806 elsif Nkind
(Context
) = N_Subprogram_Body
then
19807 Spec_Id
:= Corresponding_Spec
(Context
);
19808 Context
:= Specification
(Context
);
19809 Body_Id
:= Defining_Entity
(Context
);
19811 -- Ignore pragma when applied to the special body created
19812 -- for inlining, recognized by its internal name _Parent.
19814 if Chars
(Body_Id
) = Name_uParent
then
19818 Check_Library_Level_Entity
(Body_Id
);
19820 -- The body is a completion of a previous declaration
19822 if Present
(Spec_Id
) then
19823 Check_Pragma_Conformance
19824 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19825 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19826 Entity
=> Spec_Id
);
19828 -- The body acts as spec
19831 Check_Pragma_Conformance
19832 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19833 Entity_Pragma
=> Empty
,
19839 Set_SPARK_Pragma
(Body_Id
, N
);
19840 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19842 -- The pragma does not apply to a legal construct, issue error
19850 --------------------------------
19851 -- Static_Elaboration_Desired --
19852 --------------------------------
19854 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
19856 when Pragma_Static_Elaboration_Desired
=>
19858 Check_At_Most_N_Arguments
(1);
19860 if Is_Compilation_Unit
(Current_Scope
)
19861 and then Ekind
(Current_Scope
) = E_Package
19863 Set_Static_Elaboration_Desired
(Current_Scope
, True);
19865 Error_Pragma
("pragma% must apply to a library-level package");
19872 -- pragma Storage_Size (EXPRESSION);
19874 when Pragma_Storage_Size
=> Storage_Size
: declare
19875 P
: constant Node_Id
:= Parent
(N
);
19879 Check_No_Identifiers
;
19880 Check_Arg_Count
(1);
19882 -- The expression must be analyzed in the special manner described
19883 -- in "Handling of Default Expressions" in sem.ads.
19885 Arg
:= Get_Pragma_Arg
(Arg1
);
19886 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
19888 if not Is_OK_Static_Expression
(Arg
) then
19889 Check_Restriction
(Static_Storage_Size
, Arg
);
19892 if Nkind
(P
) /= N_Task_Definition
then
19897 if Has_Storage_Size_Pragma
(P
) then
19898 Error_Pragma
("duplicate pragma% not allowed");
19900 Set_Has_Storage_Size_Pragma
(P
, True);
19903 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
19911 -- pragma Storage_Unit (NUMERIC_LITERAL);
19913 -- Only permitted argument is System'Storage_Unit value
19915 when Pragma_Storage_Unit
=>
19916 Check_No_Identifiers
;
19917 Check_Arg_Count
(1);
19918 Check_Arg_Is_Integer_Literal
(Arg1
);
19920 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
19921 UI_From_Int
(Ttypes
.System_Storage_Unit
)
19923 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
19925 ("the only allowed argument for pragma% is ^", Arg1
);
19928 --------------------
19929 -- Stream_Convert --
19930 --------------------
19932 -- pragma Stream_Convert (
19933 -- [Entity =>] type_LOCAL_NAME,
19934 -- [Read =>] function_NAME,
19935 -- [Write =>] function NAME);
19937 when Pragma_Stream_Convert
=> Stream_Convert
: declare
19939 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
19940 -- Check that the given argument is the name of a local function
19941 -- of one argument that is not overloaded earlier in the current
19942 -- local scope. A check is also made that the argument is a
19943 -- function with one parameter.
19945 --------------------------------------
19946 -- Check_OK_Stream_Convert_Function --
19947 --------------------------------------
19949 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
19953 Check_Arg_Is_Local_Name
(Arg
);
19954 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
19956 if Has_Homonym
(Ent
) then
19958 ("argument for pragma% may not be overloaded", Arg
);
19961 if Ekind
(Ent
) /= E_Function
19962 or else No
(First_Formal
(Ent
))
19963 or else Present
(Next_Formal
(First_Formal
(Ent
)))
19966 ("argument for pragma% must be function of one argument",
19969 end Check_OK_Stream_Convert_Function
;
19971 -- Start of processing for Stream_Convert
19975 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
19976 Check_Arg_Count
(3);
19977 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19978 Check_Optional_Identifier
(Arg2
, Name_Read
);
19979 Check_Optional_Identifier
(Arg3
, Name_Write
);
19980 Check_Arg_Is_Local_Name
(Arg1
);
19981 Check_OK_Stream_Convert_Function
(Arg2
);
19982 Check_OK_Stream_Convert_Function
(Arg3
);
19985 Typ
: constant Entity_Id
:=
19986 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
19987 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
19988 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
19991 Check_First_Subtype
(Arg1
);
19993 -- Check for too early or too late. Note that we don't enforce
19994 -- the rule about primitive operations in this case, since, as
19995 -- is the case for explicit stream attributes themselves, these
19996 -- restrictions are not appropriate. Note that the chaining of
19997 -- the pragma by Rep_Item_Too_Late is actually the critical
19998 -- processing done for this pragma.
20000 if Rep_Item_Too_Early
(Typ
, N
)
20002 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
20007 -- Return if previous error
20009 if Etype
(Typ
) = Any_Type
20011 Etype
(Read
) = Any_Type
20013 Etype
(Write
) = Any_Type
20020 if Underlying_Type
(Etype
(Read
)) /= Typ
then
20022 ("incorrect return type for function&", Arg2
);
20025 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
20027 ("incorrect parameter type for function&", Arg3
);
20030 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
20031 Underlying_Type
(Etype
(Write
))
20034 ("result type of & does not match Read parameter type",
20038 end Stream_Convert
;
20044 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20046 -- This is processed by the parser since some of the style checks
20047 -- take place during source scanning and parsing. This means that
20048 -- we don't need to issue error messages here.
20050 when Pragma_Style_Checks
=> Style_Checks
: declare
20051 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20057 Check_No_Identifiers
;
20059 -- Two argument form
20061 if Arg_Count
= 2 then
20062 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20069 E_Id
:= Get_Pragma_Arg
(Arg2
);
20072 if not Is_Entity_Name
(E_Id
) then
20074 ("second argument of pragma% must be entity name",
20078 E
:= Entity
(E_Id
);
20080 if not Ignore_Style_Checks_Pragmas
then
20085 Set_Suppress_Style_Checks
20086 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
20087 exit when No
(Homonym
(E
));
20094 -- One argument form
20097 Check_Arg_Count
(1);
20099 if Nkind
(A
) = N_String_Literal
then
20103 Slen
: constant Natural := Natural (String_Length
(S
));
20104 Options
: String (1 .. Slen
);
20110 C
:= Get_String_Char
(S
, Int
(J
));
20111 exit when not In_Character_Range
(C
);
20112 Options
(J
) := Get_Character
(C
);
20114 -- If at end of string, set options. As per discussion
20115 -- above, no need to check for errors, since we issued
20116 -- them in the parser.
20119 if not Ignore_Style_Checks_Pragmas
then
20120 Set_Style_Check_Options
(Options
);
20130 elsif Nkind
(A
) = N_Identifier
then
20131 if Chars
(A
) = Name_All_Checks
then
20132 if not Ignore_Style_Checks_Pragmas
then
20134 Set_GNAT_Style_Check_Options
;
20136 Set_Default_Style_Check_Options
;
20140 elsif Chars
(A
) = Name_On
then
20141 if not Ignore_Style_Checks_Pragmas
then
20142 Style_Check
:= True;
20145 elsif Chars
(A
) = Name_Off
then
20146 if not Ignore_Style_Checks_Pragmas
then
20147 Style_Check
:= False;
20158 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
20160 when Pragma_Subtitle
=>
20162 Check_Arg_Count
(1);
20163 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
20164 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20171 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
20173 when Pragma_Suppress
=>
20174 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
20180 -- pragma Suppress_All;
20182 -- The only check made here is that the pragma has no arguments.
20183 -- There are no placement rules, and the processing required (setting
20184 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
20185 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
20186 -- then creates and inserts a pragma Suppress (All_Checks).
20188 when Pragma_Suppress_All
=>
20190 Check_Arg_Count
(0);
20192 -------------------------
20193 -- Suppress_Debug_Info --
20194 -------------------------
20196 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
20198 when Pragma_Suppress_Debug_Info
=>
20200 Check_Arg_Count
(1);
20201 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20202 Check_Arg_Is_Local_Name
(Arg1
);
20203 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
20205 ----------------------------------
20206 -- Suppress_Exception_Locations --
20207 ----------------------------------
20209 -- pragma Suppress_Exception_Locations;
20211 when Pragma_Suppress_Exception_Locations
=>
20213 Check_Arg_Count
(0);
20214 Check_Valid_Configuration_Pragma
;
20215 Exception_Locations_Suppressed
:= True;
20217 -----------------------------
20218 -- Suppress_Initialization --
20219 -----------------------------
20221 -- pragma Suppress_Initialization ([Entity =>] type_Name);
20223 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
20229 Check_Arg_Count
(1);
20230 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20231 Check_Arg_Is_Local_Name
(Arg1
);
20233 E_Id
:= Get_Pragma_Arg
(Arg1
);
20235 if Etype
(E_Id
) = Any_Type
then
20239 E
:= Entity
(E_Id
);
20241 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
20243 ("pragma% requires variable, type or subtype", Arg1
);
20246 if Rep_Item_Too_Early
(E
, N
)
20248 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
20253 -- For incomplete/private type, set flag on full view
20255 if Is_Incomplete_Or_Private_Type
(E
) then
20256 if No
(Full_View
(Base_Type
(E
))) then
20258 ("argument of pragma% cannot be an incomplete type", Arg1
);
20260 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
20263 -- For first subtype, set flag on base type
20265 elsif Is_First_Subtype
(E
) then
20266 Set_Suppress_Initialization
(Base_Type
(E
));
20268 -- For other than first subtype, set flag on subtype or variable
20271 Set_Suppress_Initialization
(E
);
20279 -- pragma System_Name (DIRECT_NAME);
20281 -- Syntax check: one argument, which must be the identifier GNAT or
20282 -- the identifier GCC, no other identifiers are acceptable.
20284 when Pragma_System_Name
=>
20286 Check_No_Identifiers
;
20287 Check_Arg_Count
(1);
20288 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
20290 -----------------------------
20291 -- Task_Dispatching_Policy --
20292 -----------------------------
20294 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
20296 when Pragma_Task_Dispatching_Policy
=> declare
20300 Check_Ada_83_Warning
;
20301 Check_Arg_Count
(1);
20302 Check_No_Identifiers
;
20303 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20304 Check_Valid_Configuration_Pragma
;
20305 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20306 DP
:= Fold_Upper
(Name_Buffer
(1));
20308 if Task_Dispatching_Policy
/= ' '
20309 and then Task_Dispatching_Policy
/= DP
20311 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20313 ("task dispatching policy incompatible with policy#");
20315 -- Set new policy, but always preserve System_Location since we
20316 -- like the error message with the run time name.
20319 Task_Dispatching_Policy
:= DP
;
20321 if Task_Dispatching_Policy_Sloc
/= System_Location
then
20322 Task_Dispatching_Policy_Sloc
:= Loc
;
20331 -- pragma Task_Info (EXPRESSION);
20333 when Pragma_Task_Info
=> Task_Info
: declare
20334 P
: constant Node_Id
:= Parent
(N
);
20340 if Warn_On_Obsolescent_Feature
then
20342 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
20343 & "instead?j?", N
);
20346 if Nkind
(P
) /= N_Task_Definition
then
20347 Error_Pragma
("pragma% must appear in task definition");
20350 Check_No_Identifiers
;
20351 Check_Arg_Count
(1);
20353 Analyze_And_Resolve
20354 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
20356 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
20360 Ent
:= Defining_Identifier
(Parent
(P
));
20362 -- Check duplicate pragma before we chain the pragma in the Rep
20363 -- Item chain of Ent.
20366 (Ent
, Name_Task_Info
, Check_Parents
=> False)
20368 Error_Pragma
("duplicate pragma% not allowed");
20371 Record_Rep_Item
(Ent
, N
);
20378 -- pragma Task_Name (string_EXPRESSION);
20380 when Pragma_Task_Name
=> Task_Name
: declare
20381 P
: constant Node_Id
:= Parent
(N
);
20386 Check_No_Identifiers
;
20387 Check_Arg_Count
(1);
20389 Arg
:= Get_Pragma_Arg
(Arg1
);
20391 -- The expression is used in the call to Create_Task, and must be
20392 -- expanded there, not in the context of the current spec. It must
20393 -- however be analyzed to capture global references, in case it
20394 -- appears in a generic context.
20396 Preanalyze_And_Resolve
(Arg
, Standard_String
);
20398 if Nkind
(P
) /= N_Task_Definition
then
20402 Ent
:= Defining_Identifier
(Parent
(P
));
20404 -- Check duplicate pragma before we chain the pragma in the Rep
20405 -- Item chain of Ent.
20408 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20410 Error_Pragma
("duplicate pragma% not allowed");
20413 Record_Rep_Item
(Ent
, N
);
20420 -- pragma Task_Storage (
20421 -- [Task_Type =>] LOCAL_NAME,
20422 -- [Top_Guard =>] static_integer_EXPRESSION);
20424 when Pragma_Task_Storage
=> Task_Storage
: declare
20425 Args
: Args_List
(1 .. 2);
20426 Names
: constant Name_List
(1 .. 2) := (
20430 Task_Type
: Node_Id
renames Args
(1);
20431 Top_Guard
: Node_Id
renames Args
(2);
20437 Gather_Associations
(Names
, Args
);
20439 if No
(Task_Type
) then
20441 ("missing task_type argument for pragma%");
20444 Check_Arg_Is_Local_Name
(Task_Type
);
20446 Ent
:= Entity
(Task_Type
);
20448 if not Is_Task_Type
(Ent
) then
20450 ("argument for pragma% must be task type", Task_Type
);
20453 if No
(Top_Guard
) then
20455 ("pragma% takes two arguments", Task_Type
);
20457 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
20460 Check_First_Subtype
(Task_Type
);
20462 if Rep_Item_Too_Late
(Ent
, N
) then
20471 -- pragma Test_Case
20472 -- ([Name =>] Static_String_EXPRESSION
20473 -- ,[Mode =>] MODE_TYPE
20474 -- [, Requires => Boolean_EXPRESSION]
20475 -- [, Ensures => Boolean_EXPRESSION]);
20477 -- MODE_TYPE ::= Nominal | Robustness
20479 -- Characteristics:
20481 -- * Analysis - The annotation undergoes initial checks to verify
20482 -- the legal placement and context. Secondary checks preanalyze the
20485 -- Analyze_Test_Case_In_Decl_Part
20487 -- * Expansion - None.
20489 -- * Template - The annotation utilizes the generic template of the
20490 -- related subprogram when it is:
20492 -- aspect on subprogram declaration
20494 -- The annotation must prepare its own template when it is:
20496 -- pragma on subprogram declaration
20498 -- * Globals - Capture of global references must occur after full
20501 -- * Instance - The annotation is instantiated automatically when
20502 -- the related generic subprogram is instantiated except for the
20503 -- "pragma on subprogram declaration" case. In that scenario the
20504 -- annotation must instantiate itself.
20506 when Pragma_Test_Case
=> Test_Case
: declare
20507 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
20508 -- Ensure that the contract of subprogram Subp_Id does not contain
20509 -- another Test_Case pragma with the same Name as the current one.
20511 -------------------------
20512 -- Check_Distinct_Name --
20513 -------------------------
20515 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
20516 Items
: constant Node_Id
:= Contract
(Subp_Id
);
20517 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
20521 -- Inspect all Test_Case pragma of the related subprogram
20522 -- looking for one with a duplicate "Name" argument.
20524 if Present
(Items
) then
20525 Prag
:= Contract_Test_Cases
(Items
);
20526 while Present
(Prag
) loop
20527 if Pragma_Name
(Prag
) = Name_Test_Case
20528 and then String_Equal
20529 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
20531 Error_Msg_Sloc
:= Sloc
(Prag
);
20532 Error_Pragma
("name for pragma % is already used #");
20535 Prag
:= Next_Pragma
(Prag
);
20538 end Check_Distinct_Name
;
20542 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
20545 Subp_Decl
: Node_Id
;
20546 Subp_Id
: Entity_Id
;
20548 -- Start of processing for Test_Case
20552 Check_At_Least_N_Arguments
(2);
20553 Check_At_Most_N_Arguments
(4);
20555 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
20559 Check_Optional_Identifier
(Arg1
, Name_Name
);
20560 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20564 Check_Optional_Identifier
(Arg2
, Name_Mode
);
20565 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
20567 -- Arguments "Requires" and "Ensures"
20569 if Present
(Arg3
) then
20570 if Present
(Arg4
) then
20571 Check_Identifier
(Arg3
, Name_Requires
);
20572 Check_Identifier
(Arg4
, Name_Ensures
);
20574 Check_Identifier_Is_One_Of
20575 (Arg3
, Name_Requires
, Name_Ensures
);
20579 -- Pragma Test_Case must be associated with a subprogram declared
20580 -- in a library-level package. First determine whether the current
20581 -- compilation unit is a legal context.
20583 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
20584 N_Generic_Package_Declaration
)
20588 -- Otherwise the placement is illegal
20595 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
20597 -- Find the enclosing context
20599 Context
:= Parent
(Subp_Decl
);
20601 if Present
(Context
) then
20602 Context
:= Parent
(Context
);
20605 -- Verify the placement of the pragma
20607 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
20609 ("pragma % cannot be applied to abstract subprogram");
20612 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
20613 Error_Pragma
("pragma % cannot be applied to entry");
20616 -- The context is a [generic] subprogram declared at the top level
20617 -- of the [generic] package unit.
20619 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
20620 N_Subprogram_Declaration
)
20621 and then Present
(Context
)
20622 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
20623 N_Package_Declaration
)
20625 Subp_Id
:= Defining_Entity
(Subp_Decl
);
20627 -- Otherwise the placement is illegal
20634 -- Preanalyze the original aspect argument "Name" for ASIS or for
20635 -- a generic subprogram to properly capture global references.
20637 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
20638 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
20640 if Present
(Asp_Arg
) then
20642 -- The argument appears with an identifier in association
20645 if Nkind
(Asp_Arg
) = N_Component_Association
then
20646 Asp_Arg
:= Expression
(Asp_Arg
);
20649 Check_Expr_Is_OK_Static_Expression
20650 (Asp_Arg
, Standard_String
);
20654 -- Ensure that the all Test_Case pragmas of the related subprogram
20655 -- have distinct names.
20657 Check_Distinct_Name
(Subp_Id
);
20659 -- Fully analyze the pragma when it appears inside a subprogram
20660 -- body because it cannot benefit from forward references.
20662 if Nkind_In
(Subp_Decl
, N_Subprogram_Body
,
20663 N_Subprogram_Body_Stub
)
20665 Analyze_Test_Case_In_Decl_Part
(N
);
20668 -- Chain the pragma on the contract for further processing by
20669 -- Analyze_Test_Case_In_Decl_Part.
20671 Add_Contract_Item
(N
, Subp_Id
);
20674 --------------------------
20675 -- Thread_Local_Storage --
20676 --------------------------
20678 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20680 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20686 Check_Arg_Count
(1);
20687 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20688 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20690 Id
:= Get_Pragma_Arg
(Arg1
);
20693 if not Is_Entity_Name
(Id
)
20694 or else Ekind
(Entity
(Id
)) /= E_Variable
20696 Error_Pragma_Arg
("local variable name required", Arg1
);
20701 if Rep_Item_Too_Early
(E
, N
)
20702 or else Rep_Item_Too_Late
(E
, N
)
20707 Set_Has_Pragma_Thread_Local_Storage
(E
);
20708 Set_Has_Gigi_Rep_Item
(E
);
20709 end Thread_Local_Storage
;
20715 -- pragma Time_Slice (static_duration_EXPRESSION);
20717 when Pragma_Time_Slice
=> Time_Slice
: declare
20723 Check_Arg_Count
(1);
20724 Check_No_Identifiers
;
20725 Check_In_Main_Program
;
20726 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
20728 if not Error_Posted
(Arg1
) then
20730 while Present
(Nod
) loop
20731 if Nkind
(Nod
) = N_Pragma
20732 and then Pragma_Name
(Nod
) = Name_Time_Slice
20734 Error_Msg_Name_1
:= Pname
;
20735 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20742 -- Process only if in main unit
20744 if Get_Source_Unit
(Loc
) = Main_Unit
then
20745 Opt
.Time_Slice_Set
:= True;
20746 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20748 if Val
<= Ureal_0
then
20749 Opt
.Time_Slice_Value
:= 0;
20751 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20752 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20755 Opt
.Time_Slice_Value
:=
20756 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20765 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20767 -- TITLING_OPTION ::=
20768 -- [Title =>] STRING_LITERAL
20769 -- | [Subtitle =>] STRING_LITERAL
20771 when Pragma_Title
=> Title
: declare
20772 Args
: Args_List
(1 .. 2);
20773 Names
: constant Name_List
(1 .. 2) := (
20779 Gather_Associations
(Names
, Args
);
20782 for J
in 1 .. 2 loop
20783 if Present
(Args
(J
)) then
20784 Check_Arg_Is_OK_Static_Expression
20785 (Args
(J
), Standard_String
);
20790 ----------------------------
20791 -- Type_Invariant[_Class] --
20792 ----------------------------
20794 -- pragma Type_Invariant[_Class]
20795 -- ([Entity =>] type_LOCAL_NAME,
20796 -- [Check =>] EXPRESSION);
20798 when Pragma_Type_Invariant |
20799 Pragma_Type_Invariant_Class
=>
20800 Type_Invariant
: declare
20801 I_Pragma
: Node_Id
;
20804 Check_Arg_Count
(2);
20806 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20807 -- setting Class_Present for the Type_Invariant_Class case.
20809 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20810 I_Pragma
:= New_Copy
(N
);
20811 Set_Pragma_Identifier
20812 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20813 Rewrite
(N
, I_Pragma
);
20814 Set_Analyzed
(N
, False);
20816 end Type_Invariant
;
20818 ---------------------
20819 -- Unchecked_Union --
20820 ---------------------
20822 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20824 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20825 Assoc
: constant Node_Id
:= Arg1
;
20826 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20836 Check_No_Identifiers
;
20837 Check_Arg_Count
(1);
20838 Check_Arg_Is_Local_Name
(Arg1
);
20840 Find_Type
(Type_Id
);
20842 Typ
:= Entity
(Type_Id
);
20845 or else Rep_Item_Too_Early
(Typ
, N
)
20849 Typ
:= Underlying_Type
(Typ
);
20852 if Rep_Item_Too_Late
(Typ
, N
) then
20856 Check_First_Subtype
(Arg1
);
20858 -- Note remaining cases are references to a type in the current
20859 -- declarative part. If we find an error, we post the error on
20860 -- the relevant type declaration at an appropriate point.
20862 if not Is_Record_Type
(Typ
) then
20863 Error_Msg_N
("unchecked union must be record type", Typ
);
20866 elsif Is_Tagged_Type
(Typ
) then
20867 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20870 elsif not Has_Discriminants
(Typ
) then
20872 ("unchecked union must have one discriminant", Typ
);
20875 -- Note: in previous versions of GNAT we used to check for limited
20876 -- types and give an error, but in fact the standard does allow
20877 -- Unchecked_Union on limited types, so this check was removed.
20879 -- Similarly, GNAT used to require that all discriminants have
20880 -- default values, but this is not mandated by the RM.
20882 -- Proceed with basic error checks completed
20885 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20886 Clist
:= Component_List
(Tdef
);
20888 -- Check presence of component list and variant part
20890 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20892 ("unchecked union must have variant part", Tdef
);
20896 -- Check components
20898 Comp
:= First
(Component_Items
(Clist
));
20899 while Present
(Comp
) loop
20900 Check_Component
(Comp
, Typ
);
20904 -- Check variant part
20906 Vpart
:= Variant_Part
(Clist
);
20908 Variant
:= First
(Variants
(Vpart
));
20909 while Present
(Variant
) loop
20910 Check_Variant
(Variant
, Typ
);
20915 Set_Is_Unchecked_Union
(Typ
);
20916 Set_Convention
(Typ
, Convention_C
);
20917 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20918 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20919 end Unchecked_Union
;
20921 ------------------------
20922 -- Unimplemented_Unit --
20923 ------------------------
20925 -- pragma Unimplemented_Unit;
20927 -- Note: this only gives an error if we are generating code, or if
20928 -- we are in a generic library unit (where the pragma appears in the
20929 -- body, not in the spec).
20931 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20932 Cunitent
: constant Entity_Id
:=
20933 Cunit_Entity
(Get_Source_Unit
(Loc
));
20934 Ent_Kind
: constant Entity_Kind
:=
20939 Check_Arg_Count
(0);
20941 if Operating_Mode
= Generate_Code
20942 or else Ent_Kind
= E_Generic_Function
20943 or else Ent_Kind
= E_Generic_Procedure
20944 or else Ent_Kind
= E_Generic_Package
20946 Get_Name_String
(Chars
(Cunitent
));
20947 Set_Casing
(Mixed_Case
);
20948 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20949 Write_Str
(" is not supported in this configuration");
20951 raise Unrecoverable_Error
;
20953 end Unimplemented_Unit
;
20955 ------------------------
20956 -- Universal_Aliasing --
20957 ------------------------
20959 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20961 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20966 Check_Arg_Count
(1);
20967 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20968 Check_Arg_Is_Local_Name
(Arg1
);
20969 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20971 if E_Id
= Any_Type
then
20973 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20974 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20977 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20978 Record_Rep_Item
(E_Id
, N
);
20979 end Universal_Alias
;
20981 --------------------
20982 -- Universal_Data --
20983 --------------------
20985 -- pragma Universal_Data [(library_unit_NAME)];
20987 when Pragma_Universal_Data
=>
20990 -- If this is a configuration pragma, then set the universal
20991 -- addressing option, otherwise confirm that the pragma satisfies
20992 -- the requirements of library unit pragma placement and leave it
20993 -- to the GNAAMP back end to detect the pragma (avoids transitive
20994 -- setting of the option due to withed units).
20996 if Is_Configuration_Pragma
then
20997 Universal_Addressing_On_AAMP
:= True;
20999 Check_Valid_Library_Unit_Pragma
;
21002 if not AAMP_On_Target
then
21003 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
21010 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
21012 when Pragma_Unmodified
=> Unmodified
: declare
21013 Arg_Node
: Node_Id
;
21014 Arg_Expr
: Node_Id
;
21015 Arg_Ent
: Entity_Id
;
21019 Check_At_Least_N_Arguments
(1);
21021 -- Loop through arguments
21024 while Present
(Arg_Node
) loop
21025 Check_No_Identifier
(Arg_Node
);
21027 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
21028 -- in fact generate reference, so that the entity will have a
21029 -- reference, which will inhibit any warnings about it not
21030 -- being referenced, and also properly show up in the ali file
21031 -- as a reference. But this reference is recorded before the
21032 -- Has_Pragma_Unreferenced flag is set, so that no warning is
21033 -- generated for this reference.
21035 Check_Arg_Is_Local_Name
(Arg_Node
);
21036 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21038 if Is_Entity_Name
(Arg_Expr
) then
21039 Arg_Ent
:= Entity
(Arg_Expr
);
21041 if not Is_Assignable
(Arg_Ent
) then
21043 ("pragma% can only be applied to a variable",
21046 Set_Has_Pragma_Unmodified
(Arg_Ent
);
21058 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
21060 -- or when used in a context clause:
21062 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
21064 when Pragma_Unreferenced
=> Unreferenced
: declare
21065 Arg_Node
: Node_Id
;
21066 Arg_Expr
: Node_Id
;
21067 Arg_Ent
: Entity_Id
;
21072 Check_At_Least_N_Arguments
(1);
21074 -- Check case of appearing within context clause
21076 if Is_In_Context_Clause
then
21078 -- The arguments must all be units mentioned in a with clause
21079 -- in the same context clause. Note we already checked (in
21080 -- Par.Prag) that the arguments are either identifiers or
21081 -- selected components.
21084 while Present
(Arg_Node
) loop
21085 Citem
:= First
(List_Containing
(N
));
21086 while Citem
/= N
loop
21087 if Nkind
(Citem
) = N_With_Clause
21089 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
21091 Set_Has_Pragma_Unreferenced
21094 (Library_Unit
(Citem
))));
21096 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
21105 ("argument of pragma% is not withed unit", Arg_Node
);
21111 -- Case of not in list of context items
21115 while Present
(Arg_Node
) loop
21116 Check_No_Identifier
(Arg_Node
);
21118 -- Note: the analyze call done by Check_Arg_Is_Local_Name
21119 -- will in fact generate reference, so that the entity will
21120 -- have a reference, which will inhibit any warnings about
21121 -- it not being referenced, and also properly show up in the
21122 -- ali file as a reference. But this reference is recorded
21123 -- before the Has_Pragma_Unreferenced flag is set, so that
21124 -- no warning is generated for this reference.
21126 Check_Arg_Is_Local_Name
(Arg_Node
);
21127 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21129 if Is_Entity_Name
(Arg_Expr
) then
21130 Arg_Ent
:= Entity
(Arg_Expr
);
21132 -- If the entity is overloaded, the pragma applies to the
21133 -- most recent overloading, as documented. In this case,
21134 -- name resolution does not generate a reference, so it
21135 -- must be done here explicitly.
21137 if Is_Overloaded
(Arg_Expr
) then
21138 Generate_Reference
(Arg_Ent
, N
);
21141 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
21149 --------------------------
21150 -- Unreferenced_Objects --
21151 --------------------------
21153 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
21155 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
21156 Arg_Node
: Node_Id
;
21157 Arg_Expr
: Node_Id
;
21161 Check_At_Least_N_Arguments
(1);
21164 while Present
(Arg_Node
) loop
21165 Check_No_Identifier
(Arg_Node
);
21166 Check_Arg_Is_Local_Name
(Arg_Node
);
21167 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
21169 if not Is_Entity_Name
(Arg_Expr
)
21170 or else not Is_Type
(Entity
(Arg_Expr
))
21173 ("argument for pragma% must be type or subtype", Arg_Node
);
21176 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
21179 end Unreferenced_Objects
;
21181 ------------------------------
21182 -- Unreserve_All_Interrupts --
21183 ------------------------------
21185 -- pragma Unreserve_All_Interrupts;
21187 when Pragma_Unreserve_All_Interrupts
=>
21189 Check_Arg_Count
(0);
21191 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
21192 Unreserve_All_Interrupts
:= True;
21199 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
21201 when Pragma_Unsuppress
=>
21203 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
21205 ----------------------------
21206 -- Unevaluated_Use_Of_Old --
21207 ----------------------------
21209 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
21211 when Pragma_Unevaluated_Use_Of_Old
=>
21213 Check_Arg_Count
(1);
21214 Check_No_Identifiers
;
21215 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
21217 -- Suppress/Unsuppress can appear as a configuration pragma, or in
21218 -- a declarative part or a package spec.
21220 if not Is_Configuration_Pragma
then
21221 Check_Is_In_Decl_Part_Or_Package_Spec
;
21224 -- Store proper setting of Uneval_Old
21226 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21227 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
21229 -------------------
21230 -- Use_VADS_Size --
21231 -------------------
21233 -- pragma Use_VADS_Size;
21235 when Pragma_Use_VADS_Size
=>
21237 Check_Arg_Count
(0);
21238 Check_Valid_Configuration_Pragma
;
21239 Use_VADS_Size
:= True;
21241 ---------------------
21242 -- Validity_Checks --
21243 ---------------------
21245 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21247 when Pragma_Validity_Checks
=> Validity_Checks
: declare
21248 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21254 Check_Arg_Count
(1);
21255 Check_No_Identifiers
;
21257 -- Pragma always active unless in CodePeer or GNATprove modes,
21258 -- which use a fixed configuration of validity checks.
21260 if not (CodePeer_Mode
or GNATprove_Mode
) then
21261 if Nkind
(A
) = N_String_Literal
then
21265 Slen
: constant Natural := Natural (String_Length
(S
));
21266 Options
: String (1 .. Slen
);
21270 -- Couldn't we use a for loop here over Options'Range???
21274 C
:= Get_String_Char
(S
, Int
(J
));
21276 -- This is a weird test, it skips setting validity
21277 -- checks entirely if any element of S is out of
21278 -- range of Character, what is that about ???
21280 exit when not In_Character_Range
(C
);
21281 Options
(J
) := Get_Character
(C
);
21284 Set_Validity_Check_Options
(Options
);
21292 elsif Nkind
(A
) = N_Identifier
then
21293 if Chars
(A
) = Name_All_Checks
then
21294 Set_Validity_Check_Options
("a");
21295 elsif Chars
(A
) = Name_On
then
21296 Validity_Checks_On
:= True;
21297 elsif Chars
(A
) = Name_Off
then
21298 Validity_Checks_On
:= False;
21302 end Validity_Checks
;
21308 -- pragma Volatile (LOCAL_NAME);
21310 when Pragma_Volatile
=>
21311 Process_Atomic_Independent_Shared_Volatile
;
21313 --------------------------
21314 -- Volatile_Full_Access --
21315 --------------------------
21317 -- pragma Volatile_Full_Access (LOCAL_NAME);
21319 when Pragma_Volatile_Full_Access
=>
21321 Process_Atomic_Independent_Shared_Volatile
;
21323 -------------------------
21324 -- Volatile_Components --
21325 -------------------------
21327 -- pragma Volatile_Components (array_LOCAL_NAME);
21329 -- Volatile is handled by the same circuit as Atomic_Components
21331 ----------------------
21332 -- Warning_As_Error --
21333 ----------------------
21335 -- pragma Warning_As_Error (static_string_EXPRESSION);
21337 when Pragma_Warning_As_Error
=>
21339 Check_Arg_Count
(1);
21340 Check_No_Identifiers
;
21341 Check_Valid_Configuration_Pragma
;
21343 if not Is_Static_String_Expression
(Arg1
) then
21345 ("argument of pragma% must be static string expression",
21348 -- OK static string expression
21351 Acquire_Warning_Match_String
(Arg1
);
21352 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
21353 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
21354 new String'(Name_Buffer (1 .. Name_Len));
21361 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
21363 -- DETAILS ::= On | Off
21364 -- DETAILS ::= On | Off, local_NAME
21365 -- DETAILS ::= static_string_EXPRESSION
21366 -- DETAILS ::= On | Off, static_string_EXPRESSION
21368 -- TOOL_NAME ::= GNAT | GNATProve
21370 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
21372 -- Note: If the first argument matches an allowed tool name, it is
21373 -- always considered to be a tool name, even if there is a string
21374 -- variable of that name.
21376 -- Note if the second argument of DETAILS is a local_NAME then the
21377 -- second form is always understood. If the intention is to use
21378 -- the fourth form, then you can write NAME & "" to force the
21379 -- intepretation as a static_string_EXPRESSION.
21381 when Pragma_Warnings => Warnings : declare
21382 Reason : String_Id;
21386 Check_At_Least_N_Arguments (1);
21388 -- See if last argument is labeled Reason. If so, make sure we
21389 -- have a string literal or a concatenation of string literals,
21390 -- and acquire the REASON string. Then remove the REASON argument
21391 -- by decreasing Num_Args by one; Remaining processing looks only
21392 -- at first Num_Args arguments).
21395 Last_Arg : constant Node_Id :=
21396 Last (Pragma_Argument_Associations (N));
21399 if Nkind (Last_Arg) = N_Pragma_Argument_Association
21400 and then Chars (Last_Arg) = Name_Reason
21403 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
21404 Reason := End_String;
21405 Arg_Count := Arg_Count - 1;
21407 -- Not allowed in compiler units (bootstrap issues)
21409 Check_Compiler_Unit ("Reason for pragma Warnings", N);
21411 -- No REASON string, set null string as reason
21414 Reason := Null_String_Id;
21418 -- Now proceed with REASON taken care of and eliminated
21420 Check_No_Identifiers;
21422 -- If debug flag -gnatd.i is set, pragma is ignored
21424 if Debug_Flag_Dot_I then
21428 -- Process various forms of the pragma
21431 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
21432 Shifted_Args : List_Id;
21435 -- See if first argument is a tool name, currently either
21436 -- GNAT or GNATprove. If so, either ignore the pragma if the
21437 -- tool used does not match, or continue as if no tool name
21438 -- was given otherwise, by shifting the arguments.
21440 if Nkind (Argx) = N_Identifier
21441 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
21443 if Chars (Argx) = Name_Gnat then
21444 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
21445 Rewrite (N, Make_Null_Statement (Loc));
21450 elsif Chars (Argx) = Name_Gnatprove then
21451 if not GNATprove_Mode then
21452 Rewrite (N, Make_Null_Statement (Loc));
21458 raise Program_Error;
21461 -- At this point, the pragma Warnings applies to the tool,
21462 -- so continue with shifted arguments.
21464 Arg_Count := Arg_Count - 1;
21466 if Arg_Count = 1 then
21467 Shifted_Args := New_List (New_Copy (Arg2));
21468 elsif Arg_Count = 2 then
21469 Shifted_Args := New_List (New_Copy (Arg2),
21471 elsif Arg_Count = 3 then
21472 Shifted_Args := New_List (New_Copy (Arg2),
21476 raise Program_Error;
21481 Chars => Name_Warnings,
21482 Pragma_Argument_Associations => Shifted_Args));
21487 -- One argument case
21489 if Arg_Count = 1 then
21491 -- On/Off one argument case was processed by parser
21493 if Nkind (Argx) = N_Identifier
21494 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21498 -- One argument case must be ON/OFF or static string expr
21500 elsif not Is_Static_String_Expression (Arg1) then
21502 ("argument of pragma% must be On/Off or static string "
21503 & "expression", Arg1);
21505 -- One argument string expression case
21509 Lit : constant Node_Id := Expr_Value_S (Argx);
21510 Str : constant String_Id := Strval (Lit);
21511 Len : constant Nat := String_Length (Str);
21519 while J <= Len loop
21520 C := Get_String_Char (Str, J);
21521 OK := In_Character_Range (C);
21524 Chr := Get_Character (C);
21526 -- Dash case: only -Wxxx is accepted
21533 C := Get_String_Char (Str, J);
21534 Chr := Get_Character (C);
21535 exit when Chr = 'W
';
21540 elsif J < Len and then Chr = '.' then
21542 C := Get_String_Char (Str, J);
21543 Chr := Get_Character (C);
21545 if not Set_Dot_Warning_Switch (Chr) then
21547 ("invalid warning switch character "
21548 & '.' & Chr, Arg1);
21554 OK := Set_Warning_Switch (Chr);
21560 ("invalid warning switch character " & Chr,
21569 -- Two or more arguments (must be two)
21572 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21573 Check_Arg_Count (2);
21581 E_Id := Get_Pragma_Arg (Arg2);
21584 -- In the expansion of an inlined body, a reference to
21585 -- the formal may be wrapped in a conversion if the
21586 -- actual is a conversion. Retrieve the real entity name.
21588 if (In_Instance_Body or In_Inlined_Body)
21589 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21591 E_Id := Expression (E_Id);
21594 -- Entity name case
21596 if Is_Entity_Name (E_Id) then
21597 E := Entity (E_Id);
21604 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21607 -- For OFF case, make entry in warnings off
21608 -- pragma table for later processing. But we do
21609 -- not do that within an instance, since these
21610 -- warnings are about what is needed in the
21611 -- template, not an instance of it.
21613 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21614 and then Warn_On_Warnings_Off
21615 and then not In_Instance
21617 Warnings_Off_Pragmas.Append ((N, E, Reason));
21620 if Is_Enumeration_Type (E) then
21624 Lit := First_Literal (E);
21625 while Present (Lit) loop
21626 Set_Warnings_Off (Lit);
21627 Next_Literal (Lit);
21632 exit when No (Homonym (E));
21637 -- Error if not entity or static string expression case
21639 elsif not Is_Static_String_Expression (Arg2) then
21641 ("second argument of pragma% must be entity name "
21642 & "or static string expression", Arg2);
21644 -- Static string expression case
21647 Acquire_Warning_Match_String (Arg2);
21649 -- Note on configuration pragma case: If this is a
21650 -- configuration pragma, then for an OFF pragma, we
21651 -- just set Config True in the call, which is all
21652 -- that needs to be done. For the case of ON, this
21653 -- is normally an error, unless it is canceling the
21654 -- effect of a previous OFF pragma in the same file.
21655 -- In any other case, an error will be signalled (ON
21656 -- with no matching OFF).
21658 -- Note: We set Used if we are inside a generic to
21659 -- disable the test that the non-config case actually
21660 -- cancels a warning. That's because we can't be sure
21661 -- there isn't an instantiation in some other unit
21662 -- where a warning is suppressed.
21664 -- We could do a little better here by checking if the
21665 -- generic unit we are inside is public, but for now
21666 -- we don't bother with that refinement.
21668 if Chars (Argx) = Name_Off then
21669 Set_Specific_Warning_Off
21670 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21671 Config => Is_Configuration_Pragma,
21672 Used => Inside_A_Generic or else In_Instance);
21674 elsif Chars (Argx) = Name_On then
21675 Set_Specific_Warning_On
21676 (Loc, Name_Buffer (1 .. Name_Len), Err);
21680 ("??pragma Warnings On with no matching "
21681 & "Warnings Off", Loc);
21690 -------------------
21691 -- Weak_External --
21692 -------------------
21694 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21696 when Pragma_Weak_External => Weak_External : declare
21701 Check_Arg_Count (1);
21702 Check_Optional_Identifier (Arg1, Name_Entity);
21703 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21704 Ent := Entity (Get_Pragma_Arg (Arg1));
21706 if Rep_Item_Too_Early (Ent, N) then
21709 Ent := Underlying_Type (Ent);
21712 -- The only processing required is to link this item on to the
21713 -- list of rep items for the given entity. This is accomplished
21714 -- by the call to Rep_Item_Too_Late (when no error is detected
21715 -- and False is returned).
21717 if Rep_Item_Too_Late (Ent, N) then
21720 Set_Has_Gigi_Rep_Item (Ent);
21724 -----------------------------
21725 -- Wide_Character_Encoding --
21726 -----------------------------
21728 -- pragma Wide_Character_Encoding (IDENTIFIER);
21730 when Pragma_Wide_Character_Encoding =>
21733 -- Nothing to do, handled in parser. Note that we do not enforce
21734 -- configuration pragma placement, this pragma can appear at any
21735 -- place in the source, allowing mixed encodings within a single
21740 --------------------
21741 -- Unknown_Pragma --
21742 --------------------
21744 -- Should be impossible, since the case of an unknown pragma is
21745 -- separately processed before the case statement is entered.
21747 when Unknown_Pragma =>
21748 raise Program_Error;
21751 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21752 -- until AI is formally approved.
21754 -- Check_Order_Dependence;
21757 when Pragma_Exit => null;
21758 end Analyze_Pragma;
21760 ---------------------------------------------
21761 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21762 ---------------------------------------------
21764 procedure Analyze_Pre_Post_Condition_In_Decl_Part (N : Node_Id) is
21765 procedure Process_Class_Wide_Condition
21767 Spec_Id : Entity_Id;
21768 Subp_Decl : Node_Id);
21769 -- Replace the type of all references to the controlling formal of
21770 -- subprogram Spec_Id found in expression Expr with the corresponding
21771 -- class-wide type. Subp_Decl is the subprogram [body] declaration
21772 -- where the pragma resides.
21774 ----------------------------------
21775 -- Process_Class_Wide_Condition --
21776 ----------------------------------
21778 procedure Process_Class_Wide_Condition
21780 Spec_Id : Entity_Id;
21781 Subp_Decl : Node_Id)
21783 Disp_Typ : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
21785 ACW : Entity_Id := Empty;
21786 -- Access to Disp_Typ'Class, created if there is a controlling formal
21787 -- that is an access parameter.
21789 function Access_Class_Wide_Type return Entity_Id;
21790 -- If expression Expr contains a reference to a controlling access
21791 -- parameter, create an access to Disp_Typ'Class for the necessary
21792 -- conversions if one does not exist.
21794 function Replace_Type (N : Node_Id) return Traverse_Result;
21795 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21796 -- aspect for a primitive subprogram of a tagged type Disp_Typ, a
21797 -- name that denotes a formal parameter of type Disp_Typ is treated
21798 -- as having type Disp_Typ'Class. Similarly, a name that denotes a
21799 -- formal access parameter of type access-to-Disp_Typ is interpreted
21800 -- as with type access-to-Disp_Typ'Class. This ensures the expression
21801 -- is well defined for a primitive subprogram of a type descended
21804 ----------------------------
21805 -- Access_Class_Wide_Type --
21806 ----------------------------
21808 function Access_Class_Wide_Type return Entity_Id is
21809 Loc : constant Source_Ptr := Sloc (N);
21813 ACW := Make_Temporary (Loc, 'T
');
21815 Insert_Before_And_Analyze (Subp_Decl,
21816 Make_Full_Type_Declaration (Loc,
21817 Defining_Identifier => ACW,
21819 Make_Access_To_Object_Definition (Loc,
21820 Subtype_Indication =>
21821 New_Occurrence_Of (Class_Wide_Type (Disp_Typ), Loc),
21822 All_Present => True)));
21824 Freeze_Before (Subp_Decl, ACW);
21828 end Access_Class_Wide_Type;
21834 function Replace_Type (N : Node_Id) return Traverse_Result is
21835 Context : constant Node_Id := Parent (N);
21836 Loc : constant Source_Ptr := Sloc (N);
21837 CW_Typ : Entity_Id := Empty;
21842 if Is_Entity_Name (N)
21843 and then Present (Entity (N))
21844 and then Is_Formal (Entity (N))
21847 Typ := Etype (Ent);
21849 -- Do not perform the type replacement for selector names in
21850 -- parameter associations. These carry an entity for reference
21851 -- purposes, but semantically they are just identifiers.
21853 if Nkind (Context) = N_Type_Conversion then
21856 elsif Nkind (Context) = N_Parameter_Association
21857 and then Selector_Name (Context) = N
21861 elsif Typ = Disp_Typ then
21862 CW_Typ := Class_Wide_Type (Typ);
21864 elsif Is_Access_Type (Typ)
21865 and then Designated_Type (Typ) = Disp_Typ
21867 CW_Typ := Access_Class_Wide_Type;
21870 if Present (CW_Typ) then
21872 Make_Type_Conversion (Loc,
21873 Subtype_Mark => New_Occurrence_Of (CW_Typ, Loc),
21874 Expression => New_Occurrence_Of (Ent, Loc)));
21875 Set_Etype (N, CW_Typ);
21882 procedure Replace_Types is new Traverse_Proc (Replace_Type);
21884 -- Start of processing for Process_Class_Wide_Condition
21887 -- The subprogram subject to Pre'Class/Post'Class does not have a
21888 -- dispatching type, therefore the aspect/pragma is illegal.
21890 if No (Disp_Typ) then
21891 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
21893 if From_Aspect_Specification (N) then
21895 ("aspect % can only be specified for a primitive operation "
21896 & "of a tagged type", Corresponding_Aspect (N));
21898 -- The pragma is a source construct
21902 ("pragma % can only be specified for a primitive operation "
21903 & "of a tagged type", N);
21907 Replace_Types (Expr);
21908 end Process_Class_Wide_Condition;
21912 Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
21913 Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl);
21914 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
21916 Restore_Scope : Boolean := False;
21918 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
21921 -- Ensure that the subprogram and its formals are visible when analyzing
21922 -- the expression of the pragma.
21924 if not In_Open_Scopes (Spec_Id) then
21925 Restore_Scope := True;
21926 Push_Scope (Spec_Id);
21928 if Is_Generic_Subprogram (Spec_Id) then
21929 Install_Generic_Formals (Spec_Id);
21931 Install_Formals (Spec_Id);
21935 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21937 -- For a class-wide condition, a reference to a controlling formal must
21938 -- be interpreted as having the class-wide type (or an access to such)
21939 -- so that the inherited condition can be properly applied to any
21940 -- overriding operation (see ARM12 6.6.1 (7)).
21942 if Class_Present (N) then
21943 Process_Class_Wide_Condition (Expr, Spec_Id, Subp_Decl);
21946 if Restore_Scope then
21950 -- Currently it is not possible to inline pre/postconditions on a
21951 -- subprogram subject to pragma Inline_Always.
21953 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
21954 end Analyze_Pre_Post_Condition_In_Decl_Part;
21956 ------------------------------------------
21957 -- Analyze_Refined_Depends_In_Decl_Part --
21958 ------------------------------------------
21960 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21961 Body_Inputs : Elist_Id := No_Elist;
21962 Body_Outputs : Elist_Id := No_Elist;
21963 -- The inputs and outputs of the subprogram body synthesized from pragma
21964 -- Refined_Depends.
21966 Dependencies : List_Id := No_List;
21968 -- The corresponding Depends pragma along with its clauses
21970 Matched_Items : Elist_Id := No_Elist;
21971 -- A list containing the entities of all successfully matched items
21972 -- found in pragma Depends.
21974 Refinements : List_Id := No_List;
21975 -- The clauses of pragma Refined_Depends
21977 Spec_Id : Entity_Id;
21978 -- The entity of the subprogram subject to pragma Refined_Depends
21980 Spec_Inputs : Elist_Id := No_Elist;
21981 Spec_Outputs : Elist_Id := No_Elist;
21982 -- The inputs and outputs of the subprogram spec synthesized from pragma
21985 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21986 -- Try to match a single dependency clause Dep_Clause against one or
21987 -- more refinement clauses found in list Refinements. Each successful
21988 -- match eliminates at least one refinement clause from Refinements.
21990 procedure Check_Output_States;
21991 -- Determine whether pragma Depends contains an output state with a
21992 -- visible refinement and if so, ensure that pragma Refined_Depends
21993 -- mentions all its constituents as outputs.
21995 procedure Normalize_Clauses (Clauses : List_Id);
21996 -- Given a list of dependence or refinement clauses Clauses, normalize
21997 -- each clause by creating multiple dependencies with exactly one input
22000 procedure Report_Extra_Clauses;
22001 -- Emit an error for each extra clause found in list Refinements
22003 -----------------------------
22004 -- Check_Dependency_Clause --
22005 -----------------------------
22007 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
22008 Dep_Input : constant Node_Id := Expression (Dep_Clause);
22009 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
22011 function Is_In_Out_State_Clause return Boolean;
22012 -- Determine whether dependence clause Dep_Clause denotes an abstract
22013 -- state that depends on itself (State => State).
22015 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
22016 -- Determine whether item Item denotes an abstract state with visible
22017 -- null refinement.
22019 procedure Match_Items
22020 (Dep_Item : Node_Id;
22021 Ref_Item : Node_Id;
22022 Matched : out Boolean);
22023 -- Try to match dependence item Dep_Item against refinement item
22024 -- Ref_Item. To match against a possible null refinement (see 2, 7),
22025 -- set Ref_Item to Empty. Flag Matched is set to True when one of
22026 -- the following conformance scenarios is in effect:
22027 -- 1) Both items denote null
22028 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
22029 -- 3) Both items denote attribute 'Result
22030 -- 4) Both items denote the same formal parameter
22031 -- 5) Both items denote the same object
22032 -- 6) Dep_Item is an abstract state with visible null refinement
22033 -- and Ref_Item denotes null.
22034 -- 7) Dep_Item is an abstract state with visible null refinement
22035 -- and Ref_Item is Empty (special case).
22036 -- 8) Dep_Item is an abstract state with visible non-null
22037 -- refinement and Ref_Item denotes one of its constituents.
22038 -- 9) Dep_Item is an abstract state without a visible refinement
22039 -- and Ref_Item denotes the same state.
22040 -- When scenario 8 is in effect, the entity of the abstract state
22041 -- denoted by Dep_Item is added to list Refined_States.
22043 procedure Record_Item
(Item_Id
: Entity_Id
);
22044 -- Store the entity of an item denoted by Item_Id in Matched_Items
22046 ----------------------------
22047 -- Is_In_Out_State_Clause --
22048 ----------------------------
22050 function Is_In_Out_State_Clause
return Boolean is
22051 Dep_Input_Id
: Entity_Id
;
22052 Dep_Output_Id
: Entity_Id
;
22055 -- Detect the following clause:
22058 if Is_Entity_Name
(Dep_Input
)
22059 and then Is_Entity_Name
(Dep_Output
)
22061 -- Handle abstract views generated for limited with clauses
22063 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
22064 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
22067 Ekind
(Dep_Input_Id
) = E_Abstract_State
22068 and then Dep_Input_Id
= Dep_Output_Id
;
22072 end Is_In_Out_State_Clause
;
22074 ---------------------------
22075 -- Is_Null_Refined_State --
22076 ---------------------------
22078 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
22079 Item_Id
: Entity_Id
;
22082 if Is_Entity_Name
(Item
) then
22084 -- Handle abstract views generated for limited with clauses
22086 Item_Id
:= Available_View
(Entity_Of
(Item
));
22088 return Ekind
(Item_Id
) = E_Abstract_State
22089 and then Has_Null_Refinement
(Item_Id
);
22094 end Is_Null_Refined_State
;
22100 procedure Match_Items
22101 (Dep_Item
: Node_Id
;
22102 Ref_Item
: Node_Id
;
22103 Matched
: out Boolean)
22105 Dep_Item_Id
: Entity_Id
;
22106 Ref_Item_Id
: Entity_Id
;
22109 -- Assume that the two items do not match
22113 -- A null matches null or Empty (special case)
22115 if Nkind
(Dep_Item
) = N_Null
22116 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
22120 -- Attribute 'Result matches attribute 'Result
22122 elsif Is_Attribute_Result
(Dep_Item
)
22123 and then Is_Attribute_Result
(Dep_Item
)
22127 -- Abstract states, formal parameters and objects
22129 elsif Is_Entity_Name
(Dep_Item
) then
22131 -- Handle abstract views generated for limited with clauses
22133 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
22135 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
22137 -- An abstract state with visible null refinement matches
22138 -- null or Empty (special case).
22140 if Has_Null_Refinement
(Dep_Item_Id
)
22141 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
22143 Record_Item
(Dep_Item_Id
);
22146 -- An abstract state with visible non-null refinement
22147 -- matches one of its constituents.
22149 elsif Has_Non_Null_Refinement
(Dep_Item_Id
) then
22150 if Is_Entity_Name
(Ref_Item
) then
22151 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
22153 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
22156 and then Present
(Encapsulating_State
(Ref_Item_Id
))
22157 and then Encapsulating_State
(Ref_Item_Id
) =
22160 Record_Item
(Dep_Item_Id
);
22165 -- An abstract state without a visible refinement matches
22168 elsif Is_Entity_Name
(Ref_Item
)
22169 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22171 Record_Item
(Dep_Item_Id
);
22175 -- A formal parameter or an object matches itself
22177 elsif Is_Entity_Name
(Ref_Item
)
22178 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
22180 Record_Item
(Dep_Item_Id
);
22190 procedure Record_Item
(Item_Id
: Entity_Id
) is
22192 if not Contains
(Matched_Items
, Item_Id
) then
22193 Add_Item
(Item_Id
, Matched_Items
);
22199 Clause_Matched
: Boolean := False;
22200 Dummy
: Boolean := False;
22201 Inputs_Match
: Boolean;
22202 Next_Ref_Clause
: Node_Id
;
22203 Outputs_Match
: Boolean;
22204 Ref_Clause
: Node_Id
;
22205 Ref_Input
: Node_Id
;
22206 Ref_Output
: Node_Id
;
22208 -- Start of processing for Check_Dependency_Clause
22211 -- Do not perform this check in an instance because it was already
22212 -- performed successfully in the generic template.
22214 if Is_Generic_Instance
(Spec_Id
) then
22218 -- Examine all refinement clauses and compare them against the
22219 -- dependence clause.
22221 Ref_Clause
:= First
(Refinements
);
22222 while Present
(Ref_Clause
) loop
22223 Next_Ref_Clause
:= Next
(Ref_Clause
);
22225 -- Obtain the attributes of the current refinement clause
22227 Ref_Input
:= Expression
(Ref_Clause
);
22228 Ref_Output
:= First
(Choices
(Ref_Clause
));
22230 -- The current refinement clause matches the dependence clause
22231 -- when both outputs match and both inputs match. See routine
22232 -- Match_Items for all possible conformance scenarios.
22234 -- Depends Dep_Output => Dep_Input
22238 -- Refined_Depends Ref_Output => Ref_Input
22241 (Dep_Item
=> Dep_Input
,
22242 Ref_Item
=> Ref_Input
,
22243 Matched
=> Inputs_Match
);
22246 (Dep_Item
=> Dep_Output
,
22247 Ref_Item
=> Ref_Output
,
22248 Matched
=> Outputs_Match
);
22250 -- An In_Out state clause may be matched against a refinement with
22251 -- a null input or null output as long as the non-null side of the
22252 -- relation contains a valid constituent of the In_Out_State.
22254 if Is_In_Out_State_Clause
then
22256 -- Depends => (State => State)
22257 -- Refined_Depends => (null => Constit) -- OK
22260 and then not Outputs_Match
22261 and then Nkind
(Ref_Output
) = N_Null
22263 Outputs_Match
:= True;
22266 -- Depends => (State => State)
22267 -- Refined_Depends => (Constit => null) -- OK
22269 if not Inputs_Match
22270 and then Outputs_Match
22271 and then Nkind
(Ref_Input
) = N_Null
22273 Inputs_Match
:= True;
22277 -- The current refinement clause is legally constructed following
22278 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
22279 -- the pool of candidates. The seach continues because a single
22280 -- dependence clause may have multiple matching refinements.
22282 if Inputs_Match
and then Outputs_Match
then
22283 Clause_Matched
:= True;
22284 Remove
(Ref_Clause
);
22287 Ref_Clause
:= Next_Ref_Clause
;
22290 -- Depending on the order or composition of refinement clauses, an
22291 -- In_Out state clause may not be directly refinable.
22293 -- Depends => ((Output, State) => (Input, State))
22294 -- Refined_State => (State => (Constit_1, Constit_2))
22295 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
22297 -- Matching normalized clause (State => State) fails because there is
22298 -- no direct refinement capable of satisfying this relation. Another
22299 -- similar case arises when clauses (Constit_1 => Input) and (Output
22300 -- => Constit_2) are matched first, leaving no candidates for clause
22301 -- (State => State). Both scenarios are legal as long as one of the
22302 -- previous clauses mentioned a valid constituent of State.
22304 if not Clause_Matched
22305 and then Is_In_Out_State_Clause
22307 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22309 Clause_Matched
:= True;
22312 -- A clause where the input is an abstract state with visible null
22313 -- refinement is implicitly matched when the output has already been
22314 -- matched in a previous clause.
22316 -- Depends => (Output => State) -- implicitly OK
22317 -- Refined_State => (State => null)
22318 -- Refined_Depends => (Output => ...)
22320 if not Clause_Matched
22321 and then Is_Null_Refined_State
(Dep_Input
)
22322 and then Is_Entity_Name
(Dep_Output
)
22324 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
22326 Clause_Matched
:= True;
22329 -- A clause where the output is an abstract state with visible null
22330 -- refinement is implicitly matched when the input has already been
22331 -- matched in a previous clause.
22333 -- Depends => (State => Input) -- implicitly OK
22334 -- Refined_State => (State => null)
22335 -- Refined_Depends => (... => Input)
22337 if not Clause_Matched
22338 and then Is_Null_Refined_State
(Dep_Output
)
22339 and then Is_Entity_Name
(Dep_Input
)
22341 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
22343 Clause_Matched
:= True;
22346 -- At this point either all refinement clauses have been examined or
22347 -- pragma Refined_Depends contains a solitary null. Only an abstract
22348 -- state with null refinement can possibly match these cases.
22350 -- Depends => (State => null)
22351 -- Refined_State => (State => null)
22352 -- Refined_Depends => null -- OK
22354 if not Clause_Matched
then
22356 (Dep_Item
=> Dep_Input
,
22358 Matched
=> Inputs_Match
);
22361 (Dep_Item
=> Dep_Output
,
22363 Matched
=> Outputs_Match
);
22365 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
22368 -- If the contents of Refined_Depends are legal, then the current
22369 -- dependence clause should be satisfied either by an explicit match
22370 -- or by one of the special cases.
22372 if not Clause_Matched
then
22374 ("dependence clause of subprogram & has no matching refinement "
22375 & "in body", Dep_Clause
, Spec_Id
);
22377 end Check_Dependency_Clause
;
22379 -------------------------
22380 -- Check_Output_States --
22381 -------------------------
22383 procedure Check_Output_States
is
22384 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22385 -- Determine whether all constituents of state State_Id with visible
22386 -- refinement are used as outputs in pragma Refined_Depends. Emit an
22387 -- error if this is not the case.
22389 -----------------------------
22390 -- Check_Constituent_Usage --
22391 -----------------------------
22393 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22394 Constit_Elmt
: Elmt_Id
;
22395 Constit_Id
: Entity_Id
;
22396 Posted
: Boolean := False;
22399 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22400 while Present
(Constit_Elmt
) loop
22401 Constit_Id
:= Node
(Constit_Elmt
);
22403 -- The constituent acts as an input (SPARK RM 7.2.5(3))
22405 if Present
(Body_Inputs
)
22406 and then Appears_In
(Body_Inputs
, Constit_Id
)
22408 Error_Msg_Name_1
:= Chars
(State_Id
);
22410 ("constituent & of state % must act as output in "
22411 & "dependence refinement", N
, Constit_Id
);
22413 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22415 elsif No
(Body_Outputs
)
22416 or else not Appears_In
(Body_Outputs
, Constit_Id
)
22421 ("output state & must be replaced by all its "
22422 & "constituents in dependence refinement",
22427 ("\constituent & is missing in output list",
22431 Next_Elmt
(Constit_Elmt
);
22433 end Check_Constituent_Usage
;
22438 Item_Elmt
: Elmt_Id
;
22439 Item_Id
: Entity_Id
;
22441 -- Start of processing for Check_Output_States
22444 -- Do not perform this check in an instance because it was already
22445 -- performed successfully in the generic template.
22447 if Is_Generic_Instance
(Spec_Id
) then
22450 -- Inspect the outputs of pragma Depends looking for a state with a
22451 -- visible refinement.
22453 elsif Present
(Spec_Outputs
) then
22454 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
22455 while Present
(Item_Elmt
) loop
22456 Item
:= Node
(Item_Elmt
);
22458 -- Deal with the mixed nature of the input and output lists
22460 if Nkind
(Item
) = N_Defining_Identifier
then
22463 Item_Id
:= Available_View
(Entity_Of
(Item
));
22466 if Ekind
(Item_Id
) = E_Abstract_State
then
22468 -- The state acts as an input-output, skip it
22470 if Present
(Spec_Inputs
)
22471 and then Appears_In
(Spec_Inputs
, Item_Id
)
22475 -- Ensure that all of the constituents are utilized as
22476 -- outputs in pragma Refined_Depends.
22478 elsif Has_Non_Null_Refinement
(Item_Id
) then
22479 Check_Constituent_Usage
(Item_Id
);
22483 Next_Elmt
(Item_Elmt
);
22486 end Check_Output_States
;
22488 -----------------------
22489 -- Normalize_Clauses --
22490 -----------------------
22492 procedure Normalize_Clauses
(Clauses
: List_Id
) is
22493 procedure Normalize_Inputs
(Clause
: Node_Id
);
22494 -- Normalize clause Clause by creating multiple clauses for each
22495 -- input item of Clause. It is assumed that Clause has exactly one
22496 -- output. The transformation is as follows:
22498 -- Output => (Input_1, Input_2) -- original
22500 -- Output => Input_1 -- normalizations
22501 -- Output => Input_2
22503 procedure Normalize_Outputs
(Clause
: Node_Id
);
22504 -- Normalize clause Clause by creating multiple clause for each
22505 -- output item of Clause. The transformation is as follows:
22507 -- (Output_1, Output_2) => Input -- original
22509 -- Output_1 => Input -- normalization
22510 -- Output_2 => Input
22512 ----------------------
22513 -- Normalize_Inputs --
22514 ----------------------
22516 procedure Normalize_Inputs
(Clause
: Node_Id
) is
22517 Inputs
: constant Node_Id
:= Expression
(Clause
);
22518 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22519 Output
: constant List_Id
:= Choices
(Clause
);
22520 Last_Input
: Node_Id
;
22522 New_Clause
: Node_Id
;
22523 Next_Input
: Node_Id
;
22526 -- Normalization is performed only when the original clause has
22527 -- more than one input. Multiple inputs appear as an aggregate.
22529 if Nkind
(Inputs
) = N_Aggregate
then
22530 Last_Input
:= Last
(Expressions
(Inputs
));
22532 -- Create a new clause for each input
22534 Input
:= First
(Expressions
(Inputs
));
22535 while Present
(Input
) loop
22536 Next_Input
:= Next
(Input
);
22538 -- Unhook the current input from the original input list
22539 -- because it will be relocated to a new clause.
22543 -- Special processing for the last input. At this point the
22544 -- original aggregate has been stripped down to one element.
22545 -- Replace the aggregate by the element itself.
22547 if Input
= Last_Input
then
22548 Rewrite
(Inputs
, Input
);
22550 -- Generate a clause of the form:
22555 Make_Component_Association
(Loc
,
22556 Choices
=> New_Copy_List_Tree
(Output
),
22557 Expression
=> Input
);
22559 -- The new clause contains replicated content that has
22560 -- already been analyzed, mark the clause as analyzed.
22562 Set_Analyzed
(New_Clause
);
22563 Insert_After
(Clause
, New_Clause
);
22566 Input
:= Next_Input
;
22569 end Normalize_Inputs
;
22571 -----------------------
22572 -- Normalize_Outputs --
22573 -----------------------
22575 procedure Normalize_Outputs
(Clause
: Node_Id
) is
22576 Inputs
: constant Node_Id
:= Expression
(Clause
);
22577 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22578 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
22579 Last_Output
: Node_Id
;
22580 New_Clause
: Node_Id
;
22581 Next_Output
: Node_Id
;
22585 -- Multiple outputs appear as an aggregate. Nothing to do when
22586 -- the clause has exactly one output.
22588 if Nkind
(Outputs
) = N_Aggregate
then
22589 Last_Output
:= Last
(Expressions
(Outputs
));
22591 -- Create a clause for each output. Note that each time a new
22592 -- clause is created, the original output list slowly shrinks
22593 -- until there is one item left.
22595 Output
:= First
(Expressions
(Outputs
));
22596 while Present
(Output
) loop
22597 Next_Output
:= Next
(Output
);
22599 -- Unhook the output from the original output list as it
22600 -- will be relocated to a new clause.
22604 -- Special processing for the last output. At this point
22605 -- the original aggregate has been stripped down to one
22606 -- element. Replace the aggregate by the element itself.
22608 if Output
= Last_Output
then
22609 Rewrite
(Outputs
, Output
);
22612 -- Generate a clause of the form:
22613 -- (Output => Inputs)
22616 Make_Component_Association
(Loc
,
22617 Choices
=> New_List
(Output
),
22618 Expression
=> New_Copy_Tree
(Inputs
));
22620 -- The new clause contains replicated content that has
22621 -- already been analyzed. There is not need to reanalyze
22624 Set_Analyzed
(New_Clause
);
22625 Insert_After
(Clause
, New_Clause
);
22628 Output
:= Next_Output
;
22631 end Normalize_Outputs
;
22637 -- Start of processing for Normalize_Clauses
22640 Clause
:= First
(Clauses
);
22641 while Present
(Clause
) loop
22642 Normalize_Outputs
(Clause
);
22646 Clause
:= First
(Clauses
);
22647 while Present
(Clause
) loop
22648 Normalize_Inputs
(Clause
);
22651 end Normalize_Clauses
;
22653 --------------------------
22654 -- Report_Extra_Clauses --
22655 --------------------------
22657 procedure Report_Extra_Clauses
is
22661 -- Do not perform this check in an instance because it was already
22662 -- performed successfully in the generic template.
22664 if Is_Generic_Instance
(Spec_Id
) then
22667 elsif Present
(Refinements
) then
22668 Clause
:= First
(Refinements
);
22669 while Present
(Clause
) loop
22671 -- Do not complain about a null input refinement, since a null
22672 -- input legitimately matches anything.
22674 if Nkind
(Clause
) = N_Component_Association
22675 and then Nkind
(Expression
(Clause
)) = N_Null
22681 ("unmatched or extra clause in dependence refinement",
22688 end Report_Extra_Clauses
;
22692 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22693 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
22694 Errors
: constant Nat
:= Serious_Errors_Detected
;
22700 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22703 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22704 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22706 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22709 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
22711 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22712 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22714 if No
(Depends
) then
22716 ("useless refinement, declaration of subprogram & lacks aspect or "
22717 & "pragma Depends", N
, Spec_Id
);
22721 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
22723 -- A null dependency relation renders the refinement useless because it
22724 -- cannot possibly mention abstract states with visible refinement. Note
22725 -- that the inverse is not true as states may be refined to null
22726 -- (SPARK RM 7.2.5(2)).
22728 if Nkind
(Deps
) = N_Null
then
22730 ("useless refinement, subprogram & does not depend on abstract "
22731 & "state with visible refinement", N
, Spec_Id
);
22735 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22736 -- This ensures that the categorization of all refined dependency items
22737 -- is consistent with their role.
22739 Analyze_Depends_In_Decl_Part
(N
);
22741 -- Do not match dependencies against refinements if Refined_Depends is
22742 -- illegal to avoid emitting misleading error.
22744 if Serious_Errors_Detected
= Errors
then
22746 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
22747 -- the inputs and outputs of the subprogram spec and body to verify
22748 -- the use of states with visible refinement and their constituents.
22750 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
22751 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
22753 Collect_Subprogram_Inputs_Outputs
22754 (Subp_Id
=> Spec_Id
,
22755 Synthesize
=> True,
22756 Subp_Inputs
=> Spec_Inputs
,
22757 Subp_Outputs
=> Spec_Outputs
,
22758 Global_Seen
=> Dummy
);
22760 Collect_Subprogram_Inputs_Outputs
22761 (Subp_Id
=> Body_Id
,
22762 Synthesize
=> True,
22763 Subp_Inputs
=> Body_Inputs
,
22764 Subp_Outputs
=> Body_Outputs
,
22765 Global_Seen
=> Dummy
);
22767 -- For an output state with a visible refinement, ensure that all
22768 -- constituents appear as outputs in the dependency refinement.
22770 Check_Output_States
;
22773 -- Matching is disabled in ASIS because clauses are not normalized as
22774 -- this is a tree altering activity similar to expansion.
22780 -- Multiple dependency clauses appear as component associations of an
22781 -- aggregate. Note that the clauses are copied because the algorithm
22782 -- modifies them and this should not be visible in Depends.
22784 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
22785 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
22786 Normalize_Clauses
(Dependencies
);
22788 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
22790 if Nkind
(Refs
) = N_Null
then
22791 Refinements
:= No_List
;
22793 -- Multiple dependency clauses appear as component associations of an
22794 -- aggregate. Note that the clauses are copied because the algorithm
22795 -- modifies them and this should not be visible in Refined_Depends.
22797 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
22798 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
22799 Normalize_Clauses
(Refinements
);
22802 -- At this point the clauses of pragmas Depends and Refined_Depends
22803 -- have been normalized into simple dependencies between one output
22804 -- and one input. Examine all clauses of pragma Depends looking for
22805 -- matching clauses in pragma Refined_Depends.
22807 Clause
:= First
(Dependencies
);
22808 while Present
(Clause
) loop
22809 Check_Dependency_Clause
(Clause
);
22813 if Serious_Errors_Detected
= Errors
then
22814 Report_Extra_Clauses
;
22817 end Analyze_Refined_Depends_In_Decl_Part
;
22819 -----------------------------------------
22820 -- Analyze_Refined_Global_In_Decl_Part --
22821 -----------------------------------------
22823 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
22825 -- The corresponding Global pragma
22827 Has_In_State
: Boolean := False;
22828 Has_In_Out_State
: Boolean := False;
22829 Has_Out_State
: Boolean := False;
22830 Has_Proof_In_State
: Boolean := False;
22831 -- These flags are set when the corresponding Global pragma has a state
22832 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22835 Has_Null_State
: Boolean := False;
22836 -- This flag is set when the corresponding Global pragma has at least
22837 -- one state with a null refinement.
22839 In_Constits
: Elist_Id
:= No_Elist
;
22840 In_Out_Constits
: Elist_Id
:= No_Elist
;
22841 Out_Constits
: Elist_Id
:= No_Elist
;
22842 Proof_In_Constits
: Elist_Id
:= No_Elist
;
22843 -- These lists contain the entities of all Input, In_Out, Output and
22844 -- Proof_In constituents that appear in Refined_Global and participate
22845 -- in state refinement.
22847 In_Items
: Elist_Id
:= No_Elist
;
22848 In_Out_Items
: Elist_Id
:= No_Elist
;
22849 Out_Items
: Elist_Id
:= No_Elist
;
22850 Proof_In_Items
: Elist_Id
:= No_Elist
;
22851 -- These list contain the entities of all Input, In_Out, Output and
22852 -- Proof_In items defined in the corresponding Global pragma.
22854 Spec_Id
: Entity_Id
;
22855 -- The entity of the subprogram subject to pragma Refined_Global
22857 procedure Check_In_Out_States
;
22858 -- Determine whether the corresponding Global pragma mentions In_Out
22859 -- states with visible refinement and if so, ensure that one of the
22860 -- following completions apply to the constituents of the state:
22861 -- 1) there is at least one constituent of mode In_Out
22862 -- 2) there is at least one Input and one Output constituent
22863 -- 3) not all constituents are present and one of them is of mode
22865 -- This routine may remove elements from In_Constits, In_Out_Constits,
22866 -- Out_Constits and Proof_In_Constits.
22868 procedure Check_Input_States
;
22869 -- Determine whether the corresponding Global pragma mentions Input
22870 -- states with visible refinement and if so, ensure that at least one of
22871 -- its constituents appears as an Input item in Refined_Global.
22872 -- This routine may remove elements from In_Constits, In_Out_Constits,
22873 -- Out_Constits and Proof_In_Constits.
22875 procedure Check_Output_States
;
22876 -- Determine whether the corresponding Global pragma mentions Output
22877 -- states with visible refinement and if so, ensure that all of its
22878 -- constituents appear as Output items in Refined_Global.
22879 -- This routine may remove elements from In_Constits, In_Out_Constits,
22880 -- Out_Constits and Proof_In_Constits.
22882 procedure Check_Proof_In_States
;
22883 -- Determine whether the corresponding Global pragma mentions Proof_In
22884 -- states with visible refinement and if so, ensure that at least one of
22885 -- its constituents appears as a Proof_In item in Refined_Global.
22886 -- This routine may remove elements from In_Constits, In_Out_Constits,
22887 -- Out_Constits and Proof_In_Constits.
22889 procedure Check_Refined_Global_List
22891 Global_Mode
: Name_Id
:= Name_Input
);
22892 -- Verify the legality of a single global list declaration. Global_Mode
22893 -- denotes the current mode in effect.
22895 procedure Collect_Global_Items
22897 Mode
: Name_Id
:= Name_Input
);
22898 -- Gather all input, in out, output and Proof_In items from node List
22899 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
22900 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
22901 -- and Has_Proof_In_State are set when there is at least one abstract
22902 -- state with visible refinement available in the corresponding mode.
22903 -- Flag Has_Null_State is set when at least state has a null refinement.
22904 -- Mode enotes the current global mode in effect.
22906 function Present_Then_Remove
22908 Item
: Entity_Id
) return Boolean;
22909 -- Search List for a particular entity Item. If Item has been found,
22910 -- remove it from List. This routine is used to strip lists In_Constits,
22911 -- In_Out_Constits and Out_Constits of valid constituents.
22913 procedure Report_Extra_Constituents
;
22914 -- Emit an error for each constituent found in lists In_Constits,
22915 -- In_Out_Constits and Out_Constits.
22917 -------------------------
22918 -- Check_In_Out_States --
22919 -------------------------
22921 procedure Check_In_Out_States
is
22922 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22923 -- Determine whether one of the following coverage scenarios is in
22925 -- 1) there is at least one constituent of mode In_Out
22926 -- 2) there is at least one Input and one Output constituent
22927 -- 3) not all constituents are present and one of them is of mode
22929 -- If this is not the case, emit an error.
22931 -----------------------------
22932 -- Check_Constituent_Usage --
22933 -----------------------------
22935 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22936 Constit_Elmt
: Elmt_Id
;
22937 Constit_Id
: Entity_Id
;
22938 Has_Missing
: Boolean := False;
22939 In_Out_Seen
: Boolean := False;
22940 In_Seen
: Boolean := False;
22941 Out_Seen
: Boolean := False;
22944 -- Process all the constituents of the state and note their modes
22945 -- within the global refinement.
22947 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22948 while Present
(Constit_Elmt
) loop
22949 Constit_Id
:= Node
(Constit_Elmt
);
22951 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22954 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22955 In_Out_Seen
:= True;
22957 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22960 -- A Proof_In constituent cannot participate in the completion
22961 -- of an Output state (SPARK RM 7.2.4(5)).
22963 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22964 Error_Msg_Name_1
:= Chars
(State_Id
);
22966 ("constituent & of state % must have mode Input, In_Out "
22967 & "or Output in global refinement", N
, Constit_Id
);
22970 Has_Missing
:= True;
22973 Next_Elmt
(Constit_Elmt
);
22976 -- A single In_Out constituent is a valid completion
22978 if In_Out_Seen
then
22981 -- A pair of one Input and one Output constituent is a valid
22984 elsif In_Seen
and then Out_Seen
then
22987 -- A single Output constituent is a valid completion only when
22988 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22990 elsif Has_Missing
and then Out_Seen
then
22995 ("global refinement of state & redefines the mode of its "
22996 & "constituents", N
, State_Id
);
22998 end Check_Constituent_Usage
;
23002 Item_Elmt
: Elmt_Id
;
23003 Item_Id
: Entity_Id
;
23005 -- Start of processing for Check_In_Out_States
23008 -- Do not perform this check in an instance because it was already
23009 -- performed successfully in the generic template.
23011 if Is_Generic_Instance
(Spec_Id
) then
23014 -- Inspect the In_Out items of the corresponding Global pragma
23015 -- looking for a state with a visible refinement.
23017 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
23018 Item_Elmt
:= First_Elmt
(In_Out_Items
);
23019 while Present
(Item_Elmt
) loop
23020 Item_Id
:= Node
(Item_Elmt
);
23022 -- Ensure that one of the three coverage variants is satisfied
23024 if Ekind
(Item_Id
) = E_Abstract_State
23025 and then Has_Non_Null_Refinement
(Item_Id
)
23027 Check_Constituent_Usage
(Item_Id
);
23030 Next_Elmt
(Item_Elmt
);
23033 end Check_In_Out_States
;
23035 ------------------------
23036 -- Check_Input_States --
23037 ------------------------
23039 procedure Check_Input_States
is
23040 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23041 -- Determine whether at least one constituent of state State_Id with
23042 -- visible refinement is used and has mode Input. Ensure that the
23043 -- remaining constituents do not have In_Out, Output or Proof_In
23046 -----------------------------
23047 -- Check_Constituent_Usage --
23048 -----------------------------
23050 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23051 Constit_Elmt
: Elmt_Id
;
23052 Constit_Id
: Entity_Id
;
23053 In_Seen
: Boolean := False;
23056 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23057 while Present
(Constit_Elmt
) loop
23058 Constit_Id
:= Node
(Constit_Elmt
);
23060 -- At least one of the constituents appears as an Input
23062 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
23065 -- The constituent appears in the global refinement, but has
23066 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
23068 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23069 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
23070 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
23072 Error_Msg_Name_1
:= Chars
(State_Id
);
23074 ("constituent & of state % must have mode Input in global "
23075 & "refinement", N
, Constit_Id
);
23078 Next_Elmt
(Constit_Elmt
);
23081 -- Not one of the constituents appeared as Input
23083 if not In_Seen
then
23085 ("global refinement of state & must include at least one "
23086 & "constituent of mode Input", N
, State_Id
);
23088 end Check_Constituent_Usage
;
23092 Item_Elmt
: Elmt_Id
;
23093 Item_Id
: Entity_Id
;
23095 -- Start of processing for Check_Input_States
23098 -- Do not perform this check in an instance because it was already
23099 -- performed successfully in the generic template.
23101 if Is_Generic_Instance
(Spec_Id
) then
23104 -- Inspect the Input items of the corresponding Global pragma looking
23105 -- for a state with a visible refinement.
23107 elsif Has_In_State
and then Present
(In_Items
) then
23108 Item_Elmt
:= First_Elmt
(In_Items
);
23109 while Present
(Item_Elmt
) loop
23110 Item_Id
:= Node
(Item_Elmt
);
23112 -- Ensure that at least one of the constituents is utilized and
23113 -- is of mode Input.
23115 if Ekind
(Item_Id
) = E_Abstract_State
23116 and then Has_Non_Null_Refinement
(Item_Id
)
23118 Check_Constituent_Usage
(Item_Id
);
23121 Next_Elmt
(Item_Elmt
);
23124 end Check_Input_States
;
23126 -------------------------
23127 -- Check_Output_States --
23128 -------------------------
23130 procedure Check_Output_States
is
23131 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23132 -- Determine whether all constituents of state State_Id with visible
23133 -- refinement are used and have mode Output. Emit an error if this is
23136 -----------------------------
23137 -- Check_Constituent_Usage --
23138 -----------------------------
23140 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23141 Constit_Elmt
: Elmt_Id
;
23142 Constit_Id
: Entity_Id
;
23143 Posted
: Boolean := False;
23146 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23147 while Present
(Constit_Elmt
) loop
23148 Constit_Id
:= Node
(Constit_Elmt
);
23150 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
23153 -- The constituent appears in the global refinement, but has
23154 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
23156 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23157 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23158 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
23160 Error_Msg_Name_1
:= Chars
(State_Id
);
23162 ("constituent & of state % must have mode Output in "
23163 & "global refinement", N
, Constit_Id
);
23165 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23171 ("output state & must be replaced by all its "
23172 & "constituents in global refinement", N
, State_Id
);
23176 ("\constituent & is missing in output list",
23180 Next_Elmt
(Constit_Elmt
);
23182 end Check_Constituent_Usage
;
23186 Item_Elmt
: Elmt_Id
;
23187 Item_Id
: Entity_Id
;
23189 -- Start of processing for Check_Output_States
23192 -- Do not perform this check in an instance because it was already
23193 -- performed successfully in the generic template.
23195 if Is_Generic_Instance
(Spec_Id
) then
23198 -- Inspect the Output items of the corresponding Global pragma
23199 -- looking for a state with a visible refinement.
23201 elsif Has_Out_State
and then Present
(Out_Items
) then
23202 Item_Elmt
:= First_Elmt
(Out_Items
);
23203 while Present
(Item_Elmt
) loop
23204 Item_Id
:= Node
(Item_Elmt
);
23206 -- Ensure that all of the constituents are utilized and they
23207 -- have mode Output.
23209 if Ekind
(Item_Id
) = E_Abstract_State
23210 and then Has_Non_Null_Refinement
(Item_Id
)
23212 Check_Constituent_Usage
(Item_Id
);
23215 Next_Elmt
(Item_Elmt
);
23218 end Check_Output_States
;
23220 ---------------------------
23221 -- Check_Proof_In_States --
23222 ---------------------------
23224 procedure Check_Proof_In_States
is
23225 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23226 -- Determine whether at least one constituent of state State_Id with
23227 -- visible refinement is used and has mode Proof_In. Ensure that the
23228 -- remaining constituents do not have Input, In_Out or Output modes.
23230 -----------------------------
23231 -- Check_Constituent_Usage --
23232 -----------------------------
23234 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23235 Constit_Elmt
: Elmt_Id
;
23236 Constit_Id
: Entity_Id
;
23237 Proof_In_Seen
: Boolean := False;
23240 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
23241 while Present
(Constit_Elmt
) loop
23242 Constit_Id
:= Node
(Constit_Elmt
);
23244 -- At least one of the constituents appears as Proof_In
23246 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
23247 Proof_In_Seen
:= True;
23249 -- The constituent appears in the global refinement, but has
23250 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
23252 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
23253 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
23254 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
23256 Error_Msg_Name_1
:= Chars
(State_Id
);
23258 ("constituent & of state % must have mode Proof_In in "
23259 & "global refinement", N
, Constit_Id
);
23262 Next_Elmt
(Constit_Elmt
);
23265 -- Not one of the constituents appeared as Proof_In
23267 if not Proof_In_Seen
then
23269 ("global refinement of state & must include at least one "
23270 & "constituent of mode Proof_In", N
, State_Id
);
23272 end Check_Constituent_Usage
;
23276 Item_Elmt
: Elmt_Id
;
23277 Item_Id
: Entity_Id
;
23279 -- Start of processing for Check_Proof_In_States
23282 -- Do not perform this check in an instance because it was already
23283 -- performed successfully in the generic template.
23285 if Is_Generic_Instance
(Spec_Id
) then
23288 -- Inspect the Proof_In items of the corresponding Global pragma
23289 -- looking for a state with a visible refinement.
23291 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
23292 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
23293 while Present
(Item_Elmt
) loop
23294 Item_Id
:= Node
(Item_Elmt
);
23296 -- Ensure that at least one of the constituents is utilized and
23297 -- is of mode Proof_In
23299 if Ekind
(Item_Id
) = E_Abstract_State
23300 and then Has_Non_Null_Refinement
(Item_Id
)
23302 Check_Constituent_Usage
(Item_Id
);
23305 Next_Elmt
(Item_Elmt
);
23308 end Check_Proof_In_States
;
23310 -------------------------------
23311 -- Check_Refined_Global_List --
23312 -------------------------------
23314 procedure Check_Refined_Global_List
23316 Global_Mode
: Name_Id
:= Name_Input
)
23318 procedure Check_Refined_Global_Item
23320 Global_Mode
: Name_Id
);
23321 -- Verify the legality of a single global item declaration. Parameter
23322 -- Global_Mode denotes the current mode in effect.
23324 -------------------------------
23325 -- Check_Refined_Global_Item --
23326 -------------------------------
23328 procedure Check_Refined_Global_Item
23330 Global_Mode
: Name_Id
)
23332 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
23334 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
23335 -- Issue a common error message for all mode mismatches. Expect
23336 -- denotes the expected mode.
23338 -----------------------------
23339 -- Inconsistent_Mode_Error --
23340 -----------------------------
23342 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
23345 ("global item & has inconsistent modes", Item
, Item_Id
);
23347 Error_Msg_Name_1
:= Global_Mode
;
23348 Error_Msg_Name_2
:= Expect
;
23349 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
23350 end Inconsistent_Mode_Error
;
23352 -- Start of processing for Check_Refined_Global_Item
23355 -- When the state or object acts as a constituent of another
23356 -- state with a visible refinement, collect it for the state
23357 -- completeness checks performed later on.
23359 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
23360 and then Present
(Encapsulating_State
(Item_Id
))
23361 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
23363 if Global_Mode
= Name_Input
then
23364 Add_Item
(Item_Id
, In_Constits
);
23366 elsif Global_Mode
= Name_In_Out
then
23367 Add_Item
(Item_Id
, In_Out_Constits
);
23369 elsif Global_Mode
= Name_Output
then
23370 Add_Item
(Item_Id
, Out_Constits
);
23372 elsif Global_Mode
= Name_Proof_In
then
23373 Add_Item
(Item_Id
, Proof_In_Constits
);
23376 -- When not a constituent, ensure that both occurrences of the
23377 -- item in pragmas Global and Refined_Global match.
23379 elsif Contains
(In_Items
, Item_Id
) then
23380 if Global_Mode
/= Name_Input
then
23381 Inconsistent_Mode_Error
(Name_Input
);
23384 elsif Contains
(In_Out_Items
, Item_Id
) then
23385 if Global_Mode
/= Name_In_Out
then
23386 Inconsistent_Mode_Error
(Name_In_Out
);
23389 elsif Contains
(Out_Items
, Item_Id
) then
23390 if Global_Mode
/= Name_Output
then
23391 Inconsistent_Mode_Error
(Name_Output
);
23394 elsif Contains
(Proof_In_Items
, Item_Id
) then
23397 -- The item does not appear in the corresponding Global pragma,
23398 -- it must be an extra (SPARK RM 7.2.4(3)).
23401 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
23403 end Check_Refined_Global_Item
;
23409 -- Start of processing for Check_Refined_Global_List
23412 -- Do not perform this check in an instance because it was already
23413 -- performed successfully in the generic template.
23415 if Is_Generic_Instance
(Spec_Id
) then
23418 elsif Nkind
(List
) = N_Null
then
23421 -- Single global item declaration
23423 elsif Nkind_In
(List
, N_Expanded_Name
,
23425 N_Selected_Component
)
23427 Check_Refined_Global_Item
(List
, Global_Mode
);
23429 -- Simple global list or moded global list declaration
23431 elsif Nkind
(List
) = N_Aggregate
then
23433 -- The declaration of a simple global list appear as a collection
23436 if Present
(Expressions
(List
)) then
23437 Item
:= First
(Expressions
(List
));
23438 while Present
(Item
) loop
23439 Check_Refined_Global_Item
(Item
, Global_Mode
);
23443 -- The declaration of a moded global list appears as a collection
23444 -- of component associations where individual choices denote
23447 elsif Present
(Component_Associations
(List
)) then
23448 Item
:= First
(Component_Associations
(List
));
23449 while Present
(Item
) loop
23450 Check_Refined_Global_List
23451 (List
=> Expression
(Item
),
23452 Global_Mode
=> Chars
(First
(Choices
(Item
))));
23460 raise Program_Error
;
23466 raise Program_Error
;
23468 end Check_Refined_Global_List
;
23470 --------------------------
23471 -- Collect_Global_Items --
23472 --------------------------
23474 procedure Collect_Global_Items
23476 Mode
: Name_Id
:= Name_Input
)
23478 procedure Collect_Global_Item
23480 Item_Mode
: Name_Id
);
23481 -- Add a single item to the appropriate list. Item_Mode denotes the
23482 -- current mode in effect.
23484 -------------------------
23485 -- Collect_Global_Item --
23486 -------------------------
23488 procedure Collect_Global_Item
23490 Item_Mode
: Name_Id
)
23492 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
23493 -- The above handles abstract views of variables and states built
23494 -- for limited with clauses.
23497 -- Signal that the global list contains at least one abstract
23498 -- state with a visible refinement. Note that the refinement may
23499 -- be null in which case there are no constituents.
23501 if Ekind
(Item_Id
) = E_Abstract_State
then
23502 if Has_Null_Refinement
(Item_Id
) then
23503 Has_Null_State
:= True;
23505 elsif Has_Non_Null_Refinement
(Item_Id
) then
23506 if Item_Mode
= Name_Input
then
23507 Has_In_State
:= True;
23508 elsif Item_Mode
= Name_In_Out
then
23509 Has_In_Out_State
:= True;
23510 elsif Item_Mode
= Name_Output
then
23511 Has_Out_State
:= True;
23512 elsif Item_Mode
= Name_Proof_In
then
23513 Has_Proof_In_State
:= True;
23518 -- Add the item to the proper list
23520 if Item_Mode
= Name_Input
then
23521 Add_Item
(Item_Id
, In_Items
);
23522 elsif Item_Mode
= Name_In_Out
then
23523 Add_Item
(Item_Id
, In_Out_Items
);
23524 elsif Item_Mode
= Name_Output
then
23525 Add_Item
(Item_Id
, Out_Items
);
23526 elsif Item_Mode
= Name_Proof_In
then
23527 Add_Item
(Item_Id
, Proof_In_Items
);
23529 end Collect_Global_Item
;
23535 -- Start of processing for Collect_Global_Items
23538 if Nkind
(List
) = N_Null
then
23541 -- Single global item declaration
23543 elsif Nkind_In
(List
, N_Expanded_Name
,
23545 N_Selected_Component
)
23547 Collect_Global_Item
(List
, Mode
);
23549 -- Single global list or moded global list declaration
23551 elsif Nkind
(List
) = N_Aggregate
then
23553 -- The declaration of a simple global list appear as a collection
23556 if Present
(Expressions
(List
)) then
23557 Item
:= First
(Expressions
(List
));
23558 while Present
(Item
) loop
23559 Collect_Global_Item
(Item
, Mode
);
23563 -- The declaration of a moded global list appears as a collection
23564 -- of component associations where individual choices denote mode.
23566 elsif Present
(Component_Associations
(List
)) then
23567 Item
:= First
(Component_Associations
(List
));
23568 while Present
(Item
) loop
23569 Collect_Global_Items
23570 (List
=> Expression
(Item
),
23571 Mode
=> Chars
(First
(Choices
(Item
))));
23579 raise Program_Error
;
23582 -- To accomodate partial decoration of disabled SPARK features, this
23583 -- routine may be called with illegal input. If this is the case, do
23584 -- not raise Program_Error.
23589 end Collect_Global_Items
;
23591 -------------------------
23592 -- Present_Then_Remove --
23593 -------------------------
23595 function Present_Then_Remove
23597 Item
: Entity_Id
) return Boolean
23602 if Present
(List
) then
23603 Elmt
:= First_Elmt
(List
);
23604 while Present
(Elmt
) loop
23605 if Node
(Elmt
) = Item
then
23606 Remove_Elmt
(List
, Elmt
);
23615 end Present_Then_Remove
;
23617 -------------------------------
23618 -- Report_Extra_Constituents --
23619 -------------------------------
23621 procedure Report_Extra_Constituents
is
23622 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
23623 -- Emit an error for every element of List
23625 ---------------------------------------
23626 -- Report_Extra_Constituents_In_List --
23627 ---------------------------------------
23629 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
23630 Constit_Elmt
: Elmt_Id
;
23633 if Present
(List
) then
23634 Constit_Elmt
:= First_Elmt
(List
);
23635 while Present
(Constit_Elmt
) loop
23636 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
23637 Next_Elmt
(Constit_Elmt
);
23640 end Report_Extra_Constituents_In_List
;
23642 -- Start of processing for Report_Extra_Constituents
23645 -- Do not perform this check in an instance because it was already
23646 -- performed successfully in the generic template.
23648 if Is_Generic_Instance
(Spec_Id
) then
23652 Report_Extra_Constituents_In_List
(In_Constits
);
23653 Report_Extra_Constituents_In_List
(In_Out_Constits
);
23654 Report_Extra_Constituents_In_List
(Out_Constits
);
23655 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
23657 end Report_Extra_Constituents
;
23661 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
23662 Errors
: constant Nat
:= Serious_Errors_Detected
;
23665 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23668 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
23669 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
23671 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
23674 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
23675 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
23677 -- The subprogram declaration lacks pragma Global. This renders
23678 -- Refined_Global useless as there is nothing to refine.
23680 if No
(Global
) then
23682 ("useless refinement, declaration of subprogram & lacks aspect or "
23683 & "pragma Global", N
, Spec_Id
);
23687 -- Extract all relevant items from the corresponding Global pragma
23689 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
23691 -- Package and subprogram bodies are instantiated individually in
23692 -- a separate compiler pass. Due to this mode of instantiation, the
23693 -- refinement of a state may no longer be visible when a subprogram
23694 -- body contract is instantiated. Since the generic template is legal,
23695 -- do not perform this check in the instance to circumvent this oddity.
23697 if Is_Generic_Instance
(Spec_Id
) then
23700 -- Non-instance case
23703 -- The corresponding Global pragma must mention at least one state
23704 -- witha visible refinement at the point Refined_Global is processed.
23705 -- States with null refinements need Refined_Global pragma
23706 -- (SPARK RM 7.2.4(2)).
23708 if not Has_In_State
23709 and then not Has_In_Out_State
23710 and then not Has_Out_State
23711 and then not Has_Proof_In_State
23712 and then not Has_Null_State
23715 ("useless refinement, subprogram & does not depend on abstract "
23716 & "state with visible refinement", N
, Spec_Id
);
23719 -- The global refinement of inputs and outputs cannot be null when
23720 -- the corresponding Global pragma contains at least one item except
23721 -- in the case where we have states with null refinements.
23723 elsif Nkind
(Items
) = N_Null
23725 (Present
(In_Items
)
23726 or else Present
(In_Out_Items
)
23727 or else Present
(Out_Items
)
23728 or else Present
(Proof_In_Items
))
23729 and then not Has_Null_State
23732 ("refinement cannot be null, subprogram & has global items",
23738 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23739 -- This ensures that the categorization of all refined global items is
23740 -- consistent with their role.
23742 Analyze_Global_In_Decl_Part
(N
);
23744 -- Perform all refinement checks with respect to completeness and mode
23747 if Serious_Errors_Detected
= Errors
then
23748 Check_Refined_Global_List
(Items
);
23751 -- For Input states with visible refinement, at least one constituent
23752 -- must be used as an Input in the global refinement.
23754 if Serious_Errors_Detected
= Errors
then
23755 Check_Input_States
;
23758 -- Verify all possible completion variants for In_Out states with
23759 -- visible refinement.
23761 if Serious_Errors_Detected
= Errors
then
23762 Check_In_Out_States
;
23765 -- For Output states with visible refinement, all constituents must be
23766 -- used as Outputs in the global refinement.
23768 if Serious_Errors_Detected
= Errors
then
23769 Check_Output_States
;
23772 -- For Proof_In states with visible refinement, at least one constituent
23773 -- must be used as Proof_In in the global refinement.
23775 if Serious_Errors_Detected
= Errors
then
23776 Check_Proof_In_States
;
23779 -- Emit errors for all constituents that belong to other states with
23780 -- visible refinement that do not appear in Global.
23782 if Serious_Errors_Detected
= Errors
then
23783 Report_Extra_Constituents
;
23785 end Analyze_Refined_Global_In_Decl_Part
;
23787 ----------------------------------------
23788 -- Analyze_Refined_State_In_Decl_Part --
23789 ----------------------------------------
23791 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
23792 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
23793 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
23794 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
23796 Available_States
: Elist_Id
:= No_Elist
;
23797 -- A list of all abstract states defined in the package declaration that
23798 -- are available for refinement. The list is used to report unrefined
23801 Body_States
: Elist_Id
:= No_Elist
;
23802 -- A list of all hidden states that appear in the body of the related
23803 -- package. The list is used to report unused hidden states.
23805 Constituents_Seen
: Elist_Id
:= No_Elist
;
23806 -- A list that contains all constituents processed so far. The list is
23807 -- used to detect multiple uses of the same constituent.
23809 Refined_States_Seen
: Elist_Id
:= No_Elist
;
23810 -- A list that contains all refined states processed so far. The list is
23811 -- used to detect duplicate refinements.
23813 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
23814 -- Perform full analysis of a single refinement clause
23816 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
23817 -- Gather the entities of all abstract states and objects declared in
23818 -- the body state space of package Pack_Id.
23820 procedure Report_Unrefined_States
(States
: Elist_Id
);
23821 -- Emit errors for all unrefined abstract states found in list States
23823 procedure Report_Unused_States
(States
: Elist_Id
);
23824 -- Emit errors for all unused states found in list States
23826 -------------------------------
23827 -- Analyze_Refinement_Clause --
23828 -------------------------------
23830 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
23831 AR_Constit
: Entity_Id
:= Empty
;
23832 AW_Constit
: Entity_Id
:= Empty
;
23833 ER_Constit
: Entity_Id
:= Empty
;
23834 EW_Constit
: Entity_Id
:= Empty
;
23835 -- The entities of external constituents that contain one of the
23836 -- following enabled properties: Async_Readers, Async_Writers,
23837 -- Effective_Reads and Effective_Writes.
23839 External_Constit_Seen
: Boolean := False;
23840 -- Flag used to mark when at least one external constituent is part
23841 -- of the state refinement.
23843 Non_Null_Seen
: Boolean := False;
23844 Null_Seen
: Boolean := False;
23845 -- Flags used to detect multiple uses of null in a single clause or a
23846 -- mixture of null and non-null constituents.
23848 Part_Of_Constits
: Elist_Id
:= No_Elist
;
23849 -- A list of all candidate constituents subject to indicator Part_Of
23850 -- where the encapsulating state is the current state.
23853 State_Id
: Entity_Id
;
23854 -- The current state being refined
23856 procedure Analyze_Constituent
(Constit
: Node_Id
);
23857 -- Perform full analysis of a single constituent
23859 procedure Check_External_Property
23860 (Prop_Nam
: Name_Id
;
23862 Constit
: Entity_Id
);
23863 -- Determine whether a property denoted by name Prop_Nam is present
23864 -- in both the refined state and constituent Constit. Flag Enabled
23865 -- should be set when the property applies to the refined state. If
23866 -- this is not the case, emit an error message.
23868 procedure Check_Matching_State
;
23869 -- Determine whether the state being refined appears in list
23870 -- Available_States. Emit an error when attempting to re-refine the
23871 -- state or when the state is not defined in the package declaration,
23872 -- otherwise remove the state from Available_States.
23874 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
23875 -- Emit errors for all unused Part_Of constituents in list Constits
23877 -------------------------
23878 -- Analyze_Constituent --
23879 -------------------------
23881 procedure Analyze_Constituent
(Constit
: Node_Id
) is
23882 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
);
23883 -- Verify that the constituent Constit_Id is a Ghost entity if the
23884 -- abstract state being refined is also Ghost. If this is the case
23885 -- verify that the Ghost policy in effect at the point of state
23886 -- and constituent declaration is the same.
23888 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
23889 -- Determine whether constituent Constit denoted by its entity
23890 -- Constit_Id appears in Hidden_States. Emit an error when the
23891 -- constituent is not a valid hidden state of the related package
23892 -- or when it is used more than once. Otherwise remove the
23893 -- constituent from Hidden_States.
23895 --------------------------------
23896 -- Check_Matching_Constituent --
23897 --------------------------------
23899 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
23900 procedure Collect_Constituent
;
23901 -- Add constituent Constit_Id to the refinements of State_Id
23903 -------------------------
23904 -- Collect_Constituent --
23905 -------------------------
23907 procedure Collect_Constituent
is
23909 -- Add the constituent to the list of processed items to aid
23910 -- with the detection of duplicates.
23912 Add_Item
(Constit_Id
, Constituents_Seen
);
23914 -- Collect the constituent in the list of refinement items
23915 -- and establish a relation between the refined state and
23918 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
23919 Set_Encapsulating_State
(Constit_Id
, State_Id
);
23921 -- The state has at least one legal constituent, mark the
23922 -- start of the refinement region. The region ends when the
23923 -- body declarations end (see routine Analyze_Declarations).
23925 Set_Has_Visible_Refinement
(State_Id
);
23927 -- When the constituent is external, save its relevant
23928 -- property for further checks.
23930 if Async_Readers_Enabled
(Constit_Id
) then
23931 AR_Constit
:= Constit_Id
;
23932 External_Constit_Seen
:= True;
23935 if Async_Writers_Enabled
(Constit_Id
) then
23936 AW_Constit
:= Constit_Id
;
23937 External_Constit_Seen
:= True;
23940 if Effective_Reads_Enabled
(Constit_Id
) then
23941 ER_Constit
:= Constit_Id
;
23942 External_Constit_Seen
:= True;
23945 if Effective_Writes_Enabled
(Constit_Id
) then
23946 EW_Constit
:= Constit_Id
;
23947 External_Constit_Seen
:= True;
23949 end Collect_Constituent
;
23953 State_Elmt
: Elmt_Id
;
23955 -- Start of processing for Check_Matching_Constituent
23958 -- Detect a duplicate use of a constituent
23960 if Contains
(Constituents_Seen
, Constit_Id
) then
23962 ("duplicate use of constituent &", Constit
, Constit_Id
);
23966 -- The constituent is subject to a Part_Of indicator
23968 if Present
(Encapsulating_State
(Constit_Id
)) then
23969 if Encapsulating_State
(Constit_Id
) = State_Id
then
23970 Check_Ghost_Constituent
(Constit_Id
);
23971 Remove
(Part_Of_Constits
, Constit_Id
);
23972 Collect_Constituent
;
23974 -- The constituent is part of another state and is used
23975 -- incorrectly in the refinement of the current state.
23978 Error_Msg_Name_1
:= Chars
(State_Id
);
23980 ("& cannot act as constituent of state %",
23981 Constit
, Constit_Id
);
23983 ("\Part_Of indicator specifies & as encapsulating "
23984 & "state", Constit
, Encapsulating_State
(Constit_Id
));
23987 -- The only other source of legal constituents is the body
23988 -- state space of the related package.
23991 if Present
(Body_States
) then
23992 State_Elmt
:= First_Elmt
(Body_States
);
23993 while Present
(State_Elmt
) loop
23995 -- Consume a valid constituent to signal that it has
23996 -- been encountered.
23998 if Node
(State_Elmt
) = Constit_Id
then
23999 Check_Ghost_Constituent
(Constit_Id
);
24000 Remove_Elmt
(Body_States
, State_Elmt
);
24001 Collect_Constituent
;
24005 Next_Elmt
(State_Elmt
);
24009 -- Constants are part of the hidden state of a package, but
24010 -- the compiler cannot determine whether they have variable
24011 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
24012 -- hidden state. Accept the constant quietly even if it is
24013 -- a visible state or lacks a Part_Of indicator.
24015 if Ekind
(Constit_Id
) = E_Constant
then
24018 -- If we get here, then the constituent is not a hidden
24019 -- state of the related package and may not be used in a
24020 -- refinement (SPARK RM 7.2.2(9)).
24023 Error_Msg_Name_1
:= Chars
(Spec_Id
);
24025 ("cannot use & in refinement, constituent is not a "
24026 & "hidden state of package %", Constit
, Constit_Id
);
24029 end Check_Matching_Constituent
;
24031 -----------------------------
24032 -- Check_Ghost_Constituent --
24033 -----------------------------
24035 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
) is
24037 if Is_Ghost_Entity
(State_Id
) then
24038 if Is_Ghost_Entity
(Constit_Id
) then
24040 -- The Ghost policy in effect at the point of abstract
24041 -- state declaration and constituent must match
24042 -- (SPARK RM 6.9(16)).
24044 if Is_Checked_Ghost_Entity
(State_Id
)
24045 and then Is_Ignored_Ghost_Entity
(Constit_Id
)
24047 Error_Msg_Sloc
:= Sloc
(Constit
);
24050 ("incompatible ghost policies in effect", State
);
24052 ("\abstract state & declared with ghost policy "
24053 & "Check", State
, State_Id
);
24055 ("\constituent & declared # with ghost policy "
24056 & "Ignore", State
, Constit_Id
);
24058 elsif Is_Ignored_Ghost_Entity
(State_Id
)
24059 and then Is_Checked_Ghost_Entity
(Constit_Id
)
24061 Error_Msg_Sloc
:= Sloc
(Constit
);
24064 ("incompatible ghost policies in effect", State
);
24066 ("\abstract state & declared with ghost policy "
24067 & "Ignore", State
, State_Id
);
24069 ("\constituent & declared # with ghost policy "
24070 & "Check", State
, Constit_Id
);
24073 -- A constituent of a Ghost abstract state must be a Ghost
24074 -- entity (SPARK RM 7.2.2(12)).
24078 ("constituent of ghost state & must be ghost",
24079 Constit
, State_Id
);
24082 end Check_Ghost_Constituent
;
24086 Constit_Id
: Entity_Id
;
24088 -- Start of processing for Analyze_Constituent
24091 -- Detect multiple uses of null in a single refinement clause or a
24092 -- mixture of null and non-null constituents.
24094 if Nkind
(Constit
) = N_Null
then
24097 ("multiple null constituents not allowed", Constit
);
24099 elsif Non_Null_Seen
then
24101 ("cannot mix null and non-null constituents", Constit
);
24106 -- Collect the constituent in the list of refinement items
24108 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
24110 -- The state has at least one legal constituent, mark the
24111 -- start of the refinement region. The region ends when the
24112 -- body declarations end (see Analyze_Declarations).
24114 Set_Has_Visible_Refinement
(State_Id
);
24117 -- Non-null constituents
24120 Non_Null_Seen
:= True;
24124 ("cannot mix null and non-null constituents", Constit
);
24128 Resolve_State
(Constit
);
24130 -- Ensure that the constituent denotes a valid state or a
24131 -- whole object (SPARK RM 7.2.2(5)).
24133 if Is_Entity_Name
(Constit
) then
24134 Constit_Id
:= Entity_Of
(Constit
);
24136 if Ekind_In
(Constit_Id
, E_Abstract_State
,
24140 Check_Matching_Constituent
(Constit_Id
);
24144 ("constituent & must denote object or state",
24145 Constit
, Constit_Id
);
24148 -- The constituent is illegal
24151 SPARK_Msg_N
("malformed constituent", Constit
);
24154 end Analyze_Constituent
;
24156 -----------------------------
24157 -- Check_External_Property --
24158 -----------------------------
24160 procedure Check_External_Property
24161 (Prop_Nam
: Name_Id
;
24163 Constit
: Entity_Id
)
24166 Error_Msg_Name_1
:= Prop_Nam
;
24168 -- The property is enabled in the related Abstract_State pragma
24169 -- that defines the state (SPARK RM 7.2.8(3)).
24172 if No
(Constit
) then
24174 ("external state & requires at least one constituent with "
24175 & "property %", State
, State_Id
);
24178 -- The property is missing in the declaration of the state, but
24179 -- a constituent is introducing it in the state refinement
24180 -- (SPARK RM 7.2.8(3)).
24182 elsif Present
(Constit
) then
24183 Error_Msg_Name_2
:= Chars
(Constit
);
24185 ("external state & lacks property % set by constituent %",
24188 end Check_External_Property
;
24190 --------------------------
24191 -- Check_Matching_State --
24192 --------------------------
24194 procedure Check_Matching_State
is
24195 State_Elmt
: Elmt_Id
;
24198 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
24200 if Contains
(Refined_States_Seen
, State_Id
) then
24202 ("duplicate refinement of state &", State
, State_Id
);
24206 -- Inspect the abstract states defined in the package declaration
24207 -- looking for a match.
24209 State_Elmt
:= First_Elmt
(Available_States
);
24210 while Present
(State_Elmt
) loop
24212 -- A valid abstract state is being refined in the body. Add
24213 -- the state to the list of processed refined states to aid
24214 -- with the detection of duplicate refinements. Remove the
24215 -- state from Available_States to signal that it has already
24218 if Node
(State_Elmt
) = State_Id
then
24219 Add_Item
(State_Id
, Refined_States_Seen
);
24220 Remove_Elmt
(Available_States
, State_Elmt
);
24224 Next_Elmt
(State_Elmt
);
24227 -- If we get here, we are refining a state that is not defined in
24228 -- the package declaration.
24230 Error_Msg_Name_1
:= Chars
(Spec_Id
);
24232 ("cannot refine state, & is not defined in package %",
24234 end Check_Matching_State
;
24236 --------------------------------
24237 -- Report_Unused_Constituents --
24238 --------------------------------
24240 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
24241 Constit_Elmt
: Elmt_Id
;
24242 Constit_Id
: Entity_Id
;
24243 Posted
: Boolean := False;
24246 if Present
(Constits
) then
24247 Constit_Elmt
:= First_Elmt
(Constits
);
24248 while Present
(Constit_Elmt
) loop
24249 Constit_Id
:= Node
(Constit_Elmt
);
24251 -- Generate an error message of the form:
24253 -- state ... has unused Part_Of constituents
24254 -- abstract state ... defined at ...
24255 -- constant ... defined at ...
24256 -- variable ... defined at ...
24261 ("state & has unused Part_Of constituents",
24265 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
24267 if Ekind
(Constit_Id
) = E_Abstract_State
then
24269 ("\abstract state & defined #", State
, Constit_Id
);
24271 elsif Ekind
(Constit_Id
) = E_Constant
then
24273 ("\constant & defined #", State
, Constit_Id
);
24276 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
24277 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
24280 Next_Elmt
(Constit_Elmt
);
24283 end Report_Unused_Constituents
;
24285 -- Local declarations
24287 Body_Ref
: Node_Id
;
24288 Body_Ref_Elmt
: Elmt_Id
;
24290 Extra_State
: Node_Id
;
24292 -- Start of processing for Analyze_Refinement_Clause
24295 -- A refinement clause appears as a component association where the
24296 -- sole choice is the state and the expressions are the constituents.
24297 -- This is a syntax error, always report.
24299 if Nkind
(Clause
) /= N_Component_Association
then
24300 Error_Msg_N
("malformed state refinement clause", Clause
);
24304 -- Analyze the state name of a refinement clause
24306 State
:= First
(Choices
(Clause
));
24309 Resolve_State
(State
);
24311 -- Ensure that the state name denotes a valid abstract state that is
24312 -- defined in the spec of the related package.
24314 if Is_Entity_Name
(State
) then
24315 State_Id
:= Entity_Of
(State
);
24317 -- Catch any attempts to re-refine a state or refine a state that
24318 -- is not defined in the package declaration.
24320 if Ekind
(State_Id
) = E_Abstract_State
then
24321 Check_Matching_State
;
24324 ("& must denote an abstract state", State
, State_Id
);
24328 -- References to a state with visible refinement are illegal.
24329 -- When nested packages are involved, detecting such references is
24330 -- tricky because pragma Refined_State is analyzed later than the
24331 -- offending pragma Depends or Global. References that occur in
24332 -- such nested context are stored in a list. Emit errors for all
24333 -- references found in Body_References (SPARK RM 6.1.4(8)).
24335 if Present
(Body_References
(State_Id
)) then
24336 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
24337 while Present
(Body_Ref_Elmt
) loop
24338 Body_Ref
:= Node
(Body_Ref_Elmt
);
24340 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
24341 Error_Msg_Sloc
:= Sloc
(State
);
24342 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
24344 Next_Elmt
(Body_Ref_Elmt
);
24348 -- The state name is illegal. This is a syntax error, always report.
24351 Error_Msg_N
("malformed state name in refinement clause", State
);
24355 -- A refinement clause may only refine one state at a time
24357 Extra_State
:= Next
(State
);
24359 if Present
(Extra_State
) then
24361 ("refinement clause cannot cover multiple states", Extra_State
);
24364 -- Replicate the Part_Of constituents of the refined state because
24365 -- the algorithm will consume items.
24367 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
24369 -- Analyze all constituents of the refinement. Multiple constituents
24370 -- appear as an aggregate.
24372 Constit
:= Expression
(Clause
);
24374 if Nkind
(Constit
) = N_Aggregate
then
24375 if Present
(Component_Associations
(Constit
)) then
24377 ("constituents of refinement clause must appear in "
24378 & "positional form", Constit
);
24380 else pragma Assert
(Present
(Expressions
(Constit
)));
24381 Constit
:= First
(Expressions
(Constit
));
24382 while Present
(Constit
) loop
24383 Analyze_Constituent
(Constit
);
24388 -- Various forms of a single constituent. Note that these may include
24389 -- malformed constituents.
24392 Analyze_Constituent
(Constit
);
24395 -- A refined external state is subject to special rules with respect
24396 -- to its properties and constituents.
24398 if Is_External_State
(State_Id
) then
24400 -- The set of properties that all external constituents yield must
24401 -- match that of the refined state. There are two cases to detect:
24402 -- the refined state lacks a property or has an extra property.
24404 if External_Constit_Seen
then
24405 Check_External_Property
24406 (Prop_Nam
=> Name_Async_Readers
,
24407 Enabled
=> Async_Readers_Enabled
(State_Id
),
24408 Constit
=> AR_Constit
);
24410 Check_External_Property
24411 (Prop_Nam
=> Name_Async_Writers
,
24412 Enabled
=> Async_Writers_Enabled
(State_Id
),
24413 Constit
=> AW_Constit
);
24415 Check_External_Property
24416 (Prop_Nam
=> Name_Effective_Reads
,
24417 Enabled
=> Effective_Reads_Enabled
(State_Id
),
24418 Constit
=> ER_Constit
);
24420 Check_External_Property
24421 (Prop_Nam
=> Name_Effective_Writes
,
24422 Enabled
=> Effective_Writes_Enabled
(State_Id
),
24423 Constit
=> EW_Constit
);
24425 -- An external state may be refined to null (SPARK RM 7.2.8(2))
24427 elsif Null_Seen
then
24430 -- The external state has constituents, but none of them are
24431 -- external (SPARK RM 7.2.8(2)).
24435 ("external state & requires at least one external "
24436 & "constituent or null refinement", State
, State_Id
);
24439 -- When a refined state is not external, it should not have external
24440 -- constituents (SPARK RM 7.2.8(1)).
24442 elsif External_Constit_Seen
then
24444 ("non-external state & cannot contain external constituents in "
24445 & "refinement", State
, State_Id
);
24448 -- Ensure that all Part_Of candidate constituents have been mentioned
24449 -- in the refinement clause.
24451 Report_Unused_Constituents
(Part_Of_Constits
);
24452 end Analyze_Refinement_Clause
;
24454 -------------------------
24455 -- Collect_Body_States --
24456 -------------------------
24458 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
24459 Result
: Elist_Id
:= No_Elist
;
24460 -- A list containing all body states of Pack_Id
24462 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
24463 -- Gather the entities of all abstract states and objects declared in
24464 -- the visible state space of package Pack_Id.
24466 ----------------------------
24467 -- Collect_Visible_States --
24468 ----------------------------
24470 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
24471 Item_Id
: Entity_Id
;
24474 -- Traverse the entity chain of the package and inspect all
24477 Item_Id
:= First_Entity
(Pack_Id
);
24478 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
24480 -- Do not consider internally generated items as those cannot
24481 -- be named and participate in refinement.
24483 if not Comes_From_Source
(Item_Id
) then
24486 elsif Ekind
(Item_Id
) = E_Abstract_State
then
24487 Add_Item
(Item_Id
, Result
);
24489 -- Do not consider constants or variables that map generic
24490 -- formals to their actuals, as the formals cannot be named
24491 -- from the outside and participate in refinement.
24493 elsif Ekind_In
(Item_Id
, E_Constant
, E_Variable
)
24494 and then No
(Corresponding_Generic_Association
24495 (Declaration_Node
(Item_Id
)))
24497 Add_Item
(Item_Id
, Result
);
24499 -- Recursively gather the visible states of a nested package
24501 elsif Ekind
(Item_Id
) = E_Package
then
24502 Collect_Visible_States
(Item_Id
);
24505 Next_Entity
(Item_Id
);
24507 end Collect_Visible_States
;
24511 Pack_Body
: constant Node_Id
:=
24512 Declaration_Node
(Body_Entity
(Pack_Id
));
24514 Item_Id
: Entity_Id
;
24516 -- Start of processing for Collect_Body_States
24519 -- Inspect the declarations of the body looking for source objects,
24520 -- packages and package instantiations.
24522 Decl
:= First
(Declarations
(Pack_Body
));
24523 while Present
(Decl
) loop
24525 -- Capture source objects as internally generated temporaries
24526 -- cannot be named and participate in refinement.
24528 if Nkind
(Decl
) = N_Object_Declaration
then
24529 Item_Id
:= Defining_Entity
(Decl
);
24531 if Comes_From_Source
(Item_Id
) then
24532 Add_Item
(Item_Id
, Result
);
24535 -- Capture the visible abstract states and objects of a source
24536 -- package [instantiation].
24538 elsif Nkind
(Decl
) = N_Package_Declaration
then
24539 Item_Id
:= Defining_Entity
(Decl
);
24541 if Comes_From_Source
(Item_Id
) then
24542 Collect_Visible_States
(Item_Id
);
24550 end Collect_Body_States
;
24552 -----------------------------
24553 -- Report_Unrefined_States --
24554 -----------------------------
24556 procedure Report_Unrefined_States
(States
: Elist_Id
) is
24557 State_Elmt
: Elmt_Id
;
24560 if Present
(States
) then
24561 State_Elmt
:= First_Elmt
(States
);
24562 while Present
(State_Elmt
) loop
24564 ("abstract state & must be refined", Node
(State_Elmt
));
24566 Next_Elmt
(State_Elmt
);
24569 end Report_Unrefined_States
;
24571 --------------------------
24572 -- Report_Unused_States --
24573 --------------------------
24575 procedure Report_Unused_States
(States
: Elist_Id
) is
24576 Posted
: Boolean := False;
24577 State_Elmt
: Elmt_Id
;
24578 State_Id
: Entity_Id
;
24581 if Present
(States
) then
24582 State_Elmt
:= First_Elmt
(States
);
24583 while Present
(State_Elmt
) loop
24584 State_Id
:= Node
(State_Elmt
);
24586 -- Constants are part of the hidden state of a package, but the
24587 -- compiler cannot determine whether they have variable input
24588 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
24589 -- hidden state. Do not emit an error when a constant does not
24590 -- participate in a state refinement, even though it acts as a
24593 if Ekind
(State_Id
) = E_Constant
then
24596 -- Generate an error message of the form:
24598 -- body of package ... has unused hidden states
24599 -- abstract state ... defined at ...
24600 -- variable ... defined at ...
24606 ("body of package & has unused hidden states", Body_Id
);
24609 Error_Msg_Sloc
:= Sloc
(State_Id
);
24611 if Ekind
(State_Id
) = E_Abstract_State
then
24613 ("\abstract state & defined #", Body_Id
, State_Id
);
24616 pragma Assert
(Ekind
(State_Id
) = E_Variable
);
24617 SPARK_Msg_NE
("\variable & defined #", Body_Id
, State_Id
);
24621 Next_Elmt
(State_Elmt
);
24624 end Report_Unused_States
;
24626 -- Local declarations
24628 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
24631 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24636 -- Replicate the abstract states declared by the package because the
24637 -- matching algorithm will consume states.
24639 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
24641 -- Gather all abstract states and objects declared in the visible
24642 -- state space of the package body. These items must be utilized as
24643 -- constituents in a state refinement.
24645 Body_States
:= Collect_Body_States
(Spec_Id
);
24647 -- Multiple non-null state refinements appear as an aggregate
24649 if Nkind
(Clauses
) = N_Aggregate
then
24650 if Present
(Expressions
(Clauses
)) then
24652 ("state refinements must appear as component associations",
24655 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
24656 Clause
:= First
(Component_Associations
(Clauses
));
24657 while Present
(Clause
) loop
24658 Analyze_Refinement_Clause
(Clause
);
24663 -- Various forms of a single state refinement. Note that these may
24664 -- include malformed refinements.
24667 Analyze_Refinement_Clause
(Clauses
);
24670 -- List all abstract states that were left unrefined
24672 Report_Unrefined_States
(Available_States
);
24674 -- Ensure that all abstract states and objects declared in the body
24675 -- state space of the related package are utilized as constituents.
24677 Report_Unused_States
(Body_States
);
24678 end Analyze_Refined_State_In_Decl_Part
;
24680 ------------------------------------
24681 -- Analyze_Test_Case_In_Decl_Part --
24682 ------------------------------------
24684 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
24685 Subp_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
24686 Spec_Id
: constant Entity_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
24688 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
24689 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
24690 -- denoted by Arg_Nam.
24692 ------------------------------
24693 -- Preanalyze_Test_Case_Arg --
24694 ------------------------------
24696 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
24700 -- Preanalyze the original aspect argument for ASIS or for a generic
24701 -- subprogram to properly capture global references.
24703 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
24707 Arg_Nam
=> Arg_Nam
,
24708 From_Aspect
=> True);
24710 if Present
(Arg
) then
24711 Preanalyze_Assert_Expression
24712 (Expression
(Arg
), Standard_Boolean
);
24716 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
24718 if Present
(Arg
) then
24719 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
24721 end Preanalyze_Test_Case_Arg
;
24725 Restore_Scope
: Boolean := False;
24727 -- Start of processing for Analyze_Test_Case_In_Decl_Part
24730 -- Ensure that the formal parameters are visible when analyzing all
24731 -- clauses. This falls out of the general rule of aspects pertaining
24732 -- to subprogram declarations.
24734 if not In_Open_Scopes
(Spec_Id
) then
24735 Restore_Scope
:= True;
24736 Push_Scope
(Spec_Id
);
24738 if Is_Generic_Subprogram
(Spec_Id
) then
24739 Install_Generic_Formals
(Spec_Id
);
24741 Install_Formals
(Spec_Id
);
24745 Preanalyze_Test_Case_Arg
(Name_Requires
);
24746 Preanalyze_Test_Case_Arg
(Name_Ensures
);
24748 if Restore_Scope
then
24752 -- Currently it is not possible to inline pre/postconditions on a
24753 -- subprogram subject to pragma Inline_Always.
24755 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
24756 end Analyze_Test_Case_In_Decl_Part
;
24762 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
24767 if Present
(List
) then
24768 Elmt
:= First_Elmt
(List
);
24769 while Present
(Elmt
) loop
24770 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
24773 Id
:= Entity_Of
(Node
(Elmt
));
24776 if Id
= Item_Id
then
24787 -----------------------------
24788 -- Check_Applicable_Policy --
24789 -----------------------------
24791 procedure Check_Applicable_Policy
(N
: Node_Id
) is
24795 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
24798 -- No effect if not valid assertion kind name
24800 if not Is_Valid_Assertion_Kind
(Ename
) then
24804 -- Loop through entries in check policy list
24806 PP
:= Opt
.Check_Policy_List
;
24807 while Present
(PP
) loop
24809 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24810 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24814 or else Pnm
= Name_Assertion
24815 or else (Pnm
= Name_Statement_Assertions
24816 and then Nam_In
(Ename
, Name_Assert
,
24817 Name_Assert_And_Cut
,
24819 Name_Loop_Invariant
,
24820 Name_Loop_Variant
))
24822 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
24825 when Name_Off | Name_Ignore
=>
24826 Set_Is_Ignored
(N
, True);
24827 Set_Is_Checked
(N
, False);
24829 when Name_On | Name_Check
=>
24830 Set_Is_Checked
(N
, True);
24831 Set_Is_Ignored
(N
, False);
24833 when Name_Disable
=>
24834 Set_Is_Ignored
(N
, True);
24835 Set_Is_Checked
(N
, False);
24836 Set_Is_Disabled
(N
, True);
24838 -- That should be exhaustive, the null here is a defence
24839 -- against a malformed tree from previous errors.
24848 PP
:= Next_Pragma
(PP
);
24852 -- If there are no specific entries that matched, then we let the
24853 -- setting of assertions govern. Note that this provides the needed
24854 -- compatibility with the RM for the cases of assertion, invariant,
24855 -- precondition, predicate, and postcondition.
24857 if Assertions_Enabled
then
24858 Set_Is_Checked
(N
, True);
24859 Set_Is_Ignored
(N
, False);
24861 Set_Is_Checked
(N
, False);
24862 Set_Is_Ignored
(N
, True);
24864 end Check_Applicable_Policy
;
24866 -------------------------------
24867 -- Check_External_Properties --
24868 -------------------------------
24870 procedure Check_External_Properties
24878 -- All properties enabled
24880 if AR
and AW
and ER
and EW
then
24883 -- Async_Readers + Effective_Writes
24884 -- Async_Readers + Async_Writers + Effective_Writes
24886 elsif AR
and EW
and not ER
then
24889 -- Async_Writers + Effective_Reads
24890 -- Async_Readers + Async_Writers + Effective_Reads
24892 elsif AW
and ER
and not EW
then
24895 -- Async_Readers + Async_Writers
24897 elsif AR
and AW
and not ER
and not EW
then
24902 elsif AR
and not AW
and not ER
and not EW
then
24907 elsif AW
and not AR
and not ER
and not EW
then
24912 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24915 end Check_External_Properties
;
24921 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
24925 -- Loop through entries in check policy list
24927 PP
:= Opt
.Check_Policy_List
;
24928 while Present
(PP
) loop
24930 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24931 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24935 or else (Pnm
= Name_Assertion
24936 and then Is_Valid_Assertion_Kind
(Nam
))
24937 or else (Pnm
= Name_Statement_Assertions
24938 and then Nam_In
(Nam
, Name_Assert
,
24939 Name_Assert_And_Cut
,
24941 Name_Loop_Invariant
,
24942 Name_Loop_Variant
))
24944 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
24945 when Name_On | Name_Check
=>
24947 when Name_Off | Name_Ignore
=>
24948 return Name_Ignore
;
24949 when Name_Disable
=>
24950 return Name_Disable
;
24952 raise Program_Error
;
24956 PP
:= Next_Pragma
(PP
);
24961 -- If there are no specific entries that matched, then we let the
24962 -- setting of assertions govern. Note that this provides the needed
24963 -- compatibility with the RM for the cases of assertion, invariant,
24964 -- precondition, predicate, and postcondition.
24966 if Assertions_Enabled
then
24969 return Name_Ignore
;
24973 ---------------------------
24974 -- Check_Missing_Part_Of --
24975 ---------------------------
24977 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
24978 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
24979 -- Determine whether a package denoted by Pack_Id declares at least one
24982 -----------------------
24983 -- Has_Visible_State --
24984 -----------------------
24986 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
24987 Item_Id
: Entity_Id
;
24990 -- Traverse the entity chain of the package trying to find at least
24991 -- one visible abstract state, variable or a package [instantiation]
24992 -- that declares a visible state.
24994 Item_Id
:= First_Entity
(Pack_Id
);
24995 while Present
(Item_Id
)
24996 and then not In_Private_Part
(Item_Id
)
24998 -- Do not consider internally generated items
25000 if not Comes_From_Source
(Item_Id
) then
25003 -- A visible state has been found
25005 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
25008 -- Recursively peek into nested packages and instantiations
25010 elsif Ekind
(Item_Id
) = E_Package
25011 and then Has_Visible_State
(Item_Id
)
25016 Next_Entity
(Item_Id
);
25020 end Has_Visible_State
;
25024 Pack_Id
: Entity_Id
;
25025 Placement
: State_Space_Kind
;
25027 -- Start of processing for Check_Missing_Part_Of
25030 -- Do not consider abstract states, variables or package instantiations
25031 -- coming from an instance as those always inherit the Part_Of indicator
25032 -- of the instance itself.
25034 if In_Instance
then
25037 -- Do not consider internally generated entities as these can never
25038 -- have a Part_Of indicator.
25040 elsif not Comes_From_Source
(Item_Id
) then
25043 -- Perform these checks only when SPARK_Mode is enabled as they will
25044 -- interfere with standard Ada rules and produce false positives.
25046 elsif SPARK_Mode
/= On
then
25049 -- Do not consider constants, because the compiler cannot accurately
25050 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
25051 -- act as a hidden state of a package.
25053 elsif Ekind
(Item_Id
) = E_Constant
then
25057 -- Find where the abstract state, variable or package instantiation
25058 -- lives with respect to the state space.
25060 Find_Placement_In_State_Space
25061 (Item_Id
=> Item_Id
,
25062 Placement
=> Placement
,
25063 Pack_Id
=> Pack_Id
);
25065 -- Items that appear in a non-package construct (subprogram, block, etc)
25066 -- do not require a Part_Of indicator because they can never act as a
25069 if Placement
= Not_In_Package
then
25072 -- An item declared in the body state space of a package always act as a
25073 -- constituent and does not need explicit Part_Of indicator.
25075 elsif Placement
= Body_State_Space
then
25078 -- In general an item declared in the visible state space of a package
25079 -- does not require a Part_Of indicator. The only exception is when the
25080 -- related package is a private child unit in which case Part_Of must
25081 -- denote a state in the parent unit or in one of its descendants.
25083 elsif Placement
= Visible_State_Space
then
25084 if Is_Child_Unit
(Pack_Id
)
25085 and then Is_Private_Descendant
(Pack_Id
)
25087 -- A package instantiation does not need a Part_Of indicator when
25088 -- the related generic template has no visible state.
25090 if Ekind
(Item_Id
) = E_Package
25091 and then Is_Generic_Instance
(Item_Id
)
25092 and then not Has_Visible_State
(Item_Id
)
25096 -- All other cases require Part_Of
25100 ("indicator Part_Of is required in this context "
25101 & "(SPARK RM 7.2.6(3))", Item_Id
);
25102 Error_Msg_Name_1
:= Chars
(Pack_Id
);
25104 ("\& is declared in the visible part of private child "
25105 & "unit %", Item_Id
);
25109 -- When the item appears in the private state space of a packge, it must
25110 -- be a part of some state declared by the said package.
25112 else pragma Assert
(Placement
= Private_State_Space
);
25114 -- The related package does not declare a state, the item cannot act
25115 -- as a Part_Of constituent.
25117 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
25120 -- A package instantiation does not need a Part_Of indicator when the
25121 -- related generic template has no visible state.
25123 elsif Ekind
(Pack_Id
) = E_Package
25124 and then Is_Generic_Instance
(Pack_Id
)
25125 and then not Has_Visible_State
(Pack_Id
)
25129 -- All other cases require Part_Of
25133 ("indicator Part_Of is required in this context "
25134 & "(SPARK RM 7.2.6(2))", Item_Id
);
25135 Error_Msg_Name_1
:= Chars
(Pack_Id
);
25137 ("\& is declared in the private part of package %", Item_Id
);
25140 end Check_Missing_Part_Of
;
25142 ---------------------------------------------------
25143 -- Check_Postcondition_Use_In_Inlined_Subprogram --
25144 ---------------------------------------------------
25146 procedure Check_Postcondition_Use_In_Inlined_Subprogram
25148 Spec_Id
: Entity_Id
)
25151 if Warn_On_Redundant_Constructs
25152 and then Has_Pragma_Inline_Always
(Spec_Id
)
25154 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
25156 if From_Aspect_Specification
(Prag
) then
25158 ("aspect % not enforced on inlined subprogram &?r?",
25159 Corresponding_Aspect
(Prag
), Spec_Id
);
25162 ("pragma % not enforced on inlined subprogram &?r?",
25166 end Check_Postcondition_Use_In_Inlined_Subprogram
;
25168 -------------------------------------
25169 -- Check_State_And_Constituent_Use --
25170 -------------------------------------
25172 procedure Check_State_And_Constituent_Use
25173 (States
: Elist_Id
;
25174 Constits
: Elist_Id
;
25177 function Find_Encapsulating_State
25178 (Constit_Id
: Entity_Id
) return Entity_Id
;
25179 -- Given the entity of a constituent, try to find a corresponding
25180 -- encapsulating state that appears in the same context. The routine
25181 -- returns Empty is no such state is found.
25183 ------------------------------
25184 -- Find_Encapsulating_State --
25185 ------------------------------
25187 function Find_Encapsulating_State
25188 (Constit_Id
: Entity_Id
) return Entity_Id
25190 State_Id
: Entity_Id
;
25193 -- Since a constituent may be part of a larger constituent set, climb
25194 -- the encapsulated state chain looking for a state that appears in
25195 -- the same context.
25197 State_Id
:= Encapsulating_State
(Constit_Id
);
25198 while Present
(State_Id
) loop
25199 if Contains
(States
, State_Id
) then
25203 State_Id
:= Encapsulating_State
(State_Id
);
25207 end Find_Encapsulating_State
;
25211 Constit_Elmt
: Elmt_Id
;
25212 Constit_Id
: Entity_Id
;
25213 State_Id
: Entity_Id
;
25215 -- Start of processing for Check_State_And_Constituent_Use
25218 -- Nothing to do if there are no states or constituents
25220 if No
(States
) or else No
(Constits
) then
25224 -- Inspect the list of constituents and try to determine whether its
25225 -- encapsulating state is in list States.
25227 Constit_Elmt
:= First_Elmt
(Constits
);
25228 while Present
(Constit_Elmt
) loop
25229 Constit_Id
:= Node
(Constit_Elmt
);
25231 -- Determine whether the constituent is part of an encapsulating
25232 -- state that appears in the same context and if this is the case,
25233 -- emit an error (SPARK RM 7.2.6(7)).
25235 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
25237 if Present
(State_Id
) then
25238 Error_Msg_Name_1
:= Chars
(Constit_Id
);
25240 ("cannot mention state & and its constituent % in the same "
25241 & "context", Context
, State_Id
);
25245 Next_Elmt
(Constit_Elmt
);
25247 end Check_State_And_Constituent_Use
;
25249 ---------------------------------------
25250 -- Collect_Subprogram_Inputs_Outputs --
25251 ---------------------------------------
25253 procedure Collect_Subprogram_Inputs_Outputs
25254 (Subp_Id
: Entity_Id
;
25255 Synthesize
: Boolean := False;
25256 Subp_Inputs
: in out Elist_Id
;
25257 Subp_Outputs
: in out Elist_Id
;
25258 Global_Seen
: out Boolean)
25260 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
25261 -- Collect all relevant items from a dependency clause
25263 procedure Collect_Global_List
25265 Mode
: Name_Id
:= Name_Input
);
25266 -- Collect all relevant items from a global list
25268 -------------------------------
25269 -- Collect_Dependency_Clause --
25270 -------------------------------
25272 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
25273 procedure Collect_Dependency_Item
25275 Is_Input
: Boolean);
25276 -- Add an item to the proper subprogram input or output collection
25278 -----------------------------
25279 -- Collect_Dependency_Item --
25280 -----------------------------
25282 procedure Collect_Dependency_Item
25284 Is_Input
: Boolean)
25289 -- Nothing to collect when the item is null
25291 if Nkind
(Item
) = N_Null
then
25294 -- Ditto for attribute 'Result
25296 elsif Is_Attribute_Result
(Item
) then
25299 -- Multiple items appear as an aggregate
25301 elsif Nkind
(Item
) = N_Aggregate
then
25302 Extra
:= First
(Expressions
(Item
));
25303 while Present
(Extra
) loop
25304 Collect_Dependency_Item
(Extra
, Is_Input
);
25308 -- Otherwise this is a solitary item
25312 Add_Item
(Item
, Subp_Inputs
);
25314 Add_Item
(Item
, Subp_Outputs
);
25317 end Collect_Dependency_Item
;
25319 -- Start of processing for Collect_Dependency_Clause
25322 if Nkind
(Clause
) = N_Null
then
25325 -- A dependency cause appears as component association
25327 elsif Nkind
(Clause
) = N_Component_Association
then
25328 Collect_Dependency_Item
25329 (Item
=> Expression
(Clause
),
25332 Collect_Dependency_Item
25333 (Item
=> First
(Choices
(Clause
)),
25334 Is_Input
=> False);
25336 -- To accomodate partial decoration of disabled SPARK features, this
25337 -- routine may be called with illegal input. If this is the case, do
25338 -- not raise Program_Error.
25343 end Collect_Dependency_Clause
;
25345 -------------------------
25346 -- Collect_Global_List --
25347 -------------------------
25349 procedure Collect_Global_List
25351 Mode
: Name_Id
:= Name_Input
)
25353 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
25354 -- Add an item to the proper subprogram input or output collection
25356 -------------------------
25357 -- Collect_Global_Item --
25358 -------------------------
25360 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
25362 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
25363 Add_Item
(Item
, Subp_Inputs
);
25366 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
25367 Add_Item
(Item
, Subp_Outputs
);
25369 end Collect_Global_Item
;
25376 -- Start of processing for Collect_Global_List
25379 if Nkind
(List
) = N_Null
then
25382 -- Single global item declaration
25384 elsif Nkind_In
(List
, N_Expanded_Name
,
25386 N_Selected_Component
)
25388 Collect_Global_Item
(List
, Mode
);
25390 -- Simple global list or moded global list declaration
25392 elsif Nkind
(List
) = N_Aggregate
then
25393 if Present
(Expressions
(List
)) then
25394 Item
:= First
(Expressions
(List
));
25395 while Present
(Item
) loop
25396 Collect_Global_Item
(Item
, Mode
);
25401 Assoc
:= First
(Component_Associations
(List
));
25402 while Present
(Assoc
) loop
25403 Collect_Global_List
25404 (List
=> Expression
(Assoc
),
25405 Mode
=> Chars
(First
(Choices
(Assoc
))));
25410 -- To accomodate partial decoration of disabled SPARK features, this
25411 -- routine may be called with illegal input. If this is the case, do
25412 -- not raise Program_Error.
25417 end Collect_Global_List
;
25421 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
25422 Spec_Id
: constant Entity_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
25426 Formal
: Entity_Id
;
25430 -- Start of processing for Collect_Subprogram_Inputs_Outputs
25433 Global_Seen
:= False;
25435 -- Process all [generic] formal parameters
25437 Formal
:= First_Entity
(Spec_Id
);
25438 while Present
(Formal
) loop
25439 if Ekind_In
(Formal
, E_Generic_In_Parameter
,
25440 E_In_Out_Parameter
,
25443 Add_Item
(Formal
, Subp_Inputs
);
25446 if Ekind_In
(Formal
, E_Generic_In_Out_Parameter
,
25447 E_In_Out_Parameter
,
25450 Add_Item
(Formal
, Subp_Outputs
);
25452 -- Out parameters can act as inputs when the related type is
25453 -- tagged, unconstrained array, unconstrained record or record
25454 -- with unconstrained components.
25456 if Ekind
(Formal
) = E_Out_Parameter
25457 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
25459 Add_Item
(Formal
, Subp_Inputs
);
25463 Next_Entity
(Formal
);
25466 -- When processing a subprogram body, look for pragmas Refined_Depends
25467 -- and Refined_Global as they specify the inputs and outputs.
25469 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
25470 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
25471 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
25473 -- Subprogram declaration or stand alone body case, look for pragmas
25474 -- Depends and Global
25477 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
25478 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25481 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
25482 -- because it provides finer granularity of inputs and outputs.
25484 if Present
(Global
) then
25485 Global_Seen
:= True;
25486 List
:= Expression
(Get_Argument
(Global
, Spec_Id
));
25488 -- The pragma may not have been analyzed because of the arbitrary
25489 -- declaration order of aspects. Make sure that it is analyzed for
25490 -- the purposes of item extraction.
25492 if not Analyzed
(List
) then
25493 if Pragma_Name
(Global
) = Name_Refined_Global
then
25494 Analyze_Refined_Global_In_Decl_Part
(Global
);
25496 Analyze_Global_In_Decl_Part
(Global
);
25500 Collect_Global_List
(List
);
25502 -- When the related subprogram lacks pragma [Refined_]Global, fall back
25503 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
25504 -- the inputs and outputs from [Refined_]Depends.
25506 elsif Synthesize
and then Present
(Depends
) then
25507 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
25509 -- Multiple dependency clauses appear as an aggregate
25511 if Nkind
(Clauses
) = N_Aggregate
then
25512 Clause
:= First
(Component_Associations
(Clauses
));
25513 while Present
(Clause
) loop
25514 Collect_Dependency_Clause
(Clause
);
25518 -- Otherwise this is a single dependency clause
25521 Collect_Dependency_Clause
(Clauses
);
25524 end Collect_Subprogram_Inputs_Outputs
;
25526 ---------------------------------
25527 -- Delay_Config_Pragma_Analyze --
25528 ---------------------------------
25530 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
25532 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
25533 Name_Priority_Specific_Dispatching
);
25534 end Delay_Config_Pragma_Analyze
;
25536 -----------------------
25537 -- Duplication_Error --
25538 -----------------------
25540 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
25541 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
25542 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
25545 Error_Msg_Sloc
:= Sloc
(Prev
);
25546 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
25548 -- Emit a precise message to distinguish between source pragmas and
25549 -- pragmas generated from aspects. The ordering of the two pragmas is
25553 -- Prag -- duplicate
25555 -- No error is emitted when both pragmas come from aspects because this
25556 -- is already detected by the general aspect analysis mechanism.
25558 if Prag_From_Asp
and Prev_From_Asp
then
25560 elsif Prag_From_Asp
then
25561 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
25562 elsif Prev_From_Asp
then
25563 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
25565 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
25567 end Duplication_Error
;
25569 ----------------------------------
25570 -- Find_Related_Package_Or_Body --
25571 ----------------------------------
25573 function Find_Related_Package_Or_Body
25575 Do_Checks
: Boolean := False) return Node_Id
25577 Context
: constant Node_Id
:= Parent
(Prag
);
25578 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
25582 Stmt
:= Prev
(Prag
);
25583 while Present
(Stmt
) loop
25585 -- Skip prior pragmas, but check for duplicates
25587 if Nkind
(Stmt
) = N_Pragma
then
25588 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
25594 -- Skip internally generated code
25596 elsif not Comes_From_Source
(Stmt
) then
25597 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
25599 -- The subprogram declaration is an internally generated spec
25600 -- for an expression function.
25602 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
25605 -- The subprogram is actually an instance housed within an
25606 -- anonymous wrapper package.
25608 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
25613 -- Return the current source construct which is illegal
25622 -- If we fall through, then the pragma was either the first declaration
25623 -- or it was preceded by other pragmas and no source constructs.
25625 -- The pragma is associated with a package. The immediate context in
25626 -- this case is the specification of the package.
25628 if Nkind
(Context
) = N_Package_Specification
then
25629 return Parent
(Context
);
25631 -- The pragma appears in the declarations of a package body
25633 elsif Nkind
(Context
) = N_Package_Body
then
25636 -- The pragma appears in the statements of a package body
25638 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
25639 and then Nkind
(Parent
(Context
)) = N_Package_Body
25641 return Parent
(Context
);
25643 -- The pragma is a byproduct of aspect expansion, return the related
25644 -- context of the original aspect. This case has a lower priority as
25645 -- the above circuitry pinpoints precisely the related context.
25647 elsif Present
(Corresponding_Aspect
(Prag
)) then
25648 return Parent
(Corresponding_Aspect
(Prag
));
25650 -- No candidate packge [body] found
25655 end Find_Related_Package_Or_Body
;
25657 -------------------------------------
25658 -- Find_Related_Subprogram_Or_Body --
25659 -------------------------------------
25661 function Find_Related_Subprogram_Or_Body
25663 Do_Checks
: Boolean := False) return Node_Id
25665 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
25667 procedure Expression_Function_Error
;
25668 -- Emit an error concerning pragma Prag that illegaly applies to an
25669 -- expression function.
25671 -------------------------------
25672 -- Expression_Function_Error --
25673 -------------------------------
25675 procedure Expression_Function_Error
is
25677 Error_Msg_Name_1
:= Prag_Nam
;
25679 -- Emit a precise message to distinguish between source pragmas and
25680 -- pragmas generated from aspects.
25682 if From_Aspect_Specification
(Prag
) then
25684 ("aspect % cannot apply to a stand alone expression function",
25688 ("pragma % cannot apply to a stand alone expression function",
25691 end Expression_Function_Error
;
25695 Context
: constant Node_Id
:= Parent
(Prag
);
25698 Look_For_Body
: constant Boolean :=
25699 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
25700 Name_Refined_Global
,
25701 Name_Refined_Post
);
25702 -- Refinement pragmas must be associated with a subprogram body [stub]
25704 -- Start of processing for Find_Related_Subprogram_Or_Body
25707 Stmt
:= Prev
(Prag
);
25708 while Present
(Stmt
) loop
25710 -- Skip prior pragmas, but check for duplicates. Pragmas produced
25711 -- by splitting a complex pre/postcondition are not considered to
25714 if Nkind
(Stmt
) = N_Pragma
then
25716 and then not Split_PPC
(Stmt
)
25717 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
25724 -- Emit an error when a refinement pragma appears on an expression
25725 -- function without a completion.
25728 and then Look_For_Body
25729 and then Nkind
(Stmt
) = N_Subprogram_Declaration
25730 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
25731 and then not Has_Completion
(Defining_Entity
(Stmt
))
25733 Expression_Function_Error
;
25736 -- The refinement pragma applies to a subprogram body stub
25738 elsif Look_For_Body
25739 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
25743 -- Skip internally generated code
25745 elsif not Comes_From_Source
(Stmt
) then
25746 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
25748 -- The subprogram declaration is an internally generated spec
25749 -- for an expression function.
25751 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
25754 -- The subprogram is actually an instance housed within an
25755 -- anonymous wrapper package.
25757 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
25762 -- Return the current construct which is either a subprogram body,
25763 -- a subprogram declaration or is illegal.
25772 -- If we fall through, then the pragma was either the first declaration
25773 -- or it was preceded by other pragmas and no source constructs.
25775 -- The pragma is associated with a library-level subprogram
25777 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
25778 return Unit
(Parent
(Context
));
25780 -- The pragma appears inside the statements of a subprogram body. This
25781 -- placement is the result of subprogram contract expansion.
25783 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
25784 return Parent
(Context
);
25786 -- The pragma appears inside the declarative part of a subprogram body
25788 elsif Nkind
(Context
) = N_Subprogram_Body
then
25791 -- The pragma is a byproduct of aspect expansion, return the related
25792 -- context of the original aspect. This case has a lower priority as
25793 -- the above circuitry pinpoints precisely the related context.
25795 elsif Present
(Corresponding_Aspect
(Prag
)) then
25796 return Parent
(Corresponding_Aspect
(Prag
));
25798 -- No candidate subprogram [body] found
25803 end Find_Related_Subprogram_Or_Body
;
25809 function Get_Argument
25811 Context_Id
: Entity_Id
:= Empty
) return Node_Id
25813 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
25816 -- Use the expression of the original aspect when compiling for ASIS or
25817 -- when analyzing the template of a generic unit. In both cases the
25818 -- aspect's tree must be decorated to allow for ASIS queries or to save
25819 -- the global references in the generic context.
25821 if From_Aspect_Specification
(Prag
)
25822 and then (ASIS_Mode
or else (Present
(Context_Id
)
25823 and then Is_Generic_Unit
(Context_Id
)))
25825 return Corresponding_Aspect
(Prag
);
25827 -- Otherwise use the expression of the pragma
25829 elsif Present
(Args
) then
25830 return First
(Args
);
25837 -------------------------
25838 -- Get_Base_Subprogram --
25839 -------------------------
25841 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
25842 Result
: Entity_Id
;
25845 -- Follow subprogram renaming chain
25849 if Is_Subprogram
(Result
)
25851 Nkind
(Parent
(Declaration_Node
(Result
))) =
25852 N_Subprogram_Renaming_Declaration
25853 and then Present
(Alias
(Result
))
25855 Result
:= Alias
(Result
);
25859 end Get_Base_Subprogram
;
25861 -----------------------
25862 -- Get_SPARK_Mode_Type --
25863 -----------------------
25865 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
25867 if N
= Name_On
then
25869 elsif N
= Name_Off
then
25872 -- Any other argument is illegal
25875 raise Program_Error
;
25877 end Get_SPARK_Mode_Type
;
25879 --------------------------------
25880 -- Get_SPARK_Mode_From_Pragma --
25881 --------------------------------
25883 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
25888 pragma Assert
(Nkind
(N
) = N_Pragma
);
25889 Args
:= Pragma_Argument_Associations
(N
);
25891 -- Extract the mode from the argument list
25893 if Present
(Args
) then
25894 Mode
:= First
(Pragma_Argument_Associations
(N
));
25895 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
25897 -- If SPARK_Mode pragma has no argument, default is ON
25902 end Get_SPARK_Mode_From_Pragma
;
25904 ---------------------------
25905 -- Has_Extra_Parentheses --
25906 ---------------------------
25908 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
25912 -- The aggregate should not have an expression list because a clause
25913 -- is always interpreted as a component association. The only way an
25914 -- expression list can sneak in is by adding extra parentheses around
25915 -- the individual clauses:
25917 -- Depends (Output => Input) -- proper form
25918 -- Depends ((Output => Input)) -- extra parentheses
25920 -- Since the extra parentheses are not allowed by the syntax of the
25921 -- pragma, flag them now to avoid emitting misleading errors down the
25924 if Nkind
(Clause
) = N_Aggregate
25925 and then Present
(Expressions
(Clause
))
25927 Expr
:= First
(Expressions
(Clause
));
25928 while Present
(Expr
) loop
25930 -- A dependency clause surrounded by extra parentheses appears
25931 -- as an aggregate of component associations with an optional
25932 -- Paren_Count set.
25934 if Nkind
(Expr
) = N_Aggregate
25935 and then Present
(Component_Associations
(Expr
))
25938 ("dependency clause contains extra parentheses", Expr
);
25940 -- Otherwise the expression is a malformed construct
25943 SPARK_Msg_N
("malformed dependency clause", Expr
);
25953 end Has_Extra_Parentheses
;
25959 procedure Initialize
is
25970 Dummy
:= Dummy
+ 1;
25973 -----------------------------
25974 -- Is_Config_Static_String --
25975 -----------------------------
25977 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25979 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
25980 -- This is an internal recursive function that is just like the outer
25981 -- function except that it adds the string to the name buffer rather
25982 -- than placing the string in the name buffer.
25984 ------------------------------
25985 -- Add_Config_Static_String --
25986 ------------------------------
25988 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25995 if Nkind
(N
) = N_Op_Concat
then
25996 if Add_Config_Static_String
(Left_Opnd
(N
)) then
25997 N
:= Right_Opnd
(N
);
26003 if Nkind
(N
) /= N_String_Literal
then
26004 Error_Msg_N
("string literal expected for pragma argument", N
);
26008 for J
in 1 .. String_Length
(Strval
(N
)) loop
26009 C
:= Get_String_Char
(Strval
(N
), J
);
26011 if not In_Character_Range
(C
) then
26013 ("string literal contains invalid wide character",
26014 Sloc
(N
) + 1 + Source_Ptr
(J
));
26018 Add_Char_To_Name_Buffer
(Get_Character
(C
));
26023 end Add_Config_Static_String
;
26025 -- Start of processing for Is_Config_Static_String
26030 return Add_Config_Static_String
(Arg
);
26031 end Is_Config_Static_String
;
26033 -------------------------------
26034 -- Is_Elaboration_SPARK_Mode --
26035 -------------------------------
26037 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
26040 (Nkind
(N
) = N_Pragma
26041 and then Pragma_Name
(N
) = Name_SPARK_Mode
26042 and then Is_List_Member
(N
));
26044 -- Pragma SPARK_Mode affects the elaboration of a package body when it
26045 -- appears in the statement part of the body.
26048 Present
(Parent
(N
))
26049 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
26050 and then List_Containing
(N
) = Statements
(Parent
(N
))
26051 and then Present
(Parent
(Parent
(N
)))
26052 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
26053 end Is_Elaboration_SPARK_Mode
;
26055 -----------------------------------------
26056 -- Is_Non_Significant_Pragma_Reference --
26057 -----------------------------------------
26059 -- This function makes use of the following static table which indicates
26060 -- whether appearance of some name in a given pragma is to be considered
26061 -- as a reference for the purposes of warnings about unreferenced objects.
26063 -- -1 indicates that appearence in any argument is significant
26064 -- 0 indicates that appearance in any argument is not significant
26065 -- +n indicates that appearance as argument n is significant, but all
26066 -- other arguments are not significant
26067 -- 9n arguments from n on are significant, before n inisignificant
26069 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
26070 (Pragma_Abort_Defer
=> -1,
26071 Pragma_Abstract_State
=> -1,
26072 Pragma_Ada_83
=> -1,
26073 Pragma_Ada_95
=> -1,
26074 Pragma_Ada_05
=> -1,
26075 Pragma_Ada_2005
=> -1,
26076 Pragma_Ada_12
=> -1,
26077 Pragma_Ada_2012
=> -1,
26078 Pragma_All_Calls_Remote
=> -1,
26079 Pragma_Allow_Integer_Address
=> -1,
26080 Pragma_Annotate
=> 93,
26081 Pragma_Assert
=> -1,
26082 Pragma_Assert_And_Cut
=> -1,
26083 Pragma_Assertion_Policy
=> 0,
26084 Pragma_Assume
=> -1,
26085 Pragma_Assume_No_Invalid_Values
=> 0,
26086 Pragma_Async_Readers
=> 0,
26087 Pragma_Async_Writers
=> 0,
26088 Pragma_Asynchronous
=> 0,
26089 Pragma_Atomic
=> 0,
26090 Pragma_Atomic_Components
=> 0,
26091 Pragma_Attach_Handler
=> -1,
26092 Pragma_Attribute_Definition
=> 92,
26093 Pragma_Check
=> -1,
26094 Pragma_Check_Float_Overflow
=> 0,
26095 Pragma_Check_Name
=> 0,
26096 Pragma_Check_Policy
=> 0,
26097 Pragma_CIL_Constructor
=> 0,
26098 Pragma_CPP_Class
=> 0,
26099 Pragma_CPP_Constructor
=> 0,
26100 Pragma_CPP_Virtual
=> 0,
26101 Pragma_CPP_Vtable
=> 0,
26103 Pragma_C_Pass_By_Copy
=> 0,
26104 Pragma_Comment
=> -1,
26105 Pragma_Common_Object
=> 0,
26106 Pragma_Compile_Time_Error
=> -1,
26107 Pragma_Compile_Time_Warning
=> -1,
26108 Pragma_Compiler_Unit
=> -1,
26109 Pragma_Compiler_Unit_Warning
=> -1,
26110 Pragma_Complete_Representation
=> 0,
26111 Pragma_Complex_Representation
=> 0,
26112 Pragma_Component_Alignment
=> 0,
26113 Pragma_Contract_Cases
=> -1,
26114 Pragma_Controlled
=> 0,
26115 Pragma_Convention
=> 0,
26116 Pragma_Convention_Identifier
=> 0,
26117 Pragma_Debug
=> -1,
26118 Pragma_Debug_Policy
=> 0,
26119 Pragma_Detect_Blocking
=> 0,
26120 Pragma_Default_Initial_Condition
=> -1,
26121 Pragma_Default_Scalar_Storage_Order
=> 0,
26122 Pragma_Default_Storage_Pool
=> 0,
26123 Pragma_Depends
=> -1,
26124 Pragma_Disable_Atomic_Synchronization
=> 0,
26125 Pragma_Discard_Names
=> 0,
26126 Pragma_Dispatching_Domain
=> -1,
26127 Pragma_Effective_Reads
=> 0,
26128 Pragma_Effective_Writes
=> 0,
26129 Pragma_Elaborate
=> 0,
26130 Pragma_Elaborate_All
=> 0,
26131 Pragma_Elaborate_Body
=> 0,
26132 Pragma_Elaboration_Checks
=> 0,
26133 Pragma_Eliminate
=> 0,
26134 Pragma_Enable_Atomic_Synchronization
=> 0,
26135 Pragma_Export
=> -1,
26136 Pragma_Export_Function
=> -1,
26137 Pragma_Export_Object
=> -1,
26138 Pragma_Export_Procedure
=> -1,
26139 Pragma_Export_Value
=> -1,
26140 Pragma_Export_Valued_Procedure
=> -1,
26141 Pragma_Extend_System
=> -1,
26142 Pragma_Extensions_Allowed
=> 0,
26143 Pragma_Extensions_Visible
=> 0,
26144 Pragma_External
=> -1,
26145 Pragma_Favor_Top_Level
=> 0,
26146 Pragma_External_Name_Casing
=> 0,
26147 Pragma_Fast_Math
=> 0,
26148 Pragma_Finalize_Storage_Only
=> 0,
26150 Pragma_Global
=> -1,
26151 Pragma_Ident
=> -1,
26152 Pragma_Ignore_Pragma
=> 0,
26153 Pragma_Implementation_Defined
=> -1,
26154 Pragma_Implemented
=> -1,
26155 Pragma_Implicit_Packing
=> 0,
26156 Pragma_Import
=> 93,
26157 Pragma_Import_Function
=> 0,
26158 Pragma_Import_Object
=> 0,
26159 Pragma_Import_Procedure
=> 0,
26160 Pragma_Import_Valued_Procedure
=> 0,
26161 Pragma_Independent
=> 0,
26162 Pragma_Independent_Components
=> 0,
26163 Pragma_Initial_Condition
=> -1,
26164 Pragma_Initialize_Scalars
=> 0,
26165 Pragma_Initializes
=> -1,
26166 Pragma_Inline
=> 0,
26167 Pragma_Inline_Always
=> 0,
26168 Pragma_Inline_Generic
=> 0,
26169 Pragma_Inspection_Point
=> -1,
26170 Pragma_Interface
=> 92,
26171 Pragma_Interface_Name
=> 0,
26172 Pragma_Interrupt_Handler
=> -1,
26173 Pragma_Interrupt_Priority
=> -1,
26174 Pragma_Interrupt_State
=> -1,
26175 Pragma_Invariant
=> -1,
26176 Pragma_Java_Constructor
=> -1,
26177 Pragma_Java_Interface
=> -1,
26178 Pragma_Keep_Names
=> 0,
26179 Pragma_License
=> 0,
26180 Pragma_Link_With
=> -1,
26181 Pragma_Linker_Alias
=> -1,
26182 Pragma_Linker_Constructor
=> -1,
26183 Pragma_Linker_Destructor
=> -1,
26184 Pragma_Linker_Options
=> -1,
26185 Pragma_Linker_Section
=> 0,
26187 Pragma_Lock_Free
=> 0,
26188 Pragma_Locking_Policy
=> 0,
26189 Pragma_Loop_Invariant
=> -1,
26190 Pragma_Loop_Optimize
=> 0,
26191 Pragma_Loop_Variant
=> -1,
26192 Pragma_Machine_Attribute
=> -1,
26194 Pragma_Main_Storage
=> -1,
26195 Pragma_Memory_Size
=> 0,
26196 Pragma_No_Return
=> 0,
26197 Pragma_No_Body
=> 0,
26198 Pragma_No_Elaboration_Code_All
=> 0,
26199 Pragma_No_Inline
=> 0,
26200 Pragma_No_Run_Time
=> -1,
26201 Pragma_No_Strict_Aliasing
=> -1,
26202 Pragma_No_Tagged_Streams
=> 0,
26203 Pragma_Normalize_Scalars
=> 0,
26204 Pragma_Obsolescent
=> 0,
26205 Pragma_Optimize
=> 0,
26206 Pragma_Optimize_Alignment
=> 0,
26207 Pragma_Overflow_Mode
=> 0,
26208 Pragma_Overriding_Renamings
=> 0,
26209 Pragma_Ordered
=> 0,
26212 Pragma_Part_Of
=> 0,
26213 Pragma_Partition_Elaboration_Policy
=> 0,
26214 Pragma_Passive
=> 0,
26215 Pragma_Persistent_BSS
=> 0,
26216 Pragma_Polling
=> 0,
26217 Pragma_Prefix_Exception_Messages
=> 0,
26219 Pragma_Postcondition
=> -1,
26220 Pragma_Post_Class
=> -1,
26222 Pragma_Precondition
=> -1,
26223 Pragma_Predicate
=> -1,
26224 Pragma_Preelaborable_Initialization
=> -1,
26225 Pragma_Preelaborate
=> 0,
26226 Pragma_Pre_Class
=> -1,
26227 Pragma_Priority
=> -1,
26228 Pragma_Priority_Specific_Dispatching
=> 0,
26229 Pragma_Profile
=> 0,
26230 Pragma_Profile_Warnings
=> 0,
26231 Pragma_Propagate_Exceptions
=> 0,
26232 Pragma_Provide_Shift_Operators
=> 0,
26233 Pragma_Psect_Object
=> 0,
26235 Pragma_Pure_Function
=> 0,
26236 Pragma_Queuing_Policy
=> 0,
26237 Pragma_Rational
=> 0,
26238 Pragma_Ravenscar
=> 0,
26239 Pragma_Refined_Depends
=> -1,
26240 Pragma_Refined_Global
=> -1,
26241 Pragma_Refined_Post
=> -1,
26242 Pragma_Refined_State
=> -1,
26243 Pragma_Relative_Deadline
=> 0,
26244 Pragma_Remote_Access_Type
=> -1,
26245 Pragma_Remote_Call_Interface
=> -1,
26246 Pragma_Remote_Types
=> -1,
26247 Pragma_Restricted_Run_Time
=> 0,
26248 Pragma_Restriction_Warnings
=> 0,
26249 Pragma_Restrictions
=> 0,
26250 Pragma_Reviewable
=> -1,
26251 Pragma_Short_Circuit_And_Or
=> 0,
26252 Pragma_Share_Generic
=> 0,
26253 Pragma_Shared
=> 0,
26254 Pragma_Shared_Passive
=> 0,
26255 Pragma_Short_Descriptors
=> 0,
26256 Pragma_Simple_Storage_Pool_Type
=> 0,
26257 Pragma_Source_File_Name
=> 0,
26258 Pragma_Source_File_Name_Project
=> 0,
26259 Pragma_Source_Reference
=> 0,
26260 Pragma_SPARK_Mode
=> 0,
26261 Pragma_Storage_Size
=> -1,
26262 Pragma_Storage_Unit
=> 0,
26263 Pragma_Static_Elaboration_Desired
=> 0,
26264 Pragma_Stream_Convert
=> 0,
26265 Pragma_Style_Checks
=> 0,
26266 Pragma_Subtitle
=> 0,
26267 Pragma_Suppress
=> 0,
26268 Pragma_Suppress_Exception_Locations
=> 0,
26269 Pragma_Suppress_All
=> 0,
26270 Pragma_Suppress_Debug_Info
=> 0,
26271 Pragma_Suppress_Initialization
=> 0,
26272 Pragma_System_Name
=> 0,
26273 Pragma_Task_Dispatching_Policy
=> 0,
26274 Pragma_Task_Info
=> -1,
26275 Pragma_Task_Name
=> -1,
26276 Pragma_Task_Storage
=> -1,
26277 Pragma_Test_Case
=> -1,
26278 Pragma_Thread_Local_Storage
=> -1,
26279 Pragma_Time_Slice
=> -1,
26281 Pragma_Type_Invariant
=> -1,
26282 Pragma_Type_Invariant_Class
=> -1,
26283 Pragma_Unchecked_Union
=> 0,
26284 Pragma_Unimplemented_Unit
=> 0,
26285 Pragma_Universal_Aliasing
=> 0,
26286 Pragma_Universal_Data
=> 0,
26287 Pragma_Unmodified
=> 0,
26288 Pragma_Unreferenced
=> 0,
26289 Pragma_Unreferenced_Objects
=> 0,
26290 Pragma_Unreserve_All_Interrupts
=> 0,
26291 Pragma_Unsuppress
=> 0,
26292 Pragma_Unevaluated_Use_Of_Old
=> 0,
26293 Pragma_Use_VADS_Size
=> 0,
26294 Pragma_Validity_Checks
=> 0,
26295 Pragma_Volatile
=> 0,
26296 Pragma_Volatile_Components
=> 0,
26297 Pragma_Volatile_Full_Access
=> 0,
26298 Pragma_Warning_As_Error
=> 0,
26299 Pragma_Warnings
=> 0,
26300 Pragma_Weak_External
=> 0,
26301 Pragma_Wide_Character_Encoding
=> 0,
26302 Unknown_Pragma
=> 0);
26304 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
26310 function Arg_No
return Nat
;
26311 -- Returns an integer showing what argument we are in. A value of
26312 -- zero means we are not in any of the arguments.
26318 function Arg_No
return Nat
is
26323 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
26337 -- Start of processing for Non_Significant_Pragma_Reference
26342 if Nkind
(P
) /= N_Pragma_Argument_Association
then
26346 Id
:= Get_Pragma_Id
(Parent
(P
));
26347 C
:= Sig_Flags
(Id
);
26362 return AN
< (C
- 90);
26368 end Is_Non_Significant_Pragma_Reference
;
26370 ------------------------------
26371 -- Is_Pragma_String_Literal --
26372 ------------------------------
26374 -- This function returns true if the corresponding pragma argument is a
26375 -- static string expression. These are the only cases in which string
26376 -- literals can appear as pragma arguments. We also allow a string literal
26377 -- as the first argument to pragma Assert (although it will of course
26378 -- always generate a type error).
26380 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
26381 Pragn
: constant Node_Id
:= Parent
(Par
);
26382 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
26383 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
26389 N
:= First
(Assoc
);
26396 if Pname
= Name_Assert
then
26399 elsif Pname
= Name_Export
then
26402 elsif Pname
= Name_Ident
then
26405 elsif Pname
= Name_Import
then
26408 elsif Pname
= Name_Interface_Name
then
26411 elsif Pname
= Name_Linker_Alias
then
26414 elsif Pname
= Name_Linker_Section
then
26417 elsif Pname
= Name_Machine_Attribute
then
26420 elsif Pname
= Name_Source_File_Name
then
26423 elsif Pname
= Name_Source_Reference
then
26426 elsif Pname
= Name_Title
then
26429 elsif Pname
= Name_Subtitle
then
26435 end Is_Pragma_String_Literal
;
26437 ---------------------------
26438 -- Is_Private_SPARK_Mode --
26439 ---------------------------
26441 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
26444 (Nkind
(N
) = N_Pragma
26445 and then Pragma_Name
(N
) = Name_SPARK_Mode
26446 and then Is_List_Member
(N
));
26448 -- For pragma SPARK_Mode to be private, it has to appear in the private
26449 -- declarations of a package.
26452 Present
(Parent
(N
))
26453 and then Nkind
(Parent
(N
)) = N_Package_Specification
26454 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
26455 end Is_Private_SPARK_Mode
;
26457 -------------------------------------
26458 -- Is_Unconstrained_Or_Tagged_Item --
26459 -------------------------------------
26461 function Is_Unconstrained_Or_Tagged_Item
26462 (Item
: Entity_Id
) return Boolean
26464 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
26465 -- Determine whether record type Typ has at least one unconstrained
26468 ---------------------------------
26469 -- Has_Unconstrained_Component --
26470 ---------------------------------
26472 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
26476 Comp
:= First_Component
(Typ
);
26477 while Present
(Comp
) loop
26478 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
26482 Next_Component
(Comp
);
26486 end Has_Unconstrained_Component
;
26490 Typ
: constant Entity_Id
:= Etype
(Item
);
26492 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
26495 if Is_Tagged_Type
(Typ
) then
26498 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
26501 elsif Is_Record_Type
(Typ
) then
26502 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
26505 return Has_Unconstrained_Component
(Typ
);
26508 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
26514 end Is_Unconstrained_Or_Tagged_Item
;
26516 -----------------------------
26517 -- Is_Valid_Assertion_Kind --
26518 -----------------------------
26520 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
26527 Name_Static_Predicate |
26528 Name_Dynamic_Predicate |
26533 Name_Type_Invariant |
26534 Name_uType_Invariant |
26538 Name_Assert_And_Cut |
26540 Name_Contract_Cases |
26542 Name_Default_Initial_Condition |
26544 Name_Initial_Condition |
26547 Name_Loop_Invariant |
26548 Name_Loop_Variant |
26549 Name_Postcondition |
26550 Name_Precondition |
26552 Name_Refined_Post |
26553 Name_Statement_Assertions
=> return True;
26555 when others => return False;
26557 end Is_Valid_Assertion_Kind
;
26559 --------------------------------------
26560 -- Process_Compilation_Unit_Pragmas --
26561 --------------------------------------
26563 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
26565 -- A special check for pragma Suppress_All, a very strange DEC pragma,
26566 -- strange because it comes at the end of the unit. Rational has the
26567 -- same name for a pragma, but treats it as a program unit pragma, In
26568 -- GNAT we just decide to allow it anywhere at all. If it appeared then
26569 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
26570 -- node, and we insert a pragma Suppress (All_Checks) at the start of
26571 -- the context clause to ensure the correct processing.
26573 if Has_Pragma_Suppress_All
(N
) then
26574 Prepend_To
(Context_Items
(N
),
26575 Make_Pragma
(Sloc
(N
),
26576 Chars
=> Name_Suppress
,
26577 Pragma_Argument_Associations
=> New_List
(
26578 Make_Pragma_Argument_Association
(Sloc
(N
),
26579 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
26582 -- Nothing else to do at the current time
26584 end Process_Compilation_Unit_Pragmas
;
26586 ------------------------------------
26587 -- Record_Possible_Body_Reference --
26588 ------------------------------------
26590 procedure Record_Possible_Body_Reference
26591 (State_Id
: Entity_Id
;
26595 Spec_Id
: Entity_Id
;
26598 -- Ensure that we are dealing with a reference to a state
26600 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
26602 -- Climb the tree starting from the reference looking for a package body
26603 -- whose spec declares the referenced state. This criteria automatically
26604 -- excludes references in package specs which are legal. Note that it is
26605 -- not wise to emit an error now as the package body may lack pragma
26606 -- Refined_State or the referenced state may not be mentioned in the
26607 -- refinement. This approach avoids the generation of misleading errors.
26610 while Present
(Context
) loop
26611 if Nkind
(Context
) = N_Package_Body
then
26612 Spec_Id
:= Corresponding_Spec
(Context
);
26614 if Present
(Abstract_States
(Spec_Id
))
26615 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
26617 if No
(Body_References
(State_Id
)) then
26618 Set_Body_References
(State_Id
, New_Elmt_List
);
26621 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
26626 Context
:= Parent
(Context
);
26628 end Record_Possible_Body_Reference
;
26630 ------------------------------
26631 -- Relocate_Pragmas_To_Body --
26632 ------------------------------
26634 procedure Relocate_Pragmas_To_Body
26635 (Subp_Body
: Node_Id
;
26636 Target_Body
: Node_Id
:= Empty
)
26638 procedure Relocate_Pragma
(Prag
: Node_Id
);
26639 -- Remove a single pragma from its current list and add it to the
26640 -- declarations of the proper body (either Subp_Body or Target_Body).
26642 ---------------------
26643 -- Relocate_Pragma --
26644 ---------------------
26646 procedure Relocate_Pragma
(Prag
: Node_Id
) is
26651 -- When subprogram stubs or expression functions are involves, the
26652 -- destination declaration list belongs to the proper body.
26654 if Present
(Target_Body
) then
26655 Target
:= Target_Body
;
26657 Target
:= Subp_Body
;
26660 Decls
:= Declarations
(Target
);
26664 Set_Declarations
(Target
, Decls
);
26667 -- Unhook the pragma from its current list
26670 Prepend
(Prag
, Decls
);
26671 end Relocate_Pragma
;
26675 Body_Id
: constant Entity_Id
:=
26676 Defining_Unit_Name
(Specification
(Subp_Body
));
26677 Next_Stmt
: Node_Id
;
26680 -- Start of processing for Relocate_Pragmas_To_Body
26683 -- Do not process a body that comes from a separate unit as no construct
26684 -- can possibly follow it.
26686 if not Is_List_Member
(Subp_Body
) then
26689 -- Do not relocate pragmas that follow a stub if the stub does not have
26692 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
26693 and then No
(Target_Body
)
26697 -- Do not process internally generated routine _Postconditions
26699 elsif Ekind
(Body_Id
) = E_Procedure
26700 and then Chars
(Body_Id
) = Name_uPostconditions
26705 -- Look at what is following the body. We are interested in certain kind
26706 -- of pragmas (either from source or byproducts of expansion) that can
26707 -- apply to a body [stub].
26709 Stmt
:= Next
(Subp_Body
);
26710 while Present
(Stmt
) loop
26712 -- Preserve the following statement for iteration purposes due to a
26713 -- possible relocation of a pragma.
26715 Next_Stmt
:= Next
(Stmt
);
26717 -- Move a candidate pragma following the body to the declarations of
26720 if Nkind
(Stmt
) = N_Pragma
26721 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
26723 Relocate_Pragma
(Stmt
);
26725 -- Skip internally generated code
26727 elsif not Comes_From_Source
(Stmt
) then
26730 -- No candidate pragmas are available for relocation
26738 end Relocate_Pragmas_To_Body
;
26740 -------------------
26741 -- Resolve_State --
26742 -------------------
26744 procedure Resolve_State
(N
: Node_Id
) is
26749 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26750 Func
:= Entity
(N
);
26752 -- Handle overloading of state names by functions. Traverse the
26753 -- homonym chain looking for an abstract state.
26755 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
26756 State
:= Homonym
(Func
);
26757 while Present
(State
) loop
26759 -- Resolve the overloading by setting the proper entity of the
26760 -- reference to that of the state.
26762 if Ekind
(State
) = E_Abstract_State
then
26763 Set_Etype
(N
, Standard_Void_Type
);
26764 Set_Entity
(N
, State
);
26765 Set_Associated_Node
(N
, State
);
26769 State
:= Homonym
(State
);
26772 -- A function can never act as a state. If the homonym chain does
26773 -- not contain a corresponding state, then something went wrong in
26774 -- the overloading mechanism.
26776 raise Program_Error
;
26781 ----------------------------
26782 -- Rewrite_Assertion_Kind --
26783 ----------------------------
26785 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
26789 if Nkind
(N
) = N_Attribute_Reference
26790 and then Attribute_Name
(N
) = Name_Class
26791 and then Nkind
(Prefix
(N
)) = N_Identifier
26793 case Chars
(Prefix
(N
)) is
26798 when Name_Type_Invariant
=>
26799 Nam
:= Name_uType_Invariant
;
26800 when Name_Invariant
=>
26801 Nam
:= Name_uInvariant
;
26806 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
26808 end Rewrite_Assertion_Kind
;
26816 Dummy
:= Dummy
+ 1;
26819 --------------------------------
26820 -- Set_Encoded_Interface_Name --
26821 --------------------------------
26823 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
26824 Str
: constant String_Id
:= Strval
(S
);
26825 Len
: constant Int
:= String_Length
(Str
);
26830 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
26833 -- Stores encoded value of character code CC. The encoding we use an
26834 -- underscore followed by four lower case hex digits.
26840 procedure Encode
is
26842 Store_String_Char
(Get_Char_Code
('_'));
26844 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
26846 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
26848 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
26850 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
26853 -- Start of processing for Set_Encoded_Interface_Name
26856 -- If first character is asterisk, this is a link name, and we leave it
26857 -- completely unmodified. We also ignore null strings (the latter case
26858 -- happens only in error cases) and no encoding should occur for Java or
26859 -- AAMP interface names.
26862 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
26863 or else VM_Target
/= No_VM
26864 or else AAMP_On_Target
26866 Set_Interface_Name
(E
, S
);
26871 CC
:= Get_String_Char
(Str
, J
);
26873 exit when not In_Character_Range
(CC
);
26875 C
:= Get_Character
(CC
);
26877 exit when C
/= '_' and then C
/= '$'
26878 and then C
not in '0' .. '9'
26879 and then C
not in 'a' .. 'z'
26880 and then C
not in 'A' .. 'Z';
26883 Set_Interface_Name
(E
, S
);
26891 -- Here we need to encode. The encoding we use as follows:
26892 -- three underscores + four hex digits (lower case)
26896 for J
in 1 .. String_Length
(Str
) loop
26897 CC
:= Get_String_Char
(Str
, J
);
26899 if not In_Character_Range
(CC
) then
26902 C
:= Get_Character
(CC
);
26904 if C
= '_' or else C
= '$'
26905 or else C
in '0' .. '9'
26906 or else C
in 'a' .. 'z'
26907 or else C
in 'A' .. 'Z'
26909 Store_String_Char
(CC
);
26916 Set_Interface_Name
(E
,
26917 Make_String_Literal
(Sloc
(S
),
26918 Strval
=> End_String
));
26920 end Set_Encoded_Interface_Name
;
26922 ------------------------
26923 -- Set_Elab_Unit_Name --
26924 ------------------------
26926 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
26931 if Nkind
(N
) = N_Identifier
26932 and then Nkind
(With_Item
) = N_Identifier
26934 Set_Entity
(N
, Entity
(With_Item
));
26936 elsif Nkind
(N
) = N_Selected_Component
then
26937 Change_Selected_Component_To_Expanded_Name
(N
);
26938 Set_Entity
(N
, Entity
(With_Item
));
26939 Set_Entity
(Selector_Name
(N
), Entity
(N
));
26941 Pref
:= Prefix
(N
);
26942 Scop
:= Scope
(Entity
(N
));
26943 while Nkind
(Pref
) = N_Selected_Component
loop
26944 Change_Selected_Component_To_Expanded_Name
(Pref
);
26945 Set_Entity
(Selector_Name
(Pref
), Scop
);
26946 Set_Entity
(Pref
, Scop
);
26947 Pref
:= Prefix
(Pref
);
26948 Scop
:= Scope
(Scop
);
26951 Set_Entity
(Pref
, Scop
);
26954 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
26955 end Set_Elab_Unit_Name
;
26957 -------------------
26958 -- Test_Case_Arg --
26959 -------------------
26961 function Test_Case_Arg
26964 From_Aspect
: Boolean := False) return Node_Id
26966 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
26971 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
26976 -- The caller requests the aspect argument
26978 if From_Aspect
then
26979 if Present
(Aspect
)
26980 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
26982 Args
:= Expression
(Aspect
);
26984 -- "Name" and "Mode" may appear without an identifier as a
26985 -- positional association.
26987 if Present
(Expressions
(Args
)) then
26988 Arg
:= First
(Expressions
(Args
));
26990 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
26998 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
27003 -- Some or all arguments may appear as component associatons
27005 if Present
(Component_Associations
(Args
)) then
27006 Arg
:= First
(Component_Associations
(Args
));
27007 while Present
(Arg
) loop
27008 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
27017 -- Otherwise retrieve the argument directly from the pragma
27020 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
27022 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
27026 -- Skip argument "Name"
27030 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
27034 -- Skip argument "Mode"
27038 -- Arguments "Requires" and "Ensures" are optional and may not be
27041 while Present
(Arg
) loop
27042 if Chars
(Arg
) = Arg_Nam
then