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_State_And_Constituent_Use
209 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
210 -- Global and Initializes. Determine whether a state from list States and a
211 -- corresponding constituent from list Constits (if any) appear in the same
212 -- context denoted by Context. If this is the case, emit an error.
214 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
215 -- Subsidiary to routines Find_Related_Package_Or_Body and
216 -- Find_Related_Subprogram_Or_Body. Emit an error on pragma Prag that
217 -- duplicates previous pragma Prev.
219 function Find_Related_Package_Or_Body
221 Do_Checks
: Boolean := False) return Node_Id
;
222 -- Subsidiary to the analysis of pragmas Abstract_State, Initial_Condition,
223 -- Initializes and Refined_State. Find the declaration of the related
224 -- package [body] subject to pragma Prag. The return value is either
225 -- N_Package_Declaration, N_Package_Body or Empty if the placement of
226 -- the pragma is illegal. If flag Do_Checks is set, the routine reports
227 -- duplicate pragmas.
229 function Get_Argument
231 Spec_Id
: Entity_Id
:= Empty
) return Node_Id
;
232 -- Obtain the argument of pragma Prag depending on context and the nature
233 -- of the pragma. The argument is extracted in the following manner:
235 -- When the pragma is generated from an aspect, return the corresponding
236 -- aspect for ASIS or when Spec_Id denotes a generic subprogram.
238 -- Otherwise return the first argument of Prag
240 -- Spec_Id denotes the entity of the subprogram spec where Prag resides
242 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
243 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
244 -- original one, following the renaming chain) is returned. Otherwise the
245 -- entity is returned unchanged. Should be in Einfo???
247 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
248 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
249 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
252 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
253 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
254 -- Determine whether dependency clause Clause is surrounded by extra
255 -- parentheses. If this is the case, issue an error message.
257 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
258 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
259 -- pragma Depends. Determine whether the type of dependency item Item is
260 -- tagged, unconstrained array, unconstrained record or a record with at
261 -- least one unconstrained component.
263 procedure Record_Possible_Body_Reference
264 (State_Id
: Entity_Id
;
266 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
267 -- Global. Given an abstract state denoted by State_Id and a reference Ref
268 -- to it, determine whether the reference appears in a package body that
269 -- will eventually refine the state. If this is the case, record the
270 -- reference for future checks (see Analyze_Refined_State_In_Decls).
272 procedure Resolve_State
(N
: Node_Id
);
273 -- Handle the overloading of state names by functions. When N denotes a
274 -- function, this routine finds the corresponding state and sets the entity
275 -- of N to that of the state.
277 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
278 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
279 -- then it is rewritten as an identifier with the corresponding special
280 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
283 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
284 -- Place semantic information on the argument of an Elaborate/Elaborate_All
285 -- pragma. Entity name for unit and its parents is taken from item in
286 -- previous with_clause that mentions the unit.
288 Dummy
: Integer := 0;
289 pragma Volatile
(Dummy
);
290 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
293 pragma No_Inline
(ip
);
294 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
295 -- is just to help debugging the front end. If a pragma Inspection_Point
296 -- is added to a source program, then breaking on ip will get you to that
297 -- point in the program.
300 pragma No_Inline
(rv
);
301 -- This is a dummy function called by the processing for pragma Reviewable.
302 -- It is there for assisting front end debugging. By placing a Reviewable
303 -- pragma in the source program, a breakpoint on rv catches this place in
304 -- the source, allowing convenient stepping to the point of interest.
310 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
) is
312 Append_New_Elmt
(Item
, To
=> To_List
);
315 -------------------------------
316 -- Adjust_External_Name_Case --
317 -------------------------------
319 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
323 -- Adjust case of literal if required
325 if Opt
.External_Name_Exp_Casing
= As_Is
then
329 -- Copy existing string
335 for J
in 1 .. String_Length
(Strval
(N
)) loop
336 CC
:= Get_String_Char
(Strval
(N
), J
);
338 if Opt
.External_Name_Exp_Casing
= Uppercase
339 and then CC
>= Get_Char_Code
('a')
340 and then CC
<= Get_Char_Code
('z')
342 Store_String_Char
(CC
- 32);
344 elsif Opt
.External_Name_Exp_Casing
= Lowercase
345 and then CC
>= Get_Char_Code
('A')
346 and then CC
<= Get_Char_Code
('Z')
348 Store_String_Char
(CC
+ 32);
351 Store_String_Char
(CC
);
356 Make_String_Literal
(Sloc
(N
),
357 Strval
=> End_String
);
359 end Adjust_External_Name_Case
;
361 -----------------------------------------
362 -- Analyze_Contract_Cases_In_Decl_Part --
363 -----------------------------------------
365 procedure Analyze_Contract_Cases_In_Decl_Part
(N
: Node_Id
) is
366 Others_Seen
: Boolean := False;
368 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
369 -- Verify the legality of a single contract case
371 ---------------------------
372 -- Analyze_Contract_Case --
373 ---------------------------
375 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
376 Case_Guard
: Node_Id
;
378 Extra_Guard
: Node_Id
;
381 if Nkind
(CCase
) = N_Component_Association
then
382 Case_Guard
:= First
(Choices
(CCase
));
383 Conseq
:= Expression
(CCase
);
385 -- Each contract case must have exactly one case guard
387 Extra_Guard
:= Next
(Case_Guard
);
389 if Present
(Extra_Guard
) then
391 ("contract case must have exactly one case guard",
395 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
397 if Nkind
(Case_Guard
) = N_Others_Choice
then
400 ("only one others choice allowed in contract cases",
406 elsif Others_Seen
then
408 ("others must be the last choice in contract cases", N
);
411 -- Preanalyze the case guard and consequence
413 if Nkind
(Case_Guard
) /= N_Others_Choice
then
414 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
417 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
419 -- The contract case is malformed
422 Error_Msg_N
("wrong syntax in contract case", CCase
);
424 end Analyze_Contract_Case
;
433 Restore_Scope
: Boolean := False;
434 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
436 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
441 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
442 Subp_Id
:= Defining_Entity
(Subp_Decl
);
443 All_Cases
:= Expression
(Get_Argument
(N
, Subp_Id
));
445 -- Single and multiple contract cases must appear in aggregate form. If
446 -- this is not the case, then either the parser of the analysis of the
447 -- pragma failed to produce an aggregate.
449 pragma Assert
(Nkind
(All_Cases
) = N_Aggregate
);
451 if Present
(Component_Associations
(All_Cases
)) then
453 -- Ensure that the formal parameters are visible when analyzing all
454 -- clauses. This falls out of the general rule of aspects pertaining
455 -- to subprogram declarations. Skip the installation for subprogram
456 -- bodies because the formals are already visible.
458 if not In_Open_Scopes
(Subp_Id
) then
459 Restore_Scope
:= True;
460 Push_Scope
(Subp_Id
);
462 if Is_Generic_Subprogram
(Subp_Id
) then
463 Install_Generic_Formals
(Subp_Id
);
465 Install_Formals
(Subp_Id
);
469 CCase
:= First
(Component_Associations
(All_Cases
));
470 while Present
(CCase
) loop
471 Analyze_Contract_Case
(CCase
);
475 if Restore_Scope
then
479 Error_Msg_N
("wrong syntax for constract cases", N
);
481 end Analyze_Contract_Cases_In_Decl_Part
;
483 ----------------------------------
484 -- Analyze_Depends_In_Decl_Part --
485 ----------------------------------
487 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
488 Loc
: constant Source_Ptr
:= Sloc
(N
);
490 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
491 -- A list containing the entities of all the inputs processed so far.
492 -- The list is populated with unique entities because the same input
493 -- may appear in multiple input lists.
495 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
496 -- A list containing the entities of all the outputs processed so far.
497 -- The list is populated with unique entities because output items are
498 -- unique in a dependence relation.
500 Constits_Seen
: Elist_Id
:= No_Elist
;
501 -- A list containing the entities of all constituents processed so far.
502 -- It aids in detecting illegal usage of a state and a corresponding
503 -- constituent in pragma [Refinde_]Depends.
505 Global_Seen
: Boolean := False;
506 -- A flag set when pragma Global has been processed
508 Null_Output_Seen
: Boolean := False;
509 -- A flag used to track the legality of a null output
511 Result_Seen
: Boolean := False;
512 -- A flag set when Subp_Id'Result is processed
515 -- The entity of the subprogram subject to pragma [Refined_]Depends
517 States_Seen
: Elist_Id
:= No_Elist
;
518 -- A list containing the entities of all states processed so far. It
519 -- helps in detecting illegal usage of a state and a corresponding
520 -- constituent in pragma [Refined_]Depends.
523 -- The entity of the subprogram [body or stub] subject to pragma
524 -- [Refined_]Depends.
526 Subp_Inputs
: Elist_Id
:= No_Elist
;
527 Subp_Outputs
: Elist_Id
:= No_Elist
;
528 -- Two lists containing the full set of inputs and output of the related
529 -- subprograms. Note that these lists contain both nodes and entities.
531 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
532 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
533 -- to the name buffer. The individual kinds are as follows:
534 -- E_Abstract_State - "state"
535 -- E_In_Parameter - "parameter"
536 -- E_In_Out_Parameter - "parameter"
537 -- E_Out_Parameter - "parameter"
538 -- E_Variable - "global"
540 procedure Analyze_Dependency_Clause
543 -- Verify the legality of a single dependency clause. Flag Is_Last
544 -- denotes whether Clause is the last clause in the relation.
546 procedure Check_Function_Return
;
547 -- Verify that Funtion'Result appears as one of the outputs
548 -- (SPARK RM 6.1.5(10)).
555 -- Ensure that an item fulfils its designated input and/or output role
556 -- as specified by pragma Global (if any) or the enclosing context. If
557 -- this is not the case, emit an error. Item and Item_Id denote the
558 -- attributes of an item. Flag Is_Input should be set when item comes
559 -- from an input list. Flag Self_Ref should be set when the item is an
560 -- output and the dependency clause has operator "+".
562 procedure Check_Usage
563 (Subp_Items
: Elist_Id
;
564 Used_Items
: Elist_Id
;
566 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
567 -- error if this is not the case.
569 procedure Normalize_Clause
(Clause
: Node_Id
);
570 -- Remove a self-dependency "+" from the input list of a clause
572 -----------------------------
573 -- Add_Item_To_Name_Buffer --
574 -----------------------------
576 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
578 if Ekind
(Item_Id
) = E_Abstract_State
then
579 Add_Str_To_Name_Buffer
("state");
581 elsif Is_Formal
(Item_Id
) then
582 Add_Str_To_Name_Buffer
("parameter");
584 elsif Ekind
(Item_Id
) = E_Variable
then
585 Add_Str_To_Name_Buffer
("global");
587 -- The routine should not be called with non-SPARK items
592 end Add_Item_To_Name_Buffer
;
594 -------------------------------
595 -- Analyze_Dependency_Clause --
596 -------------------------------
598 procedure Analyze_Dependency_Clause
602 procedure Analyze_Input_List
(Inputs
: Node_Id
);
603 -- Verify the legality of a single input list
605 procedure Analyze_Input_Output
610 Seen
: in out Elist_Id
;
611 Null_Seen
: in out Boolean;
612 Non_Null_Seen
: in out Boolean);
613 -- Verify the legality of a single input or output item. Flag
614 -- Is_Input should be set whenever Item is an input, False when it
615 -- denotes an output. Flag Self_Ref should be set when the item is an
616 -- output and the dependency clause has a "+". Flag Top_Level should
617 -- be set whenever Item appears immediately within an input or output
618 -- list. Seen is a collection of all abstract states, variables and
619 -- formals processed so far. Flag Null_Seen denotes whether a null
620 -- input or output has been encountered. Flag Non_Null_Seen denotes
621 -- whether a non-null input or output has been encountered.
623 ------------------------
624 -- Analyze_Input_List --
625 ------------------------
627 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
628 Inputs_Seen
: Elist_Id
:= No_Elist
;
629 -- A list containing the entities of all inputs that appear in the
630 -- current input list.
632 Non_Null_Input_Seen
: Boolean := False;
633 Null_Input_Seen
: Boolean := False;
634 -- Flags used to check the legality of an input list
639 -- Multiple inputs appear as an aggregate
641 if Nkind
(Inputs
) = N_Aggregate
then
642 if Present
(Component_Associations
(Inputs
)) then
644 ("nested dependency relations not allowed", Inputs
);
646 elsif Present
(Expressions
(Inputs
)) then
647 Input
:= First
(Expressions
(Inputs
));
648 while Present
(Input
) loop
655 Null_Seen
=> Null_Input_Seen
,
656 Non_Null_Seen
=> Non_Null_Input_Seen
);
661 -- Syntax error, always report
664 Error_Msg_N
("malformed input dependency list", Inputs
);
667 -- Process a solitary input
676 Null_Seen
=> Null_Input_Seen
,
677 Non_Null_Seen
=> Non_Null_Input_Seen
);
680 -- Detect an illegal dependency clause of the form
684 if Null_Output_Seen
and then Null_Input_Seen
then
686 ("null dependency clause cannot have a null input list",
689 end Analyze_Input_List
;
691 --------------------------
692 -- Analyze_Input_Output --
693 --------------------------
695 procedure Analyze_Input_Output
700 Seen
: in out Elist_Id
;
701 Null_Seen
: in out Boolean;
702 Non_Null_Seen
: in out Boolean)
704 Is_Output
: constant Boolean := not Is_Input
;
709 -- Multiple input or output items appear as an aggregate
711 if Nkind
(Item
) = N_Aggregate
then
712 if not Top_Level
then
713 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
715 elsif Present
(Component_Associations
(Item
)) then
717 ("nested dependency relations not allowed", Item
);
719 -- Recursively analyze the grouped items
721 elsif Present
(Expressions
(Item
)) then
722 Grouped
:= First
(Expressions
(Item
));
723 while Present
(Grouped
) loop
726 Is_Input
=> Is_Input
,
727 Self_Ref
=> Self_Ref
,
730 Null_Seen
=> Null_Seen
,
731 Non_Null_Seen
=> Non_Null_Seen
);
736 -- Syntax error, always report
739 Error_Msg_N
("malformed dependency list", Item
);
742 -- Process Function'Result in the context of a dependency clause
744 elsif Is_Attribute_Result
(Item
) then
745 Non_Null_Seen
:= True;
747 -- It is sufficent to analyze the prefix of 'Result in order to
748 -- establish legality of the attribute.
750 Analyze
(Prefix
(Item
));
752 -- The prefix of 'Result must denote the function for which
753 -- pragma Depends applies (SPARK RM 6.1.5(11)).
755 if not Is_Entity_Name
(Prefix
(Item
))
756 or else Ekind
(Spec_Id
) /= E_Function
757 or else Entity
(Prefix
(Item
)) /= Spec_Id
759 Error_Msg_Name_1
:= Name_Result
;
761 ("prefix of attribute % must denote the enclosing "
764 -- Function'Result is allowed to appear on the output side of a
765 -- dependency clause (SPARK RM 6.1.5(6)).
768 SPARK_Msg_N
("function result cannot act as input", Item
);
772 ("cannot mix null and non-null dependency items", Item
);
778 -- Detect multiple uses of null in a single dependency list or
779 -- throughout the whole relation. Verify the placement of a null
780 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
782 elsif Nkind
(Item
) = N_Null
then
785 ("multiple null dependency relations not allowed", Item
);
787 elsif Non_Null_Seen
then
789 ("cannot mix null and non-null dependency items", Item
);
797 ("null output list must be the last clause in a "
798 & "dependency relation", Item
);
800 -- Catch a useless dependence of the form:
805 ("useless dependence, null depends on itself", Item
);
813 Non_Null_Seen
:= True;
816 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
820 Resolve_State
(Item
);
822 -- Find the entity of the item. If this is a renaming, climb
823 -- the renaming chain to reach the root object. Renamings of
824 -- non-entire objects do not yield an entity (Empty).
826 Item_Id
:= Entity_Of
(Item
);
828 if Present
(Item_Id
) then
829 if Ekind_In
(Item_Id
, E_Abstract_State
,
835 -- Ensure that the item fulfils its role as input and/or
836 -- output as specified by pragma Global or the enclosing
839 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
841 -- Detect multiple uses of the same state, variable or
842 -- formal parameter. If this is not the case, add the
843 -- item to the list of processed relations.
845 if Contains
(Seen
, Item_Id
) then
847 ("duplicate use of item &", Item
, Item_Id
);
849 Add_Item
(Item_Id
, Seen
);
852 -- Detect illegal use of an input related to a null
853 -- output. Such input items cannot appear in other
854 -- input lists (SPARK RM 6.1.5(13)).
857 and then Null_Output_Seen
858 and then Contains
(All_Inputs_Seen
, Item_Id
)
861 ("input of a null output list cannot appear in "
862 & "multiple input lists", Item
);
865 -- Add an input or a self-referential output to the list
866 -- of all processed inputs.
868 if Is_Input
or else Self_Ref
then
869 Add_Item
(Item_Id
, All_Inputs_Seen
);
872 -- State related checks (SPARK RM 6.1.5(3))
874 if Ekind
(Item_Id
) = E_Abstract_State
then
875 if Has_Visible_Refinement
(Item_Id
) then
877 ("cannot mention state & in global refinement",
879 SPARK_Msg_N
("\use its constituents instead", Item
);
882 -- If the reference to the abstract state appears in
883 -- an enclosing package body that will eventually
884 -- refine the state, record the reference for future
888 Record_Possible_Body_Reference
889 (State_Id
=> Item_Id
,
894 -- When the item renames an entire object, replace the
895 -- item with a reference to the object.
897 if Present
(Renamed_Object
(Entity
(Item
))) then
899 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
903 -- Add the entity of the current item to the list of
906 if Ekind
(Item_Id
) = E_Abstract_State
then
907 Add_Item
(Item_Id
, States_Seen
);
910 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
911 and then Present
(Encapsulating_State
(Item_Id
))
913 Add_Item
(Item_Id
, Constits_Seen
);
916 -- All other input/output items are illegal
917 -- (SPARK RM 6.1.5(1)).
921 ("item must denote parameter, variable, or state",
925 -- All other input/output items are illegal
926 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
930 ("item must denote parameter, variable, or state", Item
);
933 end Analyze_Input_Output
;
941 Non_Null_Output_Seen
: Boolean := False;
942 -- Flag used to check the legality of an output list
944 -- Start of processing for Analyze_Dependency_Clause
947 Inputs
:= Expression
(Clause
);
950 -- An input list with a self-dependency appears as operator "+" where
951 -- the actuals inputs are the right operand.
953 if Nkind
(Inputs
) = N_Op_Plus
then
954 Inputs
:= Right_Opnd
(Inputs
);
958 -- Process the output_list of a dependency_clause
960 Output
:= First
(Choices
(Clause
));
961 while Present
(Output
) loop
965 Self_Ref
=> Self_Ref
,
967 Seen
=> All_Outputs_Seen
,
968 Null_Seen
=> Null_Output_Seen
,
969 Non_Null_Seen
=> Non_Null_Output_Seen
);
974 -- Process the input_list of a dependency_clause
976 Analyze_Input_List
(Inputs
);
977 end Analyze_Dependency_Clause
;
979 ---------------------------
980 -- Check_Function_Return --
981 ---------------------------
983 procedure Check_Function_Return
is
985 if Ekind
(Spec_Id
) = E_Function
and then not Result_Seen
then
987 ("result of & must appear in exactly one output list",
990 end Check_Function_Return
;
1003 (Item_Is_Input
: out Boolean;
1004 Item_Is_Output
: out Boolean);
1005 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1006 -- Item_Is_Output are set depending on the role.
1008 procedure Role_Error
1009 (Item_Is_Input
: Boolean;
1010 Item_Is_Output
: Boolean);
1011 -- Emit an error message concerning the incorrect use of Item in
1012 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1013 -- denote whether the item is an input and/or an output.
1020 (Item_Is_Input
: out Boolean;
1021 Item_Is_Output
: out Boolean)
1024 Item_Is_Input
:= False;
1025 Item_Is_Output
:= False;
1027 -- Abstract state cases
1029 if Ekind
(Item_Id
) = E_Abstract_State
then
1031 -- When pragma Global is present, the mode of the state may be
1032 -- further constrained by setting a more restrictive mode.
1035 if Appears_In
(Subp_Inputs
, Item_Id
) then
1036 Item_Is_Input
:= True;
1039 if Appears_In
(Subp_Outputs
, Item_Id
) then
1040 Item_Is_Output
:= True;
1043 -- Otherwise the state has a default IN OUT mode
1046 Item_Is_Input
:= True;
1047 Item_Is_Output
:= True;
1052 elsif Ekind
(Item_Id
) = E_In_Parameter
then
1053 Item_Is_Input
:= True;
1055 elsif Ekind
(Item_Id
) = E_In_Out_Parameter
then
1056 Item_Is_Input
:= True;
1057 Item_Is_Output
:= True;
1059 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1060 if Scope
(Item_Id
) = Spec_Id
then
1062 -- An OUT parameter of the related subprogram has mode IN
1063 -- if its type is unconstrained or tagged because array
1064 -- bounds, discriminants or tags can be read.
1066 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1067 Item_Is_Input
:= True;
1070 Item_Is_Output
:= True;
1072 -- An OUT parameter of an enclosing subprogram behaves as a
1073 -- read-write variable in which case the mode is IN OUT.
1076 Item_Is_Input
:= True;
1077 Item_Is_Output
:= True;
1082 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1084 -- When pragma Global is present, the mode of the variable may
1085 -- be further constrained by setting a more restrictive mode.
1089 -- A variable has mode IN when its type is unconstrained or
1090 -- tagged because array bounds, discriminants or tags can be
1093 if Appears_In
(Subp_Inputs
, Item_Id
)
1094 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1096 Item_Is_Input
:= True;
1099 if Appears_In
(Subp_Outputs
, Item_Id
) then
1100 Item_Is_Output
:= True;
1103 -- Otherwise the variable has a default IN OUT mode
1106 Item_Is_Input
:= True;
1107 Item_Is_Output
:= True;
1116 procedure Role_Error
1117 (Item_Is_Input
: Boolean;
1118 Item_Is_Output
: Boolean)
1120 Error_Msg
: Name_Id
;
1125 -- When the item is not part of the input and the output set of
1126 -- the related subprogram, then it appears as extra in pragma
1127 -- [Refined_]Depends.
1129 if not Item_Is_Input
and then not Item_Is_Output
then
1130 Add_Item_To_Name_Buffer
(Item_Id
);
1131 Add_Str_To_Name_Buffer
1132 (" & cannot appear in dependence relation");
1134 Error_Msg
:= Name_Find
;
1135 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1137 Error_Msg_Name_1
:= Chars
(Subp_Id
);
1139 ("\& is not part of the input or output set of subprogram %",
1142 -- The mode of the item and its role in pragma [Refined_]Depends
1143 -- are in conflict. Construct a detailed message explaining the
1144 -- illegality (SPARK RM 6.1.5(5-6)).
1147 if Item_Is_Input
then
1148 Add_Str_To_Name_Buffer
("read-only");
1150 Add_Str_To_Name_Buffer
("write-only");
1153 Add_Char_To_Name_Buffer
(' ');
1154 Add_Item_To_Name_Buffer
(Item_Id
);
1155 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1157 if Item_Is_Input
then
1158 Add_Str_To_Name_Buffer
("output");
1160 Add_Str_To_Name_Buffer
("input");
1163 Add_Str_To_Name_Buffer
(" in dependence relation");
1164 Error_Msg
:= Name_Find
;
1165 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1171 Item_Is_Input
: Boolean;
1172 Item_Is_Output
: Boolean;
1174 -- Start of processing for Check_Role
1177 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1182 if not Item_Is_Input
then
1183 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1186 -- Self-referential item
1189 if not Item_Is_Input
or else not Item_Is_Output
then
1190 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1195 elsif not Item_Is_Output
then
1196 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1204 procedure Check_Usage
1205 (Subp_Items
: Elist_Id
;
1206 Used_Items
: Elist_Id
;
1209 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
);
1210 -- Emit an error concerning the illegal usage of an item
1216 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
) is
1217 Error_Msg
: Name_Id
;
1224 -- Unconstrained and tagged items are not part of the explicit
1225 -- input set of the related subprogram, they do not have to be
1226 -- present in a dependence relation and should not be flagged
1227 -- (SPARK RM 6.1.5(8)).
1229 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1232 Add_Item_To_Name_Buffer
(Item_Id
);
1233 Add_Str_To_Name_Buffer
1234 (" & must appear in at least one input dependence list");
1236 Error_Msg
:= Name_Find
;
1237 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1240 -- Output case (SPARK RM 6.1.5(10))
1245 Add_Item_To_Name_Buffer
(Item_Id
);
1246 Add_Str_To_Name_Buffer
1247 (" & must appear in exactly one output dependence list");
1249 Error_Msg
:= Name_Find
;
1250 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1258 Item_Id
: Entity_Id
;
1260 -- Start of processing for Check_Usage
1263 if No
(Subp_Items
) then
1267 -- Each input or output of the subprogram must appear in a dependency
1270 Elmt
:= First_Elmt
(Subp_Items
);
1271 while Present
(Elmt
) loop
1272 Item
:= Node
(Elmt
);
1274 if Nkind
(Item
) = N_Defining_Identifier
then
1277 Item_Id
:= Entity_Of
(Item
);
1280 -- The item does not appear in a dependency
1282 if Present
(Item_Id
)
1283 and then not Contains
(Used_Items
, Item_Id
)
1285 if Is_Formal
(Item_Id
) then
1286 Usage_Error
(Item
, Item_Id
);
1288 -- States and global variables are not used properly only when
1289 -- the subprogram is subject to pragma Global.
1291 elsif Global_Seen
then
1292 Usage_Error
(Item
, Item_Id
);
1300 ----------------------
1301 -- Normalize_Clause --
1302 ----------------------
1304 procedure Normalize_Clause
(Clause
: Node_Id
) is
1305 procedure Create_Or_Modify_Clause
1311 Multiple
: Boolean);
1312 -- Create a brand new clause to represent the self-reference or
1313 -- modify the input and/or output lists of an existing clause. Output
1314 -- denotes a self-referencial output. Outputs is the output list of a
1315 -- clause. Inputs is the input list of a clause. After denotes the
1316 -- clause after which the new clause is to be inserted. Flag In_Place
1317 -- should be set when normalizing the last output of an output list.
1318 -- Flag Multiple should be set when Output comes from a list with
1321 -----------------------------
1322 -- Create_Or_Modify_Clause --
1323 -----------------------------
1325 procedure Create_Or_Modify_Clause
1333 procedure Propagate_Output
1336 -- Handle the various cases of output propagation to the input
1337 -- list. Output denotes a self-referencial output item. Inputs is
1338 -- the input list of a clause.
1340 ----------------------
1341 -- Propagate_Output --
1342 ----------------------
1344 procedure Propagate_Output
1348 function In_Input_List
1350 Inputs
: List_Id
) return Boolean;
1351 -- Determine whether a particulat item appears in the input
1352 -- list of a clause.
1358 function In_Input_List
1360 Inputs
: List_Id
) return Boolean
1365 Elmt
:= First
(Inputs
);
1366 while Present
(Elmt
) loop
1367 if Entity_Of
(Elmt
) = Item
then
1379 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1382 -- Start of processing for Propagate_Output
1385 -- The clause is of the form:
1387 -- (Output =>+ null)
1389 -- Remove null input and replace it with a copy of the output:
1391 -- (Output => Output)
1393 if Nkind
(Inputs
) = N_Null
then
1394 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1396 -- The clause is of the form:
1398 -- (Output =>+ (Input1, ..., InputN))
1400 -- Determine whether the output is not already mentioned in the
1401 -- input list and if not, add it to the list of inputs:
1403 -- (Output => (Output, Input1, ..., InputN))
1405 elsif Nkind
(Inputs
) = N_Aggregate
then
1406 Grouped
:= Expressions
(Inputs
);
1408 if not In_Input_List
1412 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1415 -- The clause is of the form:
1417 -- (Output =>+ Input)
1419 -- If the input does not mention the output, group the two
1422 -- (Output => (Output, Input))
1424 elsif Entity_Of
(Inputs
) /= Output_Id
then
1426 Make_Aggregate
(Loc
,
1427 Expressions
=> New_List
(
1428 New_Copy_Tree
(Output
),
1429 New_Copy_Tree
(Inputs
))));
1431 end Propagate_Output
;
1435 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1436 New_Clause
: Node_Id
;
1438 -- Start of processing for Create_Or_Modify_Clause
1441 -- A null output depending on itself does not require any
1444 if Nkind
(Output
) = N_Null
then
1447 -- A function result cannot depend on itself because it cannot
1448 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1450 elsif Is_Attribute_Result
(Output
) then
1451 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1455 -- When performing the transformation in place, simply add the
1456 -- output to the list of inputs (if not already there). This case
1457 -- arises when dealing with the last output of an output list -
1458 -- we perform the normalization in place to avoid generating a
1462 Propagate_Output
(Output
, Inputs
);
1464 -- A list with multiple outputs is slowly trimmed until only
1465 -- one element remains. When this happens, replace aggregate
1466 -- with the element itself.
1470 Rewrite
(Outputs
, Output
);
1476 -- Unchain the output from its output list as it will appear in
1477 -- a new clause. Note that we cannot simply rewrite the output
1478 -- as null because this will violate the semantics of pragma
1483 -- Generate a new clause of the form:
1484 -- (Output => Inputs)
1487 Make_Component_Association
(Loc
,
1488 Choices
=> New_List
(Output
),
1489 Expression
=> New_Copy_Tree
(Inputs
));
1491 -- The new clause contains replicated content that has already
1492 -- been analyzed. There is not need to reanalyze it or
1493 -- renormalize it again.
1495 Set_Analyzed
(New_Clause
);
1498 (Output
=> First
(Choices
(New_Clause
)),
1499 Inputs
=> Expression
(New_Clause
));
1501 Insert_After
(After
, New_Clause
);
1503 end Create_Or_Modify_Clause
;
1507 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1509 Last_Output
: Node_Id
;
1510 Next_Output
: Node_Id
;
1513 -- Start of processing for Normalize_Clause
1516 -- A self-dependency appears as operator "+". Remove the "+" from the
1517 -- tree by moving the real inputs to their proper place.
1519 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1520 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1521 Inputs
:= Expression
(Clause
);
1523 -- Multiple outputs appear as an aggregate
1525 if Nkind
(Outputs
) = N_Aggregate
then
1526 Last_Output
:= Last
(Expressions
(Outputs
));
1528 Output
:= First
(Expressions
(Outputs
));
1529 while Present
(Output
) loop
1531 -- Normalization may remove an output from its list,
1532 -- preserve the subsequent output now.
1534 Next_Output
:= Next
(Output
);
1536 Create_Or_Modify_Clause
1541 In_Place
=> Output
= Last_Output
,
1544 Output
:= Next_Output
;
1550 Create_Or_Modify_Clause
1559 end Normalize_Clause
;
1566 Last_Clause
: Node_Id
;
1567 Subp_Decl
: Node_Id
;
1569 Restore_Scope
: Boolean := False;
1570 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
1572 -- Start of processing for Analyze_Depends_In_Decl_Part
1577 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
1578 Subp_Id
:= Defining_Entity
(Subp_Decl
);
1579 Deps
:= Expression
(Get_Argument
(N
, Subp_Id
));
1581 -- The logic in this routine is used to analyze both pragma Depends and
1582 -- pragma Refined_Depends since they have the same syntax and base
1583 -- semantics. Find the entity of the corresponding spec when analyzing
1586 Spec_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
1588 -- Empty dependency list
1590 if Nkind
(Deps
) = N_Null
then
1592 -- Gather all states, variables and formal parameters that the
1593 -- subprogram may depend on. These items are obtained from the
1594 -- parameter profile or pragma [Refined_]Global (if available).
1596 Collect_Subprogram_Inputs_Outputs
1597 (Subp_Id
=> Subp_Id
,
1598 Subp_Inputs
=> Subp_Inputs
,
1599 Subp_Outputs
=> Subp_Outputs
,
1600 Global_Seen
=> Global_Seen
);
1602 -- Verify that every input or output of the subprogram appear in a
1605 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1606 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1607 Check_Function_Return
;
1609 -- Dependency clauses appear as component associations of an aggregate
1611 elsif Nkind
(Deps
) = N_Aggregate
then
1613 -- Do not attempt to perform analysis of a syntactically illegal
1614 -- clause as this will lead to misleading errors.
1616 if Has_Extra_Parentheses
(Deps
) then
1620 if Present
(Component_Associations
(Deps
)) then
1621 Last_Clause
:= Last
(Component_Associations
(Deps
));
1623 -- Gather all states, variables and formal parameters that the
1624 -- subprogram may depend on. These items are obtained from the
1625 -- parameter profile or pragma [Refined_]Global (if available).
1627 Collect_Subprogram_Inputs_Outputs
1628 (Subp_Id
=> Subp_Id
,
1629 Subp_Inputs
=> Subp_Inputs
,
1630 Subp_Outputs
=> Subp_Outputs
,
1631 Global_Seen
=> Global_Seen
);
1633 -- Ensure that the formal parameters are visible when analyzing
1634 -- all clauses. This falls out of the general rule of aspects
1635 -- pertaining to subprogram declarations. Skip the installation
1636 -- for subprogram bodies because the formals are already visible.
1638 if not In_Open_Scopes
(Spec_Id
) then
1639 Restore_Scope
:= True;
1640 Push_Scope
(Spec_Id
);
1642 if Is_Generic_Subprogram
(Spec_Id
) then
1643 Install_Generic_Formals
(Spec_Id
);
1645 Install_Formals
(Spec_Id
);
1649 Clause
:= First
(Component_Associations
(Deps
));
1650 while Present
(Clause
) loop
1651 Errors
:= Serious_Errors_Detected
;
1653 -- Normalization may create extra clauses that contain
1654 -- replicated input and output names. There is no need to
1657 if not Analyzed
(Clause
) then
1658 Set_Analyzed
(Clause
);
1660 Analyze_Dependency_Clause
1662 Is_Last
=> Clause
= Last_Clause
);
1665 -- Do not normalize a clause if errors were detected (count
1666 -- of Serious_Errors has increased) because the inputs and/or
1667 -- outputs may denote illegal items. Normalization is disabled
1668 -- in ASIS mode as it alters the tree by introducing new nodes
1669 -- similar to expansion.
1671 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1672 Normalize_Clause
(Clause
);
1678 if Restore_Scope
then
1682 -- Verify that every input or output of the subprogram appear in a
1685 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1686 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1687 Check_Function_Return
;
1689 -- The dependency list is malformed. This is a syntax error, always
1693 Error_Msg_N
("malformed dependency relation", Deps
);
1697 -- The top level dependency relation is malformed. This is a syntax
1698 -- error, always report.
1701 Error_Msg_N
("malformed dependency relation", Deps
);
1705 -- Ensure that a state and a corresponding constituent do not appear
1706 -- together in pragma [Refined_]Depends.
1708 Check_State_And_Constituent_Use
1709 (States
=> States_Seen
,
1710 Constits
=> Constits_Seen
,
1712 end Analyze_Depends_In_Decl_Part
;
1714 --------------------------------------------
1715 -- Analyze_External_Property_In_Decl_Part --
1716 --------------------------------------------
1718 procedure Analyze_External_Property_In_Decl_Part
1720 Expr_Val
: out Boolean)
1722 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1723 Obj_Id
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
1724 Expr
: constant Node_Id
:= Get_Pragma_Arg
(Next
(Arg1
));
1727 Error_Msg_Name_1
:= Pragma_Name
(N
);
1729 -- An external property pragma must apply to an effectively volatile
1730 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1731 -- The check is performed at the end of the declarative region due to a
1732 -- possible out-of-order arrangement of pragmas:
1735 -- pragma Async_Readers (Obj);
1736 -- pragma Volatile (Obj);
1738 if not Is_Effectively_Volatile
(Obj_Id
) then
1740 ("external property % must apply to a volatile object", N
);
1743 -- Ensure that the Boolean expression (if present) is static. A missing
1744 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1748 if Present
(Expr
) then
1749 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
1751 if Is_OK_Static_Expression
(Expr
) then
1752 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
1754 SPARK_Msg_N
("expression of % must be static", Expr
);
1757 end Analyze_External_Property_In_Decl_Part
;
1759 ---------------------------------
1760 -- Analyze_Global_In_Decl_Part --
1761 ---------------------------------
1763 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
1764 Constits_Seen
: Elist_Id
:= No_Elist
;
1765 -- A list containing the entities of all constituents processed so far.
1766 -- It aids in detecting illegal usage of a state and a corresponding
1767 -- constituent in pragma [Refinde_]Global.
1769 Seen
: Elist_Id
:= No_Elist
;
1770 -- A list containing the entities of all the items processed so far. It
1771 -- plays a role in detecting distinct entities.
1773 Spec_Id
: Entity_Id
;
1774 -- The entity of the subprogram subject to pragma [Refined_]Global
1776 States_Seen
: Elist_Id
:= No_Elist
;
1777 -- A list containing the entities of all states processed so far. It
1778 -- helps in detecting illegal usage of a state and a corresponding
1779 -- constituent in pragma [Refined_]Global.
1781 Subp_Id
: Entity_Id
;
1782 -- The entity of the subprogram [body or stub] subject to pragma
1783 -- [Refined_]Global.
1785 In_Out_Seen
: Boolean := False;
1786 Input_Seen
: Boolean := False;
1787 Output_Seen
: Boolean := False;
1788 Proof_Seen
: Boolean := False;
1789 -- Flags used to verify the consistency of modes
1791 procedure Analyze_Global_List
1793 Global_Mode
: Name_Id
:= Name_Input
);
1794 -- Verify the legality of a single global list declaration. Global_Mode
1795 -- denotes the current mode in effect.
1797 -------------------------
1798 -- Analyze_Global_List --
1799 -------------------------
1801 procedure Analyze_Global_List
1803 Global_Mode
: Name_Id
:= Name_Input
)
1805 procedure Analyze_Global_Item
1807 Global_Mode
: Name_Id
);
1808 -- Verify the legality of a single global item declaration.
1809 -- Global_Mode denotes the current mode in effect.
1811 procedure Check_Duplicate_Mode
1813 Status
: in out Boolean);
1814 -- Flag Status denotes whether a particular mode has been seen while
1815 -- processing a global list. This routine verifies that Mode is not a
1816 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
1818 procedure Check_Mode_Restriction_In_Enclosing_Context
1820 Item_Id
: Entity_Id
);
1821 -- Verify that an item of mode In_Out or Output does not appear as an
1822 -- input in the Global aspect of an enclosing subprogram. If this is
1823 -- the case, emit an error. Item and Item_Id are respectively the
1824 -- item and its entity.
1826 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
1827 -- Mode denotes either In_Out or Output. Depending on the kind of the
1828 -- related subprogram, emit an error if those two modes apply to a
1829 -- function (SPARK RM 6.1.4(10)).
1831 -------------------------
1832 -- Analyze_Global_Item --
1833 -------------------------
1835 procedure Analyze_Global_Item
1837 Global_Mode
: Name_Id
)
1839 Item_Id
: Entity_Id
;
1842 -- Detect one of the following cases
1844 -- with Global => (null, Name)
1845 -- with Global => (Name_1, null, Name_2)
1846 -- with Global => (Name, null)
1848 if Nkind
(Item
) = N_Null
then
1849 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
1854 Resolve_State
(Item
);
1856 -- Find the entity of the item. If this is a renaming, climb the
1857 -- renaming chain to reach the root object. Renamings of non-
1858 -- entire objects do not yield an entity (Empty).
1860 Item_Id
:= Entity_Of
(Item
);
1862 if Present
(Item_Id
) then
1864 -- A global item may denote a formal parameter of an enclosing
1865 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
1866 -- provide a better error diagnostic.
1868 if Is_Formal
(Item_Id
) then
1869 if Scope
(Item_Id
) = Spec_Id
then
1871 ("global item cannot reference parameter of subprogram",
1876 -- A constant cannot act as a global item (SPARK RM 6.1.4(7)).
1877 -- Do this check first to provide a better error diagnostic.
1879 elsif Ekind
(Item_Id
) = E_Constant
then
1880 SPARK_Msg_N
("global item cannot denote a constant", Item
);
1882 -- A formal object may act as a global item inside a generic
1884 elsif Is_Formal_Object
(Item_Id
) then
1887 -- The only legal references are those to abstract states and
1888 -- variables (SPARK RM 6.1.4(4)).
1890 elsif not Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
1892 ("global item must denote variable or state", Item
);
1896 -- State related checks
1898 if Ekind
(Item_Id
) = E_Abstract_State
then
1900 -- An abstract state with visible refinement cannot appear
1901 -- in pragma [Refined_]Global as its place must be taken by
1902 -- some of its constituents (SPARK RM 6.1.4(8)).
1904 if Has_Visible_Refinement
(Item_Id
) then
1906 ("cannot mention state & in global refinement",
1908 SPARK_Msg_N
("\use its constituents instead", Item
);
1911 -- If the reference to the abstract state appears in an
1912 -- enclosing package body that will eventually refine the
1913 -- state, record the reference for future checks.
1916 Record_Possible_Body_Reference
1917 (State_Id
=> Item_Id
,
1921 -- Variable related checks. These are only relevant when
1922 -- SPARK_Mode is on as they are not standard Ada legality
1925 elsif SPARK_Mode
= On
1926 and then Is_Effectively_Volatile
(Item_Id
)
1928 -- An effectively volatile object cannot appear as a global
1929 -- item of a function (SPARK RM 7.1.3(9)).
1931 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
1933 ("volatile object & cannot act as global item of a "
1934 & "function", Item
, Item_Id
);
1937 -- An effectively volatile object with external property
1938 -- Effective_Reads set to True must have mode Output or
1941 elsif Effective_Reads_Enabled
(Item_Id
)
1942 and then Global_Mode
= Name_Input
1945 ("volatile object & with property Effective_Reads must "
1946 & "have mode In_Out or Output (SPARK RM 7.1.3(11))",
1952 -- When the item renames an entire object, replace the item
1953 -- with a reference to the object.
1955 if Present
(Renamed_Object
(Entity
(Item
))) then
1956 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1960 -- Some form of illegal construct masquerading as a name
1961 -- (SPARK RM 6.1.4(4)).
1964 Error_Msg_N
("global item must denote variable or state", Item
);
1968 -- Verify that an output does not appear as an input in an
1969 -- enclosing subprogram.
1971 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
1972 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
1975 -- The same entity might be referenced through various way.
1976 -- Check the entity of the item rather than the item itself
1977 -- (SPARK RM 6.1.4(11)).
1979 if Contains
(Seen
, Item_Id
) then
1980 SPARK_Msg_N
("duplicate global item", Item
);
1982 -- Add the entity of the current item to the list of processed
1986 Add_Item
(Item_Id
, Seen
);
1988 if Ekind
(Item_Id
) = E_Abstract_State
then
1989 Add_Item
(Item_Id
, States_Seen
);
1992 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
1993 and then Present
(Encapsulating_State
(Item_Id
))
1995 Add_Item
(Item_Id
, Constits_Seen
);
1998 end Analyze_Global_Item
;
2000 --------------------------
2001 -- Check_Duplicate_Mode --
2002 --------------------------
2004 procedure Check_Duplicate_Mode
2006 Status
: in out Boolean)
2010 SPARK_Msg_N
("duplicate global mode", Mode
);
2014 end Check_Duplicate_Mode
;
2016 -------------------------------------------------
2017 -- Check_Mode_Restriction_In_Enclosing_Context --
2018 -------------------------------------------------
2020 procedure Check_Mode_Restriction_In_Enclosing_Context
2022 Item_Id
: Entity_Id
)
2024 Context
: Entity_Id
;
2026 Inputs
: Elist_Id
:= No_Elist
;
2027 Outputs
: Elist_Id
:= No_Elist
;
2030 -- Traverse the scope stack looking for enclosing subprograms
2031 -- subject to pragma [Refined_]Global.
2033 Context
:= Scope
(Subp_Id
);
2034 while Present
(Context
) and then Context
/= Standard_Standard
loop
2035 if Is_Subprogram
(Context
)
2037 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2039 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2041 Collect_Subprogram_Inputs_Outputs
2042 (Subp_Id
=> Context
,
2043 Subp_Inputs
=> Inputs
,
2044 Subp_Outputs
=> Outputs
,
2045 Global_Seen
=> Dummy
);
2047 -- The item is classified as In_Out or Output but appears as
2048 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
2050 if Appears_In
(Inputs
, Item_Id
)
2051 and then not Appears_In
(Outputs
, Item_Id
)
2054 ("global item & cannot have mode In_Out or Output",
2057 ("\item already appears as input of subprogram &",
2060 -- Stop the traversal once an error has been detected
2066 Context
:= Scope
(Context
);
2068 end Check_Mode_Restriction_In_Enclosing_Context
;
2070 ----------------------------------------
2071 -- Check_Mode_Restriction_In_Function --
2072 ----------------------------------------
2074 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2076 if Ekind
(Spec_Id
) = E_Function
then
2078 ("global mode & is not applicable to functions", Mode
);
2080 end Check_Mode_Restriction_In_Function
;
2088 -- Start of processing for Analyze_Global_List
2091 if Nkind
(List
) = N_Null
then
2092 Set_Analyzed
(List
);
2094 -- Single global item declaration
2096 elsif Nkind_In
(List
, N_Expanded_Name
,
2098 N_Selected_Component
)
2100 Analyze_Global_Item
(List
, Global_Mode
);
2102 -- Simple global list or moded global list declaration
2104 elsif Nkind
(List
) = N_Aggregate
then
2105 Set_Analyzed
(List
);
2107 -- The declaration of a simple global list appear as a collection
2110 if Present
(Expressions
(List
)) then
2111 if Present
(Component_Associations
(List
)) then
2113 ("cannot mix moded and non-moded global lists", List
);
2116 Item
:= First
(Expressions
(List
));
2117 while Present
(Item
) loop
2118 Analyze_Global_Item
(Item
, Global_Mode
);
2123 -- The declaration of a moded global list appears as a collection
2124 -- of component associations where individual choices denote
2127 elsif Present
(Component_Associations
(List
)) then
2128 if Present
(Expressions
(List
)) then
2130 ("cannot mix moded and non-moded global lists", List
);
2133 Assoc
:= First
(Component_Associations
(List
));
2134 while Present
(Assoc
) loop
2135 Mode
:= First
(Choices
(Assoc
));
2137 if Nkind
(Mode
) = N_Identifier
then
2138 if Chars
(Mode
) = Name_In_Out
then
2139 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2140 Check_Mode_Restriction_In_Function
(Mode
);
2142 elsif Chars
(Mode
) = Name_Input
then
2143 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2145 elsif Chars
(Mode
) = Name_Output
then
2146 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2147 Check_Mode_Restriction_In_Function
(Mode
);
2149 elsif Chars
(Mode
) = Name_Proof_In
then
2150 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2153 SPARK_Msg_N
("invalid mode selector", Mode
);
2157 SPARK_Msg_N
("invalid mode selector", Mode
);
2160 -- Items in a moded list appear as a collection of
2161 -- expressions. Reuse the existing machinery to analyze
2165 (List
=> Expression
(Assoc
),
2166 Global_Mode
=> Chars
(Mode
));
2174 raise Program_Error
;
2177 -- Any other attempt to declare a global item is illegal. This is a
2178 -- syntax error, always report.
2181 Error_Msg_N
("malformed global list", List
);
2183 end Analyze_Global_List
;
2188 Subp_Decl
: Node_Id
;
2190 Restore_Scope
: Boolean := False;
2191 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit
2193 -- Start of processing for Analyze_Global_In_Decl_Part
2198 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
2199 Subp_Id
:= Defining_Entity
(Subp_Decl
);
2200 Items
:= Expression
(Get_Argument
(N
, Subp_Id
));
2202 -- The logic in this routine is used to analyze both pragma Global and
2203 -- pragma Refined_Global since they have the same syntax and base
2204 -- semantics. Find the entity of the corresponding spec when analyzing
2207 Spec_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
2209 -- There is nothing to be done for a null global list
2211 if Nkind
(Items
) = N_Null
then
2212 Set_Analyzed
(Items
);
2214 -- Analyze the various forms of global lists and items. Note that some
2215 -- of these may be malformed in which case the analysis emits error
2219 -- Ensure that the formal parameters are visible when processing an
2220 -- item. This falls out of the general rule of aspects pertaining to
2221 -- subprogram declarations.
2223 if not In_Open_Scopes
(Spec_Id
) then
2224 Restore_Scope
:= True;
2225 Push_Scope
(Spec_Id
);
2227 if Is_Generic_Subprogram
(Spec_Id
) then
2228 Install_Generic_Formals
(Spec_Id
);
2230 Install_Formals
(Spec_Id
);
2234 Analyze_Global_List
(Items
);
2236 if Restore_Scope
then
2241 -- Ensure that a state and a corresponding constituent do not appear
2242 -- together in pragma [Refined_]Global.
2244 Check_State_And_Constituent_Use
2245 (States
=> States_Seen
,
2246 Constits
=> Constits_Seen
,
2248 end Analyze_Global_In_Decl_Part
;
2250 --------------------------------------------
2251 -- Analyze_Initial_Condition_In_Decl_Part --
2252 --------------------------------------------
2254 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2255 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
));
2260 -- The expression is preanalyzed because it has not been moved to its
2261 -- final place yet. A direct analysis may generate side effects and this
2262 -- is not desired at this point.
2264 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2265 end Analyze_Initial_Condition_In_Decl_Part
;
2267 --------------------------------------
2268 -- Analyze_Initializes_In_Decl_Part --
2269 --------------------------------------
2271 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2272 Pack_Spec
: constant Node_Id
:= Parent
(N
);
2273 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Parent
(Pack_Spec
));
2275 Constits_Seen
: Elist_Id
:= No_Elist
;
2276 -- A list containing the entities of all constituents processed so far.
2277 -- It aids in detecting illegal usage of a state and a corresponding
2278 -- constituent in pragma Initializes.
2280 Items_Seen
: Elist_Id
:= No_Elist
;
2281 -- A list of all initialization items processed so far. This list is
2282 -- used to detect duplicate items.
2284 Non_Null_Seen
: Boolean := False;
2285 Null_Seen
: Boolean := False;
2286 -- Flags used to check the legality of a null initialization list
2288 States_And_Vars
: Elist_Id
:= No_Elist
;
2289 -- A list of all abstract states and variables declared in the visible
2290 -- declarations of the related package. This list is used to detect the
2291 -- legality of initialization items.
2293 States_Seen
: Elist_Id
:= No_Elist
;
2294 -- A list containing the entities of all states processed so far. It
2295 -- helps in detecting illegal usage of a state and a corresponding
2296 -- constituent in pragma Initializes.
2298 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2299 -- Verify the legality of a single initialization item
2301 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2302 -- Verify the legality of a single initialization item followed by a
2303 -- list of input items.
2305 procedure Collect_States_And_Variables
;
2306 -- Inspect the visible declarations of the related package and gather
2307 -- the entities of all abstract states and variables in States_And_Vars.
2309 ---------------------------------
2310 -- Analyze_Initialization_Item --
2311 ---------------------------------
2313 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2314 Item_Id
: Entity_Id
;
2317 -- Null initialization list
2319 if Nkind
(Item
) = N_Null
then
2321 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2323 elsif Non_Null_Seen
then
2325 ("cannot mix null and non-null initialization items", Item
);
2330 -- Initialization item
2333 Non_Null_Seen
:= True;
2337 ("cannot mix null and non-null initialization items", Item
);
2341 Resolve_State
(Item
);
2343 if Is_Entity_Name
(Item
) then
2344 Item_Id
:= Entity_Of
(Item
);
2346 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
2348 -- The state or variable must be declared in the visible
2349 -- declarations of the package (SPARK RM 7.1.5(7)).
2351 if not Contains
(States_And_Vars
, Item_Id
) then
2352 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2354 ("initialization item & must appear in the visible "
2355 & "declarations of package %", Item
, Item_Id
);
2357 -- Detect a duplicate use of the same initialization item
2358 -- (SPARK RM 7.1.5(5)).
2360 elsif Contains
(Items_Seen
, Item_Id
) then
2361 SPARK_Msg_N
("duplicate initialization item", Item
);
2363 -- The item is legal, add it to the list of processed states
2367 Add_Item
(Item_Id
, Items_Seen
);
2369 if Ekind
(Item_Id
) = E_Abstract_State
then
2370 Add_Item
(Item_Id
, States_Seen
);
2373 if Present
(Encapsulating_State
(Item_Id
)) then
2374 Add_Item
(Item_Id
, Constits_Seen
);
2378 -- The item references something that is not a state or a
2379 -- variable (SPARK RM 7.1.5(3)).
2383 ("initialization item must denote variable or state",
2387 -- Some form of illegal construct masquerading as a name
2388 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2392 ("initialization item must denote variable or state", Item
);
2395 end Analyze_Initialization_Item
;
2397 ---------------------------------------------
2398 -- Analyze_Initialization_Item_With_Inputs --
2399 ---------------------------------------------
2401 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2402 Inputs_Seen
: Elist_Id
:= No_Elist
;
2403 -- A list of all inputs processed so far. This list is used to detect
2404 -- duplicate uses of an input.
2406 Non_Null_Seen
: Boolean := False;
2407 Null_Seen
: Boolean := False;
2408 -- Flags used to check the legality of an input list
2410 procedure Analyze_Input_Item
(Input
: Node_Id
);
2411 -- Verify the legality of a single input item
2413 ------------------------
2414 -- Analyze_Input_Item --
2415 ------------------------
2417 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2418 Input_Id
: Entity_Id
;
2423 if Nkind
(Input
) = N_Null
then
2426 ("multiple null initializations not allowed", Item
);
2428 elsif Non_Null_Seen
then
2430 ("cannot mix null and non-null initialization item", Item
);
2438 Non_Null_Seen
:= True;
2442 ("cannot mix null and non-null initialization item", Item
);
2446 Resolve_State
(Input
);
2448 if Is_Entity_Name
(Input
) then
2449 Input_Id
:= Entity_Of
(Input
);
2451 if Ekind_In
(Input_Id
, E_Abstract_State
,
2457 -- The input cannot denote states or variables declared
2458 -- within the related package.
2460 if Within_Scope
(Input_Id
, Current_Scope
) then
2461 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2463 ("input item & cannot denote a visible variable or "
2464 & "state of package % (SPARK RM 7.1.5(4))",
2467 -- Detect a duplicate use of the same input item
2468 -- (SPARK RM 7.1.5(5)).
2470 elsif Contains
(Inputs_Seen
, Input_Id
) then
2471 SPARK_Msg_N
("duplicate input item", Input
);
2473 -- Input is legal, add it to the list of processed inputs
2476 Add_Item
(Input_Id
, Inputs_Seen
);
2478 if Ekind
(Input_Id
) = E_Abstract_State
then
2479 Add_Item
(Input_Id
, States_Seen
);
2482 if Ekind_In
(Input_Id
, E_Abstract_State
, E_Variable
)
2483 and then Present
(Encapsulating_State
(Input_Id
))
2485 Add_Item
(Input_Id
, Constits_Seen
);
2489 -- The input references something that is not a state or a
2490 -- variable (SPARK RM 7.1.5(3)).
2494 ("input item must denote variable or state", Input
);
2497 -- Some form of illegal construct masquerading as a name
2498 -- (SPARK RM 7.1.5(3)).
2502 ("input item must denote variable or state", Input
);
2505 end Analyze_Input_Item
;
2509 Inputs
: constant Node_Id
:= Expression
(Item
);
2513 Name_Seen
: Boolean := False;
2514 -- A flag used to detect multiple item names
2516 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2519 -- Inspect the name of an item with inputs
2521 Elmt
:= First
(Choices
(Item
));
2522 while Present
(Elmt
) loop
2524 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
2527 Analyze_Initialization_Item
(Elmt
);
2533 -- Multiple input items appear as an aggregate
2535 if Nkind
(Inputs
) = N_Aggregate
then
2536 if Present
(Expressions
(Inputs
)) then
2537 Input
:= First
(Expressions
(Inputs
));
2538 while Present
(Input
) loop
2539 Analyze_Input_Item
(Input
);
2544 if Present
(Component_Associations
(Inputs
)) then
2546 ("inputs must appear in named association form", Inputs
);
2549 -- Single input item
2552 Analyze_Input_Item
(Inputs
);
2554 end Analyze_Initialization_Item_With_Inputs
;
2556 ----------------------------------
2557 -- Collect_States_And_Variables --
2558 ----------------------------------
2560 procedure Collect_States_And_Variables
is
2564 -- Collect the abstract states defined in the package (if any)
2566 if Present
(Abstract_States
(Pack_Id
)) then
2567 States_And_Vars
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
2570 -- Collect all variables the appear in the visible declarations of
2571 -- the related package.
2573 if Present
(Visible_Declarations
(Pack_Spec
)) then
2574 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
2575 while Present
(Decl
) loop
2576 if Nkind
(Decl
) = N_Object_Declaration
2577 and then Ekind
(Defining_Entity
(Decl
)) = E_Variable
2578 and then Comes_From_Source
(Decl
)
2580 Add_Item
(Defining_Entity
(Decl
), States_And_Vars
);
2586 end Collect_States_And_Variables
;
2590 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
));
2593 -- Start of processing for Analyze_Initializes_In_Decl_Part
2598 -- Nothing to do when the initialization list is empty
2600 if Nkind
(Inits
) = N_Null
then
2604 -- Single and multiple initialization clauses appear as an aggregate. If
2605 -- this is not the case, then either the parser or the analysis of the
2606 -- pragma failed to produce an aggregate.
2608 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
2610 -- Initialize the various lists used during analysis
2612 Collect_States_And_Variables
;
2614 if Present
(Expressions
(Inits
)) then
2615 Init
:= First
(Expressions
(Inits
));
2616 while Present
(Init
) loop
2617 Analyze_Initialization_Item
(Init
);
2622 if Present
(Component_Associations
(Inits
)) then
2623 Init
:= First
(Component_Associations
(Inits
));
2624 while Present
(Init
) loop
2625 Analyze_Initialization_Item_With_Inputs
(Init
);
2630 -- Ensure that a state and a corresponding constituent do not appear
2631 -- together in pragma Initializes.
2633 Check_State_And_Constituent_Use
2634 (States
=> States_Seen
,
2635 Constits
=> Constits_Seen
,
2637 end Analyze_Initializes_In_Decl_Part
;
2639 --------------------
2640 -- Analyze_Pragma --
2641 --------------------
2643 procedure Analyze_Pragma
(N
: Node_Id
) is
2644 Loc
: constant Source_Ptr
:= Sloc
(N
);
2645 Prag_Id
: Pragma_Id
;
2648 -- Name of the source pragma, or name of the corresponding aspect for
2649 -- pragmas which originate in a source aspect. In the latter case, the
2650 -- name may be different from the pragma name.
2652 Pragma_Exit
: exception;
2653 -- This exception is used to exit pragma processing completely. It
2654 -- is used when an error is detected, and no further processing is
2655 -- required. It is also used if an earlier error has left the tree in
2656 -- a state where the pragma should not be processed.
2659 -- Number of pragma argument associations
2665 -- First four pragma arguments (pragma argument association nodes, or
2666 -- Empty if the corresponding argument does not exist).
2668 type Name_List
is array (Natural range <>) of Name_Id
;
2669 type Args_List
is array (Natural range <>) of Node_Id
;
2670 -- Types used for arguments to Check_Arg_Order and Gather_Associations
2672 -----------------------
2673 -- Local Subprograms --
2674 -----------------------
2676 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
2677 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
2678 -- get the given string argument, and place it in Name_Buffer, adding
2679 -- leading and trailing asterisks if they are not already present. The
2680 -- caller has already checked that Arg is a static string expression.
2682 procedure Ada_2005_Pragma
;
2683 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
2684 -- Ada 95 mode, these are implementation defined pragmas, so should be
2685 -- caught by the No_Implementation_Pragmas restriction.
2687 procedure Ada_2012_Pragma
;
2688 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
2689 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
2690 -- should be caught by the No_Implementation_Pragmas restriction.
2692 procedure Analyze_Part_Of
2693 (Item_Id
: Entity_Id
;
2696 Legal
: out Boolean);
2697 -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of.
2698 -- Perform full analysis of indicator Part_Of. Item_Id is the entity of
2699 -- an abstract state, variable or package instantiation. State is the
2700 -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is
2701 -- set when the indicator is legal.
2703 procedure Analyze_Pre_Post_Condition
;
2704 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
2706 procedure Analyze_Refined_Pragma
2707 (Spec_Id
: out Entity_Id
;
2708 Body_Id
: out Entity_Id
;
2709 Legal
: out Boolean);
2710 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
2711 -- Refined_Global and Refined_Post. Check the placement and related
2712 -- context of the pragma. Spec_Id is the entity of the related
2713 -- subprogram. Body_Id is the entity of the subprogram body. Flag
2714 -- Legal is set when the pragma is properly placed.
2716 procedure Check_Ada_83_Warning
;
2717 -- Issues a warning message for the current pragma if operating in Ada
2718 -- 83 mode (used for language pragmas that are not a standard part of
2719 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
2722 procedure Check_Arg_Count
(Required
: Nat
);
2723 -- Check argument count for pragma is equal to given parameter. If not,
2724 -- then issue an error message and raise Pragma_Exit.
2726 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
2727 -- Arg which can either be a pragma argument association, in which case
2728 -- the check is applied to the expression of the association or an
2729 -- expression directly.
2731 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
2732 -- Check that an argument has the right form for an EXTERNAL_NAME
2733 -- parameter of an extended import/export pragma. The rule is that the
2734 -- name must be an identifier or string literal (in Ada 83 mode) or a
2735 -- static string expression (in Ada 95 mode).
2737 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
2738 -- Check the specified argument Arg to make sure that it is an
2739 -- identifier. If not give error and raise Pragma_Exit.
2741 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
2742 -- Check the specified argument Arg to make sure that it is an integer
2743 -- literal. If not give error and raise Pragma_Exit.
2745 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
2746 -- Check the specified argument Arg to make sure that it has the proper
2747 -- syntactic form for a local name and meets the semantic requirements
2748 -- for a local name. The local name is analyzed as part of the
2749 -- processing for this call. In addition, the local name is required
2750 -- to represent an entity at the library level.
2752 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
2753 -- Check the specified argument Arg to make sure that it has the proper
2754 -- syntactic form for a local name and meets the semantic requirements
2755 -- for a local name. The local name is analyzed as part of the
2756 -- processing for this call.
2758 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
2759 -- Check the specified argument Arg to make sure that it is a valid
2760 -- locking policy name. If not give error and raise Pragma_Exit.
2762 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
2763 -- Check the specified argument Arg to make sure that it is a valid
2764 -- elaboration policy name. If not give error and raise Pragma_Exit.
2766 procedure Check_Arg_Is_One_Of
2769 procedure Check_Arg_Is_One_Of
2771 N1
, N2
, N3
: Name_Id
);
2772 procedure Check_Arg_Is_One_Of
2774 N1
, N2
, N3
, N4
: Name_Id
);
2775 procedure Check_Arg_Is_One_Of
2777 N1
, N2
, N3
, N4
, N5
: Name_Id
);
2778 -- Check the specified argument Arg to make sure that it is an
2779 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
2780 -- present). If not then give error and raise Pragma_Exit.
2782 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
2783 -- Check the specified argument Arg to make sure that it is a valid
2784 -- queuing policy name. If not give error and raise Pragma_Exit.
2786 procedure Check_Arg_Is_OK_Static_Expression
2788 Typ
: Entity_Id
:= Empty
);
2789 -- Check the specified argument Arg to make sure that it is a static
2790 -- expression of the given type (i.e. it will be analyzed and resolved
2791 -- using this type, which can be any valid argument to Resolve, e.g.
2792 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2793 -- Typ is left Empty, then any static expression is allowed. Includes
2794 -- checking that the argument does not raise Constraint_Error.
2796 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
2797 -- Check the specified argument Arg to make sure that it is a valid task
2798 -- dispatching policy name. If not give error and raise Pragma_Exit.
2800 procedure Check_Arg_Order
(Names
: Name_List
);
2801 -- Checks for an instance of two arguments with identifiers for the
2802 -- current pragma which are not in the sequence indicated by Names,
2803 -- and if so, generates a fatal message about bad order of arguments.
2805 procedure Check_At_Least_N_Arguments
(N
: Nat
);
2806 -- Check there are at least N arguments present
2808 procedure Check_At_Most_N_Arguments
(N
: Nat
);
2809 -- Check there are no more than N arguments present
2811 procedure Check_Component
2814 In_Variant_Part
: Boolean := False);
2815 -- Examine an Unchecked_Union component for correct use of per-object
2816 -- constrained subtypes, and for restrictions on finalizable components.
2817 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2818 -- should be set when Comp comes from a record variant.
2820 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
);
2821 -- Subsidiary routine to the analysis of pragmas Abstract_State,
2822 -- Initial_Condition and Initializes. Determine whether pragma First
2823 -- appears before pragma Second. If this is not the case, emit an error.
2825 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
2826 -- Check if a rep item of the same name as the current pragma is already
2827 -- chained as a rep pragma to the given entity. If so give a message
2828 -- about the duplicate, and then raise Pragma_Exit so does not return.
2829 -- Note that if E is a type, then this routine avoids flagging a pragma
2830 -- which applies to a parent type from which E is derived.
2832 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
2833 -- Nam is an N_String_Literal node containing the external name set by
2834 -- an Import or Export pragma (or extended Import or Export pragma).
2835 -- This procedure checks for possible duplications if this is the export
2836 -- case, and if found, issues an appropriate error message.
2838 procedure Check_Expr_Is_OK_Static_Expression
2840 Typ
: Entity_Id
:= Empty
);
2841 -- Check the specified expression Expr to make sure that it is a static
2842 -- expression of the given type (i.e. it will be analyzed and resolved
2843 -- using this type, which can be any valid argument to Resolve, e.g.
2844 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2845 -- Typ is left Empty, then any static expression is allowed. Includes
2846 -- checking that the expression does not raise Constraint_Error.
2848 procedure Check_First_Subtype
(Arg
: Node_Id
);
2849 -- Checks that Arg, whose expression is an entity name, references a
2852 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2853 -- Checks that the given argument has an identifier, and if so, requires
2854 -- it to match the given identifier name. If there is no identifier, or
2855 -- a non-matching identifier, then an error message is given and
2856 -- Pragma_Exit is raised.
2858 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
2859 -- Checks that the given argument has an identifier, and if so, requires
2860 -- it to match one of the given identifier names. If there is no
2861 -- identifier, or a non-matching identifier, then an error message is
2862 -- given and Pragma_Exit is raised.
2864 procedure Check_In_Main_Program
;
2865 -- Common checks for pragmas that appear within a main program
2866 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2868 procedure Check_Interrupt_Or_Attach_Handler
;
2869 -- Common processing for first argument of pragma Interrupt_Handler or
2870 -- pragma Attach_Handler.
2872 procedure Check_Loop_Pragma_Placement
;
2873 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
2874 -- appear immediately within a construct restricted to loops, and that
2875 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
2877 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
2878 -- Check that pragma appears in a declarative part, or in a package
2879 -- specification, i.e. that it does not occur in a statement sequence
2882 procedure Check_No_Identifier
(Arg
: Node_Id
);
2883 -- Checks that the given argument does not have an identifier. If
2884 -- an identifier is present, then an error message is issued, and
2885 -- Pragma_Exit is raised.
2887 procedure Check_No_Identifiers
;
2888 -- Checks that none of the arguments to the pragma has an identifier.
2889 -- If any argument has an identifier, then an error message is issued,
2890 -- and Pragma_Exit is raised.
2892 procedure Check_No_Link_Name
;
2893 -- Checks that no link name is specified
2895 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2896 -- Checks if the given argument has an identifier, and if so, requires
2897 -- it to match the given identifier name. If there is a non-matching
2898 -- identifier, then an error message is given and Pragma_Exit is raised.
2900 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
2901 -- Checks if the given argument has an identifier, and if so, requires
2902 -- it to match the given identifier name. If there is a non-matching
2903 -- identifier, then an error message is given and Pragma_Exit is raised.
2904 -- In this version of the procedure, the identifier name is given as
2905 -- a string with lower case letters.
2907 procedure Check_Static_Constraint
(Constr
: Node_Id
);
2908 -- Constr is a constraint from an N_Subtype_Indication node from a
2909 -- component constraint in an Unchecked_Union type. This routine checks
2910 -- that the constraint is static as required by the restrictions for
2913 procedure Check_Valid_Configuration_Pragma
;
2914 -- Legality checks for placement of a configuration pragma
2916 procedure Check_Valid_Library_Unit_Pragma
;
2917 -- Legality checks for library unit pragmas. A special case arises for
2918 -- pragmas in generic instances that come from copies of the original
2919 -- library unit pragmas in the generic templates. In the case of other
2920 -- than library level instantiations these can appear in contexts which
2921 -- would normally be invalid (they only apply to the original template
2922 -- and to library level instantiations), and they are simply ignored,
2923 -- which is implemented by rewriting them as null statements.
2925 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
2926 -- Check an Unchecked_Union variant for lack of nested variants and
2927 -- presence of at least one component. UU_Typ is the related Unchecked_
2930 procedure Create_Generic_Template
2932 Subp_Id
: Entity_Id
);
2933 -- Subsidiary routine to the processing of pragmas Contract_Cases,
2934 -- Depends, Global, Postcondition, Precondition and Test_Case. Create
2935 -- a generic template for pragma Prag when Prag is a source construct
2936 -- and the related context denoted by Subp_Id is a generic subprogram.
2938 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
2939 -- Subsidiary routine to the processing of pragmas Abstract_State,
2940 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
2941 -- Refined_Global and Refined_State. Transform argument Arg into
2942 -- an aggregate if not one already. N_Null is never transformed.
2943 -- Arg may denote an aspect specification or a pragma argument
2946 procedure Error_Pragma
(Msg
: String);
2947 pragma No_Return
(Error_Pragma
);
2948 -- Outputs error message for current pragma. The message contains a %
2949 -- that will be replaced with the pragma name, and the flag is placed
2950 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
2951 -- calls Fix_Error (see spec of that procedure for details).
2953 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
2954 pragma No_Return
(Error_Pragma_Arg
);
2955 -- Outputs error message for current pragma. The message may contain
2956 -- a % that will be replaced with the pragma name. The parameter Arg
2957 -- may either be a pragma argument association, in which case the flag
2958 -- is placed on the expression of this association, or an expression,
2959 -- in which case the flag is placed directly on the expression. The
2960 -- message is placed using Error_Msg_N, so the message may also contain
2961 -- an & insertion character which will reference the given Arg value.
2962 -- After placing the message, Pragma_Exit is raised. Note: this routine
2963 -- calls Fix_Error (see spec of that procedure for details).
2965 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
2966 pragma No_Return
(Error_Pragma_Arg
);
2967 -- Similar to above form of Error_Pragma_Arg except that two messages
2968 -- are provided, the second is a continuation comment starting with \.
2970 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
2971 pragma No_Return
(Error_Pragma_Arg_Ident
);
2972 -- Outputs error message for current pragma. The message may contain a %
2973 -- that will be replaced with the pragma name. The parameter Arg must be
2974 -- a pragma argument association with a non-empty identifier (i.e. its
2975 -- Chars field must be set), and the error message is placed on the
2976 -- identifier. The message is placed using Error_Msg_N so the message
2977 -- may also contain an & insertion character which will reference
2978 -- the identifier. After placing the message, Pragma_Exit is raised.
2979 -- Note: this routine calls Fix_Error (see spec of that procedure for
2982 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
2983 pragma No_Return
(Error_Pragma_Ref
);
2984 -- Outputs error message for current pragma. The message may contain
2985 -- a % that will be replaced with the pragma name. The parameter Ref
2986 -- must be an entity whose name can be referenced by & and sloc by #.
2987 -- After placing the message, Pragma_Exit is raised. Note: this routine
2988 -- calls Fix_Error (see spec of that procedure for details).
2990 function Find_Lib_Unit_Name
return Entity_Id
;
2991 -- Used for a library unit pragma to find the entity to which the
2992 -- library unit pragma applies, returns the entity found.
2994 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
2995 -- If the pragma is a compilation unit pragma, the id must denote the
2996 -- compilation unit in the same compilation, and the pragma must appear
2997 -- in the list of preceding or trailing pragmas. If it is a program
2998 -- unit pragma that is not a compilation unit pragma, then the
2999 -- identifier must be visible.
3001 function Find_Unique_Parameterless_Procedure
3003 Arg
: Node_Id
) return Entity_Id
;
3004 -- Used for a procedure pragma to find the unique parameterless
3005 -- procedure identified by Name, returns it if it exists, otherwise
3006 -- errors out and uses Arg as the pragma argument for the message.
3008 function Fix_Error
(Msg
: String) return String;
3009 -- This is called prior to issuing an error message. Msg is the normal
3010 -- error message issued in the pragma case. This routine checks for the
3011 -- case of a pragma coming from an aspect in the source, and returns a
3012 -- message suitable for the aspect case as follows:
3014 -- Each substring "pragma" is replaced by "aspect"
3016 -- If "argument of" is at the start of the error message text, it is
3017 -- replaced by "entity for".
3019 -- If "argument" is at the start of the error message text, it is
3020 -- replaced by "entity".
3022 -- So for example, "argument of pragma X must be discrete type"
3023 -- returns "entity for aspect X must be a discrete type".
3025 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3026 -- be different from the pragma name). If the current pragma results
3027 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3028 -- original pragma name.
3030 procedure Gather_Associations
3032 Args
: out Args_List
);
3033 -- This procedure is used to gather the arguments for a pragma that
3034 -- permits arbitrary ordering of parameters using the normal rules
3035 -- for named and positional parameters. The Names argument is a list
3036 -- of Name_Id values that corresponds to the allowed pragma argument
3037 -- association identifiers in order. The result returned in Args is
3038 -- a list of corresponding expressions that are the pragma arguments.
3039 -- Note that this is a list of expressions, not of pragma argument
3040 -- associations (Gather_Associations has completely checked all the
3041 -- optional identifiers when it returns). An entry in Args is Empty
3042 -- on return if the corresponding argument is not present.
3044 procedure GNAT_Pragma
;
3045 -- Called for all GNAT defined pragmas to check the relevant restriction
3046 -- (No_Implementation_Pragmas).
3048 function Is_Before_First_Decl
3049 (Pragma_Node
: Node_Id
;
3050 Decls
: List_Id
) return Boolean;
3051 -- Return True if Pragma_Node is before the first declarative item in
3052 -- Decls where Decls is the list of declarative items.
3054 function Is_Configuration_Pragma
return Boolean;
3055 -- Determines if the placement of the current pragma is appropriate
3056 -- for a configuration pragma.
3058 function Is_In_Context_Clause
return Boolean;
3059 -- Returns True if pragma appears within the context clause of a unit,
3060 -- and False for any other placement (does not generate any messages).
3062 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3063 -- Analyzes the argument, and determines if it is a static string
3064 -- expression, returns True if so, False if non-static or not String.
3065 -- A special case is that a string literal returns True in Ada 83 mode
3066 -- (which has no such thing as static string expressions). Note that
3067 -- the call analyzes its argument, so this cannot be used for the case
3068 -- where an identifier might not be declared.
3070 procedure Pragma_Misplaced
;
3071 pragma No_Return
(Pragma_Misplaced
);
3072 -- Issue fatal error message for misplaced pragma
3074 procedure Process_Atomic_Independent_Shared_Volatile
;
3075 -- Common processing for pragmas Atomic, Independent, Shared, Volatile.
3076 -- Note that Shared is an obsolete Ada 83 pragma and treated as being
3077 -- identical in effect to pragma Atomic.
3079 procedure Process_Compile_Time_Warning_Or_Error
;
3080 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3082 procedure Process_Convention
3083 (C
: out Convention_Id
;
3084 Ent
: out Entity_Id
);
3085 -- Common processing for Convention, Interface, Import and Export.
3086 -- Checks first two arguments of pragma, and sets the appropriate
3087 -- convention value in the specified entity or entities. On return
3088 -- C is the convention, Ent is the referenced entity.
3090 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3091 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3092 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3094 procedure Process_Extended_Import_Export_Object_Pragma
3095 (Arg_Internal
: Node_Id
;
3096 Arg_External
: Node_Id
;
3097 Arg_Size
: Node_Id
);
3098 -- Common processing for the pragmas Import/Export_Object. The three
3099 -- arguments correspond to the three named parameters of the pragmas. An
3100 -- argument is empty if the corresponding parameter is not present in
3103 procedure Process_Extended_Import_Export_Internal_Arg
3104 (Arg_Internal
: Node_Id
:= Empty
);
3105 -- Common processing for all extended Import and Export pragmas. The
3106 -- argument is the pragma parameter for the Internal argument. If
3107 -- Arg_Internal is empty or inappropriate, an error message is posted.
3108 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3109 -- set to identify the referenced entity.
3111 procedure Process_Extended_Import_Export_Subprogram_Pragma
3112 (Arg_Internal
: Node_Id
;
3113 Arg_External
: Node_Id
;
3114 Arg_Parameter_Types
: Node_Id
;
3115 Arg_Result_Type
: Node_Id
:= Empty
;
3116 Arg_Mechanism
: Node_Id
;
3117 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3118 -- Common processing for all extended Import and Export pragmas applying
3119 -- to subprograms. The caller omits any arguments that do not apply to
3120 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3121 -- only in the Import_Function and Export_Function cases). The argument
3122 -- names correspond to the allowed pragma association identifiers.
3124 procedure Process_Generic_List
;
3125 -- Common processing for Share_Generic and Inline_Generic
3127 procedure Process_Import_Or_Interface
;
3128 -- Common processing for Import or Interface
3130 procedure Process_Import_Predefined_Type
;
3131 -- Processing for completing a type with pragma Import. This is used
3132 -- to declare types that match predefined C types, especially for cases
3133 -- without corresponding Ada predefined type.
3135 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3136 -- Inline status of a subprogram, indicated as follows:
3137 -- Suppressed: inlining is suppressed for the subprogram
3138 -- Disabled: no inlining is requested for the subprogram
3139 -- Enabled: inlining is requested/required for the subprogram
3141 procedure Process_Inline
(Status
: Inline_Status
);
3142 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3143 -- indicates the inline status specified by the pragma.
3145 procedure Process_Interface_Name
3146 (Subprogram_Def
: Entity_Id
;
3148 Link_Arg
: Node_Id
);
3149 -- Given the last two arguments of pragma Import, pragma Export, or
3150 -- pragma Interface_Name, performs validity checks and sets the
3151 -- Interface_Name field of the given subprogram entity to the
3152 -- appropriate external or link name, depending on the arguments given.
3153 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3154 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3155 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3156 -- nor Link_Arg is present, the interface name is set to the default
3157 -- from the subprogram name.
3159 procedure Process_Interrupt_Or_Attach_Handler
;
3160 -- Common processing for Interrupt and Attach_Handler pragmas
3162 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3163 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3164 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3165 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3166 -- is not set in the Restrictions case.
3168 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3169 -- Common processing for Suppress and Unsuppress. The boolean parameter
3170 -- Suppress_Case is True for the Suppress case, and False for the
3173 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
3174 -- Subsidiary to the analysis of pragmas Independent[_Components].
3175 -- Record such a pragma N applied to entity E for future checks.
3177 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3178 -- This procedure sets the Is_Exported flag for the given entity,
3179 -- checking that the entity was not previously imported. Arg is
3180 -- the argument that specified the entity. A check is also made
3181 -- for exporting inappropriate entities.
3183 procedure Set_Extended_Import_Export_External_Name
3184 (Internal_Ent
: Entity_Id
;
3185 Arg_External
: Node_Id
);
3186 -- Common processing for all extended import export pragmas. The first
3187 -- argument, Internal_Ent, is the internal entity, which has already
3188 -- been checked for validity by the caller. Arg_External is from the
3189 -- Import or Export pragma, and may be null if no External parameter
3190 -- was present. If Arg_External is present and is a non-null string
3191 -- (a null string is treated as the default), then the Interface_Name
3192 -- field of Internal_Ent is set appropriately.
3194 procedure Set_Imported
(E
: Entity_Id
);
3195 -- This procedure sets the Is_Imported flag for the given entity,
3196 -- checking that it is not previously exported or imported.
3198 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3199 -- Mech is a parameter passing mechanism (see Import_Function syntax
3200 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3201 -- has the right form, and if not issues an error message. If the
3202 -- argument has the right form then the Mechanism field of Ent is
3203 -- set appropriately.
3205 procedure Set_Rational_Profile
;
3206 -- Activate the set of configuration pragmas and permissions that make
3207 -- up the Rational profile.
3209 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
3210 -- Activate the set of configuration pragmas and restrictions that make
3211 -- up the Ravenscar Profile. N is the corresponding pragma node, which
3212 -- is used for error messages on any constructs violating the profile.
3214 ----------------------------------
3215 -- Acquire_Warning_Match_String --
3216 ----------------------------------
3218 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3220 String_To_Name_Buffer
3221 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3223 -- Add asterisk at start if not already there
3225 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3226 Name_Buffer
(2 .. Name_Len
+ 1) :=
3227 Name_Buffer
(1 .. Name_Len
);
3228 Name_Buffer
(1) := '*';
3229 Name_Len
:= Name_Len
+ 1;
3232 -- Add asterisk at end if not already there
3234 if Name_Buffer
(Name_Len
) /= '*' then
3235 Name_Len
:= Name_Len
+ 1;
3236 Name_Buffer
(Name_Len
) := '*';
3238 end Acquire_Warning_Match_String
;
3240 ---------------------
3241 -- Ada_2005_Pragma --
3242 ---------------------
3244 procedure Ada_2005_Pragma
is
3246 if Ada_Version
<= Ada_95
then
3247 Check_Restriction
(No_Implementation_Pragmas
, N
);
3249 end Ada_2005_Pragma
;
3251 ---------------------
3252 -- Ada_2012_Pragma --
3253 ---------------------
3255 procedure Ada_2012_Pragma
is
3257 if Ada_Version
<= Ada_2005
then
3258 Check_Restriction
(No_Implementation_Pragmas
, N
);
3260 end Ada_2012_Pragma
;
3262 ---------------------
3263 -- Analyze_Part_Of --
3264 ---------------------
3266 procedure Analyze_Part_Of
3267 (Item_Id
: Entity_Id
;
3270 Legal
: out Boolean)
3272 Pack_Id
: Entity_Id
;
3273 Placement
: State_Space_Kind
;
3274 Parent_Unit
: Entity_Id
;
3275 State_Id
: Entity_Id
;
3278 -- Assume that the pragma/option is illegal
3282 if Nkind_In
(State
, N_Expanded_Name
,
3284 N_Selected_Component
)
3287 Resolve_State
(State
);
3289 if Is_Entity_Name
(State
)
3290 and then Ekind
(Entity
(State
)) = E_Abstract_State
3292 State_Id
:= Entity
(State
);
3296 ("indicator Part_Of must denote an abstract state", State
);
3300 -- This is a syntax error, always report
3304 ("indicator Part_Of must denote an abstract state", State
);
3308 -- Determine where the state, variable or the package instantiation
3309 -- lives with respect to the enclosing packages or package bodies (if
3310 -- any). This placement dictates the legality of the encapsulating
3313 Find_Placement_In_State_Space
3314 (Item_Id
=> Item_Id
,
3315 Placement
=> Placement
,
3316 Pack_Id
=> Pack_Id
);
3318 -- The item appears in a non-package construct with a declarative
3319 -- part (subprogram, block, etc). As such, the item is not allowed
3320 -- to be a part of an encapsulating state because the item is not
3323 if Placement
= Not_In_Package
then
3325 ("indicator Part_Of cannot appear in this context "
3326 & "(SPARK RM 7.2.6(5))", Indic
);
3327 Error_Msg_Name_1
:= Chars
(Scope
(State_Id
));
3329 ("\& is not part of the hidden state of package %",
3332 -- The item appears in the visible state space of some package. In
3333 -- general this scenario does not warrant Part_Of except when the
3334 -- package is a private child unit and the encapsulating state is
3335 -- declared in a parent unit or a public descendant of that parent
3338 elsif Placement
= Visible_State_Space
then
3339 if Is_Child_Unit
(Pack_Id
)
3340 and then Is_Private_Descendant
(Pack_Id
)
3342 -- A variable or state abstraction which is part of the
3343 -- visible state of a private child unit (or one of its public
3344 -- descendants) must have its Part_Of indicator specified. The
3345 -- Part_Of indicator must denote a state abstraction declared
3346 -- by either the parent unit of the private unit or by a public
3347 -- descendant of that parent unit.
3349 -- Find nearest private ancestor (which can be the current unit
3352 Parent_Unit
:= Pack_Id
;
3353 while Present
(Parent_Unit
) loop
3354 exit when Private_Present
3355 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3356 Parent_Unit
:= Scope
(Parent_Unit
);
3359 Parent_Unit
:= Scope
(Parent_Unit
);
3361 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(State_Id
)) then
3363 ("indicator Part_Of must denote an abstract state of& "
3364 & "or public descendant (SPARK RM 7.2.6(3))",
3365 Indic
, Parent_Unit
);
3367 elsif Scope
(State_Id
) = Parent_Unit
3368 or else (Is_Ancestor_Package
(Parent_Unit
, Scope
(State_Id
))
3370 not Is_Private_Descendant
(Scope
(State_Id
)))
3376 ("indicator Part_Of must denote an abstract state of& "
3377 & "or public descendant (SPARK RM 7.2.6(3))",
3378 Indic
, Parent_Unit
);
3381 -- Indicator Part_Of is not needed when the related package is not
3382 -- a private child unit or a public descendant thereof.
3386 ("indicator Part_Of cannot appear in this context "
3387 & "(SPARK RM 7.2.6(5))", Indic
);
3388 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3390 ("\& is declared in the visible part of package %",
3394 -- When the item appears in the private state space of a package, the
3395 -- encapsulating state must be declared in the same package.
3397 elsif Placement
= Private_State_Space
then
3398 if Scope
(State_Id
) /= Pack_Id
then
3400 ("indicator Part_Of must designate an abstract state of "
3401 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3402 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3404 ("\& is declared in the private part of package %",
3408 -- Items declared in the body state space of a package do not need
3409 -- Part_Of indicators as the refinement has already been seen.
3413 ("indicator Part_Of cannot appear in this context "
3414 & "(SPARK RM 7.2.6(5))", Indic
);
3416 if Scope
(State_Id
) = Pack_Id
then
3417 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3419 ("\& is declared in the body of package %", Indic
, Item_Id
);
3424 end Analyze_Part_Of
;
3426 --------------------------------
3427 -- Analyze_Pre_Post_Condition --
3428 --------------------------------
3430 procedure Analyze_Pre_Post_Condition
is
3431 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
3432 Subp_Decl
: Node_Id
;
3433 Subp_Id
: Entity_Id
;
3435 Duplicates_OK
: Boolean := False;
3436 -- Flag set when a pre/postcondition allows multiple pragmas of the
3439 In_Body_OK
: Boolean := False;
3440 -- Flag set when a pre/postcondition is allowed to appear on a body
3441 -- even though the subprogram may have a spec.
3443 Is_Pre_Post
: Boolean := False;
3444 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
3448 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
3449 -- offer uniformity among the various kinds of pre/postconditions by
3450 -- rewriting the pragma identifier. This allows the retrieval of the
3451 -- original pragma name by routine Original_Aspect_Pragma_Name.
3453 if Comes_From_Source
(N
) then
3454 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
3455 Is_Pre_Post
:= True;
3456 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
3457 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
3459 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
3460 Is_Pre_Post
:= True;
3461 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
3462 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
3466 -- Determine the semantics with respect to duplicates and placement
3467 -- in a body. Pragmas Precondition and Postcondition were introduced
3468 -- before aspects and are not subject to the same aspect-like rules.
3470 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
3471 Duplicates_OK
:= True;
3477 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
3478 -- argument without an identifier.
3481 Check_Arg_Count
(1);
3482 Check_No_Identifiers
;
3484 -- Pragmas Precondition and Postcondition have complex argument
3488 Check_At_Least_N_Arguments
(1);
3489 Check_At_Most_N_Arguments
(2);
3490 Check_Optional_Identifier
(Arg1
, Name_Check
);
3492 if Present
(Arg2
) then
3493 Check_Optional_Identifier
(Arg2
, Name_Message
);
3494 Preanalyze_Spec_Expression
3495 (Get_Pragma_Arg
(Arg2
), Standard_String
);
3499 -- For a pragma PPC in the extended main source unit, record enabled
3501 -- ??? nothing checks that the pragma is in the main source unit
3503 if Is_Checked
(N
) and then not Split_PPC
(N
) then
3504 Set_SCO_Pragma_Enabled
(Loc
);
3507 -- Ensure the proper placement of the pragma
3510 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> not Duplicates_OK
);
3512 -- When a pre/postcondition pragma applies to an abstract subprogram,
3513 -- its original form must be an aspect with 'Class.
3515 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
3516 if not From_Aspect_Specification
(N
) then
3518 ("pragma % cannot be applied to abstract subprogram");
3520 elsif not Class_Present
(N
) then
3522 ("aspect % requires ''Class for abstract subprogram");
3525 -- Entry declaration
3527 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
3530 -- Generic subprogram declaration
3532 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
3537 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
3538 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
3542 -- Subprogram body stub
3544 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
3545 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
3549 -- Subprogram declaration
3551 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
3553 -- AI05-0230: When a pre/postcondition pragma applies to a null
3554 -- procedure, its original form must be an aspect with 'Class.
3556 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
3557 and then Null_Present
(Specification
(Subp_Decl
))
3558 and then From_Aspect_Specification
(N
)
3559 and then not Class_Present
(N
)
3561 Error_Pragma
("aspect % requires ''Class for null procedure");
3564 -- Otherwise the placement is illegal
3571 Subp_Id
:= Defining_Entity
(Subp_Decl
);
3573 -- Construct a generic template for the pragma when the context is a
3574 -- generic subprogram and the pragma is a source construct.
3576 Create_Generic_Template
(N
, Subp_Id
);
3578 -- Fully analyze the pragma when it appears inside a subprogram
3579 -- body because it cannot benefit from forward references.
3581 if Nkind_In
(Subp_Decl
, N_Subprogram_Body
,
3582 N_Subprogram_Body_Stub
)
3584 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
3587 -- Chain the pragma on the contract for further processing
3589 Add_Contract_Item
(N
, Subp_Id
);
3590 end Analyze_Pre_Post_Condition
;
3592 ----------------------------
3593 -- Analyze_Refined_Pragma --
3594 ----------------------------
3596 procedure Analyze_Refined_Pragma
3597 (Spec_Id
: out Entity_Id
;
3598 Body_Id
: out Entity_Id
;
3599 Legal
: out Boolean)
3601 Body_Decl
: Node_Id
;
3602 Spec_Decl
: Node_Id
;
3605 -- Assume that the pragma is illegal
3612 Check_Arg_Count
(1);
3613 Check_No_Identifiers
;
3615 -- Verify the placement of the pragma and check for duplicates. The
3616 -- pragma must apply to a subprogram body [stub].
3618 Body_Decl
:= Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
3620 -- Extract the entities of the spec and body
3622 if Nkind
(Body_Decl
) = N_Subprogram_Body
then
3623 Body_Id
:= Defining_Entity
(Body_Decl
);
3624 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
3626 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
3627 Body_Id
:= Defining_Entity
(Body_Decl
);
3628 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
3635 -- The pragma must apply to the second declaration of a subprogram.
3636 -- In other words, the body [stub] cannot acts as a spec.
3638 if No
(Spec_Id
) then
3639 Error_Pragma
("pragma % cannot apply to a stand alone body");
3642 -- Catch the case where the subprogram body is a subunit and acts as
3643 -- the third declaration of the subprogram.
3645 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
3646 Error_Pragma
("pragma % cannot apply to a subunit");
3650 -- The pragma can only apply to the body [stub] of a subprogram
3651 -- declared in the visible part of a package. Retrieve the context of
3652 -- the subprogram declaration.
3654 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
3656 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
3658 ("pragma % must apply to the body of a subprogram declared in a "
3659 & "package specification");
3663 -- If we get here, then the pragma is legal
3665 if Nam_In
(Pname
, Name_Refined_Depends
,
3666 Name_Refined_Global
,
3669 Ensure_Aggregate_Form
(Get_Argument
(N
));
3673 end Analyze_Refined_Pragma
;
3675 --------------------------
3676 -- Check_Ada_83_Warning --
3677 --------------------------
3679 procedure Check_Ada_83_Warning
is
3681 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3682 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
3684 end Check_Ada_83_Warning
;
3686 ---------------------
3687 -- Check_Arg_Count --
3688 ---------------------
3690 procedure Check_Arg_Count
(Required
: Nat
) is
3692 if Arg_Count
/= Required
then
3693 Error_Pragma
("wrong number of arguments for pragma%");
3695 end Check_Arg_Count
;
3697 --------------------------------
3698 -- Check_Arg_Is_External_Name --
3699 --------------------------------
3701 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
3702 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3705 if Nkind
(Argx
) = N_Identifier
then
3709 Analyze_And_Resolve
(Argx
, Standard_String
);
3711 if Is_OK_Static_Expression
(Argx
) then
3714 elsif Etype
(Argx
) = Any_Type
then
3717 -- An interesting special case, if we have a string literal and
3718 -- we are in Ada 83 mode, then we allow it even though it will
3719 -- not be flagged as static. This allows expected Ada 83 mode
3720 -- use of external names which are string literals, even though
3721 -- technically these are not static in Ada 83.
3723 elsif Ada_Version
= Ada_83
3724 and then Nkind
(Argx
) = N_String_Literal
3728 -- Static expression that raises Constraint_Error. This has
3729 -- already been flagged, so just exit from pragma processing.
3731 elsif Is_OK_Static_Expression
(Argx
) then
3734 -- Here we have a real error (non-static expression)
3737 Error_Msg_Name_1
:= Pname
;
3740 Msg
: constant String :=
3741 "argument for pragma% must be a identifier or "
3742 & "static string expression!";
3744 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
3749 end Check_Arg_Is_External_Name
;
3751 -----------------------------
3752 -- Check_Arg_Is_Identifier --
3753 -----------------------------
3755 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
3756 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3758 if Nkind
(Argx
) /= N_Identifier
then
3760 ("argument for pragma% must be identifier", Argx
);
3762 end Check_Arg_Is_Identifier
;
3764 ----------------------------------
3765 -- Check_Arg_Is_Integer_Literal --
3766 ----------------------------------
3768 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
3769 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3771 if Nkind
(Argx
) /= N_Integer_Literal
then
3773 ("argument for pragma% must be integer literal", Argx
);
3775 end Check_Arg_Is_Integer_Literal
;
3777 -------------------------------------------
3778 -- Check_Arg_Is_Library_Level_Local_Name --
3779 -------------------------------------------
3783 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3784 -- | library_unit_NAME
3786 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
3788 Check_Arg_Is_Local_Name
(Arg
);
3790 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
3791 and then Comes_From_Source
(N
)
3794 ("argument for pragma% must be library level entity", Arg
);
3796 end Check_Arg_Is_Library_Level_Local_Name
;
3798 -----------------------------
3799 -- Check_Arg_Is_Local_Name --
3800 -----------------------------
3804 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
3805 -- | library_unit_NAME
3807 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
3808 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3813 if Nkind
(Argx
) not in N_Direct_Name
3814 and then (Nkind
(Argx
) /= N_Attribute_Reference
3815 or else Present
(Expressions
(Argx
))
3816 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
3817 and then (not Is_Entity_Name
(Argx
)
3818 or else not Is_Compilation_Unit
(Entity
(Argx
)))
3820 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
3823 -- No further check required if not an entity name
3825 if not Is_Entity_Name
(Argx
) then
3831 Ent
: constant Entity_Id
:= Entity
(Argx
);
3832 Scop
: constant Entity_Id
:= Scope
(Ent
);
3835 -- Case of a pragma applied to a compilation unit: pragma must
3836 -- occur immediately after the program unit in the compilation.
3838 if Is_Compilation_Unit
(Ent
) then
3840 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
3843 -- Case of pragma placed immediately after spec
3845 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
3848 -- Case of pragma placed immediately after body
3850 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3851 and then Present
(Corresponding_Body
(Decl
))
3855 (Parent
(Unit_Declaration_Node
3856 (Corresponding_Body
(Decl
))));
3858 -- All other cases are illegal
3865 -- Special restricted placement rule from 10.2.1(11.8/2)
3867 elsif Is_Generic_Formal
(Ent
)
3868 and then Prag_Id
= Pragma_Preelaborable_Initialization
3870 OK
:= List_Containing
(N
) =
3871 Generic_Formal_Declarations
3872 (Unit_Declaration_Node
(Scop
));
3874 -- If this is an aspect applied to a subprogram body, the
3875 -- pragma is inserted in its declarative part.
3877 elsif From_Aspect_Specification
(N
)
3878 and then Ent
= Current_Scope
3880 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
3884 -- If the aspect is a predicate (possibly others ???) and the
3885 -- context is a record type, this is a discriminant expression
3886 -- within a type declaration, that freezes the predicated
3889 elsif From_Aspect_Specification
(N
)
3890 and then Prag_Id
= Pragma_Predicate
3891 and then Ekind
(Current_Scope
) = E_Record_Type
3892 and then Scop
= Scope
(Current_Scope
)
3896 -- Default case, just check that the pragma occurs in the scope
3897 -- of the entity denoted by the name.
3900 OK
:= Current_Scope
= Scop
;
3905 ("pragma% argument must be in same declarative part", Arg
);
3909 end Check_Arg_Is_Local_Name
;
3911 ---------------------------------
3912 -- Check_Arg_Is_Locking_Policy --
3913 ---------------------------------
3915 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
3916 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3919 Check_Arg_Is_Identifier
(Argx
);
3921 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
3922 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
3924 end Check_Arg_Is_Locking_Policy
;
3926 -----------------------------------------------
3927 -- Check_Arg_Is_Partition_Elaboration_Policy --
3928 -----------------------------------------------
3930 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
3931 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3934 Check_Arg_Is_Identifier
(Argx
);
3936 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
3938 ("& is not a valid partition elaboration policy name", Argx
);
3940 end Check_Arg_Is_Partition_Elaboration_Policy
;
3942 -------------------------
3943 -- Check_Arg_Is_One_Of --
3944 -------------------------
3946 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
3947 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3950 Check_Arg_Is_Identifier
(Argx
);
3952 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
3953 Error_Msg_Name_2
:= N1
;
3954 Error_Msg_Name_3
:= N2
;
3955 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
3957 end Check_Arg_Is_One_Of
;
3959 procedure Check_Arg_Is_One_Of
3961 N1
, N2
, N3
: Name_Id
)
3963 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3966 Check_Arg_Is_Identifier
(Argx
);
3968 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
3969 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3971 end Check_Arg_Is_One_Of
;
3973 procedure Check_Arg_Is_One_Of
3975 N1
, N2
, N3
, N4
: Name_Id
)
3977 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3980 Check_Arg_Is_Identifier
(Argx
);
3982 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
3983 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3985 end Check_Arg_Is_One_Of
;
3987 procedure Check_Arg_Is_One_Of
3989 N1
, N2
, N3
, N4
, N5
: Name_Id
)
3991 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3994 Check_Arg_Is_Identifier
(Argx
);
3996 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
3997 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
3999 end Check_Arg_Is_One_Of
;
4001 ---------------------------------
4002 -- Check_Arg_Is_Queuing_Policy --
4003 ---------------------------------
4005 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
4006 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4009 Check_Arg_Is_Identifier
(Argx
);
4011 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
4012 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
4014 end Check_Arg_Is_Queuing_Policy
;
4016 ---------------------------------------
4017 -- Check_Arg_Is_OK_Static_Expression --
4018 ---------------------------------------
4020 procedure Check_Arg_Is_OK_Static_Expression
4022 Typ
: Entity_Id
:= Empty
)
4025 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
4026 end Check_Arg_Is_OK_Static_Expression
;
4028 ------------------------------------------
4029 -- Check_Arg_Is_Task_Dispatching_Policy --
4030 ------------------------------------------
4032 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
4033 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4036 Check_Arg_Is_Identifier
(Argx
);
4038 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
4040 ("& is not an allowed task dispatching policy name", Argx
);
4042 end Check_Arg_Is_Task_Dispatching_Policy
;
4044 ---------------------
4045 -- Check_Arg_Order --
4046 ---------------------
4048 procedure Check_Arg_Order
(Names
: Name_List
) is
4051 Highest_So_Far
: Natural := 0;
4052 -- Highest index in Names seen do far
4056 for J
in 1 .. Arg_Count
loop
4057 if Chars
(Arg
) /= No_Name
then
4058 for K
in Names
'Range loop
4059 if Chars
(Arg
) = Names
(K
) then
4060 if K
< Highest_So_Far
then
4061 Error_Msg_Name_1
:= Pname
;
4063 ("parameters out of order for pragma%", Arg
);
4064 Error_Msg_Name_1
:= Names
(K
);
4065 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
4066 Error_Msg_N
("\% must appear before %", Arg
);
4070 Highest_So_Far
:= K
;
4078 end Check_Arg_Order
;
4080 --------------------------------
4081 -- Check_At_Least_N_Arguments --
4082 --------------------------------
4084 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
4086 if Arg_Count
< N
then
4087 Error_Pragma
("too few arguments for pragma%");
4089 end Check_At_Least_N_Arguments
;
4091 -------------------------------
4092 -- Check_At_Most_N_Arguments --
4093 -------------------------------
4095 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
4098 if Arg_Count
> N
then
4100 for J
in 1 .. N
loop
4102 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
4105 end Check_At_Most_N_Arguments
;
4107 ---------------------
4108 -- Check_Component --
4109 ---------------------
4111 procedure Check_Component
4114 In_Variant_Part
: Boolean := False)
4116 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
4117 Sindic
: constant Node_Id
:=
4118 Subtype_Indication
(Component_Definition
(Comp
));
4119 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
4122 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4123 -- object constraint, then the component type shall be an Unchecked_
4126 if Nkind
(Sindic
) = N_Subtype_Indication
4127 and then Has_Per_Object_Constraint
(Comp_Id
)
4128 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4131 ("component subtype subject to per-object constraint "
4132 & "must be an Unchecked_Union", Comp
);
4134 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4135 -- the body of a generic unit, or within the body of any of its
4136 -- descendant library units, no part of the type of a component
4137 -- declared in a variant_part of the unchecked union type shall be of
4138 -- a formal private type or formal private extension declared within
4139 -- the formal part of the generic unit.
4141 elsif Ada_Version
>= Ada_2012
4142 and then In_Generic_Body
(UU_Typ
)
4143 and then In_Variant_Part
4144 and then Is_Private_Type
(Typ
)
4145 and then Is_Generic_Type
(Typ
)
4148 ("component of unchecked union cannot be of generic type", Comp
);
4150 elsif Needs_Finalization
(Typ
) then
4152 ("component of unchecked union cannot be controlled", Comp
);
4154 elsif Has_Task
(Typ
) then
4156 ("component of unchecked union cannot have tasks", Comp
);
4158 end Check_Component
;
4160 -----------------------------
4161 -- Check_Declaration_Order --
4162 -----------------------------
4164 procedure Check_Declaration_Order
(First
: Node_Id
; Second
: Node_Id
) is
4165 procedure Check_Aspect_Specification_Order
;
4166 -- Inspect the aspect specifications of the context to determine the
4169 --------------------------------------
4170 -- Check_Aspect_Specification_Order --
4171 --------------------------------------
4173 procedure Check_Aspect_Specification_Order
is
4174 Asp_First
: constant Node_Id
:= Corresponding_Aspect
(First
);
4175 Asp_Second
: constant Node_Id
:= Corresponding_Aspect
(Second
);
4179 -- Both aspects must be part of the same aspect specification list
4182 (List_Containing
(Asp_First
) = List_Containing
(Asp_Second
));
4184 -- Try to reach Second starting from First in a left to right
4185 -- traversal of the aspect specifications.
4187 Asp
:= Next
(Asp_First
);
4188 while Present
(Asp
) loop
4190 -- The order is ok, First is followed by Second
4192 if Asp
= Asp_Second
then
4199 -- If we get here, then the aspects are out of order
4201 SPARK_Msg_N
("aspect % cannot come after aspect %", First
);
4202 end Check_Aspect_Specification_Order
;
4208 -- Start of processing for Check_Declaration_Order
4211 -- Cannot check the order if one of the pragmas is missing
4213 if No
(First
) or else No
(Second
) then
4217 -- Set up the error names in case the order is incorrect
4219 Error_Msg_Name_1
:= Pragma_Name
(First
);
4220 Error_Msg_Name_2
:= Pragma_Name
(Second
);
4222 if From_Aspect_Specification
(First
) then
4224 -- Both pragmas are actually aspects, check their declaration
4225 -- order in the associated aspect specification list. Otherwise
4226 -- First is an aspect and Second a source pragma.
4228 if From_Aspect_Specification
(Second
) then
4229 Check_Aspect_Specification_Order
;
4232 -- Abstract_States is a source pragma
4235 if From_Aspect_Specification
(Second
) then
4236 SPARK_Msg_N
("pragma % cannot come after aspect %", First
);
4238 -- Both pragmas are source constructs. Try to reach First from
4239 -- Second by traversing the declarations backwards.
4242 Stmt
:= Prev
(Second
);
4243 while Present
(Stmt
) loop
4245 -- The order is ok, First is followed by Second
4247 if Stmt
= First
then
4254 -- If we get here, then the pragmas are out of order
4256 SPARK_Msg_N
("pragma % cannot come after pragma %", First
);
4259 end Check_Declaration_Order
;
4261 ----------------------------
4262 -- Check_Duplicate_Pragma --
4263 ----------------------------
4265 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4266 Id
: Entity_Id
:= E
;
4270 -- Nothing to do if this pragma comes from an aspect specification,
4271 -- since we could not be duplicating a pragma, and we dealt with the
4272 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4274 if From_Aspect_Specification
(N
) then
4278 -- Otherwise current pragma may duplicate previous pragma or a
4279 -- previously given aspect specification or attribute definition
4280 -- clause for the same pragma.
4282 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4286 -- If the entity is a type, then we have to make sure that the
4287 -- ostensible duplicate is not for a parent type from which this
4291 if Nkind
(P
) = N_Pragma
then
4293 Args
: constant List_Id
:=
4294 Pragma_Argument_Associations
(P
);
4297 and then Is_Entity_Name
(Expression
(First
(Args
)))
4298 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4299 and then Entity
(Expression
(First
(Args
))) /= E
4305 elsif Nkind
(P
) = N_Aspect_Specification
4306 and then Is_Type
(Entity
(P
))
4307 and then Entity
(P
) /= E
4313 -- Here we have a definite duplicate
4315 Error_Msg_Name_1
:= Pragma_Name
(N
);
4316 Error_Msg_Sloc
:= Sloc
(P
);
4318 -- For a single protected or a single task object, the error is
4319 -- issued on the original entity.
4321 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4322 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
4325 if Nkind
(P
) = N_Aspect_Specification
4326 or else From_Aspect_Specification
(P
)
4328 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
4330 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
4335 end Check_Duplicate_Pragma
;
4337 ----------------------------------
4338 -- Check_Duplicated_Export_Name --
4339 ----------------------------------
4341 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
4342 String_Val
: constant String_Id
:= Strval
(Nam
);
4345 -- We are only interested in the export case, and in the case of
4346 -- generics, it is the instance, not the template, that is the
4347 -- problem (the template will generate a warning in any case).
4349 if not Inside_A_Generic
4350 and then (Prag_Id
= Pragma_Export
4352 Prag_Id
= Pragma_Export_Procedure
4354 Prag_Id
= Pragma_Export_Valued_Procedure
4356 Prag_Id
= Pragma_Export_Function
)
4358 for J
in Externals
.First
.. Externals
.Last
loop
4359 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
4360 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
4361 Error_Msg_N
("external name duplicates name given#", Nam
);
4366 Externals
.Append
(Nam
);
4368 end Check_Duplicated_Export_Name
;
4370 ----------------------------------------
4371 -- Check_Expr_Is_OK_Static_Expression --
4372 ----------------------------------------
4374 procedure Check_Expr_Is_OK_Static_Expression
4376 Typ
: Entity_Id
:= Empty
)
4379 if Present
(Typ
) then
4380 Analyze_And_Resolve
(Expr
, Typ
);
4382 Analyze_And_Resolve
(Expr
);
4385 if Is_OK_Static_Expression
(Expr
) then
4388 elsif Etype
(Expr
) = Any_Type
then
4391 -- An interesting special case, if we have a string literal and we
4392 -- are in Ada 83 mode, then we allow it even though it will not be
4393 -- flagged as static. This allows the use of Ada 95 pragmas like
4394 -- Import in Ada 83 mode. They will of course be flagged with
4395 -- warnings as usual, but will not cause errors.
4397 elsif Ada_Version
= Ada_83
4398 and then Nkind
(Expr
) = N_String_Literal
4402 -- Static expression that raises Constraint_Error. This has already
4403 -- been flagged, so just exit from pragma processing.
4405 elsif Is_OK_Static_Expression
(Expr
) then
4408 -- Finally, we have a real error
4411 Error_Msg_Name_1
:= Pname
;
4412 Flag_Non_Static_Expr
4413 (Fix_Error
("argument for pragma% must be a static expression!"),
4417 end Check_Expr_Is_OK_Static_Expression
;
4419 -------------------------
4420 -- Check_First_Subtype --
4421 -------------------------
4423 procedure Check_First_Subtype
(Arg
: Node_Id
) is
4424 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4425 Ent
: constant Entity_Id
:= Entity
(Argx
);
4428 if Is_First_Subtype
(Ent
) then
4431 elsif Is_Type
(Ent
) then
4433 ("pragma% cannot apply to subtype", Argx
);
4435 elsif Is_Object
(Ent
) then
4437 ("pragma% cannot apply to object, requires a type", Argx
);
4441 ("pragma% cannot apply to&, requires a type", Argx
);
4443 end Check_First_Subtype
;
4445 ----------------------
4446 -- Check_Identifier --
4447 ----------------------
4449 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4452 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4454 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
4455 Error_Msg_Name_1
:= Pname
;
4456 Error_Msg_Name_2
:= Id
;
4457 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4461 end Check_Identifier
;
4463 --------------------------------
4464 -- Check_Identifier_Is_One_Of --
4465 --------------------------------
4467 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4470 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4472 if Chars
(Arg
) = No_Name
then
4473 Error_Msg_Name_1
:= Pname
;
4474 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
4477 elsif Chars
(Arg
) /= N1
4478 and then Chars
(Arg
) /= N2
4480 Error_Msg_Name_1
:= Pname
;
4481 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
4485 end Check_Identifier_Is_One_Of
;
4487 ---------------------------
4488 -- Check_In_Main_Program --
4489 ---------------------------
4491 procedure Check_In_Main_Program
is
4492 P
: constant Node_Id
:= Parent
(N
);
4495 -- Must be at in subprogram body
4497 if Nkind
(P
) /= N_Subprogram_Body
then
4498 Error_Pragma
("% pragma allowed only in subprogram");
4500 -- Otherwise warn if obviously not main program
4502 elsif Present
(Parameter_Specifications
(Specification
(P
)))
4503 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
4505 Error_Msg_Name_1
:= Pname
;
4507 ("??pragma% is only effective in main program", N
);
4509 end Check_In_Main_Program
;
4511 ---------------------------------------
4512 -- Check_Interrupt_Or_Attach_Handler --
4513 ---------------------------------------
4515 procedure Check_Interrupt_Or_Attach_Handler
is
4516 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4517 Handler_Proc
, Proc_Scope
: Entity_Id
;
4522 if Prag_Id
= Pragma_Interrupt_Handler
then
4523 Check_Restriction
(No_Dynamic_Attachment
, N
);
4526 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
4527 Proc_Scope
:= Scope
(Handler_Proc
);
4529 -- On AAMP only, a pragma Interrupt_Handler is supported for
4530 -- nonprotected parameterless procedures.
4532 if not AAMP_On_Target
4533 or else Prag_Id
= Pragma_Attach_Handler
4535 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
4537 ("argument of pragma% must be protected procedure", Arg1
);
4540 -- For pragma case (as opposed to access case), check placement.
4541 -- We don't need to do that for aspects, because we have the
4542 -- check that they aspect applies an appropriate procedure.
4544 if not From_Aspect_Specification
(N
)
4545 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
4547 Error_Pragma
("pragma% must be in protected definition");
4551 if not Is_Library_Level_Entity
(Proc_Scope
)
4552 or else (AAMP_On_Target
4553 and then not Is_Library_Level_Entity
(Handler_Proc
))
4556 ("argument for pragma% must be library level entity", Arg1
);
4559 -- AI05-0033: A pragma cannot appear within a generic body, because
4560 -- instance can be in a nested scope. The check that protected type
4561 -- is itself a library-level declaration is done elsewhere.
4563 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
4564 -- handle code prior to AI-0033. Analysis tools typically are not
4565 -- interested in this pragma in any case, so no need to worry too
4566 -- much about its placement.
4568 if Inside_A_Generic
then
4569 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
4570 and then In_Package_Body
(Scope
(Current_Scope
))
4571 and then not Relaxed_RM_Semantics
4573 Error_Pragma
("pragma% cannot be used inside a generic");
4576 end Check_Interrupt_Or_Attach_Handler
;
4578 ---------------------------------
4579 -- Check_Loop_Pragma_Placement --
4580 ---------------------------------
4582 procedure Check_Loop_Pragma_Placement
is
4583 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
4584 -- Verify whether the current pragma is properly grouped with other
4585 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
4586 -- related loop where the pragma appears.
4588 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
4589 -- Determine whether an arbitrary statement Stmt denotes pragma
4590 -- Loop_Invariant or Loop_Variant.
4592 procedure Placement_Error
(Constr
: Node_Id
);
4593 pragma No_Return
(Placement_Error
);
4594 -- Node Constr denotes the last loop restricted construct before we
4595 -- encountered an illegal relation between enclosing constructs. Emit
4596 -- an error depending on what Constr was.
4598 --------------------------------
4599 -- Check_Loop_Pragma_Grouping --
4600 --------------------------------
4602 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
4603 Stop_Search
: exception;
4604 -- This exception is used to terminate the recursive descent of
4605 -- routine Check_Grouping.
4607 procedure Check_Grouping
(L
: List_Id
);
4608 -- Find the first group of pragmas in list L and if successful,
4609 -- ensure that the current pragma is part of that group. The
4610 -- routine raises Stop_Search once such a check is performed to
4611 -- halt the recursive descent.
4613 procedure Grouping_Error
(Prag
: Node_Id
);
4614 pragma No_Return
(Grouping_Error
);
4615 -- Emit an error concerning the current pragma indicating that it
4616 -- should be placed after pragma Prag.
4618 --------------------
4619 -- Check_Grouping --
4620 --------------------
4622 procedure Check_Grouping
(L
: List_Id
) is
4628 -- Inspect the list of declarations or statements looking for
4629 -- the first grouping of pragmas:
4632 -- pragma Loop_Invariant ...;
4633 -- pragma Loop_Variant ...;
4635 -- pragma Loop_Variant ...; -- current pragma
4637 -- If the current pragma is not in the grouping, then it must
4638 -- either appear in a different declarative or statement list
4639 -- or the construct at (1) is separating the pragma from the
4643 while Present
(Stmt
) loop
4645 -- Pragmas Loop_Invariant and Loop_Variant may only appear
4646 -- inside a loop or a block housed inside a loop. Inspect
4647 -- the declarations and statements of the block as they may
4648 -- contain the first grouping.
4650 if Nkind
(Stmt
) = N_Block_Statement
then
4651 HSS
:= Handled_Statement_Sequence
(Stmt
);
4653 Check_Grouping
(Declarations
(Stmt
));
4655 if Present
(HSS
) then
4656 Check_Grouping
(Statements
(HSS
));
4659 -- First pragma of the first topmost grouping has been found
4661 elsif Is_Loop_Pragma
(Stmt
) then
4663 -- The group and the current pragma are not in the same
4664 -- declarative or statement list.
4666 if List_Containing
(Stmt
) /= List_Containing
(N
) then
4667 Grouping_Error
(Stmt
);
4669 -- Try to reach the current pragma from the first pragma
4670 -- of the grouping while skipping other members:
4672 -- pragma Loop_Invariant ...; -- first pragma
4673 -- pragma Loop_Variant ...; -- member
4675 -- pragma Loop_Variant ...; -- current pragma
4678 while Present
(Stmt
) loop
4680 -- The current pragma is either the first pragma
4681 -- of the group or is a member of the group. Stop
4682 -- the search as the placement is legal.
4687 -- Skip group members, but keep track of the last
4688 -- pragma in the group.
4690 elsif Is_Loop_Pragma
(Stmt
) then
4693 -- A non-pragma is separating the group from the
4694 -- current pragma, the placement is illegal.
4697 Grouping_Error
(Prag
);
4703 -- If the traversal did not reach the current pragma,
4704 -- then the list must be malformed.
4706 raise Program_Error
;
4714 --------------------
4715 -- Grouping_Error --
4716 --------------------
4718 procedure Grouping_Error
(Prag
: Node_Id
) is
4720 Error_Msg_Sloc
:= Sloc
(Prag
);
4721 Error_Pragma
("pragma% must appear next to pragma#");
4724 -- Start of processing for Check_Loop_Pragma_Grouping
4727 -- Inspect the statements of the loop or nested blocks housed
4728 -- within to determine whether the current pragma is part of the
4729 -- first topmost grouping of Loop_Invariant and Loop_Variant.
4731 Check_Grouping
(Statements
(Loop_Stmt
));
4734 when Stop_Search
=> null;
4735 end Check_Loop_Pragma_Grouping
;
4737 --------------------
4738 -- Is_Loop_Pragma --
4739 --------------------
4741 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
4743 -- Inspect the original node as Loop_Invariant and Loop_Variant
4744 -- pragmas are rewritten to null when assertions are disabled.
4746 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
4748 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
4749 Name_Loop_Invariant
,
4756 ---------------------
4757 -- Placement_Error --
4758 ---------------------
4760 procedure Placement_Error
(Constr
: Node_Id
) is
4761 LA
: constant String := " with Loop_Entry";
4764 if Prag_Id
= Pragma_Assert
then
4765 Error_Msg_String
(1 .. LA
'Length) := LA
;
4766 Error_Msg_Strlen
:= LA
'Length;
4768 Error_Msg_Strlen
:= 0;
4771 if Nkind
(Constr
) = N_Pragma
then
4773 ("pragma %~ must appear immediately within the statements "
4777 ("block containing pragma %~ must appear immediately within "
4778 & "the statements of a loop", Constr
);
4780 end Placement_Error
;
4782 -- Local declarations
4787 -- Start of processing for Check_Loop_Pragma_Placement
4790 -- Check that pragma appears immediately within a loop statement,
4791 -- ignoring intervening block statements.
4795 while Present
(Stmt
) loop
4797 -- The pragma or previous block must appear immediately within the
4798 -- current block's declarative or statement part.
4800 if Nkind
(Stmt
) = N_Block_Statement
then
4801 if (No
(Declarations
(Stmt
))
4802 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
4804 List_Containing
(Prev
) /=
4805 Statements
(Handled_Statement_Sequence
(Stmt
))
4807 Placement_Error
(Prev
);
4810 -- Keep inspecting the parents because we are now within a
4811 -- chain of nested blocks.
4815 Stmt
:= Parent
(Stmt
);
4818 -- The pragma or previous block must appear immediately within the
4819 -- statements of the loop.
4821 elsif Nkind
(Stmt
) = N_Loop_Statement
then
4822 if List_Containing
(Prev
) /= Statements
(Stmt
) then
4823 Placement_Error
(Prev
);
4826 -- Stop the traversal because we reached the innermost loop
4827 -- regardless of whether we encountered an error or not.
4831 -- Ignore a handled statement sequence. Note that this node may
4832 -- be related to a subprogram body in which case we will emit an
4833 -- error on the next iteration of the search.
4835 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
4836 Stmt
:= Parent
(Stmt
);
4838 -- Any other statement breaks the chain from the pragma to the
4842 Placement_Error
(Prev
);
4847 -- Check that the current pragma Loop_Invariant or Loop_Variant is
4848 -- grouped together with other such pragmas.
4850 if Is_Loop_Pragma
(N
) then
4852 -- The previous check should have located the related loop
4854 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
4855 Check_Loop_Pragma_Grouping
(Stmt
);
4857 end Check_Loop_Pragma_Placement
;
4859 -------------------------------------------
4860 -- Check_Is_In_Decl_Part_Or_Package_Spec --
4861 -------------------------------------------
4863 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
4872 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4875 elsif Nkind_In
(P
, N_Package_Specification
,
4880 -- Note: the following tests seem a little peculiar, because
4881 -- they test for bodies, but if we were in the statement part
4882 -- of the body, we would already have hit the handled statement
4883 -- sequence, so the only way we get here is by being in the
4884 -- declarative part of the body.
4886 elsif Nkind_In
(P
, N_Subprogram_Body
,
4897 Error_Pragma
("pragma% is not in declarative part or package spec");
4898 end Check_Is_In_Decl_Part_Or_Package_Spec
;
4900 -------------------------
4901 -- Check_No_Identifier --
4902 -------------------------
4904 procedure Check_No_Identifier
(Arg
: Node_Id
) is
4906 if Nkind
(Arg
) = N_Pragma_Argument_Association
4907 and then Chars
(Arg
) /= No_Name
4909 Error_Pragma_Arg_Ident
4910 ("pragma% does not permit identifier& here", Arg
);
4912 end Check_No_Identifier
;
4914 --------------------------
4915 -- Check_No_Identifiers --
4916 --------------------------
4918 procedure Check_No_Identifiers
is
4922 for J
in 1 .. Arg_Count
loop
4923 Check_No_Identifier
(Arg_Node
);
4926 end Check_No_Identifiers
;
4928 ------------------------
4929 -- Check_No_Link_Name --
4930 ------------------------
4932 procedure Check_No_Link_Name
is
4934 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
4938 if Present
(Arg4
) then
4940 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
4942 end Check_No_Link_Name
;
4944 -------------------------------
4945 -- Check_Optional_Identifier --
4946 -------------------------------
4948 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
4951 and then Nkind
(Arg
) = N_Pragma_Argument_Association
4952 and then Chars
(Arg
) /= No_Name
4954 if Chars
(Arg
) /= Id
then
4955 Error_Msg_Name_1
:= Pname
;
4956 Error_Msg_Name_2
:= Id
;
4957 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
4961 end Check_Optional_Identifier
;
4963 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
4965 Name_Buffer
(1 .. Id
'Length) := Id
;
4966 Name_Len
:= Id
'Length;
4967 Check_Optional_Identifier
(Arg
, Name_Find
);
4968 end Check_Optional_Identifier
;
4970 -----------------------------
4971 -- Check_Static_Constraint --
4972 -----------------------------
4974 -- Note: for convenience in writing this procedure, in addition to
4975 -- the officially (i.e. by spec) allowed argument which is always a
4976 -- constraint, it also allows ranges and discriminant associations.
4977 -- Above is not clear ???
4979 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
4981 procedure Require_Static
(E
: Node_Id
);
4982 -- Require given expression to be static expression
4984 --------------------
4985 -- Require_Static --
4986 --------------------
4988 procedure Require_Static
(E
: Node_Id
) is
4990 if not Is_OK_Static_Expression
(E
) then
4991 Flag_Non_Static_Expr
4992 ("non-static constraint not allowed in Unchecked_Union!", E
);
4997 -- Start of processing for Check_Static_Constraint
5000 case Nkind
(Constr
) is
5001 when N_Discriminant_Association
=>
5002 Require_Static
(Expression
(Constr
));
5005 Require_Static
(Low_Bound
(Constr
));
5006 Require_Static
(High_Bound
(Constr
));
5008 when N_Attribute_Reference
=>
5009 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5010 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5012 when N_Range_Constraint
=>
5013 Check_Static_Constraint
(Range_Expression
(Constr
));
5015 when N_Index_Or_Discriminant_Constraint
=>
5019 IDC
:= First
(Constraints
(Constr
));
5020 while Present
(IDC
) loop
5021 Check_Static_Constraint
(IDC
);
5029 end Check_Static_Constraint
;
5031 --------------------------------------
5032 -- Check_Valid_Configuration_Pragma --
5033 --------------------------------------
5035 -- A configuration pragma must appear in the context clause of a
5036 -- compilation unit, and only other pragmas may precede it. Note that
5037 -- the test also allows use in a configuration pragma file.
5039 procedure Check_Valid_Configuration_Pragma
is
5041 if not Is_Configuration_Pragma
then
5042 Error_Pragma
("incorrect placement for configuration pragma%");
5044 end Check_Valid_Configuration_Pragma
;
5046 -------------------------------------
5047 -- Check_Valid_Library_Unit_Pragma --
5048 -------------------------------------
5050 procedure Check_Valid_Library_Unit_Pragma
is
5052 Parent_Node
: Node_Id
;
5053 Unit_Name
: Entity_Id
;
5054 Unit_Kind
: Node_Kind
;
5055 Unit_Node
: Node_Id
;
5056 Sindex
: Source_File_Index
;
5059 if not Is_List_Member
(N
) then
5063 Plist
:= List_Containing
(N
);
5064 Parent_Node
:= Parent
(Plist
);
5066 if Parent_Node
= Empty
then
5069 -- Case of pragma appearing after a compilation unit. In this case
5070 -- it must have an argument with the corresponding name and must
5071 -- be part of the following pragmas of its parent.
5073 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5074 if Plist
/= Pragmas_After
(Parent_Node
) then
5077 elsif Arg_Count
= 0 then
5079 ("argument required if outside compilation unit");
5082 Check_No_Identifiers
;
5083 Check_Arg_Count
(1);
5084 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5085 Unit_Kind
:= Nkind
(Unit_Node
);
5087 Analyze
(Get_Pragma_Arg
(Arg1
));
5089 if Unit_Kind
= N_Generic_Subprogram_Declaration
5090 or else Unit_Kind
= N_Subprogram_Declaration
5092 Unit_Name
:= Defining_Entity
(Unit_Node
);
5094 elsif Unit_Kind
in N_Generic_Instantiation
then
5095 Unit_Name
:= Defining_Entity
(Unit_Node
);
5098 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5101 if Chars
(Unit_Name
) /=
5102 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5105 ("pragma% argument is not current unit name", Arg1
);
5108 if Ekind
(Unit_Name
) = E_Package
5109 and then Present
(Renamed_Entity
(Unit_Name
))
5111 Error_Pragma
("pragma% not allowed for renamed package");
5115 -- Pragma appears other than after a compilation unit
5118 -- Here we check for the generic instantiation case and also
5119 -- for the case of processing a generic formal package. We
5120 -- detect these cases by noting that the Sloc on the node
5121 -- does not belong to the current compilation unit.
5123 Sindex
:= Source_Index
(Current_Sem_Unit
);
5125 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5126 Rewrite
(N
, Make_Null_Statement
(Loc
));
5129 -- If before first declaration, the pragma applies to the
5130 -- enclosing unit, and the name if present must be this name.
5132 elsif Is_Before_First_Decl
(N
, Plist
) then
5133 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5134 Unit_Kind
:= Nkind
(Unit_Node
);
5136 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5139 elsif Unit_Kind
= N_Subprogram_Body
5140 and then not Acts_As_Spec
(Unit_Node
)
5144 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5147 elsif Nkind
(Parent_Node
) = N_Package_Specification
5148 and then Plist
= Private_Declarations
(Parent_Node
)
5152 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5153 or else Nkind
(Parent_Node
) =
5154 N_Generic_Subprogram_Declaration
)
5155 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5159 elsif Arg_Count
> 0 then
5160 Analyze
(Get_Pragma_Arg
(Arg1
));
5162 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5164 ("name in pragma% must be enclosing unit", Arg1
);
5167 -- It is legal to have no argument in this context
5173 -- Error if not before first declaration. This is because a
5174 -- library unit pragma argument must be the name of a library
5175 -- unit (RM 10.1.5(7)), but the only names permitted in this
5176 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5177 -- generic subprogram declarations or generic instantiations.
5181 ("pragma% misplaced, must be before first declaration");
5185 end Check_Valid_Library_Unit_Pragma
;
5191 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5192 Clist
: constant Node_Id
:= Component_List
(Variant
);
5196 Comp
:= First
(Component_Items
(Clist
));
5197 while Present
(Comp
) loop
5198 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5203 -----------------------------
5204 -- Create_Generic_Template --
5205 -----------------------------
5207 procedure Create_Generic_Template
5209 Subp_Id
: Entity_Id
)
5212 if Comes_From_Source
(Prag
)
5213 and then Is_Generic_Subprogram
(Subp_Id
)
5216 (Prag
, Copy_Generic_Node
(Prag
, Empty
, Instantiating
=> False));
5218 end Create_Generic_Template
;
5220 ---------------------------
5221 -- Ensure_Aggregate_Form --
5222 ---------------------------
5224 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5225 Expr
: constant Node_Id
:= Expression
(Arg
);
5226 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
5227 Comps
: List_Id
:= No_List
;
5228 Exprs
: List_Id
:= No_List
;
5231 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
5232 -- Used to restore Comes_From_Source_Default
5235 if Nkind
(Arg
) = N_Aspect_Specification
then
5238 pragma Assert
(Nkind
(Arg
) = N_Pragma_Argument_Association
);
5242 -- The argument is already in aggregate form, but the presence of a
5243 -- name causes this to be interpreted as named association which in
5244 -- turn must be converted into an aggregate.
5246 -- pragma Global (In_Out => (A, B, C))
5250 -- pragma Global ((In_Out => (A, B, C)))
5252 -- aggregate aggregate
5254 if Nkind
(Expr
) = N_Aggregate
then
5255 if Nam
= No_Name
then
5259 -- Do not transform a null argument into an aggregate as N_Null has
5260 -- special meaning in formal verification pragmas.
5262 elsif Nkind
(Expr
) = N_Null
then
5266 -- Everything comes from source if the original comes from source
5268 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
5270 -- Positional argument is transformed into an aggregate with an
5271 -- Expressions list.
5273 if Nam
= No_Name
then
5274 Exprs
:= New_List
(Relocate_Node
(Expr
));
5276 -- An associative argument is transformed into an aggregate with
5277 -- Component_Associations.
5281 Make_Component_Association
(Loc
,
5282 Choices
=> New_List
(Make_Identifier
(Loc
, Chars
(Arg
))),
5283 Expression
=> Relocate_Node
(Expr
)));
5286 -- Remove the pragma argument name as this information has been
5287 -- captured in the aggregate.
5289 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5290 Set_Chars
(Arg
, No_Name
);
5293 Set_Expression
(Arg
,
5294 Make_Aggregate
(Loc
,
5295 Component_Associations
=> Comps
,
5296 Expressions
=> Exprs
));
5298 -- Restore Comes_From_Source default
5300 Set_Comes_From_Source_Default
(CFSD
);
5301 end Ensure_Aggregate_Form
;
5307 procedure Error_Pragma
(Msg
: String) is
5309 Error_Msg_Name_1
:= Pname
;
5310 Error_Msg_N
(Fix_Error
(Msg
), N
);
5314 ----------------------
5315 -- Error_Pragma_Arg --
5316 ----------------------
5318 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
5320 Error_Msg_Name_1
:= Pname
;
5321 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
5323 end Error_Pragma_Arg
;
5325 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
5327 Error_Msg_Name_1
:= Pname
;
5328 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
5329 Error_Pragma_Arg
(Msg2
, Arg
);
5330 end Error_Pragma_Arg
;
5332 ----------------------------
5333 -- Error_Pragma_Arg_Ident --
5334 ----------------------------
5336 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
5338 Error_Msg_Name_1
:= Pname
;
5339 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
5341 end Error_Pragma_Arg_Ident
;
5343 ----------------------
5344 -- Error_Pragma_Ref --
5345 ----------------------
5347 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
5349 Error_Msg_Name_1
:= Pname
;
5350 Error_Msg_Sloc
:= Sloc
(Ref
);
5351 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
5353 end Error_Pragma_Ref
;
5355 ------------------------
5356 -- Find_Lib_Unit_Name --
5357 ------------------------
5359 function Find_Lib_Unit_Name
return Entity_Id
is
5361 -- Return inner compilation unit entity, for case of nested
5362 -- categorization pragmas. This happens in generic unit.
5364 if Nkind
(Parent
(N
)) = N_Package_Specification
5365 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
5367 return Defining_Entity
(Parent
(N
));
5369 return Current_Scope
;
5371 end Find_Lib_Unit_Name
;
5373 ----------------------------
5374 -- Find_Program_Unit_Name --
5375 ----------------------------
5377 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
5378 Unit_Name
: Entity_Id
;
5379 Unit_Kind
: Node_Kind
;
5380 P
: constant Node_Id
:= Parent
(N
);
5383 if Nkind
(P
) = N_Compilation_Unit
then
5384 Unit_Kind
:= Nkind
(Unit
(P
));
5386 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
5387 N_Package_Declaration
)
5388 or else Unit_Kind
in N_Generic_Declaration
5390 Unit_Name
:= Defining_Entity
(Unit
(P
));
5392 if Chars
(Id
) = Chars
(Unit_Name
) then
5393 Set_Entity
(Id
, Unit_Name
);
5394 Set_Etype
(Id
, Etype
(Unit_Name
));
5396 Set_Etype
(Id
, Any_Type
);
5398 ("cannot find program unit referenced by pragma%");
5402 Set_Etype
(Id
, Any_Type
);
5403 Error_Pragma
("pragma% inapplicable to this unit");
5409 end Find_Program_Unit_Name
;
5411 -----------------------------------------
5412 -- Find_Unique_Parameterless_Procedure --
5413 -----------------------------------------
5415 function Find_Unique_Parameterless_Procedure
5417 Arg
: Node_Id
) return Entity_Id
5419 Proc
: Entity_Id
:= Empty
;
5422 -- The body of this procedure needs some comments ???
5424 if not Is_Entity_Name
(Name
) then
5426 ("argument of pragma% must be entity name", Arg
);
5428 elsif not Is_Overloaded
(Name
) then
5429 Proc
:= Entity
(Name
);
5431 if Ekind
(Proc
) /= E_Procedure
5432 or else Present
(First_Formal
(Proc
))
5435 ("argument of pragma% must be parameterless procedure", Arg
);
5440 Found
: Boolean := False;
5442 Index
: Interp_Index
;
5445 Get_First_Interp
(Name
, Index
, It
);
5446 while Present
(It
.Nam
) loop
5449 if Ekind
(Proc
) = E_Procedure
5450 and then No
(First_Formal
(Proc
))
5454 Set_Entity
(Name
, Proc
);
5455 Set_Is_Overloaded
(Name
, False);
5458 ("ambiguous handler name for pragma% ", Arg
);
5462 Get_Next_Interp
(Index
, It
);
5467 ("argument of pragma% must be parameterless procedure",
5470 Proc
:= Entity
(Name
);
5476 end Find_Unique_Parameterless_Procedure
;
5482 function Fix_Error
(Msg
: String) return String is
5483 Res
: String (Msg
'Range) := Msg
;
5484 Res_Last
: Natural := Msg
'Last;
5488 -- If we have a rewriting of another pragma, go to that pragma
5490 if Is_Rewrite_Substitution
(N
)
5491 and then Nkind
(Original_Node
(N
)) = N_Pragma
5493 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
5496 -- Case where pragma comes from an aspect specification
5498 if From_Aspect_Specification
(N
) then
5500 -- Change appearence of "pragma" in message to "aspect"
5503 while J
<= Res_Last
- 5 loop
5504 if Res
(J
.. J
+ 5) = "pragma" then
5505 Res
(J
.. J
+ 5) := "aspect";
5513 -- Change "argument of" at start of message to "entity for"
5516 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
5518 Res
(Res
'First .. Res
'First + 9) := "entity for";
5519 Res
(Res
'First + 10 .. Res_Last
- 1) :=
5520 Res
(Res
'First + 11 .. Res_Last
);
5521 Res_Last
:= Res_Last
- 1;
5524 -- Change "argument" at start of message to "entity"
5527 and then Res
(Res
'First .. Res
'First + 7) = "argument"
5529 Res
(Res
'First .. Res
'First + 5) := "entity";
5530 Res
(Res
'First + 6 .. Res_Last
- 2) :=
5531 Res
(Res
'First + 8 .. Res_Last
);
5532 Res_Last
:= Res_Last
- 2;
5535 -- Get name from corresponding aspect
5537 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
5540 -- Return possibly modified message
5542 return Res
(Res
'First .. Res_Last
);
5545 -------------------------
5546 -- Gather_Associations --
5547 -------------------------
5549 procedure Gather_Associations
5551 Args
: out Args_List
)
5556 -- Initialize all parameters to Empty
5558 for J
in Args
'Range loop
5562 -- That's all we have to do if there are no argument associations
5564 if No
(Pragma_Argument_Associations
(N
)) then
5568 -- Otherwise first deal with any positional parameters present
5570 Arg
:= First
(Pragma_Argument_Associations
(N
));
5571 for Index
in Args
'Range loop
5572 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
5573 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5577 -- Positional parameters all processed, if any left, then we
5578 -- have too many positional parameters.
5580 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
5582 ("too many positional associations for pragma%", Arg
);
5585 -- Process named parameters if any are present
5587 while Present
(Arg
) loop
5588 if Chars
(Arg
) = No_Name
then
5590 ("positional association cannot follow named association",
5594 for Index
in Names
'Range loop
5595 if Names
(Index
) = Chars
(Arg
) then
5596 if Present
(Args
(Index
)) then
5598 ("duplicate argument association for pragma%", Arg
);
5600 Args
(Index
) := Get_Pragma_Arg
(Arg
);
5605 if Index
= Names
'Last then
5606 Error_Msg_Name_1
:= Pname
;
5607 Error_Msg_N
("pragma% does not allow & argument", Arg
);
5609 -- Check for possible misspelling
5611 for Index1
in Names
'Range loop
5612 if Is_Bad_Spelling_Of
5613 (Chars
(Arg
), Names
(Index1
))
5615 Error_Msg_Name_1
:= Names
(Index1
);
5616 Error_Msg_N
-- CODEFIX
5617 ("\possible misspelling of%", Arg
);
5629 end Gather_Associations
;
5635 procedure GNAT_Pragma
is
5637 -- We need to check the No_Implementation_Pragmas restriction for
5638 -- the case of a pragma from source. Note that the case of aspects
5639 -- generating corresponding pragmas marks these pragmas as not being
5640 -- from source, so this test also catches that case.
5642 if Comes_From_Source
(N
) then
5643 Check_Restriction
(No_Implementation_Pragmas
, N
);
5647 --------------------------
5648 -- Is_Before_First_Decl --
5649 --------------------------
5651 function Is_Before_First_Decl
5652 (Pragma_Node
: Node_Id
;
5653 Decls
: List_Id
) return Boolean
5655 Item
: Node_Id
:= First
(Decls
);
5658 -- Only other pragmas can come before this pragma
5661 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
5664 elsif Item
= Pragma_Node
then
5670 end Is_Before_First_Decl
;
5672 -----------------------------
5673 -- Is_Configuration_Pragma --
5674 -----------------------------
5676 -- A configuration pragma must appear in the context clause of a
5677 -- compilation unit, and only other pragmas may precede it. Note that
5678 -- the test below also permits use in a configuration pragma file.
5680 function Is_Configuration_Pragma
return Boolean is
5681 Lis
: constant List_Id
:= List_Containing
(N
);
5682 Par
: constant Node_Id
:= Parent
(N
);
5686 -- If no parent, then we are in the configuration pragma file,
5687 -- so the placement is definitely appropriate.
5692 -- Otherwise we must be in the context clause of a compilation unit
5693 -- and the only thing allowed before us in the context list is more
5694 -- configuration pragmas.
5696 elsif Nkind
(Par
) = N_Compilation_Unit
5697 and then Context_Items
(Par
) = Lis
5704 elsif Nkind
(Prg
) /= N_Pragma
then
5714 end Is_Configuration_Pragma
;
5716 --------------------------
5717 -- Is_In_Context_Clause --
5718 --------------------------
5720 function Is_In_Context_Clause
return Boolean is
5722 Parent_Node
: Node_Id
;
5725 if not Is_List_Member
(N
) then
5729 Plist
:= List_Containing
(N
);
5730 Parent_Node
:= Parent
(Plist
);
5732 if Parent_Node
= Empty
5733 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
5734 or else Context_Items
(Parent_Node
) /= Plist
5741 end Is_In_Context_Clause
;
5743 ---------------------------------
5744 -- Is_Static_String_Expression --
5745 ---------------------------------
5747 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
5748 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5749 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
5752 Analyze_And_Resolve
(Argx
);
5754 -- Special case Ada 83, where the expression will never be static,
5755 -- but we will return true if we had a string literal to start with.
5757 if Ada_Version
= Ada_83
then
5760 -- Normal case, true only if we end up with a string literal that
5761 -- is marked as being the result of evaluating a static expression.
5764 return Is_OK_Static_Expression
(Argx
)
5765 and then Nkind
(Argx
) = N_String_Literal
;
5768 end Is_Static_String_Expression
;
5770 ----------------------
5771 -- Pragma_Misplaced --
5772 ----------------------
5774 procedure Pragma_Misplaced
is
5776 Error_Pragma
("incorrect placement of pragma%");
5777 end Pragma_Misplaced
;
5779 ------------------------------------------------
5780 -- Process_Atomic_Independent_Shared_Volatile --
5781 ------------------------------------------------
5783 procedure Process_Atomic_Independent_Shared_Volatile
is
5790 procedure Set_Atomic
(E
: Entity_Id
);
5791 -- Set given type as atomic, and if no explicit alignment was given,
5792 -- set alignment to unknown, since back end knows what the alignment
5793 -- requirements are for atomic arrays. Note: this step is necessary
5794 -- for derived types.
5800 procedure Set_Atomic
(E
: Entity_Id
) is
5804 if not Has_Alignment_Clause
(E
) then
5805 Set_Alignment
(E
, Uint_0
);
5809 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
5812 Check_Ada_83_Warning
;
5813 Check_No_Identifiers
;
5814 Check_Arg_Count
(1);
5815 Check_Arg_Is_Local_Name
(Arg1
);
5816 E_Id
:= Get_Pragma_Arg
(Arg1
);
5818 if Etype
(E_Id
) = Any_Type
then
5823 D
:= Declaration_Node
(E
);
5826 -- Check duplicate before we chain ourselves
5828 Check_Duplicate_Pragma
(E
);
5830 -- Now check appropriateness of the entity
5833 if Rep_Item_Too_Early
(E
, N
)
5835 Rep_Item_Too_Late
(E
, N
)
5839 Check_First_Subtype
(Arg1
);
5842 if Prag_Id
= Pragma_Atomic
or else Prag_Id
= Pragma_Shared
then
5844 Set_Atomic
(Underlying_Type
(E
));
5845 Set_Atomic
(Base_Type
(E
));
5848 -- Atomic/Shared imply both Independent and Volatile
5850 if Prag_Id
/= Pragma_Volatile
then
5851 Set_Is_Independent
(E
);
5852 Set_Is_Independent
(Underlying_Type
(E
));
5853 Set_Is_Independent
(Base_Type
(E
));
5855 if Prag_Id
= Pragma_Independent
then
5856 Record_Independence_Check
(N
, Base_Type
(E
));
5860 -- Attribute belongs on the base type. If the view of the type is
5861 -- currently private, it also belongs on the underlying type.
5863 if Prag_Id
/= Pragma_Independent
then
5864 Set_Is_Volatile
(Base_Type
(E
));
5865 Set_Is_Volatile
(Underlying_Type
(E
));
5867 Set_Treat_As_Volatile
(E
);
5868 Set_Treat_As_Volatile
(Underlying_Type
(E
));
5871 elsif K
= N_Object_Declaration
5872 or else (K
= N_Component_Declaration
5873 and then Original_Record_Component
(E
) = E
)
5875 if Rep_Item_Too_Late
(E
, N
) then
5879 if Prag_Id
= Pragma_Atomic
or else Prag_Id
= Pragma_Shared
then
5882 -- If the object declaration has an explicit initialization, a
5883 -- temporary may have to be created to hold the expression, to
5884 -- ensure that access to the object remain atomic.
5886 if Nkind
(Parent
(E
)) = N_Object_Declaration
5887 and then Present
(Expression
(Parent
(E
)))
5889 Set_Has_Delayed_Freeze
(E
);
5892 -- An interesting improvement here. If an object of composite
5893 -- type X is declared atomic, and the type X isn't, that's a
5894 -- pity, since it may not have appropriate alignment etc. We
5895 -- can rescue this in the special case where the object and
5896 -- type are in the same unit by just setting the type as
5897 -- atomic, so that the back end will process it as atomic.
5899 -- Note: we used to do this for elementary types as well,
5900 -- but that turns out to be a bad idea and can have unwanted
5901 -- effects, most notably if the type is elementary, the object
5902 -- a simple component within a record, and both are in a spec:
5903 -- every object of this type in the entire program will be
5904 -- treated as atomic, thus incurring a potentially costly
5905 -- synchronization operation for every access.
5907 -- Of course it would be best if the back end could just adjust
5908 -- the alignment etc for the specific object, but that's not
5909 -- something we are capable of doing at this point.
5911 Utyp
:= Underlying_Type
(Etype
(E
));
5914 and then Is_Composite_Type
(Utyp
)
5915 and then Sloc
(E
) > No_Location
5916 and then Sloc
(Utyp
) > No_Location
5918 Get_Source_File_Index
(Sloc
(E
)) =
5919 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
5921 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
5925 -- Atomic/Shared imply both Independent and Volatile
5927 if Prag_Id
/= Pragma_Volatile
then
5928 Set_Is_Independent
(E
);
5930 if Prag_Id
= Pragma_Independent
then
5931 Record_Independence_Check
(N
, E
);
5935 if Prag_Id
/= Pragma_Independent
then
5936 Set_Is_Volatile
(E
);
5937 Set_Treat_As_Volatile
(E
);
5941 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
5944 -- The following check is only relevant when SPARK_Mode is on as
5945 -- this is not a standard Ada legality rule. Pragma Volatile can
5946 -- only apply to a full type declaration or an object declaration
5947 -- (SPARK RM C.6(1)).
5950 and then Prag_Id
= Pragma_Volatile
5951 and then not Nkind_In
(K
, N_Full_Type_Declaration
,
5952 N_Object_Declaration
)
5955 ("argument of pragma % must denote a full type or object "
5956 & "declaration", Arg1
);
5958 end Process_Atomic_Independent_Shared_Volatile
;
5960 -------------------------------------------
5961 -- Process_Compile_Time_Warning_Or_Error --
5962 -------------------------------------------
5964 procedure Process_Compile_Time_Warning_Or_Error
is
5965 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5968 Check_Arg_Count
(2);
5969 Check_No_Identifiers
;
5970 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
5971 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
5973 if Compile_Time_Known_Value
(Arg1x
) then
5974 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
5976 Str
: constant String_Id
:=
5977 Strval
(Get_Pragma_Arg
(Arg2
));
5978 Len
: constant Int
:= String_Length
(Str
);
5983 Cent
: constant Entity_Id
:=
5984 Cunit_Entity
(Current_Sem_Unit
);
5986 Force
: constant Boolean :=
5987 Prag_Id
= Pragma_Compile_Time_Warning
5989 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
5990 and then (Ekind
(Cent
) /= E_Package
5991 or else not In_Private_Part
(Cent
));
5992 -- Set True if this is the warning case, and we are in the
5993 -- visible part of a package spec, or in a subprogram spec,
5994 -- in which case we want to force the client to see the
5995 -- warning, even though it is not in the main unit.
5998 -- Loop through segments of message separated by line feeds.
5999 -- We output these segments as separate messages with
6000 -- continuation marks for all but the first.
6005 Error_Msg_Strlen
:= 0;
6007 -- Loop to copy characters from argument to error message
6011 exit when Ptr
> Len
;
6012 CC
:= Get_String_Char
(Str
, Ptr
);
6015 -- Ignore wide chars ??? else store character
6017 if In_Character_Range
(CC
) then
6018 C
:= Get_Character
(CC
);
6019 exit when C
= ASCII
.LF
;
6020 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6021 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6025 -- Here with one line ready to go
6027 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6029 -- If this is a warning in a spec, then we want clients
6030 -- to see the warning, so mark the message with the
6031 -- special sequence !! to force the warning. In the case
6032 -- of a package spec, we do not force this if we are in
6033 -- the private part of the spec.
6036 if Cont
= False then
6037 Error_Msg_N
("<<~!!", Arg1
);
6040 Error_Msg_N
("\<<~!!", Arg1
);
6043 -- Error, rather than warning, or in a body, so we do not
6044 -- need to force visibility for client (error will be
6045 -- output in any case, and this is the situation in which
6046 -- we do not want a client to get a warning, since the
6047 -- warning is in the body or the spec private part).
6050 if Cont
= False then
6051 Error_Msg_N
("<<~", Arg1
);
6054 Error_Msg_N
("\<<~", Arg1
);
6058 exit when Ptr
> Len
;
6063 end Process_Compile_Time_Warning_Or_Error
;
6065 ------------------------
6066 -- Process_Convention --
6067 ------------------------
6069 procedure Process_Convention
6070 (C
: out Convention_Id
;
6071 Ent
: out Entity_Id
)
6075 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6076 -- Called if we have more than one Export/Import/Convention pragma.
6077 -- This is generally illegal, but we have a special case of allowing
6078 -- Import and Interface to coexist if they specify the convention in
6079 -- a consistent manner. We are allowed to do this, since Interface is
6080 -- an implementation defined pragma, and we choose to do it since we
6081 -- know Rational allows this combination. S is the entity id of the
6082 -- subprogram in question. This procedure also sets the special flag
6083 -- Import_Interface_Present in both pragmas in the case where we do
6084 -- have matching Import and Interface pragmas.
6086 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6087 -- Set convention in entity E, and also flag that the entity has a
6088 -- convention pragma. If entity is for a private or incomplete type,
6089 -- also set convention and flag on underlying type. This procedure
6090 -- also deals with the special case of C_Pass_By_Copy convention,
6091 -- and error checks for inappropriate convention specification.
6093 -------------------------------
6094 -- Diagnose_Multiple_Pragmas --
6095 -------------------------------
6097 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6098 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6102 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6103 -- Decl is a pragma node. This function returns True if this
6104 -- pragma has a first argument that is an identifier with a
6105 -- Chars field corresponding to the Convention_Id C.
6107 function Same_Name
(Decl
: Node_Id
) return Boolean;
6108 -- Decl is a pragma node. This function returns True if this
6109 -- pragma has a second argument that is an identifier with a
6110 -- Chars field that matches the Chars of the current subprogram.
6112 ---------------------
6113 -- Same_Convention --
6114 ---------------------
6116 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6117 Arg1
: constant Node_Id
:=
6118 First
(Pragma_Argument_Associations
(Decl
));
6121 if Present
(Arg1
) then
6123 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6125 if Nkind
(Arg
) = N_Identifier
6126 and then Is_Convention_Name
(Chars
(Arg
))
6127 and then Get_Convention_Id
(Chars
(Arg
)) = C
6135 end Same_Convention
;
6141 function Same_Name
(Decl
: Node_Id
) return Boolean is
6142 Arg1
: constant Node_Id
:=
6143 First
(Pragma_Argument_Associations
(Decl
));
6151 Arg2
:= Next
(Arg1
);
6158 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6160 if Nkind
(Arg
) = N_Identifier
6161 and then Chars
(Arg
) = Chars
(S
)
6170 -- Start of processing for Diagnose_Multiple_Pragmas
6175 -- Definitely give message if we have Convention/Export here
6177 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6180 -- If we have an Import or Export, scan back from pragma to
6181 -- find any previous pragma applying to the same procedure.
6182 -- The scan will be terminated by the start of the list, or
6183 -- hitting the subprogram declaration. This won't allow one
6184 -- pragma to appear in the public part and one in the private
6185 -- part, but that seems very unlikely in practice.
6189 while Present
(Decl
) and then Decl
/= Pdec
loop
6191 -- Look for pragma with same name as us
6193 if Nkind
(Decl
) = N_Pragma
6194 and then Same_Name
(Decl
)
6196 -- Give error if same as our pragma or Export/Convention
6198 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6204 -- Case of Import/Interface or the other way round
6206 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6209 -- Here we know that we have Import and Interface. It
6210 -- doesn't matter which way round they are. See if
6211 -- they specify the same convention. If so, all OK,
6212 -- and set special flags to stop other messages
6214 if Same_Convention
(Decl
) then
6215 Set_Import_Interface_Present
(N
);
6216 Set_Import_Interface_Present
(Decl
);
6219 -- If different conventions, special message
6222 Error_Msg_Sloc
:= Sloc
(Decl
);
6224 ("convention differs from that given#", Arg1
);
6234 -- Give message if needed if we fall through those tests
6235 -- except on Relaxed_RM_Semantics where we let go: either this
6236 -- is a case accepted/ignored by other Ada compilers (e.g.
6237 -- a mix of Convention and Import), or another error will be
6238 -- generated later (e.g. using both Import and Export).
6240 if Err
and not Relaxed_RM_Semantics
then
6242 ("at most one Convention/Export/Import pragma is allowed",
6245 end Diagnose_Multiple_Pragmas
;
6247 --------------------------------
6248 -- Set_Convention_From_Pragma --
6249 --------------------------------
6251 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6253 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6254 -- for an overridden dispatching operation. Technically this is
6255 -- an amendment and should only be done in Ada 2005 mode. However,
6256 -- this is clearly a mistake, since the problem that is addressed
6257 -- by this AI is that there is a clear gap in the RM.
6259 if Is_Dispatching_Operation
(E
)
6260 and then Present
(Overridden_Operation
(E
))
6261 and then C
/= Convention
(Overridden_Operation
(E
))
6264 ("cannot change convention for overridden dispatching "
6265 & "operation", Arg1
);
6268 -- Special checks for Convention_Stdcall
6270 if C
= Convention_Stdcall
then
6272 -- A dispatching call is not allowed. A dispatching subprogram
6273 -- cannot be used to interface to the Win32 API, so in fact
6274 -- this check does not impose any effective restriction.
6276 if Is_Dispatching_Operation
(E
) then
6277 Error_Msg_Sloc
:= Sloc
(E
);
6279 -- Note: make this unconditional so that if there is more
6280 -- than one call to which the pragma applies, we get a
6281 -- message for each call. Also don't use Error_Pragma,
6282 -- so that we get multiple messages.
6285 ("dispatching subprogram# cannot use Stdcall convention!",
6288 -- Subprograms are not allowed
6290 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
6294 and then Ekind
(E
) /= E_Variable
6296 -- An access to subprogram is also allowed
6300 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
6302 -- Allow internal call to set convention of subprogram type
6304 and then not (Ekind
(E
) = E_Subprogram_Type
)
6307 ("second argument of pragma% must be subprogram (type)",
6312 -- Set the convention
6314 Set_Convention
(E
, C
);
6315 Set_Has_Convention_Pragma
(E
);
6317 -- For the case of a record base type, also set the convention of
6318 -- any anonymous access types declared in the record which do not
6319 -- currently have a specified convention.
6321 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
6326 Comp
:= First_Component
(E
);
6327 while Present
(Comp
) loop
6328 if Present
(Etype
(Comp
))
6329 and then Ekind_In
(Etype
(Comp
),
6330 E_Anonymous_Access_Type
,
6331 E_Anonymous_Access_Subprogram_Type
)
6332 and then not Has_Convention_Pragma
(Comp
)
6334 Set_Convention
(Comp
, C
);
6337 Next_Component
(Comp
);
6342 -- Deal with incomplete/private type case, where underlying type
6343 -- is available, so set convention of that underlying type.
6345 if Is_Incomplete_Or_Private_Type
(E
)
6346 and then Present
(Underlying_Type
(E
))
6348 Set_Convention
(Underlying_Type
(E
), C
);
6349 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
6352 -- A class-wide type should inherit the convention of the specific
6353 -- root type (although this isn't specified clearly by the RM).
6355 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
6356 Set_Convention
(Class_Wide_Type
(E
), C
);
6359 -- If the entity is a record type, then check for special case of
6360 -- C_Pass_By_Copy, which is treated the same as C except that the
6361 -- special record flag is set. This convention is only permitted
6362 -- on record types (see AI95-00131).
6364 if Cname
= Name_C_Pass_By_Copy
then
6365 if Is_Record_Type
(E
) then
6366 Set_C_Pass_By_Copy
(Base_Type
(E
));
6367 elsif Is_Incomplete_Or_Private_Type
(E
)
6368 and then Is_Record_Type
(Underlying_Type
(E
))
6370 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
6373 ("C_Pass_By_Copy convention allowed only for record type",
6378 -- If the entity is a derived boolean type, check for the special
6379 -- case of convention C, C++, or Fortran, where we consider any
6380 -- nonzero value to represent true.
6382 if Is_Discrete_Type
(E
)
6383 and then Root_Type
(Etype
(E
)) = Standard_Boolean
6389 C
= Convention_Fortran
)
6391 Set_Nonzero_Is_True
(Base_Type
(E
));
6393 end Set_Convention_From_Pragma
;
6397 Comp_Unit
: Unit_Number_Type
;
6402 -- Start of processing for Process_Convention
6405 Check_At_Least_N_Arguments
(2);
6406 Check_Optional_Identifier
(Arg1
, Name_Convention
);
6407 Check_Arg_Is_Identifier
(Arg1
);
6408 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
6410 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
6411 -- tested again below to set the critical flag).
6413 if Cname
= Name_C_Pass_By_Copy
then
6416 -- Otherwise we must have something in the standard convention list
6418 elsif Is_Convention_Name
(Cname
) then
6419 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
6421 -- Otherwise warn on unrecognized convention
6424 if Warn_On_Export_Import
then
6426 ("??unrecognized convention name, C assumed",
6427 Get_Pragma_Arg
(Arg1
));
6433 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6434 Check_Arg_Is_Local_Name
(Arg2
);
6436 Id
:= Get_Pragma_Arg
(Arg2
);
6439 if not Is_Entity_Name
(Id
) then
6440 Error_Pragma_Arg
("entity name required", Arg2
);
6445 -- Set entity to return
6449 -- Ada_Pass_By_Copy special checking
6451 if C
= Convention_Ada_Pass_By_Copy
then
6452 if not Is_First_Subtype
(E
) then
6454 ("convention `Ada_Pass_By_Copy` only allowed for types",
6458 if Is_By_Reference_Type
(E
) then
6460 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
6464 -- Ada_Pass_By_Reference special checking
6466 elsif C
= Convention_Ada_Pass_By_Reference
then
6467 if not Is_First_Subtype
(E
) then
6469 ("convention `Ada_Pass_By_Reference` only allowed for types",
6473 if Is_By_Copy_Type
(E
) then
6475 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
6480 -- Go to renamed subprogram if present, since convention applies to
6481 -- the actual renamed entity, not to the renaming entity. If the
6482 -- subprogram is inherited, go to parent subprogram.
6484 if Is_Subprogram
(E
)
6485 and then Present
(Alias
(E
))
6487 if Nkind
(Parent
(Declaration_Node
(E
))) =
6488 N_Subprogram_Renaming_Declaration
6490 if Scope
(E
) /= Scope
(Alias
(E
)) then
6492 ("cannot apply pragma% to non-local entity&#", E
);
6497 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
6498 N_Private_Extension_Declaration
)
6499 and then Scope
(E
) = Scope
(Alias
(E
))
6503 -- Return the parent subprogram the entity was inherited from
6509 -- Check that we are not applying this to a specless body. Relax this
6510 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
6512 if Is_Subprogram
(E
)
6513 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
6514 and then not Relaxed_RM_Semantics
6517 ("pragma% requires separate spec and must come before body");
6520 -- Check that we are not applying this to a named constant
6522 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
6523 Error_Msg_Name_1
:= Pname
;
6525 ("cannot apply pragma% to named constant!",
6526 Get_Pragma_Arg
(Arg2
));
6528 ("\supply appropriate type for&!", Arg2
);
6531 if Ekind
(E
) = E_Enumeration_Literal
then
6532 Error_Pragma
("enumeration literal not allowed for pragma%");
6535 -- Check for rep item appearing too early or too late
6537 if Etype
(E
) = Any_Type
6538 or else Rep_Item_Too_Early
(E
, N
)
6542 elsif Present
(Underlying_Type
(E
)) then
6543 E
:= Underlying_Type
(E
);
6546 if Rep_Item_Too_Late
(E
, N
) then
6550 if Has_Convention_Pragma
(E
) then
6551 Diagnose_Multiple_Pragmas
(E
);
6553 elsif Convention
(E
) = Convention_Protected
6554 or else Ekind
(Scope
(E
)) = E_Protected_Type
6557 ("a protected operation cannot be given a different convention",
6561 -- For Intrinsic, a subprogram is required
6563 if C
= Convention_Intrinsic
6564 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
6567 ("second argument of pragma% must be a subprogram", Arg2
);
6570 -- Deal with non-subprogram cases
6572 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
6573 Set_Convention_From_Pragma
(E
);
6576 Check_First_Subtype
(Arg2
);
6577 Set_Convention_From_Pragma
(Base_Type
(E
));
6579 -- For access subprograms, we must set the convention on the
6580 -- internally generated directly designated type as well.
6582 if Ekind
(E
) = E_Access_Subprogram_Type
then
6583 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
6587 -- For the subprogram case, set proper convention for all homonyms
6588 -- in same scope and the same declarative part, i.e. the same
6589 -- compilation unit.
6592 Comp_Unit
:= Get_Source_Unit
(E
);
6593 Set_Convention_From_Pragma
(E
);
6595 -- Treat a pragma Import as an implicit body, and pragma import
6596 -- as implicit reference (for navigation in GPS).
6598 if Prag_Id
= Pragma_Import
then
6599 Generate_Reference
(E
, Id
, 'b');
6601 -- For exported entities we restrict the generation of references
6602 -- to entities exported to foreign languages since entities
6603 -- exported to Ada do not provide further information to GPS and
6604 -- add undesired references to the output of the gnatxref tool.
6606 elsif Prag_Id
= Pragma_Export
6607 and then Convention
(E
) /= Convention_Ada
6609 Generate_Reference
(E
, Id
, 'i');
6612 -- If the pragma comes from from an aspect, it only applies to the
6613 -- given entity, not its homonyms.
6615 if From_Aspect_Specification
(N
) then
6619 -- Otherwise Loop through the homonyms of the pragma argument's
6620 -- entity, an apply convention to those in the current scope.
6626 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
6628 -- Ignore entry for which convention is already set
6630 if Has_Convention_Pragma
(E1
) then
6634 -- Do not set the pragma on inherited operations or on formal
6637 if Comes_From_Source
(E1
)
6638 and then Comp_Unit
= Get_Source_Unit
(E1
)
6639 and then not Is_Formal_Subprogram
(E1
)
6640 and then Nkind
(Original_Node
(Parent
(E1
))) /=
6641 N_Full_Type_Declaration
6643 if Present
(Alias
(E1
))
6644 and then Scope
(E1
) /= Scope
(Alias
(E1
))
6647 ("cannot apply pragma% to non-local entity& declared#",
6651 Set_Convention_From_Pragma
(E1
);
6653 if Prag_Id
= Pragma_Import
then
6654 Generate_Reference
(E1
, Id
, 'b');
6662 end Process_Convention
;
6664 ----------------------------------------
6665 -- Process_Disable_Enable_Atomic_Sync --
6666 ----------------------------------------
6668 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
6670 Check_No_Identifiers
;
6671 Check_At_Most_N_Arguments
(1);
6673 -- Modeled internally as
6674 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
6678 Pragma_Identifier
=>
6679 Make_Identifier
(Loc
, Nam
),
6680 Pragma_Argument_Associations
=> New_List
(
6681 Make_Pragma_Argument_Association
(Loc
,
6683 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
6685 if Present
(Arg1
) then
6686 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
6690 end Process_Disable_Enable_Atomic_Sync
;
6692 -------------------------------------------------
6693 -- Process_Extended_Import_Export_Internal_Arg --
6694 -------------------------------------------------
6696 procedure Process_Extended_Import_Export_Internal_Arg
6697 (Arg_Internal
: Node_Id
:= Empty
)
6700 if No
(Arg_Internal
) then
6701 Error_Pragma
("Internal parameter required for pragma%");
6704 if Nkind
(Arg_Internal
) = N_Identifier
then
6707 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
6708 and then (Prag_Id
= Pragma_Import_Function
6710 Prag_Id
= Pragma_Export_Function
)
6716 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
6719 Check_Arg_Is_Local_Name
(Arg_Internal
);
6720 end Process_Extended_Import_Export_Internal_Arg
;
6722 --------------------------------------------------
6723 -- Process_Extended_Import_Export_Object_Pragma --
6724 --------------------------------------------------
6726 procedure Process_Extended_Import_Export_Object_Pragma
6727 (Arg_Internal
: Node_Id
;
6728 Arg_External
: Node_Id
;
6734 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
6735 Def_Id
:= Entity
(Arg_Internal
);
6737 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
6739 ("pragma% must designate an object", Arg_Internal
);
6742 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
6744 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
6747 ("previous Common/Psect_Object applies, pragma % not permitted",
6751 if Rep_Item_Too_Late
(Def_Id
, N
) then
6755 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
6757 if Present
(Arg_Size
) then
6758 Check_Arg_Is_External_Name
(Arg_Size
);
6761 -- Export_Object case
6763 if Prag_Id
= Pragma_Export_Object
then
6764 if not Is_Library_Level_Entity
(Def_Id
) then
6766 ("argument for pragma% must be library level entity",
6770 if Ekind
(Current_Scope
) = E_Generic_Package
then
6771 Error_Pragma
("pragma& cannot appear in a generic unit");
6774 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
6776 ("exported object must have compile time known size",
6780 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
6781 Error_Msg_N
("??duplicate Export_Object pragma", N
);
6783 Set_Exported
(Def_Id
, Arg_Internal
);
6786 -- Import_Object case
6789 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
6791 ("cannot use pragma% for task/protected object",
6795 if Ekind
(Def_Id
) = E_Constant
then
6797 ("cannot import a constant", Arg_Internal
);
6800 if Warn_On_Export_Import
6801 and then Has_Discriminants
(Etype
(Def_Id
))
6804 ("imported value must be initialized??", Arg_Internal
);
6807 if Warn_On_Export_Import
6808 and then Is_Access_Type
(Etype
(Def_Id
))
6811 ("cannot import object of an access type??", Arg_Internal
);
6814 if Warn_On_Export_Import
6815 and then Is_Imported
(Def_Id
)
6817 Error_Msg_N
("??duplicate Import_Object pragma", N
);
6819 -- Check for explicit initialization present. Note that an
6820 -- initialization generated by the code generator, e.g. for an
6821 -- access type, does not count here.
6823 elsif Present
(Expression
(Parent
(Def_Id
)))
6826 (Original_Node
(Expression
(Parent
(Def_Id
))))
6828 Error_Msg_Sloc
:= Sloc
(Def_Id
);
6830 ("imported entities cannot be initialized (RM B.1(24))",
6831 "\no initialization allowed for & declared#", Arg1
);
6833 Set_Imported
(Def_Id
);
6834 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
6837 end Process_Extended_Import_Export_Object_Pragma
;
6839 ------------------------------------------------------
6840 -- Process_Extended_Import_Export_Subprogram_Pragma --
6841 ------------------------------------------------------
6843 procedure Process_Extended_Import_Export_Subprogram_Pragma
6844 (Arg_Internal
: Node_Id
;
6845 Arg_External
: Node_Id
;
6846 Arg_Parameter_Types
: Node_Id
;
6847 Arg_Result_Type
: Node_Id
:= Empty
;
6848 Arg_Mechanism
: Node_Id
;
6849 Arg_Result_Mechanism
: Node_Id
:= Empty
)
6855 Ambiguous
: Boolean;
6858 function Same_Base_Type
6860 Formal
: Entity_Id
) return Boolean;
6861 -- Determines if Ptype references the type of Formal. Note that only
6862 -- the base types need to match according to the spec. Ptype here is
6863 -- the argument from the pragma, which is either a type name, or an
6864 -- access attribute.
6866 --------------------
6867 -- Same_Base_Type --
6868 --------------------
6870 function Same_Base_Type
6872 Formal
: Entity_Id
) return Boolean
6874 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
6878 -- Case where pragma argument is typ'Access
6880 if Nkind
(Ptype
) = N_Attribute_Reference
6881 and then Attribute_Name
(Ptype
) = Name_Access
6883 Pref
:= Prefix
(Ptype
);
6886 if not Is_Entity_Name
(Pref
)
6887 or else Entity
(Pref
) = Any_Type
6892 -- We have a match if the corresponding argument is of an
6893 -- anonymous access type, and its designated type matches the
6894 -- type of the prefix of the access attribute
6896 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
6897 and then Base_Type
(Entity
(Pref
)) =
6898 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
6900 -- Case where pragma argument is a type name
6905 if not Is_Entity_Name
(Ptype
)
6906 or else Entity
(Ptype
) = Any_Type
6911 -- We have a match if the corresponding argument is of the type
6912 -- given in the pragma (comparing base types)
6914 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
6918 -- Start of processing for
6919 -- Process_Extended_Import_Export_Subprogram_Pragma
6922 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
6926 -- Loop through homonyms (overloadings) of the entity
6928 Hom_Id
:= Entity
(Arg_Internal
);
6929 while Present
(Hom_Id
) loop
6930 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
6932 -- We need a subprogram in the current scope
6934 if not Is_Subprogram
(Def_Id
)
6935 or else Scope
(Def_Id
) /= Current_Scope
6942 -- Pragma cannot apply to subprogram body
6944 if Is_Subprogram
(Def_Id
)
6945 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
6949 ("pragma% requires separate spec"
6950 & " and must come before body");
6953 -- Test result type if given, note that the result type
6954 -- parameter can only be present for the function cases.
6956 if Present
(Arg_Result_Type
)
6957 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
6961 elsif Etype
(Def_Id
) /= Standard_Void_Type
6963 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
6967 -- Test parameter types if given. Note that this parameter
6968 -- has not been analyzed (and must not be, since it is
6969 -- semantic nonsense), so we get it as the parser left it.
6971 elsif Present
(Arg_Parameter_Types
) then
6972 Check_Matching_Types
: declare
6977 Formal
:= First_Formal
(Def_Id
);
6979 if Nkind
(Arg_Parameter_Types
) = N_Null
then
6980 if Present
(Formal
) then
6984 -- A list of one type, e.g. (List) is parsed as
6985 -- a parenthesized expression.
6987 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
6988 and then Paren_Count
(Arg_Parameter_Types
) = 1
6991 or else Present
(Next_Formal
(Formal
))
6996 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
6999 -- A list of more than one type is parsed as a aggregate
7001 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7002 and then Paren_Count
(Arg_Parameter_Types
) = 0
7004 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7005 while Present
(Ptype
) or else Present
(Formal
) loop
7008 or else not Same_Base_Type
(Ptype
, Formal
)
7013 Next_Formal
(Formal
);
7018 -- Anything else is of the wrong form
7022 ("wrong form for Parameter_Types parameter",
7023 Arg_Parameter_Types
);
7025 end Check_Matching_Types
;
7028 -- Match is now False if the entry we found did not match
7029 -- either a supplied Parameter_Types or Result_Types argument
7035 -- Ambiguous case, the flag Ambiguous shows if we already
7036 -- detected this and output the initial messages.
7039 if not Ambiguous
then
7041 Error_Msg_Name_1
:= Pname
;
7043 ("pragma% does not uniquely identify subprogram!",
7045 Error_Msg_Sloc
:= Sloc
(Ent
);
7046 Error_Msg_N
("matching subprogram #!", N
);
7050 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7051 Error_Msg_N
("matching subprogram #!", N
);
7056 Hom_Id
:= Homonym
(Hom_Id
);
7059 -- See if we found an entry
7062 if not Ambiguous
then
7063 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7065 ("pragma% cannot be given for generic subprogram");
7068 ("pragma% does not identify local subprogram");
7075 -- Import pragmas must be for imported entities
7077 if Prag_Id
= Pragma_Import_Function
7079 Prag_Id
= Pragma_Import_Procedure
7081 Prag_Id
= Pragma_Import_Valued_Procedure
7083 if not Is_Imported
(Ent
) then
7085 ("pragma Import or Interface must precede pragma%");
7088 -- Here we have the Export case which can set the entity as exported
7090 -- But does not do so if the specified external name is null, since
7091 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7092 -- compatible) to request no external name.
7094 elsif Nkind
(Arg_External
) = N_String_Literal
7095 and then String_Length
(Strval
(Arg_External
)) = 0
7099 -- In all other cases, set entity as exported
7102 Set_Exported
(Ent
, Arg_Internal
);
7105 -- Special processing for Valued_Procedure cases
7107 if Prag_Id
= Pragma_Import_Valued_Procedure
7109 Prag_Id
= Pragma_Export_Valued_Procedure
7111 Formal
:= First_Formal
(Ent
);
7114 Error_Pragma
("at least one parameter required for pragma%");
7116 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7117 Error_Pragma
("first parameter must have mode out for pragma%");
7120 Set_Is_Valued_Procedure
(Ent
);
7124 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7126 -- Process Result_Mechanism argument if present. We have already
7127 -- checked that this is only allowed for the function case.
7129 if Present
(Arg_Result_Mechanism
) then
7130 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7133 -- Process Mechanism parameter if present. Note that this parameter
7134 -- is not analyzed, and must not be analyzed since it is semantic
7135 -- nonsense, so we get it in exactly as the parser left it.
7137 if Present
(Arg_Mechanism
) then
7145 -- A single mechanism association without a formal parameter
7146 -- name is parsed as a parenthesized expression. All other
7147 -- cases are parsed as aggregates, so we rewrite the single
7148 -- parameter case as an aggregate for consistency.
7150 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7151 and then Paren_Count
(Arg_Mechanism
) = 1
7153 Rewrite
(Arg_Mechanism
,
7154 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7155 Expressions
=> New_List
(
7156 Relocate_Node
(Arg_Mechanism
))));
7159 -- Case of only mechanism name given, applies to all formals
7161 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7162 Formal
:= First_Formal
(Ent
);
7163 while Present
(Formal
) loop
7164 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7165 Next_Formal
(Formal
);
7168 -- Case of list of mechanism associations given
7171 if Null_Record_Present
(Arg_Mechanism
) then
7173 ("inappropriate form for Mechanism parameter",
7177 -- Deal with positional ones first
7179 Formal
:= First_Formal
(Ent
);
7181 if Present
(Expressions
(Arg_Mechanism
)) then
7182 Mname
:= First
(Expressions
(Arg_Mechanism
));
7183 while Present
(Mname
) loop
7186 ("too many mechanism associations", Mname
);
7189 Set_Mechanism_Value
(Formal
, Mname
);
7190 Next_Formal
(Formal
);
7195 -- Deal with named entries
7197 if Present
(Component_Associations
(Arg_Mechanism
)) then
7198 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7199 while Present
(Massoc
) loop
7200 Choice
:= First
(Choices
(Massoc
));
7202 if Nkind
(Choice
) /= N_Identifier
7203 or else Present
(Next
(Choice
))
7206 ("incorrect form for mechanism association",
7210 Formal
:= First_Formal
(Ent
);
7214 ("parameter name & not present", Choice
);
7217 if Chars
(Choice
) = Chars
(Formal
) then
7219 (Formal
, Expression
(Massoc
));
7221 -- Set entity on identifier (needed by ASIS)
7223 Set_Entity
(Choice
, Formal
);
7228 Next_Formal
(Formal
);
7237 end Process_Extended_Import_Export_Subprogram_Pragma
;
7239 --------------------------
7240 -- Process_Generic_List --
7241 --------------------------
7243 procedure Process_Generic_List
is
7248 Check_No_Identifiers
;
7249 Check_At_Least_N_Arguments
(1);
7251 -- Check all arguments are names of generic units or instances
7254 while Present
(Arg
) loop
7255 Exp
:= Get_Pragma_Arg
(Arg
);
7258 if not Is_Entity_Name
(Exp
)
7260 (not Is_Generic_Instance
(Entity
(Exp
))
7262 not Is_Generic_Unit
(Entity
(Exp
)))
7265 ("pragma% argument must be name of generic unit/instance",
7271 end Process_Generic_List
;
7273 ------------------------------------
7274 -- Process_Import_Predefined_Type --
7275 ------------------------------------
7277 procedure Process_Import_Predefined_Type
is
7278 Loc
: constant Source_Ptr
:= Sloc
(N
);
7280 Ftyp
: Node_Id
:= Empty
;
7286 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
7289 Elmt
:= First_Elmt
(Predefined_Float_Types
);
7290 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
7294 Ftyp
:= Node
(Elmt
);
7296 if Present
(Ftyp
) then
7298 -- Don't build a derived type declaration, because predefined C
7299 -- types have no declaration anywhere, so cannot really be named.
7300 -- Instead build a full type declaration, starting with an
7301 -- appropriate type definition is built
7303 if Is_Floating_Point_Type
(Ftyp
) then
7304 Def
:= Make_Floating_Point_Definition
(Loc
,
7305 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
7306 Make_Real_Range_Specification
(Loc
,
7307 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
7308 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
7310 -- Should never have a predefined type we cannot handle
7313 raise Program_Error
;
7316 -- Build and insert a Full_Type_Declaration, which will be
7317 -- analyzed as soon as this list entry has been analyzed.
7319 Decl
:= Make_Full_Type_Declaration
(Loc
,
7320 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
7321 Type_Definition
=> Def
);
7323 Insert_After
(N
, Decl
);
7324 Mark_Rewrite_Insertion
(Decl
);
7327 Error_Pragma_Arg
("no matching type found for pragma%",
7330 end Process_Import_Predefined_Type
;
7332 ---------------------------------
7333 -- Process_Import_Or_Interface --
7334 ---------------------------------
7336 procedure Process_Import_Or_Interface
is
7342 -- In Relaxed_RM_Semantics, support old Ada 83 style:
7343 -- pragma Import (Entity, "external name");
7345 if Relaxed_RM_Semantics
7346 and then Arg_Count
= 2
7347 and then Prag_Id
= Pragma_Import
7348 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
7351 Def_Id
:= Get_Pragma_Arg
(Arg1
);
7354 if not Is_Entity_Name
(Def_Id
) then
7355 Error_Pragma_Arg
("entity name required", Arg1
);
7358 Def_Id
:= Entity
(Def_Id
);
7359 Kill_Size_Check_Code
(Def_Id
);
7360 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
7363 Process_Convention
(C
, Def_Id
);
7364 Kill_Size_Check_Code
(Def_Id
);
7365 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
7368 -- Various error checks
7370 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
7372 -- We do not permit Import to apply to a renaming declaration
7374 if Present
(Renamed_Object
(Def_Id
)) then
7376 ("pragma% not allowed for object renaming", Arg2
);
7378 -- User initialization is not allowed for imported object, but
7379 -- the object declaration may contain a default initialization,
7380 -- that will be discarded. Note that an explicit initialization
7381 -- only counts if it comes from source, otherwise it is simply
7382 -- the code generator making an implicit initialization explicit.
7384 elsif Present
(Expression
(Parent
(Def_Id
)))
7385 and then Comes_From_Source
7386 (Original_Node
(Expression
(Parent
(Def_Id
))))
7388 -- Set imported flag to prevent cascaded errors
7390 Set_Is_Imported
(Def_Id
);
7392 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7394 ("no initialization allowed for declaration of& #",
7395 "\imported entities cannot be initialized (RM B.1(24))",
7399 -- If the pragma comes from an aspect specification the
7400 -- Is_Imported flag has already been set.
7402 if not From_Aspect_Specification
(N
) then
7403 Set_Imported
(Def_Id
);
7406 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7408 -- Note that we do not set Is_Public here. That's because we
7409 -- only want to set it if there is no address clause, and we
7410 -- don't know that yet, so we delay that processing till
7413 -- pragma Import completes deferred constants
7415 if Ekind
(Def_Id
) = E_Constant
then
7416 Set_Has_Completion
(Def_Id
);
7419 -- It is not possible to import a constant of an unconstrained
7420 -- array type (e.g. string) because there is no simple way to
7421 -- write a meaningful subtype for it.
7423 if Is_Array_Type
(Etype
(Def_Id
))
7424 and then not Is_Constrained
(Etype
(Def_Id
))
7427 ("imported constant& must have a constrained subtype",
7432 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7434 -- If the name is overloaded, pragma applies to all of the denoted
7435 -- entities in the same declarative part, unless the pragma comes
7436 -- from an aspect specification or was generated by the compiler
7437 -- (such as for pragma Provide_Shift_Operators).
7440 while Present
(Hom_Id
) loop
7442 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7444 -- Ignore inherited subprograms because the pragma will apply
7445 -- to the parent operation, which is the one called.
7447 if Is_Overloadable
(Def_Id
)
7448 and then Present
(Alias
(Def_Id
))
7452 -- If it is not a subprogram, it must be in an outer scope and
7453 -- pragma does not apply.
7455 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
7458 -- The pragma does not apply to primitives of interfaces
7460 elsif Is_Dispatching_Operation
(Def_Id
)
7461 and then Present
(Find_Dispatching_Type
(Def_Id
))
7462 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
7466 -- Verify that the homonym is in the same declarative part (not
7467 -- just the same scope). If the pragma comes from an aspect
7468 -- specification we know that it is part of the declaration.
7470 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
7471 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
7472 and then not From_Aspect_Specification
(N
)
7477 -- If the pragma comes from an aspect specification the
7478 -- Is_Imported flag has already been set.
7480 if not From_Aspect_Specification
(N
) then
7481 Set_Imported
(Def_Id
);
7484 -- Reject an Import applied to an abstract subprogram
7486 if Is_Subprogram
(Def_Id
)
7487 and then Is_Abstract_Subprogram
(Def_Id
)
7489 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7491 ("cannot import abstract subprogram& declared#",
7495 -- Special processing for Convention_Intrinsic
7497 if C
= Convention_Intrinsic
then
7499 -- Link_Name argument not allowed for intrinsic
7503 Set_Is_Intrinsic_Subprogram
(Def_Id
);
7505 -- If no external name is present, then check that this
7506 -- is a valid intrinsic subprogram. If an external name
7507 -- is present, then this is handled by the back end.
7510 Check_Intrinsic_Subprogram
7511 (Def_Id
, Get_Pragma_Arg
(Arg2
));
7515 -- Verify that the subprogram does not have a completion
7516 -- through a renaming declaration. For other completions the
7517 -- pragma appears as a too late representation.
7520 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
7524 and then Nkind
(Decl
) = N_Subprogram_Declaration
7525 and then Present
(Corresponding_Body
(Decl
))
7526 and then Nkind
(Unit_Declaration_Node
7527 (Corresponding_Body
(Decl
))) =
7528 N_Subprogram_Renaming_Declaration
7530 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7532 ("cannot import&, renaming already provided for "
7533 & "declaration #", N
, Def_Id
);
7537 -- If the pragma comes from an aspect specification, there
7538 -- must be an Import aspect specified as well. In the rare
7539 -- case where Import is set to False, the suprogram needs to
7540 -- have a local completion.
7543 Imp_Aspect
: constant Node_Id
:=
7544 Find_Aspect
(Def_Id
, Aspect_Import
);
7548 if Present
(Imp_Aspect
)
7549 and then Present
(Expression
(Imp_Aspect
))
7551 Expr
:= Expression
(Imp_Aspect
);
7552 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
7554 if Is_Entity_Name
(Expr
)
7555 and then Entity
(Expr
) = Standard_True
7557 Set_Has_Completion
(Def_Id
);
7560 -- If there is no expression, the default is True, as for
7561 -- all boolean aspects. Same for the older pragma.
7564 Set_Has_Completion
(Def_Id
);
7568 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7571 if Is_Compilation_Unit
(Hom_Id
) then
7573 -- Its possible homonyms are not affected by the pragma.
7574 -- Such homonyms might be present in the context of other
7575 -- units being compiled.
7579 elsif From_Aspect_Specification
(N
) then
7582 -- If the pragma was created by the compiler, then we don't
7583 -- want it to apply to other homonyms. This kind of case can
7584 -- occur when using pragma Provide_Shift_Operators, which
7585 -- generates implicit shift and rotate operators with Import
7586 -- pragmas that might apply to earlier explicit or implicit
7587 -- declarations marked with Import (for example, coming from
7588 -- an earlier pragma Provide_Shift_Operators for another type),
7589 -- and we don't generally want other homonyms being treated
7590 -- as imported or the pragma flagged as an illegal duplicate.
7592 elsif not Comes_From_Source
(N
) then
7596 Hom_Id
:= Homonym
(Hom_Id
);
7600 -- When the convention is Java or CIL, we also allow Import to
7601 -- be given for packages, generic packages, exceptions, record
7602 -- components, and access to subprograms.
7604 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
7606 (Is_Package_Or_Generic_Package
(Def_Id
)
7607 or else Ekind
(Def_Id
) = E_Exception
7608 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
7609 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
7611 Set_Imported
(Def_Id
);
7612 Set_Is_Public
(Def_Id
);
7613 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7615 -- Import a CPP class
7617 elsif C
= Convention_CPP
7618 and then (Is_Record_Type
(Def_Id
)
7619 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
7621 if Ekind
(Def_Id
) = E_Incomplete_Type
then
7622 if Present
(Full_View
(Def_Id
)) then
7623 Def_Id
:= Full_View
(Def_Id
);
7627 ("cannot import 'C'P'P type before full declaration seen",
7628 Get_Pragma_Arg
(Arg2
));
7630 -- Although we have reported the error we decorate it as
7631 -- CPP_Class to avoid reporting spurious errors
7633 Set_Is_CPP_Class
(Def_Id
);
7638 -- Types treated as CPP classes must be declared limited (note:
7639 -- this used to be a warning but there is no real benefit to it
7640 -- since we did effectively intend to treat the type as limited
7643 if not Is_Limited_Type
(Def_Id
) then
7645 ("imported 'C'P'P type must be limited",
7646 Get_Pragma_Arg
(Arg2
));
7649 if Etype
(Def_Id
) /= Def_Id
7650 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
7652 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
7655 Set_Is_CPP_Class
(Def_Id
);
7657 -- Imported CPP types must not have discriminants (because C++
7658 -- classes do not have discriminants).
7660 if Has_Discriminants
(Def_Id
) then
7662 ("imported 'C'P'P type cannot have discriminants",
7663 First
(Discriminant_Specifications
7664 (Declaration_Node
(Def_Id
))));
7667 -- Check that components of imported CPP types do not have default
7668 -- expressions. For private types this check is performed when the
7669 -- full view is analyzed (see Process_Full_View).
7671 if not Is_Private_Type
(Def_Id
) then
7672 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
7675 -- Import a CPP exception
7677 elsif C
= Convention_CPP
7678 and then Ekind
(Def_Id
) = E_Exception
7682 ("'External_'Name arguments is required for 'Cpp exception",
7685 -- As only a string is allowed, Check_Arg_Is_External_Name
7688 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
7691 if Present
(Arg4
) then
7693 ("Link_Name argument not allowed for imported Cpp exception",
7697 -- Do not call Set_Interface_Name as the name of the exception
7698 -- shouldn't be modified (and in particular it shouldn't be
7699 -- the External_Name). For exceptions, the External_Name is the
7700 -- name of the RTTI structure.
7702 -- ??? Emit an error if pragma Import/Export_Exception is present
7704 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
7706 Check_Arg_Count
(3);
7707 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
7709 Process_Import_Predefined_Type
;
7713 ("second argument of pragma% must be object, subprogram "
7714 & "or incomplete type",
7718 -- If this pragma applies to a compilation unit, then the unit, which
7719 -- is a subprogram, does not require (or allow) a body. We also do
7720 -- not need to elaborate imported procedures.
7722 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
7724 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
7726 Set_Body_Required
(Cunit
, False);
7729 end Process_Import_Or_Interface
;
7731 --------------------
7732 -- Process_Inline --
7733 --------------------
7735 procedure Process_Inline
(Status
: Inline_Status
) is
7742 procedure Make_Inline
(Subp
: Entity_Id
);
7743 -- Subp is the defining unit name of the subprogram declaration. Set
7744 -- the flag, as well as the flag in the corresponding body, if there
7747 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
7748 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
7749 -- Has_Pragma_Inline_Always for the Inline_Always case.
7751 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
7752 -- Returns True if it can be determined at this stage that inlining
7753 -- is not possible, for example if the body is available and contains
7754 -- exception handlers, we prevent inlining, since otherwise we can
7755 -- get undefined symbols at link time. This function also emits a
7756 -- warning if front-end inlining is enabled and the pragma appears
7759 -- ??? is business with link symbols still valid, or does it relate
7760 -- to front end ZCX which is being phased out ???
7762 ---------------------------
7763 -- Inlining_Not_Possible --
7764 ---------------------------
7766 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
7767 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
7771 if Nkind
(Decl
) = N_Subprogram_Body
then
7772 Stats
:= Handled_Statement_Sequence
(Decl
);
7773 return Present
(Exception_Handlers
(Stats
))
7774 or else Present
(At_End_Proc
(Stats
));
7776 elsif Nkind
(Decl
) = N_Subprogram_Declaration
7777 and then Present
(Corresponding_Body
(Decl
))
7779 if Front_End_Inlining
7780 and then Analyzed
(Corresponding_Body
(Decl
))
7782 Error_Msg_N
("pragma appears too late, ignored??", N
);
7785 -- If the subprogram is a renaming as body, the body is just a
7786 -- call to the renamed subprogram, and inlining is trivially
7790 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
7791 N_Subprogram_Renaming_Declaration
7797 Handled_Statement_Sequence
7798 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
7801 Present
(Exception_Handlers
(Stats
))
7802 or else Present
(At_End_Proc
(Stats
));
7806 -- If body is not available, assume the best, the check is
7807 -- performed again when compiling enclosing package bodies.
7811 end Inlining_Not_Possible
;
7817 procedure Make_Inline
(Subp
: Entity_Id
) is
7818 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
7819 Inner_Subp
: Entity_Id
:= Subp
;
7822 -- Ignore if bad type, avoid cascaded error
7824 if Etype
(Subp
) = Any_Type
then
7828 -- If inlining is not possible, for now do not treat as an error
7830 elsif Status
/= Suppressed
7831 and then Inlining_Not_Possible
(Subp
)
7836 -- Here we have a candidate for inlining, but we must exclude
7837 -- derived operations. Otherwise we would end up trying to inline
7838 -- a phantom declaration, and the result would be to drag in a
7839 -- body which has no direct inlining associated with it. That
7840 -- would not only be inefficient but would also result in the
7841 -- backend doing cross-unit inlining in cases where it was
7842 -- definitely inappropriate to do so.
7844 -- However, a simple Comes_From_Source test is insufficient, since
7845 -- we do want to allow inlining of generic instances which also do
7846 -- not come from source. We also need to recognize specs generated
7847 -- by the front-end for bodies that carry the pragma. Finally,
7848 -- predefined operators do not come from source but are not
7849 -- inlineable either.
7851 elsif Is_Generic_Instance
(Subp
)
7852 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
7856 elsif not Comes_From_Source
(Subp
)
7857 and then Scope
(Subp
) /= Standard_Standard
7863 -- The referenced entity must either be the enclosing entity, or
7864 -- an entity declared within the current open scope.
7866 if Present
(Scope
(Subp
))
7867 and then Scope
(Subp
) /= Current_Scope
7868 and then Subp
/= Current_Scope
7871 ("argument of% must be entity in current scope", Assoc
);
7875 -- Processing for procedure, operator or function. If subprogram
7876 -- is aliased (as for an instance) indicate that the renamed
7877 -- entity (if declared in the same unit) is inlined.
7879 if Is_Subprogram
(Subp
) then
7880 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
7882 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
7883 Set_Inline_Flags
(Inner_Subp
);
7885 Decl
:= Parent
(Parent
(Inner_Subp
));
7887 if Nkind
(Decl
) = N_Subprogram_Declaration
7888 and then Present
(Corresponding_Body
(Decl
))
7890 Set_Inline_Flags
(Corresponding_Body
(Decl
));
7892 elsif Is_Generic_Instance
(Subp
) then
7894 -- Indicate that the body needs to be created for
7895 -- inlining subsequent calls. The instantiation node
7896 -- follows the declaration of the wrapper package
7899 if Scope
(Subp
) /= Standard_Standard
7901 Need_Subprogram_Instance_Body
7902 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
7908 -- Inline is a program unit pragma (RM 10.1.5) and cannot
7909 -- appear in a formal part to apply to a formal subprogram.
7910 -- Do not apply check within an instance or a formal package
7911 -- the test will have been applied to the original generic.
7913 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
7914 and then List_Containing
(Decl
) = List_Containing
(N
)
7915 and then not In_Instance
7918 ("Inline cannot apply to a formal subprogram", N
);
7920 -- If Subp is a renaming, it is the renamed entity that
7921 -- will appear in any call, and be inlined. However, for
7922 -- ASIS uses it is convenient to indicate that the renaming
7923 -- itself is an inlined subprogram, so that some gnatcheck
7924 -- rules can be applied in the absence of expansion.
7926 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
7927 Set_Inline_Flags
(Subp
);
7933 -- For a generic subprogram set flag as well, for use at the point
7934 -- of instantiation, to determine whether the body should be
7937 elsif Is_Generic_Subprogram
(Subp
) then
7938 Set_Inline_Flags
(Subp
);
7941 -- Literals are by definition inlined
7943 elsif Kind
= E_Enumeration_Literal
then
7946 -- Anything else is an error
7950 ("expect subprogram name for pragma%", Assoc
);
7954 ----------------------
7955 -- Set_Inline_Flags --
7956 ----------------------
7958 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
7960 -- First set the Has_Pragma_XXX flags and issue the appropriate
7961 -- errors and warnings for suspicious combinations.
7963 if Prag_Id
= Pragma_No_Inline
then
7964 if Has_Pragma_Inline_Always
(Subp
) then
7966 ("Inline_Always and No_Inline are mutually exclusive", N
);
7967 elsif Has_Pragma_Inline
(Subp
) then
7969 ("Inline and No_Inline both specified for& ??",
7970 N
, Entity
(Subp_Id
));
7973 Set_Has_Pragma_No_Inline
(Subp
);
7975 if Prag_Id
= Pragma_Inline_Always
then
7976 if Has_Pragma_No_Inline
(Subp
) then
7978 ("Inline_Always and No_Inline are mutually exclusive",
7982 Set_Has_Pragma_Inline_Always
(Subp
);
7984 if Has_Pragma_No_Inline
(Subp
) then
7986 ("Inline and No_Inline both specified for& ??",
7987 N
, Entity
(Subp_Id
));
7991 if not Has_Pragma_Inline
(Subp
) then
7992 Set_Has_Pragma_Inline
(Subp
);
7996 -- Then adjust the Is_Inlined flag. It can never be set if the
7997 -- subprogram is subject to pragma No_Inline.
8001 Set_Is_Inlined
(Subp
, False);
8005 if not Has_Pragma_No_Inline
(Subp
) then
8006 Set_Is_Inlined
(Subp
, True);
8009 end Set_Inline_Flags
;
8011 -- Start of processing for Process_Inline
8014 Check_No_Identifiers
;
8015 Check_At_Least_N_Arguments
(1);
8017 if Status
= Enabled
then
8018 Inline_Processing_Required
:= True;
8022 while Present
(Assoc
) loop
8023 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8027 if Is_Entity_Name
(Subp_Id
) then
8028 Subp
:= Entity
(Subp_Id
);
8030 if Subp
= Any_Id
then
8032 -- If previous error, avoid cascaded errors
8034 Check_Error_Detected
;
8040 -- For the pragma case, climb homonym chain. This is
8041 -- what implements allowing the pragma in the renaming
8042 -- case, with the result applying to the ancestors, and
8043 -- also allows Inline to apply to all previous homonyms.
8045 if not From_Aspect_Specification
(N
) then
8046 while Present
(Homonym
(Subp
))
8047 and then Scope
(Homonym
(Subp
)) = Current_Scope
8049 Make_Inline
(Homonym
(Subp
));
8050 Subp
:= Homonym
(Subp
);
8057 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
8064 ----------------------------
8065 -- Process_Interface_Name --
8066 ----------------------------
8068 procedure Process_Interface_Name
8069 (Subprogram_Def
: Entity_Id
;
8075 String_Val
: String_Id
;
8077 procedure Check_Form_Of_Interface_Name
8079 Ext_Name_Case
: Boolean);
8080 -- SN is a string literal node for an interface name. This routine
8081 -- performs some minimal checks that the name is reasonable. In
8082 -- particular that no spaces or other obviously incorrect characters
8083 -- appear. This is only a warning, since any characters are allowed.
8084 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
8086 ----------------------------------
8087 -- Check_Form_Of_Interface_Name --
8088 ----------------------------------
8090 procedure Check_Form_Of_Interface_Name
8092 Ext_Name_Case
: Boolean)
8094 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8095 SL
: constant Nat
:= String_Length
(S
);
8100 Error_Msg_N
("interface name cannot be null string", SN
);
8103 for J
in 1 .. SL
loop
8104 C
:= Get_String_Char
(S
, J
);
8106 -- Look for dubious character and issue unconditional warning.
8107 -- Definitely dubious if not in character range.
8109 if not In_Character_Range
(C
)
8111 -- For all cases except CLI target,
8112 -- commas, spaces and slashes are dubious (in CLI, we use
8113 -- commas and backslashes in external names to specify
8114 -- assembly version and public key, while slashes and spaces
8115 -- can be used in names to mark nested classes and
8118 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
8119 and then (Get_Character
(C
) = ','
8121 Get_Character
(C
) = '\'))
8122 or else (VM_Target
/= CLI_Target
8123 and then (Get_Character
(C
) = ' '
8125 Get_Character
(C
) = '/'))
8128 ("??interface name contains illegal character",
8129 Sloc
(SN
) + Source_Ptr
(J
));
8132 end Check_Form_Of_Interface_Name
;
8134 -- Start of processing for Process_Interface_Name
8137 if No
(Link_Arg
) then
8138 if No
(Ext_Arg
) then
8139 if VM_Target
= CLI_Target
8140 and then Ekind
(Subprogram_Def
) = E_Package
8141 and then Nkind
(Parent
(Subprogram_Def
)) =
8142 N_Package_Specification
8143 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
8148 (Generic_Parent
(Parent
(Subprogram_Def
))));
8153 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8155 Link_Nam
:= Expression
(Ext_Arg
);
8158 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8159 Ext_Nam
:= Expression
(Ext_Arg
);
8164 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8165 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8166 Ext_Nam
:= Expression
(Ext_Arg
);
8167 Link_Nam
:= Expression
(Link_Arg
);
8170 -- Check expressions for external name and link name are static
8172 if Present
(Ext_Nam
) then
8173 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8174 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
8176 -- Verify that external name is not the name of a local entity,
8177 -- which would hide the imported one and could lead to run-time
8178 -- surprises. The problem can only arise for entities declared in
8179 -- a package body (otherwise the external name is fully qualified
8180 -- and will not conflict).
8188 if Prag_Id
= Pragma_Import
then
8189 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8191 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
8193 if Nam
/= Chars
(Subprogram_Def
)
8194 and then Present
(E
)
8195 and then not Is_Overloadable
(E
)
8196 and then Is_Immediately_Visible
(E
)
8197 and then not Is_Imported
(E
)
8198 and then Ekind
(Scope
(E
)) = E_Package
8201 while Present
(Par
) loop
8202 if Nkind
(Par
) = N_Package_Body
then
8203 Error_Msg_Sloc
:= Sloc
(E
);
8205 ("imported entity is hidden by & declared#",
8210 Par
:= Parent
(Par
);
8217 if Present
(Link_Nam
) then
8218 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8219 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
8222 -- If there is no link name, just set the external name
8224 if No
(Link_Nam
) then
8225 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8227 -- For the Link_Name case, the given literal is preceded by an
8228 -- asterisk, which indicates to GCC that the given name should be
8229 -- taken literally, and in particular that no prepending of
8230 -- underlines should occur, even in systems where this is the
8236 if VM_Target
= No_VM
then
8237 Store_String_Char
(Get_Char_Code
('*'));
8240 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8241 Store_String_Chars
(String_Val
);
8243 Make_String_Literal
(Sloc
(Link_Nam
),
8244 Strval
=> End_String
);
8247 -- Set the interface name. If the entity is a generic instance, use
8248 -- its alias, which is the callable entity.
8250 if Is_Generic_Instance
(Subprogram_Def
) then
8251 Set_Encoded_Interface_Name
8252 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
8254 Set_Encoded_Interface_Name
8255 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
8258 -- We allow duplicated export names in CIL/Java, as they are always
8259 -- enclosed in a namespace that differentiates them, and overloaded
8260 -- entities are supported by the VM.
8262 if Convention
(Subprogram_Def
) /= Convention_CIL
8264 Convention
(Subprogram_Def
) /= Convention_Java
8266 Check_Duplicated_Export_Name
(Link_Nam
);
8268 end Process_Interface_Name
;
8270 -----------------------------------------
8271 -- Process_Interrupt_Or_Attach_Handler --
8272 -----------------------------------------
8274 procedure Process_Interrupt_Or_Attach_Handler
is
8275 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8276 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
8277 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
8280 Set_Is_Interrupt_Handler
(Handler_Proc
);
8282 -- If the pragma is not associated with a handler procedure within a
8283 -- protected type, then it must be for a nonprotected procedure for
8284 -- the AAMP target, in which case we don't associate a representation
8285 -- item with the procedure's scope.
8287 if Ekind
(Proc_Scope
) = E_Protected_Type
then
8288 if Prag_Id
= Pragma_Interrupt_Handler
8290 Prag_Id
= Pragma_Attach_Handler
8292 Record_Rep_Item
(Proc_Scope
, N
);
8295 end Process_Interrupt_Or_Attach_Handler
;
8297 --------------------------------------------------
8298 -- Process_Restrictions_Or_Restriction_Warnings --
8299 --------------------------------------------------
8301 -- Note: some of the simple identifier cases were handled in par-prag,
8302 -- but it is harmless (and more straightforward) to simply handle all
8303 -- cases here, even if it means we repeat a bit of work in some cases.
8305 procedure Process_Restrictions_Or_Restriction_Warnings
8309 R_Id
: Restriction_Id
;
8315 -- Ignore all Restrictions pragmas in CodePeer mode
8317 if CodePeer_Mode
then
8321 Check_Ada_83_Warning
;
8322 Check_At_Least_N_Arguments
(1);
8323 Check_Valid_Configuration_Pragma
;
8326 while Present
(Arg
) loop
8328 Expr
:= Get_Pragma_Arg
(Arg
);
8330 -- Case of no restriction identifier present
8332 if Id
= No_Name
then
8333 if Nkind
(Expr
) /= N_Identifier
then
8335 ("invalid form for restriction", Arg
);
8340 (Process_Restriction_Synonyms
(Expr
));
8342 if R_Id
not in All_Boolean_Restrictions
then
8343 Error_Msg_Name_1
:= Pname
;
8345 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
8347 -- Check for possible misspelling
8349 for J
in Restriction_Id
loop
8351 Rnm
: constant String := Restriction_Id
'Image (J
);
8354 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
8355 Name_Len
:= Rnm
'Length;
8356 Set_Casing
(All_Lower_Case
);
8358 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
8360 (Identifier_Casing
(Current_Source_File
));
8361 Error_Msg_String
(1 .. Rnm
'Length) :=
8362 Name_Buffer
(1 .. Name_Len
);
8363 Error_Msg_Strlen
:= Rnm
'Length;
8364 Error_Msg_N
-- CODEFIX
8365 ("\possible misspelling of ""~""",
8366 Get_Pragma_Arg
(Arg
));
8375 if Implementation_Restriction
(R_Id
) then
8376 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
8379 -- Special processing for No_Elaboration_Code restriction
8381 if R_Id
= No_Elaboration_Code
then
8383 -- Restriction is only recognized within a configuration
8384 -- pragma file, or within a unit of the main extended
8385 -- program. Note: the test for Main_Unit is needed to
8386 -- properly include the case of configuration pragma files.
8388 if not (Current_Sem_Unit
= Main_Unit
8389 or else In_Extended_Main_Source_Unit
(N
))
8393 -- Don't allow in a subunit unless already specified in
8396 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
8397 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
8398 and then not Restriction_Active
(No_Elaboration_Code
)
8401 ("invalid specification of ""No_Elaboration_Code""",
8404 ("\restriction cannot be specified in a subunit", N
);
8406 ("\unless also specified in body or spec", N
);
8409 -- If we accept a No_Elaboration_Code restriction, then it
8410 -- needs to be added to the configuration restriction set so
8411 -- that we get proper application to other units in the main
8412 -- extended source as required.
8415 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
8419 -- If this is a warning, then set the warning unless we already
8420 -- have a real restriction active (we never want a warning to
8421 -- override a real restriction).
8424 if not Restriction_Active
(R_Id
) then
8425 Set_Restriction
(R_Id
, N
);
8426 Restriction_Warnings
(R_Id
) := True;
8429 -- If real restriction case, then set it and make sure that the
8430 -- restriction warning flag is off, since a real restriction
8431 -- always overrides a warning.
8434 Set_Restriction
(R_Id
, N
);
8435 Restriction_Warnings
(R_Id
) := False;
8438 -- Check for obsolescent restrictions in Ada 2005 mode
8441 and then Ada_Version
>= Ada_2005
8442 and then (R_Id
= No_Asynchronous_Control
8444 R_Id
= No_Unchecked_Deallocation
8446 R_Id
= No_Unchecked_Conversion
)
8448 Check_Restriction
(No_Obsolescent_Features
, N
);
8451 -- A very special case that must be processed here: pragma
8452 -- Restrictions (No_Exceptions) turns off all run-time
8453 -- checking. This is a bit dubious in terms of the formal
8454 -- language definition, but it is what is intended by RM
8455 -- H.4(12). Restriction_Warnings never affects generated code
8456 -- so this is done only in the real restriction case.
8458 -- Atomic_Synchronization is not a real check, so it is not
8459 -- affected by this processing).
8461 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
8462 -- run-time checks in CodePeer and GNATprove modes: we want to
8463 -- generate checks for analysis purposes, as set respectively
8464 -- by -gnatC and -gnatd.F
8467 and then not (CodePeer_Mode
or GNATprove_Mode
)
8468 and then R_Id
= No_Exceptions
8470 for J
in Scope_Suppress
.Suppress
'Range loop
8471 if J
/= Atomic_Synchronization
then
8472 Scope_Suppress
.Suppress
(J
) := True;
8477 -- Case of No_Dependence => unit-name. Note that the parser
8478 -- already made the necessary entry in the No_Dependence table.
8480 elsif Id
= Name_No_Dependence
then
8481 if not OK_No_Dependence_Unit_Name
(Expr
) then
8485 -- Case of No_Specification_Of_Aspect => aspect-identifier
8487 elsif Id
= Name_No_Specification_Of_Aspect
then
8492 if Nkind
(Expr
) /= N_Identifier
then
8495 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
8498 if A_Id
= No_Aspect
then
8499 Error_Pragma_Arg
("invalid restriction name", Arg
);
8501 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
8505 -- Case of No_Use_Of_Attribute => attribute-identifier
8507 elsif Id
= Name_No_Use_Of_Attribute
then
8508 if Nkind
(Expr
) /= N_Identifier
8509 or else not Is_Attribute_Name
(Chars
(Expr
))
8511 Error_Msg_N
("unknown attribute name??", Expr
);
8514 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
8517 -- Case of No_Use_Of_Entity => fully-qualified-name
8519 elsif Id
= Name_No_Use_Of_Entity
then
8521 -- Restriction is only recognized within a configuration
8522 -- pragma file, or within a unit of the main extended
8523 -- program. Note: the test for Main_Unit is needed to
8524 -- properly include the case of configuration pragma files.
8526 if Current_Sem_Unit
= Main_Unit
8527 or else In_Extended_Main_Source_Unit
(N
)
8529 if not OK_No_Dependence_Unit_Name
(Expr
) then
8530 Error_Msg_N
("wrong form for entity name", Expr
);
8532 Set_Restriction_No_Use_Of_Entity
8533 (Expr
, Warn
, No_Profile
);
8537 -- Case of No_Use_Of_Pragma => pragma-identifier
8539 elsif Id
= Name_No_Use_Of_Pragma
then
8540 if Nkind
(Expr
) /= N_Identifier
8541 or else not Is_Pragma_Name
(Chars
(Expr
))
8543 Error_Msg_N
("unknown pragma name??", Expr
);
8545 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
8548 -- All other cases of restriction identifier present
8551 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
8552 Analyze_And_Resolve
(Expr
, Any_Integer
);
8554 if R_Id
not in All_Parameter_Restrictions
then
8556 ("invalid restriction parameter identifier", Arg
);
8558 elsif not Is_OK_Static_Expression
(Expr
) then
8559 Flag_Non_Static_Expr
8560 ("value must be static expression!", Expr
);
8563 elsif not Is_Integer_Type
(Etype
(Expr
))
8564 or else Expr_Value
(Expr
) < 0
8567 ("value must be non-negative integer", Arg
);
8570 -- Restriction pragma is active
8572 Val
:= Expr_Value
(Expr
);
8574 if not UI_Is_In_Int_Range
(Val
) then
8576 ("pragma ignored, value too large??", Arg
);
8579 -- Warning case. If the real restriction is active, then we
8580 -- ignore the request, since warning never overrides a real
8581 -- restriction. Otherwise we set the proper warning. Note that
8582 -- this circuit sets the warning again if it is already set,
8583 -- which is what we want, since the constant may have changed.
8586 if not Restriction_Active
(R_Id
) then
8588 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
8589 Restriction_Warnings
(R_Id
) := True;
8592 -- Real restriction case, set restriction and make sure warning
8593 -- flag is off since real restriction always overrides warning.
8596 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
8597 Restriction_Warnings
(R_Id
) := False;
8603 end Process_Restrictions_Or_Restriction_Warnings
;
8605 ---------------------------------
8606 -- Process_Suppress_Unsuppress --
8607 ---------------------------------
8609 -- Note: this procedure makes entries in the check suppress data
8610 -- structures managed by Sem. See spec of package Sem for full
8611 -- details on how we handle recording of check suppression.
8613 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
8618 In_Package_Spec
: constant Boolean :=
8619 Is_Package_Or_Generic_Package
(Current_Scope
)
8620 and then not In_Package_Body
(Current_Scope
);
8622 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
8623 -- Used to suppress a single check on the given entity
8625 --------------------------------
8626 -- Suppress_Unsuppress_Echeck --
8627 --------------------------------
8629 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
8631 -- Check for error of trying to set atomic synchronization for
8632 -- a non-atomic variable.
8634 if C
= Atomic_Synchronization
8635 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
8638 ("pragma & requires atomic type or variable",
8639 Pragma_Identifier
(Original_Node
(N
)));
8642 Set_Checks_May_Be_Suppressed
(E
);
8644 if In_Package_Spec
then
8645 Push_Global_Suppress_Stack_Entry
8648 Suppress
=> Suppress_Case
);
8650 Push_Local_Suppress_Stack_Entry
8653 Suppress
=> Suppress_Case
);
8656 -- If this is a first subtype, and the base type is distinct,
8657 -- then also set the suppress flags on the base type.
8659 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
8660 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
8662 end Suppress_Unsuppress_Echeck
;
8664 -- Start of processing for Process_Suppress_Unsuppress
8667 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
8668 -- on user code: we want to generate checks for analysis purposes, as
8669 -- set respectively by -gnatC and -gnatd.F
8671 if (CodePeer_Mode
or GNATprove_Mode
)
8672 and then Comes_From_Source
(N
)
8677 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
8678 -- declarative part or a package spec (RM 11.5(5)).
8680 if not Is_Configuration_Pragma
then
8681 Check_Is_In_Decl_Part_Or_Package_Spec
;
8684 Check_At_Least_N_Arguments
(1);
8685 Check_At_Most_N_Arguments
(2);
8686 Check_No_Identifier
(Arg1
);
8687 Check_Arg_Is_Identifier
(Arg1
);
8689 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
8691 if C
= No_Check_Id
then
8693 ("argument of pragma% is not valid check name", Arg1
);
8696 -- Warn that suppress of Elaboration_Check has no effect in SPARK
8698 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
8700 ("Suppress of Elaboration_Check ignored in SPARK??",
8701 "\elaboration checking rules are statically enforced "
8702 & "(SPARK RM 7.7)", Arg1
);
8705 -- One-argument case
8707 if Arg_Count
= 1 then
8709 -- Make an entry in the local scope suppress table. This is the
8710 -- table that directly shows the current value of the scope
8711 -- suppress check for any check id value.
8713 if C
= All_Checks
then
8715 -- For All_Checks, we set all specific predefined checks with
8716 -- the exception of Elaboration_Check, which is handled
8717 -- specially because of not wanting All_Checks to have the
8718 -- effect of deactivating static elaboration order processing.
8719 -- Atomic_Synchronization is also not affected, since this is
8720 -- not a real check.
8722 for J
in Scope_Suppress
.Suppress
'Range loop
8723 if J
/= Elaboration_Check
8725 J
/= Atomic_Synchronization
8727 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
8731 -- If not All_Checks, and predefined check, then set appropriate
8732 -- scope entry. Note that we will set Elaboration_Check if this
8733 -- is explicitly specified. Atomic_Synchronization is allowed
8734 -- only if internally generated and entity is atomic.
8736 elsif C
in Predefined_Check_Id
8737 and then (not Comes_From_Source
(N
)
8738 or else C
/= Atomic_Synchronization
)
8740 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
8743 -- Also make an entry in the Local_Entity_Suppress table
8745 Push_Local_Suppress_Stack_Entry
8748 Suppress
=> Suppress_Case
);
8750 -- Case of two arguments present, where the check is suppressed for
8751 -- a specified entity (given as the second argument of the pragma)
8754 -- This is obsolescent in Ada 2005 mode
8756 if Ada_Version
>= Ada_2005
then
8757 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
8760 Check_Optional_Identifier
(Arg2
, Name_On
);
8761 E_Id
:= Get_Pragma_Arg
(Arg2
);
8764 if not Is_Entity_Name
(E_Id
) then
8766 ("second argument of pragma% must be entity name", Arg2
);
8775 -- Enforce RM 11.5(7) which requires that for a pragma that
8776 -- appears within a package spec, the named entity must be
8777 -- within the package spec. We allow the package name itself
8778 -- to be mentioned since that makes sense, although it is not
8779 -- strictly allowed by 11.5(7).
8782 and then E
/= Current_Scope
8783 and then Scope
(E
) /= Current_Scope
8786 ("entity in pragma% is not in package spec (RM 11.5(7))",
8790 -- Loop through homonyms. As noted below, in the case of a package
8791 -- spec, only homonyms within the package spec are considered.
8794 Suppress_Unsuppress_Echeck
(E
, C
);
8796 if Is_Generic_Instance
(E
)
8797 and then Is_Subprogram
(E
)
8798 and then Present
(Alias
(E
))
8800 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
8803 -- Move to next homonym if not aspect spec case
8805 exit when From_Aspect_Specification
(N
);
8809 -- If we are within a package specification, the pragma only
8810 -- applies to homonyms in the same scope.
8812 exit when In_Package_Spec
8813 and then Scope
(E
) /= Current_Scope
;
8816 end Process_Suppress_Unsuppress
;
8818 -------------------------------
8819 -- Record_Independence_Check --
8820 -------------------------------
8822 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
8824 -- For GCC back ends the validation is done a priori
8826 if VM_Target
= No_VM
and then not AAMP_On_Target
then
8830 Independence_Checks
.Append
((N
, E
));
8831 end Record_Independence_Check
;
8837 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
8839 if Is_Imported
(E
) then
8841 ("cannot export entity& that was previously imported", Arg
);
8843 elsif Present
(Address_Clause
(E
))
8844 and then not Relaxed_RM_Semantics
8847 ("cannot export entity& that has an address clause", Arg
);
8850 Set_Is_Exported
(E
);
8852 -- Generate a reference for entity explicitly, because the
8853 -- identifier may be overloaded and name resolution will not
8856 Generate_Reference
(E
, Arg
);
8858 -- Deal with exporting non-library level entity
8860 if not Is_Library_Level_Entity
(E
) then
8862 -- Not allowed at all for subprograms
8864 if Is_Subprogram
(E
) then
8865 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
8867 -- Otherwise set public and statically allocated
8871 Set_Is_Statically_Allocated
(E
);
8873 -- Warn if the corresponding W flag is set
8875 if Warn_On_Export_Import
8877 -- Only do this for something that was in the source. Not
8878 -- clear if this can be False now (there used for sure to be
8879 -- cases on some systems where it was False), but anyway the
8880 -- test is harmless if not needed, so it is retained.
8882 and then Comes_From_Source
(Arg
)
8885 ("?x?& has been made static as a result of Export",
8888 ("\?x?this usage is non-standard and non-portable",
8894 if Warn_On_Export_Import
and then Is_Type
(E
) then
8895 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
8898 if Warn_On_Export_Import
and Inside_A_Generic
then
8900 ("all instances of& will have the same external name?x?",
8905 ----------------------------------------------
8906 -- Set_Extended_Import_Export_External_Name --
8907 ----------------------------------------------
8909 procedure Set_Extended_Import_Export_External_Name
8910 (Internal_Ent
: Entity_Id
;
8911 Arg_External
: Node_Id
)
8913 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
8917 if No
(Arg_External
) then
8921 Check_Arg_Is_External_Name
(Arg_External
);
8923 if Nkind
(Arg_External
) = N_String_Literal
then
8924 if String_Length
(Strval
(Arg_External
)) = 0 then
8927 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
8930 elsif Nkind
(Arg_External
) = N_Identifier
then
8931 New_Name
:= Get_Default_External_Name
(Arg_External
);
8933 -- Check_Arg_Is_External_Name should let through only identifiers and
8934 -- string literals or static string expressions (which are folded to
8935 -- string literals).
8938 raise Program_Error
;
8941 -- If we already have an external name set (by a prior normal Import
8942 -- or Export pragma), then the external names must match
8944 if Present
(Interface_Name
(Internal_Ent
)) then
8946 -- Ignore mismatching names in CodePeer mode, to support some
8947 -- old compilers which would export the same procedure under
8948 -- different names, e.g:
8950 -- pragma Export_Procedure (P, "a");
8951 -- pragma Export_Procedure (P, "b");
8953 if CodePeer_Mode
then
8957 Check_Matching_Internal_Names
: declare
8958 S1
: constant String_Id
:= Strval
(Old_Name
);
8959 S2
: constant String_Id
:= Strval
(New_Name
);
8962 pragma No_Return
(Mismatch
);
8963 -- Called if names do not match
8969 procedure Mismatch
is
8971 Error_Msg_Sloc
:= Sloc
(Old_Name
);
8973 ("external name does not match that given #",
8977 -- Start of processing for Check_Matching_Internal_Names
8980 if String_Length
(S1
) /= String_Length
(S2
) then
8984 for J
in 1 .. String_Length
(S1
) loop
8985 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
8990 end Check_Matching_Internal_Names
;
8992 -- Otherwise set the given name
8995 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
8996 Check_Duplicated_Export_Name
(New_Name
);
8998 end Set_Extended_Import_Export_External_Name
;
9004 procedure Set_Imported
(E
: Entity_Id
) is
9006 -- Error message if already imported or exported
9008 if Is_Exported
(E
) or else Is_Imported
(E
) then
9010 -- Error if being set Exported twice
9012 if Is_Exported
(E
) then
9013 Error_Msg_NE
("entity& was previously exported", N
, E
);
9015 -- Ignore error in CodePeer mode where we treat all imported
9016 -- subprograms as unknown.
9018 elsif CodePeer_Mode
then
9021 -- OK if Import/Interface case
9023 elsif Import_Interface_Present
(N
) then
9026 -- Error if being set Imported twice
9029 Error_Msg_NE
("entity& was previously imported", N
, E
);
9032 Error_Msg_Name_1
:= Pname
;
9034 ("\(pragma% applies to all previous entities)", N
);
9036 Error_Msg_Sloc
:= Sloc
(E
);
9037 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9039 -- Here if not previously imported or exported, OK to import
9042 Set_Is_Imported
(E
);
9044 -- For subprogram, set Import_Pragma field
9046 if Is_Subprogram
(E
) then
9047 Set_Import_Pragma
(E
, N
);
9050 -- If the entity is an object that is not at the library level,
9051 -- then it is statically allocated. We do not worry about objects
9052 -- with address clauses in this context since they are not really
9053 -- imported in the linker sense.
9056 and then not Is_Library_Level_Entity
(E
)
9057 and then No
(Address_Clause
(E
))
9059 Set_Is_Statically_Allocated
(E
);
9066 -------------------------
9067 -- Set_Mechanism_Value --
9068 -------------------------
9070 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9071 -- analyzed, since it is semantic nonsense), so we get it in the exact
9072 -- form created by the parser.
9074 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9075 procedure Bad_Mechanism
;
9076 pragma No_Return
(Bad_Mechanism
);
9077 -- Signal bad mechanism name
9079 -------------------------
9080 -- Bad_Mechanism_Value --
9081 -------------------------
9083 procedure Bad_Mechanism
is
9085 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9088 -- Start of processing for Set_Mechanism_Value
9091 if Mechanism
(Ent
) /= Default_Mechanism
then
9093 ("mechanism for & has already been set", Mech_Name
, Ent
);
9096 -- MECHANISM_NAME ::= value | reference
9098 if Nkind
(Mech_Name
) = N_Identifier
then
9099 if Chars
(Mech_Name
) = Name_Value
then
9100 Set_Mechanism
(Ent
, By_Copy
);
9103 elsif Chars
(Mech_Name
) = Name_Reference
then
9104 Set_Mechanism
(Ent
, By_Reference
);
9107 elsif Chars
(Mech_Name
) = Name_Copy
then
9109 ("bad mechanism name, Value assumed", Mech_Name
);
9118 end Set_Mechanism_Value
;
9120 --------------------------
9121 -- Set_Rational_Profile --
9122 --------------------------
9124 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9125 -- and extension to the semantics of renaming declarations.
9127 procedure Set_Rational_Profile
is
9129 Implicit_Packing
:= True;
9130 Overriding_Renamings
:= True;
9131 Use_VADS_Size
:= True;
9132 end Set_Rational_Profile
;
9134 ---------------------------
9135 -- Set_Ravenscar_Profile --
9136 ---------------------------
9138 -- The tasks to be done here are
9140 -- Set required policies
9142 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9143 -- pragma Locking_Policy (Ceiling_Locking)
9145 -- Set Detect_Blocking mode
9147 -- Set required restrictions (see System.Rident for detailed list)
9149 -- Set the No_Dependence rules
9150 -- No_Dependence => Ada.Asynchronous_Task_Control
9151 -- No_Dependence => Ada.Calendar
9152 -- No_Dependence => Ada.Execution_Time.Group_Budget
9153 -- No_Dependence => Ada.Execution_Time.Timers
9154 -- No_Dependence => Ada.Task_Attributes
9155 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9157 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
9158 Prefix_Entity
: Entity_Id
;
9159 Selector_Entity
: Entity_Id
;
9160 Prefix_Node
: Node_Id
;
9164 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9166 if Task_Dispatching_Policy
/= ' '
9167 and then Task_Dispatching_Policy
/= 'F'
9169 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9170 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9172 -- Set the FIFO_Within_Priorities policy, but always preserve
9173 -- System_Location since we like the error message with the run time
9177 Task_Dispatching_Policy
:= 'F';
9179 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9180 Task_Dispatching_Policy_Sloc
:= Loc
;
9184 -- pragma Locking_Policy (Ceiling_Locking)
9186 if Locking_Policy
/= ' '
9187 and then Locking_Policy
/= 'C'
9189 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9190 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
9192 -- Set the Ceiling_Locking policy, but preserve System_Location since
9193 -- we like the error message with the run time name.
9196 Locking_Policy
:= 'C';
9198 if Locking_Policy_Sloc
/= System_Location
then
9199 Locking_Policy_Sloc
:= Loc
;
9203 -- pragma Detect_Blocking
9205 Detect_Blocking
:= True;
9207 -- Set the corresponding restrictions
9209 Set_Profile_Restrictions
9210 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9212 -- Set the No_Dependence restrictions
9214 -- The following No_Dependence restrictions:
9215 -- No_Dependence => Ada.Asynchronous_Task_Control
9216 -- No_Dependence => Ada.Calendar
9217 -- No_Dependence => Ada.Task_Attributes
9218 -- are already set by previous call to Set_Profile_Restrictions.
9220 -- Set the following restrictions which were added to Ada 2005:
9221 -- No_Dependence => Ada.Execution_Time.Group_Budget
9222 -- No_Dependence => Ada.Execution_Time.Timers
9224 if Ada_Version
>= Ada_2005
then
9225 Name_Buffer
(1 .. 3) := "ada";
9228 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9230 Name_Buffer
(1 .. 14) := "execution_time";
9233 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9236 Make_Selected_Component
9238 Prefix
=> Prefix_Entity
,
9239 Selector_Name
=> Selector_Entity
);
9241 Name_Buffer
(1 .. 13) := "group_budgets";
9244 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9247 Make_Selected_Component
9249 Prefix
=> Prefix_Node
,
9250 Selector_Name
=> Selector_Entity
);
9252 Set_Restriction_No_Dependence
9254 Warn
=> Treat_Restrictions_As_Warnings
,
9255 Profile
=> Ravenscar
);
9257 Name_Buffer
(1 .. 6) := "timers";
9260 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9263 Make_Selected_Component
9265 Prefix
=> Prefix_Node
,
9266 Selector_Name
=> Selector_Entity
);
9268 Set_Restriction_No_Dependence
9270 Warn
=> Treat_Restrictions_As_Warnings
,
9271 Profile
=> Ravenscar
);
9274 -- Set the following restrictions which was added to Ada 2012 (see
9276 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9278 if Ada_Version
>= Ada_2012
then
9279 Name_Buffer
(1 .. 6) := "system";
9282 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9284 Name_Buffer
(1 .. 15) := "multiprocessors";
9287 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9290 Make_Selected_Component
9292 Prefix
=> Prefix_Entity
,
9293 Selector_Name
=> Selector_Entity
);
9295 Name_Buffer
(1 .. 19) := "dispatching_domains";
9298 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
9301 Make_Selected_Component
9303 Prefix
=> Prefix_Node
,
9304 Selector_Name
=> Selector_Entity
);
9306 Set_Restriction_No_Dependence
9308 Warn
=> Treat_Restrictions_As_Warnings
,
9309 Profile
=> Ravenscar
);
9311 end Set_Ravenscar_Profile
;
9313 -- Start of processing for Analyze_Pragma
9316 -- The following code is a defense against recursion. Not clear that
9317 -- this can happen legitimately, but perhaps some error situations
9318 -- can cause it, and we did see this recursion during testing.
9320 if Analyzed
(N
) then
9323 Set_Analyzed
(N
, True);
9326 -- Deal with unrecognized pragma
9328 Pname
:= Pragma_Name
(N
);
9330 if not Is_Pragma_Name
(Pname
) then
9331 if Warn_On_Unrecognized_Pragma
then
9332 Error_Msg_Name_1
:= Pname
;
9333 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
9335 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
9336 if Is_Bad_Spelling_Of
(Pname
, PN
) then
9337 Error_Msg_Name_1
:= PN
;
9338 Error_Msg_N
-- CODEFIX
9339 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
9348 -- Here to start processing for recognized pragma
9350 Prag_Id
:= Get_Pragma_Id
(Pname
);
9351 Pname
:= Original_Aspect_Pragma_Name
(N
);
9353 -- Capture setting of Opt.Uneval_Old
9355 case Opt
.Uneval_Old
is
9357 Set_Uneval_Old_Accept
(N
);
9361 Set_Uneval_Old_Warn
(N
);
9363 raise Program_Error
;
9366 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
9367 -- is already set, indicating that we have already checked the policy
9368 -- at the right point. This happens for example in the case of a pragma
9369 -- that is derived from an Aspect.
9371 if Is_Ignored
(N
) or else Is_Checked
(N
) then
9374 -- For a pragma that is a rewriting of another pragma, copy the
9375 -- Is_Checked/Is_Ignored status from the rewritten pragma.
9377 elsif Is_Rewrite_Substitution
(N
)
9378 and then Nkind
(Original_Node
(N
)) = N_Pragma
9379 and then Original_Node
(N
) /= N
9381 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
9382 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
9384 -- Otherwise query the applicable policy at this point
9387 Check_Applicable_Policy
(N
);
9389 -- If pragma is disabled, rewrite as NULL and skip analysis
9391 if Is_Disabled
(N
) then
9392 Rewrite
(N
, Make_Null_Statement
(Loc
));
9406 if Present
(Pragma_Argument_Associations
(N
)) then
9407 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
9408 Arg1
:= First
(Pragma_Argument_Associations
(N
));
9410 if Present
(Arg1
) then
9411 Arg2
:= Next
(Arg1
);
9413 if Present
(Arg2
) then
9414 Arg3
:= Next
(Arg2
);
9416 if Present
(Arg3
) then
9417 Arg4
:= Next
(Arg3
);
9423 Check_Restriction_No_Use_Of_Pragma
(N
);
9425 -- An enumeration type defines the pragmas that are supported by the
9426 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
9427 -- into the corresponding enumeration value for the following case.
9435 -- pragma Abort_Defer;
9437 when Pragma_Abort_Defer
=>
9439 Check_Arg_Count
(0);
9441 -- The only required semantic processing is to check the
9442 -- placement. This pragma must appear at the start of the
9443 -- statement sequence of a handled sequence of statements.
9445 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
9446 or else N
/= First
(Statements
(Parent
(N
)))
9451 --------------------
9452 -- Abstract_State --
9453 --------------------
9455 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
9457 -- ABSTRACT_STATE_LIST ::=
9459 -- | STATE_NAME_WITH_OPTIONS
9460 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} )
9462 -- STATE_NAME_WITH_OPTIONS ::=
9464 -- | (STATE_NAME with OPTION_LIST)
9466 -- OPTION_LIST ::= OPTION {, OPTION}
9470 -- | NAME_VALUE_OPTION
9472 -- SIMPLE_OPTION ::= Ghost
9474 -- NAME_VALUE_OPTION ::=
9475 -- Part_Of => ABSTRACT_STATE
9476 -- | External [=> EXTERNAL_PROPERTY_LIST]
9478 -- EXTERNAL_PROPERTY_LIST ::=
9479 -- EXTERNAL_PROPERTY
9480 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} )
9482 -- EXTERNAL_PROPERTY ::=
9483 -- Async_Readers [=> boolean_EXPRESSION]
9484 -- | Async_Writers [=> boolean_EXPRESSION]
9485 -- | Effective_Reads [=> boolean_EXPRESSION]
9486 -- | Effective_Writes [=> boolean_EXPRESSION]
9487 -- others => boolean_EXPRESSION
9489 -- STATE_NAME ::= defining_identifier
9491 -- ABSTRACT_STATE ::= name
9493 when Pragma_Abstract_State
=> Abstract_State
: declare
9494 Missing_Parentheses
: Boolean := False;
9495 -- Flag set when a state declaration with options is not properly
9498 -- Flags used to verify the consistency of states
9500 Non_Null_Seen
: Boolean := False;
9501 Null_Seen
: Boolean := False;
9503 procedure Analyze_Abstract_State
9505 Pack_Id
: Entity_Id
);
9506 -- Verify the legality of a single state declaration. Create and
9507 -- decorate a state abstraction entity and introduce it into the
9508 -- visibility chain. Pack_Id denotes the entity or the related
9509 -- package where pragma Abstract_State appears.
9511 ----------------------------
9512 -- Analyze_Abstract_State --
9513 ----------------------------
9515 procedure Analyze_Abstract_State
9517 Pack_Id
: Entity_Id
)
9519 -- Flags used to verify the consistency of options
9521 AR_Seen
: Boolean := False;
9522 AW_Seen
: Boolean := False;
9523 ER_Seen
: Boolean := False;
9524 EW_Seen
: Boolean := False;
9525 External_Seen
: Boolean := False;
9526 Others_Seen
: Boolean := False;
9527 Part_Of_Seen
: Boolean := False;
9529 -- Flags used to store the static value of all external states'
9532 AR_Val
: Boolean := False;
9533 AW_Val
: Boolean := False;
9534 ER_Val
: Boolean := False;
9535 EW_Val
: Boolean := False;
9537 State_Id
: Entity_Id
:= Empty
;
9538 -- The entity to be generated for the current state declaration
9540 procedure Analyze_External_Option
(Opt
: Node_Id
);
9541 -- Verify the legality of option External
9543 procedure Analyze_External_Property
9545 Expr
: Node_Id
:= Empty
);
9546 -- Verify the legailty of a single external property. Prop
9547 -- denotes the external property. Expr is the expression used
9548 -- to set the property.
9550 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
9551 -- Verify the legality of option Part_Of
9553 procedure Check_Duplicate_Option
9555 Status
: in out Boolean);
9556 -- Flag Status denotes whether a particular option has been
9557 -- seen while processing a state. This routine verifies that
9558 -- Opt is not a duplicate option and sets the flag Status
9559 -- (SPARK RM 7.1.4(1)).
9561 procedure Check_Duplicate_Property
9563 Status
: in out Boolean);
9564 -- Flag Status denotes whether a particular property has been
9565 -- seen while processing option External. This routine verifies
9566 -- that Prop is not a duplicate property and sets flag Status.
9567 -- Opt is not a duplicate property and sets the flag Status.
9568 -- (SPARK RM 7.1.4(2))
9570 procedure Create_Abstract_State
9575 -- Generate an abstract state entity with name Nam and enter it
9576 -- into visibility. Decl is the "declaration" of the state as
9577 -- it appears in pragma Abstract_State. Loc is the location of
9578 -- the related state "declaration". Flag Is_Null should be set
9579 -- when the associated Abstract_State pragma defines a null
9582 -----------------------------
9583 -- Analyze_External_Option --
9584 -----------------------------
9586 procedure Analyze_External_Option
(Opt
: Node_Id
) is
9587 Errors
: constant Nat
:= Serious_Errors_Detected
;
9589 Props
: Node_Id
:= Empty
;
9592 Check_Duplicate_Option
(Opt
, External_Seen
);
9594 if Nkind
(Opt
) = N_Component_Association
then
9595 Props
:= Expression
(Opt
);
9598 -- External state with properties
9600 if Present
(Props
) then
9602 -- Multiple properties appear as an aggregate
9604 if Nkind
(Props
) = N_Aggregate
then
9606 -- Simple property form
9608 Prop
:= First
(Expressions
(Props
));
9609 while Present
(Prop
) loop
9610 Analyze_External_Property
(Prop
);
9614 -- Property with expression form
9616 Prop
:= First
(Component_Associations
(Props
));
9617 while Present
(Prop
) loop
9618 Analyze_External_Property
9619 (Prop
=> First
(Choices
(Prop
)),
9620 Expr
=> Expression
(Prop
));
9628 Analyze_External_Property
(Props
);
9631 -- An external state defined without any properties defaults
9632 -- all properties to True.
9641 -- Once all external properties have been processed, verify
9642 -- their mutual interaction. Do not perform the check when
9643 -- at least one of the properties is illegal as this will
9644 -- produce a bogus error.
9646 if Errors
= Serious_Errors_Detected
then
9647 Check_External_Properties
9648 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
9650 end Analyze_External_Option
;
9652 -------------------------------
9653 -- Analyze_External_Property --
9654 -------------------------------
9656 procedure Analyze_External_Property
9658 Expr
: Node_Id
:= Empty
)
9663 -- Check the placement of "others" (if available)
9665 if Nkind
(Prop
) = N_Others_Choice
then
9668 ("only one others choice allowed in option External",
9671 Others_Seen
:= True;
9674 elsif Others_Seen
then
9676 ("others must be the last property in option External",
9679 -- The only remaining legal options are the four predefined
9680 -- external properties.
9682 elsif Nkind
(Prop
) = N_Identifier
9683 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
9685 Name_Effective_Reads
,
9686 Name_Effective_Writes
)
9690 -- Otherwise the construct is not a valid property
9693 SPARK_Msg_N
("invalid external state property", Prop
);
9697 -- Ensure that the expression of the external state property
9698 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
9700 if Present
(Expr
) then
9701 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9703 if Is_OK_Static_Expression
(Expr
) then
9704 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
9707 ("expression of external state property must be "
9711 -- The lack of expression defaults the property to True
9719 if Nkind
(Prop
) = N_Identifier
then
9720 if Chars
(Prop
) = Name_Async_Readers
then
9721 Check_Duplicate_Property
(Prop
, AR_Seen
);
9724 elsif Chars
(Prop
) = Name_Async_Writers
then
9725 Check_Duplicate_Property
(Prop
, AW_Seen
);
9728 elsif Chars
(Prop
) = Name_Effective_Reads
then
9729 Check_Duplicate_Property
(Prop
, ER_Seen
);
9733 Check_Duplicate_Property
(Prop
, EW_Seen
);
9737 -- The handling of property "others" must take into account
9738 -- all other named properties that have been encountered so
9739 -- far. Only those that have not been seen are affected by
9759 end Analyze_External_Property
;
9761 ----------------------------
9762 -- Analyze_Part_Of_Option --
9763 ----------------------------
9765 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
9766 Encaps
: constant Node_Id
:= Expression
(Opt
);
9767 Encaps_Id
: Entity_Id
;
9771 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
9774 (Item_Id
=> State_Id
,
9776 Indic
=> First
(Choices
(Opt
)),
9779 -- The Part_Of indicator turns an abstract state into a
9780 -- constituent of the encapsulating state.
9783 Encaps_Id
:= Entity
(Encaps
);
9785 Append_Elmt
(State_Id
, Part_Of_Constituents
(Encaps_Id
));
9786 Set_Encapsulating_State
(State_Id
, Encaps_Id
);
9788 end Analyze_Part_Of_Option
;
9790 ----------------------------
9791 -- Check_Duplicate_Option --
9792 ----------------------------
9794 procedure Check_Duplicate_Option
9796 Status
: in out Boolean)
9800 SPARK_Msg_N
("duplicate state option", Opt
);
9804 end Check_Duplicate_Option
;
9806 ------------------------------
9807 -- Check_Duplicate_Property --
9808 ------------------------------
9810 procedure Check_Duplicate_Property
9812 Status
: in out Boolean)
9816 SPARK_Msg_N
("duplicate external property", Prop
);
9820 end Check_Duplicate_Property
;
9822 ---------------------------
9823 -- Create_Abstract_State --
9824 ---------------------------
9826 procedure Create_Abstract_State
9833 -- The abstract state may be semi-declared when the related
9834 -- package was withed through a limited with clause. In that
9835 -- case reuse the entity to fully declare the state.
9837 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
9838 State_Id
:= Entity
(Decl
);
9840 -- Otherwise the elaboration of pragma Abstract_State
9841 -- declares the state.
9844 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
9846 if Present
(Decl
) then
9847 Set_Entity
(Decl
, State_Id
);
9851 -- Null states never come from source
9853 Set_Comes_From_Source
(State_Id
, not Is_Null
);
9854 Set_Parent
(State_Id
, State
);
9855 Set_Ekind
(State_Id
, E_Abstract_State
);
9856 Set_Etype
(State_Id
, Standard_Void_Type
);
9857 Set_Encapsulating_State
(State_Id
, Empty
);
9858 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
);
9859 Set_Part_Of_Constituents
(State_Id
, New_Elmt_List
);
9861 -- An abstract state declared within a Ghost region becomes
9862 -- Ghost (SPARK RM 6.9(2)).
9864 if Ghost_Mode
> None
then
9865 Set_Is_Ghost_Entity
(State_Id
);
9868 -- Establish a link between the state declaration and the
9869 -- abstract state entity. Note that a null state remains as
9870 -- N_Null and does not carry any linkages.
9873 if Present
(Decl
) then
9874 Set_Entity
(Decl
, State_Id
);
9875 Set_Etype
(Decl
, Standard_Void_Type
);
9878 -- Every non-null state must be defined, nameable and
9881 Push_Scope
(Pack_Id
);
9882 Generate_Definition
(State_Id
);
9883 Enter_Name
(State_Id
);
9886 end Create_Abstract_State
;
9893 -- Start of processing for Analyze_Abstract_State
9896 -- A package with a null abstract state is not allowed to
9897 -- declare additional states.
9901 ("package & has null abstract state", State
, Pack_Id
);
9903 -- Null states appear as internally generated entities
9905 elsif Nkind
(State
) = N_Null
then
9906 Create_Abstract_State
9907 (Nam
=> New_Internal_Name
('S'),
9909 Loc
=> Sloc
(State
),
9913 -- Catch a case where a null state appears in a list of
9916 if Non_Null_Seen
then
9918 ("package & has non-null abstract state",
9922 -- Simple state declaration
9924 elsif Nkind
(State
) = N_Identifier
then
9925 Create_Abstract_State
9926 (Nam
=> Chars
(State
),
9928 Loc
=> Sloc
(State
),
9930 Non_Null_Seen
:= True;
9932 -- State declaration with various options. This construct
9933 -- appears as an extension aggregate in the tree.
9935 elsif Nkind
(State
) = N_Extension_Aggregate
then
9936 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
9937 Create_Abstract_State
9938 (Nam
=> Chars
(Ancestor_Part
(State
)),
9939 Decl
=> Ancestor_Part
(State
),
9940 Loc
=> Sloc
(Ancestor_Part
(State
)),
9942 Non_Null_Seen
:= True;
9945 ("state name must be an identifier",
9946 Ancestor_Part
(State
));
9949 -- Options External and Ghost appear as expressions
9951 Opt
:= First
(Expressions
(State
));
9952 while Present
(Opt
) loop
9953 if Nkind
(Opt
) = N_Identifier
then
9954 if Chars
(Opt
) = Name_External
then
9955 Analyze_External_Option
(Opt
);
9957 elsif Chars
(Opt
) = Name_Ghost
then
9958 if Present
(State_Id
) then
9959 Set_Is_Ghost_Entity
(State_Id
);
9962 -- Option Part_Of without an encapsulating state is
9963 -- illegal. (SPARK RM 7.1.4(9)).
9965 elsif Chars
(Opt
) = Name_Part_Of
then
9967 ("indicator Part_Of must denote an abstract "
9970 -- Do not emit an error message when a previous state
9971 -- declaration with options was not parenthesized as
9972 -- the option is actually another state declaration.
9974 -- with Abstract_State
9975 -- (State_1 with ..., -- missing parentheses
9976 -- (State_2 with ...),
9977 -- State_3) -- ok state declaration
9979 elsif Missing_Parentheses
then
9982 -- Otherwise the option is not allowed. Note that it
9983 -- is not possible to distinguish between an option
9984 -- and a state declaration when a previous state with
9985 -- options not properly parentheses.
9987 -- with Abstract_State
9988 -- (State_1 with ..., -- missing parentheses
9989 -- State_2); -- could be an option
9993 ("simple option not allowed in state declaration",
9997 -- Catch a case where missing parentheses around a state
9998 -- declaration with options cause a subsequent state
9999 -- declaration with options to be treated as an option.
10001 -- with Abstract_State
10002 -- (State_1 with ..., -- missing parentheses
10003 -- (State_2 with ...))
10005 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10006 Missing_Parentheses
:= True;
10008 ("state declaration must be parenthesized",
10009 Ancestor_Part
(State
));
10011 -- Otherwise the option is malformed
10014 SPARK_Msg_N
("malformed option", Opt
);
10020 -- Options External and Part_Of appear as component
10023 Opt
:= First
(Component_Associations
(State
));
10024 while Present
(Opt
) loop
10025 Opt_Nam
:= First
(Choices
(Opt
));
10027 if Nkind
(Opt_Nam
) = N_Identifier
then
10028 if Chars
(Opt_Nam
) = Name_External
then
10029 Analyze_External_Option
(Opt
);
10031 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10032 Analyze_Part_Of_Option
(Opt
);
10035 SPARK_Msg_N
("invalid state option", Opt
);
10038 SPARK_Msg_N
("invalid state option", Opt
);
10044 -- Any other attempt to declare a state is illegal. This is a
10045 -- syntax error, always report.
10048 Error_Msg_N
("malformed abstract state declaration", State
);
10052 -- Guard against a junk state. In such cases no entity is
10053 -- generated and the subsequent checks cannot be applied.
10055 if Present
(State_Id
) then
10057 -- Verify whether the state does not introduce an illegal
10058 -- hidden state within a package subject to a null abstract
10061 Check_No_Hidden_State
(State_Id
);
10063 -- Check whether the lack of option Part_Of agrees with the
10064 -- placement of the abstract state with respect to the state
10067 if not Part_Of_Seen
then
10068 Check_Missing_Part_Of
(State_Id
);
10071 -- Associate the state with its related package
10073 if No
(Abstract_States
(Pack_Id
)) then
10074 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10077 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10079 end Analyze_Abstract_State
;
10083 Pack_Decl
: Node_Id
;
10084 Pack_Id
: Entity_Id
;
10087 -- Start of processing for Abstract_State
10091 Check_No_Identifiers
;
10092 Check_Arg_Count
(1);
10094 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
10096 -- Ensure the proper placement of the pragma. Abstract states must
10097 -- be associated with a package declaration.
10099 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
10100 N_Package_Declaration
)
10104 -- Otherwise the pragma is associated with an illegal construct
10111 Ensure_Aggregate_Form
(Get_Argument
(N
));
10112 Pack_Id
:= Defining_Entity
(Pack_Decl
);
10114 -- Mark the associated package as Ghost if it is subject to aspect
10115 -- or pragma Ghost as this affects the declaration of an abstract
10118 if Is_Subject_To_Ghost
(Unit_Declaration_Node
(Pack_Id
)) then
10119 Set_Is_Ghost_Entity
(Pack_Id
);
10122 State
:= Expression
(Get_Argument
(N
));
10124 -- Multiple non-null abstract states appear as an aggregate
10126 if Nkind
(State
) = N_Aggregate
then
10127 State
:= First
(Expressions
(State
));
10128 while Present
(State
) loop
10129 Analyze_Abstract_State
(State
, Pack_Id
);
10133 -- Various forms of a single abstract state. Note that these may
10134 -- include malformed state declarations.
10137 Analyze_Abstract_State
(State
, Pack_Id
);
10140 -- Save the pragma for retrieval by other tools
10142 Add_Contract_Item
(N
, Pack_Id
);
10144 -- Verify the declaration order of pragmas Abstract_State and
10147 Check_Declaration_Order
10149 Second
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
));
10150 end Abstract_State
;
10158 -- Note: this pragma also has some specific processing in Par.Prag
10159 -- because we want to set the Ada version mode during parsing.
10161 when Pragma_Ada_83
=>
10163 Check_Arg_Count
(0);
10165 -- We really should check unconditionally for proper configuration
10166 -- pragma placement, since we really don't want mixed Ada modes
10167 -- within a single unit, and the GNAT reference manual has always
10168 -- said this was a configuration pragma, but we did not check and
10169 -- are hesitant to add the check now.
10171 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
10172 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
10173 -- or Ada 2012 mode.
10175 if Ada_Version
>= Ada_2005
then
10176 Check_Valid_Configuration_Pragma
;
10179 -- Now set Ada 83 mode
10181 Ada_Version
:= Ada_83
;
10182 Ada_Version_Explicit
:= Ada_83
;
10183 Ada_Version_Pragma
:= N
;
10191 -- Note: this pragma also has some specific processing in Par.Prag
10192 -- because we want to set the Ada 83 version mode during parsing.
10194 when Pragma_Ada_95
=>
10196 Check_Arg_Count
(0);
10198 -- We really should check unconditionally for proper configuration
10199 -- pragma placement, since we really don't want mixed Ada modes
10200 -- within a single unit, and the GNAT reference manual has always
10201 -- said this was a configuration pragma, but we did not check and
10202 -- are hesitant to add the check now.
10204 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
10205 -- or Ada 95, so we must check if we are in Ada 2005 mode.
10207 if Ada_Version
>= Ada_2005
then
10208 Check_Valid_Configuration_Pragma
;
10211 -- Now set Ada 95 mode
10213 Ada_Version
:= Ada_95
;
10214 Ada_Version_Explicit
:= Ada_95
;
10215 Ada_Version_Pragma
:= N
;
10217 ---------------------
10218 -- Ada_05/Ada_2005 --
10219 ---------------------
10222 -- pragma Ada_05 (LOCAL_NAME);
10224 -- pragma Ada_2005;
10225 -- pragma Ada_2005 (LOCAL_NAME):
10227 -- Note: these pragmas also have some specific processing in Par.Prag
10228 -- because we want to set the Ada 2005 version mode during parsing.
10230 -- The one argument form is used for managing the transition from
10231 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
10232 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
10233 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
10234 -- mode, a preference rule is established which does not choose
10235 -- such an entity unless it is unambiguously specified. This avoids
10236 -- extra subprograms marked this way from generating ambiguities in
10237 -- otherwise legal pre-Ada_2005 programs. The one argument form is
10238 -- intended for exclusive use in the GNAT run-time library.
10240 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
10246 if Arg_Count
= 1 then
10247 Check_Arg_Is_Local_Name
(Arg1
);
10248 E_Id
:= Get_Pragma_Arg
(Arg1
);
10250 if Etype
(E_Id
) = Any_Type
then
10254 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
10255 Record_Rep_Item
(Entity
(E_Id
), N
);
10258 Check_Arg_Count
(0);
10260 -- For Ada_2005 we unconditionally enforce the documented
10261 -- configuration pragma placement, since we do not want to
10262 -- tolerate mixed modes in a unit involving Ada 2005. That
10263 -- would cause real difficulties for those cases where there
10264 -- are incompatibilities between Ada 95 and Ada 2005.
10266 Check_Valid_Configuration_Pragma
;
10268 -- Now set appropriate Ada mode
10270 Ada_Version
:= Ada_2005
;
10271 Ada_Version_Explicit
:= Ada_2005
;
10272 Ada_Version_Pragma
:= N
;
10276 ---------------------
10277 -- Ada_12/Ada_2012 --
10278 ---------------------
10281 -- pragma Ada_12 (LOCAL_NAME);
10283 -- pragma Ada_2012;
10284 -- pragma Ada_2012 (LOCAL_NAME):
10286 -- Note: these pragmas also have some specific processing in Par.Prag
10287 -- because we want to set the Ada 2012 version mode during parsing.
10289 -- The one argument form is used for managing the transition from Ada
10290 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
10291 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
10292 -- mode will generate a warning. In addition, in any pre-Ada_2012
10293 -- mode, a preference rule is established which does not choose
10294 -- such an entity unless it is unambiguously specified. This avoids
10295 -- extra subprograms marked this way from generating ambiguities in
10296 -- otherwise legal pre-Ada_2012 programs. The one argument form is
10297 -- intended for exclusive use in the GNAT run-time library.
10299 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
10305 if Arg_Count
= 1 then
10306 Check_Arg_Is_Local_Name
(Arg1
);
10307 E_Id
:= Get_Pragma_Arg
(Arg1
);
10309 if Etype
(E_Id
) = Any_Type
then
10313 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
10314 Record_Rep_Item
(Entity
(E_Id
), N
);
10317 Check_Arg_Count
(0);
10319 -- For Ada_2012 we unconditionally enforce the documented
10320 -- configuration pragma placement, since we do not want to
10321 -- tolerate mixed modes in a unit involving Ada 2012. That
10322 -- would cause real difficulties for those cases where there
10323 -- are incompatibilities between Ada 95 and Ada 2012. We could
10324 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
10326 Check_Valid_Configuration_Pragma
;
10328 -- Now set appropriate Ada mode
10330 Ada_Version
:= Ada_2012
;
10331 Ada_Version_Explicit
:= Ada_2012
;
10332 Ada_Version_Pragma
:= N
;
10336 ----------------------
10337 -- All_Calls_Remote --
10338 ----------------------
10340 -- pragma All_Calls_Remote [(library_package_NAME)];
10342 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
10343 Lib_Entity
: Entity_Id
;
10346 Check_Ada_83_Warning
;
10347 Check_Valid_Library_Unit_Pragma
;
10349 if Nkind
(N
) = N_Null_Statement
then
10353 Lib_Entity
:= Find_Lib_Unit_Name
;
10355 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
10357 if Present
(Lib_Entity
)
10358 and then not Debug_Flag_U
10360 if not Is_Remote_Call_Interface
(Lib_Entity
) then
10361 Error_Pragma
("pragma% only apply to rci unit");
10363 -- Set flag for entity of the library unit
10366 Set_Has_All_Calls_Remote
(Lib_Entity
);
10370 end All_Calls_Remote
;
10372 ---------------------------
10373 -- Allow_Integer_Address --
10374 ---------------------------
10376 -- pragma Allow_Integer_Address;
10378 when Pragma_Allow_Integer_Address
=>
10380 Check_Valid_Configuration_Pragma
;
10381 Check_Arg_Count
(0);
10383 -- If Address is a private type, then set the flag to allow
10384 -- integer address values. If Address is not private, then this
10385 -- pragma has no purpose, so it is simply ignored. Not clear if
10386 -- there are any such targets now.
10388 if Opt
.Address_Is_Private
then
10389 Opt
.Allow_Integer_Address
:= True;
10397 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
10398 -- ARG ::= NAME | EXPRESSION
10400 -- The first two arguments are by convention intended to refer to an
10401 -- external tool and a tool-specific function. These arguments are
10404 when Pragma_Annotate
=> Annotate
: declare
10410 Check_At_Least_N_Arguments
(1);
10412 -- See if last argument is Entity => local_Name, and if so process
10413 -- and then remove it for remaining processing.
10416 Last_Arg
: constant Node_Id
:=
10417 Last
(Pragma_Argument_Associations
(N
));
10420 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
10421 and then Chars
(Last_Arg
) = Name_Entity
10423 Check_Arg_Is_Local_Name
(Last_Arg
);
10424 Arg_Count
:= Arg_Count
- 1;
10426 -- Not allowed in compiler units (bootstrap issues)
10428 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
10432 -- Continue processing with last argument removed for now
10434 Check_Arg_Is_Identifier
(Arg1
);
10435 Check_No_Identifiers
;
10438 -- Second parameter is optional, it is never analyzed
10443 -- Here if we have a second parameter
10446 -- Second parameter must be identifier
10448 Check_Arg_Is_Identifier
(Arg2
);
10450 -- Process remaining parameters if any
10452 Arg
:= Next
(Arg2
);
10453 while Present
(Arg
) loop
10454 Exp
:= Get_Pragma_Arg
(Arg
);
10457 if Is_Entity_Name
(Exp
) then
10460 -- For string literals, we assume Standard_String as the
10461 -- type, unless the string contains wide or wide_wide
10464 elsif Nkind
(Exp
) = N_String_Literal
then
10465 if Has_Wide_Wide_Character
(Exp
) then
10466 Resolve
(Exp
, Standard_Wide_Wide_String
);
10467 elsif Has_Wide_Character
(Exp
) then
10468 Resolve
(Exp
, Standard_Wide_String
);
10470 Resolve
(Exp
, Standard_String
);
10473 elsif Is_Overloaded
(Exp
) then
10475 ("ambiguous argument for pragma%", Exp
);
10486 -------------------------------------------------
10487 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
10488 -------------------------------------------------
10491 -- ( [Check => ] Boolean_EXPRESSION
10492 -- [, [Message =>] Static_String_EXPRESSION]);
10494 -- pragma Assert_And_Cut
10495 -- ( [Check => ] Boolean_EXPRESSION
10496 -- [, [Message =>] Static_String_EXPRESSION]);
10499 -- ( [Check => ] Boolean_EXPRESSION
10500 -- [, [Message =>] Static_String_EXPRESSION]);
10502 -- pragma Loop_Invariant
10503 -- ( [Check => ] Boolean_EXPRESSION
10504 -- [, [Message =>] Static_String_EXPRESSION]);
10506 when Pragma_Assert |
10507 Pragma_Assert_And_Cut |
10509 Pragma_Loop_Invariant
=>
10511 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
10512 -- Determine whether expression Expr contains a Loop_Entry
10513 -- attribute reference.
10515 -------------------------
10516 -- Contains_Loop_Entry --
10517 -------------------------
10519 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
10520 Has_Loop_Entry
: Boolean := False;
10522 function Process
(N
: Node_Id
) return Traverse_Result
;
10523 -- Process function for traversal to look for Loop_Entry
10529 function Process
(N
: Node_Id
) return Traverse_Result
is
10531 if Nkind
(N
) = N_Attribute_Reference
10532 and then Attribute_Name
(N
) = Name_Loop_Entry
10534 Has_Loop_Entry
:= True;
10541 procedure Traverse
is new Traverse_Proc
(Process
);
10543 -- Start of processing for Contains_Loop_Entry
10547 return Has_Loop_Entry
;
10548 end Contains_Loop_Entry
;
10555 -- Start of processing for Assert
10558 -- Assert is an Ada 2005 RM-defined pragma
10560 if Prag_Id
= Pragma_Assert
then
10563 -- The remaining ones are GNAT pragmas
10569 Check_At_Least_N_Arguments
(1);
10570 Check_At_Most_N_Arguments
(2);
10571 Check_Arg_Order
((Name_Check
, Name_Message
));
10572 Check_Optional_Identifier
(Arg1
, Name_Check
);
10573 Expr
:= Get_Pragma_Arg
(Arg1
);
10575 -- Special processing for Loop_Invariant, Loop_Variant or for
10576 -- other cases where a Loop_Entry attribute is present. If the
10577 -- assertion pragma contains attribute Loop_Entry, ensure that
10578 -- the related pragma is within a loop.
10580 if Prag_Id
= Pragma_Loop_Invariant
10581 or else Prag_Id
= Pragma_Loop_Variant
10582 or else Contains_Loop_Entry
(Expr
)
10584 Check_Loop_Pragma_Placement
;
10586 -- Perform preanalysis to deal with embedded Loop_Entry
10589 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
10592 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
10593 -- a corresponding Check pragma:
10595 -- pragma Check (name, condition [, msg]);
10597 -- Where name is the identifier matching the pragma name. So
10598 -- rewrite pragma in this manner, transfer the message argument
10599 -- if present, and analyze the result
10601 -- Note: When dealing with a semantically analyzed tree, the
10602 -- information that a Check node N corresponds to a source Assert,
10603 -- Assume, or Assert_And_Cut pragma can be retrieved from the
10604 -- pragma kind of Original_Node(N).
10607 Make_Pragma_Argument_Association
(Loc
,
10608 Expression
=> Make_Identifier
(Loc
, Pname
)),
10609 Make_Pragma_Argument_Association
(Sloc
(Expr
),
10610 Expression
=> Expr
));
10612 if Arg_Count
> 1 then
10613 Check_Optional_Identifier
(Arg2
, Name_Message
);
10615 -- Provide semantic annnotations for optional argument, for
10616 -- ASIS use, before rewriting.
10618 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
10619 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
10622 -- Rewrite as Check pragma
10626 Chars
=> Name_Check
,
10627 Pragma_Argument_Associations
=> Newa
));
10631 ----------------------
10632 -- Assertion_Policy --
10633 ----------------------
10635 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
10637 -- The following form is Ada 2012 only, but we allow it in all modes
10639 -- Pragma Assertion_Policy (
10640 -- ASSERTION_KIND => POLICY_IDENTIFIER
10641 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
10643 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
10645 -- RM_ASSERTION_KIND ::= Assert |
10646 -- Static_Predicate |
10647 -- Dynamic_Predicate |
10652 -- Type_Invariant |
10653 -- Type_Invariant'Class
10655 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
10657 -- Contract_Cases |
10659 -- Default_Initial_Condition |
10661 -- Initial_Condition |
10662 -- Loop_Invariant |
10668 -- Statement_Assertions
10670 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
10671 -- ID_ASSERTION_KIND list contains implementation-defined additions
10672 -- recognized by GNAT. The effect is to control the behavior of
10673 -- identically named aspects and pragmas, depending on the specified
10674 -- policy identifier:
10676 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
10678 -- Note: Check and Ignore are language-defined. Disable is a GNAT
10679 -- implementation defined addition that results in totally ignoring
10680 -- the corresponding assertion. If Disable is specified, then the
10681 -- argument of the assertion is not even analyzed. This is useful
10682 -- when the aspect/pragma argument references entities in a with'ed
10683 -- package that is replaced by a dummy package in the final build.
10685 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
10686 -- and Type_Invariant'Class were recognized by the parser and
10687 -- transformed into references to the special internal identifiers
10688 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
10689 -- processing is required here.
10691 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
10700 -- This can always appear as a configuration pragma
10702 if Is_Configuration_Pragma
then
10705 -- It can also appear in a declarative part or package spec in Ada
10706 -- 2012 mode. We allow this in other modes, but in that case we
10707 -- consider that we have an Ada 2012 pragma on our hands.
10710 Check_Is_In_Decl_Part_Or_Package_Spec
;
10714 -- One argument case with no identifier (first form above)
10717 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
10718 or else Chars
(Arg1
) = No_Name
)
10720 Check_Arg_Is_One_Of
10721 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
10723 -- Treat one argument Assertion_Policy as equivalent to:
10725 -- pragma Check_Policy (Assertion, policy)
10727 -- So rewrite pragma in that manner and link on to the chain
10728 -- of Check_Policy pragmas, marking the pragma as analyzed.
10730 Policy
:= Get_Pragma_Arg
(Arg1
);
10734 Chars
=> Name_Check_Policy
,
10735 Pragma_Argument_Associations
=> New_List
(
10736 Make_Pragma_Argument_Association
(Loc
,
10737 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
10739 Make_Pragma_Argument_Association
(Loc
,
10741 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
10744 -- Here if we have two or more arguments
10747 Check_At_Least_N_Arguments
(1);
10750 -- Loop through arguments
10753 while Present
(Arg
) loop
10754 LocP
:= Sloc
(Arg
);
10756 -- Kind must be specified
10758 if Nkind
(Arg
) /= N_Pragma_Argument_Association
10759 or else Chars
(Arg
) = No_Name
10762 ("missing assertion kind for pragma%", Arg
);
10765 -- Check Kind and Policy have allowed forms
10767 Kind
:= Chars
(Arg
);
10769 if not Is_Valid_Assertion_Kind
(Kind
) then
10771 ("invalid assertion kind for pragma%", Arg
);
10774 Check_Arg_Is_One_Of
10775 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
10777 -- Rewrite the Assertion_Policy pragma as a series of
10778 -- Check_Policy pragmas of the form:
10780 -- Check_Policy (Kind, Policy);
10782 -- Note: the insertion of the pragmas cannot be done with
10783 -- Insert_Action because in the configuration case, there
10784 -- are no scopes on the scope stack and the mechanism will
10787 Insert_Before_And_Analyze
(N
,
10789 Chars
=> Name_Check_Policy
,
10790 Pragma_Argument_Associations
=> New_List
(
10791 Make_Pragma_Argument_Association
(LocP
,
10792 Expression
=> Make_Identifier
(LocP
, Kind
)),
10793 Make_Pragma_Argument_Association
(LocP
,
10794 Expression
=> Get_Pragma_Arg
(Arg
)))));
10799 -- Rewrite the Assertion_Policy pragma as null since we have
10800 -- now inserted all the equivalent Check pragmas.
10802 Rewrite
(N
, Make_Null_Statement
(Loc
));
10805 end Assertion_Policy
;
10807 ------------------------------
10808 -- Assume_No_Invalid_Values --
10809 ------------------------------
10811 -- pragma Assume_No_Invalid_Values (On | Off);
10813 when Pragma_Assume_No_Invalid_Values
=>
10815 Check_Valid_Configuration_Pragma
;
10816 Check_Arg_Count
(1);
10817 Check_No_Identifiers
;
10818 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
10820 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
10821 Assume_No_Invalid_Values
:= True;
10823 Assume_No_Invalid_Values
:= False;
10826 --------------------------
10827 -- Attribute_Definition --
10828 --------------------------
10830 -- pragma Attribute_Definition
10831 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
10832 -- [Entity =>] LOCAL_NAME,
10833 -- [Expression =>] EXPRESSION | NAME);
10835 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
10836 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
10841 Check_Arg_Count
(3);
10842 Check_Optional_Identifier
(Arg1
, "attribute");
10843 Check_Optional_Identifier
(Arg2
, "entity");
10844 Check_Optional_Identifier
(Arg3
, "expression");
10846 if Nkind
(Attribute_Designator
) /= N_Identifier
then
10847 Error_Msg_N
("attribute name expected", Attribute_Designator
);
10851 Check_Arg_Is_Local_Name
(Arg2
);
10853 -- If the attribute is not recognized, then issue a warning (not
10854 -- an error), and ignore the pragma.
10856 Aname
:= Chars
(Attribute_Designator
);
10858 if not Is_Attribute_Name
(Aname
) then
10859 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
10863 -- Otherwise, rewrite the pragma as an attribute definition clause
10866 Make_Attribute_Definition_Clause
(Loc
,
10867 Name
=> Get_Pragma_Arg
(Arg2
),
10869 Expression
=> Get_Pragma_Arg
(Arg3
)));
10871 end Attribute_Definition
;
10873 ------------------------------------------------------------------
10874 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
10875 ------------------------------------------------------------------
10877 -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] );
10878 -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] );
10879 -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] );
10880 -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] );
10882 -- FLAG ::= boolean_EXPRESSION
10884 when Pragma_Async_Readers |
10885 Pragma_Async_Writers |
10886 Pragma_Effective_Reads |
10887 Pragma_Effective_Writes
=>
10888 Async_Effective
: declare
10892 Obj_Id
: Entity_Id
;
10896 Check_No_Identifiers
;
10897 Check_At_Least_N_Arguments
(1);
10898 Check_At_Most_N_Arguments
(2);
10899 Check_Arg_Is_Local_Name
(Arg1
);
10900 Error_Msg_Name_1
:= Pname
;
10902 Obj
:= Get_Pragma_Arg
(Arg1
);
10903 Expr
:= Get_Pragma_Arg
(Arg2
);
10905 -- Perform minimal verification to ensure that the argument is at
10906 -- least a variable. Subsequent finer grained checks will be done
10907 -- at the end of the declarative region the contains the pragma.
10909 if Is_Entity_Name
(Obj
)
10910 and then Present
(Entity
(Obj
))
10911 and then Ekind
(Entity
(Obj
)) = E_Variable
10913 Obj_Id
:= Entity
(Obj
);
10915 -- Detect a duplicate pragma. Note that it is not efficient to
10916 -- examine preceding statements as Boolean aspects may appear
10917 -- anywhere between the related object declaration and its
10918 -- freeze point. As an alternative, inspect the contents of the
10919 -- variable contract.
10921 Duplic
:= Get_Pragma
(Obj_Id
, Prag_Id
);
10923 if Present
(Duplic
) then
10924 Error_Msg_Sloc
:= Sloc
(Duplic
);
10925 Error_Msg_N
("pragma % duplicates pragma declared #", N
);
10927 -- No duplicate detected
10930 if Present
(Expr
) then
10931 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
10934 -- Chain the pragma on the contract for further processing
10936 Add_Contract_Item
(N
, Obj_Id
);
10939 Error_Pragma
("pragma % must apply to a volatile object");
10941 end Async_Effective
;
10947 -- pragma Asynchronous (LOCAL_NAME);
10949 when Pragma_Asynchronous
=> Asynchronous
: declare
10955 Formal
: Entity_Id
;
10957 procedure Process_Async_Pragma
;
10958 -- Common processing for procedure and access-to-procedure case
10960 --------------------------
10961 -- Process_Async_Pragma --
10962 --------------------------
10964 procedure Process_Async_Pragma
is
10967 Set_Is_Asynchronous
(Nm
);
10971 -- The formals should be of mode IN (RM E.4.1(6))
10974 while Present
(S
) loop
10975 Formal
:= Defining_Identifier
(S
);
10977 if Nkind
(Formal
) = N_Defining_Identifier
10978 and then Ekind
(Formal
) /= E_In_Parameter
10981 ("pragma% procedure can only have IN parameter",
10988 Set_Is_Asynchronous
(Nm
);
10989 end Process_Async_Pragma
;
10991 -- Start of processing for pragma Asynchronous
10994 Check_Ada_83_Warning
;
10995 Check_No_Identifiers
;
10996 Check_Arg_Count
(1);
10997 Check_Arg_Is_Local_Name
(Arg1
);
10999 if Debug_Flag_U
then
11003 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11004 Analyze
(Get_Pragma_Arg
(Arg1
));
11005 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11007 if not Is_Remote_Call_Interface
(C_Ent
)
11008 and then not Is_Remote_Types
(C_Ent
)
11010 -- This pragma should only appear in an RCI or Remote Types
11011 -- unit (RM E.4.1(4)).
11014 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11017 if Ekind
(Nm
) = E_Procedure
11018 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11020 if not Is_Remote_Call_Interface
(Nm
) then
11022 ("pragma% cannot be applied on non-remote procedure",
11026 L
:= Parameter_Specifications
(Parent
(Nm
));
11027 Process_Async_Pragma
;
11030 elsif Ekind
(Nm
) = E_Function
then
11032 ("pragma% cannot be applied to function", Arg1
);
11034 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11035 if Is_Record_Type
(Nm
) then
11037 -- A record type that is the Equivalent_Type for a remote
11038 -- access-to-subprogram type.
11040 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11043 -- A non-expanded RAS type (distribution is not enabled)
11045 N
:= Declaration_Node
(Nm
);
11048 if Nkind
(N
) = N_Full_Type_Declaration
11049 and then Nkind
(Type_Definition
(N
)) =
11050 N_Access_Procedure_Definition
11052 L
:= Parameter_Specifications
(Type_Definition
(N
));
11053 Process_Async_Pragma
;
11055 if Is_Asynchronous
(Nm
)
11056 and then Expander_Active
11057 and then Get_PCS_Name
/= Name_No_DSA
11059 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11064 ("pragma% cannot reference access-to-function type",
11068 -- Only other possibility is Access-to-class-wide type
11070 elsif Is_Access_Type
(Nm
)
11071 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11073 Check_First_Subtype
(Arg1
);
11074 Set_Is_Asynchronous
(Nm
);
11075 if Expander_Active
then
11076 RACW_Type_Is_Asynchronous
(Nm
);
11080 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
11088 -- pragma Atomic (LOCAL_NAME);
11090 when Pragma_Atomic
=>
11091 Process_Atomic_Independent_Shared_Volatile
;
11093 -----------------------
11094 -- Atomic_Components --
11095 -----------------------
11097 -- pragma Atomic_Components (array_LOCAL_NAME);
11099 -- This processing is shared by Volatile_Components
11101 when Pragma_Atomic_Components |
11102 Pragma_Volatile_Components
=>
11104 Atomic_Components
: declare
11111 Check_Ada_83_Warning
;
11112 Check_No_Identifiers
;
11113 Check_Arg_Count
(1);
11114 Check_Arg_Is_Local_Name
(Arg1
);
11115 E_Id
:= Get_Pragma_Arg
(Arg1
);
11117 if Etype
(E_Id
) = Any_Type
then
11121 E
:= Entity
(E_Id
);
11123 Check_Duplicate_Pragma
(E
);
11125 if Rep_Item_Too_Early
(E
, N
)
11127 Rep_Item_Too_Late
(E
, N
)
11132 D
:= Declaration_Node
(E
);
11135 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
11137 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
11138 and then Nkind
(D
) = N_Object_Declaration
11139 and then Nkind
(Object_Definition
(D
)) =
11140 N_Constrained_Array_Definition
)
11142 -- The flag is set on the object, or on the base type
11144 if Nkind
(D
) /= N_Object_Declaration
then
11145 E
:= Base_Type
(E
);
11148 -- Atomic implies both Independent and Volatile
11150 if Prag_Id
= Pragma_Atomic_Components
then
11151 Set_Has_Atomic_Components
(E
);
11152 Set_Has_Independent_Components
(E
);
11155 Set_Has_Volatile_Components
(E
);
11158 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
11160 end Atomic_Components
;
11162 --------------------
11163 -- Attach_Handler --
11164 --------------------
11166 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
11168 when Pragma_Attach_Handler
=>
11169 Check_Ada_83_Warning
;
11170 Check_No_Identifiers
;
11171 Check_Arg_Count
(2);
11173 if No_Run_Time_Mode
then
11174 Error_Msg_CRT
("Attach_Handler pragma", N
);
11176 Check_Interrupt_Or_Attach_Handler
;
11178 -- The expression that designates the attribute may depend on a
11179 -- discriminant, and is therefore a per-object expression, to
11180 -- be expanded in the init proc. If expansion is enabled, then
11181 -- perform semantic checks on a copy only.
11186 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11189 -- In Relaxed_RM_Semantics mode, we allow any static
11190 -- integer value, for compatibility with other compilers.
11192 if Relaxed_RM_Semantics
11193 and then Nkind
(Parg2
) = N_Integer_Literal
11195 Typ
:= Standard_Integer
;
11197 Typ
:= RTE
(RE_Interrupt_ID
);
11200 if Expander_Active
then
11201 Temp
:= New_Copy_Tree
(Parg2
);
11202 Set_Parent
(Temp
, N
);
11203 Preanalyze_And_Resolve
(Temp
, Typ
);
11206 Resolve
(Parg2
, Typ
);
11210 Process_Interrupt_Or_Attach_Handler
;
11213 --------------------
11214 -- C_Pass_By_Copy --
11215 --------------------
11217 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
11219 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
11225 Check_Valid_Configuration_Pragma
;
11226 Check_Arg_Count
(1);
11227 Check_Optional_Identifier
(Arg1
, "max_size");
11229 Arg
:= Get_Pragma_Arg
(Arg1
);
11230 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
11232 Val
:= Expr_Value
(Arg
);
11236 ("maximum size for pragma% must be positive", Arg1
);
11238 elsif UI_Is_In_Int_Range
(Val
) then
11239 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
11241 -- If a giant value is given, Int'Last will do well enough.
11242 -- If sometime someone complains that a record larger than
11243 -- two gigabytes is not copied, we will worry about it then.
11246 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
11248 end C_Pass_By_Copy
;
11254 -- pragma Check ([Name =>] CHECK_KIND,
11255 -- [Check =>] Boolean_EXPRESSION
11256 -- [,[Message =>] String_EXPRESSION]);
11258 -- CHECK_KIND ::= IDENTIFIER |
11261 -- Invariant'Class |
11262 -- Type_Invariant'Class
11264 -- The identifiers Assertions and Statement_Assertions are not
11265 -- allowed, since they have special meaning for Check_Policy.
11267 when Pragma_Check
=> Check
: declare
11275 Check_At_Least_N_Arguments
(2);
11276 Check_At_Most_N_Arguments
(3);
11277 Check_Optional_Identifier
(Arg1
, Name_Name
);
11278 Check_Optional_Identifier
(Arg2
, Name_Check
);
11280 if Arg_Count
= 3 then
11281 Check_Optional_Identifier
(Arg3
, Name_Message
);
11282 Str
:= Get_Pragma_Arg
(Arg3
);
11285 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
11286 Check_Arg_Is_Identifier
(Arg1
);
11287 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
11289 -- Check forbidden name Assertions or Statement_Assertions
11292 when Name_Assertions
=>
11294 ("""Assertions"" is not allowed as a check kind "
11295 & "for pragma%", Arg1
);
11297 when Name_Statement_Assertions
=>
11299 ("""Statement_Assertions"" is not allowed as a check kind "
11300 & "for pragma%", Arg1
);
11306 -- Check applicable policy. We skip this if Checked/Ignored status
11307 -- is already set (e.g. in the casse of a pragma from an aspect).
11309 if Is_Checked
(N
) or else Is_Ignored
(N
) then
11312 -- For a non-source pragma that is a rewriting of another pragma,
11313 -- copy the Is_Checked/Ignored status from the rewritten pragma.
11315 elsif Is_Rewrite_Substitution
(N
)
11316 and then Nkind
(Original_Node
(N
)) = N_Pragma
11317 and then Original_Node
(N
) /= N
11319 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11320 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11322 -- Otherwise query the applicable policy at this point
11325 case Check_Kind
(Cname
) is
11326 when Name_Ignore
=>
11327 Set_Is_Ignored
(N
, True);
11328 Set_Is_Checked
(N
, False);
11331 Set_Is_Ignored
(N
, False);
11332 Set_Is_Checked
(N
, True);
11334 -- For disable, rewrite pragma as null statement and skip
11335 -- rest of the analysis of the pragma.
11337 when Name_Disable
=>
11338 Rewrite
(N
, Make_Null_Statement
(Loc
));
11342 -- No other possibilities
11345 raise Program_Error
;
11349 -- If check kind was not Disable, then continue pragma analysis
11351 Expr
:= Get_Pragma_Arg
(Arg2
);
11353 -- Deal with SCO generation
11356 when Name_Predicate |
11359 -- Nothing to do: since checks occur in client units,
11360 -- the SCO for the aspect in the declaration unit is
11361 -- conservatively always enabled.
11367 if Is_Checked
(N
) and then not Split_PPC
(N
) then
11369 -- Mark aspect/pragma SCO as enabled
11371 Set_SCO_Pragma_Enabled
(Loc
);
11375 -- Deal with analyzing the string argument.
11377 if Arg_Count
= 3 then
11379 -- If checks are not on we don't want any expansion (since
11380 -- such expansion would not get properly deleted) but
11381 -- we do want to analyze (to get proper references).
11382 -- The Preanalyze_And_Resolve routine does just what we want
11384 if Is_Ignored
(N
) then
11385 Preanalyze_And_Resolve
(Str
, Standard_String
);
11387 -- Otherwise we need a proper analysis and expansion
11390 Analyze_And_Resolve
(Str
, Standard_String
);
11394 -- Now you might think we could just do the same with the Boolean
11395 -- expression if checks are off (and expansion is on) and then
11396 -- rewrite the check as a null statement. This would work but we
11397 -- would lose the useful warnings about an assertion being bound
11398 -- to fail even if assertions are turned off.
11400 -- So instead we wrap the boolean expression in an if statement
11401 -- that looks like:
11403 -- if False and then condition then
11407 -- The reason we do this rewriting during semantic analysis rather
11408 -- than as part of normal expansion is that we cannot analyze and
11409 -- expand the code for the boolean expression directly, or it may
11410 -- cause insertion of actions that would escape the attempt to
11411 -- suppress the check code.
11413 -- Note that the Sloc for the if statement corresponds to the
11414 -- argument condition, not the pragma itself. The reason for
11415 -- this is that we may generate a warning if the condition is
11416 -- False at compile time, and we do not want to delete this
11417 -- warning when we delete the if statement.
11419 if Expander_Active
and Is_Ignored
(N
) then
11420 Eloc
:= Sloc
(Expr
);
11423 Make_If_Statement
(Eloc
,
11425 Make_And_Then
(Eloc
,
11426 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
11427 Right_Opnd
=> Expr
),
11428 Then_Statements
=> New_List
(
11429 Make_Null_Statement
(Eloc
))));
11431 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11433 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11435 -- Check is active or expansion not active. In these cases we can
11436 -- just go ahead and analyze the boolean with no worries.
11439 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
11440 Analyze_And_Resolve
(Expr
, Any_Boolean
);
11441 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
11445 --------------------------
11446 -- Check_Float_Overflow --
11447 --------------------------
11449 -- pragma Check_Float_Overflow;
11451 when Pragma_Check_Float_Overflow
=>
11453 Check_Valid_Configuration_Pragma
;
11454 Check_Arg_Count
(0);
11455 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
11461 -- pragma Check_Name (check_IDENTIFIER);
11463 when Pragma_Check_Name
=>
11465 Check_No_Identifiers
;
11466 Check_Valid_Configuration_Pragma
;
11467 Check_Arg_Count
(1);
11468 Check_Arg_Is_Identifier
(Arg1
);
11471 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
11474 for J
in Check_Names
.First
.. Check_Names
.Last
loop
11475 if Check_Names
.Table
(J
) = Nam
then
11480 Check_Names
.Append
(Nam
);
11487 -- This is the old style syntax, which is still allowed in all modes:
11489 -- pragma Check_Policy ([Name =>] CHECK_KIND
11490 -- [Policy =>] POLICY_IDENTIFIER);
11492 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
11494 -- CHECK_KIND ::= IDENTIFIER |
11497 -- Type_Invariant'Class |
11500 -- This is the new style syntax, compatible with Assertion_Policy
11501 -- and also allowed in all modes.
11503 -- Pragma Check_Policy (
11504 -- CHECK_KIND => POLICY_IDENTIFIER
11505 -- {, CHECK_KIND => POLICY_IDENTIFIER});
11507 -- Note: the identifiers Name and Policy are not allowed as
11508 -- Check_Kind values. This avoids ambiguities between the old and
11509 -- new form syntax.
11511 when Pragma_Check_Policy
=> Check_Policy
: declare
11517 Check_At_Least_N_Arguments
(1);
11519 -- A Check_Policy pragma can appear either as a configuration
11520 -- pragma, or in a declarative part or a package spec (see RM
11521 -- 11.5(5) for rules for Suppress/Unsuppress which are also
11522 -- followed for Check_Policy).
11524 if not Is_Configuration_Pragma
then
11525 Check_Is_In_Decl_Part_Or_Package_Spec
;
11528 -- Figure out if we have the old or new syntax. We have the
11529 -- old syntax if the first argument has no identifier, or the
11530 -- identifier is Name.
11532 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
11533 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
11537 Check_Arg_Count
(2);
11538 Check_Optional_Identifier
(Arg1
, Name_Name
);
11539 Kind
:= Get_Pragma_Arg
(Arg1
);
11540 Rewrite_Assertion_Kind
(Kind
);
11541 Check_Arg_Is_Identifier
(Arg1
);
11543 -- Check forbidden check kind
11545 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
11546 Error_Msg_Name_2
:= Chars
(Kind
);
11548 ("pragma% does not allow% as check name", Arg1
);
11553 Check_Optional_Identifier
(Arg2
, Name_Policy
);
11554 Check_Arg_Is_One_Of
11556 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
11557 Ident
:= Get_Pragma_Arg
(Arg2
);
11559 if Chars
(Kind
) = Name_Ghost
then
11561 -- Pragma Check_Policy specifying a Ghost policy cannot
11562 -- occur within a ghost subprogram or package.
11564 if Ghost_Mode
> None
then
11566 ("pragma % cannot appear within ghost subprogram or "
11569 -- The policy identifier of pragma Ghost must be either
11570 -- Check or Ignore (SPARK RM 6.9(7)).
11572 elsif not Nam_In
(Chars
(Ident
), Name_Check
,
11576 ("argument of pragma % Ghost must be Check or Ignore",
11581 -- And chain pragma on the Check_Policy_List for search
11583 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
11584 Opt
.Check_Policy_List
:= N
;
11586 -- For the new syntax, what we do is to convert each argument to
11587 -- an old syntax equivalent. We do that because we want to chain
11588 -- old style Check_Policy pragmas for the search (we don't want
11589 -- to have to deal with multiple arguments in the search).
11599 while Present
(Arg
) loop
11600 LocP
:= Sloc
(Arg
);
11601 Argx
:= Get_Pragma_Arg
(Arg
);
11603 -- Kind must be specified
11605 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11606 or else Chars
(Arg
) = No_Name
11609 ("missing assertion kind for pragma%", Arg
);
11612 -- Construct equivalent old form syntax Check_Policy
11613 -- pragma and insert it to get remaining checks.
11617 Chars
=> Name_Check_Policy
,
11618 Pragma_Argument_Associations
=> New_List
(
11619 Make_Pragma_Argument_Association
(LocP
,
11621 Make_Identifier
(LocP
, Chars
(Arg
))),
11622 Make_Pragma_Argument_Association
(Sloc
(Argx
),
11623 Expression
=> Argx
))));
11628 -- Rewrite original Check_Policy pragma to null, since we
11629 -- have converted it into a series of old syntax pragmas.
11631 Rewrite
(N
, Make_Null_Statement
(Loc
));
11637 ---------------------
11638 -- CIL_Constructor --
11639 ---------------------
11641 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
11643 -- Processing for this pragma is shared with Java_Constructor
11649 -- pragma Comment (static_string_EXPRESSION)
11651 -- Processing for pragma Comment shares the circuitry for pragma
11652 -- Ident. The only differences are that Ident enforces a limit of 31
11653 -- characters on its argument, and also enforces limitations on
11654 -- placement for DEC compatibility. Pragma Comment shares neither of
11655 -- these restrictions.
11657 -------------------
11658 -- Common_Object --
11659 -------------------
11661 -- pragma Common_Object (
11662 -- [Internal =>] LOCAL_NAME
11663 -- [, [External =>] EXTERNAL_SYMBOL]
11664 -- [, [Size =>] EXTERNAL_SYMBOL]);
11666 -- Processing for this pragma is shared with Psect_Object
11668 ------------------------
11669 -- Compile_Time_Error --
11670 ------------------------
11672 -- pragma Compile_Time_Error
11673 -- (boolean_EXPRESSION, static_string_EXPRESSION);
11675 when Pragma_Compile_Time_Error
=>
11677 Process_Compile_Time_Warning_Or_Error
;
11679 --------------------------
11680 -- Compile_Time_Warning --
11681 --------------------------
11683 -- pragma Compile_Time_Warning
11684 -- (boolean_EXPRESSION, static_string_EXPRESSION);
11686 when Pragma_Compile_Time_Warning
=>
11688 Process_Compile_Time_Warning_Or_Error
;
11690 ---------------------------
11691 -- Compiler_Unit_Warning --
11692 ---------------------------
11694 -- pragma Compiler_Unit_Warning;
11698 -- Originally, we had only pragma Compiler_Unit, and it resulted in
11699 -- errors not warnings. This means that we had introduced a big extra
11700 -- inertia to compiler changes, since even if we implemented a new
11701 -- feature, and even if all versions to be used for bootstrapping
11702 -- implemented this new feature, we could not use it, since old
11703 -- compilers would give errors for using this feature in units
11704 -- having Compiler_Unit pragmas.
11706 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
11707 -- problem. We no longer have any units mentioning Compiler_Unit,
11708 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
11709 -- and thus generates a warning which can be ignored. So that deals
11710 -- with the problem of old compilers not implementing the newer form
11713 -- Newer compilers recognize the new pragma, but generate warning
11714 -- messages instead of errors, which again can be ignored in the
11715 -- case of an old compiler which implements a wanted new feature
11716 -- but at the time felt like warning about it for older compilers.
11718 -- We retain Compiler_Unit so that new compilers can be used to build
11719 -- older run-times that use this pragma. That's an unusual case, but
11720 -- it's easy enough to handle, so why not?
11722 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
11724 Check_Arg_Count
(0);
11726 -- Only recognized in main unit
11728 if Current_Sem_Unit
= Main_Unit
then
11729 Compiler_Unit
:= True;
11732 -----------------------------
11733 -- Complete_Representation --
11734 -----------------------------
11736 -- pragma Complete_Representation;
11738 when Pragma_Complete_Representation
=>
11740 Check_Arg_Count
(0);
11742 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
11744 ("pragma & must appear within record representation clause");
11747 ----------------------------
11748 -- Complex_Representation --
11749 ----------------------------
11751 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
11753 when Pragma_Complex_Representation
=> Complex_Representation
: declare
11760 Check_Arg_Count
(1);
11761 Check_Optional_Identifier
(Arg1
, Name_Entity
);
11762 Check_Arg_Is_Local_Name
(Arg1
);
11763 E_Id
:= Get_Pragma_Arg
(Arg1
);
11765 if Etype
(E_Id
) = Any_Type
then
11769 E
:= Entity
(E_Id
);
11771 if not Is_Record_Type
(E
) then
11773 ("argument for pragma% must be record type", Arg1
);
11776 Ent
:= First_Entity
(E
);
11779 or else No
(Next_Entity
(Ent
))
11780 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
11781 or else not Is_Floating_Point_Type
(Etype
(Ent
))
11782 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
11785 ("record for pragma% must have two fields of the same "
11786 & "floating-point type", Arg1
);
11789 Set_Has_Complex_Representation
(Base_Type
(E
));
11791 -- We need to treat the type has having a non-standard
11792 -- representation, for back-end purposes, even though in
11793 -- general a complex will have the default representation
11794 -- of a record with two real components.
11796 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
11798 end Complex_Representation
;
11800 -------------------------
11801 -- Component_Alignment --
11802 -------------------------
11804 -- pragma Component_Alignment (
11805 -- [Form =>] ALIGNMENT_CHOICE
11806 -- [, [Name =>] type_LOCAL_NAME]);
11808 -- ALIGNMENT_CHOICE ::=
11810 -- | Component_Size_4
11814 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
11815 Args
: Args_List
(1 .. 2);
11816 Names
: constant Name_List
(1 .. 2) := (
11820 Form
: Node_Id
renames Args
(1);
11821 Name
: Node_Id
renames Args
(2);
11823 Atype
: Component_Alignment_Kind
;
11828 Gather_Associations
(Names
, Args
);
11831 Error_Pragma
("missing Form argument for pragma%");
11834 Check_Arg_Is_Identifier
(Form
);
11836 -- Get proper alignment, note that Default = Component_Size on all
11837 -- machines we have so far, and we want to set this value rather
11838 -- than the default value to indicate that it has been explicitly
11839 -- set (and thus will not get overridden by the default component
11840 -- alignment for the current scope)
11842 if Chars
(Form
) = Name_Component_Size
then
11843 Atype
:= Calign_Component_Size
;
11845 elsif Chars
(Form
) = Name_Component_Size_4
then
11846 Atype
:= Calign_Component_Size_4
;
11848 elsif Chars
(Form
) = Name_Default
then
11849 Atype
:= Calign_Component_Size
;
11851 elsif Chars
(Form
) = Name_Storage_Unit
then
11852 Atype
:= Calign_Storage_Unit
;
11856 ("invalid Form parameter for pragma%", Form
);
11859 -- Case with no name, supplied, affects scope table entry
11863 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
11865 -- Case of name supplied
11868 Check_Arg_Is_Local_Name
(Name
);
11870 Typ
:= Entity
(Name
);
11873 or else Rep_Item_Too_Early
(Typ
, N
)
11877 Typ
:= Underlying_Type
(Typ
);
11880 if not Is_Record_Type
(Typ
)
11881 and then not Is_Array_Type
(Typ
)
11884 ("Name parameter of pragma% must identify record or "
11885 & "array type", Name
);
11888 -- An explicit Component_Alignment pragma overrides an
11889 -- implicit pragma Pack, but not an explicit one.
11891 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
11892 Set_Is_Packed
(Base_Type
(Typ
), False);
11893 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
11896 end Component_AlignmentP
;
11898 --------------------
11899 -- Contract_Cases --
11900 --------------------
11902 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
11904 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
11906 -- CASE_GUARD ::= boolean_EXPRESSION | others
11908 -- CONSEQUENCE ::= boolean_EXPRESSION
11910 when Pragma_Contract_Cases
=> Contract_Cases
: declare
11911 Subp_Decl
: Node_Id
;
11912 Subp_Id
: Entity_Id
;
11916 Check_No_Identifiers
;
11917 Check_Arg_Count
(1);
11919 -- The pragma is analyzed at the end of the declarative part which
11920 -- contains the related subprogram. Reset the analyzed flag.
11922 Set_Analyzed
(N
, False);
11924 -- Ensure the proper placement of the pragma. Contract_Cases must
11925 -- be associated with a subprogram declaration or a body that acts
11929 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
11931 -- Generic subprogram
11933 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
11936 -- Body acts as spec
11938 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
11939 and then No
(Corresponding_Spec
(Subp_Decl
))
11943 -- Body stub acts as spec
11945 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
11946 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
11952 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
11960 Subp_Id
:= Defining_Entity
(Subp_Decl
);
11962 Ensure_Aggregate_Form
(Get_Argument
(N
, Subp_Id
));
11964 -- Construct a generic template for the pragma when the context is
11965 -- a generic subprogram and the pragma is a source construct.
11967 Create_Generic_Template
(N
, Subp_Id
);
11969 -- Fully analyze the pragma when it appears inside a subprogram
11970 -- body because it cannot benefit from forward references.
11972 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
11973 Analyze_Contract_Cases_In_Decl_Part
(N
);
11976 -- Chain the pragma on the contract for further processing
11978 Add_Contract_Item
(N
, Subp_Id
);
11979 end Contract_Cases
;
11985 -- pragma Controlled (first_subtype_LOCAL_NAME);
11987 when Pragma_Controlled
=> Controlled
: declare
11991 Check_No_Identifiers
;
11992 Check_Arg_Count
(1);
11993 Check_Arg_Is_Local_Name
(Arg1
);
11994 Arg
:= Get_Pragma_Arg
(Arg1
);
11996 if not Is_Entity_Name
(Arg
)
11997 or else not Is_Access_Type
(Entity
(Arg
))
11999 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
12001 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
12009 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
12010 -- [Entity =>] LOCAL_NAME);
12012 when Pragma_Convention
=> Convention
: declare
12015 pragma Warnings
(Off
, C
);
12016 pragma Warnings
(Off
, E
);
12018 Check_Arg_Order
((Name_Convention
, Name_Entity
));
12019 Check_Ada_83_Warning
;
12020 Check_Arg_Count
(2);
12021 Process_Convention
(C
, E
);
12024 ---------------------------
12025 -- Convention_Identifier --
12026 ---------------------------
12028 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
12029 -- [Convention =>] convention_IDENTIFIER);
12031 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
12037 Check_Arg_Order
((Name_Name
, Name_Convention
));
12038 Check_Arg_Count
(2);
12039 Check_Optional_Identifier
(Arg1
, Name_Name
);
12040 Check_Optional_Identifier
(Arg2
, Name_Convention
);
12041 Check_Arg_Is_Identifier
(Arg1
);
12042 Check_Arg_Is_Identifier
(Arg2
);
12043 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
12044 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
12046 if Is_Convention_Name
(Cname
) then
12047 Record_Convention_Identifier
12048 (Idnam
, Get_Convention_Id
(Cname
));
12051 ("second arg for % pragma must be convention", Arg2
);
12053 end Convention_Identifier
;
12059 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
12061 when Pragma_CPP_Class
=> CPP_Class
: declare
12065 if Warn_On_Obsolescent_Feature
then
12067 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
12068 & "effect; replace it by pragma import?j?", N
);
12071 Check_Arg_Count
(1);
12075 Chars
=> Name_Import
,
12076 Pragma_Argument_Associations
=> New_List
(
12077 Make_Pragma_Argument_Association
(Loc
,
12078 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
12079 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
12083 ---------------------
12084 -- CPP_Constructor --
12085 ---------------------
12087 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
12088 -- [, [External_Name =>] static_string_EXPRESSION ]
12089 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12091 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
12094 Def_Id
: Entity_Id
;
12095 Tag_Typ
: Entity_Id
;
12099 Check_At_Least_N_Arguments
(1);
12100 Check_At_Most_N_Arguments
(3);
12101 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12102 Check_Arg_Is_Local_Name
(Arg1
);
12104 Id
:= Get_Pragma_Arg
(Arg1
);
12105 Find_Program_Unit_Name
(Id
);
12107 -- If we did not find the name, we are done
12109 if Etype
(Id
) = Any_Type
then
12113 Def_Id
:= Entity
(Id
);
12115 -- Check if already defined as constructor
12117 if Is_Constructor
(Def_Id
) then
12119 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
12123 if Ekind
(Def_Id
) = E_Function
12124 and then (Is_CPP_Class
(Etype
(Def_Id
))
12125 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
12127 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
12129 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
12131 ("'C'P'P constructor must be defined in the scope of "
12132 & "its returned type", Arg1
);
12135 if Arg_Count
>= 2 then
12136 Set_Imported
(Def_Id
);
12137 Set_Is_Public
(Def_Id
);
12138 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12141 Set_Has_Completion
(Def_Id
);
12142 Set_Is_Constructor
(Def_Id
);
12143 Set_Convention
(Def_Id
, Convention_CPP
);
12145 -- Imported C++ constructors are not dispatching primitives
12146 -- because in C++ they don't have a dispatch table slot.
12147 -- However, in Ada the constructor has the profile of a
12148 -- function that returns a tagged type and therefore it has
12149 -- been treated as a primitive operation during semantic
12150 -- analysis. We now remove it from the list of primitive
12151 -- operations of the type.
12153 if Is_Tagged_Type
(Etype
(Def_Id
))
12154 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
12155 and then Is_Dispatching_Operation
(Def_Id
)
12157 Tag_Typ
:= Etype
(Def_Id
);
12159 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
12160 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
12164 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
12165 Set_Is_Dispatching_Operation
(Def_Id
, False);
12168 -- For backward compatibility, if the constructor returns a
12169 -- class wide type, and we internally change the return type to
12170 -- the corresponding root type.
12172 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
12173 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
12177 ("pragma% requires function returning a 'C'P'P_Class type",
12180 end CPP_Constructor
;
12186 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
12190 if Warn_On_Obsolescent_Feature
then
12192 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
12201 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
12205 if Warn_On_Obsolescent_Feature
then
12207 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
12216 -- pragma CPU (EXPRESSION);
12218 when Pragma_CPU
=> CPU
: declare
12219 P
: constant Node_Id
:= Parent
(N
);
12225 Check_No_Identifiers
;
12226 Check_Arg_Count
(1);
12230 if Nkind
(P
) = N_Subprogram_Body
then
12231 Check_In_Main_Program
;
12233 Arg
:= Get_Pragma_Arg
(Arg1
);
12234 Analyze_And_Resolve
(Arg
, Any_Integer
);
12236 Ent
:= Defining_Unit_Name
(Specification
(P
));
12238 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
12239 Ent
:= Defining_Identifier
(Ent
);
12244 if not Is_OK_Static_Expression
(Arg
) then
12245 Flag_Non_Static_Expr
12246 ("main subprogram affinity is not static!", Arg
);
12249 -- If constraint error, then we already signalled an error
12251 elsif Raises_Constraint_Error
(Arg
) then
12254 -- Otherwise check in range
12258 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
12259 -- This is the entity System.Multiprocessors.CPU_Range;
12261 Val
: constant Uint
:= Expr_Value
(Arg
);
12264 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
12266 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
12269 ("main subprogram CPU is out of range", Arg1
);
12275 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12279 elsif Nkind
(P
) = N_Task_Definition
then
12280 Arg
:= Get_Pragma_Arg
(Arg1
);
12281 Ent
:= Defining_Identifier
(Parent
(P
));
12283 -- The expression must be analyzed in the special manner
12284 -- described in "Handling of Default and Per-Object
12285 -- Expressions" in sem.ads.
12287 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
12289 -- Anything else is incorrect
12295 -- Check duplicate pragma before we chain the pragma in the Rep
12296 -- Item chain of Ent.
12298 Check_Duplicate_Pragma
(Ent
);
12299 Record_Rep_Item
(Ent
, N
);
12306 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
12308 when Pragma_Debug
=> Debug
: declare
12315 -- The condition for executing the call is that the expander
12316 -- is active and that we are not ignoring this debug pragma.
12321 (Expander_Active
and then not Is_Ignored
(N
)),
12324 if not Is_Ignored
(N
) then
12325 Set_SCO_Pragma_Enabled
(Loc
);
12328 if Arg_Count
= 2 then
12330 Make_And_Then
(Loc
,
12331 Left_Opnd
=> Relocate_Node
(Cond
),
12332 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
12333 Call
:= Get_Pragma_Arg
(Arg2
);
12335 Call
:= Get_Pragma_Arg
(Arg1
);
12339 N_Indexed_Component
,
12343 N_Selected_Component
)
12345 -- If this pragma Debug comes from source, its argument was
12346 -- parsed as a name form (which is syntactically identical).
12347 -- In a generic context a parameterless call will be left as
12348 -- an expanded name (if global) or selected_component if local.
12349 -- Change it to a procedure call statement now.
12351 Change_Name_To_Procedure_Call_Statement
(Call
);
12353 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
12355 -- Already in the form of a procedure call statement: nothing
12356 -- to do (could happen in case of an internally generated
12362 -- All other cases: diagnose error
12365 ("argument of pragma ""Debug"" is not procedure call",
12370 -- Rewrite into a conditional with an appropriate condition. We
12371 -- wrap the procedure call in a block so that overhead from e.g.
12372 -- use of the secondary stack does not generate execution overhead
12373 -- for suppressed conditions.
12375 -- Normally the analysis that follows will freeze the subprogram
12376 -- being called. However, if the call is to a null procedure,
12377 -- we want to freeze it before creating the block, because the
12378 -- analysis that follows may be done with expansion disabled, in
12379 -- which case the body will not be generated, leading to spurious
12382 if Nkind
(Call
) = N_Procedure_Call_Statement
12383 and then Is_Entity_Name
(Name
(Call
))
12385 Analyze
(Name
(Call
));
12386 Freeze_Before
(N
, Entity
(Name
(Call
)));
12390 Make_Implicit_If_Statement
(N
,
12392 Then_Statements
=> New_List
(
12393 Make_Block_Statement
(Loc
,
12394 Handled_Statement_Sequence
=>
12395 Make_Handled_Sequence_Of_Statements
(Loc
,
12396 Statements
=> New_List
(Relocate_Node
(Call
)))))));
12399 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
12400 -- after analysis of the normally rewritten node, to capture all
12401 -- references to entities, which avoids issuing wrong warnings
12402 -- about unused entities.
12404 if GNATprove_Mode
then
12405 Rewrite
(N
, Make_Null_Statement
(Loc
));
12413 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
12415 when Pragma_Debug_Policy
=>
12417 Check_Arg_Count
(1);
12418 Check_No_Identifiers
;
12419 Check_Arg_Is_Identifier
(Arg1
);
12421 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
12422 -- rewrite it that way, and let the rest of the checking come
12423 -- from analyzing the rewritten pragma.
12427 Chars
=> Name_Check_Policy
,
12428 Pragma_Argument_Associations
=> New_List
(
12429 Make_Pragma_Argument_Association
(Loc
,
12430 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
12432 Make_Pragma_Argument_Association
(Loc
,
12433 Expression
=> Get_Pragma_Arg
(Arg1
)))));
12436 -------------------------------
12437 -- Default_Initial_Condition --
12438 -------------------------------
12440 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
12442 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
12449 Check_No_Identifiers
;
12450 Check_At_Most_N_Arguments
(1);
12453 while Present
(Stmt
) loop
12455 -- Skip prior pragmas, but check for duplicates
12457 if Nkind
(Stmt
) = N_Pragma
then
12458 if Pragma_Name
(Stmt
) = Pname
then
12459 Error_Msg_Name_1
:= Pname
;
12460 Error_Msg_Sloc
:= Sloc
(Stmt
);
12461 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
12464 -- Skip internally generated code
12466 elsif not Comes_From_Source
(Stmt
) then
12469 -- The associated private type [extension] has been found, stop
12472 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
12473 N_Private_Type_Declaration
)
12475 Typ
:= Defining_Entity
(Stmt
);
12478 -- The pragma does not apply to a legal construct, issue an
12479 -- error and stop the analysis.
12486 Stmt
:= Prev
(Stmt
);
12489 Set_Has_Default_Init_Cond
(Typ
);
12490 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
12492 -- Chain the pragma on the rep item chain for further processing
12494 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
12495 end Default_Init_Cond
;
12497 ----------------------------------
12498 -- Default_Scalar_Storage_Order --
12499 ----------------------------------
12501 -- pragma Default_Scalar_Storage_Order
12502 -- (High_Order_First | Low_Order_First);
12504 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
12505 Default
: Character;
12509 Check_Arg_Count
(1);
12511 -- Default_Scalar_Storage_Order can appear as a configuration
12512 -- pragma, or in a declarative part of a package spec.
12514 if not Is_Configuration_Pragma
then
12515 Check_Is_In_Decl_Part_Or_Package_Spec
;
12518 Check_No_Identifiers
;
12519 Check_Arg_Is_One_Of
12520 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
12521 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12522 Default
:= Fold_Upper
(Name_Buffer
(1));
12524 if not Support_Nondefault_SSO_On_Target
12525 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
12527 if Warn_On_Unrecognized_Pragma
then
12529 ("non-default Scalar_Storage_Order not supported "
12530 & "on target?g?", N
);
12532 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
12535 -- Here set the specified default
12538 Opt
.Default_SSO
:= Default
;
12542 --------------------------
12543 -- Default_Storage_Pool --
12544 --------------------------
12546 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
12548 when Pragma_Default_Storage_Pool
=>
12550 Check_Arg_Count
(1);
12552 -- Default_Storage_Pool can appear as a configuration pragma, or
12553 -- in a declarative part of a package spec.
12555 if not Is_Configuration_Pragma
then
12556 Check_Is_In_Decl_Part_Or_Package_Spec
;
12559 -- Case of Default_Storage_Pool (null);
12561 if Nkind
(Expression
(Arg1
)) = N_Null
then
12562 Analyze
(Expression
(Arg1
));
12564 -- This is an odd case, this is not really an expression, so
12565 -- we don't have a type for it. So just set the type to Empty.
12567 Set_Etype
(Expression
(Arg1
), Empty
);
12569 -- Case of Default_Storage_Pool (storage_pool_NAME);
12572 -- If it's a configuration pragma, then the only allowed
12573 -- argument is "null".
12575 if Is_Configuration_Pragma
then
12576 Error_Pragma_Arg
("NULL expected", Arg1
);
12579 -- The expected type for a non-"null" argument is
12580 -- Root_Storage_Pool'Class, and the pool must be a variable.
12582 Analyze_And_Resolve
12583 (Get_Pragma_Arg
(Arg1
),
12584 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
12586 if not Is_Variable
(Expression
(Arg1
)) then
12588 ("default storage pool must be a variable", Arg1
);
12592 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
12593 -- for an access type will use this information to set the
12594 -- appropriate attributes of the access type.
12596 Default_Pool
:= Expression
(Arg1
);
12602 -- pragma Depends (DEPENDENCY_RELATION);
12604 -- DEPENDENCY_RELATION ::=
12606 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
12608 -- DEPENDENCY_CLAUSE ::=
12609 -- OUTPUT_LIST =>[+] INPUT_LIST
12610 -- | NULL_DEPENDENCY_CLAUSE
12612 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
12614 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
12616 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
12618 -- OUTPUT ::= NAME | FUNCTION_RESULT
12621 -- where FUNCTION_RESULT is a function Result attribute_reference
12623 when Pragma_Depends
=> Depends
: declare
12624 Subp_Decl
: Node_Id
;
12625 Subp_Id
: Entity_Id
;
12629 Check_Arg_Count
(1);
12631 -- Ensure the proper placement of the pragma. Depends must be
12632 -- associated with a subprogram declaration or a body that acts
12636 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
12638 -- Body acts as spec
12640 if Nkind
(Subp_Decl
) = N_Subprogram_Body
12641 and then No
(Corresponding_Spec
(Subp_Decl
))
12645 -- Body stub acts as spec
12647 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12648 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12652 -- Subprogram declaration
12654 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
12662 Subp_Id
:= Defining_Entity
(Subp_Decl
);
12664 Ensure_Aggregate_Form
(Get_Argument
(N
, Subp_Id
));
12666 -- Construct a generic template for the pragma when the context is
12667 -- a generic subprogram and the pragma is a source construct.
12669 Create_Generic_Template
(N
, Subp_Id
);
12671 -- When the pragma appears on a subprogram body, perform the full
12674 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
12675 Analyze_Depends_In_Decl_Part
(N
);
12678 -- Chain the pragma on the contract for further processing
12680 Add_Contract_Item
(N
, Subp_Id
);
12683 ---------------------
12684 -- Detect_Blocking --
12685 ---------------------
12687 -- pragma Detect_Blocking;
12689 when Pragma_Detect_Blocking
=>
12691 Check_Arg_Count
(0);
12692 Check_Valid_Configuration_Pragma
;
12693 Detect_Blocking
:= True;
12695 ------------------------------------
12696 -- Disable_Atomic_Synchronization --
12697 ------------------------------------
12699 -- pragma Disable_Atomic_Synchronization [(Entity)];
12701 when Pragma_Disable_Atomic_Synchronization
=>
12703 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
12705 -------------------
12706 -- Discard_Names --
12707 -------------------
12709 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
12711 when Pragma_Discard_Names
=> Discard_Names
: declare
12716 Check_Ada_83_Warning
;
12718 -- Deal with configuration pragma case
12720 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
12721 Global_Discard_Names
:= True;
12724 -- Otherwise, check correct appropriate context
12727 Check_Is_In_Decl_Part_Or_Package_Spec
;
12729 if Arg_Count
= 0 then
12731 -- If there is no parameter, then from now on this pragma
12732 -- applies to any enumeration, exception or tagged type
12733 -- defined in the current declarative part, and recursively
12734 -- to any nested scope.
12736 Set_Discard_Names
(Current_Scope
);
12740 Check_Arg_Count
(1);
12741 Check_Optional_Identifier
(Arg1
, Name_On
);
12742 Check_Arg_Is_Local_Name
(Arg1
);
12744 E_Id
:= Get_Pragma_Arg
(Arg1
);
12746 if Etype
(E_Id
) = Any_Type
then
12749 E
:= Entity
(E_Id
);
12752 if (Is_First_Subtype
(E
)
12754 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
12755 or else Ekind
(E
) = E_Exception
12757 Set_Discard_Names
(E
);
12758 Record_Rep_Item
(E
, N
);
12762 ("inappropriate entity for pragma%", Arg1
);
12769 ------------------------
12770 -- Dispatching_Domain --
12771 ------------------------
12773 -- pragma Dispatching_Domain (EXPRESSION);
12775 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
12776 P
: constant Node_Id
:= Parent
(N
);
12782 Check_No_Identifiers
;
12783 Check_Arg_Count
(1);
12785 -- This pragma is born obsolete, but not the aspect
12787 if not From_Aspect_Specification
(N
) then
12789 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
12792 if Nkind
(P
) = N_Task_Definition
then
12793 Arg
:= Get_Pragma_Arg
(Arg1
);
12794 Ent
:= Defining_Identifier
(Parent
(P
));
12796 -- The expression must be analyzed in the special manner
12797 -- described in "Handling of Default and Per-Object
12798 -- Expressions" in sem.ads.
12800 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
12802 -- Check duplicate pragma before we chain the pragma in the Rep
12803 -- Item chain of Ent.
12805 Check_Duplicate_Pragma
(Ent
);
12806 Record_Rep_Item
(Ent
, N
);
12808 -- Anything else is incorrect
12813 end Dispatching_Domain
;
12819 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
12821 when Pragma_Elaborate
=> Elaborate
: declare
12826 -- Pragma must be in context items list of a compilation unit
12828 if not Is_In_Context_Clause
then
12832 -- Must be at least one argument
12834 if Arg_Count
= 0 then
12835 Error_Pragma
("pragma% requires at least one argument");
12838 -- In Ada 83 mode, there can be no items following it in the
12839 -- context list except other pragmas and implicit with clauses
12840 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
12841 -- placement rule does not apply.
12843 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
12845 while Present
(Citem
) loop
12846 if Nkind
(Citem
) = N_Pragma
12847 or else (Nkind
(Citem
) = N_With_Clause
12848 and then Implicit_With
(Citem
))
12853 ("(Ada 83) pragma% must be at end of context clause");
12860 -- Finally, the arguments must all be units mentioned in a with
12861 -- clause in the same context clause. Note we already checked (in
12862 -- Par.Prag) that the arguments are all identifiers or selected
12866 Outer
: while Present
(Arg
) loop
12867 Citem
:= First
(List_Containing
(N
));
12868 Inner
: while Citem
/= N
loop
12869 if Nkind
(Citem
) = N_With_Clause
12870 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
12872 Set_Elaborate_Present
(Citem
, True);
12873 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
12875 -- With the pragma present, elaboration calls on
12876 -- subprograms from the named unit need no further
12877 -- checks, as long as the pragma appears in the current
12878 -- compilation unit. If the pragma appears in some unit
12879 -- in the context, there might still be a need for an
12880 -- Elaborate_All_Desirable from the current compilation
12881 -- to the named unit, so we keep the check enabled.
12883 if In_Extended_Main_Source_Unit
(N
) then
12885 -- This does not apply in SPARK mode, where we allow
12886 -- pragma Elaborate, but we don't trust it to be right
12887 -- so we will still insist on the Elaborate_All.
12889 if SPARK_Mode
/= On
then
12890 Set_Suppress_Elaboration_Warnings
12891 (Entity
(Name
(Citem
)));
12903 ("argument of pragma% is not withed unit", Arg
);
12909 -- Give a warning if operating in static mode with one of the
12910 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
12913 and not Dynamic_Elaboration_Checks
12915 -- pragma Elaborate not allowed in SPARK mode anyway. We
12916 -- already complained about it, no point in generating any
12917 -- further complaint.
12919 and SPARK_Mode
/= On
12922 ("?l?use of pragma Elaborate may not be safe", N
);
12924 ("?l?use pragma Elaborate_All instead if possible", N
);
12928 -------------------
12929 -- Elaborate_All --
12930 -------------------
12932 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
12934 when Pragma_Elaborate_All
=> Elaborate_All
: declare
12939 Check_Ada_83_Warning
;
12941 -- Pragma must be in context items list of a compilation unit
12943 if not Is_In_Context_Clause
then
12947 -- Must be at least one argument
12949 if Arg_Count
= 0 then
12950 Error_Pragma
("pragma% requires at least one argument");
12953 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
12954 -- have to appear at the end of the context clause, but may
12955 -- appear mixed in with other items, even in Ada 83 mode.
12957 -- Final check: the arguments must all be units mentioned in
12958 -- a with clause in the same context clause. Note that we
12959 -- already checked (in Par.Prag) that all the arguments are
12960 -- either identifiers or selected components.
12963 Outr
: while Present
(Arg
) loop
12964 Citem
:= First
(List_Containing
(N
));
12965 Innr
: while Citem
/= N
loop
12966 if Nkind
(Citem
) = N_With_Clause
12967 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
12969 Set_Elaborate_All_Present
(Citem
, True);
12970 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
12972 -- Suppress warnings and elaboration checks on the named
12973 -- unit if the pragma is in the current compilation, as
12974 -- for pragma Elaborate.
12976 if In_Extended_Main_Source_Unit
(N
) then
12977 Set_Suppress_Elaboration_Warnings
12978 (Entity
(Name
(Citem
)));
12987 Set_Error_Posted
(N
);
12989 ("argument of pragma% is not withed unit", Arg
);
12996 --------------------
12997 -- Elaborate_Body --
12998 --------------------
13000 -- pragma Elaborate_Body [( library_unit_NAME )];
13002 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
13003 Cunit_Node
: Node_Id
;
13004 Cunit_Ent
: Entity_Id
;
13007 Check_Ada_83_Warning
;
13008 Check_Valid_Library_Unit_Pragma
;
13010 if Nkind
(N
) = N_Null_Statement
then
13014 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
13015 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13017 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
13020 Error_Pragma
("pragma% must refer to a spec, not a body");
13022 Set_Body_Required
(Cunit_Node
, True);
13023 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
13025 -- If we are in dynamic elaboration mode, then we suppress
13026 -- elaboration warnings for the unit, since it is definitely
13027 -- fine NOT to do dynamic checks at the first level (and such
13028 -- checks will be suppressed because no elaboration boolean
13029 -- is created for Elaborate_Body packages).
13031 -- But in the static model of elaboration, Elaborate_Body is
13032 -- definitely NOT good enough to ensure elaboration safety on
13033 -- its own, since the body may WITH other units that are not
13034 -- safe from an elaboration point of view, so a client must
13035 -- still do an Elaborate_All on such units.
13037 -- Debug flag -gnatdD restores the old behavior of 3.13, where
13038 -- Elaborate_Body always suppressed elab warnings.
13040 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
13041 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
13044 end Elaborate_Body
;
13046 ------------------------
13047 -- Elaboration_Checks --
13048 ------------------------
13050 -- pragma Elaboration_Checks (Static | Dynamic);
13052 when Pragma_Elaboration_Checks
=>
13054 Check_Arg_Count
(1);
13055 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
13057 -- Set flag accordingly (ignore attempt at dynamic elaboration
13058 -- checks in SPARK mode).
13060 Dynamic_Elaboration_Checks
:=
13061 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
)
13062 and then SPARK_Mode
/= On
;
13068 -- pragma Eliminate (
13069 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
13070 -- [,[Entity =>] IDENTIFIER |
13071 -- SELECTED_COMPONENT |
13073 -- [, OVERLOADING_RESOLUTION]);
13075 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
13078 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
13079 -- FUNCTION_PROFILE
13081 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
13083 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
13084 -- Result_Type => result_SUBTYPE_NAME]
13086 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
13087 -- SUBTYPE_NAME ::= STRING_LITERAL
13089 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
13090 -- SOURCE_TRACE ::= STRING_LITERAL
13092 when Pragma_Eliminate
=> Eliminate
: declare
13093 Args
: Args_List
(1 .. 5);
13094 Names
: constant Name_List
(1 .. 5) := (
13097 Name_Parameter_Types
,
13099 Name_Source_Location
);
13101 Unit_Name
: Node_Id
renames Args
(1);
13102 Entity
: Node_Id
renames Args
(2);
13103 Parameter_Types
: Node_Id
renames Args
(3);
13104 Result_Type
: Node_Id
renames Args
(4);
13105 Source_Location
: Node_Id
renames Args
(5);
13109 Check_Valid_Configuration_Pragma
;
13110 Gather_Associations
(Names
, Args
);
13112 if No
(Unit_Name
) then
13113 Error_Pragma
("missing Unit_Name argument for pragma%");
13117 and then (Present
(Parameter_Types
)
13119 Present
(Result_Type
)
13121 Present
(Source_Location
))
13123 Error_Pragma
("missing Entity argument for pragma%");
13126 if (Present
(Parameter_Types
)
13128 Present
(Result_Type
))
13130 Present
(Source_Location
)
13133 ("parameter profile and source location cannot be used "
13134 & "together in pragma%");
13137 Process_Eliminate_Pragma
13146 -----------------------------------
13147 -- Enable_Atomic_Synchronization --
13148 -----------------------------------
13150 -- pragma Enable_Atomic_Synchronization [(Entity)];
13152 when Pragma_Enable_Atomic_Synchronization
=>
13154 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
13161 -- [ Convention =>] convention_IDENTIFIER,
13162 -- [ Entity =>] LOCAL_NAME
13163 -- [, [External_Name =>] static_string_EXPRESSION ]
13164 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13166 when Pragma_Export
=> Export
: declare
13168 Def_Id
: Entity_Id
;
13170 pragma Warnings
(Off
, C
);
13173 Check_Ada_83_Warning
;
13177 Name_External_Name
,
13180 Check_At_Least_N_Arguments
(2);
13181 Check_At_Most_N_Arguments
(4);
13183 -- In Relaxed_RM_Semantics, support old Ada 83 style:
13184 -- pragma Export (Entity, "external name");
13186 if Relaxed_RM_Semantics
13187 and then Arg_Count
= 2
13188 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
13191 Def_Id
:= Get_Pragma_Arg
(Arg1
);
13194 if not Is_Entity_Name
(Def_Id
) then
13195 Error_Pragma_Arg
("entity name required", Arg1
);
13198 Def_Id
:= Entity
(Def_Id
);
13199 Set_Exported
(Def_Id
, Arg1
);
13202 Process_Convention
(C
, Def_Id
);
13204 if Ekind
(Def_Id
) /= E_Constant
then
13205 Note_Possible_Modification
13206 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13209 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13210 Set_Exported
(Def_Id
, Arg2
);
13213 -- If the entity is a deferred constant, propagate the information
13214 -- to the full view, because gigi elaborates the full view only.
13216 if Ekind
(Def_Id
) = E_Constant
13217 and then Present
(Full_View
(Def_Id
))
13220 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
13222 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
13223 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
13224 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
13229 ---------------------
13230 -- Export_Function --
13231 ---------------------
13233 -- pragma Export_Function (
13234 -- [Internal =>] LOCAL_NAME
13235 -- [, [External =>] EXTERNAL_SYMBOL]
13236 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13237 -- [, [Result_Type =>] TYPE_DESIGNATOR]
13238 -- [, [Mechanism =>] MECHANISM]
13239 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
13241 -- EXTERNAL_SYMBOL ::=
13243 -- | static_string_EXPRESSION
13245 -- PARAMETER_TYPES ::=
13247 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13249 -- TYPE_DESIGNATOR ::=
13251 -- | subtype_Name ' Access
13255 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13257 -- MECHANISM_ASSOCIATION ::=
13258 -- [formal_parameter_NAME =>] MECHANISM_NAME
13260 -- MECHANISM_NAME ::=
13264 when Pragma_Export_Function
=> Export_Function
: declare
13265 Args
: Args_List
(1 .. 6);
13266 Names
: constant Name_List
(1 .. 6) := (
13269 Name_Parameter_Types
,
13272 Name_Result_Mechanism
);
13274 Internal
: Node_Id
renames Args
(1);
13275 External
: Node_Id
renames Args
(2);
13276 Parameter_Types
: Node_Id
renames Args
(3);
13277 Result_Type
: Node_Id
renames Args
(4);
13278 Mechanism
: Node_Id
renames Args
(5);
13279 Result_Mechanism
: Node_Id
renames Args
(6);
13283 Gather_Associations
(Names
, Args
);
13284 Process_Extended_Import_Export_Subprogram_Pragma
(
13285 Arg_Internal
=> Internal
,
13286 Arg_External
=> External
,
13287 Arg_Parameter_Types
=> Parameter_Types
,
13288 Arg_Result_Type
=> Result_Type
,
13289 Arg_Mechanism
=> Mechanism
,
13290 Arg_Result_Mechanism
=> Result_Mechanism
);
13291 end Export_Function
;
13293 -------------------
13294 -- Export_Object --
13295 -------------------
13297 -- pragma Export_Object (
13298 -- [Internal =>] LOCAL_NAME
13299 -- [, [External =>] EXTERNAL_SYMBOL]
13300 -- [, [Size =>] EXTERNAL_SYMBOL]);
13302 -- EXTERNAL_SYMBOL ::=
13304 -- | static_string_EXPRESSION
13306 -- PARAMETER_TYPES ::=
13308 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13310 -- TYPE_DESIGNATOR ::=
13312 -- | subtype_Name ' Access
13316 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13318 -- MECHANISM_ASSOCIATION ::=
13319 -- [formal_parameter_NAME =>] MECHANISM_NAME
13321 -- MECHANISM_NAME ::=
13325 when Pragma_Export_Object
=> Export_Object
: declare
13326 Args
: Args_List
(1 .. 3);
13327 Names
: constant Name_List
(1 .. 3) := (
13332 Internal
: Node_Id
renames Args
(1);
13333 External
: Node_Id
renames Args
(2);
13334 Size
: Node_Id
renames Args
(3);
13338 Gather_Associations
(Names
, Args
);
13339 Process_Extended_Import_Export_Object_Pragma
(
13340 Arg_Internal
=> Internal
,
13341 Arg_External
=> External
,
13345 ----------------------
13346 -- Export_Procedure --
13347 ----------------------
13349 -- pragma Export_Procedure (
13350 -- [Internal =>] LOCAL_NAME
13351 -- [, [External =>] EXTERNAL_SYMBOL]
13352 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13353 -- [, [Mechanism =>] MECHANISM]);
13355 -- EXTERNAL_SYMBOL ::=
13357 -- | static_string_EXPRESSION
13359 -- PARAMETER_TYPES ::=
13361 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13363 -- TYPE_DESIGNATOR ::=
13365 -- | subtype_Name ' Access
13369 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13371 -- MECHANISM_ASSOCIATION ::=
13372 -- [formal_parameter_NAME =>] MECHANISM_NAME
13374 -- MECHANISM_NAME ::=
13378 when Pragma_Export_Procedure
=> Export_Procedure
: declare
13379 Args
: Args_List
(1 .. 4);
13380 Names
: constant Name_List
(1 .. 4) := (
13383 Name_Parameter_Types
,
13386 Internal
: Node_Id
renames Args
(1);
13387 External
: Node_Id
renames Args
(2);
13388 Parameter_Types
: Node_Id
renames Args
(3);
13389 Mechanism
: Node_Id
renames Args
(4);
13393 Gather_Associations
(Names
, Args
);
13394 Process_Extended_Import_Export_Subprogram_Pragma
(
13395 Arg_Internal
=> Internal
,
13396 Arg_External
=> External
,
13397 Arg_Parameter_Types
=> Parameter_Types
,
13398 Arg_Mechanism
=> Mechanism
);
13399 end Export_Procedure
;
13405 -- pragma Export_Value (
13406 -- [Value =>] static_integer_EXPRESSION,
13407 -- [Link_Name =>] static_string_EXPRESSION);
13409 when Pragma_Export_Value
=>
13411 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
13412 Check_Arg_Count
(2);
13414 Check_Optional_Identifier
(Arg1
, Name_Value
);
13415 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
13417 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
13418 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
13420 -----------------------------
13421 -- Export_Valued_Procedure --
13422 -----------------------------
13424 -- pragma Export_Valued_Procedure (
13425 -- [Internal =>] LOCAL_NAME
13426 -- [, [External =>] EXTERNAL_SYMBOL,]
13427 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
13428 -- [, [Mechanism =>] MECHANISM]);
13430 -- EXTERNAL_SYMBOL ::=
13432 -- | static_string_EXPRESSION
13434 -- PARAMETER_TYPES ::=
13436 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
13438 -- TYPE_DESIGNATOR ::=
13440 -- | subtype_Name ' Access
13444 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
13446 -- MECHANISM_ASSOCIATION ::=
13447 -- [formal_parameter_NAME =>] MECHANISM_NAME
13449 -- MECHANISM_NAME ::=
13453 when Pragma_Export_Valued_Procedure
=>
13454 Export_Valued_Procedure
: declare
13455 Args
: Args_List
(1 .. 4);
13456 Names
: constant Name_List
(1 .. 4) := (
13459 Name_Parameter_Types
,
13462 Internal
: Node_Id
renames Args
(1);
13463 External
: Node_Id
renames Args
(2);
13464 Parameter_Types
: Node_Id
renames Args
(3);
13465 Mechanism
: Node_Id
renames Args
(4);
13469 Gather_Associations
(Names
, Args
);
13470 Process_Extended_Import_Export_Subprogram_Pragma
(
13471 Arg_Internal
=> Internal
,
13472 Arg_External
=> External
,
13473 Arg_Parameter_Types
=> Parameter_Types
,
13474 Arg_Mechanism
=> Mechanism
);
13475 end Export_Valued_Procedure
;
13477 -------------------
13478 -- Extend_System --
13479 -------------------
13481 -- pragma Extend_System ([Name =>] Identifier);
13483 when Pragma_Extend_System
=> Extend_System
: declare
13486 Check_Valid_Configuration_Pragma
;
13487 Check_Arg_Count
(1);
13488 Check_Optional_Identifier
(Arg1
, Name_Name
);
13489 Check_Arg_Is_Identifier
(Arg1
);
13491 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13494 and then Name_Buffer
(1 .. 4) = "aux_"
13496 if Present
(System_Extend_Pragma_Arg
) then
13497 if Chars
(Get_Pragma_Arg
(Arg1
)) =
13498 Chars
(Expression
(System_Extend_Pragma_Arg
))
13502 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
13503 Error_Pragma
("pragma% conflicts with that #");
13507 System_Extend_Pragma_Arg
:= Arg1
;
13509 if not GNAT_Mode
then
13510 System_Extend_Unit
:= Arg1
;
13514 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
13518 ------------------------
13519 -- Extensions_Allowed --
13520 ------------------------
13522 -- pragma Extensions_Allowed (ON | OFF);
13524 when Pragma_Extensions_Allowed
=>
13526 Check_Arg_Count
(1);
13527 Check_No_Identifiers
;
13528 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13530 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13531 Extensions_Allowed
:= True;
13532 Ada_Version
:= Ada_Version_Type
'Last;
13535 Extensions_Allowed
:= False;
13536 Ada_Version
:= Ada_Version_Explicit
;
13537 Ada_Version_Pragma
:= Empty
;
13540 ------------------------
13541 -- Extensions_Visible --
13542 ------------------------
13544 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
13546 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
13548 Formal
: Entity_Id
;
13549 Has_OK_Formal
: Boolean := False;
13550 Spec_Id
: Entity_Id
;
13551 Subp_Decl
: Node_Id
;
13552 Subp_Id
: Entity_Id
;
13556 Check_No_Identifiers
;
13557 Check_At_Most_N_Arguments
(1);
13560 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
13562 -- Generic subprogram declaration
13564 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
13567 -- Body acts as spec
13569 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13570 and then No
(Corresponding_Spec
(Subp_Decl
))
13574 -- Body stub acts as spec
13576 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13577 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13581 -- Subprogram declaration
13583 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13586 -- Otherwise the pragma is associated with an illegal construct
13589 Error_Pragma
("pragma % must apply to a subprogram");
13593 Spec_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
13594 Subp_Id
:= Defining_Entity
(Subp_Decl
);
13596 -- Examine the formals of the related subprogram
13598 Formal
:= First_Formal
(Spec_Id
);
13599 while Present
(Formal
) loop
13601 -- At least one of the formals is of a specific tagged type,
13602 -- the pragma is legal.
13604 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
13605 Has_OK_Formal
:= True;
13608 -- A generic subprogram with at least one formal of a private
13609 -- type ensures the legality of the pragma because the actual
13610 -- may be specifically tagged. Note that this is verified by
13611 -- the check above at instantiation time.
13613 elsif Is_Private_Type
(Etype
(Formal
))
13614 and then Is_Generic_Type
(Etype
(Formal
))
13616 Has_OK_Formal
:= True;
13620 Next_Formal
(Formal
);
13623 if not Has_OK_Formal
then
13624 Error_Msg_Name_1
:= Pname
;
13625 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
13627 ("\subprogram & lacks parameter of specific tagged or "
13628 & "generic private type", N
, Spec_Id
);
13632 -- Construct a generic template for the pragma when the context is
13633 -- a generic subprogram and the pragma is a source construct.
13635 Create_Generic_Template
(N
, Subp_Id
);
13637 -- Analyze the Boolean expression (if any)
13639 if Present
(Arg1
) then
13640 Expr
:= Expression
(Get_Argument
(N
));
13642 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
13644 if not Is_OK_Static_Expression
(Expr
) then
13646 ("expression of pragma % must be static", Expr
);
13651 -- Chain the pragma on the contract for further processing
13653 Add_Contract_Item
(N
, Subp_Id
);
13654 end Extensions_Visible
;
13660 -- pragma External (
13661 -- [ Convention =>] convention_IDENTIFIER,
13662 -- [ Entity =>] LOCAL_NAME
13663 -- [, [External_Name =>] static_string_EXPRESSION ]
13664 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13666 when Pragma_External
=> External
: declare
13667 Def_Id
: Entity_Id
;
13670 pragma Warnings
(Off
, C
);
13677 Name_External_Name
,
13679 Check_At_Least_N_Arguments
(2);
13680 Check_At_Most_N_Arguments
(4);
13681 Process_Convention
(C
, Def_Id
);
13682 Note_Possible_Modification
13683 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
13684 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
13685 Set_Exported
(Def_Id
, Arg2
);
13688 --------------------------
13689 -- External_Name_Casing --
13690 --------------------------
13692 -- pragma External_Name_Casing (
13693 -- UPPERCASE | LOWERCASE
13694 -- [, AS_IS | UPPERCASE | LOWERCASE]);
13696 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
13699 Check_No_Identifiers
;
13701 if Arg_Count
= 2 then
13702 Check_Arg_Is_One_Of
13703 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
13705 case Chars
(Get_Pragma_Arg
(Arg2
)) is
13707 Opt
.External_Name_Exp_Casing
:= As_Is
;
13709 when Name_Uppercase
=>
13710 Opt
.External_Name_Exp_Casing
:= Uppercase
;
13712 when Name_Lowercase
=>
13713 Opt
.External_Name_Exp_Casing
:= Lowercase
;
13720 Check_Arg_Count
(1);
13723 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
13725 case Chars
(Get_Pragma_Arg
(Arg1
)) is
13726 when Name_Uppercase
=>
13727 Opt
.External_Name_Imp_Casing
:= Uppercase
;
13729 when Name_Lowercase
=>
13730 Opt
.External_Name_Imp_Casing
:= Lowercase
;
13735 end External_Name_Casing
;
13741 -- pragma Fast_Math;
13743 when Pragma_Fast_Math
=>
13745 Check_No_Identifiers
;
13746 Check_Valid_Configuration_Pragma
;
13749 --------------------------
13750 -- Favor_Top_Level --
13751 --------------------------
13753 -- pragma Favor_Top_Level (type_NAME);
13755 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
13756 Named_Entity
: Entity_Id
;
13760 Check_No_Identifiers
;
13761 Check_Arg_Count
(1);
13762 Check_Arg_Is_Local_Name
(Arg1
);
13763 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
13765 -- If it's an access-to-subprogram type (in particular, not a
13766 -- subtype), set the flag on that type.
13768 if Is_Access_Subprogram_Type
(Named_Entity
) then
13769 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
13771 -- Otherwise it's an error (name denotes the wrong sort of entity)
13775 ("access-to-subprogram type expected",
13776 Get_Pragma_Arg
(Arg1
));
13778 end Favor_Top_Level
;
13780 ---------------------------
13781 -- Finalize_Storage_Only --
13782 ---------------------------
13784 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
13786 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
13787 Assoc
: constant Node_Id
:= Arg1
;
13788 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
13793 Check_No_Identifiers
;
13794 Check_Arg_Count
(1);
13795 Check_Arg_Is_Local_Name
(Arg1
);
13797 Find_Type
(Type_Id
);
13798 Typ
:= Entity
(Type_Id
);
13801 or else Rep_Item_Too_Early
(Typ
, N
)
13805 Typ
:= Underlying_Type
(Typ
);
13808 if not Is_Controlled
(Typ
) then
13809 Error_Pragma
("pragma% must specify controlled type");
13812 Check_First_Subtype
(Arg1
);
13814 if Finalize_Storage_Only
(Typ
) then
13815 Error_Pragma
("duplicate pragma%, only one allowed");
13817 elsif not Rep_Item_Too_Late
(Typ
, N
) then
13818 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
13820 end Finalize_Storage
;
13826 -- pragma Ghost [ (boolean_EXPRESSION) ];
13828 when Pragma_Ghost
=> Ghost
: declare
13832 Orig_Stmt
: Node_Id
;
13833 Prev_Id
: Entity_Id
;
13838 Check_No_Identifiers
;
13839 Check_At_Most_N_Arguments
(1);
13841 Context
:= Parent
(N
);
13843 -- Handle compilation units
13845 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
13846 Context
:= Unit
(Parent
(Context
));
13851 while Present
(Stmt
) loop
13853 -- Skip prior pragmas, but check for duplicates
13855 if Nkind
(Stmt
) = N_Pragma
then
13856 if Pragma_Name
(Stmt
) = Pname
then
13857 Error_Msg_Name_1
:= Pname
;
13858 Error_Msg_Sloc
:= Sloc
(Stmt
);
13859 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
13862 -- Protected and task types cannot be subject to pragma Ghost
13864 elsif Nkind
(Stmt
) = N_Protected_Type_Declaration
then
13865 Error_Pragma
("pragma % cannot apply to a protected type");
13868 elsif Nkind
(Stmt
) = N_Task_Type_Declaration
then
13869 Error_Pragma
("pragma % cannot apply to a task type");
13872 -- Skip internally generated code
13874 elsif not Comes_From_Source
(Stmt
) then
13875 Orig_Stmt
:= Original_Node
(Stmt
);
13877 -- When pragma Ghost applies to an untagged derivation, the
13878 -- derivation is transformed into a [sub]type declaration.
13880 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
13881 N_Subtype_Declaration
)
13882 and then Comes_From_Source
(Orig_Stmt
)
13883 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
13884 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
13885 N_Derived_Type_Definition
13887 Id
:= Defining_Entity
(Stmt
);
13890 -- When pragma Ghost applies to an expression function, the
13891 -- expression function is transformed into a subprogram.
13893 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
13894 and then Comes_From_Source
(Orig_Stmt
)
13895 and then Nkind
(Orig_Stmt
) = N_Expression_Function
13897 Id
:= Defining_Entity
(Stmt
);
13901 -- The pragma applies to a legal construct, stop the traversal
13903 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
13904 N_Full_Type_Declaration
,
13905 N_Generic_Subprogram_Declaration
,
13906 N_Object_Declaration
,
13907 N_Private_Extension_Declaration
,
13908 N_Private_Type_Declaration
,
13909 N_Subprogram_Declaration
,
13910 N_Subtype_Declaration
)
13912 Id
:= Defining_Entity
(Stmt
);
13915 -- The pragma does not apply to a legal construct, issue an
13916 -- error and stop the analysis.
13920 ("pragma % must apply to an object, package, subprogram "
13925 Stmt
:= Prev
(Stmt
);
13930 -- When pragma Ghost is associated with a [generic] package, it
13931 -- appears in the visible declarations.
13933 if Nkind
(Context
) = N_Package_Specification
13934 and then Present
(Visible_Declarations
(Context
))
13935 and then List_Containing
(N
) = Visible_Declarations
(Context
)
13937 Id
:= Defining_Entity
(Context
);
13939 -- Pragma Ghost applies to a stand alone subprogram body
13941 elsif Nkind
(Context
) = N_Subprogram_Body
13942 and then No
(Corresponding_Spec
(Context
))
13944 Id
:= Defining_Entity
(Context
);
13950 ("pragma % must apply to an object, package, subprogram or "
13955 -- A derived type or type extension cannot be subject to pragma
13956 -- Ghost if either the parent type or one of the progenitor types
13957 -- is not Ghost (SPARK RM 6.9(9)).
13959 if Is_Derived_Type
(Id
) then
13960 Check_Ghost_Derivation
(Id
);
13963 -- Handle completions of types and constants that are subject to
13966 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
13967 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
13969 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
13970 Error_Msg_Name_1
:= Pname
;
13972 -- The full declaration of a deferred constant cannot be
13973 -- subject to pragma Ghost unless the deferred declaration
13974 -- is also Ghost (SPARK RM 6.9(10)).
13976 if Ekind
(Prev_Id
) = E_Constant
then
13977 Error_Msg_Name_1
:= Pname
;
13978 Error_Msg_NE
(Fix_Error
13979 ("pragma % must apply to declaration of deferred "
13980 & "constant &"), N
, Id
);
13983 -- Pragma Ghost may appear on the full view of an incomplete
13984 -- type because the incomplete declaration lacks aspects and
13985 -- cannot be subject to pragma Ghost.
13987 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
13990 -- The full declaration of a type cannot be subject to
13991 -- pragma Ghost unless the partial view is also Ghost
13992 -- (SPARK RM 6.9(10)).
13995 Error_Msg_NE
(Fix_Error
13996 ("pragma % must apply to partial view of type &"),
14003 -- Analyze the Boolean expression (if any)
14005 if Present
(Arg1
) then
14006 Expr
:= Get_Pragma_Arg
(Arg1
);
14008 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
14010 if Is_OK_Static_Expression
(Expr
) then
14012 -- "Ghostness" cannot be turned off once enabled within a
14013 -- region (SPARK RM 6.9(7)).
14015 if Is_False
(Expr_Value
(Expr
))
14016 and then Ghost_Mode
> None
14019 ("pragma % with value False cannot appear in enabled "
14024 -- Otherwie the expression is not static
14028 ("expression of pragma % must be static", Expr
);
14033 Set_Is_Ghost_Entity
(Id
);
14040 -- pragma Global (GLOBAL_SPECIFICATION);
14042 -- GLOBAL_SPECIFICATION ::=
14045 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
14047 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
14049 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
14050 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
14051 -- GLOBAL_ITEM ::= NAME
14053 when Pragma_Global
=> Global
: declare
14054 Subp_Decl
: Node_Id
;
14055 Subp_Id
: Entity_Id
;
14059 Check_Arg_Count
(1);
14061 -- Ensure the proper placement of the pragma. Global must be
14062 -- associated with a subprogram declaration or a body that acts
14066 Find_Related_Subprogram_Or_Body
(N
, Do_Checks
=> True);
14068 -- Body acts as spec
14070 if Nkind
(Subp_Decl
) = N_Subprogram_Body
14071 and then No
(Corresponding_Spec
(Subp_Decl
))
14075 -- Body stub acts as spec
14077 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14078 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14082 -- Subprogram declaration
14084 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14092 Subp_Id
:= Defining_Entity
(Subp_Decl
);
14094 Ensure_Aggregate_Form
(Get_Argument
(N
, Subp_Id
));
14096 -- Construct a generic template for the pragma when the context is
14097 -- a generic subprogram and the pragma is a source construct.
14099 Create_Generic_Template
(N
, Subp_Id
);
14101 -- When the pragma appears on a subprogram body, perform the full
14104 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
14105 Analyze_Global_In_Decl_Part
(N
);
14108 -- Chain the pragma on the contract for further processing
14110 Add_Contract_Item
(N
, Subp_Id
);
14117 -- pragma Ident (static_string_EXPRESSION)
14119 -- Note: pragma Comment shares this processing. Pragma Ident is
14120 -- identical in effect to pragma Commment.
14122 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
14127 Check_Arg_Count
(1);
14128 Check_No_Identifiers
;
14129 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
14132 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
14139 GP
:= Parent
(Parent
(N
));
14141 if Nkind_In
(GP
, N_Package_Declaration
,
14142 N_Generic_Package_Declaration
)
14147 -- If we have a compilation unit, then record the ident value,
14148 -- checking for improper duplication.
14150 if Nkind
(GP
) = N_Compilation_Unit
then
14151 CS
:= Ident_String
(Current_Sem_Unit
);
14153 if Present
(CS
) then
14155 -- If we have multiple instances, concatenate them, but
14156 -- not in ASIS, where we want the original tree.
14158 if not ASIS_Mode
then
14159 Start_String
(Strval
(CS
));
14160 Store_String_Char
(' ');
14161 Store_String_Chars
(Strval
(Str
));
14162 Set_Strval
(CS
, End_String
);
14166 Set_Ident_String
(Current_Sem_Unit
, Str
);
14169 -- For subunits, we just ignore the Ident, since in GNAT these
14170 -- are not separate object files, and hence not separate units
14171 -- in the unit table.
14173 elsif Nkind
(GP
) = N_Subunit
then
14179 ----------------------------
14180 -- Implementation_Defined --
14181 ----------------------------
14183 -- pragma Implementation_Defined (LOCAL_NAME);
14185 -- Marks previously declared entity as implementation defined. For
14186 -- an overloaded entity, applies to the most recent homonym.
14188 -- pragma Implementation_Defined;
14190 -- The form with no arguments appears anywhere within a scope, most
14191 -- typically a package spec, and indicates that all entities that are
14192 -- defined within the package spec are Implementation_Defined.
14194 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
14199 Check_No_Identifiers
;
14201 -- Form with no arguments
14203 if Arg_Count
= 0 then
14204 Set_Is_Implementation_Defined
(Current_Scope
);
14206 -- Form with one argument
14209 Check_Arg_Count
(1);
14210 Check_Arg_Is_Local_Name
(Arg1
);
14211 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14212 Set_Is_Implementation_Defined
(Ent
);
14214 end Implementation_Defined
;
14220 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
14222 -- IMPLEMENTATION_KIND ::=
14223 -- By_Entry | By_Protected_Procedure | By_Any | Optional
14225 -- "By_Any" and "Optional" are treated as synonyms in order to
14226 -- support Ada 2012 aspect Synchronization.
14228 when Pragma_Implemented
=> Implemented
: declare
14229 Proc_Id
: Entity_Id
;
14234 Check_Arg_Count
(2);
14235 Check_No_Identifiers
;
14236 Check_Arg_Is_Identifier
(Arg1
);
14237 Check_Arg_Is_Local_Name
(Arg1
);
14238 Check_Arg_Is_One_Of
(Arg2
,
14241 Name_By_Protected_Procedure
,
14244 -- Extract the name of the local procedure
14246 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14248 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
14249 -- primitive procedure of a synchronized tagged type.
14251 if Ekind
(Proc_Id
) = E_Procedure
14252 and then Is_Primitive
(Proc_Id
)
14253 and then Present
(First_Formal
(Proc_Id
))
14255 Typ
:= Etype
(First_Formal
(Proc_Id
));
14257 if Is_Tagged_Type
(Typ
)
14260 -- Check for a protected, a synchronized or a task interface
14262 ((Is_Interface
(Typ
)
14263 and then Is_Synchronized_Interface
(Typ
))
14265 -- Check for a protected type or a task type that implements
14269 (Is_Concurrent_Record_Type
(Typ
)
14270 and then Present
(Interfaces
(Typ
)))
14272 -- In analysis-only mode, examine original protected type
14275 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
14276 and then Present
(Interface_List
(Parent
(Typ
))))
14278 -- Check for a private record extension with keyword
14282 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
14283 E_Record_Subtype_With_Private
)
14284 and then Synchronized_Present
(Parent
(Typ
))))
14289 ("controlling formal must be of synchronized tagged type",
14294 -- Procedures declared inside a protected type must be accepted
14296 elsif Ekind
(Proc_Id
) = E_Procedure
14297 and then Is_Protected_Type
(Scope
(Proc_Id
))
14301 -- The first argument is not a primitive procedure
14305 ("pragma % must be applied to a primitive procedure", Arg1
);
14309 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
14310 -- By_Protected_Procedure to the primitive procedure of a task
14313 if Chars
(Arg2
) = Name_By_Protected_Procedure
14314 and then Is_Interface
(Typ
)
14315 and then Is_Task_Interface
(Typ
)
14318 ("implementation kind By_Protected_Procedure cannot be "
14319 & "applied to a task interface primitive", Arg2
);
14323 Record_Rep_Item
(Proc_Id
, N
);
14326 ----------------------
14327 -- Implicit_Packing --
14328 ----------------------
14330 -- pragma Implicit_Packing;
14332 when Pragma_Implicit_Packing
=>
14334 Check_Arg_Count
(0);
14335 Implicit_Packing
:= True;
14342 -- [Convention =>] convention_IDENTIFIER,
14343 -- [Entity =>] LOCAL_NAME
14344 -- [, [External_Name =>] static_string_EXPRESSION ]
14345 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14347 when Pragma_Import
=>
14348 Check_Ada_83_Warning
;
14352 Name_External_Name
,
14355 Check_At_Least_N_Arguments
(2);
14356 Check_At_Most_N_Arguments
(4);
14357 Process_Import_Or_Interface
;
14359 ---------------------
14360 -- Import_Function --
14361 ---------------------
14363 -- pragma Import_Function (
14364 -- [Internal =>] LOCAL_NAME,
14365 -- [, [External =>] EXTERNAL_SYMBOL]
14366 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14367 -- [, [Result_Type =>] SUBTYPE_MARK]
14368 -- [, [Mechanism =>] MECHANISM]
14369 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14371 -- EXTERNAL_SYMBOL ::=
14373 -- | static_string_EXPRESSION
14375 -- PARAMETER_TYPES ::=
14377 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14379 -- TYPE_DESIGNATOR ::=
14381 -- | subtype_Name ' Access
14385 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14387 -- MECHANISM_ASSOCIATION ::=
14388 -- [formal_parameter_NAME =>] MECHANISM_NAME
14390 -- MECHANISM_NAME ::=
14394 when Pragma_Import_Function
=> Import_Function
: declare
14395 Args
: Args_List
(1 .. 6);
14396 Names
: constant Name_List
(1 .. 6) := (
14399 Name_Parameter_Types
,
14402 Name_Result_Mechanism
);
14404 Internal
: Node_Id
renames Args
(1);
14405 External
: Node_Id
renames Args
(2);
14406 Parameter_Types
: Node_Id
renames Args
(3);
14407 Result_Type
: Node_Id
renames Args
(4);
14408 Mechanism
: Node_Id
renames Args
(5);
14409 Result_Mechanism
: Node_Id
renames Args
(6);
14413 Gather_Associations
(Names
, Args
);
14414 Process_Extended_Import_Export_Subprogram_Pragma
(
14415 Arg_Internal
=> Internal
,
14416 Arg_External
=> External
,
14417 Arg_Parameter_Types
=> Parameter_Types
,
14418 Arg_Result_Type
=> Result_Type
,
14419 Arg_Mechanism
=> Mechanism
,
14420 Arg_Result_Mechanism
=> Result_Mechanism
);
14421 end Import_Function
;
14423 -------------------
14424 -- Import_Object --
14425 -------------------
14427 -- pragma Import_Object (
14428 -- [Internal =>] LOCAL_NAME
14429 -- [, [External =>] EXTERNAL_SYMBOL]
14430 -- [, [Size =>] EXTERNAL_SYMBOL]);
14432 -- EXTERNAL_SYMBOL ::=
14434 -- | static_string_EXPRESSION
14436 when Pragma_Import_Object
=> Import_Object
: declare
14437 Args
: Args_List
(1 .. 3);
14438 Names
: constant Name_List
(1 .. 3) := (
14443 Internal
: Node_Id
renames Args
(1);
14444 External
: Node_Id
renames Args
(2);
14445 Size
: Node_Id
renames Args
(3);
14449 Gather_Associations
(Names
, Args
);
14450 Process_Extended_Import_Export_Object_Pragma
(
14451 Arg_Internal
=> Internal
,
14452 Arg_External
=> External
,
14456 ----------------------
14457 -- Import_Procedure --
14458 ----------------------
14460 -- pragma Import_Procedure (
14461 -- [Internal =>] LOCAL_NAME
14462 -- [, [External =>] EXTERNAL_SYMBOL]
14463 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14464 -- [, [Mechanism =>] MECHANISM]);
14466 -- EXTERNAL_SYMBOL ::=
14468 -- | static_string_EXPRESSION
14470 -- PARAMETER_TYPES ::=
14472 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14474 -- TYPE_DESIGNATOR ::=
14476 -- | subtype_Name ' Access
14480 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14482 -- MECHANISM_ASSOCIATION ::=
14483 -- [formal_parameter_NAME =>] MECHANISM_NAME
14485 -- MECHANISM_NAME ::=
14489 when Pragma_Import_Procedure
=> Import_Procedure
: declare
14490 Args
: Args_List
(1 .. 4);
14491 Names
: constant Name_List
(1 .. 4) := (
14494 Name_Parameter_Types
,
14497 Internal
: Node_Id
renames Args
(1);
14498 External
: Node_Id
renames Args
(2);
14499 Parameter_Types
: Node_Id
renames Args
(3);
14500 Mechanism
: Node_Id
renames Args
(4);
14504 Gather_Associations
(Names
, Args
);
14505 Process_Extended_Import_Export_Subprogram_Pragma
(
14506 Arg_Internal
=> Internal
,
14507 Arg_External
=> External
,
14508 Arg_Parameter_Types
=> Parameter_Types
,
14509 Arg_Mechanism
=> Mechanism
);
14510 end Import_Procedure
;
14512 -----------------------------
14513 -- Import_Valued_Procedure --
14514 -----------------------------
14516 -- pragma Import_Valued_Procedure (
14517 -- [Internal =>] LOCAL_NAME
14518 -- [, [External =>] EXTERNAL_SYMBOL]
14519 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14520 -- [, [Mechanism =>] MECHANISM]);
14522 -- EXTERNAL_SYMBOL ::=
14524 -- | static_string_EXPRESSION
14526 -- PARAMETER_TYPES ::=
14528 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14530 -- TYPE_DESIGNATOR ::=
14532 -- | subtype_Name ' Access
14536 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14538 -- MECHANISM_ASSOCIATION ::=
14539 -- [formal_parameter_NAME =>] MECHANISM_NAME
14541 -- MECHANISM_NAME ::=
14545 when Pragma_Import_Valued_Procedure
=>
14546 Import_Valued_Procedure
: declare
14547 Args
: Args_List
(1 .. 4);
14548 Names
: constant Name_List
(1 .. 4) := (
14551 Name_Parameter_Types
,
14554 Internal
: Node_Id
renames Args
(1);
14555 External
: Node_Id
renames Args
(2);
14556 Parameter_Types
: Node_Id
renames Args
(3);
14557 Mechanism
: Node_Id
renames Args
(4);
14561 Gather_Associations
(Names
, Args
);
14562 Process_Extended_Import_Export_Subprogram_Pragma
(
14563 Arg_Internal
=> Internal
,
14564 Arg_External
=> External
,
14565 Arg_Parameter_Types
=> Parameter_Types
,
14566 Arg_Mechanism
=> Mechanism
);
14567 end Import_Valued_Procedure
;
14573 -- pragma Independent (LOCAL_NAME);
14575 when Pragma_Independent
=>
14576 Process_Atomic_Independent_Shared_Volatile
;
14578 ----------------------------
14579 -- Independent_Components --
14580 ----------------------------
14582 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
14584 when Pragma_Independent_Components
=> Independent_Components
: declare
14592 Check_Ada_83_Warning
;
14594 Check_No_Identifiers
;
14595 Check_Arg_Count
(1);
14596 Check_Arg_Is_Local_Name
(Arg1
);
14597 E_Id
:= Get_Pragma_Arg
(Arg1
);
14599 if Etype
(E_Id
) = Any_Type
then
14603 E
:= Entity
(E_Id
);
14605 -- Check duplicate before we chain ourselves
14607 Check_Duplicate_Pragma
(E
);
14609 -- Check appropriate entity
14611 if Rep_Item_Too_Early
(E
, N
)
14613 Rep_Item_Too_Late
(E
, N
)
14618 D
:= Declaration_Node
(E
);
14621 -- The flag is set on the base type, or on the object
14623 if K
= N_Full_Type_Declaration
14624 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
14626 Set_Has_Independent_Components
(Base_Type
(E
));
14627 Record_Independence_Check
(N
, Base_Type
(E
));
14629 -- For record type, set all components independent
14631 if Is_Record_Type
(E
) then
14632 C
:= First_Component
(E
);
14633 while Present
(C
) loop
14634 Set_Is_Independent
(C
);
14635 Next_Component
(C
);
14639 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
14640 and then Nkind
(D
) = N_Object_Declaration
14641 and then Nkind
(Object_Definition
(D
)) =
14642 N_Constrained_Array_Definition
14644 Set_Has_Independent_Components
(E
);
14645 Record_Independence_Check
(N
, E
);
14648 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
14650 end Independent_Components
;
14652 -----------------------
14653 -- Initial_Condition --
14654 -----------------------
14656 -- pragma Initial_Condition (boolean_EXPRESSION);
14658 when Pragma_Initial_Condition
=> Initial_Condition
: declare
14659 Pack_Decl
: Node_Id
;
14660 Pack_Id
: Entity_Id
;
14664 Check_No_Identifiers
;
14665 Check_Arg_Count
(1);
14667 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
14669 -- Ensure the proper placement of the pragma. Initial_Condition
14670 -- must be associated with a package declaration.
14672 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
14673 N_Package_Declaration
)
14677 -- Otherwise the pragma is associated with an illegal context
14684 -- The pragma must be analyzed at the end of the visible
14685 -- declarations of the related package. Save the pragma for later
14686 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to
14687 -- the contract of the package.
14689 Pack_Id
:= Defining_Entity
(Pack_Decl
);
14690 Add_Contract_Item
(N
, Pack_Id
);
14692 -- Verify the declaration order of pragma Initial_Condition with
14693 -- respect to pragmas Abstract_State and Initializes when SPARK
14694 -- checks are enabled.
14696 if SPARK_Mode
/= Off
then
14697 Check_Declaration_Order
14698 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
14701 Check_Declaration_Order
14702 (First
=> Get_Pragma
(Pack_Id
, Pragma_Initializes
),
14705 end Initial_Condition
;
14707 ------------------------
14708 -- Initialize_Scalars --
14709 ------------------------
14711 -- pragma Initialize_Scalars;
14713 when Pragma_Initialize_Scalars
=>
14715 Check_Arg_Count
(0);
14716 Check_Valid_Configuration_Pragma
;
14717 Check_Restriction
(No_Initialize_Scalars
, N
);
14719 -- Initialize_Scalars creates false positives in CodePeer, and
14720 -- incorrect negative results in GNATprove mode, so ignore this
14721 -- pragma in these modes.
14723 if not Restriction_Active
(No_Initialize_Scalars
)
14724 and then not (CodePeer_Mode
or GNATprove_Mode
)
14726 Init_Or_Norm_Scalars
:= True;
14727 Initialize_Scalars
:= True;
14734 -- pragma Initializes (INITIALIZATION_SPEC);
14736 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST
14738 -- INITIALIZATION_LIST ::=
14739 -- INITIALIZATION_ITEM
14740 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
14742 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
14747 -- | (INPUT {, INPUT})
14751 when Pragma_Initializes
=> Initializes
: declare
14752 Pack_Decl
: Node_Id
;
14753 Pack_Id
: Entity_Id
;
14757 Check_No_Identifiers
;
14758 Check_Arg_Count
(1);
14760 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
14762 -- Ensure the proper placement of the pragma. Initializes must be
14763 -- associated with a package declaration.
14765 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
14766 N_Package_Declaration
)
14770 -- Otherwise the pragma is associated with an illegal construc
14777 Ensure_Aggregate_Form
(Get_Argument
(N
));
14779 -- The pragma must be analyzed at the end of the visible
14780 -- declarations of the related package. Save the pragma for later
14781 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the
14782 -- contract of the package.
14784 Pack_Id
:= Defining_Entity
(Pack_Decl
);
14785 Add_Contract_Item
(N
, Pack_Id
);
14787 -- Verify the declaration order of pragmas Abstract_State and
14788 -- Initializes when SPARK checks are enabled.
14790 if SPARK_Mode
/= Off
then
14791 Check_Declaration_Order
14792 (First
=> Get_Pragma
(Pack_Id
, Pragma_Abstract_State
),
14801 -- pragma Inline ( NAME {, NAME} );
14803 when Pragma_Inline
=>
14805 -- Pragma always active unless in GNATprove mode. It is disabled
14806 -- in GNATprove mode because frontend inlining is applied
14807 -- independently of pragmas Inline and Inline_Always for
14808 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
14811 if not GNATprove_Mode
then
14813 -- Inline status is Enabled if inlining option is active
14815 if Inline_Active
then
14816 Process_Inline
(Enabled
);
14818 Process_Inline
(Disabled
);
14822 -------------------
14823 -- Inline_Always --
14824 -------------------
14826 -- pragma Inline_Always ( NAME {, NAME} );
14828 when Pragma_Inline_Always
=>
14831 -- Pragma always active unless in CodePeer mode or GNATprove
14832 -- mode. It is disabled in CodePeer mode because inlining is
14833 -- not helpful, and enabling it caused walk order issues. It
14834 -- is disabled in GNATprove mode because frontend inlining is
14835 -- applied independently of pragmas Inline and Inline_Always for
14836 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
14839 if not CodePeer_Mode
and not GNATprove_Mode
then
14840 Process_Inline
(Enabled
);
14843 --------------------
14844 -- Inline_Generic --
14845 --------------------
14847 -- pragma Inline_Generic (NAME {, NAME});
14849 when Pragma_Inline_Generic
=>
14851 Process_Generic_List
;
14853 ----------------------
14854 -- Inspection_Point --
14855 ----------------------
14857 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
14859 when Pragma_Inspection_Point
=> Inspection_Point
: declare
14866 if Arg_Count
> 0 then
14869 Exp
:= Get_Pragma_Arg
(Arg
);
14872 if not Is_Entity_Name
(Exp
)
14873 or else not Is_Object
(Entity
(Exp
))
14875 Error_Pragma_Arg
("object name required", Arg
);
14879 exit when No
(Arg
);
14882 end Inspection_Point
;
14888 -- pragma Interface (
14889 -- [ Convention =>] convention_IDENTIFIER,
14890 -- [ Entity =>] LOCAL_NAME
14891 -- [, [External_Name =>] static_string_EXPRESSION ]
14892 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14894 when Pragma_Interface
=>
14899 Name_External_Name
,
14901 Check_At_Least_N_Arguments
(2);
14902 Check_At_Most_N_Arguments
(4);
14903 Process_Import_Or_Interface
;
14905 -- In Ada 2005, the permission to use Interface (a reserved word)
14906 -- as a pragma name is considered an obsolescent feature, and this
14907 -- pragma was already obsolescent in Ada 95.
14909 if Ada_Version
>= Ada_95
then
14911 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
14913 if Warn_On_Obsolescent_Feature
then
14915 ("pragma Interface is an obsolescent feature?j?", N
);
14917 ("|use pragma Import instead?j?", N
);
14921 --------------------
14922 -- Interface_Name --
14923 --------------------
14925 -- pragma Interface_Name (
14926 -- [ Entity =>] LOCAL_NAME
14927 -- [,[External_Name =>] static_string_EXPRESSION ]
14928 -- [,[Link_Name =>] static_string_EXPRESSION ]);
14930 when Pragma_Interface_Name
=> Interface_Name
: declare
14932 Def_Id
: Entity_Id
;
14933 Hom_Id
: Entity_Id
;
14939 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
14940 Check_At_Least_N_Arguments
(2);
14941 Check_At_Most_N_Arguments
(3);
14942 Id
:= Get_Pragma_Arg
(Arg1
);
14945 -- This is obsolete from Ada 95 on, but it is an implementation
14946 -- defined pragma, so we do not consider that it violates the
14947 -- restriction (No_Obsolescent_Features).
14949 if Ada_Version
>= Ada_95
then
14950 if Warn_On_Obsolescent_Feature
then
14952 ("pragma Interface_Name is an obsolescent feature?j?", N
);
14954 ("|use pragma Import instead?j?", N
);
14958 if not Is_Entity_Name
(Id
) then
14960 ("first argument for pragma% must be entity name", Arg1
);
14961 elsif Etype
(Id
) = Any_Type
then
14964 Def_Id
:= Entity
(Id
);
14967 -- Special DEC-compatible processing for the object case, forces
14968 -- object to be imported.
14970 if Ekind
(Def_Id
) = E_Variable
then
14971 Kill_Size_Check_Code
(Def_Id
);
14972 Note_Possible_Modification
(Id
, Sure
=> False);
14974 -- Initialization is not allowed for imported variable
14976 if Present
(Expression
(Parent
(Def_Id
)))
14977 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
14979 Error_Msg_Sloc
:= Sloc
(Def_Id
);
14981 ("no initialization allowed for declaration of& #",
14985 -- For compatibility, support VADS usage of providing both
14986 -- pragmas Interface and Interface_Name to obtain the effect
14987 -- of a single Import pragma.
14989 if Is_Imported
(Def_Id
)
14990 and then Present
(First_Rep_Item
(Def_Id
))
14991 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
14993 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
14997 Set_Imported
(Def_Id
);
15000 Set_Is_Public
(Def_Id
);
15001 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15004 -- Otherwise must be subprogram
15006 elsif not Is_Subprogram
(Def_Id
) then
15008 ("argument of pragma% is not subprogram", Arg1
);
15011 Check_At_Most_N_Arguments
(3);
15015 -- Loop through homonyms
15018 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15020 if Is_Imported
(Def_Id
) then
15021 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
15025 exit when From_Aspect_Specification
(N
);
15026 Hom_Id
:= Homonym
(Hom_Id
);
15028 exit when No
(Hom_Id
)
15029 or else Scope
(Hom_Id
) /= Current_Scope
;
15034 ("argument of pragma% is not imported subprogram",
15038 end Interface_Name
;
15040 -----------------------
15041 -- Interrupt_Handler --
15042 -----------------------
15044 -- pragma Interrupt_Handler (handler_NAME);
15046 when Pragma_Interrupt_Handler
=>
15047 Check_Ada_83_Warning
;
15048 Check_Arg_Count
(1);
15049 Check_No_Identifiers
;
15051 if No_Run_Time_Mode
then
15052 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
15054 Check_Interrupt_Or_Attach_Handler
;
15055 Process_Interrupt_Or_Attach_Handler
;
15058 ------------------------
15059 -- Interrupt_Priority --
15060 ------------------------
15062 -- pragma Interrupt_Priority [(EXPRESSION)];
15064 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
15065 P
: constant Node_Id
:= Parent
(N
);
15070 Check_Ada_83_Warning
;
15072 if Arg_Count
/= 0 then
15073 Arg
:= Get_Pragma_Arg
(Arg1
);
15074 Check_Arg_Count
(1);
15075 Check_No_Identifiers
;
15077 -- The expression must be analyzed in the special manner
15078 -- described in "Handling of Default and Per-Object
15079 -- Expressions" in sem.ads.
15081 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
15084 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
15089 Ent
:= Defining_Identifier
(Parent
(P
));
15091 -- Check duplicate pragma before we chain the pragma in the Rep
15092 -- Item chain of Ent.
15094 Check_Duplicate_Pragma
(Ent
);
15095 Record_Rep_Item
(Ent
, N
);
15097 end Interrupt_Priority
;
15099 ---------------------
15100 -- Interrupt_State --
15101 ---------------------
15103 -- pragma Interrupt_State (
15104 -- [Name =>] INTERRUPT_ID,
15105 -- [State =>] INTERRUPT_STATE);
15107 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
15108 -- INTERRUPT_STATE => System | Runtime | User
15110 -- Note: if the interrupt id is given as an identifier, then it must
15111 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
15112 -- given as a static integer expression which must be in the range of
15113 -- Ada.Interrupts.Interrupt_ID.
15115 when Pragma_Interrupt_State
=> Interrupt_State
: declare
15116 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
15117 -- This is the entity Ada.Interrupts.Interrupt_ID;
15119 State_Type
: Character;
15120 -- Set to 's'/'r'/'u' for System/Runtime/User
15123 -- Index to entry in Interrupt_States table
15126 -- Value of interrupt
15128 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15129 -- The first argument to the pragma
15131 Int_Ent
: Entity_Id
;
15132 -- Interrupt entity in Ada.Interrupts.Names
15136 Check_Arg_Order
((Name_Name
, Name_State
));
15137 Check_Arg_Count
(2);
15139 Check_Optional_Identifier
(Arg1
, Name_Name
);
15140 Check_Optional_Identifier
(Arg2
, Name_State
);
15141 Check_Arg_Is_Identifier
(Arg2
);
15143 -- First argument is identifier
15145 if Nkind
(Arg1X
) = N_Identifier
then
15147 -- Search list of names in Ada.Interrupts.Names
15149 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
15151 if No
(Int_Ent
) then
15152 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
15154 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
15155 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
15159 Next_Entity
(Int_Ent
);
15162 -- First argument is not an identifier, so it must be a static
15163 -- expression of type Ada.Interrupts.Interrupt_ID.
15166 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15167 Int_Val
:= Expr_Value
(Arg1X
);
15169 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
15171 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
15174 ("value not in range of type "
15175 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
15181 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15182 when Name_Runtime
=> State_Type
:= 'r';
15183 when Name_System
=> State_Type
:= 's';
15184 when Name_User
=> State_Type
:= 'u';
15187 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
15190 -- Check if entry is already stored
15192 IST_Num
:= Interrupt_States
.First
;
15194 -- If entry not found, add it
15196 if IST_Num
> Interrupt_States
.Last
then
15197 Interrupt_States
.Append
15198 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
15199 Interrupt_State
=> State_Type
,
15200 Pragma_Loc
=> Loc
));
15203 -- Case of entry for the same entry
15205 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
15208 -- If state matches, done, no need to make redundant entry
15211 State_Type
= Interrupt_States
.Table
(IST_Num
).
15214 -- Otherwise if state does not match, error
15217 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
15219 ("state conflicts with that given #", Arg2
);
15223 IST_Num
:= IST_Num
+ 1;
15225 end Interrupt_State
;
15231 -- pragma Invariant
15232 -- ([Entity =>] type_LOCAL_NAME,
15233 -- [Check =>] EXPRESSION
15234 -- [,[Message =>] String_Expression]);
15236 when Pragma_Invariant
=> Invariant
: declare
15243 Check_At_Least_N_Arguments
(2);
15244 Check_At_Most_N_Arguments
(3);
15245 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15246 Check_Optional_Identifier
(Arg2
, Name_Check
);
15248 if Arg_Count
= 3 then
15249 Check_Optional_Identifier
(Arg3
, Name_Message
);
15250 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
15253 Check_Arg_Is_Local_Name
(Arg1
);
15255 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15256 Find_Type
(Type_Id
);
15257 Typ
:= Entity
(Type_Id
);
15259 if Typ
= Any_Type
then
15262 -- An invariant must apply to a private type, or appear in the
15263 -- private part of a package spec and apply to a completion.
15264 -- a class-wide invariant can only appear on a private declaration
15265 -- or private extension, not a completion.
15267 elsif Ekind_In
(Typ
, E_Private_Type
,
15268 E_Record_Type_With_Private
,
15269 E_Limited_Private_Type
)
15273 elsif In_Private_Part
(Current_Scope
)
15274 and then Has_Private_Declaration
(Typ
)
15275 and then not Class_Present
(N
)
15279 elsif In_Private_Part
(Current_Scope
) then
15281 ("pragma% only allowed for private type declared in "
15282 & "visible part", Arg1
);
15286 ("pragma% only allowed for private type", Arg1
);
15289 -- Not allowed for abstract type in the non-class case (it is
15290 -- allowed to use Invariant'Class for abstract types).
15292 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
15294 ("pragma% not allowed for abstract type", Arg1
);
15297 -- Note that the type has at least one invariant, and also that
15298 -- it has inheritable invariants if we have Invariant'Class
15299 -- or Type_Invariant'Class. Build the corresponding invariant
15300 -- procedure declaration, so that calls to it can be generated
15301 -- before the body is built (e.g. within an expression function).
15303 Insert_After_And_Analyze
15304 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
15306 if Class_Present
(N
) then
15307 Set_Has_Inheritable_Invariants
(Typ
);
15310 -- The remaining processing is simply to link the pragma on to
15311 -- the rep item chain, for processing when the type is frozen.
15312 -- This is accomplished by a call to Rep_Item_Too_Late.
15314 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15317 ----------------------
15318 -- Java_Constructor --
15319 ----------------------
15321 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
15323 -- Also handles pragma CIL_Constructor
15325 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
15326 Java_Constructor
: declare
15327 Convention
: Convention_Id
;
15328 Def_Id
: Entity_Id
;
15329 Hom_Id
: Entity_Id
;
15331 This_Formal
: Entity_Id
;
15335 Check_Arg_Count
(1);
15336 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15337 Check_Arg_Is_Local_Name
(Arg1
);
15339 Id
:= Get_Pragma_Arg
(Arg1
);
15340 Find_Program_Unit_Name
(Id
);
15342 -- If we did not find the name, we are done
15344 if Etype
(Id
) = Any_Type
then
15348 -- Check wrong use of pragma in wrong VM target
15350 if VM_Target
= No_VM
then
15353 elsif VM_Target
= CLI_Target
15354 and then Prag_Id
= Pragma_Java_Constructor
15356 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
15358 elsif VM_Target
= JVM_Target
15359 and then Prag_Id
= Pragma_CIL_Constructor
15361 Error_Pragma
("must use pragma 'Java_'Constructor");
15365 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
15366 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
15367 when others => null;
15370 Hom_Id
:= Entity
(Id
);
15372 -- Loop through homonyms
15375 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
15377 -- The constructor is required to be a function
15379 if Ekind
(Def_Id
) /= E_Function
then
15380 if VM_Target
= JVM_Target
then
15382 ("pragma% requires function returning a 'Java access "
15386 ("pragma% requires function returning a 'C'I'L access "
15391 -- Check arguments: For tagged type the first formal must be
15392 -- named "this" and its type must be a named access type
15393 -- designating a class-wide tagged type that has convention
15394 -- CIL/Java. The first formal must also have a null default
15395 -- value. For example:
15397 -- type Typ is tagged ...
15398 -- type Ref is access all Typ;
15399 -- pragma Convention (CIL, Typ);
15401 -- function New_Typ (This : Ref) return Ref;
15402 -- function New_Typ (This : Ref; I : Integer) return Ref;
15403 -- pragma Cil_Constructor (New_Typ);
15405 -- Reason: The first formal must NOT be a primitive of the
15408 -- This rule also applies to constructors of delegates used
15409 -- to interface with standard target libraries. For example:
15411 -- type Delegate is access procedure ...
15412 -- pragma Import (CIL, Delegate, ...);
15414 -- function new_Delegate
15415 -- (This : Delegate := null; ... ) return Delegate;
15417 -- For value-types this rule does not apply.
15419 if not Is_Value_Type
(Etype
(Def_Id
)) then
15420 if No
(First_Formal
(Def_Id
)) then
15421 Error_Msg_Name_1
:= Pname
;
15422 Error_Msg_N
("% function must have parameters", Def_Id
);
15426 -- In the JRE library we have several occurrences in which
15427 -- the "this" parameter is not the first formal.
15429 This_Formal
:= First_Formal
(Def_Id
);
15431 -- In the JRE library we have several occurrences in which
15432 -- the "this" parameter is not the first formal. Search for
15435 if VM_Target
= JVM_Target
then
15436 while Present
(This_Formal
)
15437 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
15439 Next_Formal
(This_Formal
);
15442 if No
(This_Formal
) then
15443 This_Formal
:= First_Formal
(Def_Id
);
15447 -- Warning: The first parameter should be named "this".
15448 -- We temporarily allow it because we have the following
15449 -- case in the Java runtime (file s-osinte.ads) ???
15451 -- function new_Thread
15452 -- (Self_Id : System.Address) return Thread_Id;
15453 -- pragma Java_Constructor (new_Thread);
15455 if VM_Target
= JVM_Target
15456 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
15458 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
15462 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
15463 Error_Msg_Name_1
:= Pname
;
15465 ("first formal of % function must be named `this`",
15466 Parent
(This_Formal
));
15468 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
15469 Error_Msg_Name_1
:= Pname
;
15471 ("first formal of % function must be an access type",
15472 Parameter_Type
(Parent
(This_Formal
)));
15474 -- For delegates the type of the first formal must be a
15475 -- named access-to-subprogram type (see previous example)
15477 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
15478 and then Ekind
(Etype
(This_Formal
))
15479 /= E_Access_Subprogram_Type
15481 Error_Msg_Name_1
:= Pname
;
15483 ("first formal of % function must be a named access "
15484 & "to subprogram type",
15485 Parameter_Type
(Parent
(This_Formal
)));
15487 -- Warning: We should reject anonymous access types because
15488 -- the constructor must not be handled as a primitive of the
15489 -- tagged type. We temporarily allow it because this profile
15490 -- is currently generated by cil2ada???
15492 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
15493 and then not Ekind_In
(Etype
(This_Formal
),
15495 E_General_Access_Type
,
15496 E_Anonymous_Access_Type
)
15498 Error_Msg_Name_1
:= Pname
;
15500 ("first formal of % function must be a named access "
15501 & "type", Parameter_Type
(Parent
(This_Formal
)));
15503 elsif Atree
.Convention
15504 (Designated_Type
(Etype
(This_Formal
))) /= Convention
15506 Error_Msg_Name_1
:= Pname
;
15508 if Convention
= Convention_Java
then
15510 ("pragma% requires convention 'Cil in designated "
15511 & "type", Parameter_Type
(Parent
(This_Formal
)));
15514 ("pragma% requires convention 'Java in designated "
15515 & "type", Parameter_Type
(Parent
(This_Formal
)));
15518 elsif No
(Expression
(Parent
(This_Formal
)))
15519 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
15521 Error_Msg_Name_1
:= Pname
;
15523 ("pragma% requires first formal with default `null`",
15524 Parameter_Type
(Parent
(This_Formal
)));
15528 -- Check result type: the constructor must be a function
15530 -- * a value type (only allowed in the CIL compiler)
15531 -- * an access-to-subprogram type with convention Java/CIL
15532 -- * an access-type designating a type that has convention
15535 if Is_Value_Type
(Etype
(Def_Id
)) then
15538 -- Access-to-subprogram type with convention Java/CIL
15540 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
15541 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
15542 if Convention
= Convention_Java
then
15544 ("pragma% requires function returning a 'Java "
15545 & "access type", Arg1
);
15547 pragma Assert
(Convention
= Convention_CIL
);
15549 ("pragma% requires function returning a 'C'I'L "
15550 & "access type", Arg1
);
15554 elsif Is_Access_Type
(Etype
(Def_Id
)) then
15555 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
15556 E_General_Access_Type
)
15559 (Designated_Type
(Etype
(Def_Id
))) /= Convention
15561 Error_Msg_Name_1
:= Pname
;
15563 if Convention
= Convention_Java
then
15565 ("pragma% requires function returning a named "
15566 & "'Java access type", Arg1
);
15569 ("pragma% requires function returning a named "
15570 & "'C'I'L access type", Arg1
);
15575 Set_Is_Constructor
(Def_Id
);
15576 Set_Convention
(Def_Id
, Convention
);
15577 Set_Is_Imported
(Def_Id
);
15579 exit when From_Aspect_Specification
(N
);
15580 Hom_Id
:= Homonym
(Hom_Id
);
15582 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
15584 end Java_Constructor
;
15586 ----------------------
15587 -- Java_Interface --
15588 ----------------------
15590 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
15592 when Pragma_Java_Interface
=> Java_Interface
: declare
15598 Check_Arg_Count
(1);
15599 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15600 Check_Arg_Is_Local_Name
(Arg1
);
15602 Arg
:= Get_Pragma_Arg
(Arg1
);
15605 if Etype
(Arg
) = Any_Type
then
15609 if not Is_Entity_Name
(Arg
)
15610 or else not Is_Type
(Entity
(Arg
))
15612 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
15615 Typ
:= Underlying_Type
(Entity
(Arg
));
15617 -- For now simply check some of the semantic constraints on the
15618 -- type. This currently leaves out some restrictions on interface
15619 -- types, namely that the parent type must be java.lang.Object.Typ
15620 -- and that all primitives of the type should be declared
15623 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
15625 ("pragma% requires an abstract tagged type", Arg1
);
15627 elsif not Has_Discriminants
(Typ
)
15628 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
15629 /= E_Anonymous_Access_Type
15631 not Is_Class_Wide_Type
15632 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
15635 ("type must have a class-wide access discriminant", Arg1
);
15637 end Java_Interface
;
15643 -- pragma Keep_Names ([On => ] LOCAL_NAME);
15645 when Pragma_Keep_Names
=> Keep_Names
: declare
15650 Check_Arg_Count
(1);
15651 Check_Optional_Identifier
(Arg1
, Name_On
);
15652 Check_Arg_Is_Local_Name
(Arg1
);
15654 Arg
:= Get_Pragma_Arg
(Arg1
);
15657 if Etype
(Arg
) = Any_Type
then
15661 if not Is_Entity_Name
(Arg
)
15662 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
15665 ("pragma% requires a local enumeration type", Arg1
);
15668 Set_Discard_Names
(Entity
(Arg
), False);
15675 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
15677 when Pragma_License
=>
15680 -- Do not analyze pragma any further in CodePeer mode, to avoid
15681 -- extraneous errors in this implementation-dependent pragma,
15682 -- which has a different profile on other compilers.
15684 if CodePeer_Mode
then
15688 Check_Arg_Count
(1);
15689 Check_No_Identifiers
;
15690 Check_Valid_Configuration_Pragma
;
15691 Check_Arg_Is_Identifier
(Arg1
);
15694 Sind
: constant Source_File_Index
:=
15695 Source_Index
(Current_Sem_Unit
);
15698 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15700 Set_License
(Sind
, GPL
);
15702 when Name_Modified_GPL
=>
15703 Set_License
(Sind
, Modified_GPL
);
15705 when Name_Restricted
=>
15706 Set_License
(Sind
, Restricted
);
15708 when Name_Unrestricted
=>
15709 Set_License
(Sind
, Unrestricted
);
15712 Error_Pragma_Arg
("invalid license name", Arg1
);
15720 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
15722 when Pragma_Link_With
=> Link_With
: declare
15728 if Operating_Mode
= Generate_Code
15729 and then In_Extended_Main_Source_Unit
(N
)
15731 Check_At_Least_N_Arguments
(1);
15732 Check_No_Identifiers
;
15733 Check_Is_In_Decl_Part_Or_Package_Spec
;
15734 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15738 while Present
(Arg
) loop
15739 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
15741 -- Store argument, converting sequences of spaces to a
15742 -- single null character (this is one of the differences
15743 -- in processing between Link_With and Linker_Options).
15745 Arg_Store
: declare
15746 C
: constant Char_Code
:= Get_Char_Code
(' ');
15747 S
: constant String_Id
:=
15748 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
15749 L
: constant Nat
:= String_Length
(S
);
15752 procedure Skip_Spaces
;
15753 -- Advance F past any spaces
15759 procedure Skip_Spaces
is
15761 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
15766 -- Start of processing for Arg_Store
15769 Skip_Spaces
; -- skip leading spaces
15771 -- Loop through characters, changing any embedded
15772 -- sequence of spaces to a single null character (this
15773 -- is how Link_With/Linker_Options differ)
15776 if Get_String_Char
(S
, F
) = C
then
15779 Store_String_Char
(ASCII
.NUL
);
15782 Store_String_Char
(Get_String_Char
(S
, F
));
15790 if Present
(Arg
) then
15791 Store_String_Char
(ASCII
.NUL
);
15795 Store_Linker_Option_String
(End_String
);
15803 -- pragma Linker_Alias (
15804 -- [Entity =>] LOCAL_NAME
15805 -- [Target =>] static_string_EXPRESSION);
15807 when Pragma_Linker_Alias
=>
15809 Check_Arg_Order
((Name_Entity
, Name_Target
));
15810 Check_Arg_Count
(2);
15811 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15812 Check_Optional_Identifier
(Arg2
, Name_Target
);
15813 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
15814 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
15816 -- The only processing required is to link this item on to the
15817 -- list of rep items for the given entity. This is accomplished
15818 -- by the call to Rep_Item_Too_Late (when no error is detected
15819 -- and False is returned).
15821 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
15824 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
15827 ------------------------
15828 -- Linker_Constructor --
15829 ------------------------
15831 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
15833 -- Code is shared with Linker_Destructor
15835 -----------------------
15836 -- Linker_Destructor --
15837 -----------------------
15839 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
15841 when Pragma_Linker_Constructor |
15842 Pragma_Linker_Destructor
=>
15843 Linker_Constructor
: declare
15849 Check_Arg_Count
(1);
15850 Check_No_Identifiers
;
15851 Check_Arg_Is_Local_Name
(Arg1
);
15852 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
15854 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
15856 if not Is_Library_Level_Entity
(Proc
) then
15858 ("argument for pragma% must be library level entity", Arg1
);
15861 -- The only processing required is to link this item on to the
15862 -- list of rep items for the given entity. This is accomplished
15863 -- by the call to Rep_Item_Too_Late (when no error is detected
15864 -- and False is returned).
15866 if Rep_Item_Too_Late
(Proc
, N
) then
15869 Set_Has_Gigi_Rep_Item
(Proc
);
15871 end Linker_Constructor
;
15873 --------------------
15874 -- Linker_Options --
15875 --------------------
15877 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
15879 when Pragma_Linker_Options
=> Linker_Options
: declare
15883 Check_Ada_83_Warning
;
15884 Check_No_Identifiers
;
15885 Check_Arg_Count
(1);
15886 Check_Is_In_Decl_Part_Or_Package_Spec
;
15887 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15888 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
15891 while Present
(Arg
) loop
15892 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
15893 Store_String_Char
(ASCII
.NUL
);
15895 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
15899 if Operating_Mode
= Generate_Code
15900 and then In_Extended_Main_Source_Unit
(N
)
15902 Store_Linker_Option_String
(End_String
);
15904 end Linker_Options
;
15906 --------------------
15907 -- Linker_Section --
15908 --------------------
15910 -- pragma Linker_Section (
15911 -- [Entity =>] LOCAL_NAME
15912 -- [Section =>] static_string_EXPRESSION);
15914 when Pragma_Linker_Section
=> Linker_Section
: declare
15921 Check_Arg_Order
((Name_Entity
, Name_Section
));
15922 Check_Arg_Count
(2);
15923 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15924 Check_Optional_Identifier
(Arg2
, Name_Section
);
15925 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
15926 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
15928 -- Check kind of entity
15930 Arg
:= Get_Pragma_Arg
(Arg1
);
15931 Ent
:= Entity
(Arg
);
15933 case Ekind
(Ent
) is
15935 -- Objects (constants and variables) and types. For these cases
15936 -- all we need to do is to set the Linker_Section_pragma field,
15937 -- checking that we do not have a duplicate.
15939 when E_Constant | E_Variable | Type_Kind
=>
15940 LPE
:= Linker_Section_Pragma
(Ent
);
15942 if Present
(LPE
) then
15943 Error_Msg_Sloc
:= Sloc
(LPE
);
15945 ("Linker_Section already specified for &#", Arg1
, Ent
);
15948 Set_Linker_Section_Pragma
(Ent
, N
);
15952 when Subprogram_Kind
=>
15954 -- Aspect case, entity already set
15956 if From_Aspect_Specification
(N
) then
15957 Set_Linker_Section_Pragma
15958 (Entity
(Corresponding_Aspect
(N
)), N
);
15960 -- Pragma case, we must climb the homonym chain, but skip
15961 -- any for which the linker section is already set.
15965 if No
(Linker_Section_Pragma
(Ent
)) then
15966 Set_Linker_Section_Pragma
(Ent
, N
);
15969 Ent
:= Homonym
(Ent
);
15971 or else Scope
(Ent
) /= Current_Scope
;
15975 -- All other cases are illegal
15979 ("pragma% applies only to objects, subprograms, and types",
15982 end Linker_Section
;
15988 -- pragma List (On | Off)
15990 -- There is nothing to do here, since we did all the processing for
15991 -- this pragma in Par.Prag (so that it works properly even in syntax
15994 when Pragma_List
=>
16001 -- pragma Lock_Free [(Boolean_EXPRESSION)];
16003 when Pragma_Lock_Free
=> Lock_Free
: declare
16004 P
: constant Node_Id
:= Parent
(N
);
16010 Check_No_Identifiers
;
16011 Check_At_Most_N_Arguments
(1);
16013 -- Protected definition case
16015 if Nkind
(P
) = N_Protected_Definition
then
16016 Ent
:= Defining_Identifier
(Parent
(P
));
16020 if Arg_Count
= 1 then
16021 Arg
:= Get_Pragma_Arg
(Arg1
);
16022 Val
:= Is_True
(Static_Boolean
(Arg
));
16024 -- No arguments (expression is considered to be True)
16030 -- Check duplicate pragma before we chain the pragma in the Rep
16031 -- Item chain of Ent.
16033 Check_Duplicate_Pragma
(Ent
);
16034 Record_Rep_Item
(Ent
, N
);
16035 Set_Uses_Lock_Free
(Ent
, Val
);
16037 -- Anything else is incorrect placement
16044 --------------------
16045 -- Locking_Policy --
16046 --------------------
16048 -- pragma Locking_Policy (policy_IDENTIFIER);
16050 when Pragma_Locking_Policy
=> declare
16051 subtype LP_Range
is Name_Id
16052 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
16057 Check_Ada_83_Warning
;
16058 Check_Arg_Count
(1);
16059 Check_No_Identifiers
;
16060 Check_Arg_Is_Locking_Policy
(Arg1
);
16061 Check_Valid_Configuration_Pragma
;
16062 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
16065 when Name_Ceiling_Locking
=>
16067 when Name_Inheritance_Locking
=>
16069 when Name_Concurrent_Readers_Locking
=>
16073 if Locking_Policy
/= ' '
16074 and then Locking_Policy
/= LP
16076 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
16077 Error_Pragma
("locking policy incompatible with policy#");
16079 -- Set new policy, but always preserve System_Location since we
16080 -- like the error message with the run time name.
16083 Locking_Policy
:= LP
;
16085 if Locking_Policy_Sloc
/= System_Location
then
16086 Locking_Policy_Sloc
:= Loc
;
16091 -------------------
16092 -- Loop_Optimize --
16093 -------------------
16095 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
16097 -- OPTIMIZATION_HINT ::=
16098 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
16100 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
16105 Check_At_Least_N_Arguments
(1);
16106 Check_No_Identifiers
;
16108 Hint
:= First
(Pragma_Argument_Associations
(N
));
16109 while Present
(Hint
) loop
16110 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
16118 Check_Loop_Pragma_Placement
;
16125 -- pragma Loop_Variant
16126 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
16128 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
16130 -- CHANGE_DIRECTION ::= Increases | Decreases
16132 when Pragma_Loop_Variant
=> Loop_Variant
: declare
16137 Check_At_Least_N_Arguments
(1);
16138 Check_Loop_Pragma_Placement
;
16140 -- Process all increasing / decreasing expressions
16142 Variant
:= First
(Pragma_Argument_Associations
(N
));
16143 while Present
(Variant
) loop
16144 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
16147 Error_Pragma_Arg
("wrong change modifier", Variant
);
16150 Preanalyze_Assert_Expression
16151 (Expression
(Variant
), Any_Discrete
);
16157 -----------------------
16158 -- Machine_Attribute --
16159 -----------------------
16161 -- pragma Machine_Attribute (
16162 -- [Entity =>] LOCAL_NAME,
16163 -- [Attribute_Name =>] static_string_EXPRESSION
16164 -- [, [Info =>] static_EXPRESSION] );
16166 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
16167 Def_Id
: Entity_Id
;
16171 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
16173 if Arg_Count
= 3 then
16174 Check_Optional_Identifier
(Arg3
, Name_Info
);
16175 Check_Arg_Is_OK_Static_Expression
(Arg3
);
16177 Check_Arg_Count
(2);
16180 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16181 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
16182 Check_Arg_Is_Local_Name
(Arg1
);
16183 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16184 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16186 if Is_Access_Type
(Def_Id
) then
16187 Def_Id
:= Designated_Type
(Def_Id
);
16190 if Rep_Item_Too_Early
(Def_Id
, N
) then
16194 Def_Id
:= Underlying_Type
(Def_Id
);
16196 -- The only processing required is to link this item on to the
16197 -- list of rep items for the given entity. This is accomplished
16198 -- by the call to Rep_Item_Too_Late (when no error is detected
16199 -- and False is returned).
16201 if Rep_Item_Too_Late
(Def_Id
, N
) then
16204 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16206 end Machine_Attribute
;
16213 -- (MAIN_OPTION [, MAIN_OPTION]);
16216 -- [STACK_SIZE =>] static_integer_EXPRESSION
16217 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
16218 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
16220 when Pragma_Main
=> Main
: declare
16221 Args
: Args_List
(1 .. 3);
16222 Names
: constant Name_List
(1 .. 3) := (
16224 Name_Task_Stack_Size_Default
,
16225 Name_Time_Slicing_Enabled
);
16231 Gather_Associations
(Names
, Args
);
16233 for J
in 1 .. 2 loop
16234 if Present
(Args
(J
)) then
16235 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16239 if Present
(Args
(3)) then
16240 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
16244 while Present
(Nod
) loop
16245 if Nkind
(Nod
) = N_Pragma
16246 and then Pragma_Name
(Nod
) = Name_Main
16248 Error_Msg_Name_1
:= Pname
;
16249 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16260 -- pragma Main_Storage
16261 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
16263 -- MAIN_STORAGE_OPTION ::=
16264 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
16265 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
16267 when Pragma_Main_Storage
=> Main_Storage
: declare
16268 Args
: Args_List
(1 .. 2);
16269 Names
: constant Name_List
(1 .. 2) := (
16270 Name_Working_Storage
,
16277 Gather_Associations
(Names
, Args
);
16279 for J
in 1 .. 2 loop
16280 if Present
(Args
(J
)) then
16281 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
16285 Check_In_Main_Program
;
16288 while Present
(Nod
) loop
16289 if Nkind
(Nod
) = N_Pragma
16290 and then Pragma_Name
(Nod
) = Name_Main_Storage
16292 Error_Msg_Name_1
:= Pname
;
16293 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
16304 -- pragma Memory_Size (NUMERIC_LITERAL)
16306 when Pragma_Memory_Size
=>
16309 -- Memory size is simply ignored
16311 Check_No_Identifiers
;
16312 Check_Arg_Count
(1);
16313 Check_Arg_Is_Integer_Literal
(Arg1
);
16321 -- The only correct use of this pragma is on its own in a file, in
16322 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
16323 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
16324 -- check for a file containing nothing but a No_Body pragma). If we
16325 -- attempt to process it during normal semantics processing, it means
16326 -- it was misplaced.
16328 when Pragma_No_Body
=>
16332 -----------------------------
16333 -- No_Elaboration_Code_All --
16334 -----------------------------
16336 -- pragma No_Elaboration_Code_All;
16338 when Pragma_No_Elaboration_Code_All
=> NECA
: declare
16341 Check_Valid_Library_Unit_Pragma
;
16343 if Nkind
(N
) = N_Null_Statement
then
16347 -- Must appear for a spec or generic spec
16349 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
16350 N_Generic_Package_Declaration
,
16351 N_Generic_Subprogram_Declaration
,
16352 N_Package_Declaration
,
16353 N_Subprogram_Declaration
)
16357 ("pragma% can only occur for package "
16358 & "or subprogram spec"));
16361 -- Set flag in unit table
16363 Set_No_Elab_Code_All
(Current_Sem_Unit
);
16365 -- Set restriction No_Elaboration_Code if this is the main unit
16367 if Current_Sem_Unit
= Main_Unit
then
16368 Set_Restriction
(No_Elaboration_Code
, N
);
16371 -- If we are in the main unit or in an extended main source unit,
16372 -- then we also add it to the configuration restrictions so that
16373 -- it will apply to all units in the extended main source.
16375 if Current_Sem_Unit
= Main_Unit
16376 or else In_Extended_Main_Source_Unit
(N
)
16378 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
16381 -- If in main extended unit, activate transitive with test
16383 if In_Extended_Main_Source_Unit
(N
) then
16384 Opt
.No_Elab_Code_All_Pragma
:= N
;
16392 -- pragma No_Inline ( NAME {, NAME} );
16394 when Pragma_No_Inline
=>
16396 Process_Inline
(Suppressed
);
16402 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
16404 when Pragma_No_Return
=> No_Return
: declare
16412 Check_At_Least_N_Arguments
(1);
16414 -- Loop through arguments of pragma
16417 while Present
(Arg
) loop
16418 Check_Arg_Is_Local_Name
(Arg
);
16419 Id
:= Get_Pragma_Arg
(Arg
);
16422 if not Is_Entity_Name
(Id
) then
16423 Error_Pragma_Arg
("entity name required", Arg
);
16426 if Etype
(Id
) = Any_Type
then
16430 -- Loop to find matching procedures
16435 and then Scope
(E
) = Current_Scope
16437 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
16440 -- Set flag on any alias as well
16442 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
16443 Set_No_Return
(Alias
(E
));
16449 exit when From_Aspect_Specification
(N
);
16453 -- If entity in not in current scope it may be the enclosing
16454 -- suprogram body to which the aspect applies.
16457 if Entity
(Id
) = Current_Scope
16458 and then From_Aspect_Specification
(N
)
16460 Set_No_Return
(Entity
(Id
));
16462 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
16474 -- pragma No_Run_Time;
16476 -- Note: this pragma is retained for backwards compatibility. See
16477 -- body of Rtsfind for full details on its handling.
16479 when Pragma_No_Run_Time
=>
16481 Check_Valid_Configuration_Pragma
;
16482 Check_Arg_Count
(0);
16484 No_Run_Time_Mode
:= True;
16485 Configurable_Run_Time_Mode
:= True;
16487 -- Set Duration to 32 bits if word size is 32
16489 if Ttypes
.System_Word_Size
= 32 then
16490 Duration_32_Bits_On_Target
:= True;
16493 -- Set appropriate restrictions
16495 Set_Restriction
(No_Finalization
, N
);
16496 Set_Restriction
(No_Exception_Handlers
, N
);
16497 Set_Restriction
(Max_Tasks
, N
, 0);
16498 Set_Restriction
(No_Tasking
, N
);
16500 -----------------------
16501 -- No_Tagged_Streams --
16502 -----------------------
16504 -- pragma No_Tagged_Streams;
16505 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
16507 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
16513 Check_At_Most_N_Arguments
(1);
16515 -- One argument case
16517 if Arg_Count
= 1 then
16518 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16519 Check_Arg_Is_Local_Name
(Arg1
);
16520 E_Id
:= Get_Pragma_Arg
(Arg1
);
16522 if Etype
(E_Id
) = Any_Type
then
16526 E
:= Entity
(E_Id
);
16528 Check_Duplicate_Pragma
(E
);
16530 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
16532 ("argument for pragma% must be root tagged type", Arg1
);
16535 if Rep_Item_Too_Early
(E
, N
)
16537 Rep_Item_Too_Late
(E
, N
)
16541 Set_No_Tagged_Streams_Pragma
(E
, N
);
16544 -- Zero argument case
16547 Check_Is_In_Decl_Part_Or_Package_Spec
;
16548 No_Tagged_Streams
:= N
;
16550 end No_Tagged_Strms
;
16552 ------------------------
16553 -- No_Strict_Aliasing --
16554 ------------------------
16556 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
16558 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
16563 Check_At_Most_N_Arguments
(1);
16565 if Arg_Count
= 0 then
16566 Check_Valid_Configuration_Pragma
;
16567 Opt
.No_Strict_Aliasing
:= True;
16570 Check_Optional_Identifier
(Arg2
, Name_Entity
);
16571 Check_Arg_Is_Local_Name
(Arg1
);
16572 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16574 if E_Id
= Any_Type
then
16576 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
16577 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
16580 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
16582 end No_Strict_Aliasing
;
16584 -----------------------
16585 -- Normalize_Scalars --
16586 -----------------------
16588 -- pragma Normalize_Scalars;
16590 when Pragma_Normalize_Scalars
=>
16591 Check_Ada_83_Warning
;
16592 Check_Arg_Count
(0);
16593 Check_Valid_Configuration_Pragma
;
16595 -- Normalize_Scalars creates false positives in CodePeer, and
16596 -- incorrect negative results in GNATprove mode, so ignore this
16597 -- pragma in these modes.
16599 if not (CodePeer_Mode
or GNATprove_Mode
) then
16600 Normalize_Scalars
:= True;
16601 Init_Or_Norm_Scalars
:= True;
16608 -- pragma Obsolescent;
16610 -- pragma Obsolescent (
16611 -- [Message =>] static_string_EXPRESSION
16612 -- [,[Version =>] Ada_05]]);
16614 -- pragma Obsolescent (
16615 -- [Entity =>] NAME
16616 -- [,[Message =>] static_string_EXPRESSION
16617 -- [,[Version =>] Ada_05]] );
16619 when Pragma_Obsolescent
=> Obsolescent
: declare
16623 procedure Set_Obsolescent
(E
: Entity_Id
);
16624 -- Given an entity Ent, mark it as obsolescent if appropriate
16626 ---------------------
16627 -- Set_Obsolescent --
16628 ---------------------
16630 procedure Set_Obsolescent
(E
: Entity_Id
) is
16639 -- Entity name was given
16641 if Present
(Ename
) then
16643 -- If entity name matches, we are fine. Save entity in
16644 -- pragma argument, for ASIS use.
16646 if Chars
(Ename
) = Chars
(Ent
) then
16647 Set_Entity
(Ename
, Ent
);
16648 Generate_Reference
(Ent
, Ename
);
16650 -- If entity name does not match, only possibility is an
16651 -- enumeration literal from an enumeration type declaration.
16653 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
16655 ("pragma % entity name does not match declaration");
16658 Ent
:= First_Literal
(E
);
16662 ("pragma % entity name does not match any "
16663 & "enumeration literal");
16665 elsif Chars
(Ent
) = Chars
(Ename
) then
16666 Set_Entity
(Ename
, Ent
);
16667 Generate_Reference
(Ent
, Ename
);
16671 Ent
:= Next_Literal
(Ent
);
16677 -- Ent points to entity to be marked
16679 if Arg_Count
>= 1 then
16681 -- Deal with static string argument
16683 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16684 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
16686 for J
in 1 .. String_Length
(S
) loop
16687 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
16689 ("pragma% argument does not allow wide characters",
16694 Obsolescent_Warnings
.Append
16695 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
16697 -- Check for Ada_05 parameter
16699 if Arg_Count
/= 1 then
16700 Check_Arg_Count
(2);
16703 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
16706 Check_Arg_Is_Identifier
(Argx
);
16708 if Chars
(Argx
) /= Name_Ada_05
then
16709 Error_Msg_Name_2
:= Name_Ada_05
;
16711 ("only allowed argument for pragma% is %", Argx
);
16714 if Ada_Version_Explicit
< Ada_2005
16715 or else not Warn_On_Ada_2005_Compatibility
16723 -- Set flag if pragma active
16726 Set_Is_Obsolescent
(Ent
);
16730 end Set_Obsolescent
;
16732 -- Start of processing for pragma Obsolescent
16737 Check_At_Most_N_Arguments
(3);
16739 -- See if first argument specifies an entity name
16743 (Chars
(Arg1
) = Name_Entity
16745 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
16747 N_Operator_Symbol
))
16749 Ename
:= Get_Pragma_Arg
(Arg1
);
16751 -- Eliminate first argument, so we can share processing
16755 Arg_Count
:= Arg_Count
- 1;
16757 -- No Entity name argument given
16763 if Arg_Count
>= 1 then
16764 Check_Optional_Identifier
(Arg1
, Name_Message
);
16766 if Arg_Count
= 2 then
16767 Check_Optional_Identifier
(Arg2
, Name_Version
);
16771 -- Get immediately preceding declaration
16774 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
16778 -- Cases where we do not follow anything other than another pragma
16782 -- First case: library level compilation unit declaration with
16783 -- the pragma immediately following the declaration.
16785 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
16787 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
16790 -- Case 2: library unit placement for package
16794 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
16796 if Is_Package_Or_Generic_Package
(Ent
) then
16797 Set_Obsolescent
(Ent
);
16803 -- Cases where we must follow a declaration, including an
16804 -- abstract subprogram declaration, which is not in the
16805 -- other node subtypes.
16808 if Nkind
(Decl
) not in N_Declaration
16809 and then Nkind
(Decl
) not in N_Later_Decl_Item
16810 and then Nkind
(Decl
) not in N_Generic_Declaration
16811 and then Nkind
(Decl
) not in N_Renaming_Declaration
16812 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
16815 ("pragma% misplaced, "
16816 & "must immediately follow a declaration");
16819 Set_Obsolescent
(Defining_Entity
(Decl
));
16829 -- pragma Optimize (Time | Space | Off);
16831 -- The actual check for optimize is done in Gigi. Note that this
16832 -- pragma does not actually change the optimization setting, it
16833 -- simply checks that it is consistent with the pragma.
16835 when Pragma_Optimize
=>
16836 Check_No_Identifiers
;
16837 Check_Arg_Count
(1);
16838 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
16840 ------------------------
16841 -- Optimize_Alignment --
16842 ------------------------
16844 -- pragma Optimize_Alignment (Time | Space | Off);
16846 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
16848 Check_No_Identifiers
;
16849 Check_Arg_Count
(1);
16850 Check_Valid_Configuration_Pragma
;
16853 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
16857 Opt
.Optimize_Alignment
:= 'T';
16859 Opt
.Optimize_Alignment
:= 'S';
16861 Opt
.Optimize_Alignment
:= 'O';
16863 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
16867 -- Set indication that mode is set locally. If we are in fact in a
16868 -- configuration pragma file, this setting is harmless since the
16869 -- switch will get reset anyway at the start of each unit.
16871 Optimize_Alignment_Local
:= True;
16872 end Optimize_Alignment
;
16878 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
16880 when Pragma_Ordered
=> Ordered
: declare
16881 Assoc
: constant Node_Id
:= Arg1
;
16887 Check_No_Identifiers
;
16888 Check_Arg_Count
(1);
16889 Check_Arg_Is_Local_Name
(Arg1
);
16891 Type_Id
:= Get_Pragma_Arg
(Assoc
);
16892 Find_Type
(Type_Id
);
16893 Typ
:= Entity
(Type_Id
);
16895 if Typ
= Any_Type
then
16898 Typ
:= Underlying_Type
(Typ
);
16901 if not Is_Enumeration_Type
(Typ
) then
16902 Error_Pragma
("pragma% must specify enumeration type");
16905 Check_First_Subtype
(Arg1
);
16906 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
16909 -------------------
16910 -- Overflow_Mode --
16911 -------------------
16913 -- pragma Overflow_Mode
16914 -- ([General => ] MODE [, [Assertions => ] MODE]);
16916 -- MODE := STRICT | MINIMIZED | ELIMINATED
16918 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
16919 -- since System.Bignums makes this assumption. This is true of nearly
16920 -- all (all?) targets.
16922 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
16923 function Get_Overflow_Mode
16925 Arg
: Node_Id
) return Overflow_Mode_Type
;
16926 -- Function to process one pragma argument, Arg. If an identifier
16927 -- is present, it must be Name. Mode type is returned if a valid
16928 -- argument exists, otherwise an error is signalled.
16930 -----------------------
16931 -- Get_Overflow_Mode --
16932 -----------------------
16934 function Get_Overflow_Mode
16936 Arg
: Node_Id
) return Overflow_Mode_Type
16938 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
16941 Check_Optional_Identifier
(Arg
, Name
);
16942 Check_Arg_Is_Identifier
(Argx
);
16944 if Chars
(Argx
) = Name_Strict
then
16947 elsif Chars
(Argx
) = Name_Minimized
then
16950 elsif Chars
(Argx
) = Name_Eliminated
then
16951 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
16953 ("Eliminated not implemented on this target", Argx
);
16959 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
16961 end Get_Overflow_Mode
;
16963 -- Start of processing for Overflow_Mode
16967 Check_At_Least_N_Arguments
(1);
16968 Check_At_Most_N_Arguments
(2);
16970 -- Process first argument
16972 Scope_Suppress
.Overflow_Mode_General
:=
16973 Get_Overflow_Mode
(Name_General
, Arg1
);
16975 -- Case of only one argument
16977 if Arg_Count
= 1 then
16978 Scope_Suppress
.Overflow_Mode_Assertions
:=
16979 Scope_Suppress
.Overflow_Mode_General
;
16981 -- Case of two arguments present
16984 Scope_Suppress
.Overflow_Mode_Assertions
:=
16985 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
16989 --------------------------
16990 -- Overriding Renamings --
16991 --------------------------
16993 -- pragma Overriding_Renamings;
16995 when Pragma_Overriding_Renamings
=>
16997 Check_Arg_Count
(0);
16998 Check_Valid_Configuration_Pragma
;
16999 Overriding_Renamings
:= True;
17005 -- pragma Pack (first_subtype_LOCAL_NAME);
17007 when Pragma_Pack
=> Pack
: declare
17008 Assoc
: constant Node_Id
:= Arg1
;
17012 Ignore
: Boolean := False;
17015 Check_No_Identifiers
;
17016 Check_Arg_Count
(1);
17017 Check_Arg_Is_Local_Name
(Arg1
);
17018 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17020 if not Is_Entity_Name
(Type_Id
)
17021 or else not Is_Type
(Entity
(Type_Id
))
17024 ("argument for pragma% must be type or subtype", Arg1
);
17027 Find_Type
(Type_Id
);
17028 Typ
:= Entity
(Type_Id
);
17031 or else Rep_Item_Too_Early
(Typ
, N
)
17035 Typ
:= Underlying_Type
(Typ
);
17038 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
17039 Error_Pragma
("pragma% must specify array or record type");
17042 Check_First_Subtype
(Arg1
);
17043 Check_Duplicate_Pragma
(Typ
);
17047 if Is_Array_Type
(Typ
) then
17048 Ctyp
:= Component_Type
(Typ
);
17050 -- Ignore pack that does nothing
17052 if Known_Static_Esize
(Ctyp
)
17053 and then Known_Static_RM_Size
(Ctyp
)
17054 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
17055 and then Addressable
(Esize
(Ctyp
))
17060 -- Process OK pragma Pack. Note that if there is a separate
17061 -- component clause present, the Pack will be cancelled. This
17062 -- processing is in Freeze.
17064 if not Rep_Item_Too_Late
(Typ
, N
) then
17066 -- In CodePeer mode, we do not need complex front-end
17067 -- expansions related to pragma Pack, so disable handling
17070 if CodePeer_Mode
then
17073 -- Don't attempt any packing for VM targets. We possibly
17074 -- could deal with some cases of array bit-packing, but we
17075 -- don't bother, since this is not a typical kind of
17076 -- representation in the VM context anyway (and would not
17077 -- for example work nicely with the debugger).
17079 elsif VM_Target
/= No_VM
then
17080 if not GNAT_Mode
then
17082 ("??pragma% ignored in this configuration");
17085 -- Normal case where we do the pack action
17089 Set_Is_Packed
(Base_Type
(Typ
));
17090 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17093 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17097 -- For record types, the pack is always effective
17099 else pragma Assert
(Is_Record_Type
(Typ
));
17100 if not Rep_Item_Too_Late
(Typ
, N
) then
17102 -- Ignore pack request with warning in VM mode (skip warning
17103 -- if we are compiling GNAT run time library).
17105 if VM_Target
/= No_VM
then
17106 if not GNAT_Mode
then
17108 ("??pragma% ignored in this configuration");
17111 -- Normal case of pack request active
17114 Set_Is_Packed
(Base_Type
(Typ
));
17115 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
17116 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
17128 -- There is nothing to do here, since we did all the processing for
17129 -- this pragma in Par.Prag (so that it works properly even in syntax
17132 when Pragma_Page
=>
17139 -- pragma Part_Of (ABSTRACT_STATE);
17141 -- ABSTRACT_STATE ::= NAME
17143 when Pragma_Part_Of
=> Part_Of
: declare
17144 procedure Propagate_Part_Of
17145 (Pack_Id
: Entity_Id
;
17146 State_Id
: Entity_Id
;
17147 Instance
: Node_Id
);
17148 -- Propagate the Part_Of indicator to all abstract states and
17149 -- variables declared in the visible state space of a package
17150 -- denoted by Pack_Id. State_Id is the encapsulating state.
17151 -- Instance is the package instantiation node.
17153 -----------------------
17154 -- Propagate_Part_Of --
17155 -----------------------
17157 procedure Propagate_Part_Of
17158 (Pack_Id
: Entity_Id
;
17159 State_Id
: Entity_Id
;
17160 Instance
: Node_Id
)
17162 Has_Item
: Boolean := False;
17163 -- Flag set when the visible state space contains at least one
17164 -- abstract state or variable.
17166 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
17167 -- Propagate the Part_Of indicator to all abstract states and
17168 -- variables declared in the visible state space of a package
17169 -- denoted by Pack_Id.
17171 -----------------------
17172 -- Propagate_Part_Of --
17173 -----------------------
17175 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
17176 Item_Id
: Entity_Id
;
17179 -- Traverse the entity chain of the package and set relevant
17180 -- attributes of abstract states and variables declared in
17181 -- the visible state space of the package.
17183 Item_Id
:= First_Entity
(Pack_Id
);
17184 while Present
(Item_Id
)
17185 and then not In_Private_Part
(Item_Id
)
17187 -- Do not consider internally generated items
17189 if not Comes_From_Source
(Item_Id
) then
17192 -- The Part_Of indicator turns an abstract state or
17193 -- variable into a constituent of the encapsulating
17196 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
17201 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17202 Set_Encapsulating_State
(Item_Id
, State_Id
);
17204 -- Recursively handle nested packages and instantiations
17206 elsif Ekind
(Item_Id
) = E_Package
then
17207 Propagate_Part_Of
(Item_Id
);
17210 Next_Entity
(Item_Id
);
17212 end Propagate_Part_Of
;
17214 -- Start of processing for Propagate_Part_Of
17217 Propagate_Part_Of
(Pack_Id
);
17219 -- Detect a package instantiation that is subject to a Part_Of
17220 -- indicator, but has no visible state.
17222 if not Has_Item
then
17224 ("package instantiation & has Part_Of indicator but "
17225 & "lacks visible state", Instance
, Pack_Id
);
17227 end Propagate_Part_Of
;
17231 Item_Id
: Entity_Id
;
17234 State_Id
: Entity_Id
;
17237 -- Start of processing for Part_Of
17241 Check_No_Identifiers
;
17242 Check_Arg_Count
(1);
17244 -- Ensure the proper placement of the pragma. Part_Of must appear
17245 -- on a variable declaration or a package instantiation.
17248 while Present
(Stmt
) loop
17250 -- Skip prior pragmas, but check for duplicates
17252 if Nkind
(Stmt
) = N_Pragma
then
17253 if Pragma_Name
(Stmt
) = Pname
then
17254 Error_Msg_Name_1
:= Pname
;
17255 Error_Msg_Sloc
:= Sloc
(Stmt
);
17256 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
17259 -- Skip internally generated code
17261 elsif not Comes_From_Source
(Stmt
) then
17264 -- The pragma applies to an object declaration (possibly a
17265 -- variable) or a package instantiation. Stop the traversal
17266 -- and continue the analysis.
17268 elsif Nkind_In
(Stmt
, N_Object_Declaration
,
17269 N_Package_Instantiation
)
17273 -- The pragma does not apply to a legal construct, issue an
17274 -- error and stop the analysis.
17281 Stmt
:= Prev
(Stmt
);
17284 -- When the context is an object declaration, ensure that we are
17285 -- dealing with a variable.
17287 if Nkind
(Stmt
) = N_Object_Declaration
17288 and then Ekind
(Defining_Entity
(Stmt
)) /= E_Variable
17290 SPARK_Msg_N
("indicator Part_Of must apply to a variable", N
);
17294 -- Extract the entity of the related object declaration or package
17295 -- instantiation. In the case of the instantiation, use the entity
17296 -- of the instance spec.
17298 if Nkind
(Stmt
) = N_Package_Instantiation
then
17299 Stmt
:= Instance_Spec
(Stmt
);
17302 Item_Id
:= Defining_Entity
(Stmt
);
17303 State
:= Get_Pragma_Arg
(Arg1
);
17305 -- Detect any discrepancies between the placement of the object
17306 -- or package instantiation with respect to state space and the
17307 -- encapsulating state.
17310 (Item_Id
=> Item_Id
,
17316 State_Id
:= Entity
(State
);
17318 -- Add the pragma to the contract of the item. This aids with
17319 -- the detection of a missing but required Part_Of indicator.
17321 Add_Contract_Item
(N
, Item_Id
);
17323 -- The Part_Of indicator turns a variable into a constituent
17324 -- of the encapsulating state.
17326 if Ekind
(Item_Id
) = E_Variable
then
17327 Append_Elmt
(Item_Id
, Part_Of_Constituents
(State_Id
));
17328 Set_Encapsulating_State
(Item_Id
, State_Id
);
17330 -- Propagate the Part_Of indicator to the visible state space
17331 -- of the package instantiation.
17335 (Pack_Id
=> Item_Id
,
17336 State_Id
=> State_Id
,
17342 ----------------------------------
17343 -- Partition_Elaboration_Policy --
17344 ----------------------------------
17346 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
17348 when Pragma_Partition_Elaboration_Policy
=> declare
17349 subtype PEP_Range
is Name_Id
17350 range First_Partition_Elaboration_Policy_Name
17351 .. Last_Partition_Elaboration_Policy_Name
;
17352 PEP_Val
: PEP_Range
;
17357 Check_Arg_Count
(1);
17358 Check_No_Identifiers
;
17359 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
17360 Check_Valid_Configuration_Pragma
;
17361 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17364 when Name_Concurrent
=>
17366 when Name_Sequential
=>
17370 if Partition_Elaboration_Policy
/= ' '
17371 and then Partition_Elaboration_Policy
/= PEP
17373 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
17375 ("partition elaboration policy incompatible with policy#");
17377 -- Set new policy, but always preserve System_Location since we
17378 -- like the error message with the run time name.
17381 Partition_Elaboration_Policy
:= PEP
;
17383 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
17384 Partition_Elaboration_Policy_Sloc
:= Loc
;
17393 -- pragma Passive [(PASSIVE_FORM)];
17395 -- PASSIVE_FORM ::= Semaphore | No
17397 when Pragma_Passive
=>
17400 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
17401 Error_Pragma
("pragma% must be within task definition");
17404 if Arg_Count
/= 0 then
17405 Check_Arg_Count
(1);
17406 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
17409 ----------------------------------
17410 -- Preelaborable_Initialization --
17411 ----------------------------------
17413 -- pragma Preelaborable_Initialization (DIRECT_NAME);
17415 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
17420 Check_Arg_Count
(1);
17421 Check_No_Identifiers
;
17422 Check_Arg_Is_Identifier
(Arg1
);
17423 Check_Arg_Is_Local_Name
(Arg1
);
17424 Check_First_Subtype
(Arg1
);
17425 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17427 -- The pragma may come from an aspect on a private declaration,
17428 -- even if the freeze point at which this is analyzed in the
17429 -- private part after the full view.
17431 if Has_Private_Declaration
(Ent
)
17432 and then From_Aspect_Specification
(N
)
17436 -- Check appropriate type argument
17438 elsif Is_Private_Type
(Ent
)
17439 or else Is_Protected_Type
(Ent
)
17440 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
17442 -- AI05-0028: The pragma applies to all composite types. Note
17443 -- that we apply this binding interpretation to earlier versions
17444 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
17445 -- choice since there are other compilers that do the same.
17447 or else Is_Composite_Type
(Ent
)
17453 ("pragma % can only be applied to private, formal derived, "
17454 & "protected, or composite type", Arg1
);
17457 -- Give an error if the pragma is applied to a protected type that
17458 -- does not qualify (due to having entries, or due to components
17459 -- that do not qualify).
17461 if Is_Protected_Type
(Ent
)
17462 and then not Has_Preelaborable_Initialization
(Ent
)
17465 ("protected type & does not have preelaborable "
17466 & "initialization", Ent
);
17468 -- Otherwise mark the type as definitely having preelaborable
17472 Set_Known_To_Have_Preelab_Init
(Ent
);
17475 if Has_Pragma_Preelab_Init
(Ent
)
17476 and then Warn_On_Redundant_Constructs
17478 Error_Pragma
("?r?duplicate pragma%!");
17480 Set_Has_Pragma_Preelab_Init
(Ent
);
17484 --------------------
17485 -- Persistent_BSS --
17486 --------------------
17488 -- pragma Persistent_BSS [(object_NAME)];
17490 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
17497 Check_At_Most_N_Arguments
(1);
17499 -- Case of application to specific object (one argument)
17501 if Arg_Count
= 1 then
17502 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17504 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
17506 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
17509 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
17512 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17513 Decl
:= Parent
(Ent
);
17515 -- Check for duplication before inserting in list of
17516 -- representation items.
17518 Check_Duplicate_Pragma
(Ent
);
17520 if Rep_Item_Too_Late
(Ent
, N
) then
17524 if Present
(Expression
(Decl
)) then
17526 ("object for pragma% cannot have initialization", Arg1
);
17529 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
17531 ("object type for pragma% is not potentially persistent",
17536 Make_Linker_Section_Pragma
17537 (Ent
, Sloc
(N
), ".persistent.bss");
17538 Insert_After
(N
, Prag
);
17541 -- Case of use as configuration pragma with no arguments
17544 Check_Valid_Configuration_Pragma
;
17545 Persistent_BSS_Mode
:= True;
17547 end Persistent_BSS
;
17553 -- pragma Polling (ON | OFF);
17555 when Pragma_Polling
=>
17557 Check_Arg_Count
(1);
17558 Check_No_Identifiers
;
17559 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17560 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
17562 -----------------------------------
17563 -- Post/Post_Class/Postcondition --
17564 -----------------------------------
17566 -- pragma Post (Boolean_EXPRESSION);
17567 -- pragma Post_Class (Boolean_EXPRESSION);
17568 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
17569 -- [,[Message =>] String_EXPRESSION]);
17572 Pragma_Post_Class |
17573 Pragma_Postcondition
=>
17574 Analyze_Pre_Post_Condition
;
17576 --------------------------------
17577 -- Pre/Pre_Class/Precondition --
17578 --------------------------------
17580 -- pragma Pre (Boolean_EXPRESSION);
17581 -- pragma Pre_Class (Boolean_EXPRESSION);
17582 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
17583 -- [,[Message =>] String_EXPRESSION]);
17587 Pragma_Precondition
=>
17588 Analyze_Pre_Post_Condition
;
17594 -- pragma Predicate
17595 -- ([Entity =>] type_LOCAL_NAME,
17596 -- [Check =>] boolean_EXPRESSION);
17598 when Pragma_Predicate
=> Predicate
: declare
17605 Check_Arg_Count
(2);
17606 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17607 Check_Optional_Identifier
(Arg2
, Name_Check
);
17609 Check_Arg_Is_Local_Name
(Arg1
);
17611 Type_Id
:= Get_Pragma_Arg
(Arg1
);
17612 Find_Type
(Type_Id
);
17613 Typ
:= Entity
(Type_Id
);
17615 if Typ
= Any_Type
then
17619 -- The remaining processing is simply to link the pragma on to
17620 -- the rep item chain, for processing when the type is frozen.
17621 -- This is accomplished by a call to Rep_Item_Too_Late. We also
17622 -- mark the type as having predicates.
17624 Set_Has_Predicates
(Typ
);
17625 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
17632 -- pragma Preelaborate [(library_unit_NAME)];
17634 -- Set the flag Is_Preelaborated of program unit name entity
17636 when Pragma_Preelaborate
=> Preelaborate
: declare
17637 Pa
: constant Node_Id
:= Parent
(N
);
17638 Pk
: constant Node_Kind
:= Nkind
(Pa
);
17642 Check_Ada_83_Warning
;
17643 Check_Valid_Library_Unit_Pragma
;
17645 if Nkind
(N
) = N_Null_Statement
then
17649 Ent
:= Find_Lib_Unit_Name
;
17650 Check_Duplicate_Pragma
(Ent
);
17652 -- This filters out pragmas inside generic parents that show up
17653 -- inside instantiations. Pragmas that come from aspects in the
17654 -- unit are not ignored.
17656 if Present
(Ent
) then
17657 if Pk
= N_Package_Specification
17658 and then Present
(Generic_Parent
(Pa
))
17659 and then not From_Aspect_Specification
(N
)
17664 if not Debug_Flag_U
then
17665 Set_Is_Preelaborated
(Ent
);
17666 Set_Suppress_Elaboration_Warnings
(Ent
);
17672 -------------------------------
17673 -- Prefix_Exception_Messages --
17674 -------------------------------
17676 -- pragma Prefix_Exception_Messages;
17678 when Pragma_Prefix_Exception_Messages
=>
17680 Check_Valid_Configuration_Pragma
;
17681 Check_Arg_Count
(0);
17682 Prefix_Exception_Messages
:= True;
17688 -- pragma Priority (EXPRESSION);
17690 when Pragma_Priority
=> Priority
: declare
17691 P
: constant Node_Id
:= Parent
(N
);
17696 Check_No_Identifiers
;
17697 Check_Arg_Count
(1);
17701 if Nkind
(P
) = N_Subprogram_Body
then
17702 Check_In_Main_Program
;
17704 Ent
:= Defining_Unit_Name
(Specification
(P
));
17706 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
17707 Ent
:= Defining_Identifier
(Ent
);
17710 Arg
:= Get_Pragma_Arg
(Arg1
);
17711 Analyze_And_Resolve
(Arg
, Standard_Integer
);
17715 if not Is_OK_Static_Expression
(Arg
) then
17716 Flag_Non_Static_Expr
17717 ("main subprogram priority is not static!", Arg
);
17720 -- If constraint error, then we already signalled an error
17722 elsif Raises_Constraint_Error
(Arg
) then
17725 -- Otherwise check in range except if Relaxed_RM_Semantics
17726 -- where we ignore the value if out of range.
17730 Val
: constant Uint
:= Expr_Value
(Arg
);
17732 if not Relaxed_RM_Semantics
17735 or else Val
> Expr_Value
(Expression
17736 (Parent
(RTE
(RE_Max_Priority
)))))
17739 ("main subprogram priority is out of range", Arg1
);
17742 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
17747 -- Load an arbitrary entity from System.Tasking.Stages or
17748 -- System.Tasking.Restricted.Stages (depending on the
17749 -- supported profile) to make sure that one of these packages
17750 -- is implicitly with'ed, since we need to have the tasking
17751 -- run time active for the pragma Priority to have any effect.
17752 -- Previously we with'ed the package System.Tasking, but this
17753 -- package does not trigger the required initialization of the
17754 -- run-time library.
17757 Discard
: Entity_Id
;
17758 pragma Warnings
(Off
, Discard
);
17760 if Restricted_Profile
then
17761 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
17763 Discard
:= RTE
(RE_Activate_Tasks
);
17767 -- Task or Protected, must be of type Integer
17769 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
17770 Arg
:= Get_Pragma_Arg
(Arg1
);
17771 Ent
:= Defining_Identifier
(Parent
(P
));
17773 -- The expression must be analyzed in the special manner
17774 -- described in "Handling of Default and Per-Object
17775 -- Expressions" in sem.ads.
17777 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
17779 if not Is_OK_Static_Expression
(Arg
) then
17780 Check_Restriction
(Static_Priorities
, Arg
);
17783 -- Anything else is incorrect
17789 -- Check duplicate pragma before we chain the pragma in the Rep
17790 -- Item chain of Ent.
17792 Check_Duplicate_Pragma
(Ent
);
17793 Record_Rep_Item
(Ent
, N
);
17796 -----------------------------------
17797 -- Priority_Specific_Dispatching --
17798 -----------------------------------
17800 -- pragma Priority_Specific_Dispatching (
17801 -- policy_IDENTIFIER,
17802 -- first_priority_EXPRESSION,
17803 -- last_priority_EXPRESSION);
17805 when Pragma_Priority_Specific_Dispatching
=>
17806 Priority_Specific_Dispatching
: declare
17807 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
17808 -- This is the entity System.Any_Priority;
17811 Lower_Bound
: Node_Id
;
17812 Upper_Bound
: Node_Id
;
17818 Check_Arg_Count
(3);
17819 Check_No_Identifiers
;
17820 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
17821 Check_Valid_Configuration_Pragma
;
17822 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
17823 DP
:= Fold_Upper
(Name_Buffer
(1));
17825 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
17826 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
17827 Lower_Val
:= Expr_Value
(Lower_Bound
);
17829 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
17830 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
17831 Upper_Val
:= Expr_Value
(Upper_Bound
);
17833 -- It is not allowed to use Task_Dispatching_Policy and
17834 -- Priority_Specific_Dispatching in the same partition.
17836 if Task_Dispatching_Policy
/= ' ' then
17837 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
17839 ("pragma% incompatible with Task_Dispatching_Policy#");
17841 -- Check lower bound in range
17843 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
17845 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
17848 ("first_priority is out of range", Arg2
);
17850 -- Check upper bound in range
17852 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
17854 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
17857 ("last_priority is out of range", Arg3
);
17859 -- Check that the priority range is valid
17861 elsif Lower_Val
> Upper_Val
then
17863 ("last_priority_expression must be greater than or equal to "
17864 & "first_priority_expression");
17866 -- Store the new policy, but always preserve System_Location since
17867 -- we like the error message with the run-time name.
17870 -- Check overlapping in the priority ranges specified in other
17871 -- Priority_Specific_Dispatching pragmas within the same
17872 -- partition. We can only check those we know about.
17875 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
17877 if Specific_Dispatching
.Table
(J
).First_Priority
in
17878 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
17879 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
17880 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
17883 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
17885 ("priority range overlaps with "
17886 & "Priority_Specific_Dispatching#");
17890 -- The use of Priority_Specific_Dispatching is incompatible
17891 -- with Task_Dispatching_Policy.
17893 if Task_Dispatching_Policy
/= ' ' then
17894 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
17896 ("Priority_Specific_Dispatching incompatible "
17897 & "with Task_Dispatching_Policy#");
17900 -- The use of Priority_Specific_Dispatching forces ceiling
17903 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
17904 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
17906 ("Priority_Specific_Dispatching incompatible "
17907 & "with Locking_Policy#");
17909 -- Set the Ceiling_Locking policy, but preserve System_Location
17910 -- since we like the error message with the run time name.
17913 Locking_Policy
:= 'C';
17915 if Locking_Policy_Sloc
/= System_Location
then
17916 Locking_Policy_Sloc
:= Loc
;
17920 -- Add entry in the table
17922 Specific_Dispatching
.Append
17923 ((Dispatching_Policy
=> DP
,
17924 First_Priority
=> UI_To_Int
(Lower_Val
),
17925 Last_Priority
=> UI_To_Int
(Upper_Val
),
17926 Pragma_Loc
=> Loc
));
17928 end Priority_Specific_Dispatching
;
17934 -- pragma Profile (profile_IDENTIFIER);
17936 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
17938 when Pragma_Profile
=>
17940 Check_Arg_Count
(1);
17941 Check_Valid_Configuration_Pragma
;
17942 Check_No_Identifiers
;
17945 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
17948 if Chars
(Argx
) = Name_Ravenscar
then
17949 Set_Ravenscar_Profile
(N
);
17951 elsif Chars
(Argx
) = Name_Restricted
then
17952 Set_Profile_Restrictions
17954 N
, Warn
=> Treat_Restrictions_As_Warnings
);
17956 elsif Chars
(Argx
) = Name_Rational
then
17957 Set_Rational_Profile
;
17959 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
17960 Set_Profile_Restrictions
17961 (No_Implementation_Extensions
,
17962 N
, Warn
=> Treat_Restrictions_As_Warnings
);
17965 Error_Pragma_Arg
("& is not a valid profile", Argx
);
17969 ----------------------
17970 -- Profile_Warnings --
17971 ----------------------
17973 -- pragma Profile_Warnings (profile_IDENTIFIER);
17975 -- profile_IDENTIFIER => Restricted | Ravenscar
17977 when Pragma_Profile_Warnings
=>
17979 Check_Arg_Count
(1);
17980 Check_Valid_Configuration_Pragma
;
17981 Check_No_Identifiers
;
17984 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
17987 if Chars
(Argx
) = Name_Ravenscar
then
17988 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
17990 elsif Chars
(Argx
) = Name_Restricted
then
17991 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
17993 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
17994 Set_Profile_Restrictions
17995 (No_Implementation_Extensions
, N
, Warn
=> True);
17998 Error_Pragma_Arg
("& is not a valid profile", Argx
);
18002 --------------------------
18003 -- Propagate_Exceptions --
18004 --------------------------
18006 -- pragma Propagate_Exceptions;
18008 -- Note: this pragma is obsolete and has no effect
18010 when Pragma_Propagate_Exceptions
=>
18012 Check_Arg_Count
(0);
18014 if Warn_On_Obsolescent_Feature
then
18016 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
18017 "and has no effect?j?", N
);
18020 -----------------------------
18021 -- Provide_Shift_Operators --
18022 -----------------------------
18024 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
18026 when Pragma_Provide_Shift_Operators
=>
18027 Provide_Shift_Operators
: declare
18030 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
18031 -- Insert declaration and pragma Instrinsic for named shift op
18033 ----------------------------
18034 -- Declare_Shift_Operator --
18035 ----------------------------
18037 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
18043 Make_Subprogram_Declaration
(Loc
,
18044 Make_Function_Specification
(Loc
,
18045 Defining_Unit_Name
=>
18046 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
18048 Result_Definition
=>
18049 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
18051 Parameter_Specifications
=> New_List
(
18052 Make_Parameter_Specification
(Loc
,
18053 Defining_Identifier
=>
18054 Make_Defining_Identifier
(Loc
, Name_Value
),
18056 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
18058 Make_Parameter_Specification
(Loc
,
18059 Defining_Identifier
=>
18060 Make_Defining_Identifier
(Loc
, Name_Amount
),
18062 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
18066 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
18067 Pragma_Argument_Associations
=> New_List
(
18068 Make_Pragma_Argument_Association
(Loc
,
18069 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
18070 Make_Pragma_Argument_Association
(Loc
,
18071 Expression
=> Make_Identifier
(Loc
, Nam
))));
18073 Insert_After
(N
, Import
);
18074 Insert_After
(N
, Func
);
18075 end Declare_Shift_Operator
;
18077 -- Start of processing for Provide_Shift_Operators
18081 Check_Arg_Count
(1);
18082 Check_Arg_Is_Local_Name
(Arg1
);
18084 Arg1
:= Get_Pragma_Arg
(Arg1
);
18086 -- We must have an entity name
18088 if not Is_Entity_Name
(Arg1
) then
18090 ("pragma % must apply to integer first subtype", Arg1
);
18093 -- If no Entity, means there was a prior error so ignore
18095 if Present
(Entity
(Arg1
)) then
18096 Ent
:= Entity
(Arg1
);
18098 -- Apply error checks
18100 if not Is_First_Subtype
(Ent
) then
18102 ("cannot apply pragma %",
18103 "\& is not a first subtype",
18106 elsif not Is_Integer_Type
(Ent
) then
18108 ("cannot apply pragma %",
18109 "\& is not an integer type",
18112 elsif Has_Shift_Operator
(Ent
) then
18114 ("cannot apply pragma %",
18115 "\& already has declared shift operators",
18118 elsif Is_Frozen
(Ent
) then
18120 ("pragma % appears too late",
18121 "\& is already frozen",
18125 -- Now declare the operators. We do this during analysis rather
18126 -- than expansion, since we want the operators available if we
18127 -- are operating in -gnatc or ASIS mode.
18129 Declare_Shift_Operator
(Name_Rotate_Left
);
18130 Declare_Shift_Operator
(Name_Rotate_Right
);
18131 Declare_Shift_Operator
(Name_Shift_Left
);
18132 Declare_Shift_Operator
(Name_Shift_Right
);
18133 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
18135 end Provide_Shift_Operators
;
18141 -- pragma Psect_Object (
18142 -- [Internal =>] LOCAL_NAME,
18143 -- [, [External =>] EXTERNAL_SYMBOL]
18144 -- [, [Size =>] EXTERNAL_SYMBOL]);
18146 when Pragma_Psect_Object | Pragma_Common_Object
=>
18147 Psect_Object
: declare
18148 Args
: Args_List
(1 .. 3);
18149 Names
: constant Name_List
(1 .. 3) := (
18154 Internal
: Node_Id
renames Args
(1);
18155 External
: Node_Id
renames Args
(2);
18156 Size
: Node_Id
renames Args
(3);
18158 Def_Id
: Entity_Id
;
18160 procedure Check_Arg
(Arg
: Node_Id
);
18161 -- Checks that argument is either a string literal or an
18162 -- identifier, and posts error message if not.
18168 procedure Check_Arg
(Arg
: Node_Id
) is
18170 if not Nkind_In
(Original_Node
(Arg
),
18175 ("inappropriate argument for pragma %", Arg
);
18179 -- Start of processing for Common_Object/Psect_Object
18183 Gather_Associations
(Names
, Args
);
18184 Process_Extended_Import_Export_Internal_Arg
(Internal
);
18186 Def_Id
:= Entity
(Internal
);
18188 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
18190 ("pragma% must designate an object", Internal
);
18193 Check_Arg
(Internal
);
18195 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
18197 ("cannot use pragma% for imported/exported object",
18201 if Is_Concurrent_Type
(Etype
(Internal
)) then
18203 ("cannot specify pragma % for task/protected object",
18207 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
18209 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
18211 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
18214 if Ekind
(Def_Id
) = E_Constant
then
18216 ("cannot specify pragma % for a constant", Internal
);
18219 if Is_Record_Type
(Etype
(Internal
)) then
18225 Ent
:= First_Entity
(Etype
(Internal
));
18226 while Present
(Ent
) loop
18227 Decl
:= Declaration_Node
(Ent
);
18229 if Ekind
(Ent
) = E_Component
18230 and then Nkind
(Decl
) = N_Component_Declaration
18231 and then Present
(Expression
(Decl
))
18232 and then Warn_On_Export_Import
18235 ("?x?object for pragma % has defaults", Internal
);
18245 if Present
(Size
) then
18249 if Present
(External
) then
18250 Check_Arg_Is_External_Name
(External
);
18253 -- If all error tests pass, link pragma on to the rep item chain
18255 Record_Rep_Item
(Def_Id
, N
);
18262 -- pragma Pure [(library_unit_NAME)];
18264 when Pragma_Pure
=> Pure
: declare
18268 Check_Ada_83_Warning
;
18269 Check_Valid_Library_Unit_Pragma
;
18271 if Nkind
(N
) = N_Null_Statement
then
18275 Ent
:= Find_Lib_Unit_Name
;
18277 Set_Has_Pragma_Pure
(Ent
);
18278 Set_Suppress_Elaboration_Warnings
(Ent
);
18281 -------------------
18282 -- Pure_Function --
18283 -------------------
18285 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
18287 when Pragma_Pure_Function
=> Pure_Function
: declare
18290 Def_Id
: Entity_Id
;
18291 Effective
: Boolean := False;
18295 Check_Arg_Count
(1);
18296 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18297 Check_Arg_Is_Local_Name
(Arg1
);
18298 E_Id
:= Get_Pragma_Arg
(Arg1
);
18300 if Error_Posted
(E_Id
) then
18304 -- Loop through homonyms (overloadings) of referenced entity
18306 E
:= Entity
(E_Id
);
18308 if Present
(E
) then
18310 Def_Id
:= Get_Base_Subprogram
(E
);
18312 if not Ekind_In
(Def_Id
, E_Function
,
18313 E_Generic_Function
,
18317 ("pragma% requires a function name", Arg1
);
18320 Set_Is_Pure
(Def_Id
);
18322 if not Has_Pragma_Pure_Function
(Def_Id
) then
18323 Set_Has_Pragma_Pure_Function
(Def_Id
);
18327 exit when From_Aspect_Specification
(N
);
18329 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
18333 and then Warn_On_Redundant_Constructs
18336 ("pragma Pure_Function on& is redundant?r?",
18342 --------------------
18343 -- Queuing_Policy --
18344 --------------------
18346 -- pragma Queuing_Policy (policy_IDENTIFIER);
18348 when Pragma_Queuing_Policy
=> declare
18352 Check_Ada_83_Warning
;
18353 Check_Arg_Count
(1);
18354 Check_No_Identifiers
;
18355 Check_Arg_Is_Queuing_Policy
(Arg1
);
18356 Check_Valid_Configuration_Pragma
;
18357 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
18358 QP
:= Fold_Upper
(Name_Buffer
(1));
18360 if Queuing_Policy
/= ' '
18361 and then Queuing_Policy
/= QP
18363 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
18364 Error_Pragma
("queuing policy incompatible with policy#");
18366 -- Set new policy, but always preserve System_Location since we
18367 -- like the error message with the run time name.
18370 Queuing_Policy
:= QP
;
18372 if Queuing_Policy_Sloc
/= System_Location
then
18373 Queuing_Policy_Sloc
:= Loc
;
18382 -- pragma Rational, for compatibility with foreign compiler
18384 when Pragma_Rational
=>
18385 Set_Rational_Profile
;
18387 ------------------------------------
18388 -- Refined_Depends/Refined_Global --
18389 ------------------------------------
18391 -- pragma Refined_Depends (DEPENDENCY_RELATION);
18393 -- DEPENDENCY_RELATION ::=
18395 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
18397 -- DEPENDENCY_CLAUSE ::=
18398 -- OUTPUT_LIST =>[+] INPUT_LIST
18399 -- | NULL_DEPENDENCY_CLAUSE
18401 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
18403 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
18405 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
18407 -- OUTPUT ::= NAME | FUNCTION_RESULT
18410 -- where FUNCTION_RESULT is a function Result attribute_reference
18412 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
18414 -- GLOBAL_SPECIFICATION ::=
18417 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
18419 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
18421 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
18422 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
18423 -- GLOBAL_ITEM ::= NAME
18425 when Pragma_Refined_Depends |
18426 Pragma_Refined_Global
=> Refined_Depends_Global
:
18428 Body_Id
: Entity_Id
;
18430 Spec_Id
: Entity_Id
;
18433 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18435 -- Save the pragma in the contract of the subprogram body. The
18436 -- remaining analysis is performed at the end of the enclosing
18440 Add_Contract_Item
(N
, Body_Id
);
18442 end Refined_Depends_Global
;
18448 -- pragma Refined_Post (boolean_EXPRESSION);
18450 when Pragma_Refined_Post
=> Refined_Post
: declare
18451 Body_Id
: Entity_Id
;
18453 Spec_Id
: Entity_Id
;
18456 Analyze_Refined_Pragma
(Spec_Id
, Body_Id
, Legal
);
18458 -- Fully analyze the pragma when it appears inside a subprogram
18459 -- body because it cannot benefit from forward references.
18462 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
18464 -- Chain the pragma on the contract for easy retrieval
18466 Add_Contract_Item
(N
, Body_Id
);
18470 -------------------
18471 -- Refined_State --
18472 -------------------
18474 -- pragma Refined_State (REFINEMENT_LIST);
18476 -- REFINEMENT_LIST ::=
18477 -- REFINEMENT_CLAUSE
18478 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
18480 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
18482 -- CONSTITUENT_LIST ::=
18485 -- | (CONSTITUENT {, CONSTITUENT})
18487 -- CONSTITUENT ::= object_NAME | state_NAME
18489 when Pragma_Refined_State
=> Refined_State
: declare
18490 Pack_Decl
: Node_Id
;
18491 Spec_Id
: Entity_Id
;
18495 Check_No_Identifiers
;
18496 Check_Arg_Count
(1);
18498 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18500 -- Ensure the proper placement of the pragma. Refined states must
18501 -- be associated with a package body.
18503 if Nkind
(Pack_Decl
) = N_Package_Body
then
18506 -- Otherwise the pragma is associated with an illegal construct
18513 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
18515 -- State refinement is allowed only when the corresponding package
18516 -- declaration has non-null pragma Abstract_State. Refinement not
18517 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
18519 if SPARK_Mode
/= Off
18521 (No
(Abstract_States
(Spec_Id
))
18522 or else Has_Null_Abstract_State
(Spec_Id
))
18525 ("useless refinement, package & does not define abstract "
18526 & "states", N
, Spec_Id
);
18530 -- The pragma must be analyzed at the end of the declarations as
18531 -- it has visibility over the whole declarative region. Save the
18532 -- pragma for later (see Analyze_Refined_State_In_Decl_Part) by
18533 -- adding it to the contract of the package body.
18535 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
18538 -----------------------
18539 -- Relative_Deadline --
18540 -----------------------
18542 -- pragma Relative_Deadline (time_span_EXPRESSION);
18544 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
18545 P
: constant Node_Id
:= Parent
(N
);
18550 Check_No_Identifiers
;
18551 Check_Arg_Count
(1);
18553 Arg
:= Get_Pragma_Arg
(Arg1
);
18555 -- The expression must be analyzed in the special manner described
18556 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
18558 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
18562 if Nkind
(P
) = N_Subprogram_Body
then
18563 Check_In_Main_Program
;
18565 -- Only Task and subprogram cases allowed
18567 elsif Nkind
(P
) /= N_Task_Definition
then
18571 -- Check duplicate pragma before we set the corresponding flag
18573 if Has_Relative_Deadline_Pragma
(P
) then
18574 Error_Pragma
("duplicate pragma% not allowed");
18577 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
18578 -- Relative_Deadline pragma node cannot be inserted in the Rep
18579 -- Item chain of Ent since it is rewritten by the expander as a
18580 -- procedure call statement that will break the chain.
18582 Set_Has_Relative_Deadline_Pragma
(P
, True);
18583 end Relative_Deadline
;
18585 ------------------------
18586 -- Remote_Access_Type --
18587 ------------------------
18589 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
18591 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
18596 Check_Arg_Count
(1);
18597 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18598 Check_Arg_Is_Local_Name
(Arg1
);
18600 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
18602 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
18603 and then Ekind
(E
) = E_General_Access_Type
18604 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
18605 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
18607 and then Is_Valid_Remote_Object_Type
18608 (Root_Type
(Directly_Designated_Type
(E
)))
18610 Set_Is_Remote_Types
(E
);
18614 ("pragma% applies only to formal access to classwide types",
18617 end Remote_Access_Type
;
18619 ---------------------------
18620 -- Remote_Call_Interface --
18621 ---------------------------
18623 -- pragma Remote_Call_Interface [(library_unit_NAME)];
18625 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
18626 Cunit_Node
: Node_Id
;
18627 Cunit_Ent
: Entity_Id
;
18631 Check_Ada_83_Warning
;
18632 Check_Valid_Library_Unit_Pragma
;
18634 if Nkind
(N
) = N_Null_Statement
then
18638 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
18639 K
:= Nkind
(Unit
(Cunit_Node
));
18640 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
18642 if K
= N_Package_Declaration
18643 or else K
= N_Generic_Package_Declaration
18644 or else K
= N_Subprogram_Declaration
18645 or else K
= N_Generic_Subprogram_Declaration
18646 or else (K
= N_Subprogram_Body
18647 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
18652 "pragma% must apply to package or subprogram declaration");
18655 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
18656 end Remote_Call_Interface
;
18662 -- pragma Remote_Types [(library_unit_NAME)];
18664 when Pragma_Remote_Types
=> Remote_Types
: declare
18665 Cunit_Node
: Node_Id
;
18666 Cunit_Ent
: Entity_Id
;
18669 Check_Ada_83_Warning
;
18670 Check_Valid_Library_Unit_Pragma
;
18672 if Nkind
(N
) = N_Null_Statement
then
18676 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
18677 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
18679 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
18680 N_Generic_Package_Declaration
)
18683 ("pragma% can only apply to a package declaration");
18686 Set_Is_Remote_Types
(Cunit_Ent
);
18693 -- pragma Ravenscar;
18695 when Pragma_Ravenscar
=>
18697 Check_Arg_Count
(0);
18698 Check_Valid_Configuration_Pragma
;
18699 Set_Ravenscar_Profile
(N
);
18701 if Warn_On_Obsolescent_Feature
then
18703 ("pragma Ravenscar is an obsolescent feature?j?", N
);
18705 ("|use pragma Profile (Ravenscar) instead?j?", N
);
18708 -------------------------
18709 -- Restricted_Run_Time --
18710 -------------------------
18712 -- pragma Restricted_Run_Time;
18714 when Pragma_Restricted_Run_Time
=>
18716 Check_Arg_Count
(0);
18717 Check_Valid_Configuration_Pragma
;
18718 Set_Profile_Restrictions
18719 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
18721 if Warn_On_Obsolescent_Feature
then
18723 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
18726 ("|use pragma Profile (Restricted) instead?j?", N
);
18733 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
18736 -- restriction_IDENTIFIER
18737 -- | restriction_parameter_IDENTIFIER => EXPRESSION
18739 when Pragma_Restrictions
=>
18740 Process_Restrictions_Or_Restriction_Warnings
18741 (Warn
=> Treat_Restrictions_As_Warnings
);
18743 --------------------------
18744 -- Restriction_Warnings --
18745 --------------------------
18747 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
18750 -- restriction_IDENTIFIER
18751 -- | restriction_parameter_IDENTIFIER => EXPRESSION
18753 when Pragma_Restriction_Warnings
=>
18755 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
18761 -- pragma Reviewable;
18763 when Pragma_Reviewable
=>
18764 Check_Ada_83_Warning
;
18765 Check_Arg_Count
(0);
18767 -- Call dummy debugging function rv. This is done to assist front
18768 -- end debugging. By placing a Reviewable pragma in the source
18769 -- program, a breakpoint on rv catches this place in the source,
18770 -- allowing convenient stepping to the point of interest.
18774 --------------------------
18775 -- Short_Circuit_And_Or --
18776 --------------------------
18778 -- pragma Short_Circuit_And_Or;
18780 when Pragma_Short_Circuit_And_Or
=>
18782 Check_Arg_Count
(0);
18783 Check_Valid_Configuration_Pragma
;
18784 Short_Circuit_And_Or
:= True;
18786 -------------------
18787 -- Share_Generic --
18788 -------------------
18790 -- pragma Share_Generic (GNAME {, GNAME});
18792 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
18794 when Pragma_Share_Generic
=>
18796 Process_Generic_List
;
18802 -- pragma Shared (LOCAL_NAME);
18804 when Pragma_Shared
=>
18806 Process_Atomic_Independent_Shared_Volatile
;
18808 --------------------
18809 -- Shared_Passive --
18810 --------------------
18812 -- pragma Shared_Passive [(library_unit_NAME)];
18814 -- Set the flag Is_Shared_Passive of program unit name entity
18816 when Pragma_Shared_Passive
=> Shared_Passive
: declare
18817 Cunit_Node
: Node_Id
;
18818 Cunit_Ent
: Entity_Id
;
18821 Check_Ada_83_Warning
;
18822 Check_Valid_Library_Unit_Pragma
;
18824 if Nkind
(N
) = N_Null_Statement
then
18828 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
18829 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
18831 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
18832 N_Generic_Package_Declaration
)
18835 ("pragma% can only apply to a package declaration");
18838 Set_Is_Shared_Passive
(Cunit_Ent
);
18839 end Shared_Passive
;
18841 -----------------------
18842 -- Short_Descriptors --
18843 -----------------------
18845 -- pragma Short_Descriptors;
18847 -- Recognize and validate, but otherwise ignore
18849 when Pragma_Short_Descriptors
=>
18851 Check_Arg_Count
(0);
18852 Check_Valid_Configuration_Pragma
;
18854 ------------------------------
18855 -- Simple_Storage_Pool_Type --
18856 ------------------------------
18858 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
18860 when Pragma_Simple_Storage_Pool_Type
=>
18861 Simple_Storage_Pool_Type
: declare
18867 Check_Arg_Count
(1);
18868 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18870 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18871 Find_Type
(Type_Id
);
18872 Typ
:= Entity
(Type_Id
);
18874 if Typ
= Any_Type
then
18878 -- We require the pragma to apply to a type declared in a package
18879 -- declaration, but not (immediately) within a package body.
18881 if Ekind
(Current_Scope
) /= E_Package
18882 or else In_Package_Body
(Current_Scope
)
18885 ("pragma% can only apply to type declared immediately "
18886 & "within a package declaration");
18889 -- A simple storage pool type must be an immutably limited record
18890 -- or private type. If the pragma is given for a private type,
18891 -- the full type is similarly restricted (which is checked later
18892 -- in Freeze_Entity).
18894 if Is_Record_Type
(Typ
)
18895 and then not Is_Limited_View
(Typ
)
18898 ("pragma% can only apply to explicitly limited record type");
18900 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
18902 ("pragma% can only apply to a private type that is limited");
18904 elsif not Is_Record_Type
(Typ
)
18905 and then not Is_Private_Type
(Typ
)
18908 ("pragma% can only apply to limited record or private type");
18911 Record_Rep_Item
(Typ
, N
);
18912 end Simple_Storage_Pool_Type
;
18914 ----------------------
18915 -- Source_File_Name --
18916 ----------------------
18918 -- There are five forms for this pragma:
18920 -- pragma Source_File_Name (
18921 -- [UNIT_NAME =>] unit_NAME,
18922 -- BODY_FILE_NAME => STRING_LITERAL
18923 -- [, [INDEX =>] INTEGER_LITERAL]);
18925 -- pragma Source_File_Name (
18926 -- [UNIT_NAME =>] unit_NAME,
18927 -- SPEC_FILE_NAME => STRING_LITERAL
18928 -- [, [INDEX =>] INTEGER_LITERAL]);
18930 -- pragma Source_File_Name (
18931 -- BODY_FILE_NAME => STRING_LITERAL
18932 -- [, DOT_REPLACEMENT => STRING_LITERAL]
18933 -- [, CASING => CASING_SPEC]);
18935 -- pragma Source_File_Name (
18936 -- SPEC_FILE_NAME => STRING_LITERAL
18937 -- [, DOT_REPLACEMENT => STRING_LITERAL]
18938 -- [, CASING => CASING_SPEC]);
18940 -- pragma Source_File_Name (
18941 -- SUBUNIT_FILE_NAME => STRING_LITERAL
18942 -- [, DOT_REPLACEMENT => STRING_LITERAL]
18943 -- [, CASING => CASING_SPEC]);
18945 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
18947 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
18948 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
18949 -- only be used when no project file is used, while SFNP can only be
18950 -- used when a project file is used.
18952 -- No processing here. Processing was completed during parsing, since
18953 -- we need to have file names set as early as possible. Units are
18954 -- loaded well before semantic processing starts.
18956 -- The only processing we defer to this point is the check for
18957 -- correct placement.
18959 when Pragma_Source_File_Name
=>
18961 Check_Valid_Configuration_Pragma
;
18963 ------------------------------
18964 -- Source_File_Name_Project --
18965 ------------------------------
18967 -- See Source_File_Name for syntax
18969 -- No processing here. Processing was completed during parsing, since
18970 -- we need to have file names set as early as possible. Units are
18971 -- loaded well before semantic processing starts.
18973 -- The only processing we defer to this point is the check for
18974 -- correct placement.
18976 when Pragma_Source_File_Name_Project
=>
18978 Check_Valid_Configuration_Pragma
;
18980 -- Check that a pragma Source_File_Name_Project is used only in a
18981 -- configuration pragmas file.
18983 -- Pragmas Source_File_Name_Project should only be generated by
18984 -- the Project Manager in configuration pragmas files.
18986 -- This is really an ugly test. It seems to depend on some
18987 -- accidental and undocumented property. At the very least it
18988 -- needs to be documented, but it would be better to have a
18989 -- clean way of testing if we are in a configuration file???
18991 if Present
(Parent
(N
)) then
18993 ("pragma% can only appear in a configuration pragmas file");
18996 ----------------------
18997 -- Source_Reference --
18998 ----------------------
19000 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
19002 -- Nothing to do, all processing completed in Par.Prag, since we need
19003 -- the information for possible parser messages that are output.
19005 when Pragma_Source_Reference
=>
19012 -- pragma SPARK_Mode [(On | Off)];
19014 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
19015 Mode_Id
: SPARK_Mode_Type
;
19017 procedure Check_Pragma_Conformance
19018 (Context_Pragma
: Node_Id
;
19019 Entity_Pragma
: Node_Id
;
19020 Entity
: Entity_Id
);
19021 -- If Context_Pragma is not Empty, verify that the new pragma N
19022 -- is compatible with the pragma Context_Pragma that was inherited
19023 -- from the context:
19024 -- . if Context_Pragma is ON, then the new mode can be anything
19025 -- . if Context_Pragma is OFF, then the only allowed new mode is
19028 -- If Entity is not Empty, verify that the new pragma N is
19029 -- compatible with Entity_Pragma, the SPARK_Mode previously set
19030 -- for Entity (which may be Empty):
19031 -- . if Entity_Pragma is ON, then the new mode can be anything
19032 -- . if Entity_Pragma is OFF, then the only allowed new mode is
19034 -- . if Entity_Pragma is Empty, we always issue an error, as this
19035 -- corresponds to a case where a previous section of Entity
19036 -- had no SPARK_Mode set.
19038 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
19039 -- Verify that pragma is applied to library-level entity E
19041 procedure Set_SPARK_Flags
;
19042 -- Sets SPARK_Mode from Mode_Id and SPARK_Mode_Pragma from N,
19043 -- and ensures that Dynamic_Elaboration_Checks are off if the
19044 -- call sets SPARK_Mode On.
19046 ------------------------------
19047 -- Check_Pragma_Conformance --
19048 ------------------------------
19050 procedure Check_Pragma_Conformance
19051 (Context_Pragma
: Node_Id
;
19052 Entity_Pragma
: Node_Id
;
19053 Entity
: Entity_Id
)
19055 Arg
: Node_Id
:= Arg1
;
19058 -- The current pragma may appear without an argument. If this
19059 -- is the case, associate all error messages with the pragma
19066 -- The mode of the current pragma is compared against that of
19067 -- an enclosing context.
19069 if Present
(Context_Pragma
) then
19070 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
19072 -- Issue an error if the new mode is less restrictive than
19073 -- that of the context.
19075 if Get_SPARK_Mode_From_Pragma
(Context_Pragma
) = Off
19076 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19079 ("cannot change SPARK_Mode from Off to On", Arg
);
19080 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19081 Error_Msg_N
("\SPARK_Mode was set to Off#", Arg
);
19086 -- The mode of the current pragma is compared against that of
19087 -- an initial package/subprogram declaration.
19089 if Present
(Entity
) then
19091 -- Both the initial declaration and the completion carry
19092 -- SPARK_Mode pragmas.
19094 if Present
(Entity_Pragma
) then
19095 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
19097 -- Issue an error if the new mode is less restrictive
19098 -- than that of the initial declaration.
19100 if Get_SPARK_Mode_From_Pragma
(Entity_Pragma
) = Off
19101 and then Get_SPARK_Mode_From_Pragma
(N
) = On
19103 Error_Msg_N
("incorrect use of SPARK_Mode", Arg
);
19104 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
19106 ("\value Off was set for SPARK_Mode on&#",
19111 -- Otherwise the initial declaration lacks a SPARK_Mode
19112 -- pragma in which case the current pragma is illegal as
19113 -- it cannot "complete".
19116 Error_Msg_N
("incorrect use of SPARK_Mode", Arg
);
19117 Error_Msg_Sloc
:= Sloc
(Entity
);
19119 ("\no value was set for SPARK_Mode on&#",
19124 end Check_Pragma_Conformance
;
19126 --------------------------------
19127 -- Check_Library_Level_Entity --
19128 --------------------------------
19130 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
19131 MsgF
: constant String := "incorrect placement of pragma%";
19134 if not Is_Library_Level_Entity
(E
) then
19135 Error_Msg_Name_1
:= Pname
;
19136 Error_Msg_N
(Fix_Error
(MsgF
), N
);
19138 if Ekind_In
(E
, E_Generic_Package
,
19143 ("\& is not a library-level package", N
, E
);
19146 ("\& is not a library-level subprogram", N
, E
);
19151 end Check_Library_Level_Entity
;
19153 ---------------------
19154 -- Set_SPARK_Flags --
19155 ---------------------
19157 procedure Set_SPARK_Flags
is
19159 SPARK_Mode
:= Mode_Id
;
19160 SPARK_Mode_Pragma
:= N
;
19162 if SPARK_Mode
= On
then
19163 Dynamic_Elaboration_Checks
:= False;
19165 end Set_SPARK_Flags
;
19169 Body_Id
: Entity_Id
;
19172 Spec_Id
: Entity_Id
;
19175 -- Start of processing for Do_SPARK_Mode
19178 -- When a SPARK_Mode pragma appears inside an instantiation whose
19179 -- enclosing context has SPARK_Mode set to "off", the pragma has
19180 -- no semantic effect.
19182 if Ignore_Pragma_SPARK_Mode
then
19183 Rewrite
(N
, Make_Null_Statement
(Loc
));
19189 Check_No_Identifiers
;
19190 Check_At_Most_N_Arguments
(1);
19192 -- Check the legality of the mode (no argument = ON)
19194 if Arg_Count
= 1 then
19195 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19196 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
19201 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
19202 Context
:= Parent
(N
);
19204 -- The pragma appears in a configuration pragmas file
19206 if No
(Context
) then
19207 Check_Valid_Configuration_Pragma
;
19209 if Present
(SPARK_Mode_Pragma
) then
19210 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
19211 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19217 -- The pragma acts as a configuration pragma in a compilation unit
19219 -- pragma SPARK_Mode ...;
19220 -- package Pack is ...;
19222 elsif Nkind
(Context
) = N_Compilation_Unit
19223 and then List_Containing
(N
) = Context_Items
(Context
)
19225 Check_Valid_Configuration_Pragma
;
19228 -- Otherwise the placement of the pragma within the tree dictates
19229 -- its associated construct. Inspect the declarative list where
19230 -- the pragma resides to find a potential construct.
19234 while Present
(Stmt
) loop
19236 -- Skip prior pragmas, but check for duplicates
19238 if Nkind
(Stmt
) = N_Pragma
then
19239 if Pragma_Name
(Stmt
) = Pname
then
19240 Error_Msg_Name_1
:= Pname
;
19241 Error_Msg_Sloc
:= Sloc
(Stmt
);
19242 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
19246 -- The pragma applies to a [generic] subprogram declaration.
19247 -- Note that this case covers an internally generated spec
19248 -- for a stand alone body.
19251 -- procedure Proc ...;
19252 -- pragma SPARK_Mode ..;
19254 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
19255 N_Subprogram_Declaration
)
19257 Spec_Id
:= Defining_Entity
(Stmt
);
19258 Check_Library_Level_Entity
(Spec_Id
);
19259 Check_Pragma_Conformance
19260 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19261 Entity_Pragma
=> Empty
,
19264 Set_SPARK_Pragma
(Spec_Id
, N
);
19265 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19268 -- Skip internally generated code
19270 elsif not Comes_From_Source
(Stmt
) then
19273 -- Otherwise the pragma does not apply to a legal construct
19274 -- or it does not appear at the top of a declarative or a
19275 -- statement list. Issue an error and stop the analysis.
19285 -- The pragma applies to a package or a subprogram that acts as
19286 -- a compilation unit.
19288 -- procedure Proc ...;
19289 -- pragma SPARK_Mode ...;
19291 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
19292 Context
:= Unit
(Parent
(Context
));
19295 -- The pragma appears within package declarations
19297 if Nkind
(Context
) = N_Package_Specification
then
19298 Spec_Id
:= Defining_Entity
(Context
);
19299 Check_Library_Level_Entity
(Spec_Id
);
19301 -- The pragma is at the top of the visible declarations
19304 -- pragma SPARK_Mode ...;
19306 if List_Containing
(N
) = Visible_Declarations
(Context
) then
19307 Check_Pragma_Conformance
19308 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19309 Entity_Pragma
=> Empty
,
19313 Set_SPARK_Pragma
(Spec_Id
, N
);
19314 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19315 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19316 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
19318 -- The pragma is at the top of the private declarations
19322 -- pragma SPARK_Mode ...;
19325 Check_Pragma_Conformance
19326 (Context_Pragma
=> Empty
,
19327 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19328 Entity
=> Spec_Id
);
19331 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
19332 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
19335 -- The pragma appears at the top of package body declarations
19337 -- package body Pack is
19338 -- pragma SPARK_Mode ...;
19340 elsif Nkind
(Context
) = N_Package_Body
then
19341 Spec_Id
:= Corresponding_Spec
(Context
);
19342 Body_Id
:= Defining_Entity
(Context
);
19343 Check_Library_Level_Entity
(Body_Id
);
19344 Check_Pragma_Conformance
19345 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19346 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
),
19347 Entity
=> Spec_Id
);
19350 Set_SPARK_Pragma
(Body_Id
, N
);
19351 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19352 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19353 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
19355 -- The pragma appears at the top of package body statements
19357 -- package body Pack is
19359 -- pragma SPARK_Mode;
19361 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
19362 and then Nkind
(Parent
(Context
)) = N_Package_Body
19364 Context
:= Parent
(Context
);
19365 Spec_Id
:= Corresponding_Spec
(Context
);
19366 Body_Id
:= Defining_Entity
(Context
);
19367 Check_Library_Level_Entity
(Body_Id
);
19368 Check_Pragma_Conformance
19369 (Context_Pragma
=> Empty
,
19370 Entity_Pragma
=> SPARK_Pragma
(Body_Id
),
19371 Entity
=> Body_Id
);
19374 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
19375 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
19377 -- The pragma appeared as an aspect of a [generic] subprogram
19378 -- declaration that acts as a compilation unit.
19381 -- procedure Proc ...;
19382 -- pragma SPARK_Mode ...;
19384 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
19385 N_Subprogram_Declaration
)
19387 Spec_Id
:= Defining_Entity
(Context
);
19388 Check_Library_Level_Entity
(Spec_Id
);
19389 Check_Pragma_Conformance
19390 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
19391 Entity_Pragma
=> Empty
,
19394 Set_SPARK_Pragma
(Spec_Id
, N
);
19395 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
19397 -- The pragma appears at the top of subprogram body
19400 -- procedure Proc ... is
19401 -- pragma SPARK_Mode;
19403 elsif Nkind
(Context
) = N_Subprogram_Body
then
19404 Spec_Id
:= Corresponding_Spec
(Context
);
19405 Context
:= Specification
(Context
);
19406 Body_Id
:= Defining_Entity
(Context
);
19408 -- Ignore pragma when applied to the special body created
19409 -- for inlining, recognized by its internal name _Parent.
19411 if Chars
(Body_Id
) = Name_uParent
then
19415 Check_Library_Level_Entity
(Body_Id
);
19417 -- The body is a completion of a previous declaration
19419 if Present
(Spec_Id
) then
19420 Check_Pragma_Conformance
19421 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19422 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
),
19423 Entity
=> Spec_Id
);
19425 -- The body acts as spec
19428 Check_Pragma_Conformance
19429 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
19430 Entity_Pragma
=> Empty
,
19436 Set_SPARK_Pragma
(Body_Id
, N
);
19437 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
19439 -- The pragma does not apply to a legal construct, issue error
19447 --------------------------------
19448 -- Static_Elaboration_Desired --
19449 --------------------------------
19451 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
19453 when Pragma_Static_Elaboration_Desired
=>
19455 Check_At_Most_N_Arguments
(1);
19457 if Is_Compilation_Unit
(Current_Scope
)
19458 and then Ekind
(Current_Scope
) = E_Package
19460 Set_Static_Elaboration_Desired
(Current_Scope
, True);
19462 Error_Pragma
("pragma% must apply to a library-level package");
19469 -- pragma Storage_Size (EXPRESSION);
19471 when Pragma_Storage_Size
=> Storage_Size
: declare
19472 P
: constant Node_Id
:= Parent
(N
);
19476 Check_No_Identifiers
;
19477 Check_Arg_Count
(1);
19479 -- The expression must be analyzed in the special manner described
19480 -- in "Handling of Default Expressions" in sem.ads.
19482 Arg
:= Get_Pragma_Arg
(Arg1
);
19483 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
19485 if not Is_OK_Static_Expression
(Arg
) then
19486 Check_Restriction
(Static_Storage_Size
, Arg
);
19489 if Nkind
(P
) /= N_Task_Definition
then
19494 if Has_Storage_Size_Pragma
(P
) then
19495 Error_Pragma
("duplicate pragma% not allowed");
19497 Set_Has_Storage_Size_Pragma
(P
, True);
19500 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
19508 -- pragma Storage_Unit (NUMERIC_LITERAL);
19510 -- Only permitted argument is System'Storage_Unit value
19512 when Pragma_Storage_Unit
=>
19513 Check_No_Identifiers
;
19514 Check_Arg_Count
(1);
19515 Check_Arg_Is_Integer_Literal
(Arg1
);
19517 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
19518 UI_From_Int
(Ttypes
.System_Storage_Unit
)
19520 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
19522 ("the only allowed argument for pragma% is ^", Arg1
);
19525 --------------------
19526 -- Stream_Convert --
19527 --------------------
19529 -- pragma Stream_Convert (
19530 -- [Entity =>] type_LOCAL_NAME,
19531 -- [Read =>] function_NAME,
19532 -- [Write =>] function NAME);
19534 when Pragma_Stream_Convert
=> Stream_Convert
: declare
19536 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
19537 -- Check that the given argument is the name of a local function
19538 -- of one argument that is not overloaded earlier in the current
19539 -- local scope. A check is also made that the argument is a
19540 -- function with one parameter.
19542 --------------------------------------
19543 -- Check_OK_Stream_Convert_Function --
19544 --------------------------------------
19546 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
19550 Check_Arg_Is_Local_Name
(Arg
);
19551 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
19553 if Has_Homonym
(Ent
) then
19555 ("argument for pragma% may not be overloaded", Arg
);
19558 if Ekind
(Ent
) /= E_Function
19559 or else No
(First_Formal
(Ent
))
19560 or else Present
(Next_Formal
(First_Formal
(Ent
)))
19563 ("argument for pragma% must be function of one argument",
19566 end Check_OK_Stream_Convert_Function
;
19568 -- Start of processing for Stream_Convert
19572 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
19573 Check_Arg_Count
(3);
19574 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19575 Check_Optional_Identifier
(Arg2
, Name_Read
);
19576 Check_Optional_Identifier
(Arg3
, Name_Write
);
19577 Check_Arg_Is_Local_Name
(Arg1
);
19578 Check_OK_Stream_Convert_Function
(Arg2
);
19579 Check_OK_Stream_Convert_Function
(Arg3
);
19582 Typ
: constant Entity_Id
:=
19583 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
19584 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
19585 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
19588 Check_First_Subtype
(Arg1
);
19590 -- Check for too early or too late. Note that we don't enforce
19591 -- the rule about primitive operations in this case, since, as
19592 -- is the case for explicit stream attributes themselves, these
19593 -- restrictions are not appropriate. Note that the chaining of
19594 -- the pragma by Rep_Item_Too_Late is actually the critical
19595 -- processing done for this pragma.
19597 if Rep_Item_Too_Early
(Typ
, N
)
19599 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
19604 -- Return if previous error
19606 if Etype
(Typ
) = Any_Type
19608 Etype
(Read
) = Any_Type
19610 Etype
(Write
) = Any_Type
19617 if Underlying_Type
(Etype
(Read
)) /= Typ
then
19619 ("incorrect return type for function&", Arg2
);
19622 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
19624 ("incorrect parameter type for function&", Arg3
);
19627 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
19628 Underlying_Type
(Etype
(Write
))
19631 ("result type of & does not match Read parameter type",
19635 end Stream_Convert
;
19641 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
19643 -- This is processed by the parser since some of the style checks
19644 -- take place during source scanning and parsing. This means that
19645 -- we don't need to issue error messages here.
19647 when Pragma_Style_Checks
=> Style_Checks
: declare
19648 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19654 Check_No_Identifiers
;
19656 -- Two argument form
19658 if Arg_Count
= 2 then
19659 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19666 E_Id
:= Get_Pragma_Arg
(Arg2
);
19669 if not Is_Entity_Name
(E_Id
) then
19671 ("second argument of pragma% must be entity name",
19675 E
:= Entity
(E_Id
);
19677 if not Ignore_Style_Checks_Pragmas
then
19682 Set_Suppress_Style_Checks
19683 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
19684 exit when No
(Homonym
(E
));
19691 -- One argument form
19694 Check_Arg_Count
(1);
19696 if Nkind
(A
) = N_String_Literal
then
19700 Slen
: constant Natural := Natural (String_Length
(S
));
19701 Options
: String (1 .. Slen
);
19707 C
:= Get_String_Char
(S
, Int
(J
));
19708 exit when not In_Character_Range
(C
);
19709 Options
(J
) := Get_Character
(C
);
19711 -- If at end of string, set options. As per discussion
19712 -- above, no need to check for errors, since we issued
19713 -- them in the parser.
19716 if not Ignore_Style_Checks_Pragmas
then
19717 Set_Style_Check_Options
(Options
);
19727 elsif Nkind
(A
) = N_Identifier
then
19728 if Chars
(A
) = Name_All_Checks
then
19729 if not Ignore_Style_Checks_Pragmas
then
19731 Set_GNAT_Style_Check_Options
;
19733 Set_Default_Style_Check_Options
;
19737 elsif Chars
(A
) = Name_On
then
19738 if not Ignore_Style_Checks_Pragmas
then
19739 Style_Check
:= True;
19742 elsif Chars
(A
) = Name_Off
then
19743 if not Ignore_Style_Checks_Pragmas
then
19744 Style_Check
:= False;
19755 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
19757 when Pragma_Subtitle
=>
19759 Check_Arg_Count
(1);
19760 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
19761 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
19768 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
19770 when Pragma_Suppress
=>
19771 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
19777 -- pragma Suppress_All;
19779 -- The only check made here is that the pragma has no arguments.
19780 -- There are no placement rules, and the processing required (setting
19781 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
19782 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
19783 -- then creates and inserts a pragma Suppress (All_Checks).
19785 when Pragma_Suppress_All
=>
19787 Check_Arg_Count
(0);
19789 -------------------------
19790 -- Suppress_Debug_Info --
19791 -------------------------
19793 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
19795 when Pragma_Suppress_Debug_Info
=>
19797 Check_Arg_Count
(1);
19798 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19799 Check_Arg_Is_Local_Name
(Arg1
);
19800 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
19802 ----------------------------------
19803 -- Suppress_Exception_Locations --
19804 ----------------------------------
19806 -- pragma Suppress_Exception_Locations;
19808 when Pragma_Suppress_Exception_Locations
=>
19810 Check_Arg_Count
(0);
19811 Check_Valid_Configuration_Pragma
;
19812 Exception_Locations_Suppressed
:= True;
19814 -----------------------------
19815 -- Suppress_Initialization --
19816 -----------------------------
19818 -- pragma Suppress_Initialization ([Entity =>] type_Name);
19820 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
19826 Check_Arg_Count
(1);
19827 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19828 Check_Arg_Is_Local_Name
(Arg1
);
19830 E_Id
:= Get_Pragma_Arg
(Arg1
);
19832 if Etype
(E_Id
) = Any_Type
then
19836 E
:= Entity
(E_Id
);
19838 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
19840 ("pragma% requires variable, type or subtype", Arg1
);
19843 if Rep_Item_Too_Early
(E
, N
)
19845 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
19850 -- For incomplete/private type, set flag on full view
19852 if Is_Incomplete_Or_Private_Type
(E
) then
19853 if No
(Full_View
(Base_Type
(E
))) then
19855 ("argument of pragma% cannot be an incomplete type", Arg1
);
19857 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
19860 -- For first subtype, set flag on base type
19862 elsif Is_First_Subtype
(E
) then
19863 Set_Suppress_Initialization
(Base_Type
(E
));
19865 -- For other than first subtype, set flag on subtype or variable
19868 Set_Suppress_Initialization
(E
);
19876 -- pragma System_Name (DIRECT_NAME);
19878 -- Syntax check: one argument, which must be the identifier GNAT or
19879 -- the identifier GCC, no other identifiers are acceptable.
19881 when Pragma_System_Name
=>
19883 Check_No_Identifiers
;
19884 Check_Arg_Count
(1);
19885 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
19887 -----------------------------
19888 -- Task_Dispatching_Policy --
19889 -----------------------------
19891 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
19893 when Pragma_Task_Dispatching_Policy
=> declare
19897 Check_Ada_83_Warning
;
19898 Check_Arg_Count
(1);
19899 Check_No_Identifiers
;
19900 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
19901 Check_Valid_Configuration_Pragma
;
19902 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
19903 DP
:= Fold_Upper
(Name_Buffer
(1));
19905 if Task_Dispatching_Policy
/= ' '
19906 and then Task_Dispatching_Policy
/= DP
19908 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
19910 ("task dispatching policy incompatible with policy#");
19912 -- Set new policy, but always preserve System_Location since we
19913 -- like the error message with the run time name.
19916 Task_Dispatching_Policy
:= DP
;
19918 if Task_Dispatching_Policy_Sloc
/= System_Location
then
19919 Task_Dispatching_Policy_Sloc
:= Loc
;
19928 -- pragma Task_Info (EXPRESSION);
19930 when Pragma_Task_Info
=> Task_Info
: declare
19931 P
: constant Node_Id
:= Parent
(N
);
19937 if Warn_On_Obsolescent_Feature
then
19939 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
19940 & "instead?j?", N
);
19943 if Nkind
(P
) /= N_Task_Definition
then
19944 Error_Pragma
("pragma% must appear in task definition");
19947 Check_No_Identifiers
;
19948 Check_Arg_Count
(1);
19950 Analyze_And_Resolve
19951 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
19953 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
19957 Ent
:= Defining_Identifier
(Parent
(P
));
19959 -- Check duplicate pragma before we chain the pragma in the Rep
19960 -- Item chain of Ent.
19963 (Ent
, Name_Task_Info
, Check_Parents
=> False)
19965 Error_Pragma
("duplicate pragma% not allowed");
19968 Record_Rep_Item
(Ent
, N
);
19975 -- pragma Task_Name (string_EXPRESSION);
19977 when Pragma_Task_Name
=> Task_Name
: declare
19978 P
: constant Node_Id
:= Parent
(N
);
19983 Check_No_Identifiers
;
19984 Check_Arg_Count
(1);
19986 Arg
:= Get_Pragma_Arg
(Arg1
);
19988 -- The expression is used in the call to Create_Task, and must be
19989 -- expanded there, not in the context of the current spec. It must
19990 -- however be analyzed to capture global references, in case it
19991 -- appears in a generic context.
19993 Preanalyze_And_Resolve
(Arg
, Standard_String
);
19995 if Nkind
(P
) /= N_Task_Definition
then
19999 Ent
:= Defining_Identifier
(Parent
(P
));
20001 -- Check duplicate pragma before we chain the pragma in the Rep
20002 -- Item chain of Ent.
20005 (Ent
, Name_Task_Name
, Check_Parents
=> False)
20007 Error_Pragma
("duplicate pragma% not allowed");
20010 Record_Rep_Item
(Ent
, N
);
20017 -- pragma Task_Storage (
20018 -- [Task_Type =>] LOCAL_NAME,
20019 -- [Top_Guard =>] static_integer_EXPRESSION);
20021 when Pragma_Task_Storage
=> Task_Storage
: declare
20022 Args
: Args_List
(1 .. 2);
20023 Names
: constant Name_List
(1 .. 2) := (
20027 Task_Type
: Node_Id
renames Args
(1);
20028 Top_Guard
: Node_Id
renames Args
(2);
20034 Gather_Associations
(Names
, Args
);
20036 if No
(Task_Type
) then
20038 ("missing task_type argument for pragma%");
20041 Check_Arg_Is_Local_Name
(Task_Type
);
20043 Ent
:= Entity
(Task_Type
);
20045 if not Is_Task_Type
(Ent
) then
20047 ("argument for pragma% must be task type", Task_Type
);
20050 if No
(Top_Guard
) then
20052 ("pragma% takes two arguments", Task_Type
);
20054 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
20057 Check_First_Subtype
(Task_Type
);
20059 if Rep_Item_Too_Late
(Ent
, N
) then
20068 -- pragma Test_Case
20069 -- ([Name =>] Static_String_EXPRESSION
20070 -- ,[Mode =>] MODE_TYPE
20071 -- [, Requires => Boolean_EXPRESSION]
20072 -- [, Ensures => Boolean_EXPRESSION]);
20074 -- MODE_TYPE ::= Nominal | Robustness
20076 when Pragma_Test_Case
=> Test_Case
: declare
20077 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
20078 -- Ensure that the contract of subprogram Subp_Id does not contain
20079 -- another Test_Case pragma with the same Name as the current one.
20081 -------------------------
20082 -- Check_Distinct_Name --
20083 -------------------------
20085 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
20086 Items
: constant Node_Id
:= Contract
(Subp_Id
);
20087 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
20091 -- Inspect all Test_Case pragma of the related subprogram
20092 -- looking for one with a duplicate "Name" argument.
20094 if Present
(Items
) then
20095 Prag
:= Contract_Test_Cases
(Items
);
20096 while Present
(Prag
) loop
20097 if Pragma_Name
(Prag
) = Name_Test_Case
20098 and then String_Equal
20099 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
20101 Error_Msg_Sloc
:= Sloc
(Prag
);
20102 Error_Pragma
("name for pragma % is already used #");
20105 Prag
:= Next_Pragma
(Prag
);
20108 end Check_Distinct_Name
;
20112 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
20115 Subp_Decl
: Node_Id
;
20116 Subp_Id
: Entity_Id
;
20118 -- Start of processing for Test_Case
20122 Check_At_Least_N_Arguments
(2);
20123 Check_At_Most_N_Arguments
(4);
20125 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
20129 Check_Optional_Identifier
(Arg1
, Name_Name
);
20130 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20134 Check_Optional_Identifier
(Arg2
, Name_Mode
);
20135 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
20137 -- Arguments "Requires" and "Ensures"
20139 if Present
(Arg3
) then
20140 if Present
(Arg4
) then
20141 Check_Identifier
(Arg3
, Name_Requires
);
20142 Check_Identifier
(Arg4
, Name_Ensures
);
20144 Check_Identifier_Is_One_Of
20145 (Arg3
, Name_Requires
, Name_Ensures
);
20149 -- Pragma Test_Case must be associated with a subprogram declared
20150 -- in a library-level package. First determine whether the current
20151 -- compilation unit is a legal context.
20153 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
20154 N_Generic_Package_Declaration
)
20158 -- Otherwise the placement is illegal
20165 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
20167 -- Find the enclosing context
20169 Context
:= Parent
(Subp_Decl
);
20171 if Present
(Context
) then
20172 Context
:= Parent
(Context
);
20175 -- Verify the placement of the pragma
20177 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
20179 ("pragma % cannot be applied to abstract subprogram");
20182 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
20183 Error_Pragma
("pragma % cannot be applied to entry");
20186 -- The context is a [generic] subprogram declared at the top level
20187 -- of the [generic] package unit.
20189 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
20190 N_Subprogram_Declaration
)
20191 and then Present
(Context
)
20192 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
20193 N_Package_Declaration
)
20195 Subp_Id
:= Defining_Entity
(Subp_Decl
);
20197 -- Otherwise the placement is illegal
20204 -- Preanalyze the original aspect argument "Name" for ASIS or for
20205 -- a generic subprogram to properly capture global references.
20207 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
20208 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
20210 if Present
(Asp_Arg
) then
20212 -- The argument appears with an identifier in association
20215 if Nkind
(Asp_Arg
) = N_Component_Association
then
20216 Asp_Arg
:= Expression
(Asp_Arg
);
20219 Check_Expr_Is_OK_Static_Expression
20220 (Asp_Arg
, Standard_String
);
20224 -- Ensure that the all Test_Case pragmas of the related subprogram
20225 -- have distinct names.
20227 Check_Distinct_Name
(Subp_Id
);
20229 -- Construct a generic template for the pragma when the context is
20230 -- a generic subprogram and the pragma is a source construct.
20232 Create_Generic_Template
(N
, Subp_Id
);
20234 -- Fully analyze the pragma when it appears inside a subprogram
20235 -- body because it cannot benefit from forward references.
20237 if Nkind_In
(Subp_Decl
, N_Subprogram_Body
,
20238 N_Subprogram_Body_Stub
)
20240 Analyze_Test_Case_In_Decl_Part
(N
);
20243 -- Chain the pragma on the contract for further processing
20245 Add_Contract_Item
(N
, Subp_Id
);
20248 --------------------------
20249 -- Thread_Local_Storage --
20250 --------------------------
20252 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
20254 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
20260 Check_Arg_Count
(1);
20261 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20262 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20264 Id
:= Get_Pragma_Arg
(Arg1
);
20267 if not Is_Entity_Name
(Id
)
20268 or else Ekind
(Entity
(Id
)) /= E_Variable
20270 Error_Pragma_Arg
("local variable name required", Arg1
);
20275 if Rep_Item_Too_Early
(E
, N
)
20276 or else Rep_Item_Too_Late
(E
, N
)
20281 Set_Has_Pragma_Thread_Local_Storage
(E
);
20282 Set_Has_Gigi_Rep_Item
(E
);
20283 end Thread_Local_Storage
;
20289 -- pragma Time_Slice (static_duration_EXPRESSION);
20291 when Pragma_Time_Slice
=> Time_Slice
: declare
20297 Check_Arg_Count
(1);
20298 Check_No_Identifiers
;
20299 Check_In_Main_Program
;
20300 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
20302 if not Error_Posted
(Arg1
) then
20304 while Present
(Nod
) loop
20305 if Nkind
(Nod
) = N_Pragma
20306 and then Pragma_Name
(Nod
) = Name_Time_Slice
20308 Error_Msg_Name_1
:= Pname
;
20309 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20316 -- Process only if in main unit
20318 if Get_Source_Unit
(Loc
) = Main_Unit
then
20319 Opt
.Time_Slice_Set
:= True;
20320 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
20322 if Val
<= Ureal_0
then
20323 Opt
.Time_Slice_Value
:= 0;
20325 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
20326 Opt
.Time_Slice_Value
:= 1_000_000_000
;
20329 Opt
.Time_Slice_Value
:=
20330 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
20339 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
20341 -- TITLING_OPTION ::=
20342 -- [Title =>] STRING_LITERAL
20343 -- | [Subtitle =>] STRING_LITERAL
20345 when Pragma_Title
=> Title
: declare
20346 Args
: Args_List
(1 .. 2);
20347 Names
: constant Name_List
(1 .. 2) := (
20353 Gather_Associations
(Names
, Args
);
20356 for J
in 1 .. 2 loop
20357 if Present
(Args
(J
)) then
20358 Check_Arg_Is_OK_Static_Expression
20359 (Args
(J
), Standard_String
);
20364 ----------------------------
20365 -- Type_Invariant[_Class] --
20366 ----------------------------
20368 -- pragma Type_Invariant[_Class]
20369 -- ([Entity =>] type_LOCAL_NAME,
20370 -- [Check =>] EXPRESSION);
20372 when Pragma_Type_Invariant |
20373 Pragma_Type_Invariant_Class
=>
20374 Type_Invariant
: declare
20375 I_Pragma
: Node_Id
;
20378 Check_Arg_Count
(2);
20380 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
20381 -- setting Class_Present for the Type_Invariant_Class case.
20383 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
20384 I_Pragma
:= New_Copy
(N
);
20385 Set_Pragma_Identifier
20386 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
20387 Rewrite
(N
, I_Pragma
);
20388 Set_Analyzed
(N
, False);
20390 end Type_Invariant
;
20392 ---------------------
20393 -- Unchecked_Union --
20394 ---------------------
20396 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
20398 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
20399 Assoc
: constant Node_Id
:= Arg1
;
20400 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
20410 Check_No_Identifiers
;
20411 Check_Arg_Count
(1);
20412 Check_Arg_Is_Local_Name
(Arg1
);
20414 Find_Type
(Type_Id
);
20416 Typ
:= Entity
(Type_Id
);
20419 or else Rep_Item_Too_Early
(Typ
, N
)
20423 Typ
:= Underlying_Type
(Typ
);
20426 if Rep_Item_Too_Late
(Typ
, N
) then
20430 Check_First_Subtype
(Arg1
);
20432 -- Note remaining cases are references to a type in the current
20433 -- declarative part. If we find an error, we post the error on
20434 -- the relevant type declaration at an appropriate point.
20436 if not Is_Record_Type
(Typ
) then
20437 Error_Msg_N
("unchecked union must be record type", Typ
);
20440 elsif Is_Tagged_Type
(Typ
) then
20441 Error_Msg_N
("unchecked union must not be tagged", Typ
);
20444 elsif not Has_Discriminants
(Typ
) then
20446 ("unchecked union must have one discriminant", Typ
);
20449 -- Note: in previous versions of GNAT we used to check for limited
20450 -- types and give an error, but in fact the standard does allow
20451 -- Unchecked_Union on limited types, so this check was removed.
20453 -- Similarly, GNAT used to require that all discriminants have
20454 -- default values, but this is not mandated by the RM.
20456 -- Proceed with basic error checks completed
20459 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
20460 Clist
:= Component_List
(Tdef
);
20462 -- Check presence of component list and variant part
20464 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
20466 ("unchecked union must have variant part", Tdef
);
20470 -- Check components
20472 Comp
:= First
(Component_Items
(Clist
));
20473 while Present
(Comp
) loop
20474 Check_Component
(Comp
, Typ
);
20478 -- Check variant part
20480 Vpart
:= Variant_Part
(Clist
);
20482 Variant
:= First
(Variants
(Vpart
));
20483 while Present
(Variant
) loop
20484 Check_Variant
(Variant
, Typ
);
20489 Set_Is_Unchecked_Union
(Typ
);
20490 Set_Convention
(Typ
, Convention_C
);
20491 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
20492 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
20493 end Unchecked_Union
;
20495 ------------------------
20496 -- Unimplemented_Unit --
20497 ------------------------
20499 -- pragma Unimplemented_Unit;
20501 -- Note: this only gives an error if we are generating code, or if
20502 -- we are in a generic library unit (where the pragma appears in the
20503 -- body, not in the spec).
20505 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
20506 Cunitent
: constant Entity_Id
:=
20507 Cunit_Entity
(Get_Source_Unit
(Loc
));
20508 Ent_Kind
: constant Entity_Kind
:=
20513 Check_Arg_Count
(0);
20515 if Operating_Mode
= Generate_Code
20516 or else Ent_Kind
= E_Generic_Function
20517 or else Ent_Kind
= E_Generic_Procedure
20518 or else Ent_Kind
= E_Generic_Package
20520 Get_Name_String
(Chars
(Cunitent
));
20521 Set_Casing
(Mixed_Case
);
20522 Write_Str
(Name_Buffer
(1 .. Name_Len
));
20523 Write_Str
(" is not supported in this configuration");
20525 raise Unrecoverable_Error
;
20527 end Unimplemented_Unit
;
20529 ------------------------
20530 -- Universal_Aliasing --
20531 ------------------------
20533 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
20535 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
20540 Check_Arg_Count
(1);
20541 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20542 Check_Arg_Is_Local_Name
(Arg1
);
20543 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20545 if E_Id
= Any_Type
then
20547 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
20548 Error_Pragma_Arg
("pragma% requires type", Arg1
);
20551 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
20552 Record_Rep_Item
(E_Id
, N
);
20553 end Universal_Alias
;
20555 --------------------
20556 -- Universal_Data --
20557 --------------------
20559 -- pragma Universal_Data [(library_unit_NAME)];
20561 when Pragma_Universal_Data
=>
20564 -- If this is a configuration pragma, then set the universal
20565 -- addressing option, otherwise confirm that the pragma satisfies
20566 -- the requirements of library unit pragma placement and leave it
20567 -- to the GNAAMP back end to detect the pragma (avoids transitive
20568 -- setting of the option due to withed units).
20570 if Is_Configuration_Pragma
then
20571 Universal_Addressing_On_AAMP
:= True;
20573 Check_Valid_Library_Unit_Pragma
;
20576 if not AAMP_On_Target
then
20577 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
20584 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
20586 when Pragma_Unmodified
=> Unmodified
: declare
20587 Arg_Node
: Node_Id
;
20588 Arg_Expr
: Node_Id
;
20589 Arg_Ent
: Entity_Id
;
20593 Check_At_Least_N_Arguments
(1);
20595 -- Loop through arguments
20598 while Present
(Arg_Node
) loop
20599 Check_No_Identifier
(Arg_Node
);
20601 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
20602 -- in fact generate reference, so that the entity will have a
20603 -- reference, which will inhibit any warnings about it not
20604 -- being referenced, and also properly show up in the ali file
20605 -- as a reference. But this reference is recorded before the
20606 -- Has_Pragma_Unreferenced flag is set, so that no warning is
20607 -- generated for this reference.
20609 Check_Arg_Is_Local_Name
(Arg_Node
);
20610 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20612 if Is_Entity_Name
(Arg_Expr
) then
20613 Arg_Ent
:= Entity
(Arg_Expr
);
20615 if not Is_Assignable
(Arg_Ent
) then
20617 ("pragma% can only be applied to a variable",
20620 Set_Has_Pragma_Unmodified
(Arg_Ent
);
20632 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
20634 -- or when used in a context clause:
20636 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
20638 when Pragma_Unreferenced
=> Unreferenced
: declare
20639 Arg_Node
: Node_Id
;
20640 Arg_Expr
: Node_Id
;
20641 Arg_Ent
: Entity_Id
;
20646 Check_At_Least_N_Arguments
(1);
20648 -- Check case of appearing within context clause
20650 if Is_In_Context_Clause
then
20652 -- The arguments must all be units mentioned in a with clause
20653 -- in the same context clause. Note we already checked (in
20654 -- Par.Prag) that the arguments are either identifiers or
20655 -- selected components.
20658 while Present
(Arg_Node
) loop
20659 Citem
:= First
(List_Containing
(N
));
20660 while Citem
/= N
loop
20661 if Nkind
(Citem
) = N_With_Clause
20663 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
20665 Set_Has_Pragma_Unreferenced
20668 (Library_Unit
(Citem
))));
20670 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
20679 ("argument of pragma% is not withed unit", Arg_Node
);
20685 -- Case of not in list of context items
20689 while Present
(Arg_Node
) loop
20690 Check_No_Identifier
(Arg_Node
);
20692 -- Note: the analyze call done by Check_Arg_Is_Local_Name
20693 -- will in fact generate reference, so that the entity will
20694 -- have a reference, which will inhibit any warnings about
20695 -- it not being referenced, and also properly show up in the
20696 -- ali file as a reference. But this reference is recorded
20697 -- before the Has_Pragma_Unreferenced flag is set, so that
20698 -- no warning is generated for this reference.
20700 Check_Arg_Is_Local_Name
(Arg_Node
);
20701 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20703 if Is_Entity_Name
(Arg_Expr
) then
20704 Arg_Ent
:= Entity
(Arg_Expr
);
20706 -- If the entity is overloaded, the pragma applies to the
20707 -- most recent overloading, as documented. In this case,
20708 -- name resolution does not generate a reference, so it
20709 -- must be done here explicitly.
20711 if Is_Overloaded
(Arg_Expr
) then
20712 Generate_Reference
(Arg_Ent
, N
);
20715 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
20723 --------------------------
20724 -- Unreferenced_Objects --
20725 --------------------------
20727 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
20729 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
20730 Arg_Node
: Node_Id
;
20731 Arg_Expr
: Node_Id
;
20735 Check_At_Least_N_Arguments
(1);
20738 while Present
(Arg_Node
) loop
20739 Check_No_Identifier
(Arg_Node
);
20740 Check_Arg_Is_Local_Name
(Arg_Node
);
20741 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
20743 if not Is_Entity_Name
(Arg_Expr
)
20744 or else not Is_Type
(Entity
(Arg_Expr
))
20747 ("argument for pragma% must be type or subtype", Arg_Node
);
20750 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
20753 end Unreferenced_Objects
;
20755 ------------------------------
20756 -- Unreserve_All_Interrupts --
20757 ------------------------------
20759 -- pragma Unreserve_All_Interrupts;
20761 when Pragma_Unreserve_All_Interrupts
=>
20763 Check_Arg_Count
(0);
20765 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
20766 Unreserve_All_Interrupts
:= True;
20773 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
20775 when Pragma_Unsuppress
=>
20777 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
20779 ----------------------------
20780 -- Unevaluated_Use_Of_Old --
20781 ----------------------------
20783 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
20785 when Pragma_Unevaluated_Use_Of_Old
=>
20787 Check_Arg_Count
(1);
20788 Check_No_Identifiers
;
20789 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
20791 -- Suppress/Unsuppress can appear as a configuration pragma, or in
20792 -- a declarative part or a package spec.
20794 if not Is_Configuration_Pragma
then
20795 Check_Is_In_Decl_Part_Or_Package_Spec
;
20798 -- Store proper setting of Uneval_Old
20800 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20801 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
20803 -------------------
20804 -- Use_VADS_Size --
20805 -------------------
20807 -- pragma Use_VADS_Size;
20809 when Pragma_Use_VADS_Size
=>
20811 Check_Arg_Count
(0);
20812 Check_Valid_Configuration_Pragma
;
20813 Use_VADS_Size
:= True;
20815 ---------------------
20816 -- Validity_Checks --
20817 ---------------------
20819 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
20821 when Pragma_Validity_Checks
=> Validity_Checks
: declare
20822 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20828 Check_Arg_Count
(1);
20829 Check_No_Identifiers
;
20831 -- Pragma always active unless in CodePeer or GNATprove modes,
20832 -- which use a fixed configuration of validity checks.
20834 if not (CodePeer_Mode
or GNATprove_Mode
) then
20835 if Nkind
(A
) = N_String_Literal
then
20839 Slen
: constant Natural := Natural (String_Length
(S
));
20840 Options
: String (1 .. Slen
);
20844 -- Couldn't we use a for loop here over Options'Range???
20848 C
:= Get_String_Char
(S
, Int
(J
));
20850 -- This is a weird test, it skips setting validity
20851 -- checks entirely if any element of S is out of
20852 -- range of Character, what is that about ???
20854 exit when not In_Character_Range
(C
);
20855 Options
(J
) := Get_Character
(C
);
20858 Set_Validity_Check_Options
(Options
);
20866 elsif Nkind
(A
) = N_Identifier
then
20867 if Chars
(A
) = Name_All_Checks
then
20868 Set_Validity_Check_Options
("a");
20869 elsif Chars
(A
) = Name_On
then
20870 Validity_Checks_On
:= True;
20871 elsif Chars
(A
) = Name_Off
then
20872 Validity_Checks_On
:= False;
20876 end Validity_Checks
;
20882 -- pragma Volatile (LOCAL_NAME);
20884 when Pragma_Volatile
=>
20885 Process_Atomic_Independent_Shared_Volatile
;
20887 -------------------------
20888 -- Volatile_Components --
20889 -------------------------
20891 -- pragma Volatile_Components (array_LOCAL_NAME);
20893 -- Volatile is handled by the same circuit as Atomic_Components
20895 ----------------------
20896 -- Warning_As_Error --
20897 ----------------------
20899 -- pragma Warning_As_Error (static_string_EXPRESSION);
20901 when Pragma_Warning_As_Error
=>
20903 Check_Arg_Count
(1);
20904 Check_No_Identifiers
;
20905 Check_Valid_Configuration_Pragma
;
20907 if not Is_Static_String_Expression
(Arg1
) then
20909 ("argument of pragma% must be static string expression",
20912 -- OK static string expression
20915 Acquire_Warning_Match_String
(Arg1
);
20916 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
20917 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
20918 new String'(Name_Buffer (1 .. Name_Len));
20925 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
20927 -- DETAILS ::= On | Off
20928 -- DETAILS ::= On | Off, local_NAME
20929 -- DETAILS ::= static_string_EXPRESSION
20930 -- DETAILS ::= On | Off, static_string_EXPRESSION
20932 -- TOOL_NAME ::= GNAT | GNATProve
20934 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
20936 -- Note: If the first argument matches an allowed tool name, it is
20937 -- always considered to be a tool name, even if there is a string
20938 -- variable of that name.
20940 -- Note if the second argument of DETAILS is a local_NAME then the
20941 -- second form is always understood. If the intention is to use
20942 -- the fourth form, then you can write NAME & "" to force the
20943 -- intepretation as a static_string_EXPRESSION.
20945 when Pragma_Warnings => Warnings : declare
20946 Reason : String_Id;
20950 Check_At_Least_N_Arguments (1);
20952 -- See if last argument is labeled Reason. If so, make sure we
20953 -- have a string literal or a concatenation of string literals,
20954 -- and acquire the REASON string. Then remove the REASON argument
20955 -- by decreasing Num_Args by one; Remaining processing looks only
20956 -- at first Num_Args arguments).
20959 Last_Arg : constant Node_Id :=
20960 Last (Pragma_Argument_Associations (N));
20963 if Nkind (Last_Arg) = N_Pragma_Argument_Association
20964 and then Chars (Last_Arg) = Name_Reason
20967 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
20968 Reason := End_String;
20969 Arg_Count := Arg_Count - 1;
20971 -- Not allowed in compiler units (bootstrap issues)
20973 Check_Compiler_Unit ("Reason for pragma Warnings", N);
20975 -- No REASON string, set null string as reason
20978 Reason := Null_String_Id;
20982 -- Now proceed with REASON taken care of and eliminated
20984 Check_No_Identifiers;
20986 -- If debug flag -gnatd.i is set, pragma is ignored
20988 if Debug_Flag_Dot_I then
20992 -- Process various forms of the pragma
20995 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
20996 Shifted_Args : List_Id;
20999 -- See if first argument is a tool name, currently either
21000 -- GNAT or GNATprove. If so, either ignore the pragma if the
21001 -- tool used does not match, or continue as if no tool name
21002 -- was given otherwise, by shifting the arguments.
21004 if Nkind (Argx) = N_Identifier
21005 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
21007 if Chars (Argx) = Name_Gnat then
21008 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
21009 Rewrite (N, Make_Null_Statement (Loc));
21014 elsif Chars (Argx) = Name_Gnatprove then
21015 if not GNATprove_Mode then
21016 Rewrite (N, Make_Null_Statement (Loc));
21022 raise Program_Error;
21025 -- At this point, the pragma Warnings applies to the tool,
21026 -- so continue with shifted arguments.
21028 Arg_Count := Arg_Count - 1;
21030 if Arg_Count = 1 then
21031 Shifted_Args := New_List (New_Copy (Arg2));
21032 elsif Arg_Count = 2 then
21033 Shifted_Args := New_List (New_Copy (Arg2),
21035 elsif Arg_Count = 3 then
21036 Shifted_Args := New_List (New_Copy (Arg2),
21040 raise Program_Error;
21045 Chars => Name_Warnings,
21046 Pragma_Argument_Associations => Shifted_Args));
21051 -- One argument case
21053 if Arg_Count = 1 then
21055 -- On/Off one argument case was processed by parser
21057 if Nkind (Argx) = N_Identifier
21058 and then Nam_In (Chars (Argx), Name_On, Name_Off)
21062 -- One argument case must be ON/OFF or static string expr
21064 elsif not Is_Static_String_Expression (Arg1) then
21066 ("argument of pragma% must be On/Off or static string "
21067 & "expression", Arg1);
21069 -- One argument string expression case
21073 Lit : constant Node_Id := Expr_Value_S (Argx);
21074 Str : constant String_Id := Strval (Lit);
21075 Len : constant Nat := String_Length (Str);
21083 while J <= Len loop
21084 C := Get_String_Char (Str, J);
21085 OK := In_Character_Range (C);
21088 Chr := Get_Character (C);
21090 -- Dash case: only -Wxxx is accepted
21097 C := Get_String_Char (Str, J);
21098 Chr := Get_Character (C);
21099 exit when Chr = 'W
';
21104 elsif J < Len and then Chr = '.' then
21106 C := Get_String_Char (Str, J);
21107 Chr := Get_Character (C);
21109 if not Set_Dot_Warning_Switch (Chr) then
21111 ("invalid warning switch character "
21112 & '.' & Chr, Arg1);
21118 OK := Set_Warning_Switch (Chr);
21124 ("invalid warning switch character " & Chr,
21133 -- Two or more arguments (must be two)
21136 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21137 Check_Arg_Count (2);
21145 E_Id := Get_Pragma_Arg (Arg2);
21148 -- In the expansion of an inlined body, a reference to
21149 -- the formal may be wrapped in a conversion if the
21150 -- actual is a conversion. Retrieve the real entity name.
21152 if (In_Instance_Body or In_Inlined_Body)
21153 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
21155 E_Id := Expression (E_Id);
21158 -- Entity name case
21160 if Is_Entity_Name (E_Id) then
21161 E := Entity (E_Id);
21168 (E, (Chars (Get_Pragma_Arg (Arg1)) =
21171 -- For OFF case, make entry in warnings off
21172 -- pragma table for later processing. But we do
21173 -- not do that within an instance, since these
21174 -- warnings are about what is needed in the
21175 -- template, not an instance of it.
21177 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
21178 and then Warn_On_Warnings_Off
21179 and then not In_Instance
21181 Warnings_Off_Pragmas.Append ((N, E, Reason));
21184 if Is_Enumeration_Type (E) then
21188 Lit := First_Literal (E);
21189 while Present (Lit) loop
21190 Set_Warnings_Off (Lit);
21191 Next_Literal (Lit);
21196 exit when No (Homonym (E));
21201 -- Error if not entity or static string expression case
21203 elsif not Is_Static_String_Expression (Arg2) then
21205 ("second argument of pragma% must be entity name "
21206 & "or static string expression", Arg2);
21208 -- Static string expression case
21211 Acquire_Warning_Match_String (Arg2);
21213 -- Note on configuration pragma case: If this is a
21214 -- configuration pragma, then for an OFF pragma, we
21215 -- just set Config True in the call, which is all
21216 -- that needs to be done. For the case of ON, this
21217 -- is normally an error, unless it is canceling the
21218 -- effect of a previous OFF pragma in the same file.
21219 -- In any other case, an error will be signalled (ON
21220 -- with no matching OFF).
21222 -- Note: We set Used if we are inside a generic to
21223 -- disable the test that the non-config case actually
21224 -- cancels a warning. That's because we can't be sure
21225 -- there isn't an instantiation in some other unit
21226 -- where a warning is suppressed.
21228 -- We could do a little better here by checking if the
21229 -- generic unit we are inside is public, but for now
21230 -- we don't bother with that refinement.
21232 if Chars (Argx) = Name_Off then
21233 Set_Specific_Warning_Off
21234 (Loc, Name_Buffer (1 .. Name_Len), Reason,
21235 Config => Is_Configuration_Pragma,
21236 Used => Inside_A_Generic or else In_Instance);
21238 elsif Chars (Argx) = Name_On then
21239 Set_Specific_Warning_On
21240 (Loc, Name_Buffer (1 .. Name_Len), Err);
21244 ("??pragma Warnings On with no matching "
21245 & "Warnings Off", Loc);
21254 -------------------
21255 -- Weak_External --
21256 -------------------
21258 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
21260 when Pragma_Weak_External => Weak_External : declare
21265 Check_Arg_Count (1);
21266 Check_Optional_Identifier (Arg1, Name_Entity);
21267 Check_Arg_Is_Library_Level_Local_Name (Arg1);
21268 Ent := Entity (Get_Pragma_Arg (Arg1));
21270 if Rep_Item_Too_Early (Ent, N) then
21273 Ent := Underlying_Type (Ent);
21276 -- The only processing required is to link this item on to the
21277 -- list of rep items for the given entity. This is accomplished
21278 -- by the call to Rep_Item_Too_Late (when no error is detected
21279 -- and False is returned).
21281 if Rep_Item_Too_Late (Ent, N) then
21284 Set_Has_Gigi_Rep_Item (Ent);
21288 -----------------------------
21289 -- Wide_Character_Encoding --
21290 -----------------------------
21292 -- pragma Wide_Character_Encoding (IDENTIFIER);
21294 when Pragma_Wide_Character_Encoding =>
21297 -- Nothing to do, handled in parser. Note that we do not enforce
21298 -- configuration pragma placement, this pragma can appear at any
21299 -- place in the source, allowing mixed encodings within a single
21304 --------------------
21305 -- Unknown_Pragma --
21306 --------------------
21308 -- Should be impossible, since the case of an unknown pragma is
21309 -- separately processed before the case statement is entered.
21311 when Unknown_Pragma =>
21312 raise Program_Error;
21315 -- AI05-0144: detect dangerous order dependence. Disabled for now,
21316 -- until AI is formally approved.
21318 -- Check_Order_Dependence;
21321 when Pragma_Exit => null;
21322 end Analyze_Pragma;
21324 ---------------------------------------------
21325 -- Analyze_Pre_Post_Condition_In_Decl_Part --
21326 ---------------------------------------------
21328 procedure Analyze_Pre_Post_Condition_In_Decl_Part (N : Node_Id) is
21329 procedure Process_Class_Wide_Condition
21331 Spec_Id : Entity_Id;
21332 Subp_Decl : Node_Id);
21333 -- Replace the type of all references to the controlling formal of
21334 -- subprogram Spec_Id found in expression Expr with the corresponding
21335 -- class-wide type. Subp_Decl is the subprogram [body] declaration
21336 -- where the pragma resides.
21338 ----------------------------------
21339 -- Process_Class_Wide_Condition --
21340 ----------------------------------
21342 procedure Process_Class_Wide_Condition
21344 Spec_Id : Entity_Id;
21345 Subp_Decl : Node_Id)
21347 Disp_Typ : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
21349 ACW : Entity_Id := Empty;
21350 -- Access to Disp_Typ'Class, created if there is a controlling formal
21351 -- that is an access parameter.
21353 function Access_Class_Wide_Type return Entity_Id;
21354 -- If expression Expr contains a reference to a controlling access
21355 -- parameter, create an access to Disp_Typ'Class for the necessary
21356 -- conversions if one does not exist.
21358 function Replace_Type (N : Node_Id) return Traverse_Result;
21359 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
21360 -- aspect for a primitive subprogram of a tagged type Disp_Typ, a
21361 -- name that denotes a formal parameter of type Disp_Typ is treated
21362 -- as having type Disp_Typ'Class. Similarly, a name that denotes a
21363 -- formal access parameter of type access-to-Disp_Typ is interpreted
21364 -- as with type access-to-Disp_Typ'Class. This ensures the expression
21365 -- is well defined for a primitive subprogram of a type descended
21368 ----------------------------
21369 -- Access_Class_Wide_Type --
21370 ----------------------------
21372 function Access_Class_Wide_Type return Entity_Id is
21373 Loc : constant Source_Ptr := Sloc (N);
21377 ACW := Make_Temporary (Loc, 'T
');
21379 Insert_Before_And_Analyze (Subp_Decl,
21380 Make_Full_Type_Declaration (Loc,
21381 Defining_Identifier => ACW,
21383 Make_Access_To_Object_Definition (Loc,
21384 Subtype_Indication =>
21385 New_Occurrence_Of (Class_Wide_Type (Disp_Typ), Loc),
21386 All_Present => True)));
21388 Freeze_Before (Subp_Decl, ACW);
21392 end Access_Class_Wide_Type;
21398 function Replace_Type (N : Node_Id) return Traverse_Result is
21399 Context : constant Node_Id := Parent (N);
21400 Loc : constant Source_Ptr := Sloc (N);
21401 CW_Typ : Entity_Id := Empty;
21406 if Is_Entity_Name (N)
21407 and then Present (Entity (N))
21408 and then Is_Formal (Entity (N))
21411 Typ := Etype (Ent);
21413 -- Do not perform the type replacement for selector names in
21414 -- parameter associations. These carry an entity for reference
21415 -- purposes, but semantically they are just identifiers.
21417 if Nkind (Context) = N_Type_Conversion then
21420 elsif Nkind (Context) = N_Parameter_Association
21421 and then Selector_Name (Context) = N
21425 elsif Typ = Disp_Typ then
21426 CW_Typ := Class_Wide_Type (Typ);
21428 elsif Is_Access_Type (Typ)
21429 and then Designated_Type (Typ) = Disp_Typ
21431 CW_Typ := Access_Class_Wide_Type;
21434 if Present (CW_Typ) then
21436 Make_Type_Conversion (Loc,
21437 Subtype_Mark => New_Occurrence_Of (CW_Typ, Loc),
21438 Expression => New_Occurrence_Of (Ent, Loc)));
21439 Set_Etype (N, CW_Typ);
21446 procedure Replace_Types is new Traverse_Proc (Replace_Type);
21448 -- Start of processing for Process_Class_Wide_Condition
21451 -- The subprogram subject to Pre'Class/Post'Class does not have a
21452 -- dispatching type, therefore the aspect/pragma is illegal.
21454 if No (Disp_Typ) then
21455 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
21457 if From_Aspect_Specification (N) then
21459 ("aspect % can only be specified for a primitive operation "
21460 & "of a tagged type", Corresponding_Aspect (N));
21462 -- The pragma is a source construct
21466 ("pragma % can only be specified for a primitive operation "
21467 & "of a tagged type", N);
21471 Replace_Types (Expr);
21472 end Process_Class_Wide_Condition;
21476 Subp_Decl : constant Node_Id := Find_Related_Subprogram_Or_Body (N);
21477 Expr : constant Node_Id :=
21478 Expression (Get_Argument (N, Defining_Entity (Subp_Decl)));
21479 Spec_Id : constant Entity_Id := Corresponding_Spec_Of (Subp_Decl);
21481 Restore_Scope : Boolean := False;
21482 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
21484 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
21487 -- Ensure that the subprogram and its formals are visible when analyzing
21488 -- the expression of the pragma.
21490 if not In_Open_Scopes (Spec_Id) then
21491 Restore_Scope := True;
21492 Push_Scope (Spec_Id);
21494 if Is_Generic_Subprogram (Spec_Id) then
21495 Install_Generic_Formals (Spec_Id);
21497 Install_Formals (Spec_Id);
21501 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
21503 -- For a class-wide condition, a reference to a controlling formal must
21504 -- be interpreted as having the class-wide type (or an access to such)
21505 -- so that the inherited condition can be properly applied to any
21506 -- overriding operation (see ARM12 6.6.1 (7)).
21508 if Class_Present (N) then
21509 Process_Class_Wide_Condition (Expr, Spec_Id, Subp_Decl);
21512 -- Remove the subprogram from the scope stack now that the pre-analysis
21513 -- of the precondition/postcondition is done.
21515 if Restore_Scope then
21518 end Analyze_Pre_Post_Condition_In_Decl_Part;
21520 ------------------------------------------
21521 -- Analyze_Refined_Depends_In_Decl_Part --
21522 ------------------------------------------
21524 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
21525 Body_Inputs : Elist_Id := No_Elist;
21526 Body_Outputs : Elist_Id := No_Elist;
21527 -- The inputs and outputs of the subprogram body synthesized from pragma
21528 -- Refined_Depends.
21530 Dependencies : List_Id := No_List;
21532 -- The corresponding Depends pragma along with its clauses
21534 Matched_Items : Elist_Id := No_Elist;
21535 -- A list containing the entities of all successfully matched items
21536 -- found in pragma Depends.
21538 Refinements : List_Id := No_List;
21539 -- The clauses of pragma Refined_Depends
21541 Spec_Id : Entity_Id;
21542 -- The entity of the subprogram subject to pragma Refined_Depends
21544 Spec_Inputs : Elist_Id := No_Elist;
21545 Spec_Outputs : Elist_Id := No_Elist;
21546 -- The inputs and outputs of the subprogram spec synthesized from pragma
21549 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
21550 -- Try to match a single dependency clause Dep_Clause against one or
21551 -- more refinement clauses found in list Refinements. Each successful
21552 -- match eliminates at least one refinement clause from Refinements.
21554 procedure Check_Output_States;
21555 -- Determine whether pragma Depends contains an output state with a
21556 -- visible refinement and if so, ensure that pragma Refined_Depends
21557 -- mentions all its constituents as outputs.
21559 procedure Normalize_Clauses (Clauses : List_Id);
21560 -- Given a list of dependence or refinement clauses Clauses, normalize
21561 -- each clause by creating multiple dependencies with exactly one input
21564 procedure Report_Extra_Clauses;
21565 -- Emit an error for each extra clause found in list Refinements
21567 -----------------------------
21568 -- Check_Dependency_Clause --
21569 -----------------------------
21571 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
21572 Dep_Input : constant Node_Id := Expression (Dep_Clause);
21573 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
21575 function Is_In_Out_State_Clause return Boolean;
21576 -- Determine whether dependence clause Dep_Clause denotes an abstract
21577 -- state that depends on itself (State => State).
21579 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
21580 -- Determine whether item Item denotes an abstract state with visible
21581 -- null refinement.
21583 procedure Match_Items
21584 (Dep_Item : Node_Id;
21585 Ref_Item : Node_Id;
21586 Matched : out Boolean);
21587 -- Try to match dependence item Dep_Item against refinement item
21588 -- Ref_Item. To match against a possible null refinement (see 2, 7),
21589 -- set Ref_Item to Empty. Flag Matched is set to True when one of
21590 -- the following conformance scenarios is in effect:
21591 -- 1) Both items denote null
21592 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
21593 -- 3) Both items denote attribute 'Result
21594 -- 4) Both items denote the same formal parameter
21595 -- 5) Both items denote the same variable
21596 -- 6) Dep_Item is an abstract state with visible null refinement
21597 -- and Ref_Item denotes null.
21598 -- 7) Dep_Item is an abstract state with visible null refinement
21599 -- and Ref_Item is Empty (special case).
21600 -- 8) Dep_Item is an abstract state with visible non-null
21601 -- refinement and Ref_Item denotes one of its constituents.
21602 -- 9) Dep_Item is an abstract state without a visible refinement
21603 -- and Ref_Item denotes the same state.
21604 -- When scenario 8 is in effect, the entity of the abstract state
21605 -- denoted by Dep_Item is added to list Refined_States.
21607 procedure Record_Item
(Item_Id
: Entity_Id
);
21608 -- Store the entity of an item denoted by Item_Id in Matched_Items
21610 ----------------------------
21611 -- Is_In_Out_State_Clause --
21612 ----------------------------
21614 function Is_In_Out_State_Clause
return Boolean is
21615 Dep_Input_Id
: Entity_Id
;
21616 Dep_Output_Id
: Entity_Id
;
21619 -- Detect the following clause:
21622 if Is_Entity_Name
(Dep_Input
)
21623 and then Is_Entity_Name
(Dep_Output
)
21625 -- Handle abstract views generated for limited with clauses
21627 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
21628 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
21631 Ekind
(Dep_Input_Id
) = E_Abstract_State
21632 and then Dep_Input_Id
= Dep_Output_Id
;
21636 end Is_In_Out_State_Clause
;
21638 ---------------------------
21639 -- Is_Null_Refined_State --
21640 ---------------------------
21642 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
21643 Item_Id
: Entity_Id
;
21646 if Is_Entity_Name
(Item
) then
21648 -- Handle abstract views generated for limited with clauses
21650 Item_Id
:= Available_View
(Entity_Of
(Item
));
21652 return Ekind
(Item_Id
) = E_Abstract_State
21653 and then Has_Null_Refinement
(Item_Id
);
21658 end Is_Null_Refined_State
;
21664 procedure Match_Items
21665 (Dep_Item
: Node_Id
;
21666 Ref_Item
: Node_Id
;
21667 Matched
: out Boolean)
21669 Dep_Item_Id
: Entity_Id
;
21670 Ref_Item_Id
: Entity_Id
;
21673 -- Assume that the two items do not match
21677 -- A null matches null or Empty (special case)
21679 if Nkind
(Dep_Item
) = N_Null
21680 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
21684 -- Attribute 'Result matches attribute 'Result
21686 elsif Is_Attribute_Result
(Dep_Item
)
21687 and then Is_Attribute_Result
(Dep_Item
)
21691 -- Abstract states, formal parameters and variables
21693 elsif Is_Entity_Name
(Dep_Item
) then
21695 -- Handle abstract views generated for limited with clauses
21697 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
21699 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
21701 -- An abstract state with visible null refinement matches
21702 -- null or Empty (special case).
21704 if Has_Null_Refinement
(Dep_Item_Id
)
21705 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
21707 Record_Item
(Dep_Item_Id
);
21710 -- An abstract state with visible non-null refinement
21711 -- matches one of its constituents.
21713 elsif Has_Non_Null_Refinement
(Dep_Item_Id
) then
21714 if Is_Entity_Name
(Ref_Item
) then
21715 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
21717 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
, E_Variable
)
21718 and then Present
(Encapsulating_State
(Ref_Item_Id
))
21719 and then Encapsulating_State
(Ref_Item_Id
) =
21722 Record_Item
(Dep_Item_Id
);
21727 -- An abstract state without a visible refinement matches
21730 elsif Is_Entity_Name
(Ref_Item
)
21731 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
21733 Record_Item
(Dep_Item_Id
);
21737 -- A formal parameter or a variable matches itself
21739 elsif Is_Entity_Name
(Ref_Item
)
21740 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
21742 Record_Item
(Dep_Item_Id
);
21752 procedure Record_Item
(Item_Id
: Entity_Id
) is
21754 if not Contains
(Matched_Items
, Item_Id
) then
21755 Add_Item
(Item_Id
, Matched_Items
);
21761 Clause_Matched
: Boolean := False;
21762 Dummy
: Boolean := False;
21763 Inputs_Match
: Boolean;
21764 Next_Ref_Clause
: Node_Id
;
21765 Outputs_Match
: Boolean;
21766 Ref_Clause
: Node_Id
;
21767 Ref_Input
: Node_Id
;
21768 Ref_Output
: Node_Id
;
21770 -- Start of processing for Check_Dependency_Clause
21773 -- Examine all refinement clauses and compare them against the
21774 -- dependence clause.
21776 Ref_Clause
:= First
(Refinements
);
21777 while Present
(Ref_Clause
) loop
21778 Next_Ref_Clause
:= Next
(Ref_Clause
);
21780 -- Obtain the attributes of the current refinement clause
21782 Ref_Input
:= Expression
(Ref_Clause
);
21783 Ref_Output
:= First
(Choices
(Ref_Clause
));
21785 -- The current refinement clause matches the dependence clause
21786 -- when both outputs match and both inputs match. See routine
21787 -- Match_Items for all possible conformance scenarios.
21789 -- Depends Dep_Output => Dep_Input
21793 -- Refined_Depends Ref_Output => Ref_Input
21796 (Dep_Item
=> Dep_Input
,
21797 Ref_Item
=> Ref_Input
,
21798 Matched
=> Inputs_Match
);
21801 (Dep_Item
=> Dep_Output
,
21802 Ref_Item
=> Ref_Output
,
21803 Matched
=> Outputs_Match
);
21805 -- An In_Out state clause may be matched against a refinement with
21806 -- a null input or null output as long as the non-null side of the
21807 -- relation contains a valid constituent of the In_Out_State.
21809 if Is_In_Out_State_Clause
then
21811 -- Depends => (State => State)
21812 -- Refined_Depends => (null => Constit) -- OK
21815 and then not Outputs_Match
21816 and then Nkind
(Ref_Output
) = N_Null
21818 Outputs_Match
:= True;
21821 -- Depends => (State => State)
21822 -- Refined_Depends => (Constit => null) -- OK
21824 if not Inputs_Match
21825 and then Outputs_Match
21826 and then Nkind
(Ref_Input
) = N_Null
21828 Inputs_Match
:= True;
21832 -- The current refinement clause is legally constructed following
21833 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
21834 -- the pool of candidates. The seach continues because a single
21835 -- dependence clause may have multiple matching refinements.
21837 if Inputs_Match
and then Outputs_Match
then
21838 Clause_Matched
:= True;
21839 Remove
(Ref_Clause
);
21842 Ref_Clause
:= Next_Ref_Clause
;
21845 -- Depending on the order or composition of refinement clauses, an
21846 -- In_Out state clause may not be directly refinable.
21848 -- Depends => ((Output, State) => (Input, State))
21849 -- Refined_State => (State => (Constit_1, Constit_2))
21850 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
21852 -- Matching normalized clause (State => State) fails because there is
21853 -- no direct refinement capable of satisfying this relation. Another
21854 -- similar case arises when clauses (Constit_1 => Input) and (Output
21855 -- => Constit_2) are matched first, leaving no candidates for clause
21856 -- (State => State). Both scenarios are legal as long as one of the
21857 -- previous clauses mentioned a valid constituent of State.
21859 if not Clause_Matched
21860 and then Is_In_Out_State_Clause
21862 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
21864 Clause_Matched
:= True;
21867 -- A clause where the input is an abstract state with visible null
21868 -- refinement is implicitly matched when the output has already been
21869 -- matched in a previous clause.
21871 -- Depends => (Output => State) -- implicitly OK
21872 -- Refined_State => (State => null)
21873 -- Refined_Depends => (Output => ...)
21875 if not Clause_Matched
21876 and then Is_Null_Refined_State
(Dep_Input
)
21877 and then Is_Entity_Name
(Dep_Output
)
21879 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
21881 Clause_Matched
:= True;
21884 -- A clause where the output is an abstract state with visible null
21885 -- refinement is implicitly matched when the input has already been
21886 -- matched in a previous clause.
21888 -- Depends => (State => Input) -- implicitly OK
21889 -- Refined_State => (State => null)
21890 -- Refined_Depends => (... => Input)
21892 if not Clause_Matched
21893 and then Is_Null_Refined_State
(Dep_Output
)
21894 and then Is_Entity_Name
(Dep_Input
)
21896 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
21898 Clause_Matched
:= True;
21901 -- At this point either all refinement clauses have been examined or
21902 -- pragma Refined_Depends contains a solitary null. Only an abstract
21903 -- state with null refinement can possibly match these cases.
21905 -- Depends => (State => null)
21906 -- Refined_State => (State => null)
21907 -- Refined_Depends => null -- OK
21909 if not Clause_Matched
then
21911 (Dep_Item
=> Dep_Input
,
21913 Matched
=> Inputs_Match
);
21916 (Dep_Item
=> Dep_Output
,
21918 Matched
=> Outputs_Match
);
21920 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
21923 -- If the contents of Refined_Depends are legal, then the current
21924 -- dependence clause should be satisfied either by an explicit match
21925 -- or by one of the special cases.
21927 if not Clause_Matched
then
21929 ("dependence clause of subprogram & has no matching refinement "
21930 & "in body", Dep_Clause
, Spec_Id
);
21932 end Check_Dependency_Clause
;
21934 -------------------------
21935 -- Check_Output_States --
21936 -------------------------
21938 procedure Check_Output_States
is
21939 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
21940 -- Determine whether all constituents of state State_Id with visible
21941 -- refinement are used as outputs in pragma Refined_Depends. Emit an
21942 -- error if this is not the case.
21944 -----------------------------
21945 -- Check_Constituent_Usage --
21946 -----------------------------
21948 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
21949 Constit_Elmt
: Elmt_Id
;
21950 Constit_Id
: Entity_Id
;
21951 Posted
: Boolean := False;
21954 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
21955 while Present
(Constit_Elmt
) loop
21956 Constit_Id
:= Node
(Constit_Elmt
);
21958 -- The constituent acts as an input (SPARK RM 7.2.5(3))
21960 if Present
(Body_Inputs
)
21961 and then Appears_In
(Body_Inputs
, Constit_Id
)
21963 Error_Msg_Name_1
:= Chars
(State_Id
);
21965 ("constituent & of state % must act as output in "
21966 & "dependence refinement", N
, Constit_Id
);
21968 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
21970 elsif No
(Body_Outputs
)
21971 or else not Appears_In
(Body_Outputs
, Constit_Id
)
21976 ("output state & must be replaced by all its "
21977 & "constituents in dependence refinement",
21982 ("\constituent & is missing in output list",
21986 Next_Elmt
(Constit_Elmt
);
21988 end Check_Constituent_Usage
;
21993 Item_Elmt
: Elmt_Id
;
21994 Item_Id
: Entity_Id
;
21996 -- Start of processing for Check_Output_States
21999 -- Inspect the outputs of pragma Depends looking for a state with a
22000 -- visible refinement.
22002 if Present
(Spec_Outputs
) then
22003 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
22004 while Present
(Item_Elmt
) loop
22005 Item
:= Node
(Item_Elmt
);
22007 -- Deal with the mixed nature of the input and output lists
22009 if Nkind
(Item
) = N_Defining_Identifier
then
22012 Item_Id
:= Available_View
(Entity_Of
(Item
));
22015 if Ekind
(Item_Id
) = E_Abstract_State
then
22017 -- The state acts as an input-output, skip it
22019 if Present
(Spec_Inputs
)
22020 and then Appears_In
(Spec_Inputs
, Item_Id
)
22024 -- Ensure that all of the constituents are utilized as
22025 -- outputs in pragma Refined_Depends.
22027 elsif Has_Non_Null_Refinement
(Item_Id
) then
22028 Check_Constituent_Usage
(Item_Id
);
22032 Next_Elmt
(Item_Elmt
);
22035 end Check_Output_States
;
22037 -----------------------
22038 -- Normalize_Clauses --
22039 -----------------------
22041 procedure Normalize_Clauses
(Clauses
: List_Id
) is
22042 procedure Normalize_Inputs
(Clause
: Node_Id
);
22043 -- Normalize clause Clause by creating multiple clauses for each
22044 -- input item of Clause. It is assumed that Clause has exactly one
22045 -- output. The transformation is as follows:
22047 -- Output => (Input_1, Input_2) -- original
22049 -- Output => Input_1 -- normalizations
22050 -- Output => Input_2
22052 procedure Normalize_Outputs
(Clause
: Node_Id
);
22053 -- Normalize clause Clause by creating multiple clause for each
22054 -- output item of Clause. The transformation is as follows:
22056 -- (Output_1, Output_2) => Input -- original
22058 -- Output_1 => Input -- normalization
22059 -- Output_2 => Input
22061 ----------------------
22062 -- Normalize_Inputs --
22063 ----------------------
22065 procedure Normalize_Inputs
(Clause
: Node_Id
) is
22066 Inputs
: constant Node_Id
:= Expression
(Clause
);
22067 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22068 Output
: constant List_Id
:= Choices
(Clause
);
22069 Last_Input
: Node_Id
;
22071 New_Clause
: Node_Id
;
22072 Next_Input
: Node_Id
;
22075 -- Normalization is performed only when the original clause has
22076 -- more than one input. Multiple inputs appear as an aggregate.
22078 if Nkind
(Inputs
) = N_Aggregate
then
22079 Last_Input
:= Last
(Expressions
(Inputs
));
22081 -- Create a new clause for each input
22083 Input
:= First
(Expressions
(Inputs
));
22084 while Present
(Input
) loop
22085 Next_Input
:= Next
(Input
);
22087 -- Unhook the current input from the original input list
22088 -- because it will be relocated to a new clause.
22092 -- Special processing for the last input. At this point the
22093 -- original aggregate has been stripped down to one element.
22094 -- Replace the aggregate by the element itself.
22096 if Input
= Last_Input
then
22097 Rewrite
(Inputs
, Input
);
22099 -- Generate a clause of the form:
22104 Make_Component_Association
(Loc
,
22105 Choices
=> New_Copy_List_Tree
(Output
),
22106 Expression
=> Input
);
22108 -- The new clause contains replicated content that has
22109 -- already been analyzed, mark the clause as analyzed.
22111 Set_Analyzed
(New_Clause
);
22112 Insert_After
(Clause
, New_Clause
);
22115 Input
:= Next_Input
;
22118 end Normalize_Inputs
;
22120 -----------------------
22121 -- Normalize_Outputs --
22122 -----------------------
22124 procedure Normalize_Outputs
(Clause
: Node_Id
) is
22125 Inputs
: constant Node_Id
:= Expression
(Clause
);
22126 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
22127 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
22128 Last_Output
: Node_Id
;
22129 New_Clause
: Node_Id
;
22130 Next_Output
: Node_Id
;
22134 -- Multiple outputs appear as an aggregate. Nothing to do when
22135 -- the clause has exactly one output.
22137 if Nkind
(Outputs
) = N_Aggregate
then
22138 Last_Output
:= Last
(Expressions
(Outputs
));
22140 -- Create a clause for each output. Note that each time a new
22141 -- clause is created, the original output list slowly shrinks
22142 -- until there is one item left.
22144 Output
:= First
(Expressions
(Outputs
));
22145 while Present
(Output
) loop
22146 Next_Output
:= Next
(Output
);
22148 -- Unhook the output from the original output list as it
22149 -- will be relocated to a new clause.
22153 -- Special processing for the last output. At this point
22154 -- the original aggregate has been stripped down to one
22155 -- element. Replace the aggregate by the element itself.
22157 if Output
= Last_Output
then
22158 Rewrite
(Outputs
, Output
);
22161 -- Generate a clause of the form:
22162 -- (Output => Inputs)
22165 Make_Component_Association
(Loc
,
22166 Choices
=> New_List
(Output
),
22167 Expression
=> New_Copy_Tree
(Inputs
));
22169 -- The new clause contains replicated content that has
22170 -- already been analyzed. There is not need to reanalyze
22173 Set_Analyzed
(New_Clause
);
22174 Insert_After
(Clause
, New_Clause
);
22177 Output
:= Next_Output
;
22180 end Normalize_Outputs
;
22186 -- Start of processing for Normalize_Clauses
22189 Clause
:= First
(Clauses
);
22190 while Present
(Clause
) loop
22191 Normalize_Outputs
(Clause
);
22195 Clause
:= First
(Clauses
);
22196 while Present
(Clause
) loop
22197 Normalize_Inputs
(Clause
);
22200 end Normalize_Clauses
;
22202 --------------------------
22203 -- Report_Extra_Clauses --
22204 --------------------------
22206 procedure Report_Extra_Clauses
is
22210 if Present
(Refinements
) then
22211 Clause
:= First
(Refinements
);
22212 while Present
(Clause
) loop
22214 -- Do not complain about a null input refinement, since a null
22215 -- input legitimately matches anything.
22217 if Nkind
(Clause
) /= N_Component_Association
22218 or else Nkind
(Expression
(Clause
)) /= N_Null
22221 ("unmatched or extra clause in dependence refinement",
22228 end Report_Extra_Clauses
;
22232 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
22233 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
22234 Errors
: constant Nat
:= Serious_Errors_Detected
;
22235 Refs
: constant Node_Id
:= Expression
(Get_Argument
(N
));
22240 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
22243 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
22244 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
22246 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
22249 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
22251 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
22252 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
22254 if No
(Depends
) then
22256 ("useless refinement, declaration of subprogram & lacks aspect or "
22257 & "pragma Depends", N
, Spec_Id
);
22261 Deps
:= Expression
(Get_Argument
(Depends
));
22263 -- A null dependency relation renders the refinement useless because it
22264 -- cannot possibly mention abstract states with visible refinement. Note
22265 -- that the inverse is not true as states may be refined to null
22266 -- (SPARK RM 7.2.5(2)).
22268 if Nkind
(Deps
) = N_Null
then
22270 ("useless refinement, subprogram & does not depend on abstract "
22271 & "state with visible refinement", N
, Spec_Id
);
22275 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
22276 -- This ensures that the categorization of all refined dependency items
22277 -- is consistent with their role.
22279 Analyze_Depends_In_Decl_Part
(N
);
22281 -- Do not match dependencies against refinements if Refined_Depends is
22282 -- illegal to avoid emitting misleading error.
22284 if Serious_Errors_Detected
= Errors
then
22286 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
22287 -- the inputs and outputs of the subprogram spec and body to verify
22288 -- the use of states with visible refinement and their constituents.
22290 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
22291 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
22293 Collect_Subprogram_Inputs_Outputs
22294 (Subp_Id
=> Spec_Id
,
22295 Synthesize
=> True,
22296 Subp_Inputs
=> Spec_Inputs
,
22297 Subp_Outputs
=> Spec_Outputs
,
22298 Global_Seen
=> Dummy
);
22300 Collect_Subprogram_Inputs_Outputs
22301 (Subp_Id
=> Body_Id
,
22302 Synthesize
=> True,
22303 Subp_Inputs
=> Body_Inputs
,
22304 Subp_Outputs
=> Body_Outputs
,
22305 Global_Seen
=> Dummy
);
22307 -- For an output state with a visible refinement, ensure that all
22308 -- constituents appear as outputs in the dependency refinement.
22310 Check_Output_States
;
22313 -- Matching is disabled in ASIS because clauses are not normalized as
22314 -- this is a tree altering activity similar to expansion.
22320 -- Multiple dependency clauses appear as component associations of an
22321 -- aggregate. Note that the clauses are copied because the algorithm
22322 -- modifies them and this should not be visible in Depends.
22324 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
22325 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
22326 Normalize_Clauses
(Dependencies
);
22328 if Nkind
(Refs
) = N_Null
then
22329 Refinements
:= No_List
;
22331 -- Multiple dependency clauses appear as component associations of an
22332 -- aggregate. Note that the clauses are copied because the algorithm
22333 -- modifies them and this should not be visible in Refined_Depends.
22335 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
22336 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
22337 Normalize_Clauses
(Refinements
);
22340 -- At this point the clauses of pragmas Depends and Refined_Depends
22341 -- have been normalized into simple dependencies between one output
22342 -- and one input. Examine all clauses of pragma Depends looking for
22343 -- matching clauses in pragma Refined_Depends.
22345 Clause
:= First
(Dependencies
);
22346 while Present
(Clause
) loop
22347 Check_Dependency_Clause
(Clause
);
22351 if Serious_Errors_Detected
= Errors
then
22352 Report_Extra_Clauses
;
22355 end Analyze_Refined_Depends_In_Decl_Part
;
22357 -----------------------------------------
22358 -- Analyze_Refined_Global_In_Decl_Part --
22359 -----------------------------------------
22361 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
22363 -- The corresponding Global pragma
22365 Has_In_State
: Boolean := False;
22366 Has_In_Out_State
: Boolean := False;
22367 Has_Out_State
: Boolean := False;
22368 Has_Proof_In_State
: Boolean := False;
22369 -- These flags are set when the corresponding Global pragma has a state
22370 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
22373 Has_Null_State
: Boolean := False;
22374 -- This flag is set when the corresponding Global pragma has at least
22375 -- one state with a null refinement.
22377 In_Constits
: Elist_Id
:= No_Elist
;
22378 In_Out_Constits
: Elist_Id
:= No_Elist
;
22379 Out_Constits
: Elist_Id
:= No_Elist
;
22380 Proof_In_Constits
: Elist_Id
:= No_Elist
;
22381 -- These lists contain the entities of all Input, In_Out, Output and
22382 -- Proof_In constituents that appear in Refined_Global and participate
22383 -- in state refinement.
22385 In_Items
: Elist_Id
:= No_Elist
;
22386 In_Out_Items
: Elist_Id
:= No_Elist
;
22387 Out_Items
: Elist_Id
:= No_Elist
;
22388 Proof_In_Items
: Elist_Id
:= No_Elist
;
22389 -- These list contain the entities of all Input, In_Out, Output and
22390 -- Proof_In items defined in the corresponding Global pragma.
22392 procedure Check_In_Out_States
;
22393 -- Determine whether the corresponding Global pragma mentions In_Out
22394 -- states with visible refinement and if so, ensure that one of the
22395 -- following completions apply to the constituents of the state:
22396 -- 1) there is at least one constituent of mode In_Out
22397 -- 2) there is at least one Input and one Output constituent
22398 -- 3) not all constituents are present and one of them is of mode
22400 -- This routine may remove elements from In_Constits, In_Out_Constits,
22401 -- Out_Constits and Proof_In_Constits.
22403 procedure Check_Input_States
;
22404 -- Determine whether the corresponding Global pragma mentions Input
22405 -- states with visible refinement and if so, ensure that at least one of
22406 -- its constituents appears as an Input item in Refined_Global.
22407 -- This routine may remove elements from In_Constits, In_Out_Constits,
22408 -- Out_Constits and Proof_In_Constits.
22410 procedure Check_Output_States
;
22411 -- Determine whether the corresponding Global pragma mentions Output
22412 -- states with visible refinement and if so, ensure that all of its
22413 -- constituents appear as Output items in Refined_Global.
22414 -- This routine may remove elements from In_Constits, In_Out_Constits,
22415 -- Out_Constits and Proof_In_Constits.
22417 procedure Check_Proof_In_States
;
22418 -- Determine whether the corresponding Global pragma mentions Proof_In
22419 -- states with visible refinement and if so, ensure that at least one of
22420 -- its constituents appears as a Proof_In item in Refined_Global.
22421 -- This routine may remove elements from In_Constits, In_Out_Constits,
22422 -- Out_Constits and Proof_In_Constits.
22424 procedure Check_Refined_Global_List
22426 Global_Mode
: Name_Id
:= Name_Input
);
22427 -- Verify the legality of a single global list declaration. Global_Mode
22428 -- denotes the current mode in effect.
22430 procedure Collect_Global_Items
(Prag
: Node_Id
);
22431 -- Gather all input, in out, output and Proof_In items of pragma Prag
22432 -- in lists In_Items, In_Out_Items, Out_Items and Proof_In_Items. Flags
22433 -- Has_In_State, Has_In_Out_State, Has_Out_State and Has_Proof_In_State
22434 -- are set when there is at least one abstract state with visible
22435 -- refinement available in the corresponding mode. Flag Has_Null_State
22436 -- is set when at least state has a null refinement.
22438 function Present_Then_Remove
22440 Item
: Entity_Id
) return Boolean;
22441 -- Search List for a particular entity Item. If Item has been found,
22442 -- remove it from List. This routine is used to strip lists In_Constits,
22443 -- In_Out_Constits and Out_Constits of valid constituents.
22445 procedure Report_Extra_Constituents
;
22446 -- Emit an error for each constituent found in lists In_Constits,
22447 -- In_Out_Constits and Out_Constits.
22449 -------------------------
22450 -- Check_In_Out_States --
22451 -------------------------
22453 procedure Check_In_Out_States
is
22454 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22455 -- Determine whether one of the following coverage scenarios is in
22457 -- 1) there is at least one constituent of mode In_Out
22458 -- 2) there is at least one Input and one Output constituent
22459 -- 3) not all constituents are present and one of them is of mode
22461 -- If this is not the case, emit an error.
22463 -----------------------------
22464 -- Check_Constituent_Usage --
22465 -----------------------------
22467 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22468 Constit_Elmt
: Elmt_Id
;
22469 Constit_Id
: Entity_Id
;
22470 Has_Missing
: Boolean := False;
22471 In_Out_Seen
: Boolean := False;
22472 In_Seen
: Boolean := False;
22473 Out_Seen
: Boolean := False;
22476 -- Process all the constituents of the state and note their modes
22477 -- within the global refinement.
22479 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22480 while Present
(Constit_Elmt
) loop
22481 Constit_Id
:= Node
(Constit_Elmt
);
22483 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22486 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
22487 In_Out_Seen
:= True;
22489 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22492 -- A Proof_In constituent cannot participate in the completion
22493 -- of an Output state (SPARK RM 7.2.4(5)).
22495 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22496 Error_Msg_Name_1
:= Chars
(State_Id
);
22498 ("constituent & of state % must have mode Input, In_Out "
22499 & "or Output in global refinement",
22503 Has_Missing
:= True;
22506 Next_Elmt
(Constit_Elmt
);
22509 -- A single In_Out constituent is a valid completion
22511 if In_Out_Seen
then
22514 -- A pair of one Input and one Output constituent is a valid
22517 elsif In_Seen
and then Out_Seen
then
22520 -- A single Output constituent is a valid completion only when
22521 -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
22523 elsif Has_Missing
and then Out_Seen
then
22528 ("global refinement of state & redefines the mode of its "
22529 & "constituents", N
, State_Id
);
22531 end Check_Constituent_Usage
;
22535 Item_Elmt
: Elmt_Id
;
22536 Item_Id
: Entity_Id
;
22538 -- Start of processing for Check_In_Out_States
22541 -- Inspect the In_Out items of the corresponding Global pragma
22542 -- looking for a state with a visible refinement.
22544 if Has_In_Out_State
and then Present
(In_Out_Items
) then
22545 Item_Elmt
:= First_Elmt
(In_Out_Items
);
22546 while Present
(Item_Elmt
) loop
22547 Item_Id
:= Node
(Item_Elmt
);
22549 -- Ensure that one of the three coverage variants is satisfied
22551 if Ekind
(Item_Id
) = E_Abstract_State
22552 and then Has_Non_Null_Refinement
(Item_Id
)
22554 Check_Constituent_Usage
(Item_Id
);
22557 Next_Elmt
(Item_Elmt
);
22560 end Check_In_Out_States
;
22562 ------------------------
22563 -- Check_Input_States --
22564 ------------------------
22566 procedure Check_Input_States
is
22567 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22568 -- Determine whether at least one constituent of state State_Id with
22569 -- visible refinement is used and has mode Input. Ensure that the
22570 -- remaining constituents do not have In_Out, Output or Proof_In
22573 -----------------------------
22574 -- Check_Constituent_Usage --
22575 -----------------------------
22577 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22578 Constit_Elmt
: Elmt_Id
;
22579 Constit_Id
: Entity_Id
;
22580 In_Seen
: Boolean := False;
22583 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22584 while Present
(Constit_Elmt
) loop
22585 Constit_Id
:= Node
(Constit_Elmt
);
22587 -- At least one of the constituents appears as an Input
22589 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
22592 -- The constituent appears in the global refinement, but has
22593 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
22595 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22596 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22597 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22599 Error_Msg_Name_1
:= Chars
(State_Id
);
22601 ("constituent & of state % must have mode Input in global "
22602 & "refinement", N
, Constit_Id
);
22605 Next_Elmt
(Constit_Elmt
);
22608 -- Not one of the constituents appeared as Input
22610 if not In_Seen
then
22612 ("global refinement of state & must include at least one "
22613 & "constituent of mode Input", N
, State_Id
);
22615 end Check_Constituent_Usage
;
22619 Item_Elmt
: Elmt_Id
;
22620 Item_Id
: Entity_Id
;
22622 -- Start of processing for Check_Input_States
22625 -- Inspect the Input items of the corresponding Global pragma
22626 -- looking for a state with a visible refinement.
22628 if Has_In_State
and then Present
(In_Items
) then
22629 Item_Elmt
:= First_Elmt
(In_Items
);
22630 while Present
(Item_Elmt
) loop
22631 Item_Id
:= Node
(Item_Elmt
);
22633 -- Ensure that at least one of the constituents is utilized and
22634 -- is of mode Input.
22636 if Ekind
(Item_Id
) = E_Abstract_State
22637 and then Has_Non_Null_Refinement
(Item_Id
)
22639 Check_Constituent_Usage
(Item_Id
);
22642 Next_Elmt
(Item_Elmt
);
22645 end Check_Input_States
;
22647 -------------------------
22648 -- Check_Output_States --
22649 -------------------------
22651 procedure Check_Output_States
is
22652 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22653 -- Determine whether all constituents of state State_Id with visible
22654 -- refinement are used and have mode Output. Emit an error if this is
22657 -----------------------------
22658 -- Check_Constituent_Usage --
22659 -----------------------------
22661 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22662 Constit_Elmt
: Elmt_Id
;
22663 Constit_Id
: Entity_Id
;
22664 Posted
: Boolean := False;
22667 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22668 while Present
(Constit_Elmt
) loop
22669 Constit_Id
:= Node
(Constit_Elmt
);
22671 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
22674 -- The constituent appears in the global refinement, but has
22675 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
22677 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
22678 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22679 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
22681 Error_Msg_Name_1
:= Chars
(State_Id
);
22683 ("constituent & of state % must have mode Output in "
22684 & "global refinement", N
, Constit_Id
);
22686 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
22692 ("output state & must be replaced by all its "
22693 & "constituents in global refinement", N
, State_Id
);
22697 ("\constituent & is missing in output list",
22701 Next_Elmt
(Constit_Elmt
);
22703 end Check_Constituent_Usage
;
22707 Item_Elmt
: Elmt_Id
;
22708 Item_Id
: Entity_Id
;
22710 -- Start of processing for Check_Output_States
22713 -- Inspect the Output items of the corresponding Global pragma
22714 -- looking for a state with a visible refinement.
22716 if Has_Out_State
and then Present
(Out_Items
) then
22717 Item_Elmt
:= First_Elmt
(Out_Items
);
22718 while Present
(Item_Elmt
) loop
22719 Item_Id
:= Node
(Item_Elmt
);
22721 -- Ensure that all of the constituents are utilized and they
22722 -- have mode Output.
22724 if Ekind
(Item_Id
) = E_Abstract_State
22725 and then Has_Non_Null_Refinement
(Item_Id
)
22727 Check_Constituent_Usage
(Item_Id
);
22730 Next_Elmt
(Item_Elmt
);
22733 end Check_Output_States
;
22735 ---------------------------
22736 -- Check_Proof_In_States --
22737 ---------------------------
22739 procedure Check_Proof_In_States
is
22740 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
22741 -- Determine whether at least one constituent of state State_Id with
22742 -- visible refinement is used and has mode Proof_In. Ensure that the
22743 -- remaining constituents do not have Input, In_Out or Output modes.
22745 -----------------------------
22746 -- Check_Constituent_Usage --
22747 -----------------------------
22749 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
22750 Constit_Elmt
: Elmt_Id
;
22751 Constit_Id
: Entity_Id
;
22752 Proof_In_Seen
: Boolean := False;
22755 Constit_Elmt
:= First_Elmt
(Refinement_Constituents
(State_Id
));
22756 while Present
(Constit_Elmt
) loop
22757 Constit_Id
:= Node
(Constit_Elmt
);
22759 -- At least one of the constituents appears as Proof_In
22761 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
22762 Proof_In_Seen
:= True;
22764 -- The constituent appears in the global refinement, but has
22765 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
22767 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
22768 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
22769 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
22771 Error_Msg_Name_1
:= Chars
(State_Id
);
22773 ("constituent & of state % must have mode Proof_In in "
22774 & "global refinement", N
, Constit_Id
);
22777 Next_Elmt
(Constit_Elmt
);
22780 -- Not one of the constituents appeared as Proof_In
22782 if not Proof_In_Seen
then
22784 ("global refinement of state & must include at least one "
22785 & "constituent of mode Proof_In", N
, State_Id
);
22787 end Check_Constituent_Usage
;
22791 Item_Elmt
: Elmt_Id
;
22792 Item_Id
: Entity_Id
;
22794 -- Start of processing for Check_Proof_In_States
22797 -- Inspect the Proof_In items of the corresponding Global pragma
22798 -- looking for a state with a visible refinement.
22800 if Has_Proof_In_State
and then Present
(Proof_In_Items
) then
22801 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
22802 while Present
(Item_Elmt
) loop
22803 Item_Id
:= Node
(Item_Elmt
);
22805 -- Ensure that at least one of the constituents is utilized and
22806 -- is of mode Proof_In
22808 if Ekind
(Item_Id
) = E_Abstract_State
22809 and then Has_Non_Null_Refinement
(Item_Id
)
22811 Check_Constituent_Usage
(Item_Id
);
22814 Next_Elmt
(Item_Elmt
);
22817 end Check_Proof_In_States
;
22819 -------------------------------
22820 -- Check_Refined_Global_List --
22821 -------------------------------
22823 procedure Check_Refined_Global_List
22825 Global_Mode
: Name_Id
:= Name_Input
)
22827 procedure Check_Refined_Global_Item
22829 Global_Mode
: Name_Id
);
22830 -- Verify the legality of a single global item declaration. Parameter
22831 -- Global_Mode denotes the current mode in effect.
22833 -------------------------------
22834 -- Check_Refined_Global_Item --
22835 -------------------------------
22837 procedure Check_Refined_Global_Item
22839 Global_Mode
: Name_Id
)
22841 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
22843 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
22844 -- Issue a common error message for all mode mismatches. Expect
22845 -- denotes the expected mode.
22847 -----------------------------
22848 -- Inconsistent_Mode_Error --
22849 -----------------------------
22851 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
22854 ("global item & has inconsistent modes", Item
, Item_Id
);
22856 Error_Msg_Name_1
:= Global_Mode
;
22857 Error_Msg_Name_2
:= Expect
;
22858 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
22859 end Inconsistent_Mode_Error
;
22861 -- Start of processing for Check_Refined_Global_Item
22864 -- When the state or variable acts as a constituent of another
22865 -- state with a visible refinement, collect it for the state
22866 -- completeness checks performed later on.
22868 if Present
(Encapsulating_State
(Item_Id
))
22869 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
22871 if Global_Mode
= Name_Input
then
22872 Add_Item
(Item_Id
, In_Constits
);
22874 elsif Global_Mode
= Name_In_Out
then
22875 Add_Item
(Item_Id
, In_Out_Constits
);
22877 elsif Global_Mode
= Name_Output
then
22878 Add_Item
(Item_Id
, Out_Constits
);
22880 elsif Global_Mode
= Name_Proof_In
then
22881 Add_Item
(Item_Id
, Proof_In_Constits
);
22884 -- When not a constituent, ensure that both occurrences of the
22885 -- item in pragmas Global and Refined_Global match.
22887 elsif Contains
(In_Items
, Item_Id
) then
22888 if Global_Mode
/= Name_Input
then
22889 Inconsistent_Mode_Error
(Name_Input
);
22892 elsif Contains
(In_Out_Items
, Item_Id
) then
22893 if Global_Mode
/= Name_In_Out
then
22894 Inconsistent_Mode_Error
(Name_In_Out
);
22897 elsif Contains
(Out_Items
, Item_Id
) then
22898 if Global_Mode
/= Name_Output
then
22899 Inconsistent_Mode_Error
(Name_Output
);
22902 elsif Contains
(Proof_In_Items
, Item_Id
) then
22905 -- The item does not appear in the corresponding Global pragma,
22906 -- it must be an extra (SPARK RM 7.2.4(3)).
22909 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
22911 end Check_Refined_Global_Item
;
22917 -- Start of processing for Check_Refined_Global_List
22920 if Nkind
(List
) = N_Null
then
22923 -- Single global item declaration
22925 elsif Nkind_In
(List
, N_Expanded_Name
,
22927 N_Selected_Component
)
22929 Check_Refined_Global_Item
(List
, Global_Mode
);
22931 -- Simple global list or moded global list declaration
22933 elsif Nkind
(List
) = N_Aggregate
then
22935 -- The declaration of a simple global list appear as a collection
22938 if Present
(Expressions
(List
)) then
22939 Item
:= First
(Expressions
(List
));
22940 while Present
(Item
) loop
22941 Check_Refined_Global_Item
(Item
, Global_Mode
);
22946 -- The declaration of a moded global list appears as a collection
22947 -- of component associations where individual choices denote
22950 elsif Present
(Component_Associations
(List
)) then
22951 Item
:= First
(Component_Associations
(List
));
22952 while Present
(Item
) loop
22953 Check_Refined_Global_List
22954 (List
=> Expression
(Item
),
22955 Global_Mode
=> Chars
(First
(Choices
(Item
))));
22963 raise Program_Error
;
22969 raise Program_Error
;
22971 end Check_Refined_Global_List
;
22973 --------------------------
22974 -- Collect_Global_Items --
22975 --------------------------
22977 procedure Collect_Global_Items
(Prag
: Node_Id
) is
22978 procedure Process_Global_List
22980 Mode
: Name_Id
:= Name_Input
);
22981 -- Collect all items housed in a global list. Formal Mode denotes the
22982 -- current mode in effect.
22984 -------------------------
22985 -- Process_Global_List --
22986 -------------------------
22988 procedure Process_Global_List
22990 Mode
: Name_Id
:= Name_Input
)
22992 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
22993 -- Add a single item to the appropriate list. Formal Mode denotes
22994 -- the current mode in effect.
22996 -------------------------
22997 -- Process_Global_Item --
22998 -------------------------
23000 procedure Process_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
23001 Item_Id
: constant Entity_Id
:=
23002 Available_View
(Entity_Of
(Item
));
23003 -- The above handles abstract views of variables and states
23004 -- built for limited with clauses.
23007 -- Signal that the global list contains at least one abstract
23008 -- state with a visible refinement. Note that the refinement
23009 -- may be null in which case there are no constituents.
23011 if Ekind
(Item_Id
) = E_Abstract_State
then
23012 if Has_Null_Refinement
(Item_Id
) then
23013 Has_Null_State
:= True;
23015 elsif Has_Non_Null_Refinement
(Item_Id
) then
23016 if Mode
= Name_Input
then
23017 Has_In_State
:= True;
23018 elsif Mode
= Name_In_Out
then
23019 Has_In_Out_State
:= True;
23020 elsif Mode
= Name_Output
then
23021 Has_Out_State
:= True;
23022 elsif Mode
= Name_Proof_In
then
23023 Has_Proof_In_State
:= True;
23028 -- Add the item to the proper list
23030 if Mode
= Name_Input
then
23031 Add_Item
(Item_Id
, In_Items
);
23032 elsif Mode
= Name_In_Out
then
23033 Add_Item
(Item_Id
, In_Out_Items
);
23034 elsif Mode
= Name_Output
then
23035 Add_Item
(Item_Id
, Out_Items
);
23036 elsif Mode
= Name_Proof_In
then
23037 Add_Item
(Item_Id
, Proof_In_Items
);
23039 end Process_Global_Item
;
23045 -- Start of processing for Process_Global_List
23048 if Nkind
(List
) = N_Null
then
23051 -- Single global item declaration
23053 elsif Nkind_In
(List
, N_Expanded_Name
,
23055 N_Selected_Component
)
23057 Process_Global_Item
(List
, Mode
);
23059 -- Single global list or moded global list declaration
23061 elsif Nkind
(List
) = N_Aggregate
then
23063 -- The declaration of a simple global list appear as a
23064 -- collection of expressions.
23066 if Present
(Expressions
(List
)) then
23067 Item
:= First
(Expressions
(List
));
23068 while Present
(Item
) loop
23069 Process_Global_Item
(Item
, Mode
);
23073 -- The declaration of a moded global list appears as a
23074 -- collection of component associations where individual
23075 -- choices denote mode.
23077 elsif Present
(Component_Associations
(List
)) then
23078 Item
:= First
(Component_Associations
(List
));
23079 while Present
(Item
) loop
23080 Process_Global_List
23081 (List
=> Expression
(Item
),
23082 Mode
=> Chars
(First
(Choices
(Item
))));
23090 raise Program_Error
;
23093 -- To accomodate partial decoration of disabled SPARK features,
23094 -- this routine may be called with illegal input. If this is the
23095 -- case, do not raise Program_Error.
23100 end Process_Global_List
;
23102 -- Start of processing for Collect_Global_Items
23105 Process_Global_List
(Expression
(Get_Argument
(Prag
)));
23106 end Collect_Global_Items
;
23108 -------------------------
23109 -- Present_Then_Remove --
23110 -------------------------
23112 function Present_Then_Remove
23114 Item
: Entity_Id
) return Boolean
23119 if Present
(List
) then
23120 Elmt
:= First_Elmt
(List
);
23121 while Present
(Elmt
) loop
23122 if Node
(Elmt
) = Item
then
23123 Remove_Elmt
(List
, Elmt
);
23132 end Present_Then_Remove
;
23134 -------------------------------
23135 -- Report_Extra_Constituents --
23136 -------------------------------
23138 procedure Report_Extra_Constituents
is
23139 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
23140 -- Emit an error for every element of List
23142 ---------------------------------------
23143 -- Report_Extra_Constituents_In_List --
23144 ---------------------------------------
23146 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
23147 Constit_Elmt
: Elmt_Id
;
23150 if Present
(List
) then
23151 Constit_Elmt
:= First_Elmt
(List
);
23152 while Present
(Constit_Elmt
) loop
23153 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
23154 Next_Elmt
(Constit_Elmt
);
23157 end Report_Extra_Constituents_In_List
;
23159 -- Start of processing for Report_Extra_Constituents
23162 Report_Extra_Constituents_In_List
(In_Constits
);
23163 Report_Extra_Constituents_In_List
(In_Out_Constits
);
23164 Report_Extra_Constituents_In_List
(Out_Constits
);
23165 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
23166 end Report_Extra_Constituents
;
23170 Body_Decl
: constant Node_Id
:= Find_Related_Subprogram_Or_Body
(N
);
23171 Errors
: constant Nat
:= Serious_Errors_Detected
;
23172 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
));
23173 Spec_Id
: Entity_Id
;
23175 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
23178 if Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
23179 Spec_Id
:= Corresponding_Spec_Of_Stub
(Body_Decl
);
23181 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
23184 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
23186 -- The subprogram declaration lacks pragma Global. This renders
23187 -- Refined_Global useless as there is nothing to refine.
23189 if No
(Global
) then
23191 ("useless refinement, declaration of subprogram & lacks aspect or "
23192 & "pragma Global", N
, Spec_Id
);
23196 -- Extract all relevant items from the corresponding Global pragma
23198 Collect_Global_Items
(Global
);
23200 -- Corresponding Global pragma must mention at least one state witha
23201 -- visible refinement at the point Refined_Global is processed. States
23202 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)).
23204 if not Has_In_State
23205 and then not Has_In_Out_State
23206 and then not Has_Out_State
23207 and then not Has_Proof_In_State
23208 and then not Has_Null_State
23211 ("useless refinement, subprogram & does not depend on abstract "
23212 & "state with visible refinement", N
, Spec_Id
);
23216 -- The global refinement of inputs and outputs cannot be null when the
23217 -- corresponding Global pragma contains at least one item except in the
23218 -- case where we have states with null refinements.
23220 if Nkind
(Items
) = N_Null
23222 (Present
(In_Items
)
23223 or else Present
(In_Out_Items
)
23224 or else Present
(Out_Items
)
23225 or else Present
(Proof_In_Items
))
23226 and then not Has_Null_State
23229 ("refinement cannot be null, subprogram & has global items",
23234 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
23235 -- This ensures that the categorization of all refined global items is
23236 -- consistent with their role.
23238 Analyze_Global_In_Decl_Part
(N
);
23240 -- Perform all refinement checks with respect to completeness and mode
23243 if Serious_Errors_Detected
= Errors
then
23244 Check_Refined_Global_List
(Items
);
23247 -- For Input states with visible refinement, at least one constituent
23248 -- must be used as an Input in the global refinement.
23250 if Serious_Errors_Detected
= Errors
then
23251 Check_Input_States
;
23254 -- Verify all possible completion variants for In_Out states with
23255 -- visible refinement.
23257 if Serious_Errors_Detected
= Errors
then
23258 Check_In_Out_States
;
23261 -- For Output states with visible refinement, all constituents must be
23262 -- used as Outputs in the global refinement.
23264 if Serious_Errors_Detected
= Errors
then
23265 Check_Output_States
;
23268 -- For Proof_In states with visible refinement, at least one constituent
23269 -- must be used as Proof_In in the global refinement.
23271 if Serious_Errors_Detected
= Errors
then
23272 Check_Proof_In_States
;
23275 -- Emit errors for all constituents that belong to other states with
23276 -- visible refinement that do not appear in Global.
23278 if Serious_Errors_Detected
= Errors
then
23279 Report_Extra_Constituents
;
23281 end Analyze_Refined_Global_In_Decl_Part
;
23283 ----------------------------------------
23284 -- Analyze_Refined_State_In_Decl_Part --
23285 ----------------------------------------
23287 procedure Analyze_Refined_State_In_Decl_Part
(N
: Node_Id
) is
23288 Available_States
: Elist_Id
:= No_Elist
;
23289 -- A list of all abstract states defined in the package declaration that
23290 -- are available for refinement. The list is used to report unrefined
23293 Body_Id
: Entity_Id
;
23294 -- The body entity of the package subject to pragma Refined_State
23296 Body_States
: Elist_Id
:= No_Elist
;
23297 -- A list of all hidden states that appear in the body of the related
23298 -- package. The list is used to report unused hidden states.
23300 Constituents_Seen
: Elist_Id
:= No_Elist
;
23301 -- A list that contains all constituents processed so far. The list is
23302 -- used to detect multiple uses of the same constituent.
23304 Refined_States_Seen
: Elist_Id
:= No_Elist
;
23305 -- A list that contains all refined states processed so far. The list is
23306 -- used to detect duplicate refinements.
23308 Spec_Id
: Entity_Id
;
23309 -- The spec entity of the package subject to pragma Refined_State
23311 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
23312 -- Perform full analysis of a single refinement clause
23314 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
;
23315 -- Gather the entities of all abstract states and variables declared in
23316 -- the body state space of package Pack_Id.
23318 procedure Report_Unrefined_States
(States
: Elist_Id
);
23319 -- Emit errors for all unrefined abstract states found in list States
23321 procedure Report_Unused_States
(States
: Elist_Id
);
23322 -- Emit errors for all unused states found in list States
23324 -------------------------------
23325 -- Analyze_Refinement_Clause --
23326 -------------------------------
23328 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
23329 AR_Constit
: Entity_Id
:= Empty
;
23330 AW_Constit
: Entity_Id
:= Empty
;
23331 ER_Constit
: Entity_Id
:= Empty
;
23332 EW_Constit
: Entity_Id
:= Empty
;
23333 -- The entities of external constituents that contain one of the
23334 -- following enabled properties: Async_Readers, Async_Writers,
23335 -- Effective_Reads and Effective_Writes.
23337 External_Constit_Seen
: Boolean := False;
23338 -- Flag used to mark when at least one external constituent is part
23339 -- of the state refinement.
23341 Non_Null_Seen
: Boolean := False;
23342 Null_Seen
: Boolean := False;
23343 -- Flags used to detect multiple uses of null in a single clause or a
23344 -- mixture of null and non-null constituents.
23346 Part_Of_Constits
: Elist_Id
:= No_Elist
;
23347 -- A list of all candidate constituents subject to indicator Part_Of
23348 -- where the encapsulating state is the current state.
23351 State_Id
: Entity_Id
;
23352 -- The current state being refined
23354 procedure Analyze_Constituent
(Constit
: Node_Id
);
23355 -- Perform full analysis of a single constituent
23357 procedure Check_External_Property
23358 (Prop_Nam
: Name_Id
;
23360 Constit
: Entity_Id
);
23361 -- Determine whether a property denoted by name Prop_Nam is present
23362 -- in both the refined state and constituent Constit. Flag Enabled
23363 -- should be set when the property applies to the refined state. If
23364 -- this is not the case, emit an error message.
23366 procedure Check_Matching_State
;
23367 -- Determine whether the state being refined appears in list
23368 -- Available_States. Emit an error when attempting to re-refine the
23369 -- state or when the state is not defined in the package declaration,
23370 -- otherwise remove the state from Available_States.
23372 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
23373 -- Emit errors for all unused Part_Of constituents in list Constits
23375 -------------------------
23376 -- Analyze_Constituent --
23377 -------------------------
23379 procedure Analyze_Constituent
(Constit
: Node_Id
) is
23380 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
);
23381 -- Verify that the constituent Constit_Id is a Ghost entity if the
23382 -- abstract state being refined is also Ghost. If this is the case
23383 -- verify that the Ghost policy in effect at the point of state
23384 -- and constituent declaration is the same.
23386 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
);
23387 -- Determine whether constituent Constit denoted by its entity
23388 -- Constit_Id appears in Hidden_States. Emit an error when the
23389 -- constituent is not a valid hidden state of the related package
23390 -- or when it is used more than once. Otherwise remove the
23391 -- constituent from Hidden_States.
23393 --------------------------------
23394 -- Check_Matching_Constituent --
23395 --------------------------------
23397 procedure Check_Matching_Constituent
(Constit_Id
: Entity_Id
) is
23398 procedure Collect_Constituent
;
23399 -- Add constituent Constit_Id to the refinements of State_Id
23401 -------------------------
23402 -- Collect_Constituent --
23403 -------------------------
23405 procedure Collect_Constituent
is
23407 -- Add the constituent to the list of processed items to aid
23408 -- with the detection of duplicates.
23410 Add_Item
(Constit_Id
, Constituents_Seen
);
23412 -- Collect the constituent in the list of refinement items
23413 -- and establish a relation between the refined state and
23416 Append_Elmt
(Constit_Id
, Refinement_Constituents
(State_Id
));
23417 Set_Encapsulating_State
(Constit_Id
, State_Id
);
23419 -- The state has at least one legal constituent, mark the
23420 -- start of the refinement region. The region ends when the
23421 -- body declarations end (see routine Analyze_Declarations).
23423 Set_Has_Visible_Refinement
(State_Id
);
23425 -- When the constituent is external, save its relevant
23426 -- property for further checks.
23428 if Async_Readers_Enabled
(Constit_Id
) then
23429 AR_Constit
:= Constit_Id
;
23430 External_Constit_Seen
:= True;
23433 if Async_Writers_Enabled
(Constit_Id
) then
23434 AW_Constit
:= Constit_Id
;
23435 External_Constit_Seen
:= True;
23438 if Effective_Reads_Enabled
(Constit_Id
) then
23439 ER_Constit
:= Constit_Id
;
23440 External_Constit_Seen
:= True;
23443 if Effective_Writes_Enabled
(Constit_Id
) then
23444 EW_Constit
:= Constit_Id
;
23445 External_Constit_Seen
:= True;
23447 end Collect_Constituent
;
23451 State_Elmt
: Elmt_Id
;
23453 -- Start of processing for Check_Matching_Constituent
23456 -- Detect a duplicate use of a constituent
23458 if Contains
(Constituents_Seen
, Constit_Id
) then
23460 ("duplicate use of constituent &", Constit
, Constit_Id
);
23464 -- The constituent is subject to a Part_Of indicator
23466 if Present
(Encapsulating_State
(Constit_Id
)) then
23467 if Encapsulating_State
(Constit_Id
) = State_Id
then
23468 Check_Ghost_Constituent
(Constit_Id
);
23469 Remove
(Part_Of_Constits
, Constit_Id
);
23470 Collect_Constituent
;
23472 -- The constituent is part of another state and is used
23473 -- incorrectly in the refinement of the current state.
23476 Error_Msg_Name_1
:= Chars
(State_Id
);
23478 ("& cannot act as constituent of state %",
23479 Constit
, Constit_Id
);
23481 ("\Part_Of indicator specifies & as encapsulating "
23482 & "state", Constit
, Encapsulating_State
(Constit_Id
));
23485 -- The only other source of legal constituents is the body
23486 -- state space of the related package.
23489 if Present
(Body_States
) then
23490 State_Elmt
:= First_Elmt
(Body_States
);
23491 while Present
(State_Elmt
) loop
23493 -- Consume a valid constituent to signal that it has
23494 -- been encountered.
23496 if Node
(State_Elmt
) = Constit_Id
then
23497 Check_Ghost_Constituent
(Constit_Id
);
23499 Remove_Elmt
(Body_States
, State_Elmt
);
23500 Collect_Constituent
;
23504 Next_Elmt
(State_Elmt
);
23508 -- If we get here, then the constituent is not a hidden
23509 -- state of the related package and may not be used in a
23510 -- refinement (SPARK RM 7.2.2(9)).
23512 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23514 ("cannot use & in refinement, constituent is not a hidden "
23515 & "state of package %", Constit
, Constit_Id
);
23517 end Check_Matching_Constituent
;
23519 -----------------------------
23520 -- Check_Ghost_Constituent --
23521 -----------------------------
23523 procedure Check_Ghost_Constituent
(Constit_Id
: Entity_Id
) is
23525 if Is_Ghost_Entity
(State_Id
) then
23526 if Is_Ghost_Entity
(Constit_Id
) then
23528 -- The Ghost policy in effect at the point of abstract
23529 -- state declaration and constituent must match
23530 -- (SPARK RM 6.9(16)).
23532 if Is_Checked_Ghost_Entity
(State_Id
)
23533 and then Is_Ignored_Ghost_Entity
(Constit_Id
)
23535 Error_Msg_Sloc
:= Sloc
(Constit
);
23538 ("incompatible ghost policies in effect", State
);
23540 ("\abstract state & declared with ghost policy "
23541 & "Check", State
, State_Id
);
23543 ("\constituent & declared # with ghost policy "
23544 & "Ignore", State
, Constit_Id
);
23546 elsif Is_Ignored_Ghost_Entity
(State_Id
)
23547 and then Is_Checked_Ghost_Entity
(Constit_Id
)
23549 Error_Msg_Sloc
:= Sloc
(Constit
);
23552 ("incompatible ghost policies in effect", State
);
23554 ("\abstract state & declared with ghost policy "
23555 & "Ignore", State
, State_Id
);
23557 ("\constituent & declared # with ghost policy "
23558 & "Check", State
, Constit_Id
);
23561 -- A constituent of a Ghost abstract state must be a Ghost
23562 -- entity (SPARK RM 7.2.2(12)).
23566 ("constituent of ghost state & must be ghost",
23567 Constit
, State_Id
);
23570 end Check_Ghost_Constituent
;
23574 Constit_Id
: Entity_Id
;
23576 -- Start of processing for Analyze_Constituent
23579 -- Detect multiple uses of null in a single refinement clause or a
23580 -- mixture of null and non-null constituents.
23582 if Nkind
(Constit
) = N_Null
then
23585 ("multiple null constituents not allowed", Constit
);
23587 elsif Non_Null_Seen
then
23589 ("cannot mix null and non-null constituents", Constit
);
23594 -- Collect the constituent in the list of refinement items
23596 Append_Elmt
(Constit
, Refinement_Constituents
(State_Id
));
23598 -- The state has at least one legal constituent, mark the
23599 -- start of the refinement region. The region ends when the
23600 -- body declarations end (see Analyze_Declarations).
23602 Set_Has_Visible_Refinement
(State_Id
);
23605 -- Non-null constituents
23608 Non_Null_Seen
:= True;
23612 ("cannot mix null and non-null constituents", Constit
);
23616 Resolve_State
(Constit
);
23618 -- Ensure that the constituent denotes a valid state or a
23621 if Is_Entity_Name
(Constit
) then
23622 Constit_Id
:= Entity_Of
(Constit
);
23624 if Ekind_In
(Constit_Id
, E_Abstract_State
, E_Variable
) then
23625 Check_Matching_Constituent
(Constit_Id
);
23629 ("constituent & must denote a variable or state (SPARK "
23630 & "RM 7.2.2(5))", Constit
, Constit_Id
);
23633 -- The constituent is illegal
23636 SPARK_Msg_N
("malformed constituent", Constit
);
23639 end Analyze_Constituent
;
23641 -----------------------------
23642 -- Check_External_Property --
23643 -----------------------------
23645 procedure Check_External_Property
23646 (Prop_Nam
: Name_Id
;
23648 Constit
: Entity_Id
)
23651 Error_Msg_Name_1
:= Prop_Nam
;
23653 -- The property is enabled in the related Abstract_State pragma
23654 -- that defines the state (SPARK RM 7.2.8(3)).
23657 if No
(Constit
) then
23659 ("external state & requires at least one constituent with "
23660 & "property %", State
, State_Id
);
23663 -- The property is missing in the declaration of the state, but
23664 -- a constituent is introducing it in the state refinement
23665 -- (SPARK RM 7.2.8(3)).
23667 elsif Present
(Constit
) then
23668 Error_Msg_Name_2
:= Chars
(Constit
);
23670 ("external state & lacks property % set by constituent %",
23673 end Check_External_Property
;
23675 --------------------------
23676 -- Check_Matching_State --
23677 --------------------------
23679 procedure Check_Matching_State
is
23680 State_Elmt
: Elmt_Id
;
23683 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
23685 if Contains
(Refined_States_Seen
, State_Id
) then
23687 ("duplicate refinement of state &", State
, State_Id
);
23691 -- Inspect the abstract states defined in the package declaration
23692 -- looking for a match.
23694 State_Elmt
:= First_Elmt
(Available_States
);
23695 while Present
(State_Elmt
) loop
23697 -- A valid abstract state is being refined in the body. Add
23698 -- the state to the list of processed refined states to aid
23699 -- with the detection of duplicate refinements. Remove the
23700 -- state from Available_States to signal that it has already
23703 if Node
(State_Elmt
) = State_Id
then
23704 Add_Item
(State_Id
, Refined_States_Seen
);
23705 Remove_Elmt
(Available_States
, State_Elmt
);
23709 Next_Elmt
(State_Elmt
);
23712 -- If we get here, we are refining a state that is not defined in
23713 -- the package declaration.
23715 Error_Msg_Name_1
:= Chars
(Spec_Id
);
23717 ("cannot refine state, & is not defined in package %",
23719 end Check_Matching_State
;
23721 --------------------------------
23722 -- Report_Unused_Constituents --
23723 --------------------------------
23725 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
23726 Constit_Elmt
: Elmt_Id
;
23727 Constit_Id
: Entity_Id
;
23728 Posted
: Boolean := False;
23731 if Present
(Constits
) then
23732 Constit_Elmt
:= First_Elmt
(Constits
);
23733 while Present
(Constit_Elmt
) loop
23734 Constit_Id
:= Node
(Constit_Elmt
);
23736 -- Generate an error message of the form:
23738 -- state ... has unused Part_Of constituents
23739 -- abstract state ... defined at ...
23740 -- variable ... defined at ...
23745 ("state & has unused Part_Of constituents",
23749 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
23751 if Ekind
(Constit_Id
) = E_Abstract_State
then
23753 ("\abstract state & defined #", State
, Constit_Id
);
23756 ("\variable & defined #", State
, Constit_Id
);
23759 Next_Elmt
(Constit_Elmt
);
23762 end Report_Unused_Constituents
;
23764 -- Local declarations
23766 Body_Ref
: Node_Id
;
23767 Body_Ref_Elmt
: Elmt_Id
;
23769 Extra_State
: Node_Id
;
23771 -- Start of processing for Analyze_Refinement_Clause
23774 -- A refinement clause appears as a component association where the
23775 -- sole choice is the state and the expressions are the constituents.
23776 -- This is a syntax error, always report.
23778 if Nkind
(Clause
) /= N_Component_Association
then
23779 Error_Msg_N
("malformed state refinement clause", Clause
);
23783 -- Analyze the state name of a refinement clause
23785 State
:= First
(Choices
(Clause
));
23788 Resolve_State
(State
);
23790 -- Ensure that the state name denotes a valid abstract state that is
23791 -- defined in the spec of the related package.
23793 if Is_Entity_Name
(State
) then
23794 State_Id
:= Entity_Of
(State
);
23796 -- Catch any attempts to re-refine a state or refine a state that
23797 -- is not defined in the package declaration.
23799 if Ekind
(State_Id
) = E_Abstract_State
then
23800 Check_Matching_State
;
23803 ("& must denote an abstract state", State
, State_Id
);
23807 -- References to a state with visible refinement are illegal.
23808 -- When nested packages are involved, detecting such references is
23809 -- tricky because pragma Refined_State is analyzed later than the
23810 -- offending pragma Depends or Global. References that occur in
23811 -- such nested context are stored in a list. Emit errors for all
23812 -- references found in Body_References (SPARK RM 6.1.4(8)).
23814 if Present
(Body_References
(State_Id
)) then
23815 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
23816 while Present
(Body_Ref_Elmt
) loop
23817 Body_Ref
:= Node
(Body_Ref_Elmt
);
23819 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
23820 Error_Msg_Sloc
:= Sloc
(State
);
23821 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
23823 Next_Elmt
(Body_Ref_Elmt
);
23827 -- The state name is illegal. This is a syntax error, always report.
23830 Error_Msg_N
("malformed state name in refinement clause", State
);
23834 -- A refinement clause may only refine one state at a time
23836 Extra_State
:= Next
(State
);
23838 if Present
(Extra_State
) then
23840 ("refinement clause cannot cover multiple states", Extra_State
);
23843 -- Replicate the Part_Of constituents of the refined state because
23844 -- the algorithm will consume items.
23846 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
23848 -- Analyze all constituents of the refinement. Multiple constituents
23849 -- appear as an aggregate.
23851 Constit
:= Expression
(Clause
);
23853 if Nkind
(Constit
) = N_Aggregate
then
23854 if Present
(Component_Associations
(Constit
)) then
23856 ("constituents of refinement clause must appear in "
23857 & "positional form", Constit
);
23859 else pragma Assert
(Present
(Expressions
(Constit
)));
23860 Constit
:= First
(Expressions
(Constit
));
23861 while Present
(Constit
) loop
23862 Analyze_Constituent
(Constit
);
23868 -- Various forms of a single constituent. Note that these may include
23869 -- malformed constituents.
23872 Analyze_Constituent
(Constit
);
23875 -- A refined external state is subject to special rules with respect
23876 -- to its properties and constituents.
23878 if Is_External_State
(State_Id
) then
23880 -- The set of properties that all external constituents yield must
23881 -- match that of the refined state. There are two cases to detect:
23882 -- the refined state lacks a property or has an extra property.
23884 if External_Constit_Seen
then
23885 Check_External_Property
23886 (Prop_Nam
=> Name_Async_Readers
,
23887 Enabled
=> Async_Readers_Enabled
(State_Id
),
23888 Constit
=> AR_Constit
);
23890 Check_External_Property
23891 (Prop_Nam
=> Name_Async_Writers
,
23892 Enabled
=> Async_Writers_Enabled
(State_Id
),
23893 Constit
=> AW_Constit
);
23895 Check_External_Property
23896 (Prop_Nam
=> Name_Effective_Reads
,
23897 Enabled
=> Effective_Reads_Enabled
(State_Id
),
23898 Constit
=> ER_Constit
);
23900 Check_External_Property
23901 (Prop_Nam
=> Name_Effective_Writes
,
23902 Enabled
=> Effective_Writes_Enabled
(State_Id
),
23903 Constit
=> EW_Constit
);
23905 -- An external state may be refined to null (SPARK RM 7.2.8(2))
23907 elsif Null_Seen
then
23910 -- The external state has constituents, but none of them are
23911 -- external (SPARK RM 7.2.8(2)).
23915 ("external state & requires at least one external "
23916 & "constituent or null refinement", State
, State_Id
);
23919 -- When a refined state is not external, it should not have external
23920 -- constituents (SPARK RM 7.2.8(1)).
23922 elsif External_Constit_Seen
then
23924 ("non-external state & cannot contain external constituents in "
23925 & "refinement", State
, State_Id
);
23928 -- Ensure that all Part_Of candidate constituents have been mentioned
23929 -- in the refinement clause.
23931 Report_Unused_Constituents
(Part_Of_Constits
);
23932 end Analyze_Refinement_Clause
;
23934 -------------------------
23935 -- Collect_Body_States --
23936 -------------------------
23938 function Collect_Body_States
(Pack_Id
: Entity_Id
) return Elist_Id
is
23939 Result
: Elist_Id
:= No_Elist
;
23940 -- A list containing all body states of Pack_Id
23942 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
);
23943 -- Gather the entities of all abstract states and variables declared
23944 -- in the visible state space of package Pack_Id.
23946 ----------------------------
23947 -- Collect_Visible_States --
23948 ----------------------------
23950 procedure Collect_Visible_States
(Pack_Id
: Entity_Id
) is
23951 Item_Id
: Entity_Id
;
23954 -- Traverse the entity chain of the package and inspect all
23957 Item_Id
:= First_Entity
(Pack_Id
);
23958 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
23960 -- Do not consider internally generated items as those cannot
23961 -- be named and participate in refinement.
23963 if not Comes_From_Source
(Item_Id
) then
23966 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
23967 Add_Item
(Item_Id
, Result
);
23969 -- Recursively gather the visible states of a nested package
23971 elsif Ekind
(Item_Id
) = E_Package
then
23972 Collect_Visible_States
(Item_Id
);
23975 Next_Entity
(Item_Id
);
23977 end Collect_Visible_States
;
23981 Pack_Body
: constant Node_Id
:=
23982 Declaration_Node
(Body_Entity
(Pack_Id
));
23984 Item_Id
: Entity_Id
;
23986 -- Start of processing for Collect_Body_States
23989 -- Inspect the declarations of the body looking for source variables,
23990 -- packages and package instantiations.
23992 Decl
:= First
(Declarations
(Pack_Body
));
23993 while Present
(Decl
) loop
23994 if Nkind
(Decl
) = N_Object_Declaration
then
23995 Item_Id
:= Defining_Entity
(Decl
);
23997 -- Capture source variables only as internally generated
23998 -- temporaries cannot be named and participate in refinement.
24000 if Ekind
(Item_Id
) = E_Variable
24001 and then Comes_From_Source
(Item_Id
)
24003 Add_Item
(Item_Id
, Result
);
24006 elsif Nkind
(Decl
) = N_Package_Declaration
then
24007 Item_Id
:= Defining_Entity
(Decl
);
24009 -- Capture the visible abstract states and variables of a
24010 -- source package [instantiation].
24012 if Comes_From_Source
(Item_Id
) then
24013 Collect_Visible_States
(Item_Id
);
24021 end Collect_Body_States
;
24023 -----------------------------
24024 -- Report_Unrefined_States --
24025 -----------------------------
24027 procedure Report_Unrefined_States
(States
: Elist_Id
) is
24028 State_Elmt
: Elmt_Id
;
24031 if Present
(States
) then
24032 State_Elmt
:= First_Elmt
(States
);
24033 while Present
(State_Elmt
) loop
24035 ("abstract state & must be refined", Node
(State_Elmt
));
24037 Next_Elmt
(State_Elmt
);
24040 end Report_Unrefined_States
;
24042 --------------------------
24043 -- Report_Unused_States --
24044 --------------------------
24046 procedure Report_Unused_States
(States
: Elist_Id
) is
24047 Posted
: Boolean := False;
24048 State_Elmt
: Elmt_Id
;
24049 State_Id
: Entity_Id
;
24052 if Present
(States
) then
24053 State_Elmt
:= First_Elmt
(States
);
24054 while Present
(State_Elmt
) loop
24055 State_Id
:= Node
(State_Elmt
);
24057 -- Generate an error message of the form:
24059 -- body of package ... has unused hidden states
24060 -- abstract state ... defined at ...
24061 -- variable ... defined at ...
24066 ("body of package & has unused hidden states", Body_Id
);
24069 Error_Msg_Sloc
:= Sloc
(State_Id
);
24071 if Ekind
(State_Id
) = E_Abstract_State
then
24073 ("\abstract state & defined #", Body_Id
, State_Id
);
24076 ("\variable & defined #", Body_Id
, State_Id
);
24079 Next_Elmt
(State_Elmt
);
24082 end Report_Unused_States
;
24084 -- Local declarations
24086 Body_Decl
: constant Node_Id
:= Parent
(N
);
24087 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
));
24090 -- Start of processing for Analyze_Refined_State_In_Decl_Part
24095 Body_Id
:= Defining_Entity
(Body_Decl
);
24096 Spec_Id
:= Corresponding_Spec
(Body_Decl
);
24098 -- Replicate the abstract states declared by the package because the
24099 -- matching algorithm will consume states.
24101 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
24103 -- Gather all abstract states and variables declared in the visible
24104 -- state space of the package body. These items must be utilized as
24105 -- constituents in a state refinement.
24107 Body_States
:= Collect_Body_States
(Spec_Id
);
24109 -- Multiple non-null state refinements appear as an aggregate
24111 if Nkind
(Clauses
) = N_Aggregate
then
24112 if Present
(Expressions
(Clauses
)) then
24114 ("state refinements must appear as component associations",
24117 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
24118 Clause
:= First
(Component_Associations
(Clauses
));
24119 while Present
(Clause
) loop
24120 Analyze_Refinement_Clause
(Clause
);
24126 -- Various forms of a single state refinement. Note that these may
24127 -- include malformed refinements.
24130 Analyze_Refinement_Clause
(Clauses
);
24133 -- List all abstract states that were left unrefined
24135 Report_Unrefined_States
(Available_States
);
24137 -- Ensure that all abstract states and variables declared in the body
24138 -- state space of the related package are utilized as constituents.
24140 Report_Unused_States
(Body_States
);
24141 end Analyze_Refined_State_In_Decl_Part
;
24143 ------------------------------------
24144 -- Analyze_Test_Case_In_Decl_Part --
24145 ------------------------------------
24147 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
24148 procedure Preanalyze_Test_Case_Arg
24149 (Arg_Nam
: Name_Id
;
24150 Subp_Id
: Entity_Id
);
24151 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
24152 -- denoted by Arg_Nam. Subp_Id is the entity of the subprogram subject
24153 -- to pragma Test_Case.
24155 ------------------------------
24156 -- Preanalyze_Test_Case_Arg --
24157 ------------------------------
24159 procedure Preanalyze_Test_Case_Arg
24160 (Arg_Nam
: Name_Id
;
24161 Subp_Id
: Entity_Id
)
24166 -- Preanalyze the original aspect argument for ASIS or for a generic
24167 -- subprogram to properly capture global references.
24169 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
24173 Arg_Nam
=> Arg_Nam
,
24174 From_Aspect
=> True);
24176 if Present
(Arg
) then
24177 Preanalyze_Assert_Expression
24178 (Expression
(Arg
), Standard_Boolean
);
24182 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
24184 if Present
(Arg
) then
24185 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
24187 end Preanalyze_Test_Case_Arg
;
24191 Subp_Decl
: Node_Id
;
24192 Subp_Id
: Entity_Id
;
24194 Restore_Scope
: Boolean := False;
24195 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
24197 -- Start of processing for Analyze_Test_Case_In_Decl_Part
24200 Subp_Decl
:= Find_Related_Subprogram_Or_Body
(N
);
24201 Subp_Id
:= Defining_Entity
(Subp_Decl
);
24203 -- Ensure that the formal parameters are visible when analyzing all
24204 -- clauses. This falls out of the general rule of aspects pertaining
24205 -- to subprogram declarations.
24207 if not In_Open_Scopes
(Subp_Id
) then
24208 Restore_Scope
:= True;
24209 Push_Scope
(Subp_Id
);
24211 if Is_Generic_Subprogram
(Subp_Id
) then
24212 Install_Generic_Formals
(Subp_Id
);
24214 Install_Formals
(Subp_Id
);
24218 Preanalyze_Test_Case_Arg
(Name_Requires
, Subp_Id
);
24219 Preanalyze_Test_Case_Arg
(Name_Ensures
, Subp_Id
);
24221 if Restore_Scope
then
24224 end Analyze_Test_Case_In_Decl_Part
;
24230 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
24235 if Present
(List
) then
24236 Elmt
:= First_Elmt
(List
);
24237 while Present
(Elmt
) loop
24238 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
24241 Id
:= Entity_Of
(Node
(Elmt
));
24244 if Id
= Item_Id
then
24255 -----------------------------
24256 -- Check_Applicable_Policy --
24257 -----------------------------
24259 procedure Check_Applicable_Policy
(N
: Node_Id
) is
24263 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
24266 -- No effect if not valid assertion kind name
24268 if not Is_Valid_Assertion_Kind
(Ename
) then
24272 -- Loop through entries in check policy list
24274 PP
:= Opt
.Check_Policy_List
;
24275 while Present
(PP
) loop
24277 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24278 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24282 or else Pnm
= Name_Assertion
24283 or else (Pnm
= Name_Statement_Assertions
24284 and then Nam_In
(Ename
, Name_Assert
,
24285 Name_Assert_And_Cut
,
24287 Name_Loop_Invariant
,
24288 Name_Loop_Variant
))
24290 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
24293 when Name_Off | Name_Ignore
=>
24294 Set_Is_Ignored
(N
, True);
24295 Set_Is_Checked
(N
, False);
24297 when Name_On | Name_Check
=>
24298 Set_Is_Checked
(N
, True);
24299 Set_Is_Ignored
(N
, False);
24301 when Name_Disable
=>
24302 Set_Is_Ignored
(N
, True);
24303 Set_Is_Checked
(N
, False);
24304 Set_Is_Disabled
(N
, True);
24306 -- That should be exhaustive, the null here is a defence
24307 -- against a malformed tree from previous errors.
24316 PP
:= Next_Pragma
(PP
);
24320 -- If there are no specific entries that matched, then we let the
24321 -- setting of assertions govern. Note that this provides the needed
24322 -- compatibility with the RM for the cases of assertion, invariant,
24323 -- precondition, predicate, and postcondition.
24325 if Assertions_Enabled
then
24326 Set_Is_Checked
(N
, True);
24327 Set_Is_Ignored
(N
, False);
24329 Set_Is_Checked
(N
, False);
24330 Set_Is_Ignored
(N
, True);
24332 end Check_Applicable_Policy
;
24334 -------------------------------
24335 -- Check_External_Properties --
24336 -------------------------------
24338 procedure Check_External_Properties
24346 -- All properties enabled
24348 if AR
and AW
and ER
and EW
then
24351 -- Async_Readers + Effective_Writes
24352 -- Async_Readers + Async_Writers + Effective_Writes
24354 elsif AR
and EW
and not ER
then
24357 -- Async_Writers + Effective_Reads
24358 -- Async_Readers + Async_Writers + Effective_Reads
24360 elsif AW
and ER
and not EW
then
24363 -- Async_Readers + Async_Writers
24365 elsif AR
and AW
and not ER
and not EW
then
24370 elsif AR
and not AW
and not ER
and not EW
then
24375 elsif AW
and not AR
and not ER
and not EW
then
24380 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
24383 end Check_External_Properties
;
24389 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
24393 -- Loop through entries in check policy list
24395 PP
:= Opt
.Check_Policy_List
;
24396 while Present
(PP
) loop
24398 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
24399 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
24403 or else (Pnm
= Name_Assertion
24404 and then Is_Valid_Assertion_Kind
(Nam
))
24405 or else (Pnm
= Name_Statement_Assertions
24406 and then Nam_In
(Nam
, Name_Assert
,
24407 Name_Assert_And_Cut
,
24409 Name_Loop_Invariant
,
24410 Name_Loop_Variant
))
24412 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
24413 when Name_On | Name_Check
=>
24415 when Name_Off | Name_Ignore
=>
24416 return Name_Ignore
;
24417 when Name_Disable
=>
24418 return Name_Disable
;
24420 raise Program_Error
;
24424 PP
:= Next_Pragma
(PP
);
24429 -- If there are no specific entries that matched, then we let the
24430 -- setting of assertions govern. Note that this provides the needed
24431 -- compatibility with the RM for the cases of assertion, invariant,
24432 -- precondition, predicate, and postcondition.
24434 if Assertions_Enabled
then
24437 return Name_Ignore
;
24441 ---------------------------
24442 -- Check_Missing_Part_Of --
24443 ---------------------------
24445 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
24446 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
24447 -- Determine whether a package denoted by Pack_Id declares at least one
24450 -----------------------
24451 -- Has_Visible_State --
24452 -----------------------
24454 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
24455 Item_Id
: Entity_Id
;
24458 -- Traverse the entity chain of the package trying to find at least
24459 -- one visible abstract state, variable or a package [instantiation]
24460 -- that declares a visible state.
24462 Item_Id
:= First_Entity
(Pack_Id
);
24463 while Present
(Item_Id
)
24464 and then not In_Private_Part
(Item_Id
)
24466 -- Do not consider internally generated items
24468 if not Comes_From_Source
(Item_Id
) then
24471 -- A visible state has been found
24473 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
24476 -- Recursively peek into nested packages and instantiations
24478 elsif Ekind
(Item_Id
) = E_Package
24479 and then Has_Visible_State
(Item_Id
)
24484 Next_Entity
(Item_Id
);
24488 end Has_Visible_State
;
24492 Pack_Id
: Entity_Id
;
24493 Placement
: State_Space_Kind
;
24495 -- Start of processing for Check_Missing_Part_Of
24498 -- Do not consider abstract states, variables or package instantiations
24499 -- coming from an instance as those always inherit the Part_Of indicator
24500 -- of the instance itself.
24502 if In_Instance
then
24505 -- Do not consider internally generated entities as these can never
24506 -- have a Part_Of indicator.
24508 elsif not Comes_From_Source
(Item_Id
) then
24511 -- Perform these checks only when SPARK_Mode is enabled as they will
24512 -- interfere with standard Ada rules and produce false positives.
24514 elsif SPARK_Mode
/= On
then
24518 -- Find where the abstract state, variable or package instantiation
24519 -- lives with respect to the state space.
24521 Find_Placement_In_State_Space
24522 (Item_Id
=> Item_Id
,
24523 Placement
=> Placement
,
24524 Pack_Id
=> Pack_Id
);
24526 -- Items that appear in a non-package construct (subprogram, block, etc)
24527 -- do not require a Part_Of indicator because they can never act as a
24530 if Placement
= Not_In_Package
then
24533 -- An item declared in the body state space of a package always act as a
24534 -- constituent and does not need explicit Part_Of indicator.
24536 elsif Placement
= Body_State_Space
then
24539 -- In general an item declared in the visible state space of a package
24540 -- does not require a Part_Of indicator. The only exception is when the
24541 -- related package is a private child unit in which case Part_Of must
24542 -- denote a state in the parent unit or in one of its descendants.
24544 elsif Placement
= Visible_State_Space
then
24545 if Is_Child_Unit
(Pack_Id
)
24546 and then Is_Private_Descendant
(Pack_Id
)
24548 -- A package instantiation does not need a Part_Of indicator when
24549 -- the related generic template has no visible state.
24551 if Ekind
(Item_Id
) = E_Package
24552 and then Is_Generic_Instance
(Item_Id
)
24553 and then not Has_Visible_State
(Item_Id
)
24557 -- All other cases require Part_Of
24561 ("indicator Part_Of is required in this context "
24562 & "(SPARK RM 7.2.6(3))", Item_Id
);
24563 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24565 ("\& is declared in the visible part of private child "
24566 & "unit %", Item_Id
);
24570 -- When the item appears in the private state space of a packge, it must
24571 -- be a part of some state declared by the said package.
24573 else pragma Assert
(Placement
= Private_State_Space
);
24575 -- The related package does not declare a state, the item cannot act
24576 -- as a Part_Of constituent.
24578 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
24581 -- A package instantiation does not need a Part_Of indicator when the
24582 -- related generic template has no visible state.
24584 elsif Ekind
(Pack_Id
) = E_Package
24585 and then Is_Generic_Instance
(Pack_Id
)
24586 and then not Has_Visible_State
(Pack_Id
)
24590 -- All other cases require Part_Of
24594 ("indicator Part_Of is required in this context "
24595 & "(SPARK RM 7.2.6(2))", Item_Id
);
24596 Error_Msg_Name_1
:= Chars
(Pack_Id
);
24598 ("\& is declared in the private part of package %", Item_Id
);
24601 end Check_Missing_Part_Of
;
24603 -------------------------------------
24604 -- Check_State_And_Constituent_Use --
24605 -------------------------------------
24607 procedure Check_State_And_Constituent_Use
24608 (States
: Elist_Id
;
24609 Constits
: Elist_Id
;
24612 function Find_Encapsulating_State
24613 (Constit_Id
: Entity_Id
) return Entity_Id
;
24614 -- Given the entity of a constituent, try to find a corresponding
24615 -- encapsulating state that appears in the same context. The routine
24616 -- returns Empty is no such state is found.
24618 ------------------------------
24619 -- Find_Encapsulating_State --
24620 ------------------------------
24622 function Find_Encapsulating_State
24623 (Constit_Id
: Entity_Id
) return Entity_Id
24625 State_Id
: Entity_Id
;
24628 -- Since a constituent may be part of a larger constituent set, climb
24629 -- the encapsulated state chain looking for a state that appears in
24630 -- the same context.
24632 State_Id
:= Encapsulating_State
(Constit_Id
);
24633 while Present
(State_Id
) loop
24634 if Contains
(States
, State_Id
) then
24638 State_Id
:= Encapsulating_State
(State_Id
);
24642 end Find_Encapsulating_State
;
24646 Constit_Elmt
: Elmt_Id
;
24647 Constit_Id
: Entity_Id
;
24648 State_Id
: Entity_Id
;
24650 -- Start of processing for Check_State_And_Constituent_Use
24653 -- Nothing to do if there are no states or constituents
24655 if No
(States
) or else No
(Constits
) then
24659 -- Inspect the list of constituents and try to determine whether its
24660 -- encapsulating state is in list States.
24662 Constit_Elmt
:= First_Elmt
(Constits
);
24663 while Present
(Constit_Elmt
) loop
24664 Constit_Id
:= Node
(Constit_Elmt
);
24666 -- Determine whether the constituent is part of an encapsulating
24667 -- state that appears in the same context and if this is the case,
24668 -- emit an error (SPARK RM 7.2.6(7)).
24670 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
24672 if Present
(State_Id
) then
24673 Error_Msg_Name_1
:= Chars
(Constit_Id
);
24675 ("cannot mention state & and its constituent % in the same "
24676 & "context", Context
, State_Id
);
24680 Next_Elmt
(Constit_Elmt
);
24682 end Check_State_And_Constituent_Use
;
24684 ---------------------------------------
24685 -- Collect_Subprogram_Inputs_Outputs --
24686 ---------------------------------------
24688 procedure Collect_Subprogram_Inputs_Outputs
24689 (Subp_Id
: Entity_Id
;
24690 Synthesize
: Boolean := False;
24691 Subp_Inputs
: in out Elist_Id
;
24692 Subp_Outputs
: in out Elist_Id
;
24693 Global_Seen
: out Boolean)
24695 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
24696 -- Collect all relevant items from a dependency clause
24698 procedure Collect_Global_List
24700 Mode
: Name_Id
:= Name_Input
);
24701 -- Collect all relevant items from a global list
24703 -------------------------------
24704 -- Collect_Dependency_Clause --
24705 -------------------------------
24707 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
24708 procedure Collect_Dependency_Item
24710 Is_Input
: Boolean);
24711 -- Add an item to the proper subprogram input or output collection
24713 -----------------------------
24714 -- Collect_Dependency_Item --
24715 -----------------------------
24717 procedure Collect_Dependency_Item
24719 Is_Input
: Boolean)
24724 -- Nothing to collect when the item is null
24726 if Nkind
(Item
) = N_Null
then
24729 -- Ditto for attribute 'Result
24731 elsif Is_Attribute_Result
(Item
) then
24734 -- Multiple items appear as an aggregate
24736 elsif Nkind
(Item
) = N_Aggregate
then
24737 Extra
:= First
(Expressions
(Item
));
24738 while Present
(Extra
) loop
24739 Collect_Dependency_Item
(Extra
, Is_Input
);
24743 -- Otherwise this is a solitary item
24747 Add_Item
(Item
, Subp_Inputs
);
24749 Add_Item
(Item
, Subp_Outputs
);
24752 end Collect_Dependency_Item
;
24754 -- Start of processing for Collect_Dependency_Clause
24757 if Nkind
(Clause
) = N_Null
then
24760 -- A dependency cause appears as component association
24762 elsif Nkind
(Clause
) = N_Component_Association
then
24763 Collect_Dependency_Item
24764 (Expression
(Clause
), Is_Input
=> True);
24765 Collect_Dependency_Item
24766 (First
(Choices
(Clause
)), Is_Input
=> False);
24768 -- To accomodate partial decoration of disabled SPARK features, this
24769 -- routine may be called with illegal input. If this is the case, do
24770 -- not raise Program_Error.
24775 end Collect_Dependency_Clause
;
24777 -------------------------
24778 -- Collect_Global_List --
24779 -------------------------
24781 procedure Collect_Global_List
24783 Mode
: Name_Id
:= Name_Input
)
24785 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
24786 -- Add an item to the proper subprogram input or output collection
24788 -------------------------
24789 -- Collect_Global_Item --
24790 -------------------------
24792 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
24794 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
24795 Add_Item
(Item
, Subp_Inputs
);
24798 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
24799 Add_Item
(Item
, Subp_Outputs
);
24801 end Collect_Global_Item
;
24808 -- Start of processing for Collect_Global_List
24811 if Nkind
(List
) = N_Null
then
24814 -- Single global item declaration
24816 elsif Nkind_In
(List
, N_Expanded_Name
,
24818 N_Selected_Component
)
24820 Collect_Global_Item
(List
, Mode
);
24822 -- Simple global list or moded global list declaration
24824 elsif Nkind
(List
) = N_Aggregate
then
24825 if Present
(Expressions
(List
)) then
24826 Item
:= First
(Expressions
(List
));
24827 while Present
(Item
) loop
24828 Collect_Global_Item
(Item
, Mode
);
24833 Assoc
:= First
(Component_Associations
(List
));
24834 while Present
(Assoc
) loop
24835 Collect_Global_List
24836 (List
=> Expression
(Assoc
),
24837 Mode
=> Chars
(First
(Choices
(Assoc
))));
24842 -- To accomodate partial decoration of disabled SPARK features, this
24843 -- routine may be called with illegal input. If this is the case, do
24844 -- not raise Program_Error.
24849 end Collect_Global_List
;
24853 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
24854 Spec_Id
: constant Entity_Id
:= Corresponding_Spec_Of
(Subp_Decl
);
24858 Formal
: Entity_Id
;
24862 -- Start of processing for Collect_Subprogram_Inputs_Outputs
24865 Global_Seen
:= False;
24867 -- Process all formal parameters
24869 Formal
:= First_Formal
(Spec_Id
);
24870 while Present
(Formal
) loop
24871 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
24872 Add_Item
(Formal
, Subp_Inputs
);
24875 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
24876 Add_Item
(Formal
, Subp_Outputs
);
24878 -- Out parameters can act as inputs when the related type is
24879 -- tagged, unconstrained array, unconstrained record or record
24880 -- with unconstrained components.
24882 if Ekind
(Formal
) = E_Out_Parameter
24883 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
24885 Add_Item
(Formal
, Subp_Inputs
);
24889 Next_Formal
(Formal
);
24892 -- When processing a subprogram body, look for pragmas Refined_Depends
24893 -- and Refined_Global as they specify the inputs and outputs.
24895 if Ekind
(Subp_Id
) = E_Subprogram_Body
then
24896 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
24897 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
24899 -- Subprogram declaration case, look for pragmas Depends and Global
24902 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
24903 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
24906 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
24907 -- because it provides finer granularity of inputs and outputs.
24909 if Present
(Global
) then
24910 Global_Seen
:= True;
24911 List
:= Expression
(Get_Argument
(Global
, Spec_Id
));
24913 -- The pragma may not have been analyzed because of the arbitrary
24914 -- declaration order of aspects. Make sure that it is analyzed for
24915 -- the purposes of item extraction.
24917 if not Analyzed
(List
) then
24918 if Pragma_Name
(Global
) = Name_Refined_Global
then
24919 Analyze_Refined_Global_In_Decl_Part
(Global
);
24921 Analyze_Global_In_Decl_Part
(Global
);
24925 Collect_Global_List
(List
);
24927 -- When the related subprogram lacks pragma [Refined_]Global, fall back
24928 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
24929 -- the inputs and outputs from [Refined_]Depends.
24931 elsif Synthesize
and then Present
(Depends
) then
24932 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
24934 -- Multiple dependency clauses appear as an aggregate
24936 if Nkind
(Clauses
) = N_Aggregate
then
24937 Clause
:= First
(Component_Associations
(Clauses
));
24938 while Present
(Clause
) loop
24939 Collect_Dependency_Clause
(Clause
);
24943 -- Otherwise this is a single dependency clause
24946 Collect_Dependency_Clause
(Clauses
);
24949 end Collect_Subprogram_Inputs_Outputs
;
24951 ---------------------------------
24952 -- Delay_Config_Pragma_Analyze --
24953 ---------------------------------
24955 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
24957 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
24958 Name_Priority_Specific_Dispatching
);
24959 end Delay_Config_Pragma_Analyze
;
24961 -----------------------
24962 -- Duplication_Error --
24963 -----------------------
24965 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
24966 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
24967 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
24970 Error_Msg_Sloc
:= Sloc
(Prev
);
24971 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
24973 -- Emit a precise message to distinguish between source pragmas and
24974 -- pragmas generated from aspects. The ordering of the two pragmas is
24978 -- Prag -- duplicate
24980 -- No error is emitted when both pragmas come from aspects because this
24981 -- is already detected by the general aspect analysis mechanism.
24983 if Prag_From_Asp
and Prev_From_Asp
then
24985 elsif Prag_From_Asp
then
24986 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
24987 elsif Prev_From_Asp
then
24988 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
24990 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
24992 end Duplication_Error
;
24994 ----------------------------------
24995 -- Find_Related_Package_Or_Body --
24996 ----------------------------------
24998 function Find_Related_Package_Or_Body
25000 Do_Checks
: Boolean := False) return Node_Id
25002 Context
: constant Node_Id
:= Parent
(Prag
);
25003 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
25007 Stmt
:= Prev
(Prag
);
25008 while Present
(Stmt
) loop
25010 -- Skip prior pragmas, but check for duplicates
25012 if Nkind
(Stmt
) = N_Pragma
then
25013 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
25019 -- Skip internally generated code
25021 elsif not Comes_From_Source
(Stmt
) then
25022 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
25024 -- The subprogram declaration is an internally generated spec
25025 -- for an expression function.
25027 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
25030 -- The subprogram is actually an instance housed within an
25031 -- anonymous wrapper package.
25033 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
25038 -- Return the current source construct which is illegal
25047 -- If we fall through, then the pragma was either the first declaration
25048 -- or it was preceded by other pragmas and no source constructs.
25050 -- The pragma is associated with a package. The immediate context in
25051 -- this case is the specification of the package.
25053 if Nkind
(Context
) = N_Package_Specification
then
25054 return Parent
(Context
);
25056 -- The pragma appears in the declarations of a package body
25058 elsif Nkind
(Context
) = N_Package_Body
then
25061 -- The pragma appears in the statements of a package body
25063 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
25064 and then Nkind
(Parent
(Context
)) = N_Package_Body
25066 return Parent
(Context
);
25068 -- The pragma is a byproduct of aspect expansion, return the related
25069 -- context of the original aspect. This case has a lower priority as
25070 -- the above circuitry pinpoints precisely the related context.
25072 elsif Present
(Corresponding_Aspect
(Prag
)) then
25073 return Parent
(Corresponding_Aspect
(Prag
));
25075 -- No candidate packge [body] found
25080 end Find_Related_Package_Or_Body
;
25082 -------------------------------------
25083 -- Find_Related_Subprogram_Or_Body --
25084 -------------------------------------
25086 function Find_Related_Subprogram_Or_Body
25088 Do_Checks
: Boolean := False) return Node_Id
25090 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
25092 procedure Expression_Function_Error
;
25093 -- Emit an error concerning pragma Prag that illegaly applies to an
25094 -- expression function.
25096 -------------------------------
25097 -- Expression_Function_Error --
25098 -------------------------------
25100 procedure Expression_Function_Error
is
25102 Error_Msg_Name_1
:= Prag_Nam
;
25104 -- Emit a precise message to distinguish between source pragmas and
25105 -- pragmas generated from aspects.
25107 if From_Aspect_Specification
(Prag
) then
25109 ("aspect % cannot apply to a stand alone expression function",
25113 ("pragma % cannot apply to a stand alone expression function",
25116 end Expression_Function_Error
;
25120 Context
: constant Node_Id
:= Parent
(Prag
);
25123 Look_For_Body
: constant Boolean :=
25124 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
25125 Name_Refined_Global
,
25126 Name_Refined_Post
);
25127 -- Refinement pragmas must be associated with a subprogram body [stub]
25129 -- Start of processing for Find_Related_Subprogram_Or_Body
25132 Stmt
:= Prev
(Prag
);
25133 while Present
(Stmt
) loop
25135 -- Skip prior pragmas, but check for duplicates. Pragmas produced
25136 -- by splitting a complex pre/postcondition are not considered to
25139 if Nkind
(Stmt
) = N_Pragma
then
25141 and then not Split_PPC
(Stmt
)
25142 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
25149 -- Emit an error when a refinement pragma appears on an expression
25150 -- function without a completion.
25153 and then Look_For_Body
25154 and then Nkind
(Stmt
) = N_Subprogram_Declaration
25155 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
25156 and then not Has_Completion
(Defining_Entity
(Stmt
))
25158 Expression_Function_Error
;
25161 -- The refinement pragma applies to a subprogram body stub
25163 elsif Look_For_Body
25164 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
25168 -- Skip internally generated code
25170 elsif not Comes_From_Source
(Stmt
) then
25171 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
25173 -- The subprogram declaration is an internally generated spec
25174 -- for an expression function.
25176 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
25179 -- The subprogram is actually an instance housed within an
25180 -- anonymous wrapper package.
25182 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
25187 -- Return the current construct which is either a subprogram body,
25188 -- a subprogram declaration or is illegal.
25197 -- If we fall through, then the pragma was either the first declaration
25198 -- or it was preceded by other pragmas and no source constructs.
25200 -- The pragma is associated with a library-level subprogram
25202 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
25203 return Unit
(Parent
(Context
));
25205 -- The pragma appears inside the statements of a subprogram body. This
25206 -- placement is the result of subprogram contract expansion.
25208 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
25209 return Parent
(Context
);
25211 -- The pragma appears inside the declarative part of a subprogram body
25213 elsif Nkind
(Context
) = N_Subprogram_Body
then
25216 -- The pragma is a byproduct of aspect expansion, return the related
25217 -- context of the original aspect. This case has a lower priority as
25218 -- the above circuitry pinpoints precisely the related context.
25220 elsif Present
(Corresponding_Aspect
(Prag
)) then
25221 return Parent
(Corresponding_Aspect
(Prag
));
25223 -- No candidate subprogram [body] found
25228 end Find_Related_Subprogram_Or_Body
;
25234 function Get_Argument
25236 Spec_Id
: Entity_Id
:= Empty
) return Node_Id
25238 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
25241 -- Use the expression of the original aspect if possible when compiling
25242 -- for ASIS or when analyzing the template of a generic subprogram. In
25243 -- both cases the aspect's tree must be decorated to allow for ASIS
25244 -- queries or to save all global references in the generic context.
25246 if From_Aspect_Specification
(Prag
)
25248 (ASIS_Mode
or else (Present
(Spec_Id
)
25249 and then Is_Generic_Subprogram
(Spec_Id
)))
25251 return Corresponding_Aspect
(Prag
);
25253 -- Otherwise use the expression of the pragma
25255 elsif Present
(Args
) then
25256 return First
(Args
);
25263 -------------------------
25264 -- Get_Base_Subprogram --
25265 -------------------------
25267 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
25268 Result
: Entity_Id
;
25271 -- Follow subprogram renaming chain
25275 if Is_Subprogram
(Result
)
25277 Nkind
(Parent
(Declaration_Node
(Result
))) =
25278 N_Subprogram_Renaming_Declaration
25279 and then Present
(Alias
(Result
))
25281 Result
:= Alias
(Result
);
25285 end Get_Base_Subprogram
;
25287 -----------------------
25288 -- Get_SPARK_Mode_Type --
25289 -----------------------
25291 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
25293 if N
= Name_On
then
25295 elsif N
= Name_Off
then
25298 -- Any other argument is illegal
25301 raise Program_Error
;
25303 end Get_SPARK_Mode_Type
;
25305 --------------------------------
25306 -- Get_SPARK_Mode_From_Pragma --
25307 --------------------------------
25309 function Get_SPARK_Mode_From_Pragma
(N
: Node_Id
) return SPARK_Mode_Type
is
25314 pragma Assert
(Nkind
(N
) = N_Pragma
);
25315 Args
:= Pragma_Argument_Associations
(N
);
25317 -- Extract the mode from the argument list
25319 if Present
(Args
) then
25320 Mode
:= First
(Pragma_Argument_Associations
(N
));
25321 return Get_SPARK_Mode_Type
(Chars
(Get_Pragma_Arg
(Mode
)));
25323 -- If SPARK_Mode pragma has no argument, default is ON
25328 end Get_SPARK_Mode_From_Pragma
;
25330 ---------------------------
25331 -- Has_Extra_Parentheses --
25332 ---------------------------
25334 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
25338 -- The aggregate should not have an expression list because a clause
25339 -- is always interpreted as a component association. The only way an
25340 -- expression list can sneak in is by adding extra parentheses around
25341 -- the individual clauses:
25343 -- Depends (Output => Input) -- proper form
25344 -- Depends ((Output => Input)) -- extra parentheses
25346 -- Since the extra parentheses are not allowed by the syntax of the
25347 -- pragma, flag them now to avoid emitting misleading errors down the
25350 if Nkind
(Clause
) = N_Aggregate
25351 and then Present
(Expressions
(Clause
))
25353 Expr
:= First
(Expressions
(Clause
));
25354 while Present
(Expr
) loop
25356 -- A dependency clause surrounded by extra parentheses appears
25357 -- as an aggregate of component associations with an optional
25358 -- Paren_Count set.
25360 if Nkind
(Expr
) = N_Aggregate
25361 and then Present
(Component_Associations
(Expr
))
25364 ("dependency clause contains extra parentheses", Expr
);
25366 -- Otherwise the expression is a malformed construct
25369 SPARK_Msg_N
("malformed dependency clause", Expr
);
25379 end Has_Extra_Parentheses
;
25385 procedure Initialize
is
25396 Dummy
:= Dummy
+ 1;
25399 -----------------------------
25400 -- Is_Config_Static_String --
25401 -----------------------------
25403 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25405 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
25406 -- This is an internal recursive function that is just like the outer
25407 -- function except that it adds the string to the name buffer rather
25408 -- than placing the string in the name buffer.
25410 ------------------------------
25411 -- Add_Config_Static_String --
25412 ------------------------------
25414 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
25421 if Nkind
(N
) = N_Op_Concat
then
25422 if Add_Config_Static_String
(Left_Opnd
(N
)) then
25423 N
:= Right_Opnd
(N
);
25429 if Nkind
(N
) /= N_String_Literal
then
25430 Error_Msg_N
("string literal expected for pragma argument", N
);
25434 for J
in 1 .. String_Length
(Strval
(N
)) loop
25435 C
:= Get_String_Char
(Strval
(N
), J
);
25437 if not In_Character_Range
(C
) then
25439 ("string literal contains invalid wide character",
25440 Sloc
(N
) + 1 + Source_Ptr
(J
));
25444 Add_Char_To_Name_Buffer
(Get_Character
(C
));
25449 end Add_Config_Static_String
;
25451 -- Start of processing for Is_Config_Static_String
25456 return Add_Config_Static_String
(Arg
);
25457 end Is_Config_Static_String
;
25459 -------------------------------
25460 -- Is_Elaboration_SPARK_Mode --
25461 -------------------------------
25463 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
25466 (Nkind
(N
) = N_Pragma
25467 and then Pragma_Name
(N
) = Name_SPARK_Mode
25468 and then Is_List_Member
(N
));
25470 -- Pragma SPARK_Mode affects the elaboration of a package body when it
25471 -- appears in the statement part of the body.
25474 Present
(Parent
(N
))
25475 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
25476 and then List_Containing
(N
) = Statements
(Parent
(N
))
25477 and then Present
(Parent
(Parent
(N
)))
25478 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
25479 end Is_Elaboration_SPARK_Mode
;
25481 -----------------------------------------
25482 -- Is_Non_Significant_Pragma_Reference --
25483 -----------------------------------------
25485 -- This function makes use of the following static table which indicates
25486 -- whether appearance of some name in a given pragma is to be considered
25487 -- as a reference for the purposes of warnings about unreferenced objects.
25489 -- -1 indicates that appearence in any argument is significant
25490 -- 0 indicates that appearance in any argument is not significant
25491 -- +n indicates that appearance as argument n is significant, but all
25492 -- other arguments are not significant
25493 -- 9n arguments from n on are significant, before n inisignificant
25495 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
25496 (Pragma_Abort_Defer
=> -1,
25497 Pragma_Abstract_State
=> -1,
25498 Pragma_Ada_83
=> -1,
25499 Pragma_Ada_95
=> -1,
25500 Pragma_Ada_05
=> -1,
25501 Pragma_Ada_2005
=> -1,
25502 Pragma_Ada_12
=> -1,
25503 Pragma_Ada_2012
=> -1,
25504 Pragma_All_Calls_Remote
=> -1,
25505 Pragma_Allow_Integer_Address
=> -1,
25506 Pragma_Annotate
=> 93,
25507 Pragma_Assert
=> -1,
25508 Pragma_Assert_And_Cut
=> -1,
25509 Pragma_Assertion_Policy
=> 0,
25510 Pragma_Assume
=> -1,
25511 Pragma_Assume_No_Invalid_Values
=> 0,
25512 Pragma_Async_Readers
=> 0,
25513 Pragma_Async_Writers
=> 0,
25514 Pragma_Asynchronous
=> 0,
25515 Pragma_Atomic
=> 0,
25516 Pragma_Atomic_Components
=> 0,
25517 Pragma_Attach_Handler
=> -1,
25518 Pragma_Attribute_Definition
=> 92,
25519 Pragma_Check
=> -1,
25520 Pragma_Check_Float_Overflow
=> 0,
25521 Pragma_Check_Name
=> 0,
25522 Pragma_Check_Policy
=> 0,
25523 Pragma_CIL_Constructor
=> 0,
25524 Pragma_CPP_Class
=> 0,
25525 Pragma_CPP_Constructor
=> 0,
25526 Pragma_CPP_Virtual
=> 0,
25527 Pragma_CPP_Vtable
=> 0,
25529 Pragma_C_Pass_By_Copy
=> 0,
25530 Pragma_Comment
=> -1,
25531 Pragma_Common_Object
=> 0,
25532 Pragma_Compile_Time_Error
=> -1,
25533 Pragma_Compile_Time_Warning
=> -1,
25534 Pragma_Compiler_Unit
=> -1,
25535 Pragma_Compiler_Unit_Warning
=> -1,
25536 Pragma_Complete_Representation
=> 0,
25537 Pragma_Complex_Representation
=> 0,
25538 Pragma_Component_Alignment
=> 0,
25539 Pragma_Contract_Cases
=> -1,
25540 Pragma_Controlled
=> 0,
25541 Pragma_Convention
=> 0,
25542 Pragma_Convention_Identifier
=> 0,
25543 Pragma_Debug
=> -1,
25544 Pragma_Debug_Policy
=> 0,
25545 Pragma_Detect_Blocking
=> 0,
25546 Pragma_Default_Initial_Condition
=> -1,
25547 Pragma_Default_Scalar_Storage_Order
=> 0,
25548 Pragma_Default_Storage_Pool
=> 0,
25549 Pragma_Depends
=> -1,
25550 Pragma_Disable_Atomic_Synchronization
=> 0,
25551 Pragma_Discard_Names
=> 0,
25552 Pragma_Dispatching_Domain
=> -1,
25553 Pragma_Effective_Reads
=> 0,
25554 Pragma_Effective_Writes
=> 0,
25555 Pragma_Elaborate
=> 0,
25556 Pragma_Elaborate_All
=> 0,
25557 Pragma_Elaborate_Body
=> 0,
25558 Pragma_Elaboration_Checks
=> 0,
25559 Pragma_Eliminate
=> 0,
25560 Pragma_Enable_Atomic_Synchronization
=> 0,
25561 Pragma_Export
=> -1,
25562 Pragma_Export_Function
=> -1,
25563 Pragma_Export_Object
=> -1,
25564 Pragma_Export_Procedure
=> -1,
25565 Pragma_Export_Value
=> -1,
25566 Pragma_Export_Valued_Procedure
=> -1,
25567 Pragma_Extend_System
=> -1,
25568 Pragma_Extensions_Allowed
=> 0,
25569 Pragma_Extensions_Visible
=> 0,
25570 Pragma_External
=> -1,
25571 Pragma_Favor_Top_Level
=> 0,
25572 Pragma_External_Name_Casing
=> 0,
25573 Pragma_Fast_Math
=> 0,
25574 Pragma_Finalize_Storage_Only
=> 0,
25576 Pragma_Global
=> -1,
25577 Pragma_Ident
=> -1,
25578 Pragma_Implementation_Defined
=> -1,
25579 Pragma_Implemented
=> -1,
25580 Pragma_Implicit_Packing
=> 0,
25581 Pragma_Import
=> 93,
25582 Pragma_Import_Function
=> 0,
25583 Pragma_Import_Object
=> 0,
25584 Pragma_Import_Procedure
=> 0,
25585 Pragma_Import_Valued_Procedure
=> 0,
25586 Pragma_Independent
=> 0,
25587 Pragma_Independent_Components
=> 0,
25588 Pragma_Initial_Condition
=> -1,
25589 Pragma_Initialize_Scalars
=> 0,
25590 Pragma_Initializes
=> -1,
25591 Pragma_Inline
=> 0,
25592 Pragma_Inline_Always
=> 0,
25593 Pragma_Inline_Generic
=> 0,
25594 Pragma_Inspection_Point
=> -1,
25595 Pragma_Interface
=> 92,
25596 Pragma_Interface_Name
=> 0,
25597 Pragma_Interrupt_Handler
=> -1,
25598 Pragma_Interrupt_Priority
=> -1,
25599 Pragma_Interrupt_State
=> -1,
25600 Pragma_Invariant
=> -1,
25601 Pragma_Java_Constructor
=> -1,
25602 Pragma_Java_Interface
=> -1,
25603 Pragma_Keep_Names
=> 0,
25604 Pragma_License
=> 0,
25605 Pragma_Link_With
=> -1,
25606 Pragma_Linker_Alias
=> -1,
25607 Pragma_Linker_Constructor
=> -1,
25608 Pragma_Linker_Destructor
=> -1,
25609 Pragma_Linker_Options
=> -1,
25610 Pragma_Linker_Section
=> 0,
25612 Pragma_Lock_Free
=> 0,
25613 Pragma_Locking_Policy
=> 0,
25614 Pragma_Loop_Invariant
=> -1,
25615 Pragma_Loop_Optimize
=> 0,
25616 Pragma_Loop_Variant
=> -1,
25617 Pragma_Machine_Attribute
=> -1,
25619 Pragma_Main_Storage
=> -1,
25620 Pragma_Memory_Size
=> 0,
25621 Pragma_No_Return
=> 0,
25622 Pragma_No_Body
=> 0,
25623 Pragma_No_Elaboration_Code_All
=> 0,
25624 Pragma_No_Inline
=> 0,
25625 Pragma_No_Run_Time
=> -1,
25626 Pragma_No_Strict_Aliasing
=> -1,
25627 Pragma_No_Tagged_Streams
=> 0,
25628 Pragma_Normalize_Scalars
=> 0,
25629 Pragma_Obsolescent
=> 0,
25630 Pragma_Optimize
=> 0,
25631 Pragma_Optimize_Alignment
=> 0,
25632 Pragma_Overflow_Mode
=> 0,
25633 Pragma_Overriding_Renamings
=> 0,
25634 Pragma_Ordered
=> 0,
25637 Pragma_Part_Of
=> 0,
25638 Pragma_Partition_Elaboration_Policy
=> 0,
25639 Pragma_Passive
=> 0,
25640 Pragma_Persistent_BSS
=> 0,
25641 Pragma_Polling
=> 0,
25642 Pragma_Prefix_Exception_Messages
=> 0,
25644 Pragma_Postcondition
=> -1,
25645 Pragma_Post_Class
=> -1,
25647 Pragma_Precondition
=> -1,
25648 Pragma_Predicate
=> -1,
25649 Pragma_Preelaborable_Initialization
=> -1,
25650 Pragma_Preelaborate
=> 0,
25651 Pragma_Pre_Class
=> -1,
25652 Pragma_Priority
=> -1,
25653 Pragma_Priority_Specific_Dispatching
=> 0,
25654 Pragma_Profile
=> 0,
25655 Pragma_Profile_Warnings
=> 0,
25656 Pragma_Propagate_Exceptions
=> 0,
25657 Pragma_Provide_Shift_Operators
=> 0,
25658 Pragma_Psect_Object
=> 0,
25660 Pragma_Pure_Function
=> 0,
25661 Pragma_Queuing_Policy
=> 0,
25662 Pragma_Rational
=> 0,
25663 Pragma_Ravenscar
=> 0,
25664 Pragma_Refined_Depends
=> -1,
25665 Pragma_Refined_Global
=> -1,
25666 Pragma_Refined_Post
=> -1,
25667 Pragma_Refined_State
=> -1,
25668 Pragma_Relative_Deadline
=> 0,
25669 Pragma_Remote_Access_Type
=> -1,
25670 Pragma_Remote_Call_Interface
=> -1,
25671 Pragma_Remote_Types
=> -1,
25672 Pragma_Restricted_Run_Time
=> 0,
25673 Pragma_Restriction_Warnings
=> 0,
25674 Pragma_Restrictions
=> 0,
25675 Pragma_Reviewable
=> -1,
25676 Pragma_Short_Circuit_And_Or
=> 0,
25677 Pragma_Share_Generic
=> 0,
25678 Pragma_Shared
=> 0,
25679 Pragma_Shared_Passive
=> 0,
25680 Pragma_Short_Descriptors
=> 0,
25681 Pragma_Simple_Storage_Pool_Type
=> 0,
25682 Pragma_Source_File_Name
=> 0,
25683 Pragma_Source_File_Name_Project
=> 0,
25684 Pragma_Source_Reference
=> 0,
25685 Pragma_SPARK_Mode
=> 0,
25686 Pragma_Storage_Size
=> -1,
25687 Pragma_Storage_Unit
=> 0,
25688 Pragma_Static_Elaboration_Desired
=> 0,
25689 Pragma_Stream_Convert
=> 0,
25690 Pragma_Style_Checks
=> 0,
25691 Pragma_Subtitle
=> 0,
25692 Pragma_Suppress
=> 0,
25693 Pragma_Suppress_Exception_Locations
=> 0,
25694 Pragma_Suppress_All
=> 0,
25695 Pragma_Suppress_Debug_Info
=> 0,
25696 Pragma_Suppress_Initialization
=> 0,
25697 Pragma_System_Name
=> 0,
25698 Pragma_Task_Dispatching_Policy
=> 0,
25699 Pragma_Task_Info
=> -1,
25700 Pragma_Task_Name
=> -1,
25701 Pragma_Task_Storage
=> -1,
25702 Pragma_Test_Case
=> -1,
25703 Pragma_Thread_Local_Storage
=> -1,
25704 Pragma_Time_Slice
=> -1,
25706 Pragma_Type_Invariant
=> -1,
25707 Pragma_Type_Invariant_Class
=> -1,
25708 Pragma_Unchecked_Union
=> 0,
25709 Pragma_Unimplemented_Unit
=> 0,
25710 Pragma_Universal_Aliasing
=> 0,
25711 Pragma_Universal_Data
=> 0,
25712 Pragma_Unmodified
=> 0,
25713 Pragma_Unreferenced
=> 0,
25714 Pragma_Unreferenced_Objects
=> 0,
25715 Pragma_Unreserve_All_Interrupts
=> 0,
25716 Pragma_Unsuppress
=> 0,
25717 Pragma_Unevaluated_Use_Of_Old
=> 0,
25718 Pragma_Use_VADS_Size
=> 0,
25719 Pragma_Validity_Checks
=> 0,
25720 Pragma_Volatile
=> 0,
25721 Pragma_Volatile_Components
=> 0,
25722 Pragma_Warning_As_Error
=> 0,
25723 Pragma_Warnings
=> 0,
25724 Pragma_Weak_External
=> 0,
25725 Pragma_Wide_Character_Encoding
=> 0,
25726 Unknown_Pragma
=> 0);
25728 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
25734 function Arg_No
return Nat
;
25735 -- Returns an integer showing what argument we are in. A value of
25736 -- zero means we are not in any of the arguments.
25742 function Arg_No
return Nat
is
25747 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
25761 -- Start of processing for Non_Significant_Pragma_Reference
25766 if Nkind
(P
) /= N_Pragma_Argument_Association
then
25770 Id
:= Get_Pragma_Id
(Parent
(P
));
25771 C
:= Sig_Flags
(Id
);
25786 return AN
< (C
- 90);
25792 end Is_Non_Significant_Pragma_Reference
;
25794 ------------------------------
25795 -- Is_Pragma_String_Literal --
25796 ------------------------------
25798 -- This function returns true if the corresponding pragma argument is a
25799 -- static string expression. These are the only cases in which string
25800 -- literals can appear as pragma arguments. We also allow a string literal
25801 -- as the first argument to pragma Assert (although it will of course
25802 -- always generate a type error).
25804 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
25805 Pragn
: constant Node_Id
:= Parent
(Par
);
25806 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
25807 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
25813 N
:= First
(Assoc
);
25820 if Pname
= Name_Assert
then
25823 elsif Pname
= Name_Export
then
25826 elsif Pname
= Name_Ident
then
25829 elsif Pname
= Name_Import
then
25832 elsif Pname
= Name_Interface_Name
then
25835 elsif Pname
= Name_Linker_Alias
then
25838 elsif Pname
= Name_Linker_Section
then
25841 elsif Pname
= Name_Machine_Attribute
then
25844 elsif Pname
= Name_Source_File_Name
then
25847 elsif Pname
= Name_Source_Reference
then
25850 elsif Pname
= Name_Title
then
25853 elsif Pname
= Name_Subtitle
then
25859 end Is_Pragma_String_Literal
;
25861 ---------------------------
25862 -- Is_Private_SPARK_Mode --
25863 ---------------------------
25865 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
25868 (Nkind
(N
) = N_Pragma
25869 and then Pragma_Name
(N
) = Name_SPARK_Mode
25870 and then Is_List_Member
(N
));
25872 -- For pragma SPARK_Mode to be private, it has to appear in the private
25873 -- declarations of a package.
25876 Present
(Parent
(N
))
25877 and then Nkind
(Parent
(N
)) = N_Package_Specification
25878 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
25879 end Is_Private_SPARK_Mode
;
25881 -------------------------------------
25882 -- Is_Unconstrained_Or_Tagged_Item --
25883 -------------------------------------
25885 function Is_Unconstrained_Or_Tagged_Item
25886 (Item
: Entity_Id
) return Boolean
25888 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
25889 -- Determine whether record type Typ has at least one unconstrained
25892 ---------------------------------
25893 -- Has_Unconstrained_Component --
25894 ---------------------------------
25896 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
25900 Comp
:= First_Component
(Typ
);
25901 while Present
(Comp
) loop
25902 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
25906 Next_Component
(Comp
);
25910 end Has_Unconstrained_Component
;
25914 Typ
: constant Entity_Id
:= Etype
(Item
);
25916 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
25919 if Is_Tagged_Type
(Typ
) then
25922 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
25925 elsif Is_Record_Type
(Typ
) then
25926 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
25929 return Has_Unconstrained_Component
(Typ
);
25932 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
25938 end Is_Unconstrained_Or_Tagged_Item
;
25940 -----------------------------
25941 -- Is_Valid_Assertion_Kind --
25942 -----------------------------
25944 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
25951 Name_Static_Predicate |
25952 Name_Dynamic_Predicate |
25957 Name_Type_Invariant |
25958 Name_uType_Invariant |
25962 Name_Assert_And_Cut |
25964 Name_Contract_Cases |
25966 Name_Default_Initial_Condition |
25968 Name_Initial_Condition |
25971 Name_Loop_Invariant |
25972 Name_Loop_Variant |
25973 Name_Postcondition |
25974 Name_Precondition |
25976 Name_Refined_Post |
25977 Name_Statement_Assertions
=> return True;
25979 when others => return False;
25981 end Is_Valid_Assertion_Kind
;
25983 --------------------------------------
25984 -- Process_Compilation_Unit_Pragmas --
25985 --------------------------------------
25987 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
25989 -- A special check for pragma Suppress_All, a very strange DEC pragma,
25990 -- strange because it comes at the end of the unit. Rational has the
25991 -- same name for a pragma, but treats it as a program unit pragma, In
25992 -- GNAT we just decide to allow it anywhere at all. If it appeared then
25993 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
25994 -- node, and we insert a pragma Suppress (All_Checks) at the start of
25995 -- the context clause to ensure the correct processing.
25997 if Has_Pragma_Suppress_All
(N
) then
25998 Prepend_To
(Context_Items
(N
),
25999 Make_Pragma
(Sloc
(N
),
26000 Chars
=> Name_Suppress
,
26001 Pragma_Argument_Associations
=> New_List
(
26002 Make_Pragma_Argument_Association
(Sloc
(N
),
26003 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
26006 -- Nothing else to do at the current time
26008 end Process_Compilation_Unit_Pragmas
;
26010 ------------------------------------
26011 -- Record_Possible_Body_Reference --
26012 ------------------------------------
26014 procedure Record_Possible_Body_Reference
26015 (State_Id
: Entity_Id
;
26019 Spec_Id
: Entity_Id
;
26022 -- Ensure that we are dealing with a reference to a state
26024 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
26026 -- Climb the tree starting from the reference looking for a package body
26027 -- whose spec declares the referenced state. This criteria automatically
26028 -- excludes references in package specs which are legal. Note that it is
26029 -- not wise to emit an error now as the package body may lack pragma
26030 -- Refined_State or the referenced state may not be mentioned in the
26031 -- refinement. This approach avoids the generation of misleading errors.
26034 while Present
(Context
) loop
26035 if Nkind
(Context
) = N_Package_Body
then
26036 Spec_Id
:= Corresponding_Spec
(Context
);
26038 if Present
(Abstract_States
(Spec_Id
))
26039 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
26041 if No
(Body_References
(State_Id
)) then
26042 Set_Body_References
(State_Id
, New_Elmt_List
);
26045 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
26050 Context
:= Parent
(Context
);
26052 end Record_Possible_Body_Reference
;
26054 ------------------------------
26055 -- Relocate_Pragmas_To_Body --
26056 ------------------------------
26058 procedure Relocate_Pragmas_To_Body
26059 (Subp_Body
: Node_Id
;
26060 Target_Body
: Node_Id
:= Empty
)
26062 procedure Relocate_Pragma
(Prag
: Node_Id
);
26063 -- Remove a single pragma from its current list and add it to the
26064 -- declarations of the proper body (either Subp_Body or Target_Body).
26066 ---------------------
26067 -- Relocate_Pragma --
26068 ---------------------
26070 procedure Relocate_Pragma
(Prag
: Node_Id
) is
26075 -- When subprogram stubs or expression functions are involves, the
26076 -- destination declaration list belongs to the proper body.
26078 if Present
(Target_Body
) then
26079 Target
:= Target_Body
;
26081 Target
:= Subp_Body
;
26084 Decls
:= Declarations
(Target
);
26088 Set_Declarations
(Target
, Decls
);
26091 -- Unhook the pragma from its current list
26094 Prepend
(Prag
, Decls
);
26095 end Relocate_Pragma
;
26099 Body_Id
: constant Entity_Id
:=
26100 Defining_Unit_Name
(Specification
(Subp_Body
));
26101 Next_Stmt
: Node_Id
;
26104 -- Start of processing for Relocate_Pragmas_To_Body
26107 -- Do not process a body that comes from a separate unit as no construct
26108 -- can possibly follow it.
26110 if not Is_List_Member
(Subp_Body
) then
26113 -- Do not relocate pragmas that follow a stub if the stub does not have
26116 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
26117 and then No
(Target_Body
)
26121 -- Do not process internally generated routine _Postconditions
26123 elsif Ekind
(Body_Id
) = E_Procedure
26124 and then Chars
(Body_Id
) = Name_uPostconditions
26129 -- Look at what is following the body. We are interested in certain kind
26130 -- of pragmas (either from source or byproducts of expansion) that can
26131 -- apply to a body [stub].
26133 Stmt
:= Next
(Subp_Body
);
26134 while Present
(Stmt
) loop
26136 -- Preserve the following statement for iteration purposes due to a
26137 -- possible relocation of a pragma.
26139 Next_Stmt
:= Next
(Stmt
);
26141 -- Move a candidate pragma following the body to the declarations of
26144 if Nkind
(Stmt
) = N_Pragma
26145 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
26147 Relocate_Pragma
(Stmt
);
26149 -- Skip internally generated code
26151 elsif not Comes_From_Source
(Stmt
) then
26154 -- No candidate pragmas are available for relocation
26162 end Relocate_Pragmas_To_Body
;
26164 -------------------
26165 -- Resolve_State --
26166 -------------------
26168 procedure Resolve_State
(N
: Node_Id
) is
26173 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26174 Func
:= Entity
(N
);
26176 -- Handle overloading of state names by functions. Traverse the
26177 -- homonym chain looking for an abstract state.
26179 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
26180 State
:= Homonym
(Func
);
26181 while Present
(State
) loop
26183 -- Resolve the overloading by setting the proper entity of the
26184 -- reference to that of the state.
26186 if Ekind
(State
) = E_Abstract_State
then
26187 Set_Etype
(N
, Standard_Void_Type
);
26188 Set_Entity
(N
, State
);
26189 Set_Associated_Node
(N
, State
);
26193 State
:= Homonym
(State
);
26196 -- A function can never act as a state. If the homonym chain does
26197 -- not contain a corresponding state, then something went wrong in
26198 -- the overloading mechanism.
26200 raise Program_Error
;
26205 ----------------------------
26206 -- Rewrite_Assertion_Kind --
26207 ----------------------------
26209 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
26213 if Nkind
(N
) = N_Attribute_Reference
26214 and then Attribute_Name
(N
) = Name_Class
26215 and then Nkind
(Prefix
(N
)) = N_Identifier
26217 case Chars
(Prefix
(N
)) is
26222 when Name_Type_Invariant
=>
26223 Nam
:= Name_uType_Invariant
;
26224 when Name_Invariant
=>
26225 Nam
:= Name_uInvariant
;
26230 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
26232 end Rewrite_Assertion_Kind
;
26240 Dummy
:= Dummy
+ 1;
26243 --------------------------------
26244 -- Set_Encoded_Interface_Name --
26245 --------------------------------
26247 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
26248 Str
: constant String_Id
:= Strval
(S
);
26249 Len
: constant Int
:= String_Length
(Str
);
26254 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
26257 -- Stores encoded value of character code CC. The encoding we use an
26258 -- underscore followed by four lower case hex digits.
26264 procedure Encode
is
26266 Store_String_Char
(Get_Char_Code
('_'));
26268 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
26270 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
26272 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
26274 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
26277 -- Start of processing for Set_Encoded_Interface_Name
26280 -- If first character is asterisk, this is a link name, and we leave it
26281 -- completely unmodified. We also ignore null strings (the latter case
26282 -- happens only in error cases) and no encoding should occur for Java or
26283 -- AAMP interface names.
26286 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
26287 or else VM_Target
/= No_VM
26288 or else AAMP_On_Target
26290 Set_Interface_Name
(E
, S
);
26295 CC
:= Get_String_Char
(Str
, J
);
26297 exit when not In_Character_Range
(CC
);
26299 C
:= Get_Character
(CC
);
26301 exit when C
/= '_' and then C
/= '$'
26302 and then C
not in '0' .. '9'
26303 and then C
not in 'a' .. 'z'
26304 and then C
not in 'A' .. 'Z';
26307 Set_Interface_Name
(E
, S
);
26315 -- Here we need to encode. The encoding we use as follows:
26316 -- three underscores + four hex digits (lower case)
26320 for J
in 1 .. String_Length
(Str
) loop
26321 CC
:= Get_String_Char
(Str
, J
);
26323 if not In_Character_Range
(CC
) then
26326 C
:= Get_Character
(CC
);
26328 if C
= '_' or else C
= '$'
26329 or else C
in '0' .. '9'
26330 or else C
in 'a' .. 'z'
26331 or else C
in 'A' .. 'Z'
26333 Store_String_Char
(CC
);
26340 Set_Interface_Name
(E
,
26341 Make_String_Literal
(Sloc
(S
),
26342 Strval
=> End_String
));
26344 end Set_Encoded_Interface_Name
;
26346 ------------------------
26347 -- Set_Elab_Unit_Name --
26348 ------------------------
26350 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
26355 if Nkind
(N
) = N_Identifier
26356 and then Nkind
(With_Item
) = N_Identifier
26358 Set_Entity
(N
, Entity
(With_Item
));
26360 elsif Nkind
(N
) = N_Selected_Component
then
26361 Change_Selected_Component_To_Expanded_Name
(N
);
26362 Set_Entity
(N
, Entity
(With_Item
));
26363 Set_Entity
(Selector_Name
(N
), Entity
(N
));
26365 Pref
:= Prefix
(N
);
26366 Scop
:= Scope
(Entity
(N
));
26367 while Nkind
(Pref
) = N_Selected_Component
loop
26368 Change_Selected_Component_To_Expanded_Name
(Pref
);
26369 Set_Entity
(Selector_Name
(Pref
), Scop
);
26370 Set_Entity
(Pref
, Scop
);
26371 Pref
:= Prefix
(Pref
);
26372 Scop
:= Scope
(Scop
);
26375 Set_Entity
(Pref
, Scop
);
26378 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
26379 end Set_Elab_Unit_Name
;
26381 -------------------
26382 -- Test_Case_Arg --
26383 -------------------
26385 function Test_Case_Arg
26388 From_Aspect
: Boolean := False) return Node_Id
26390 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
26395 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
26400 -- The caller requests the aspect argument
26402 if From_Aspect
then
26403 if Present
(Aspect
)
26404 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
26406 Args
:= Expression
(Aspect
);
26408 -- "Name" and "Mode" may appear without an identifier as a
26409 -- positional association.
26411 if Present
(Expressions
(Args
)) then
26412 Arg
:= First
(Expressions
(Args
));
26414 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
26422 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
26427 -- Some or all arguments may appear as component associatons
26429 if Present
(Component_Associations
(Args
)) then
26430 Arg
:= First
(Component_Associations
(Args
));
26431 while Present
(Arg
) loop
26432 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
26441 -- Otherwise retrieve the argument directly from the pragma
26444 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
26446 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
26450 -- Skip argument "Name"
26454 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
26458 -- Skip argument "Mode"
26462 -- Arguments "Requires" and "Ensures" are optional and may not be
26465 while Present
(Arg
) loop
26466 if Chars
(Arg
) = Arg_Nam
then