1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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
;
45 with Lib
.Writ
; use Lib
.Writ
;
46 with Lib
.Xref
; use Lib
.Xref
;
47 with Namet
.Sp
; use Namet
.Sp
;
48 with Nlists
; use Nlists
;
49 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_VFpt
; use Sem_VFpt
;
73 with Sem_Warn
; use Sem_Warn
;
74 with Stand
; use Stand
;
75 with Sinfo
; use Sinfo
;
76 with Sinfo
.CN
; use Sinfo
.CN
;
77 with Sinput
; use Sinput
;
78 with Snames
; use Snames
;
79 with Stringt
; use Stringt
;
80 with Stylesw
; use Stylesw
;
82 with Targparm
; use Targparm
;
83 with Tbuild
; use Tbuild
;
85 with Uintp
; use Uintp
;
86 with Uname
; use Uname
;
87 with Urealp
; use Urealp
;
88 with Validsw
; use Validsw
;
89 with Warnsw
; use Warnsw
;
91 package body Sem_Prag
is
93 ----------------------------------------------
94 -- Common Handling of Import-Export Pragmas --
95 ----------------------------------------------
97 -- In the following section, a number of Import_xxx and Export_xxx pragmas
98 -- are defined by GNAT. These are compatible with the DEC pragmas of the
99 -- same name, and all have the following common form and processing:
102 -- [Internal =>] LOCAL_NAME
103 -- [, [External =>] EXTERNAL_SYMBOL]
104 -- [, other optional parameters ]);
107 -- [Internal =>] LOCAL_NAME
108 -- [, [External =>] EXTERNAL_SYMBOL]
109 -- [, other optional parameters ]);
111 -- EXTERNAL_SYMBOL ::=
113 -- | static_string_EXPRESSION
115 -- The internal LOCAL_NAME designates the entity that is imported or
116 -- exported, and must refer to an entity in the current declarative
117 -- part (as required by the rules for LOCAL_NAME).
119 -- The external linker name is designated by the External parameter if
120 -- given, or the Internal parameter if not (if there is no External
121 -- parameter, the External parameter is a copy of the Internal name).
123 -- If the External parameter is given as a string, then this string is
124 -- treated as an external name (exactly as though it had been given as an
125 -- External_Name parameter for a normal Import pragma).
127 -- If the External parameter is given as an identifier (or there is no
128 -- External parameter, so that the Internal identifier is used), then
129 -- the external name is the characters of the identifier, translated
130 -- to all upper case letters for OpenVMS versions of GNAT, and to all
131 -- lower case letters for all other versions
133 -- Note: the external name specified or implied by any of these special
134 -- Import_xxx or Export_xxx pragmas override an external or link name
135 -- specified in a previous Import or Export pragma.
137 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
138 -- named notation, following the standard rules for subprogram calls, i.e.
139 -- parameters can be given in any order if named notation is used, and
140 -- positional and named notation can be mixed, subject to the rule that all
141 -- positional parameters must appear first.
143 -- Note: All these pragmas are implemented exactly following the DEC design
144 -- and implementation and are intended to be fully compatible with the use
145 -- of these pragmas in the DEC Ada compiler.
147 --------------------------------------------
148 -- Checking for Duplicated External Names --
149 --------------------------------------------
151 -- It is suspicious if two separate Export pragmas use the same external
152 -- name. The following table is used to diagnose this situation so that
153 -- an appropriate warning can be issued.
155 -- The Node_Id stored is for the N_String_Literal node created to hold
156 -- the value of the external name. The Sloc of this node is used to
157 -- cross-reference the location of the duplication.
159 package Externals
is new Table
.Table
(
160 Table_Component_Type
=> Node_Id
,
161 Table_Index_Type
=> Int
,
162 Table_Low_Bound
=> 0,
163 Table_Initial
=> 100,
164 Table_Increment
=> 100,
165 Table_Name
=> "Name_Externals");
167 -------------------------------------
168 -- Local Subprograms and Variables --
169 -------------------------------------
171 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
);
172 -- Subsidiary routine to the analysis of pragmas Depends and Global. Append
173 -- an input or output item to a list. If the list is empty, a new one is
176 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
177 -- This routine is used for possible casing adjustment of an explicit
178 -- external name supplied as a string literal (the node N), according to
179 -- the casing requirement of Opt.External_Name_Casing. If this is set to
180 -- As_Is, then the string literal is returned unchanged, but if it is set
181 -- to Uppercase or Lowercase, then a new string literal with appropriate
182 -- casing is constructed.
184 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
185 -- Subsidiary to the analysis of pragma Global and pragma Depends. Query
186 -- whether a particular item appears in a mixed list of nodes and entities.
187 -- It is assumed that all nodes in the list have entities.
189 procedure Collect_Subprogram_Inputs_Outputs
190 (Subp_Id
: Entity_Id
;
191 Subp_Inputs
: in out Elist_Id
;
192 Subp_Outputs
: in out Elist_Id
;
193 Global_Seen
: out Boolean);
194 -- Subsidiary to the analysis of pragma Global and pragma Depends. Gather
195 -- all inputs and outputs of subprogram Subp_Id in lists Subp_Inputs and
196 -- Subp_Outputs. If the case where the subprogram has no inputs and/or
197 -- outputs, the corresponding returned list is No_Elist. Flag Global_Seen
198 -- is set when the related subprogram has aspect/pragma Global.
200 function Find_Related_Subprogram
202 Check_Duplicates
: Boolean := False) return Node_Id
;
203 -- Find the declaration of the related subprogram subject to pragma Prag.
204 -- If flag Check_Duplicates is set, the routine emits errors concerning
205 -- duplicate pragmas. If a related subprogram is found, then either the
206 -- corresponding N_Subprogram_Declaration node is returned, or, if the
207 -- pragma applies to a subprogram body, then the N_Subprogram_Body node
208 -- is returned. Note that in the latter case, no check is made to ensure
209 -- that there is no separate declaration of the subprogram.
211 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
212 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
213 -- original one, following the renaming chain) is returned. Otherwise the
214 -- entity is returned unchanged. Should be in Einfo???
216 function Get_SPARK_Mode_Id
(N
: Name_Id
) return SPARK_Mode_Id
;
217 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
218 -- Get_SPARK_Mode_Id. Convert a name into a corresponding value of type
221 function Original_Name
(N
: Node_Id
) return Name_Id
;
222 -- N is a pragma node or aspect specification node. This function returns
223 -- the name of the pragma or aspect in original source form, taking into
224 -- account possible rewrites, and also cases where a pragma comes from an
225 -- aspect (in such cases, the name can be different from the pragma name,
226 -- e.g. a Pre aspect generates a Precondition pragma). This also deals with
227 -- the presence of 'Class, which results in one of the special names
228 -- Name_uPre, Name_uPost, Name_uInvariant, or Name_uType_Invariant being
229 -- returned to represent the corresponding aspects with x'Class names.
231 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
);
232 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
233 -- of a Test_Case pragma if present (possibly Empty). We treat these as
234 -- spec expressions (i.e. similar to a default expression).
236 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
237 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
238 -- then it is rewritten as an identifier with the corresponding special
239 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas
240 -- Check, Check_Policy.
243 -- This is a dummy function called by the processing for pragma Reviewable.
244 -- It is there for assisting front end debugging. By placing a Reviewable
245 -- pragma in the source program, a breakpoint on rv catches this place in
246 -- the source, allowing convenient stepping to the point of interest.
248 function Requires_Profile_Installation
250 Subp
: Node_Id
) return Boolean;
251 -- Subsidiary routine to the analysis of pragma Depends and pragma Global.
252 -- Determine whether the profile of subprogram Subp must be installed into
253 -- visibility to access its formals from pragma Prag.
255 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
256 -- Place semantic information on the argument of an Elaborate/Elaborate_All
257 -- pragma. Entity name for unit and its parents is taken from item in
258 -- previous with_clause that mentions the unit.
264 procedure Add_Item
(Item
: Entity_Id
; To_List
: in out Elist_Id
) is
267 To_List
:= New_Elmt_List
;
270 Append_Unique_Elmt
(Item
, To_List
);
273 -------------------------------
274 -- Adjust_External_Name_Case --
275 -------------------------------
277 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
281 -- Adjust case of literal if required
283 if Opt
.External_Name_Exp_Casing
= As_Is
then
287 -- Copy existing string
293 for J
in 1 .. String_Length
(Strval
(N
)) loop
294 CC
:= Get_String_Char
(Strval
(N
), J
);
296 if Opt
.External_Name_Exp_Casing
= Uppercase
297 and then CC
>= Get_Char_Code
('a')
298 and then CC
<= Get_Char_Code
('z')
300 Store_String_Char
(CC
- 32);
302 elsif Opt
.External_Name_Exp_Casing
= Lowercase
303 and then CC
>= Get_Char_Code
('A')
304 and then CC
<= Get_Char_Code
('Z')
306 Store_String_Char
(CC
+ 32);
309 Store_String_Char
(CC
);
314 Make_String_Literal
(Sloc
(N
),
315 Strval
=> End_String
);
317 end Adjust_External_Name_Case
;
319 -----------------------------------------
320 -- Analyze_Contract_Cases_In_Decl_Part --
321 -----------------------------------------
323 procedure Analyze_Contract_Cases_In_Decl_Part
(N
: Node_Id
) is
324 Others_Seen
: Boolean := False;
326 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
327 -- Verify the legality of a single contract case
329 ---------------------------
330 -- Analyze_Contract_Case --
331 ---------------------------
333 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
334 Case_Guard
: Node_Id
;
336 Extra_Guard
: Node_Id
;
339 if Nkind
(CCase
) = N_Component_Association
then
340 Case_Guard
:= First
(Choices
(CCase
));
341 Conseq
:= Expression
(CCase
);
343 -- Each contract case must have exactly one case guard
345 Extra_Guard
:= Next
(Case_Guard
);
347 if Present
(Extra_Guard
) then
349 ("contract case may have only one case guard", Extra_Guard
);
352 -- Check the placement of "others" (if available)
354 if Nkind
(Case_Guard
) = N_Others_Choice
then
357 ("only one others choice allowed in aspect Contract_Cases",
363 elsif Others_Seen
then
365 ("others must be the last choice in aspect Contract_Cases",
369 -- Preanalyze the case guard and consequence
371 if Nkind
(Case_Guard
) /= N_Others_Choice
then
372 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
375 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
377 -- The contract case is malformed
380 Error_Msg_N
("wrong syntax in contract case", CCase
);
382 end Analyze_Contract_Case
;
386 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
392 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
397 Subp_Decl
:= Find_Related_Subprogram
(N
);
398 Subp_Id
:= Defining_Unit_Name
(Specification
(Subp_Decl
));
399 All_Cases
:= Expression
(Arg1
);
401 -- Multiple contract cases appear in aggregate form
403 if Nkind
(All_Cases
) = N_Aggregate
then
404 if No
(Component_Associations
(All_Cases
)) then
405 Error_Msg_N
("wrong syntax for aspect Contract_Cases", N
);
407 -- Individual contract cases appear as component associations
410 -- Ensure that the formal parameters are visible when analyzing
411 -- all clauses. This falls out of the general rule of aspects
412 -- pertaining to subprogram declarations. Skip the installation
413 -- for subprogram bodies because the formals are already visible.
415 if Requires_Profile_Installation
(N
, Subp_Decl
) then
416 Push_Scope
(Subp_Id
);
417 Install_Formals
(Subp_Id
);
420 CCase
:= First
(Component_Associations
(All_Cases
));
421 while Present
(CCase
) loop
422 Analyze_Contract_Case
(CCase
);
426 if Requires_Profile_Installation
(N
, Subp_Decl
) then
432 Error_Msg_N
("wrong syntax for aspect Contract_Cases", N
);
434 end Analyze_Contract_Cases_In_Decl_Part
;
436 ----------------------------------
437 -- Analyze_Depends_In_Decl_Part --
438 ----------------------------------
440 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
441 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
442 Loc
: constant Source_Ptr
:= Sloc
(N
);
444 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
445 -- A list containing the entities of all the inputs processed so far.
446 -- This Elist is populated with unique entities because the same input
447 -- may appear in multiple input lists.
449 Global_Seen
: Boolean := False;
450 -- A flag set when pragma Global has been processed
452 Outputs_Seen
: Elist_Id
:= No_Elist
;
453 -- A list containing the entities of all the outputs processed so far.
454 -- The elements of this list may come from different output lists.
456 Null_Output_Seen
: Boolean := False;
457 -- A flag used to track the legality of a null output
459 Result_Seen
: Boolean := False;
460 -- A flag set when Subp_Id'Result is processed
463 -- The entity of the subprogram subject to pragma Depends
465 Subp_Inputs
: Elist_Id
:= No_Elist
;
466 Subp_Outputs
: Elist_Id
:= No_Elist
;
467 -- Two lists containing the full set of inputs and output of the related
468 -- subprograms. Note that these lists contain both nodes and entities.
470 procedure Analyze_Dependency_Clause
473 -- Verify the legality of a single dependency clause. Flag Is_Last
474 -- denotes whether Clause is the last clause in the relation.
476 procedure Check_Function_Return
;
477 -- Verify that Funtion'Result appears as one of the outputs
484 -- Ensure that an item has a proper "in", "in out" or "out" mode
485 -- depending on its function. If this is not the case, emit an error.
486 -- Item and Item_Id denote the attributes of an item. Flag Is_Input
487 -- should be set when item comes from an input list. Flag Self_Ref
488 -- should be set when the item is an output and the dependency clause
491 procedure Check_Usage
492 (Subp_Items
: Elist_Id
;
493 Used_Items
: Elist_Id
;
495 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
496 -- error if this is not the case.
498 procedure Normalize_Clause
(Clause
: Node_Id
);
499 -- Remove a self-dependency "+" from the input list of a clause.
500 -- Depending on the contents of the relation, either split the the
501 -- clause into multiple smaller clauses or perform the normalization in
504 -------------------------------
505 -- Analyze_Dependency_Clause --
506 -------------------------------
508 procedure Analyze_Dependency_Clause
512 procedure Analyze_Input_List
(Inputs
: Node_Id
);
513 -- Verify the legality of a single input list
515 procedure Analyze_Input_Output
520 Seen
: in out Elist_Id
;
521 Null_Seen
: in out Boolean);
522 -- Verify the legality of a single input or output item. Flag
523 -- Is_Input should be set whenever Item is an input, False when it
524 -- denotes an output. Flag Self_Ref should be set when the item is an
525 -- output and the dependency clause has a "+". Flag Top_Level should
526 -- be set whenever Item appears immediately within an input or output
527 -- list. Seen is a collection of all abstract states, variables and
528 -- formals processed so far. Flag Null_Seen denotes whether a null
529 -- input or output has been encountered.
531 ------------------------
532 -- Analyze_Input_List --
533 ------------------------
535 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
536 Inputs_Seen
: Elist_Id
:= No_Elist
;
537 -- A list containing the entities of all inputs that appear in the
538 -- current input list.
540 Null_Input_Seen
: Boolean := False;
541 -- A flag used to track the legality of a null input
546 -- Multiple inputs appear as an aggregate
548 if Nkind
(Inputs
) = N_Aggregate
then
549 if Present
(Component_Associations
(Inputs
)) then
551 ("nested dependency relations not allowed", Inputs
);
553 elsif Present
(Expressions
(Inputs
)) then
554 Input
:= First
(Expressions
(Inputs
));
555 while Present
(Input
) loop
562 Null_Seen
=> Null_Input_Seen
);
568 Error_Msg_N
("malformed input dependency list", Inputs
);
571 -- Process a solitary input
580 Null_Seen
=> Null_Input_Seen
);
583 -- Detect an illegal dependency clause of the form
587 if Null_Output_Seen
and then Null_Input_Seen
then
589 ("null dependency clause cannot have a null input list",
592 end Analyze_Input_List
;
594 --------------------------
595 -- Analyze_Input_Output --
596 --------------------------
598 procedure Analyze_Input_Output
603 Seen
: in out Elist_Id
;
604 Null_Seen
: in out Boolean)
606 Is_Output
: constant Boolean := not Is_Input
;
611 -- Multiple input or output items appear as an aggregate
613 if Nkind
(Item
) = N_Aggregate
then
614 if not Top_Level
then
615 Error_Msg_N
("nested grouping of items not allowed", Item
);
617 elsif Present
(Component_Associations
(Item
)) then
619 ("nested dependency relations not allowed", Item
);
621 -- Recursively analyze the grouped items
623 elsif Present
(Expressions
(Item
)) then
624 Grouped
:= First
(Expressions
(Item
));
625 while Present
(Grouped
) loop
628 Is_Input
=> Is_Input
,
629 Self_Ref
=> Self_Ref
,
632 Null_Seen
=> Null_Seen
);
638 Error_Msg_N
("malformed dependency list", Item
);
641 -- Process Function'Result in the context of a dependency clause
643 elsif Nkind
(Item
) = N_Attribute_Reference
644 and then Attribute_Name
(Item
) = Name_Result
646 -- It is sufficent to analyze the prefix of 'Result in order to
647 -- establish legality of the attribute.
649 Analyze
(Prefix
(Item
));
651 -- The prefix of 'Result must denote the function for which
652 -- aspect/pragma Depends applies.
654 if not Is_Entity_Name
(Prefix
(Item
))
655 or else Ekind
(Subp_Id
) /= E_Function
656 or else Entity
(Prefix
(Item
)) /= Subp_Id
658 Error_Msg_Name_1
:= Name_Result
;
660 ("prefix of attribute % must denote the enclosing "
663 -- Function'Result is allowed to appear on the output side of a
664 -- dependency clause.
667 Error_Msg_N
("function result cannot act as input", Item
);
673 -- Detect multiple uses of null in a single dependency list or
674 -- throughout the whole relation. Verify the placement of a null
675 -- output list relative to the other clauses.
677 elsif Nkind
(Item
) = N_Null
then
680 ("multiple null dependency relations not allowed", Item
);
684 if Is_Output
and then not Is_Last
then
686 ("null output list must be the last clause in a "
687 & "dependency relation", Item
);
696 -- Find the entity of the item. If this is a renaming, climb
697 -- the renaming chain to reach the root object. Renamings of
698 -- non-entire objects do not yield an entity (Empty).
700 Item_Id
:= Entity_Of
(Item
);
702 if Present
(Item_Id
) then
703 if Ekind_In
(Item_Id
, E_Abstract_State
,
709 -- Ensure that the item is of the correct mode depending
712 Check_Mode
(Item
, Item_Id
, Is_Input
, Self_Ref
);
714 -- Detect multiple uses of the same state, variable or
715 -- formal parameter. If this is not the case, add the
716 -- item to the list of processed relations.
718 if Contains
(Seen
, Item_Id
) then
719 Error_Msg_N
("duplicate use of item", Item
);
721 Add_Item
(Item_Id
, Seen
);
724 -- Detect an illegal use of an input related to a null
725 -- output. Such input items cannot appear in other input
729 and then Contains
(All_Inputs_Seen
, Item_Id
)
732 ("input of a null output list appears in multiple "
733 & "input lists", Item
);
735 Add_Item
(Item_Id
, All_Inputs_Seen
);
738 -- When the item renames an entire object, replace the
739 -- item with a reference to the object.
741 if Present
(Renamed_Object
(Entity
(Item
))) then
743 New_Reference_To
(Item_Id
, Sloc
(Item
)));
747 -- All other input/output items are illegal
751 ("item must denote variable, state or formal "
752 & "parameter", Item
);
755 -- All other input/output items are illegal
759 ("item must denote variable, state or formal parameter",
763 end Analyze_Input_Output
;
771 -- Start of processing for Analyze_Dependency_Clause
774 Inputs
:= Expression
(Clause
);
777 -- An input list with a self-dependency appears as operator "+" where
778 -- the actuals inputs are the right operand.
780 if Nkind
(Inputs
) = N_Op_Plus
then
781 Inputs
:= Right_Opnd
(Inputs
);
785 -- Process the output_list of a dependency_clause
787 Output
:= First
(Choices
(Clause
));
788 while Present
(Output
) loop
792 Self_Ref
=> Self_Ref
,
794 Seen
=> Outputs_Seen
,
795 Null_Seen
=> Null_Output_Seen
);
800 -- Process the input_list of a dependency_clause
802 Analyze_Input_List
(Inputs
);
803 end Analyze_Dependency_Clause
;
805 ----------------------------
806 -- Check_Function_Return --
807 ----------------------------
809 procedure Check_Function_Return
is
811 if Ekind
(Subp_Id
) = E_Function
and then not Result_Seen
then
813 ("result of & must appear in exactly one output list",
816 end Check_Function_Return
;
832 if Ekind
(Item_Id
) = E_Out_Parameter
834 and then not Appears_In
(Subp_Inputs
, Item_Id
))
837 ("item & must have mode in or in out", Item
, Item_Id
);
840 -- Self-referential output
844 -- A self-referential state or variable must appear in both input
845 -- and output lists of a subprogram.
847 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
850 (Appears_In
(Subp_Inputs
, Item_Id
)
852 Appears_In
(Subp_Outputs
, Item_Id
))
854 Error_Msg_NE
("item & must have mode in out", Item
, Item_Id
);
857 -- Self-referential parameter
859 elsif Ekind
(Item_Id
) /= E_In_Out_Parameter
then
860 Error_Msg_NE
("item & must have mode in out", Item
, Item_Id
);
865 elsif Ekind
(Item_Id
) = E_In_Parameter
867 (Global_Seen
and then not Appears_In
(Subp_Outputs
, Item_Id
))
870 ("item & must have mode out or in out", Item
, Item_Id
);
878 procedure Check_Usage
879 (Subp_Items
: Elist_Id
;
880 Used_Items
: Elist_Id
;
883 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
);
884 -- Emit an error concerning the erroneous usage of an item
890 procedure Usage_Error
(Item
: Node_Id
; Item_Id
: Entity_Id
) is
894 ("item & must appear in at least one input list of aspect "
895 & "Depends", Item
, Item_Id
);
898 ("item & must appear in exactly one output list of aspect "
899 & "Depends", Item
, Item_Id
);
909 -- Start of processing for Check_Usage
912 if No
(Subp_Items
) then
916 -- Each input or output of the subprogram must appear in a dependency
919 Elmt
:= First_Elmt
(Subp_Items
);
920 while Present
(Elmt
) loop
923 if Nkind
(Item
) = N_Defining_Identifier
then
926 Item_Id
:= Entity
(Item
);
929 -- The item does not appear in a dependency
931 if not Contains
(Used_Items
, Item_Id
) then
932 if Is_Formal
(Item_Id
) then
933 Usage_Error
(Item
, Item_Id
);
935 -- States and global variables are not used properly only when
936 -- the subprogram is subject to pragma Global.
938 elsif Global_Seen
then
939 Usage_Error
(Item
, Item_Id
);
947 ----------------------
948 -- Normalize_Clause --
949 ----------------------
951 procedure Normalize_Clause
(Clause
: Node_Id
) is
952 procedure Create_Or_Modify_Clause
959 -- Create a brand new clause to represent the self-reference or
960 -- modify the input and/or output lists of an existing clause. Output
961 -- denotes a self-referencial output. Outputs is the output list of a
962 -- clause. Inputs is the input list of a clause. After denotes the
963 -- clause after which the new clause is to be inserted. Flag In_Place
964 -- should be set when normalizing the last output of an output list.
965 -- Flag Multiple should be set when Output comes from a list with
968 -----------------------------
969 -- Create_Or_Modify_Clause --
970 -----------------------------
972 procedure Create_Or_Modify_Clause
980 procedure Propagate_Output
983 -- Handle the various cases of output propagation to the input
984 -- list. Output denotes a self-referencial output item. Inputs is
985 -- the input list of a clause.
987 ----------------------
988 -- Propagate_Output --
989 ----------------------
991 procedure Propagate_Output
995 function In_Input_List
997 Inputs
: List_Id
) return Boolean;
998 -- Determine whether a particulat item appears in the input
1005 function In_Input_List
1007 Inputs
: List_Id
) return Boolean
1012 Elmt
:= First
(Inputs
);
1013 while Present
(Elmt
) loop
1014 if Entity_Of
(Elmt
) = Item
then
1026 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1029 -- Start of processing for Propagate_Output
1032 -- The clause is of the form:
1034 -- (Output =>+ null)
1036 -- Remove the null input and replace it with a copy of the
1039 -- (Output => Output)
1041 if Nkind
(Inputs
) = N_Null
then
1042 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1044 -- The clause is of the form:
1046 -- (Output =>+ (Input1, ..., InputN))
1048 -- Determine whether the output is not already mentioned in the
1049 -- input list and if not, add it to the list of inputs:
1051 -- (Output => (Output, Input1, ..., InputN))
1053 elsif Nkind
(Inputs
) = N_Aggregate
then
1054 Grouped
:= Expressions
(Inputs
);
1056 if not In_Input_List
1060 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1063 -- The clause is of the form:
1065 -- (Output =>+ Input)
1067 -- If the input does not mention the output, group the two
1070 -- (Output => (Output, Input))
1072 elsif Entity_Of
(Inputs
) /= Output_Id
then
1074 Make_Aggregate
(Loc
,
1075 Expressions
=> New_List
(
1076 New_Copy_Tree
(Output
),
1077 New_Copy_Tree
(Inputs
))));
1079 end Propagate_Output
;
1083 Loc
: constant Source_Ptr
:= Sloc
(Output
);
1086 -- Start of processing for Create_Or_Modify_Clause
1089 -- A function result cannot depend on itself because it cannot
1090 -- appear in the input list of a relation.
1092 if Nkind
(Output
) = N_Attribute_Reference
1093 and then Attribute_Name
(Output
) = Name_Result
1095 Error_Msg_N
("function result cannot depend on itself", Output
);
1098 -- A null output depending on itself does not require any
1101 elsif Nkind
(Output
) = N_Null
then
1105 -- When performing the transformation in place, simply add the
1106 -- output to the list of inputs (if not already there). This case
1107 -- arises when dealing with the last output of an output list -
1108 -- we perform the normalization in place to avoid generating a
1112 Propagate_Output
(Output
, Inputs
);
1114 -- A list with multiple outputs is slowly trimmed until only
1115 -- one element remains. When this happens, replace the
1116 -- aggregate with the element itself.
1120 Rewrite
(Outputs
, Output
);
1126 -- Unchain the output from its output list as it will appear in
1127 -- a new clause. Note that we cannot simply rewrite the output
1128 -- as null because this will violate the semantics of aspect or
1133 -- Create a new clause of the form:
1135 -- (Output => Inputs)
1138 Make_Component_Association
(Loc
,
1139 Choices
=> New_List
(Output
),
1140 Expression
=> New_Copy_Tree
(Inputs
));
1142 -- The new clause contains replicated content that has already
1143 -- been analyzed. There is not need to reanalyze it or
1144 -- renormalize it again.
1146 Set_Analyzed
(Clause
);
1149 (Output
=> First
(Choices
(Clause
)),
1150 Inputs
=> Expression
(Clause
));
1152 Insert_After
(After
, Clause
);
1154 end Create_Or_Modify_Clause
;
1158 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1160 Last_Output
: Node_Id
;
1161 Next_Output
: Node_Id
;
1164 -- Start of processing for Normalize_Clause
1167 -- A self-dependency appears as operator "+". Remove the "+" from the
1168 -- tree by moving the real inputs to their proper place.
1170 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1171 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1172 Inputs
:= Expression
(Clause
);
1174 -- Multiple outputs appear as an aggregate
1176 if Nkind
(Outputs
) = N_Aggregate
then
1177 Last_Output
:= Last
(Expressions
(Outputs
));
1179 Output
:= First
(Expressions
(Outputs
));
1180 while Present
(Output
) loop
1182 -- Normalization may remove an output from its list,
1183 -- preserve the subsequent output now.
1185 Next_Output
:= Next
(Output
);
1187 Create_Or_Modify_Clause
1192 In_Place
=> Output
= Last_Output
,
1195 Output
:= Next_Output
;
1201 Create_Or_Modify_Clause
1210 end Normalize_Clause
;
1216 Last_Clause
: Node_Id
;
1217 Subp_Decl
: Node_Id
;
1219 -- Start of processing for Analyze_Depends_In_Decl_Part
1224 Subp_Decl
:= Find_Related_Subprogram
(N
);
1225 Subp_Id
:= Defining_Unit_Name
(Specification
(Subp_Decl
));
1226 Clause
:= Expression
(Arg1
);
1228 -- Empty dependency list
1230 if Nkind
(Clause
) = N_Null
then
1232 -- Gather all states, variables and formal parameters that the
1233 -- subprogram may depend on. These items are obtained from the
1234 -- parameter profile or pragma Global (if available).
1236 Collect_Subprogram_Inputs_Outputs
1237 (Subp_Id
=> Subp_Id
,
1238 Subp_Inputs
=> Subp_Inputs
,
1239 Subp_Outputs
=> Subp_Outputs
,
1240 Global_Seen
=> Global_Seen
);
1242 -- Verify that every input or output of the subprogram appear in a
1245 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1246 Check_Usage
(Subp_Outputs
, Outputs_Seen
, False);
1247 Check_Function_Return
;
1249 -- Dependency clauses appear as component associations of an aggregate
1251 elsif Nkind
(Clause
) = N_Aggregate
1252 and then Present
(Component_Associations
(Clause
))
1254 Last_Clause
:= Last
(Component_Associations
(Clause
));
1256 -- Gather all states, variables and formal parameters that the
1257 -- subprogram may depend on. These items are obtained from the
1258 -- parameter profile or pragma Global (if available).
1260 Collect_Subprogram_Inputs_Outputs
1261 (Subp_Id
=> Subp_Id
,
1262 Subp_Inputs
=> Subp_Inputs
,
1263 Subp_Outputs
=> Subp_Outputs
,
1264 Global_Seen
=> Global_Seen
);
1266 -- Ensure that the formal parameters are visible when analyzing all
1267 -- clauses. This falls out of the general rule of aspects pertaining
1268 -- to subprogram declarations. Skip the installation for subprogram
1269 -- bodies because the formals are already visible.
1271 if Requires_Profile_Installation
(N
, Subp_Decl
) then
1272 Push_Scope
(Subp_Id
);
1273 Install_Formals
(Subp_Id
);
1276 Clause
:= First
(Component_Associations
(Clause
));
1277 while Present
(Clause
) loop
1278 Errors
:= Serious_Errors_Detected
;
1280 -- Normalization may create extra clauses that contain replicated
1281 -- input and output names. There is no need to reanalyze or
1282 -- renormalize these extra clauses.
1284 if not Analyzed
(Clause
) then
1285 Set_Analyzed
(Clause
);
1287 Analyze_Dependency_Clause
1289 Is_Last
=> Clause
= Last_Clause
);
1291 -- Do not normalize an erroneous clause because the inputs or
1292 -- outputs may denote illegal items.
1294 if Errors
= Serious_Errors_Detected
then
1295 Normalize_Clause
(Clause
);
1302 if Requires_Profile_Installation
(N
, Subp_Decl
) then
1306 -- Verify that every input or output of the subprogram appear in a
1309 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1310 Check_Usage
(Subp_Outputs
, Outputs_Seen
, False);
1311 Check_Function_Return
;
1313 -- The top level dependency relation is malformed
1316 Error_Msg_N
("malformed dependency relation", Clause
);
1318 end Analyze_Depends_In_Decl_Part
;
1320 ---------------------------------
1321 -- Analyze_Global_In_Decl_Part --
1322 ---------------------------------
1324 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
1325 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1327 Seen
: Elist_Id
:= No_Elist
;
1328 -- A list containing the entities of all the items processed so far. It
1329 -- plays a role in detecting distinct entities.
1331 Subp_Id
: Entity_Id
;
1332 -- The entity of the subprogram subject to pragma Global
1334 Contract_Seen
: Boolean := False;
1335 In_Out_Seen
: Boolean := False;
1336 Input_Seen
: Boolean := False;
1337 Output_Seen
: Boolean := False;
1338 -- Flags used to verify the consistency of modes
1340 procedure Analyze_Global_List
1342 Global_Mode
: Name_Id
:= Name_Input
);
1343 -- Verify the legality of a single global list declaration. Global_Mode
1344 -- denotes the current mode in effect.
1346 -------------------------
1347 -- Analyze_Global_List --
1348 -------------------------
1350 procedure Analyze_Global_List
1352 Global_Mode
: Name_Id
:= Name_Input
)
1354 procedure Analyze_Global_Item
1356 Global_Mode
: Name_Id
);
1357 -- Verify the legality of a single global item declaration.
1358 -- Global_Mode denotes the current mode in effect.
1360 procedure Check_Duplicate_Mode
1362 Status
: in out Boolean);
1363 -- Flag Status denotes whether a particular mode has been seen while
1364 -- processing a global list. This routine verifies that Mode is not a
1365 -- duplicate mode and sets the flag Status.
1367 procedure Check_Mode_Restriction_In_Enclosing_Context
1369 Item_Id
: Entity_Id
);
1370 -- Verify that an item of mode In_Out or Output does not appear as an
1371 -- input in the Global aspect of an enclosing subprogram. If this is
1372 -- the case, emit an error. Item and Item_Id are respectively the
1373 -- item and its entity.
1375 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
1376 -- Mode denotes either In_Out or Output. Depending on the kind of the
1377 -- related subprogram, emit an error if those two modes apply to a
1380 -------------------------
1381 -- Analyze_Global_Item --
1382 -------------------------
1384 procedure Analyze_Global_Item
1386 Global_Mode
: Name_Id
)
1388 Item_Id
: Entity_Id
;
1391 -- Detect one of the following cases
1393 -- with Global => (null, Name)
1394 -- with Global => (Name_1, null, Name_2)
1395 -- with Global => (Name, null)
1397 if Nkind
(Item
) = N_Null
then
1398 Error_Msg_N
("cannot mix null and non-null global items", Item
);
1404 -- Find the entity of the item. If this is a renaming, climb the
1405 -- renaming chain to reach the root object. Renamings of non-
1406 -- entire objects do not yield an entity (Empty).
1408 Item_Id
:= Entity_Of
(Item
);
1410 if Present
(Item_Id
) then
1412 -- A global item cannot reference a formal parameter. Do this
1413 -- check first to provide a better error diagnostic.
1415 if Is_Formal
(Item_Id
) then
1417 ("global item cannot reference formal parameter", Item
);
1420 -- The only legal references are those to abstract states and
1423 elsif not Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
1425 ("global item must denote variable or state", Item
);
1429 -- When the item renames an entire object, replace the item
1430 -- with a reference to the object.
1432 if Present
(Renamed_Object
(Entity
(Item
))) then
1433 Rewrite
(Item
, New_Reference_To
(Item_Id
, Sloc
(Item
)));
1437 -- Some form of illegal construct masquerading as a name
1440 Error_Msg_N
("global item must denote variable or state", Item
);
1444 -- At this point we know that the global item is one of the two
1445 -- valid choices. Perform mode- and usage-specific checks.
1447 if Ekind
(Item_Id
) = E_Abstract_State
1448 and then Is_Volatile_State
(Item_Id
)
1450 -- A global item of mode In_Out or Output cannot denote a
1451 -- volatile Input state.
1453 if Is_Input_State
(Item_Id
)
1454 and then Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
)
1457 ("global item of mode In_Out or Output cannot reference "
1458 & "Volatile Input state", Item
);
1460 -- A global item of mode In_Out or Input cannot reference a
1461 -- volatile Output state.
1463 elsif Is_Output_State
(Item_Id
)
1464 and then Nam_In
(Global_Mode
, Name_In_Out
, Name_Input
)
1467 ("global item of mode In_Out or Input cannot reference "
1468 & "Volatile Output state", Item
);
1472 -- Verify that an output does not appear as an input in an
1473 -- enclosing subprogram.
1475 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
1476 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
1479 -- The same entity might be referenced through various way. Check
1480 -- the entity of the item rather than the item itself.
1482 if Contains
(Seen
, Item_Id
) then
1483 Error_Msg_N
("duplicate global item", Item
);
1485 -- Add the entity of the current item to the list of processed
1489 Add_Item
(Item_Id
, Seen
);
1491 end Analyze_Global_Item
;
1493 --------------------------
1494 -- Check_Duplicate_Mode --
1495 --------------------------
1497 procedure Check_Duplicate_Mode
1499 Status
: in out Boolean)
1503 Error_Msg_N
("duplicate global mode", Mode
);
1507 end Check_Duplicate_Mode
;
1509 -------------------------------------------------
1510 -- Check_Mode_Restriction_In_Enclosing_Context --
1511 -------------------------------------------------
1513 procedure Check_Mode_Restriction_In_Enclosing_Context
1515 Item_Id
: Entity_Id
)
1518 Inputs
: Elist_Id
:= No_Elist
;
1519 Outputs
: Elist_Id
:= No_Elist
;
1520 Subp_Id
: Entity_Id
;
1523 -- Traverse the scope stack looking for enclosing subprograms
1524 -- subject to aspect/pragma Global.
1526 Subp_Id
:= Scope
(Current_Scope
);
1527 while Present
(Subp_Id
) and then Subp_Id
/= Standard_Standard
loop
1528 if Is_Subprogram
(Subp_Id
)
1529 and then Has_Aspect
(Subp_Id
, Aspect_Global
)
1531 Collect_Subprogram_Inputs_Outputs
1532 (Subp_Id
=> Subp_Id
,
1533 Subp_Inputs
=> Inputs
,
1534 Subp_Outputs
=> Outputs
,
1535 Global_Seen
=> Dummy
);
1537 -- The item is classified as In_Out or Output but appears as
1538 -- an Input in an enclosing subprogram.
1540 if Appears_In
(Inputs
, Item_Id
)
1541 and then not Appears_In
(Outputs
, Item_Id
)
1544 ("global item & cannot have mode In_Out or Output",
1547 ("\item already appears as input of subprogram &",
1552 Subp_Id
:= Scope
(Subp_Id
);
1554 end Check_Mode_Restriction_In_Enclosing_Context
;
1556 ----------------------------------------
1557 -- Check_Mode_Restriction_In_Function --
1558 ----------------------------------------
1560 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
1562 if Ekind
(Subp_Id
) = E_Function
then
1564 ("global mode & not applicable to functions", Mode
);
1566 end Check_Mode_Restriction_In_Function
;
1574 -- Start of processing for Analyze_Global_List
1577 -- Single global item declaration
1579 if Nkind_In
(List
, N_Identifier
, N_Selected_Component
) then
1580 Analyze_Global_Item
(List
, Global_Mode
);
1582 -- Simple global list or moded global list declaration
1584 elsif Nkind
(List
) = N_Aggregate
then
1586 -- The declaration of a simple global list appear as a collection
1589 if Present
(Expressions
(List
)) then
1590 if Present
(Component_Associations
(List
)) then
1592 ("cannot mix moded and non-moded global lists", List
);
1595 Item
:= First
(Expressions
(List
));
1596 while Present
(Item
) loop
1597 Analyze_Global_Item
(Item
, Global_Mode
);
1602 -- The declaration of a moded global list appears as a collection
1603 -- of component associations where individual choices denote
1606 elsif Present
(Component_Associations
(List
)) then
1607 if Present
(Expressions
(List
)) then
1609 ("cannot mix moded and non-moded global lists", List
);
1612 Assoc
:= First
(Component_Associations
(List
));
1613 while Present
(Assoc
) loop
1614 Mode
:= First
(Choices
(Assoc
));
1616 if Nkind
(Mode
) = N_Identifier
then
1617 if Chars
(Mode
) = Name_Contract_In
then
1618 Check_Duplicate_Mode
(Mode
, Contract_Seen
);
1620 elsif Chars
(Mode
) = Name_In_Out
then
1621 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
1622 Check_Mode_Restriction_In_Function
(Mode
);
1624 elsif Chars
(Mode
) = Name_Input
then
1625 Check_Duplicate_Mode
(Mode
, Input_Seen
);
1627 elsif Chars
(Mode
) = Name_Output
then
1628 Check_Duplicate_Mode
(Mode
, Output_Seen
);
1629 Check_Mode_Restriction_In_Function
(Mode
);
1632 Error_Msg_N
("invalid mode selector", Mode
);
1636 Error_Msg_N
("invalid mode selector", Mode
);
1639 -- Items in a moded list appear as a collection of
1640 -- expressions. Reuse the existing machinery to analyze
1644 (List
=> Expression
(Assoc
),
1645 Global_Mode
=> Chars
(Mode
));
1650 -- Something went horribly wrong, we have a malformed tree
1653 raise Program_Error
;
1656 -- Any other attempt to declare a global item is erroneous
1659 Error_Msg_N
("malformed global list declaration", List
);
1661 end Analyze_Global_List
;
1666 Subp_Decl
: Node_Id
;
1668 -- Start of processing for Analyze_Global_In_Decl_List
1673 Subp_Decl
:= Find_Related_Subprogram
(N
);
1674 Subp_Id
:= Defining_Unit_Name
(Specification
(Subp_Decl
));
1675 List
:= Expression
(Arg1
);
1677 -- There is nothing to be done for a null global list
1679 if Nkind
(List
) = N_Null
then
1682 -- Analyze the various forms of global lists and items. Note that some
1683 -- of these may be malformed in which case the analysis emits error
1687 -- Ensure that the formal parameters are visible when processing an
1688 -- item. This falls out of the general rule of aspects pertaining to
1689 -- subprogram declarations.
1691 if Requires_Profile_Installation
(N
, Subp_Decl
) then
1692 Push_Scope
(Subp_Id
);
1693 Install_Formals
(Subp_Id
);
1696 Analyze_Global_List
(List
);
1698 if Requires_Profile_Installation
(N
, Subp_Decl
) then
1702 end Analyze_Global_In_Decl_Part
;
1704 ------------------------------
1705 -- Analyze_PPC_In_Decl_Part --
1706 ------------------------------
1708 procedure Analyze_PPC_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
1709 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1712 -- Install formals and push subprogram spec onto scope stack so that we
1713 -- can see the formals from the pragma.
1715 Install_Formals
(S
);
1718 -- Preanalyze the boolean expression, we treat this as a spec expression
1719 -- (i.e. similar to a default expression).
1721 -- In ASIS mode, for a pragma generated from a source aspect, analyze
1722 -- directly the the original aspect expression, which is shared with
1723 -- the generated pragma.
1725 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
1726 Preanalyze_Assert_Expression
1727 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
1729 Preanalyze_Assert_Expression
1730 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
1733 -- For a class-wide condition, a reference to a controlling formal must
1734 -- be interpreted as having the class-wide type (or an access to such)
1735 -- so that the inherited condition can be properly applied to any
1736 -- overriding operation (see ARM12 6.6.1 (7)).
1738 if Class_Present
(N
) then
1739 Class_Wide_Condition
: declare
1740 T
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
1742 ACW
: Entity_Id
:= Empty
;
1743 -- Access to T'class, created if there is a controlling formal
1744 -- that is an access parameter.
1746 function Get_ACW
return Entity_Id
;
1747 -- If the expression has a reference to an controlling access
1748 -- parameter, create an access to T'class for the necessary
1749 -- conversions if one does not exist.
1751 function Process
(N
: Node_Id
) return Traverse_Result
;
1752 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
1753 -- aspect for a primitive subprogram of a tagged type T, a name
1754 -- that denotes a formal parameter of type T is interpreted as
1755 -- having type T'Class. Similarly, a name that denotes a formal
1756 -- accessparameter of type access-to-T is interpreted as having
1757 -- type access-to-T'Class. This ensures the expression is well-
1758 -- defined for a primitive subprogram of a type descended from T.
1759 -- Note that this replacement is not done for selector names in
1760 -- parameter associations. These carry an entity for reference
1761 -- purposes, but semantically they are just identifiers.
1767 function Get_ACW
return Entity_Id
is
1768 Loc
: constant Source_Ptr
:= Sloc
(N
);
1773 Decl
:= Make_Full_Type_Declaration
(Loc
,
1774 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
1776 Make_Access_To_Object_Definition
(Loc
,
1777 Subtype_Indication
=>
1778 New_Occurrence_Of
(Class_Wide_Type
(T
), Loc
),
1779 All_Present
=> True));
1781 Insert_Before
(Unit_Declaration_Node
(S
), Decl
);
1783 ACW
:= Defining_Identifier
(Decl
);
1784 Freeze_Before
(Unit_Declaration_Node
(S
), ACW
);
1794 function Process
(N
: Node_Id
) return Traverse_Result
is
1795 Loc
: constant Source_Ptr
:= Sloc
(N
);
1799 if Is_Entity_Name
(N
)
1800 and then Present
(Entity
(N
))
1801 and then Is_Formal
(Entity
(N
))
1802 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
1804 (Nkind
(Parent
(N
)) /= N_Parameter_Association
1805 or else N
/= Selector_Name
(Parent
(N
)))
1807 if Etype
(Entity
(N
)) = T
then
1808 Typ
:= Class_Wide_Type
(T
);
1810 elsif Is_Access_Type
(Etype
(Entity
(N
)))
1811 and then Designated_Type
(Etype
(Entity
(N
))) = T
1818 if Present
(Typ
) then
1820 Make_Type_Conversion
(Loc
,
1822 New_Occurrence_Of
(Typ
, Loc
),
1823 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
1831 procedure Replace_Type
is new Traverse_Proc
(Process
);
1833 -- Start of processing for Class_Wide_Condition
1836 if not Present
(T
) then
1838 Chars
(Identifier
(Corresponding_Aspect
(N
)));
1840 Error_Msg_Name_2
:= Name_Class
;
1843 ("aspect `%''%` can only be specified for a primitive "
1844 & "operation of a tagged type", Corresponding_Aspect
(N
));
1847 Replace_Type
(Get_Pragma_Arg
(Arg1
));
1848 end Class_Wide_Condition
;
1851 -- Remove the subprogram from the scope stack now that the pre-analysis
1852 -- of the precondition/postcondition is done.
1855 end Analyze_PPC_In_Decl_Part
;
1857 --------------------
1858 -- Analyze_Pragma --
1859 --------------------
1861 procedure Analyze_Pragma
(N
: Node_Id
) is
1862 Loc
: constant Source_Ptr
:= Sloc
(N
);
1863 Prag_Id
: Pragma_Id
;
1866 -- Name of the source pragma, or name of the corresponding aspect for
1867 -- pragmas which originate in a source aspect. In the latter case, the
1868 -- name may be different from the pragma name.
1870 Pragma_Exit
: exception;
1871 -- This exception is used to exit pragma processing completely. It is
1872 -- used when an error is detected, and no further processing is
1873 -- required. It is also used if an earlier error has left the tree in
1874 -- a state where the pragma should not be processed.
1877 -- Number of pragma argument associations
1883 -- First four pragma arguments (pragma argument association nodes, or
1884 -- Empty if the corresponding argument does not exist).
1886 type Name_List
is array (Natural range <>) of Name_Id
;
1887 type Args_List
is array (Natural range <>) of Node_Id
;
1888 -- Types used for arguments to Check_Arg_Order and Gather_Associations
1890 procedure Ada_2005_Pragma
;
1891 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
1892 -- Ada 95 mode, these are implementation defined pragmas, so should be
1893 -- caught by the No_Implementation_Pragmas restriction.
1895 procedure Ada_2012_Pragma
;
1896 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
1897 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
1898 -- should be caught by the No_Implementation_Pragmas restriction.
1900 procedure Check_Ada_83_Warning
;
1901 -- Issues a warning message for the current pragma if operating in Ada
1902 -- 83 mode (used for language pragmas that are not a standard part of
1903 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
1906 procedure Check_Arg_Count
(Required
: Nat
);
1907 -- Check argument count for pragma is equal to given parameter. If not,
1908 -- then issue an error message and raise Pragma_Exit.
1910 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
1911 -- Arg which can either be a pragma argument association, in which case
1912 -- the check is applied to the expression of the association or an
1913 -- expression directly.
1915 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
1916 -- Check that an argument has the right form for an EXTERNAL_NAME
1917 -- parameter of an extended import/export pragma. The rule is that the
1918 -- name must be an identifier or string literal (in Ada 83 mode) or a
1919 -- static string expression (in Ada 95 mode).
1921 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
1922 -- Check the specified argument Arg to make sure that it is an
1923 -- identifier. If not give error and raise Pragma_Exit.
1925 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
1926 -- Check the specified argument Arg to make sure that it is an integer
1927 -- literal. If not give error and raise Pragma_Exit.
1929 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
1930 -- Check the specified argument Arg to make sure that it has the proper
1931 -- syntactic form for a local name and meets the semantic requirements
1932 -- for a local name. The local name is analyzed as part of the
1933 -- processing for this call. In addition, the local name is required
1934 -- to represent an entity at the library level.
1936 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
1937 -- Check the specified argument Arg to make sure that it has the proper
1938 -- syntactic form for a local name and meets the semantic requirements
1939 -- for a local name. The local name is analyzed as part of the
1940 -- processing for this call.
1942 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
1943 -- Check the specified argument Arg to make sure that it is a valid
1944 -- locking policy name. If not give error and raise Pragma_Exit.
1946 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
1947 -- Check the specified argument Arg to make sure that it is a valid
1948 -- elaboration policy name. If not give error and raise Pragma_Exit.
1950 procedure Check_Arg_Is_One_Of
1953 procedure Check_Arg_Is_One_Of
1955 N1
, N2
, N3
: Name_Id
);
1956 procedure Check_Arg_Is_One_Of
1958 N1
, N2
, N3
, N4
: Name_Id
);
1959 procedure Check_Arg_Is_One_Of
1961 N1
, N2
, N3
, N4
, N5
: Name_Id
);
1962 -- Check the specified argument Arg to make sure that it is an
1963 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
1964 -- present). If not then give error and raise Pragma_Exit.
1966 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
1967 -- Check the specified argument Arg to make sure that it is a valid
1968 -- queuing policy name. If not give error and raise Pragma_Exit.
1970 procedure Check_Arg_Is_Static_Expression
1972 Typ
: Entity_Id
:= Empty
);
1973 -- Check the specified argument Arg to make sure that it is a static
1974 -- expression of the given type (i.e. it will be analyzed and resolved
1975 -- using this type, which can be any valid argument to Resolve, e.g.
1976 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
1977 -- Typ is left Empty, then any static expression is allowed.
1979 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
1980 -- Check the specified argument Arg to make sure that it is a valid task
1981 -- dispatching policy name. If not give error and raise Pragma_Exit.
1983 procedure Check_Arg_Order
(Names
: Name_List
);
1984 -- Checks for an instance of two arguments with identifiers for the
1985 -- current pragma which are not in the sequence indicated by Names,
1986 -- and if so, generates a fatal message about bad order of arguments.
1988 procedure Check_At_Least_N_Arguments
(N
: Nat
);
1989 -- Check there are at least N arguments present
1991 procedure Check_At_Most_N_Arguments
(N
: Nat
);
1992 -- Check there are no more than N arguments present
1994 procedure Check_Component
1997 In_Variant_Part
: Boolean := False);
1998 -- Examine an Unchecked_Union component for correct use of per-object
1999 -- constrained subtypes, and for restrictions on finalizable components.
2000 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
2001 -- should be set when Comp comes from a record variant.
2003 procedure Check_Test_Case
;
2004 -- Called to process a test-case pragma. It starts with checking pragma
2005 -- arguments, and the rest of the treatment is similar to the one for
2006 -- pre- and postcondition in Check_Precondition_Postcondition, except
2007 -- the placement rules for the test-case pragma are stricter. These
2008 -- pragmas may only occur after a subprogram spec declared directly
2009 -- in a package spec unit. In this case, the pragma is chained to the
2010 -- subprogram in question (using Contract_Test_Cases and Next_Pragma)
2011 -- and analysis of the pragma is delayed till the end of the spec. In
2012 -- all other cases, an error message for bad placement is given.
2014 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
2015 -- Check if a rep item of the same name as the current pragma is already
2016 -- chained as a rep pragma to the given entity. If so give a message
2017 -- about the duplicate, and then raise Pragma_Exit so does not return.
2019 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
2020 -- Nam is an N_String_Literal node containing the external name set by
2021 -- an Import or Export pragma (or extended Import or Export pragma).
2022 -- This procedure checks for possible duplications if this is the export
2023 -- case, and if found, issues an appropriate error message.
2025 procedure Check_Expr_Is_Static_Expression
2027 Typ
: Entity_Id
:= Empty
);
2028 -- Check the specified expression Expr to make sure that it is a static
2029 -- expression of the given type (i.e. it will be analyzed and resolved
2030 -- using this type, which can be any valid argument to Resolve, e.g.
2031 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
2032 -- Typ is left Empty, then any static expression is allowed.
2034 procedure Check_First_Subtype
(Arg
: Node_Id
);
2035 -- Checks that Arg, whose expression is an entity name, references a
2038 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2039 -- Checks that the given argument has an identifier, and if so, requires
2040 -- it to match the given identifier name. If there is no identifier, or
2041 -- a non-matching identifier, then an error message is given and
2042 -- Pragma_Exit is raised.
2044 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
2045 -- Checks that the given argument has an identifier, and if so, requires
2046 -- it to match one of the given identifier names. If there is no
2047 -- identifier, or a non-matching identifier, then an error message is
2048 -- given and Pragma_Exit is raised.
2050 procedure Check_In_Main_Program
;
2051 -- Common checks for pragmas that appear within a main program
2052 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
2054 procedure Check_Interrupt_Or_Attach_Handler
;
2055 -- Common processing for first argument of pragma Interrupt_Handler or
2056 -- pragma Attach_Handler.
2058 procedure Check_Loop_Pragma_Placement
;
2059 -- Verify whether pragma Loop_Invariant or Loop_Optimize or Loop_Variant
2060 -- appear immediately within a construct restricted to loops.
2062 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
2063 -- Check that pragma appears in a declarative part, or in a package
2064 -- specification, i.e. that it does not occur in a statement sequence
2067 procedure Check_No_Identifier
(Arg
: Node_Id
);
2068 -- Checks that the given argument does not have an identifier. If
2069 -- an identifier is present, then an error message is issued, and
2070 -- Pragma_Exit is raised.
2072 procedure Check_No_Identifiers
;
2073 -- Checks that none of the arguments to the pragma has an identifier.
2074 -- If any argument has an identifier, then an error message is issued,
2075 -- and Pragma_Exit is raised.
2077 procedure Check_No_Link_Name
;
2078 -- Checks that no link name is specified
2080 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
2081 -- Checks if the given argument has an identifier, and if so, requires
2082 -- it to match the given identifier name. If there is a non-matching
2083 -- identifier, then an error message is given and Pragma_Exit is raised.
2085 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
2086 -- Checks if the given argument has an identifier, and if so, requires
2087 -- it to match the given identifier name. If there is a non-matching
2088 -- identifier, then an error message is given and Pragma_Exit is raised.
2089 -- In this version of the procedure, the identifier name is given as
2090 -- a string with lower case letters.
2092 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean);
2093 -- Called to process a precondition or postcondition pragma. There are
2096 -- The pragma appears after a subprogram spec
2098 -- If the corresponding check is not enabled, the pragma is analyzed
2099 -- but otherwise ignored and control returns with In_Body set False.
2101 -- If the check is enabled, then the first step is to analyze the
2102 -- pragma, but this is skipped if the subprogram spec appears within
2103 -- a package specification (because this is the case where we delay
2104 -- analysis till the end of the spec). Then (whether or not it was
2105 -- analyzed), the pragma is chained to the subprogram in question
2106 -- (using Pre_Post_Conditions and Next_Pragma) and control returns
2107 -- to the caller with In_Body set False.
2109 -- The pragma appears at the start of subprogram body declarations
2111 -- In this case an immediate return to the caller is made with
2112 -- In_Body set True, and the pragma is NOT analyzed.
2114 -- In all other cases, an error message for bad placement is given
2116 procedure Check_Static_Constraint
(Constr
: Node_Id
);
2117 -- Constr is a constraint from an N_Subtype_Indication node from a
2118 -- component constraint in an Unchecked_Union type. This routine checks
2119 -- that the constraint is static as required by the restrictions for
2122 procedure Check_Valid_Configuration_Pragma
;
2123 -- Legality checks for placement of a configuration pragma
2125 procedure Check_Valid_Library_Unit_Pragma
;
2126 -- Legality checks for library unit pragmas. A special case arises for
2127 -- pragmas in generic instances that come from copies of the original
2128 -- library unit pragmas in the generic templates. In the case of other
2129 -- than library level instantiations these can appear in contexts which
2130 -- would normally be invalid (they only apply to the original template
2131 -- and to library level instantiations), and they are simply ignored,
2132 -- which is implemented by rewriting them as null statements.
2134 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
2135 -- Check an Unchecked_Union variant for lack of nested variants and
2136 -- presence of at least one component. UU_Typ is the related Unchecked_
2139 procedure Error_Pragma
(Msg
: String);
2140 pragma No_Return
(Error_Pragma
);
2141 -- Outputs error message for current pragma. The message contains a %
2142 -- that will be replaced with the pragma name, and the flag is placed
2143 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
2144 -- calls Fix_Error (see spec of that procedure for details).
2146 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
2147 pragma No_Return
(Error_Pragma_Arg
);
2148 -- Outputs error message for current pragma. The message may contain
2149 -- a % that will be replaced with the pragma name. The parameter Arg
2150 -- may either be a pragma argument association, in which case the flag
2151 -- is placed on the expression of this association, or an expression,
2152 -- in which case the flag is placed directly on the expression. The
2153 -- message is placed using Error_Msg_N, so the message may also contain
2154 -- an & insertion character which will reference the given Arg value.
2155 -- After placing the message, Pragma_Exit is raised. Note: this routine
2156 -- calls Fix_Error (see spec of that procedure for details).
2158 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
2159 pragma No_Return
(Error_Pragma_Arg
);
2160 -- Similar to above form of Error_Pragma_Arg except that two messages
2161 -- are provided, the second is a continuation comment starting with \.
2163 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
2164 pragma No_Return
(Error_Pragma_Arg_Ident
);
2165 -- Outputs error message for current pragma. The message may contain
2166 -- a % that will be replaced with the pragma name. The parameter Arg
2167 -- must be a pragma argument association with a non-empty identifier
2168 -- (i.e. its Chars field must be set), and the error message is placed
2169 -- on the identifier. The message is placed using Error_Msg_N so
2170 -- the message may also contain an & insertion character which will
2171 -- reference the identifier. After placing the message, Pragma_Exit
2172 -- is raised. Note: this routine calls Fix_Error (see spec of that
2173 -- procedure for details).
2175 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
2176 pragma No_Return
(Error_Pragma_Ref
);
2177 -- Outputs error message for current pragma. The message may contain
2178 -- a % that will be replaced with the pragma name. The parameter Ref
2179 -- must be an entity whose name can be referenced by & and sloc by #.
2180 -- After placing the message, Pragma_Exit is raised. Note: this routine
2181 -- calls Fix_Error (see spec of that procedure for details).
2183 function Find_Lib_Unit_Name
return Entity_Id
;
2184 -- Used for a library unit pragma to find the entity to which the
2185 -- library unit pragma applies, returns the entity found.
2187 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
2188 -- If the pragma is a compilation unit pragma, the id must denote the
2189 -- compilation unit in the same compilation, and the pragma must appear
2190 -- in the list of preceding or trailing pragmas. If it is a program
2191 -- unit pragma that is not a compilation unit pragma, then the
2192 -- identifier must be visible.
2194 function Find_Unique_Parameterless_Procedure
2196 Arg
: Node_Id
) return Entity_Id
;
2197 -- Used for a procedure pragma to find the unique parameterless
2198 -- procedure identified by Name, returns it if it exists, otherwise
2199 -- errors out and uses Arg as the pragma argument for the message.
2201 procedure Fix_Error
(Msg
: in out String);
2202 -- This is called prior to issuing an error message. Msg is a string
2203 -- that typically contains the substring "pragma". If the pragma comes
2204 -- from an aspect, each such "pragma" substring is replaced with the
2205 -- characters "aspect", and Error_Msg_Name_1 is set to the name of the
2206 -- aspect (which may be different from the pragma name). If the current
2207 -- pragma results from rewriting another pragma, then Error_Msg_Name_1
2208 -- is set to the original pragma name.
2210 procedure Gather_Associations
2212 Args
: out Args_List
);
2213 -- This procedure is used to gather the arguments for a pragma that
2214 -- permits arbitrary ordering of parameters using the normal rules
2215 -- for named and positional parameters. The Names argument is a list
2216 -- of Name_Id values that corresponds to the allowed pragma argument
2217 -- association identifiers in order. The result returned in Args is
2218 -- a list of corresponding expressions that are the pragma arguments.
2219 -- Note that this is a list of expressions, not of pragma argument
2220 -- associations (Gather_Associations has completely checked all the
2221 -- optional identifiers when it returns). An entry in Args is Empty
2222 -- on return if the corresponding argument is not present.
2224 procedure GNAT_Pragma
;
2225 -- Called for all GNAT defined pragmas to check the relevant restriction
2226 -- (No_Implementation_Pragmas).
2228 procedure S14_Pragma
;
2229 -- Called for all pragmas defined for formal verification to check that
2230 -- the S14_Extensions flag is set.
2231 -- This name needs fixing ??? There is no such thing as an
2232 -- "S14_Extensions" flag ???
2234 function Is_Before_First_Decl
2235 (Pragma_Node
: Node_Id
;
2236 Decls
: List_Id
) return Boolean;
2237 -- Return True if Pragma_Node is before the first declarative item in
2238 -- Decls where Decls is the list of declarative items.
2240 function Is_Configuration_Pragma
return Boolean;
2241 -- Determines if the placement of the current pragma is appropriate
2242 -- for a configuration pragma.
2244 function Is_In_Context_Clause
return Boolean;
2245 -- Returns True if pragma appears within the context clause of a unit,
2246 -- and False for any other placement (does not generate any messages).
2248 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
2249 -- Analyzes the argument, and determines if it is a static string
2250 -- expression, returns True if so, False if non-static or not String.
2252 procedure Pragma_Misplaced
;
2253 pragma No_Return
(Pragma_Misplaced
);
2254 -- Issue fatal error message for misplaced pragma
2256 procedure Process_Atomic_Shared_Volatile
;
2257 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
2258 -- Shared is an obsolete Ada 83 pragma, treated as being identical
2259 -- in effect to pragma Atomic.
2261 procedure Process_Compile_Time_Warning_Or_Error
;
2262 -- Common processing for Compile_Time_Error and Compile_Time_Warning
2264 procedure Process_Convention
2265 (C
: out Convention_Id
;
2266 Ent
: out Entity_Id
);
2267 -- Common processing for Convention, Interface, Import and Export.
2268 -- Checks first two arguments of pragma, and sets the appropriate
2269 -- convention value in the specified entity or entities. On return
2270 -- C is the convention, Ent is the referenced entity.
2272 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
2273 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
2274 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
2276 procedure Process_Extended_Import_Export_Exception_Pragma
2277 (Arg_Internal
: Node_Id
;
2278 Arg_External
: Node_Id
;
2280 Arg_Code
: Node_Id
);
2281 -- Common processing for the pragmas Import/Export_Exception. The three
2282 -- arguments correspond to the three named parameters of the pragma. An
2283 -- argument is empty if the corresponding parameter is not present in
2286 procedure Process_Extended_Import_Export_Object_Pragma
2287 (Arg_Internal
: Node_Id
;
2288 Arg_External
: Node_Id
;
2289 Arg_Size
: Node_Id
);
2290 -- Common processing for the pragmas Import/Export_Object. The three
2291 -- arguments correspond to the three named parameters of the pragmas. An
2292 -- argument is empty if the corresponding parameter is not present in
2295 procedure Process_Extended_Import_Export_Internal_Arg
2296 (Arg_Internal
: Node_Id
:= Empty
);
2297 -- Common processing for all extended Import and Export pragmas. The
2298 -- argument is the pragma parameter for the Internal argument. If
2299 -- Arg_Internal is empty or inappropriate, an error message is posted.
2300 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
2301 -- set to identify the referenced entity.
2303 procedure Process_Extended_Import_Export_Subprogram_Pragma
2304 (Arg_Internal
: Node_Id
;
2305 Arg_External
: Node_Id
;
2306 Arg_Parameter_Types
: Node_Id
;
2307 Arg_Result_Type
: Node_Id
:= Empty
;
2308 Arg_Mechanism
: Node_Id
;
2309 Arg_Result_Mechanism
: Node_Id
:= Empty
;
2310 Arg_First_Optional_Parameter
: Node_Id
:= Empty
);
2311 -- Common processing for all extended Import and Export pragmas applying
2312 -- to subprograms. The caller omits any arguments that do not apply to
2313 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
2314 -- only in the Import_Function and Export_Function cases). The argument
2315 -- names correspond to the allowed pragma association identifiers.
2317 procedure Process_Generic_List
;
2318 -- Common processing for Share_Generic and Inline_Generic
2320 procedure Process_Import_Or_Interface
;
2321 -- Common processing for Import of Interface
2323 procedure Process_Import_Predefined_Type
;
2324 -- Processing for completing a type with pragma Import. This is used
2325 -- to declare types that match predefined C types, especially for cases
2326 -- without corresponding Ada predefined type.
2328 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
2329 -- Inline status of a subprogram, indicated as follows:
2330 -- Suppressed: inlining is suppressed for the subprogram
2331 -- Disabled: no inlining is requested for the subprogram
2332 -- Enabled: inlining is requested/required for the subprogram
2334 procedure Process_Inline
(Status
: Inline_Status
);
2335 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
2336 -- indicates the inline status specified by the pragma.
2338 procedure Process_Interface_Name
2339 (Subprogram_Def
: Entity_Id
;
2341 Link_Arg
: Node_Id
);
2342 -- Given the last two arguments of pragma Import, pragma Export, or
2343 -- pragma Interface_Name, performs validity checks and sets the
2344 -- Interface_Name field of the given subprogram entity to the
2345 -- appropriate external or link name, depending on the arguments given.
2346 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
2347 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
2348 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
2349 -- nor Link_Arg is present, the interface name is set to the default
2350 -- from the subprogram name.
2352 procedure Process_Interrupt_Or_Attach_Handler
;
2353 -- Common processing for Interrupt and Attach_Handler pragmas
2355 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
2356 -- Common processing for Restrictions and Restriction_Warnings pragmas.
2357 -- Warn is True for Restriction_Warnings, or for Restrictions if the
2358 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
2359 -- is not set in the Restrictions case.
2361 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
2362 -- Common processing for Suppress and Unsuppress. The boolean parameter
2363 -- Suppress_Case is True for the Suppress case, and False for the
2366 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
2367 -- This procedure sets the Is_Exported flag for the given entity,
2368 -- checking that the entity was not previously imported. Arg is
2369 -- the argument that specified the entity. A check is also made
2370 -- for exporting inappropriate entities.
2372 procedure Set_Extended_Import_Export_External_Name
2373 (Internal_Ent
: Entity_Id
;
2374 Arg_External
: Node_Id
);
2375 -- Common processing for all extended import export pragmas. The first
2376 -- argument, Internal_Ent, is the internal entity, which has already
2377 -- been checked for validity by the caller. Arg_External is from the
2378 -- Import or Export pragma, and may be null if no External parameter
2379 -- was present. If Arg_External is present and is a non-null string
2380 -- (a null string is treated as the default), then the Interface_Name
2381 -- field of Internal_Ent is set appropriately.
2383 procedure Set_Imported
(E
: Entity_Id
);
2384 -- This procedure sets the Is_Imported flag for the given entity,
2385 -- checking that it is not previously exported or imported.
2387 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
2388 -- Mech is a parameter passing mechanism (see Import_Function syntax
2389 -- for MECHANISM_NAME). This routine checks that the mechanism argument
2390 -- has the right form, and if not issues an error message. If the
2391 -- argument has the right form then the Mechanism field of Ent is
2392 -- set appropriately.
2394 procedure Set_Rational_Profile
;
2395 -- Activate the set of configuration pragmas and permissions that make
2396 -- up the Rational profile.
2398 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
2399 -- Activate the set of configuration pragmas and restrictions that make
2400 -- up the Ravenscar Profile. N is the corresponding pragma node, which
2401 -- is used for error messages on any constructs that violate the
2404 ---------------------
2405 -- Ada_2005_Pragma --
2406 ---------------------
2408 procedure Ada_2005_Pragma
is
2410 if Ada_Version
<= Ada_95
then
2411 Check_Restriction
(No_Implementation_Pragmas
, N
);
2413 end Ada_2005_Pragma
;
2415 ---------------------
2416 -- Ada_2012_Pragma --
2417 ---------------------
2419 procedure Ada_2012_Pragma
is
2421 if Ada_Version
<= Ada_2005
then
2422 Check_Restriction
(No_Implementation_Pragmas
, N
);
2424 end Ada_2012_Pragma
;
2426 --------------------------
2427 -- Check_Ada_83_Warning --
2428 --------------------------
2430 procedure Check_Ada_83_Warning
is
2432 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
2433 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
2435 end Check_Ada_83_Warning
;
2437 ---------------------
2438 -- Check_Arg_Count --
2439 ---------------------
2441 procedure Check_Arg_Count
(Required
: Nat
) is
2443 if Arg_Count
/= Required
then
2444 Error_Pragma
("wrong number of arguments for pragma%");
2446 end Check_Arg_Count
;
2448 --------------------------------
2449 -- Check_Arg_Is_External_Name --
2450 --------------------------------
2452 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
2453 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2456 if Nkind
(Argx
) = N_Identifier
then
2460 Analyze_And_Resolve
(Argx
, Standard_String
);
2462 if Is_OK_Static_Expression
(Argx
) then
2465 elsif Etype
(Argx
) = Any_Type
then
2468 -- An interesting special case, if we have a string literal and
2469 -- we are in Ada 83 mode, then we allow it even though it will
2470 -- not be flagged as static. This allows expected Ada 83 mode
2471 -- use of external names which are string literals, even though
2472 -- technically these are not static in Ada 83.
2474 elsif Ada_Version
= Ada_83
2475 and then Nkind
(Argx
) = N_String_Literal
2479 -- Static expression that raises Constraint_Error. This has
2480 -- already been flagged, so just exit from pragma processing.
2482 elsif Is_Static_Expression
(Argx
) then
2485 -- Here we have a real error (non-static expression)
2488 Error_Msg_Name_1
:= Pname
;
2492 "argument for pragma% must be a identifier or "
2493 & "static string expression!";
2496 Flag_Non_Static_Expr
(Msg
, Argx
);
2501 end Check_Arg_Is_External_Name
;
2503 -----------------------------
2504 -- Check_Arg_Is_Identifier --
2505 -----------------------------
2507 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
2508 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2510 if Nkind
(Argx
) /= N_Identifier
then
2512 ("argument for pragma% must be identifier", Argx
);
2514 end Check_Arg_Is_Identifier
;
2516 ----------------------------------
2517 -- Check_Arg_Is_Integer_Literal --
2518 ----------------------------------
2520 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
2521 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2523 if Nkind
(Argx
) /= N_Integer_Literal
then
2525 ("argument for pragma% must be integer literal", Argx
);
2527 end Check_Arg_Is_Integer_Literal
;
2529 -------------------------------------------
2530 -- Check_Arg_Is_Library_Level_Local_Name --
2531 -------------------------------------------
2535 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
2536 -- | library_unit_NAME
2538 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
2540 Check_Arg_Is_Local_Name
(Arg
);
2542 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
2543 and then Comes_From_Source
(N
)
2546 ("argument for pragma% must be library level entity", Arg
);
2548 end Check_Arg_Is_Library_Level_Local_Name
;
2550 -----------------------------
2551 -- Check_Arg_Is_Local_Name --
2552 -----------------------------
2556 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
2557 -- | library_unit_NAME
2559 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
2560 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2565 if Nkind
(Argx
) not in N_Direct_Name
2566 and then (Nkind
(Argx
) /= N_Attribute_Reference
2567 or else Present
(Expressions
(Argx
))
2568 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
2569 and then (not Is_Entity_Name
(Argx
)
2570 or else not Is_Compilation_Unit
(Entity
(Argx
)))
2572 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
2575 -- No further check required if not an entity name
2577 if not Is_Entity_Name
(Argx
) then
2583 Ent
: constant Entity_Id
:= Entity
(Argx
);
2584 Scop
: constant Entity_Id
:= Scope
(Ent
);
2587 -- Case of a pragma applied to a compilation unit: pragma must
2588 -- occur immediately after the program unit in the compilation.
2590 if Is_Compilation_Unit
(Ent
) then
2592 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
2595 -- Case of pragma placed immediately after spec
2597 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
2600 -- Case of pragma placed immediately after body
2602 elsif Nkind
(Decl
) = N_Subprogram_Declaration
2603 and then Present
(Corresponding_Body
(Decl
))
2607 (Parent
(Unit_Declaration_Node
2608 (Corresponding_Body
(Decl
))));
2610 -- All other cases are illegal
2617 -- Special restricted placement rule from 10.2.1(11.8/2)
2619 elsif Is_Generic_Formal
(Ent
)
2620 and then Prag_Id
= Pragma_Preelaborable_Initialization
2622 OK
:= List_Containing
(N
) =
2623 Generic_Formal_Declarations
2624 (Unit_Declaration_Node
(Scop
));
2626 -- Default case, just check that the pragma occurs in the scope
2627 -- of the entity denoted by the name.
2630 OK
:= Current_Scope
= Scop
;
2635 ("pragma% argument must be in same declarative part", Arg
);
2639 end Check_Arg_Is_Local_Name
;
2641 ---------------------------------
2642 -- Check_Arg_Is_Locking_Policy --
2643 ---------------------------------
2645 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
2646 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2649 Check_Arg_Is_Identifier
(Argx
);
2651 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
2652 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
2654 end Check_Arg_Is_Locking_Policy
;
2656 -----------------------------------------------
2657 -- Check_Arg_Is_Partition_Elaboration_Policy --
2658 -----------------------------------------------
2660 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
2661 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2664 Check_Arg_Is_Identifier
(Argx
);
2666 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
2668 ("& is not a valid partition elaboration policy name", Argx
);
2670 end Check_Arg_Is_Partition_Elaboration_Policy
;
2672 -------------------------
2673 -- Check_Arg_Is_One_Of --
2674 -------------------------
2676 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
2677 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2680 Check_Arg_Is_Identifier
(Argx
);
2682 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
2683 Error_Msg_Name_2
:= N1
;
2684 Error_Msg_Name_3
:= N2
;
2685 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
2687 end Check_Arg_Is_One_Of
;
2689 procedure Check_Arg_Is_One_Of
2691 N1
, N2
, N3
: Name_Id
)
2693 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2696 Check_Arg_Is_Identifier
(Argx
);
2698 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
2699 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
2701 end Check_Arg_Is_One_Of
;
2703 procedure Check_Arg_Is_One_Of
2705 N1
, N2
, N3
, N4
: Name_Id
)
2707 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2710 Check_Arg_Is_Identifier
(Argx
);
2712 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
2713 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
2715 end Check_Arg_Is_One_Of
;
2717 procedure Check_Arg_Is_One_Of
2719 N1
, N2
, N3
, N4
, N5
: Name_Id
)
2721 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2724 Check_Arg_Is_Identifier
(Argx
);
2726 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
2727 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
2729 end Check_Arg_Is_One_Of
;
2731 ---------------------------------
2732 -- Check_Arg_Is_Queuing_Policy --
2733 ---------------------------------
2735 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
2736 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2739 Check_Arg_Is_Identifier
(Argx
);
2741 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
2742 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
2744 end Check_Arg_Is_Queuing_Policy
;
2746 ------------------------------------
2747 -- Check_Arg_Is_Static_Expression --
2748 ------------------------------------
2750 procedure Check_Arg_Is_Static_Expression
2752 Typ
: Entity_Id
:= Empty
)
2755 Check_Expr_Is_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
2756 end Check_Arg_Is_Static_Expression
;
2758 ------------------------------------------
2759 -- Check_Arg_Is_Task_Dispatching_Policy --
2760 ------------------------------------------
2762 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
2763 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2766 Check_Arg_Is_Identifier
(Argx
);
2768 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
2770 ("& is not a valid task dispatching policy name", Argx
);
2772 end Check_Arg_Is_Task_Dispatching_Policy
;
2774 ---------------------
2775 -- Check_Arg_Order --
2776 ---------------------
2778 procedure Check_Arg_Order
(Names
: Name_List
) is
2781 Highest_So_Far
: Natural := 0;
2782 -- Highest index in Names seen do far
2786 for J
in 1 .. Arg_Count
loop
2787 if Chars
(Arg
) /= No_Name
then
2788 for K
in Names
'Range loop
2789 if Chars
(Arg
) = Names
(K
) then
2790 if K
< Highest_So_Far
then
2791 Error_Msg_Name_1
:= Pname
;
2793 ("parameters out of order for pragma%", Arg
);
2794 Error_Msg_Name_1
:= Names
(K
);
2795 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
2796 Error_Msg_N
("\% must appear before %", Arg
);
2800 Highest_So_Far
:= K
;
2808 end Check_Arg_Order
;
2810 --------------------------------
2811 -- Check_At_Least_N_Arguments --
2812 --------------------------------
2814 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
2816 if Arg_Count
< N
then
2817 Error_Pragma
("too few arguments for pragma%");
2819 end Check_At_Least_N_Arguments
;
2821 -------------------------------
2822 -- Check_At_Most_N_Arguments --
2823 -------------------------------
2825 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
2828 if Arg_Count
> N
then
2830 for J
in 1 .. N
loop
2832 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
2835 end Check_At_Most_N_Arguments
;
2837 ---------------------
2838 -- Check_Component --
2839 ---------------------
2841 procedure Check_Component
2844 In_Variant_Part
: Boolean := False)
2846 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
2847 Sindic
: constant Node_Id
:=
2848 Subtype_Indication
(Component_Definition
(Comp
));
2849 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
2852 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
2853 -- object constraint, then the component type shall be an Unchecked_
2856 if Nkind
(Sindic
) = N_Subtype_Indication
2857 and then Has_Per_Object_Constraint
(Comp_Id
)
2858 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
2861 ("component subtype subject to per-object constraint "
2862 & "must be an Unchecked_Union", Comp
);
2864 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
2865 -- the body of a generic unit, or within the body of any of its
2866 -- descendant library units, no part of the type of a component
2867 -- declared in a variant_part of the unchecked union type shall be of
2868 -- a formal private type or formal private extension declared within
2869 -- the formal part of the generic unit.
2871 elsif Ada_Version
>= Ada_2012
2872 and then In_Generic_Body
(UU_Typ
)
2873 and then In_Variant_Part
2874 and then Is_Private_Type
(Typ
)
2875 and then Is_Generic_Type
(Typ
)
2878 ("component of unchecked union cannot be of generic type", Comp
);
2880 elsif Needs_Finalization
(Typ
) then
2882 ("component of unchecked union cannot be controlled", Comp
);
2884 elsif Has_Task
(Typ
) then
2886 ("component of unchecked union cannot have tasks", Comp
);
2888 end Check_Component
;
2890 ----------------------------
2891 -- Check_Duplicate_Pragma --
2892 ----------------------------
2894 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
2895 Id
: Entity_Id
:= E
;
2899 -- Nothing to do if this pragma comes from an aspect specification,
2900 -- since we could not be duplicating a pragma, and we dealt with the
2901 -- case of duplicated aspects in Analyze_Aspect_Specifications.
2903 if From_Aspect_Specification
(N
) then
2907 -- Otherwise current pragma may duplicate previous pragma or a
2908 -- previously given aspect specification or attribute definition
2909 -- clause for the same pragma.
2911 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
2914 Error_Msg_Name_1
:= Pragma_Name
(N
);
2915 Error_Msg_Sloc
:= Sloc
(P
);
2917 -- For a single protected or a single task object, the error is
2918 -- issued on the original entity.
2920 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
2921 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
2924 if Nkind
(P
) = N_Aspect_Specification
2925 or else From_Aspect_Specification
(P
)
2927 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
2929 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
2934 end Check_Duplicate_Pragma
;
2936 ----------------------------------
2937 -- Check_Duplicated_Export_Name --
2938 ----------------------------------
2940 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
2941 String_Val
: constant String_Id
:= Strval
(Nam
);
2944 -- We are only interested in the export case, and in the case of
2945 -- generics, it is the instance, not the template, that is the
2946 -- problem (the template will generate a warning in any case).
2948 if not Inside_A_Generic
2949 and then (Prag_Id
= Pragma_Export
2951 Prag_Id
= Pragma_Export_Procedure
2953 Prag_Id
= Pragma_Export_Valued_Procedure
2955 Prag_Id
= Pragma_Export_Function
)
2957 for J
in Externals
.First
.. Externals
.Last
loop
2958 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
2959 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
2960 Error_Msg_N
("external name duplicates name given#", Nam
);
2965 Externals
.Append
(Nam
);
2967 end Check_Duplicated_Export_Name
;
2969 -------------------------------------
2970 -- Check_Expr_Is_Static_Expression --
2971 -------------------------------------
2973 procedure Check_Expr_Is_Static_Expression
2975 Typ
: Entity_Id
:= Empty
)
2978 if Present
(Typ
) then
2979 Analyze_And_Resolve
(Expr
, Typ
);
2981 Analyze_And_Resolve
(Expr
);
2984 if Is_OK_Static_Expression
(Expr
) then
2987 elsif Etype
(Expr
) = Any_Type
then
2990 -- An interesting special case, if we have a string literal and we
2991 -- are in Ada 83 mode, then we allow it even though it will not be
2992 -- flagged as static. This allows the use of Ada 95 pragmas like
2993 -- Import in Ada 83 mode. They will of course be flagged with
2994 -- warnings as usual, but will not cause errors.
2996 elsif Ada_Version
= Ada_83
2997 and then Nkind
(Expr
) = N_String_Literal
3001 -- Static expression that raises Constraint_Error. This has already
3002 -- been flagged, so just exit from pragma processing.
3004 elsif Is_Static_Expression
(Expr
) then
3007 -- Finally, we have a real error
3010 Error_Msg_Name_1
:= Pname
;
3014 "argument for pragma% must be a static expression!";
3017 Flag_Non_Static_Expr
(Msg
, Expr
);
3022 end Check_Expr_Is_Static_Expression
;
3024 -------------------------
3025 -- Check_First_Subtype --
3026 -------------------------
3028 procedure Check_First_Subtype
(Arg
: Node_Id
) is
3029 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
3030 Ent
: constant Entity_Id
:= Entity
(Argx
);
3033 if Is_First_Subtype
(Ent
) then
3036 elsif Is_Type
(Ent
) then
3038 ("pragma% cannot apply to subtype", Argx
);
3040 elsif Is_Object
(Ent
) then
3042 ("pragma% cannot apply to object, requires a type", Argx
);
3046 ("pragma% cannot apply to&, requires a type", Argx
);
3048 end Check_First_Subtype
;
3050 ----------------------
3051 -- Check_Identifier --
3052 ----------------------
3054 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
3057 and then Nkind
(Arg
) = N_Pragma_Argument_Association
3059 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
3060 Error_Msg_Name_1
:= Pname
;
3061 Error_Msg_Name_2
:= Id
;
3062 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
3066 end Check_Identifier
;
3068 --------------------------------
3069 -- Check_Identifier_Is_One_Of --
3070 --------------------------------
3072 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
3075 and then Nkind
(Arg
) = N_Pragma_Argument_Association
3077 if Chars
(Arg
) = No_Name
then
3078 Error_Msg_Name_1
:= Pname
;
3079 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
3082 elsif Chars
(Arg
) /= N1
3083 and then Chars
(Arg
) /= N2
3085 Error_Msg_Name_1
:= Pname
;
3086 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
3090 end Check_Identifier_Is_One_Of
;
3092 ---------------------------
3093 -- Check_In_Main_Program --
3094 ---------------------------
3096 procedure Check_In_Main_Program
is
3097 P
: constant Node_Id
:= Parent
(N
);
3100 -- Must be at in subprogram body
3102 if Nkind
(P
) /= N_Subprogram_Body
then
3103 Error_Pragma
("% pragma allowed only in subprogram");
3105 -- Otherwise warn if obviously not main program
3107 elsif Present
(Parameter_Specifications
(Specification
(P
)))
3108 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
3110 Error_Msg_Name_1
:= Pname
;
3112 ("??pragma% is only effective in main program", N
);
3114 end Check_In_Main_Program
;
3116 ---------------------------------------
3117 -- Check_Interrupt_Or_Attach_Handler --
3118 ---------------------------------------
3120 procedure Check_Interrupt_Or_Attach_Handler
is
3121 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
3122 Handler_Proc
, Proc_Scope
: Entity_Id
;
3127 if Prag_Id
= Pragma_Interrupt_Handler
then
3128 Check_Restriction
(No_Dynamic_Attachment
, N
);
3131 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
3132 Proc_Scope
:= Scope
(Handler_Proc
);
3134 -- On AAMP only, a pragma Interrupt_Handler is supported for
3135 -- nonprotected parameterless procedures.
3137 if not AAMP_On_Target
3138 or else Prag_Id
= Pragma_Attach_Handler
3140 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
3142 ("argument of pragma% must be protected procedure", Arg1
);
3145 if Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
)) then
3146 Error_Pragma
("pragma% must be in protected definition");
3150 if not Is_Library_Level_Entity
(Proc_Scope
)
3151 or else (AAMP_On_Target
3152 and then not Is_Library_Level_Entity
(Handler_Proc
))
3155 ("argument for pragma% must be library level entity", Arg1
);
3158 -- AI05-0033: A pragma cannot appear within a generic body, because
3159 -- instance can be in a nested scope. The check that protected type
3160 -- is itself a library-level declaration is done elsewhere.
3162 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
3163 -- handle code prior to AI-0033. Analysis tools typically are not
3164 -- interested in this pragma in any case, so no need to worry too
3165 -- much about its placement.
3167 if Inside_A_Generic
then
3168 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
3169 and then In_Package_Body
(Scope
(Current_Scope
))
3170 and then not Relaxed_RM_Semantics
3172 Error_Pragma
("pragma% cannot be used inside a generic");
3175 end Check_Interrupt_Or_Attach_Handler
;
3177 ---------------------------------
3178 -- Check_Loop_Pragma_Placement --
3179 ---------------------------------
3181 procedure Check_Loop_Pragma_Placement
is
3182 procedure Placement_Error
(Constr
: Node_Id
);
3183 pragma No_Return
(Placement_Error
);
3184 -- Node Constr denotes the last loop restricted construct before we
3185 -- encountered an illegal relation between enclosing constructs. Emit
3186 -- an error depending on what Constr was.
3188 ---------------------
3189 -- Placement_Error --
3190 ---------------------
3192 procedure Placement_Error
(Constr
: Node_Id
) is
3194 if Nkind
(Constr
) = N_Pragma
then
3196 ("pragma % must appear immediately within the statements "
3200 ("block containing pragma % must appear immediately within "
3201 & "the statements of a loop", Constr
);
3203 end Placement_Error
;
3205 -- Local declarations
3210 -- Start of processing for Check_Loop_Pragma_Placement
3215 while Present
(Stmt
) loop
3217 -- The pragma or previous block must appear immediately within the
3218 -- current block's declarative or statement part.
3220 if Nkind
(Stmt
) = N_Block_Statement
then
3221 if (No
(Declarations
(Stmt
))
3222 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
3224 List_Containing
(Prev
) /=
3225 Statements
(Handled_Statement_Sequence
(Stmt
))
3227 Placement_Error
(Prev
);
3230 -- Keep inspecting the parents because we are now within a
3231 -- chain of nested blocks.
3235 Stmt
:= Parent
(Stmt
);
3238 -- The pragma or previous block must appear immediately within the
3239 -- statements of the loop.
3241 elsif Nkind
(Stmt
) = N_Loop_Statement
then
3242 if List_Containing
(Prev
) /= Statements
(Stmt
) then
3243 Placement_Error
(Prev
);
3246 -- Stop the traversal because we reached the innermost loop
3247 -- regardless of whether we encountered an error or not.
3251 -- Ignore a handled statement sequence. Note that this node may
3252 -- be related to a subprogram body in which case we will emit an
3253 -- error on the next iteration of the search.
3255 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
3256 Stmt
:= Parent
(Stmt
);
3258 -- Any other statement breaks the chain from the pragma to the
3262 Placement_Error
(Prev
);
3266 end Check_Loop_Pragma_Placement
;
3268 -------------------------------------------
3269 -- Check_Is_In_Decl_Part_Or_Package_Spec --
3270 -------------------------------------------
3272 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
3281 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
3284 elsif Nkind_In
(P
, N_Package_Specification
,
3289 -- Note: the following tests seem a little peculiar, because
3290 -- they test for bodies, but if we were in the statement part
3291 -- of the body, we would already have hit the handled statement
3292 -- sequence, so the only way we get here is by being in the
3293 -- declarative part of the body.
3295 elsif Nkind_In
(P
, N_Subprogram_Body
,
3306 Error_Pragma
("pragma% is not in declarative part or package spec");
3307 end Check_Is_In_Decl_Part_Or_Package_Spec
;
3309 -------------------------
3310 -- Check_No_Identifier --
3311 -------------------------
3313 procedure Check_No_Identifier
(Arg
: Node_Id
) is
3315 if Nkind
(Arg
) = N_Pragma_Argument_Association
3316 and then Chars
(Arg
) /= No_Name
3318 Error_Pragma_Arg_Ident
3319 ("pragma% does not permit identifier& here", Arg
);
3321 end Check_No_Identifier
;
3323 --------------------------
3324 -- Check_No_Identifiers --
3325 --------------------------
3327 procedure Check_No_Identifiers
is
3331 for J
in 1 .. Arg_Count
loop
3332 Check_No_Identifier
(Arg_Node
);
3335 end Check_No_Identifiers
;
3337 ------------------------
3338 -- Check_No_Link_Name --
3339 ------------------------
3341 procedure Check_No_Link_Name
is
3343 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
3347 if Present
(Arg4
) then
3349 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
3351 end Check_No_Link_Name
;
3353 -------------------------------
3354 -- Check_Optional_Identifier --
3355 -------------------------------
3357 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
3360 and then Nkind
(Arg
) = N_Pragma_Argument_Association
3361 and then Chars
(Arg
) /= No_Name
3363 if Chars
(Arg
) /= Id
then
3364 Error_Msg_Name_1
:= Pname
;
3365 Error_Msg_Name_2
:= Id
;
3366 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
3370 end Check_Optional_Identifier
;
3372 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
3374 Name_Buffer
(1 .. Id
'Length) := Id
;
3375 Name_Len
:= Id
'Length;
3376 Check_Optional_Identifier
(Arg
, Name_Find
);
3377 end Check_Optional_Identifier
;
3379 --------------------------------------
3380 -- Check_Precondition_Postcondition --
3381 --------------------------------------
3383 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean) is
3387 procedure Chain_PPC
(PO
: Node_Id
);
3388 -- If PO is an entry or a [generic] subprogram declaration node, then
3389 -- the precondition/postcondition applies to this subprogram and the
3390 -- processing for the pragma is completed. Otherwise the pragma is
3397 procedure Chain_PPC
(PO
: Node_Id
) is
3401 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
3402 if not From_Aspect_Specification
(N
) then
3404 ("pragma% cannot be applied to abstract subprogram");
3406 elsif Class_Present
(N
) then
3411 ("aspect % requires ''Class for abstract subprogram");
3414 -- AI05-0230: The same restriction applies to null procedures. For
3415 -- compatibility with earlier uses of the Ada pragma, apply this
3416 -- rule only to aspect specifications.
3418 -- The above discrpency needs documentation. Robert is dubious
3419 -- about whether it is a good idea ???
3421 elsif Nkind
(PO
) = N_Subprogram_Declaration
3422 and then Nkind
(Specification
(PO
)) = N_Procedure_Specification
3423 and then Null_Present
(Specification
(PO
))
3424 and then From_Aspect_Specification
(N
)
3425 and then not Class_Present
(N
)
3428 ("aspect % requires ''Class for null procedure");
3430 -- Pre/postconditions are legal on a subprogram body if it is not
3431 -- a completion of a declaration. They are also legal on a stub
3432 -- with no previous declarations (this is checked when processing
3433 -- the corresponding aspects).
3435 elsif Nkind
(PO
) = N_Subprogram_Body
3436 and then Acts_As_Spec
(PO
)
3440 elsif Nkind
(PO
) = N_Subprogram_Body_Stub
then
3443 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
3444 N_Expression_Function
,
3445 N_Generic_Subprogram_Declaration
,
3446 N_Entry_Declaration
)
3451 -- Here if we have [generic] subprogram or entry declaration
3453 if Nkind
(PO
) = N_Entry_Declaration
then
3454 S
:= Defining_Entity
(PO
);
3456 S
:= Defining_Unit_Name
(Specification
(PO
));
3458 if Nkind
(S
) = N_Defining_Program_Unit_Name
then
3459 S
:= Defining_Identifier
(S
);
3463 -- Note: we do not analyze the pragma at this point. Instead we
3464 -- delay this analysis until the end of the declarative part in
3465 -- which the pragma appears. This implements the required delay
3466 -- in this analysis, allowing forward references. The analysis
3467 -- happens at the end of Analyze_Declarations.
3469 -- Chain spec PPC pragma to list for subprogram
3471 Add_Contract_Item
(N
, S
);
3473 -- Return indicating spec case
3479 -- Start of processing for Check_Precondition_Postcondition
3482 if not Is_List_Member
(N
) then
3486 -- Preanalyze message argument if present. Visibility in this
3487 -- argument is established at the point of pragma occurrence.
3489 if Arg_Count
= 2 then
3490 Check_Optional_Identifier
(Arg2
, Name_Message
);
3491 Preanalyze_Spec_Expression
3492 (Get_Pragma_Arg
(Arg2
), Standard_String
);
3495 -- For a pragma PPC in the extended main source unit, record enabled
3498 if not Is_Ignored
(N
) and then not Split_PPC
(N
) then
3499 Set_SCO_Pragma_Enabled
(Loc
);
3502 -- If we are within an inlined body, the legality of the pragma
3503 -- has been checked already.
3505 if In_Inlined_Body
then
3510 -- Search prior declarations
3513 while Present
(Prev
(P
)) loop
3516 -- If the previous node is a generic subprogram, do not go to to
3517 -- the original node, which is the unanalyzed tree: we need to
3518 -- attach the pre/postconditions to the analyzed version at this
3519 -- point. They get propagated to the original tree when analyzing
3520 -- the corresponding body.
3522 if Nkind
(P
) not in N_Generic_Declaration
then
3523 PO
:= Original_Node
(P
);
3528 -- Skip past prior pragma
3530 if Nkind
(PO
) = N_Pragma
then
3533 -- Skip stuff not coming from source
3535 elsif not Comes_From_Source
(PO
) then
3537 -- The condition may apply to a subprogram instantiation
3539 if Nkind
(PO
) = N_Subprogram_Declaration
3540 and then Present
(Generic_Parent
(Specification
(PO
)))
3545 elsif Nkind
(PO
) = N_Subprogram_Declaration
3546 and then In_Instance
3551 -- For all other cases of non source code, do nothing
3557 -- Only remaining possibility is subprogram declaration
3565 -- If we fall through loop, pragma is at start of list, so see if it
3566 -- is at the start of declarations of a subprogram body.
3570 if Nkind
(PO
) = N_Subprogram_Body
3571 and then List_Containing
(N
) = Declarations
(PO
)
3573 if Operating_Mode
/= Generate_Code
or else Inside_A_Generic
then
3575 -- Analyze pragma expression for correctness and for ASIS use
3577 Preanalyze_Assert_Expression
3578 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
3580 -- In ASIS mode, for a pragma generated from a source aspect,
3581 -- also analyze the original aspect expression.
3583 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
3584 Preanalyze_Assert_Expression
3585 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
3589 -- Retain a copy of the pre- or postcondition pragma for formal
3590 -- verification purposes. The copy is needed because the pragma is
3591 -- expanded into other constructs which are not acceptable in the
3594 if Acts_As_Spec
(PO
)
3595 and then (SPARK_Mode
or else Formal_Extensions
)
3598 Prag
: constant Node_Id
:= New_Copy_Tree
(N
);
3601 -- Preanalyze the pragma
3603 Preanalyze_Assert_Expression
3605 (First
(Pragma_Argument_Associations
(Prag
))),
3608 -- Preanalyze the corresponding aspect (if any)
3610 if Present
(Corresponding_Aspect
(Prag
)) then
3611 Preanalyze_Assert_Expression
3612 (Expression
(Corresponding_Aspect
(Prag
)),
3616 -- Chain the copy on the contract of the body
3619 (Prag
, Defining_Unit_Name
(Specification
(PO
)));
3626 -- See if it is in the pragmas after a library level subprogram
3628 elsif Nkind
(PO
) = N_Compilation_Unit_Aux
then
3630 -- In formal verification mode, analyze pragma expression for
3631 -- correctness, as it is not expanded later.
3634 Analyze_PPC_In_Decl_Part
3635 (N
, Defining_Entity
(Unit
(Parent
(PO
))));
3638 Chain_PPC
(Unit
(Parent
(PO
)));
3642 -- If we fall through, pragma was misplaced
3645 end Check_Precondition_Postcondition
;
3647 -----------------------------
3648 -- Check_Static_Constraint --
3649 -----------------------------
3651 -- Note: for convenience in writing this procedure, in addition to
3652 -- the officially (i.e. by spec) allowed argument which is always a
3653 -- constraint, it also allows ranges and discriminant associations.
3654 -- Above is not clear ???
3656 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
3658 procedure Require_Static
(E
: Node_Id
);
3659 -- Require given expression to be static expression
3661 --------------------
3662 -- Require_Static --
3663 --------------------
3665 procedure Require_Static
(E
: Node_Id
) is
3667 if not Is_OK_Static_Expression
(E
) then
3668 Flag_Non_Static_Expr
3669 ("non-static constraint not allowed in Unchecked_Union!", E
);
3674 -- Start of processing for Check_Static_Constraint
3677 case Nkind
(Constr
) is
3678 when N_Discriminant_Association
=>
3679 Require_Static
(Expression
(Constr
));
3682 Require_Static
(Low_Bound
(Constr
));
3683 Require_Static
(High_Bound
(Constr
));
3685 when N_Attribute_Reference
=>
3686 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
3687 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
3689 when N_Range_Constraint
=>
3690 Check_Static_Constraint
(Range_Expression
(Constr
));
3692 when N_Index_Or_Discriminant_Constraint
=>
3696 IDC
:= First
(Constraints
(Constr
));
3697 while Present
(IDC
) loop
3698 Check_Static_Constraint
(IDC
);
3706 end Check_Static_Constraint
;
3708 ---------------------
3709 -- Check_Test_Case --
3710 ---------------------
3712 procedure Check_Test_Case
is
3716 procedure Chain_CTC
(PO
: Node_Id
);
3717 -- If PO is a [generic] subprogram declaration node, then the
3718 -- test-case applies to this subprogram and the processing for
3719 -- the pragma is completed. Otherwise the pragma is misplaced.
3725 procedure Chain_CTC
(PO
: Node_Id
) is
3729 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
3731 ("pragma% cannot be applied to abstract subprogram");
3733 elsif Nkind
(PO
) = N_Entry_Declaration
then
3734 Error_Pragma
("pragma% cannot be applied to entry");
3736 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
3737 N_Generic_Subprogram_Declaration
)
3742 -- Here if we have [generic] subprogram declaration
3744 S
:= Defining_Unit_Name
(Specification
(PO
));
3746 -- Note: we do not analyze the pragma at this point. Instead we
3747 -- delay this analysis until the end of the declarative part in
3748 -- which the pragma appears. This implements the required delay
3749 -- in this analysis, allowing forward references. The analysis
3750 -- happens at the end of Analyze_Declarations.
3752 -- There should not be another test-case with the same name
3753 -- associated to this subprogram.
3756 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
3760 CTC
:= Contract_Test_Cases
(Contract
(S
));
3761 while Present
(CTC
) loop
3763 -- Omit pragma Contract_Cases because it does not introduce
3764 -- a unique case name and it does not follow the syntax of
3767 if Pragma_Name
(CTC
) = Name_Contract_Cases
then
3771 (Name
, Get_Name_From_CTC_Pragma
(CTC
))
3773 Error_Msg_Sloc
:= Sloc
(CTC
);
3774 Error_Pragma
("name for pragma% is already used#");
3777 CTC
:= Next_Pragma
(CTC
);
3781 -- Chain spec CTC pragma to list for subprogram
3783 Add_Contract_Item
(N
, S
);
3786 -- Start of processing for Check_Test_Case
3789 -- First check pragma arguments
3791 Check_At_Least_N_Arguments
(2);
3792 Check_At_Most_N_Arguments
(4);
3794 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
3796 Check_Optional_Identifier
(Arg1
, Name_Name
);
3797 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
3799 -- In ASIS mode, for a pragma generated from a source aspect, also
3800 -- analyze the original aspect expression.
3802 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
3803 Check_Expr_Is_Static_Expression
3804 (Original_Node
(Get_Pragma_Arg
(Arg1
)), Standard_String
);
3807 Check_Optional_Identifier
(Arg2
, Name_Mode
);
3808 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
3810 if Arg_Count
= 4 then
3811 Check_Identifier
(Arg3
, Name_Requires
);
3812 Check_Identifier
(Arg4
, Name_Ensures
);
3814 elsif Arg_Count
= 3 then
3815 Check_Identifier_Is_One_Of
(Arg3
, Name_Requires
, Name_Ensures
);
3818 -- Check pragma placement
3820 if not Is_List_Member
(N
) then
3824 -- Test-case should only appear in package spec unit
3826 if Get_Source_Unit
(N
) = No_Unit
3827 or else not Nkind_In
(Sinfo
.Unit
(Cunit
(Get_Source_Unit
(N
))),
3828 N_Package_Declaration
,
3829 N_Generic_Package_Declaration
)
3834 -- Search prior declarations
3837 while Present
(Prev
(P
)) loop
3840 -- If the previous node is a generic subprogram, do not go to to
3841 -- the original node, which is the unanalyzed tree: we need to
3842 -- attach the test-case to the analyzed version at this point.
3843 -- They get propagated to the original tree when analyzing the
3844 -- corresponding body.
3846 if Nkind
(P
) not in N_Generic_Declaration
then
3847 PO
:= Original_Node
(P
);
3852 -- Skip past prior pragma
3854 if Nkind
(PO
) = N_Pragma
then
3857 -- Skip stuff not coming from source
3859 elsif not Comes_From_Source
(PO
) then
3862 -- Only remaining possibility is subprogram declaration. First
3863 -- check that it is declared directly in a package declaration.
3864 -- This may be either the package declaration for the current unit
3865 -- being defined or a local package declaration.
3867 elsif not Present
(Parent
(Parent
(PO
)))
3868 or else not Present
(Parent
(Parent
(Parent
(PO
))))
3869 or else not Nkind_In
(Parent
(Parent
(PO
)),
3870 N_Package_Declaration
,
3871 N_Generic_Package_Declaration
)
3881 -- If we fall through, pragma was misplaced
3884 end Check_Test_Case
;
3886 --------------------------------------
3887 -- Check_Valid_Configuration_Pragma --
3888 --------------------------------------
3890 -- A configuration pragma must appear in the context clause of a
3891 -- compilation unit, and only other pragmas may precede it. Note that
3892 -- the test also allows use in a configuration pragma file.
3894 procedure Check_Valid_Configuration_Pragma
is
3896 if not Is_Configuration_Pragma
then
3897 Error_Pragma
("incorrect placement for configuration pragma%");
3899 end Check_Valid_Configuration_Pragma
;
3901 -------------------------------------
3902 -- Check_Valid_Library_Unit_Pragma --
3903 -------------------------------------
3905 procedure Check_Valid_Library_Unit_Pragma
is
3907 Parent_Node
: Node_Id
;
3908 Unit_Name
: Entity_Id
;
3909 Unit_Kind
: Node_Kind
;
3910 Unit_Node
: Node_Id
;
3911 Sindex
: Source_File_Index
;
3914 if not Is_List_Member
(N
) then
3918 Plist
:= List_Containing
(N
);
3919 Parent_Node
:= Parent
(Plist
);
3921 if Parent_Node
= Empty
then
3924 -- Case of pragma appearing after a compilation unit. In this case
3925 -- it must have an argument with the corresponding name and must
3926 -- be part of the following pragmas of its parent.
3928 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
3929 if Plist
/= Pragmas_After
(Parent_Node
) then
3932 elsif Arg_Count
= 0 then
3934 ("argument required if outside compilation unit");
3937 Check_No_Identifiers
;
3938 Check_Arg_Count
(1);
3939 Unit_Node
:= Unit
(Parent
(Parent_Node
));
3940 Unit_Kind
:= Nkind
(Unit_Node
);
3942 Analyze
(Get_Pragma_Arg
(Arg1
));
3944 if Unit_Kind
= N_Generic_Subprogram_Declaration
3945 or else Unit_Kind
= N_Subprogram_Declaration
3947 Unit_Name
:= Defining_Entity
(Unit_Node
);
3949 elsif Unit_Kind
in N_Generic_Instantiation
then
3950 Unit_Name
:= Defining_Entity
(Unit_Node
);
3953 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
3956 if Chars
(Unit_Name
) /=
3957 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
3960 ("pragma% argument is not current unit name", Arg1
);
3963 if Ekind
(Unit_Name
) = E_Package
3964 and then Present
(Renamed_Entity
(Unit_Name
))
3966 Error_Pragma
("pragma% not allowed for renamed package");
3970 -- Pragma appears other than after a compilation unit
3973 -- Here we check for the generic instantiation case and also
3974 -- for the case of processing a generic formal package. We
3975 -- detect these cases by noting that the Sloc on the node
3976 -- does not belong to the current compilation unit.
3978 Sindex
:= Source_Index
(Current_Sem_Unit
);
3980 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
3981 Rewrite
(N
, Make_Null_Statement
(Loc
));
3984 -- If before first declaration, the pragma applies to the
3985 -- enclosing unit, and the name if present must be this name.
3987 elsif Is_Before_First_Decl
(N
, Plist
) then
3988 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
3989 Unit_Kind
:= Nkind
(Unit_Node
);
3991 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
3994 elsif Unit_Kind
= N_Subprogram_Body
3995 and then not Acts_As_Spec
(Unit_Node
)
3999 elsif Nkind
(Parent_Node
) = N_Package_Body
then
4002 elsif Nkind
(Parent_Node
) = N_Package_Specification
4003 and then Plist
= Private_Declarations
(Parent_Node
)
4007 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
4008 or else Nkind
(Parent_Node
) =
4009 N_Generic_Subprogram_Declaration
)
4010 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
4014 elsif Arg_Count
> 0 then
4015 Analyze
(Get_Pragma_Arg
(Arg1
));
4017 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
4019 ("name in pragma% must be enclosing unit", Arg1
);
4022 -- It is legal to have no argument in this context
4028 -- Error if not before first declaration. This is because a
4029 -- library unit pragma argument must be the name of a library
4030 -- unit (RM 10.1.5(7)), but the only names permitted in this
4031 -- context are (RM 10.1.5(6)) names of subprogram declarations,
4032 -- generic subprogram declarations or generic instantiations.
4036 ("pragma% misplaced, must be before first declaration");
4040 end Check_Valid_Library_Unit_Pragma
;
4046 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
4047 Clist
: constant Node_Id
:= Component_List
(Variant
);
4051 Comp
:= First
(Component_Items
(Clist
));
4052 while Present
(Comp
) loop
4053 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
4062 procedure Error_Pragma
(Msg
: String) is
4063 MsgF
: String := Msg
;
4065 Error_Msg_Name_1
:= Pname
;
4067 Error_Msg_N
(MsgF
, N
);
4071 ----------------------
4072 -- Error_Pragma_Arg --
4073 ----------------------
4075 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
4076 MsgF
: String := Msg
;
4078 Error_Msg_Name_1
:= Pname
;
4080 Error_Msg_N
(MsgF
, Get_Pragma_Arg
(Arg
));
4082 end Error_Pragma_Arg
;
4084 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
4085 MsgF
: String := Msg1
;
4087 Error_Msg_Name_1
:= Pname
;
4089 Error_Msg_N
(MsgF
, Get_Pragma_Arg
(Arg
));
4090 Error_Pragma_Arg
(Msg2
, Arg
);
4091 end Error_Pragma_Arg
;
4093 ----------------------------
4094 -- Error_Pragma_Arg_Ident --
4095 ----------------------------
4097 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
4098 MsgF
: String := Msg
;
4100 Error_Msg_Name_1
:= Pname
;
4102 Error_Msg_N
(MsgF
, Arg
);
4104 end Error_Pragma_Arg_Ident
;
4106 ----------------------
4107 -- Error_Pragma_Ref --
4108 ----------------------
4110 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
4111 MsgF
: String := Msg
;
4113 Error_Msg_Name_1
:= Pname
;
4115 Error_Msg_Sloc
:= Sloc
(Ref
);
4116 Error_Msg_NE
(MsgF
, N
, Ref
);
4118 end Error_Pragma_Ref
;
4120 ------------------------
4121 -- Find_Lib_Unit_Name --
4122 ------------------------
4124 function Find_Lib_Unit_Name
return Entity_Id
is
4126 -- Return inner compilation unit entity, for case of nested
4127 -- categorization pragmas. This happens in generic unit.
4129 if Nkind
(Parent
(N
)) = N_Package_Specification
4130 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
4132 return Defining_Entity
(Parent
(N
));
4134 return Current_Scope
;
4136 end Find_Lib_Unit_Name
;
4138 ----------------------------
4139 -- Find_Program_Unit_Name --
4140 ----------------------------
4142 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
4143 Unit_Name
: Entity_Id
;
4144 Unit_Kind
: Node_Kind
;
4145 P
: constant Node_Id
:= Parent
(N
);
4148 if Nkind
(P
) = N_Compilation_Unit
then
4149 Unit_Kind
:= Nkind
(Unit
(P
));
4151 if Unit_Kind
= N_Subprogram_Declaration
4152 or else Unit_Kind
= N_Package_Declaration
4153 or else Unit_Kind
in N_Generic_Declaration
4155 Unit_Name
:= Defining_Entity
(Unit
(P
));
4157 if Chars
(Id
) = Chars
(Unit_Name
) then
4158 Set_Entity
(Id
, Unit_Name
);
4159 Set_Etype
(Id
, Etype
(Unit_Name
));
4161 Set_Etype
(Id
, Any_Type
);
4163 ("cannot find program unit referenced by pragma%");
4167 Set_Etype
(Id
, Any_Type
);
4168 Error_Pragma
("pragma% inapplicable to this unit");
4174 end Find_Program_Unit_Name
;
4176 -----------------------------------------
4177 -- Find_Unique_Parameterless_Procedure --
4178 -----------------------------------------
4180 function Find_Unique_Parameterless_Procedure
4182 Arg
: Node_Id
) return Entity_Id
4184 Proc
: Entity_Id
:= Empty
;
4187 -- The body of this procedure needs some comments ???
4189 if not Is_Entity_Name
(Name
) then
4191 ("argument of pragma% must be entity name", Arg
);
4193 elsif not Is_Overloaded
(Name
) then
4194 Proc
:= Entity
(Name
);
4196 if Ekind
(Proc
) /= E_Procedure
4197 or else Present
(First_Formal
(Proc
))
4200 ("argument of pragma% must be parameterless procedure", Arg
);
4205 Found
: Boolean := False;
4207 Index
: Interp_Index
;
4210 Get_First_Interp
(Name
, Index
, It
);
4211 while Present
(It
.Nam
) loop
4214 if Ekind
(Proc
) = E_Procedure
4215 and then No
(First_Formal
(Proc
))
4219 Set_Entity
(Name
, Proc
);
4220 Set_Is_Overloaded
(Name
, False);
4223 ("ambiguous handler name for pragma% ", Arg
);
4227 Get_Next_Interp
(Index
, It
);
4232 ("argument of pragma% must be parameterless procedure",
4235 Proc
:= Entity
(Name
);
4241 end Find_Unique_Parameterless_Procedure
;
4247 procedure Fix_Error
(Msg
: in out String) is
4249 -- If we have a rewriting of another pragma, go to that pragma
4251 if Is_Rewrite_Substitution
(N
)
4252 and then Nkind
(Original_Node
(N
)) = N_Pragma
4254 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
4257 -- Case where pragma comes from an aspect specification
4259 if From_Aspect_Specification
(N
) then
4261 -- Change appearence of "pragma" in message to "aspect"
4263 for J
in Msg
'First .. Msg
'Last - 5 loop
4264 if Msg
(J
.. J
+ 5) = "pragma" then
4265 Msg
(J
.. J
+ 5) := "aspect";
4269 -- Get name from corresponding aspect
4271 Error_Msg_Name_1
:= Original_Name
(N
);
4275 -------------------------
4276 -- Gather_Associations --
4277 -------------------------
4279 procedure Gather_Associations
4281 Args
: out Args_List
)
4286 -- Initialize all parameters to Empty
4288 for J
in Args
'Range loop
4292 -- That's all we have to do if there are no argument associations
4294 if No
(Pragma_Argument_Associations
(N
)) then
4298 -- Otherwise first deal with any positional parameters present
4300 Arg
:= First
(Pragma_Argument_Associations
(N
));
4301 for Index
in Args
'Range loop
4302 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
4303 Args
(Index
) := Get_Pragma_Arg
(Arg
);
4307 -- Positional parameters all processed, if any left, then we
4308 -- have too many positional parameters.
4310 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
4312 ("too many positional associations for pragma%", Arg
);
4315 -- Process named parameters if any are present
4317 while Present
(Arg
) loop
4318 if Chars
(Arg
) = No_Name
then
4320 ("positional association cannot follow named association",
4324 for Index
in Names
'Range loop
4325 if Names
(Index
) = Chars
(Arg
) then
4326 if Present
(Args
(Index
)) then
4328 ("duplicate argument association for pragma%", Arg
);
4330 Args
(Index
) := Get_Pragma_Arg
(Arg
);
4335 if Index
= Names
'Last then
4336 Error_Msg_Name_1
:= Pname
;
4337 Error_Msg_N
("pragma% does not allow & argument", Arg
);
4339 -- Check for possible misspelling
4341 for Index1
in Names
'Range loop
4342 if Is_Bad_Spelling_Of
4343 (Chars
(Arg
), Names
(Index1
))
4345 Error_Msg_Name_1
:= Names
(Index1
);
4346 Error_Msg_N
-- CODEFIX
4347 ("\possible misspelling of%", Arg
);
4359 end Gather_Associations
;
4365 procedure GNAT_Pragma
is
4367 -- We need to check the No_Implementation_Pragmas restriction for
4368 -- the case of a pragma from source. Note that the case of aspects
4369 -- generating corresponding pragmas marks these pragmas as not being
4370 -- from source, so this test also catches that case.
4372 if Comes_From_Source
(N
) then
4373 Check_Restriction
(No_Implementation_Pragmas
, N
);
4377 --------------------------
4378 -- Is_Before_First_Decl --
4379 --------------------------
4381 function Is_Before_First_Decl
4382 (Pragma_Node
: Node_Id
;
4383 Decls
: List_Id
) return Boolean
4385 Item
: Node_Id
:= First
(Decls
);
4388 -- Only other pragmas can come before this pragma
4391 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
4394 elsif Item
= Pragma_Node
then
4400 end Is_Before_First_Decl
;
4402 -----------------------------
4403 -- Is_Configuration_Pragma --
4404 -----------------------------
4406 -- A configuration pragma must appear in the context clause of a
4407 -- compilation unit, and only other pragmas may precede it. Note that
4408 -- the test below also permits use in a configuration pragma file.
4410 function Is_Configuration_Pragma
return Boolean is
4411 Lis
: constant List_Id
:= List_Containing
(N
);
4412 Par
: constant Node_Id
:= Parent
(N
);
4416 -- If no parent, then we are in the configuration pragma file,
4417 -- so the placement is definitely appropriate.
4422 -- Otherwise we must be in the context clause of a compilation unit
4423 -- and the only thing allowed before us in the context list is more
4424 -- configuration pragmas.
4426 elsif Nkind
(Par
) = N_Compilation_Unit
4427 and then Context_Items
(Par
) = Lis
4434 elsif Nkind
(Prg
) /= N_Pragma
then
4444 end Is_Configuration_Pragma
;
4446 --------------------------
4447 -- Is_In_Context_Clause --
4448 --------------------------
4450 function Is_In_Context_Clause
return Boolean is
4452 Parent_Node
: Node_Id
;
4455 if not Is_List_Member
(N
) then
4459 Plist
:= List_Containing
(N
);
4460 Parent_Node
:= Parent
(Plist
);
4462 if Parent_Node
= Empty
4463 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
4464 or else Context_Items
(Parent_Node
) /= Plist
4471 end Is_In_Context_Clause
;
4473 ---------------------------------
4474 -- Is_Static_String_Expression --
4475 ---------------------------------
4477 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
4478 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4481 Analyze_And_Resolve
(Argx
);
4482 return Is_OK_Static_Expression
(Argx
)
4483 and then Nkind
(Argx
) = N_String_Literal
;
4484 end Is_Static_String_Expression
;
4486 ----------------------
4487 -- Pragma_Misplaced --
4488 ----------------------
4490 procedure Pragma_Misplaced
is
4492 Error_Pragma
("incorrect placement of pragma%");
4493 end Pragma_Misplaced
;
4495 ------------------------------------
4496 -- Process_Atomic_Shared_Volatile --
4497 ------------------------------------
4499 procedure Process_Atomic_Shared_Volatile
is
4506 procedure Set_Atomic
(E
: Entity_Id
);
4507 -- Set given type as atomic, and if no explicit alignment was given,
4508 -- set alignment to unknown, since back end knows what the alignment
4509 -- requirements are for atomic arrays. Note: this step is necessary
4510 -- for derived types.
4516 procedure Set_Atomic
(E
: Entity_Id
) is
4520 if not Has_Alignment_Clause
(E
) then
4521 Set_Alignment
(E
, Uint_0
);
4525 -- Start of processing for Process_Atomic_Shared_Volatile
4528 Check_Ada_83_Warning
;
4529 Check_No_Identifiers
;
4530 Check_Arg_Count
(1);
4531 Check_Arg_Is_Local_Name
(Arg1
);
4532 E_Id
:= Get_Pragma_Arg
(Arg1
);
4534 if Etype
(E_Id
) = Any_Type
then
4539 D
:= Declaration_Node
(E
);
4542 -- Check duplicate before we chain ourselves!
4544 Check_Duplicate_Pragma
(E
);
4546 -- Now check appropriateness of the entity
4549 if Rep_Item_Too_Early
(E
, N
)
4551 Rep_Item_Too_Late
(E
, N
)
4555 Check_First_Subtype
(Arg1
);
4558 if Prag_Id
/= Pragma_Volatile
then
4560 Set_Atomic
(Underlying_Type
(E
));
4561 Set_Atomic
(Base_Type
(E
));
4564 -- Attribute belongs on the base type. If the view of the type is
4565 -- currently private, it also belongs on the underlying type.
4567 Set_Is_Volatile
(Base_Type
(E
));
4568 Set_Is_Volatile
(Underlying_Type
(E
));
4570 Set_Treat_As_Volatile
(E
);
4571 Set_Treat_As_Volatile
(Underlying_Type
(E
));
4573 elsif K
= N_Object_Declaration
4574 or else (K
= N_Component_Declaration
4575 and then Original_Record_Component
(E
) = E
)
4577 if Rep_Item_Too_Late
(E
, N
) then
4581 if Prag_Id
/= Pragma_Volatile
then
4584 -- If the object declaration has an explicit initialization, a
4585 -- temporary may have to be created to hold the expression, to
4586 -- ensure that access to the object remain atomic.
4588 if Nkind
(Parent
(E
)) = N_Object_Declaration
4589 and then Present
(Expression
(Parent
(E
)))
4591 Set_Has_Delayed_Freeze
(E
);
4594 -- An interesting improvement here. If an object of composite
4595 -- type X is declared atomic, and the type X isn't, that's a
4596 -- pity, since it may not have appropriate alignment etc. We
4597 -- can rescue this in the special case where the object and
4598 -- type are in the same unit by just setting the type as
4599 -- atomic, so that the back end will process it as atomic.
4601 -- Note: we used to do this for elementary types as well,
4602 -- but that turns out to be a bad idea and can have unwanted
4603 -- effects, most notably if the type is elementary, the object
4604 -- a simple component within a record, and both are in a spec:
4605 -- every object of this type in the entire program will be
4606 -- treated as atomic, thus incurring a potentially costly
4607 -- synchronization operation for every access.
4609 -- Of course it would be best if the back end could just adjust
4610 -- the alignment etc for the specific object, but that's not
4611 -- something we are capable of doing at this point.
4613 Utyp
:= Underlying_Type
(Etype
(E
));
4616 and then Is_Composite_Type
(Utyp
)
4617 and then Sloc
(E
) > No_Location
4618 and then Sloc
(Utyp
) > No_Location
4620 Get_Source_File_Index
(Sloc
(E
)) =
4621 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
4623 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
4627 Set_Is_Volatile
(E
);
4628 Set_Treat_As_Volatile
(E
);
4632 ("inappropriate entity for pragma%", Arg1
);
4634 end Process_Atomic_Shared_Volatile
;
4636 -------------------------------------------
4637 -- Process_Compile_Time_Warning_Or_Error --
4638 -------------------------------------------
4640 procedure Process_Compile_Time_Warning_Or_Error
is
4641 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4644 Check_Arg_Count
(2);
4645 Check_No_Identifiers
;
4646 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
4647 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
4649 if Compile_Time_Known_Value
(Arg1x
) then
4650 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
4652 Str
: constant String_Id
:=
4653 Strval
(Get_Pragma_Arg
(Arg2
));
4654 Len
: constant Int
:= String_Length
(Str
);
4659 Cent
: constant Entity_Id
:=
4660 Cunit_Entity
(Current_Sem_Unit
);
4662 Force
: constant Boolean :=
4663 Prag_Id
= Pragma_Compile_Time_Warning
4665 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
4666 and then (Ekind
(Cent
) /= E_Package
4667 or else not In_Private_Part
(Cent
));
4668 -- Set True if this is the warning case, and we are in the
4669 -- visible part of a package spec, or in a subprogram spec,
4670 -- in which case we want to force the client to see the
4671 -- warning, even though it is not in the main unit.
4674 -- Loop through segments of message separated by line feeds.
4675 -- We output these segments as separate messages with
4676 -- continuation marks for all but the first.
4681 Error_Msg_Strlen
:= 0;
4683 -- Loop to copy characters from argument to error message
4687 exit when Ptr
> Len
;
4688 CC
:= Get_String_Char
(Str
, Ptr
);
4691 -- Ignore wide chars ??? else store character
4693 if In_Character_Range
(CC
) then
4694 C
:= Get_Character
(CC
);
4695 exit when C
= ASCII
.LF
;
4696 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
4697 Error_Msg_String
(Error_Msg_Strlen
) := C
;
4701 -- Here with one line ready to go
4703 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
4705 -- If this is a warning in a spec, then we want clients
4706 -- to see the warning, so mark the message with the
4707 -- special sequence !! to force the warning. In the case
4708 -- of a package spec, we do not force this if we are in
4709 -- the private part of the spec.
4712 if Cont
= False then
4713 Error_Msg_N
("<~!!", Arg1
);
4716 Error_Msg_N
("\<~!!", Arg1
);
4719 -- Error, rather than warning, or in a body, so we do not
4720 -- need to force visibility for client (error will be
4721 -- output in any case, and this is the situation in which
4722 -- we do not want a client to get a warning, since the
4723 -- warning is in the body or the spec private part).
4726 if Cont
= False then
4727 Error_Msg_N
("<~", Arg1
);
4730 Error_Msg_N
("\<~", Arg1
);
4734 exit when Ptr
> Len
;
4739 end Process_Compile_Time_Warning_Or_Error
;
4741 ------------------------
4742 -- Process_Convention --
4743 ------------------------
4745 procedure Process_Convention
4746 (C
: out Convention_Id
;
4747 Ent
: out Entity_Id
)
4753 Comp_Unit
: Unit_Number_Type
;
4755 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
4756 -- Called if we have more than one Export/Import/Convention pragma.
4757 -- This is generally illegal, but we have a special case of allowing
4758 -- Import and Interface to coexist if they specify the convention in
4759 -- a consistent manner. We are allowed to do this, since Interface is
4760 -- an implementation defined pragma, and we choose to do it since we
4761 -- know Rational allows this combination. S is the entity id of the
4762 -- subprogram in question. This procedure also sets the special flag
4763 -- Import_Interface_Present in both pragmas in the case where we do
4764 -- have matching Import and Interface pragmas.
4766 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
4767 -- Set convention in entity E, and also flag that the entity has a
4768 -- convention pragma. If entity is for a private or incomplete type,
4769 -- also set convention and flag on underlying type. This procedure
4770 -- also deals with the special case of C_Pass_By_Copy convention.
4772 -------------------------------
4773 -- Diagnose_Multiple_Pragmas --
4774 -------------------------------
4776 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
4777 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
4781 function Same_Convention
(Decl
: Node_Id
) return Boolean;
4782 -- Decl is a pragma node. This function returns True if this
4783 -- pragma has a first argument that is an identifier with a
4784 -- Chars field corresponding to the Convention_Id C.
4786 function Same_Name
(Decl
: Node_Id
) return Boolean;
4787 -- Decl is a pragma node. This function returns True if this
4788 -- pragma has a second argument that is an identifier with a
4789 -- Chars field that matches the Chars of the current subprogram.
4791 ---------------------
4792 -- Same_Convention --
4793 ---------------------
4795 function Same_Convention
(Decl
: Node_Id
) return Boolean is
4796 Arg1
: constant Node_Id
:=
4797 First
(Pragma_Argument_Associations
(Decl
));
4800 if Present
(Arg1
) then
4802 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4804 if Nkind
(Arg
) = N_Identifier
4805 and then Is_Convention_Name
(Chars
(Arg
))
4806 and then Get_Convention_Id
(Chars
(Arg
)) = C
4814 end Same_Convention
;
4820 function Same_Name
(Decl
: Node_Id
) return Boolean is
4821 Arg1
: constant Node_Id
:=
4822 First
(Pragma_Argument_Associations
(Decl
));
4830 Arg2
:= Next
(Arg1
);
4837 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
4839 if Nkind
(Arg
) = N_Identifier
4840 and then Chars
(Arg
) = Chars
(S
)
4849 -- Start of processing for Diagnose_Multiple_Pragmas
4854 -- Definitely give message if we have Convention/Export here
4856 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
4859 -- If we have an Import or Export, scan back from pragma to
4860 -- find any previous pragma applying to the same procedure.
4861 -- The scan will be terminated by the start of the list, or
4862 -- hitting the subprogram declaration. This won't allow one
4863 -- pragma to appear in the public part and one in the private
4864 -- part, but that seems very unlikely in practice.
4868 while Present
(Decl
) and then Decl
/= Pdec
loop
4870 -- Look for pragma with same name as us
4872 if Nkind
(Decl
) = N_Pragma
4873 and then Same_Name
(Decl
)
4875 -- Give error if same as our pragma or Export/Convention
4877 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
4883 -- Case of Import/Interface or the other way round
4885 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
4888 -- Here we know that we have Import and Interface. It
4889 -- doesn't matter which way round they are. See if
4890 -- they specify the same convention. If so, all OK,
4891 -- and set special flags to stop other messages
4893 if Same_Convention
(Decl
) then
4894 Set_Import_Interface_Present
(N
);
4895 Set_Import_Interface_Present
(Decl
);
4898 -- If different conventions, special message
4901 Error_Msg_Sloc
:= Sloc
(Decl
);
4903 ("convention differs from that given#", Arg1
);
4913 -- Give message if needed if we fall through those tests
4914 -- except on Relaxed_RM_Semantics where we let go: either this
4915 -- is a case accepted/ignored by other Ada compilers (e.g.
4916 -- a mix of Convention and Import), or another error will be
4917 -- generated later (e.g. using both Import and Export).
4919 if Err
and not Relaxed_RM_Semantics
then
4921 ("at most one Convention/Export/Import pragma is allowed",
4924 end Diagnose_Multiple_Pragmas
;
4926 --------------------------------
4927 -- Set_Convention_From_Pragma --
4928 --------------------------------
4930 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
4932 -- Ada 2005 (AI-430): Check invalid attempt to change convention
4933 -- for an overridden dispatching operation. Technically this is
4934 -- an amendment and should only be done in Ada 2005 mode. However,
4935 -- this is clearly a mistake, since the problem that is addressed
4936 -- by this AI is that there is a clear gap in the RM!
4938 if Is_Dispatching_Operation
(E
)
4939 and then Present
(Overridden_Operation
(E
))
4940 and then C
/= Convention
(Overridden_Operation
(E
))
4942 -- An attempt to override a subprogram with a ghost subprogram
4943 -- appears as a mismatch in conventions.
4945 if C
= Convention_Ghost
then
4946 Error_Msg_N
("ghost subprogram & cannot be overriding", E
);
4949 ("cannot change convention for overridden dispatching "
4950 & "operation", Arg1
);
4954 -- Special checks for Convention_Stdcall
4956 if C
= Convention_Stdcall
then
4958 -- A dispatching call is not allowed. A dispatching subprogram
4959 -- cannot be used to interface to the Win32 API, so in fact
4960 -- this check does not impose any effective restriction.
4962 if Is_Dispatching_Operation
(E
) then
4963 Error_Msg_Sloc
:= Sloc
(E
);
4965 -- Note: make this unconditional so that if there is more
4966 -- than one call to which the pragma applies, we get a
4967 -- message for each call. Also don't use Error_Pragma,
4968 -- so that we get multiple messages!
4971 ("dispatching subprogram# cannot use Stdcall convention!",
4974 -- Subprogram is allowed, but not a generic subprogram
4976 elsif not Is_Subprogram
(E
)
4977 and then not Is_Generic_Subprogram
(E
)
4981 and then Ekind
(E
) /= E_Variable
4983 -- An access to subprogram is also allowed
4987 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
4989 -- Allow internal call to set convention of subprogram type
4991 and then not (Ekind
(E
) = E_Subprogram_Type
)
4994 ("second argument of pragma% must be subprogram (type)",
4999 -- Set the convention
5001 Set_Convention
(E
, C
);
5002 Set_Has_Convention_Pragma
(E
);
5004 if Is_Incomplete_Or_Private_Type
(E
)
5005 and then Present
(Underlying_Type
(E
))
5007 Set_Convention
(Underlying_Type
(E
), C
);
5008 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
5011 -- A class-wide type should inherit the convention of the specific
5012 -- root type (although this isn't specified clearly by the RM).
5014 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
5015 Set_Convention
(Class_Wide_Type
(E
), C
);
5018 -- If the entity is a record type, then check for special case of
5019 -- C_Pass_By_Copy, which is treated the same as C except that the
5020 -- special record flag is set. This convention is only permitted
5021 -- on record types (see AI95-00131).
5023 if Cname
= Name_C_Pass_By_Copy
then
5024 if Is_Record_Type
(E
) then
5025 Set_C_Pass_By_Copy
(Base_Type
(E
));
5026 elsif Is_Incomplete_Or_Private_Type
(E
)
5027 and then Is_Record_Type
(Underlying_Type
(E
))
5029 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
5032 ("C_Pass_By_Copy convention allowed only for record type",
5037 -- If the entity is a derived boolean type, check for the special
5038 -- case of convention C, C++, or Fortran, where we consider any
5039 -- nonzero value to represent true.
5041 if Is_Discrete_Type
(E
)
5042 and then Root_Type
(Etype
(E
)) = Standard_Boolean
5048 C
= Convention_Fortran
)
5050 Set_Nonzero_Is_True
(Base_Type
(E
));
5052 end Set_Convention_From_Pragma
;
5054 -- Start of processing for Process_Convention
5057 Check_At_Least_N_Arguments
(2);
5058 Check_Optional_Identifier
(Arg1
, Name_Convention
);
5059 Check_Arg_Is_Identifier
(Arg1
);
5060 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
5062 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
5063 -- tested again below to set the critical flag).
5065 if Cname
= Name_C_Pass_By_Copy
then
5068 -- Otherwise we must have something in the standard convention list
5070 elsif Is_Convention_Name
(Cname
) then
5071 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
5073 -- In DEC VMS, it seems that there is an undocumented feature that
5074 -- any unrecognized convention is treated as the default, which for
5075 -- us is convention C. It does not seem so terrible to do this
5076 -- unconditionally, silently in the VMS case, and with a warning
5077 -- in the non-VMS case.
5080 if Warn_On_Export_Import
and not OpenVMS_On_Target
then
5082 ("??unrecognized convention name, C assumed",
5083 Get_Pragma_Arg
(Arg1
));
5089 Check_Optional_Identifier
(Arg2
, Name_Entity
);
5090 Check_Arg_Is_Local_Name
(Arg2
);
5092 Id
:= Get_Pragma_Arg
(Arg2
);
5095 if not Is_Entity_Name
(Id
) then
5096 Error_Pragma_Arg
("entity name required", Arg2
);
5101 -- Set entity to return
5105 -- Ada_Pass_By_Copy special checking
5107 if C
= Convention_Ada_Pass_By_Copy
then
5108 if not Is_First_Subtype
(E
) then
5110 ("convention `Ada_Pass_By_Copy` only allowed for types",
5114 if Is_By_Reference_Type
(E
) then
5116 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
5121 -- Ada_Pass_By_Reference special checking
5123 if C
= Convention_Ada_Pass_By_Reference
then
5124 if not Is_First_Subtype
(E
) then
5126 ("convention `Ada_Pass_By_Reference` only allowed for types",
5130 if Is_By_Copy_Type
(E
) then
5132 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
5137 -- Ghost special checking
5139 if Is_Ghost_Subprogram
(E
)
5140 and then Present
(Overridden_Operation
(E
))
5142 Error_Msg_N
("ghost subprogram & cannot be overriding", E
);
5145 -- Go to renamed subprogram if present, since convention applies to
5146 -- the actual renamed entity, not to the renaming entity. If the
5147 -- subprogram is inherited, go to parent subprogram.
5149 if Is_Subprogram
(E
)
5150 and then Present
(Alias
(E
))
5152 if Nkind
(Parent
(Declaration_Node
(E
))) =
5153 N_Subprogram_Renaming_Declaration
5155 if Scope
(E
) /= Scope
(Alias
(E
)) then
5157 ("cannot apply pragma% to non-local entity&#", E
);
5162 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
5163 N_Private_Extension_Declaration
)
5164 and then Scope
(E
) = Scope
(Alias
(E
))
5168 -- Return the parent subprogram the entity was inherited from
5174 -- Check that we are not applying this to a specless body
5175 -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada
5178 if Is_Subprogram
(E
)
5179 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
5180 and then not Relaxed_RM_Semantics
5183 ("pragma% requires separate spec and must come before body");
5186 -- Check that we are not applying this to a named constant
5188 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
5189 Error_Msg_Name_1
:= Pname
;
5191 ("cannot apply pragma% to named constant!",
5192 Get_Pragma_Arg
(Arg2
));
5194 ("\supply appropriate type for&!", Arg2
);
5197 if Ekind
(E
) = E_Enumeration_Literal
then
5198 Error_Pragma
("enumeration literal not allowed for pragma%");
5201 -- Check for rep item appearing too early or too late
5203 if Etype
(E
) = Any_Type
5204 or else Rep_Item_Too_Early
(E
, N
)
5208 elsif Present
(Underlying_Type
(E
)) then
5209 E
:= Underlying_Type
(E
);
5212 if Rep_Item_Too_Late
(E
, N
) then
5216 if Has_Convention_Pragma
(E
) then
5217 Diagnose_Multiple_Pragmas
(E
);
5219 elsif Convention
(E
) = Convention_Protected
5220 or else Ekind
(Scope
(E
)) = E_Protected_Type
5223 ("a protected operation cannot be given a different convention",
5227 -- For Intrinsic, a subprogram is required
5229 if C
= Convention_Intrinsic
5230 and then not Is_Subprogram
(E
)
5231 and then not Is_Generic_Subprogram
(E
)
5234 ("second argument of pragma% must be a subprogram", Arg2
);
5237 -- Deal with non-subprogram cases
5239 if not Is_Subprogram
(E
)
5240 and then not Is_Generic_Subprogram
(E
)
5242 Set_Convention_From_Pragma
(E
);
5245 Check_First_Subtype
(Arg2
);
5246 Set_Convention_From_Pragma
(Base_Type
(E
));
5248 -- For access subprograms, we must set the convention on the
5249 -- internally generated directly designated type as well.
5251 if Ekind
(E
) = E_Access_Subprogram_Type
then
5252 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
5256 -- For the subprogram case, set proper convention for all homonyms
5257 -- in same scope and the same declarative part, i.e. the same
5258 -- compilation unit.
5261 Comp_Unit
:= Get_Source_Unit
(E
);
5262 Set_Convention_From_Pragma
(E
);
5264 -- Treat a pragma Import as an implicit body, and pragma import
5265 -- as implicit reference (for navigation in GPS).
5267 if Prag_Id
= Pragma_Import
then
5268 Generate_Reference
(E
, Id
, 'b');
5270 -- For exported entities we restrict the generation of references
5271 -- to entities exported to foreign languages since entities
5272 -- exported to Ada do not provide further information to GPS and
5273 -- add undesired references to the output of the gnatxref tool.
5275 elsif Prag_Id
= Pragma_Export
5276 and then Convention
(E
) /= Convention_Ada
5278 Generate_Reference
(E
, Id
, 'i');
5281 -- If the pragma comes from from an aspect, it only applies to the
5282 -- given entity, not its homonyms.
5284 if From_Aspect_Specification
(N
) then
5288 -- Otherwise Loop through the homonyms of the pragma argument's
5289 -- entity, an apply convention to those in the current scope.
5295 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
5297 -- Ignore entry for which convention is already set
5299 if Has_Convention_Pragma
(E1
) then
5303 -- Do not set the pragma on inherited operations or on formal
5306 if Comes_From_Source
(E1
)
5307 and then Comp_Unit
= Get_Source_Unit
(E1
)
5308 and then not Is_Formal_Subprogram
(E1
)
5309 and then Nkind
(Original_Node
(Parent
(E1
))) /=
5310 N_Full_Type_Declaration
5312 if Present
(Alias
(E1
))
5313 and then Scope
(E1
) /= Scope
(Alias
(E1
))
5316 ("cannot apply pragma% to non-local entity& declared#",
5320 Set_Convention_From_Pragma
(E1
);
5322 if Prag_Id
= Pragma_Import
then
5323 Generate_Reference
(E1
, Id
, 'b');
5331 end Process_Convention
;
5333 ----------------------------------------
5334 -- Process_Disable_Enable_Atomic_Sync --
5335 ----------------------------------------
5337 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
5339 Check_No_Identifiers
;
5340 Check_At_Most_N_Arguments
(1);
5342 -- Modeled internally as
5343 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
5347 Pragma_Identifier
=>
5348 Make_Identifier
(Loc
, Nam
),
5349 Pragma_Argument_Associations
=> New_List
(
5350 Make_Pragma_Argument_Association
(Loc
,
5352 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
5354 if Present
(Arg1
) then
5355 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
5359 end Process_Disable_Enable_Atomic_Sync
;
5361 -----------------------------------------------------
5362 -- Process_Extended_Import_Export_Exception_Pragma --
5363 -----------------------------------------------------
5365 procedure Process_Extended_Import_Export_Exception_Pragma
5366 (Arg_Internal
: Node_Id
;
5367 Arg_External
: Node_Id
;
5375 if not OpenVMS_On_Target
then
5377 ("??pragma% ignored (applies only to Open'V'M'S)");
5380 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
5381 Def_Id
:= Entity
(Arg_Internal
);
5383 if Ekind
(Def_Id
) /= E_Exception
then
5385 ("pragma% must refer to declared exception", Arg_Internal
);
5388 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
5390 if Present
(Arg_Form
) then
5391 Check_Arg_Is_One_Of
(Arg_Form
, Name_Ada
, Name_VMS
);
5394 if Present
(Arg_Form
)
5395 and then Chars
(Arg_Form
) = Name_Ada
5399 Set_Is_VMS_Exception
(Def_Id
);
5400 Set_Exception_Code
(Def_Id
, No_Uint
);
5403 if Present
(Arg_Code
) then
5404 if not Is_VMS_Exception
(Def_Id
) then
5406 ("Code option for pragma% not allowed for Ada case",
5410 Check_Arg_Is_Static_Expression
(Arg_Code
, Any_Integer
);
5411 Code_Val
:= Expr_Value
(Arg_Code
);
5413 if not UI_Is_In_Int_Range
(Code_Val
) then
5415 ("Code option for pragma% must be in 32-bit range",
5419 Set_Exception_Code
(Def_Id
, Code_Val
);
5422 end Process_Extended_Import_Export_Exception_Pragma
;
5424 -------------------------------------------------
5425 -- Process_Extended_Import_Export_Internal_Arg --
5426 -------------------------------------------------
5428 procedure Process_Extended_Import_Export_Internal_Arg
5429 (Arg_Internal
: Node_Id
:= Empty
)
5432 if No
(Arg_Internal
) then
5433 Error_Pragma
("Internal parameter required for pragma%");
5436 if Nkind
(Arg_Internal
) = N_Identifier
then
5439 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
5440 and then (Prag_Id
= Pragma_Import_Function
5442 Prag_Id
= Pragma_Export_Function
)
5448 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
5451 Check_Arg_Is_Local_Name
(Arg_Internal
);
5452 end Process_Extended_Import_Export_Internal_Arg
;
5454 --------------------------------------------------
5455 -- Process_Extended_Import_Export_Object_Pragma --
5456 --------------------------------------------------
5458 procedure Process_Extended_Import_Export_Object_Pragma
5459 (Arg_Internal
: Node_Id
;
5460 Arg_External
: Node_Id
;
5466 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
5467 Def_Id
:= Entity
(Arg_Internal
);
5469 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
5471 ("pragma% must designate an object", Arg_Internal
);
5474 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
5476 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
5479 ("previous Common/Psect_Object applies, pragma % not permitted",
5483 if Rep_Item_Too_Late
(Def_Id
, N
) then
5487 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
5489 if Present
(Arg_Size
) then
5490 Check_Arg_Is_External_Name
(Arg_Size
);
5493 -- Export_Object case
5495 if Prag_Id
= Pragma_Export_Object
then
5496 if not Is_Library_Level_Entity
(Def_Id
) then
5498 ("argument for pragma% must be library level entity",
5502 if Ekind
(Current_Scope
) = E_Generic_Package
then
5503 Error_Pragma
("pragma& cannot appear in a generic unit");
5506 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
5508 ("exported object must have compile time known size",
5512 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
5513 Error_Msg_N
("??duplicate Export_Object pragma", N
);
5515 Set_Exported
(Def_Id
, Arg_Internal
);
5518 -- Import_Object case
5521 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
5523 ("cannot use pragma% for task/protected object",
5527 if Ekind
(Def_Id
) = E_Constant
then
5529 ("cannot import a constant", Arg_Internal
);
5532 if Warn_On_Export_Import
5533 and then Has_Discriminants
(Etype
(Def_Id
))
5536 ("imported value must be initialized??", Arg_Internal
);
5539 if Warn_On_Export_Import
5540 and then Is_Access_Type
(Etype
(Def_Id
))
5543 ("cannot import object of an access type??", Arg_Internal
);
5546 if Warn_On_Export_Import
5547 and then Is_Imported
(Def_Id
)
5549 Error_Msg_N
("??duplicate Import_Object pragma", N
);
5551 -- Check for explicit initialization present. Note that an
5552 -- initialization generated by the code generator, e.g. for an
5553 -- access type, does not count here.
5555 elsif Present
(Expression
(Parent
(Def_Id
)))
5558 (Original_Node
(Expression
(Parent
(Def_Id
))))
5560 Error_Msg_Sloc
:= Sloc
(Def_Id
);
5562 ("imported entities cannot be initialized (RM B.1(24))",
5563 "\no initialization allowed for & declared#", Arg1
);
5565 Set_Imported
(Def_Id
);
5566 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
5569 end Process_Extended_Import_Export_Object_Pragma
;
5571 ------------------------------------------------------
5572 -- Process_Extended_Import_Export_Subprogram_Pragma --
5573 ------------------------------------------------------
5575 procedure Process_Extended_Import_Export_Subprogram_Pragma
5576 (Arg_Internal
: Node_Id
;
5577 Arg_External
: Node_Id
;
5578 Arg_Parameter_Types
: Node_Id
;
5579 Arg_Result_Type
: Node_Id
:= Empty
;
5580 Arg_Mechanism
: Node_Id
;
5581 Arg_Result_Mechanism
: Node_Id
:= Empty
;
5582 Arg_First_Optional_Parameter
: Node_Id
:= Empty
)
5588 Ambiguous
: Boolean;
5592 function Same_Base_Type
5594 Formal
: Entity_Id
) return Boolean;
5595 -- Determines if Ptype references the type of Formal. Note that only
5596 -- the base types need to match according to the spec. Ptype here is
5597 -- the argument from the pragma, which is either a type name, or an
5598 -- access attribute.
5600 --------------------
5601 -- Same_Base_Type --
5602 --------------------
5604 function Same_Base_Type
5606 Formal
: Entity_Id
) return Boolean
5608 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
5612 -- Case where pragma argument is typ'Access
5614 if Nkind
(Ptype
) = N_Attribute_Reference
5615 and then Attribute_Name
(Ptype
) = Name_Access
5617 Pref
:= Prefix
(Ptype
);
5620 if not Is_Entity_Name
(Pref
)
5621 or else Entity
(Pref
) = Any_Type
5626 -- We have a match if the corresponding argument is of an
5627 -- anonymous access type, and its designated type matches the
5628 -- type of the prefix of the access attribute
5630 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
5631 and then Base_Type
(Entity
(Pref
)) =
5632 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
5634 -- Case where pragma argument is a type name
5639 if not Is_Entity_Name
(Ptype
)
5640 or else Entity
(Ptype
) = Any_Type
5645 -- We have a match if the corresponding argument is of the type
5646 -- given in the pragma (comparing base types)
5648 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
5652 -- Start of processing for
5653 -- Process_Extended_Import_Export_Subprogram_Pragma
5656 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
5660 -- Loop through homonyms (overloadings) of the entity
5662 Hom_Id
:= Entity
(Arg_Internal
);
5663 while Present
(Hom_Id
) loop
5664 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
5666 -- We need a subprogram in the current scope
5668 if not Is_Subprogram
(Def_Id
)
5669 or else Scope
(Def_Id
) /= Current_Scope
5676 -- Pragma cannot apply to subprogram body
5678 if Is_Subprogram
(Def_Id
)
5679 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
5683 ("pragma% requires separate spec"
5684 & " and must come before body");
5687 -- Test result type if given, note that the result type
5688 -- parameter can only be present for the function cases.
5690 if Present
(Arg_Result_Type
)
5691 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
5695 elsif Etype
(Def_Id
) /= Standard_Void_Type
5697 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
5701 -- Test parameter types if given. Note that this parameter
5702 -- has not been analyzed (and must not be, since it is
5703 -- semantic nonsense), so we get it as the parser left it.
5705 elsif Present
(Arg_Parameter_Types
) then
5706 Check_Matching_Types
: declare
5711 Formal
:= First_Formal
(Def_Id
);
5713 if Nkind
(Arg_Parameter_Types
) = N_Null
then
5714 if Present
(Formal
) then
5718 -- A list of one type, e.g. (List) is parsed as
5719 -- a parenthesized expression.
5721 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
5722 and then Paren_Count
(Arg_Parameter_Types
) = 1
5725 or else Present
(Next_Formal
(Formal
))
5730 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
5733 -- A list of more than one type is parsed as a aggregate
5735 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
5736 and then Paren_Count
(Arg_Parameter_Types
) = 0
5738 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
5739 while Present
(Ptype
) or else Present
(Formal
) loop
5742 or else not Same_Base_Type
(Ptype
, Formal
)
5747 Next_Formal
(Formal
);
5752 -- Anything else is of the wrong form
5756 ("wrong form for Parameter_Types parameter",
5757 Arg_Parameter_Types
);
5759 end Check_Matching_Types
;
5762 -- Match is now False if the entry we found did not match
5763 -- either a supplied Parameter_Types or Result_Types argument
5769 -- Ambiguous case, the flag Ambiguous shows if we already
5770 -- detected this and output the initial messages.
5773 if not Ambiguous
then
5775 Error_Msg_Name_1
:= Pname
;
5777 ("pragma% does not uniquely identify subprogram!",
5779 Error_Msg_Sloc
:= Sloc
(Ent
);
5780 Error_Msg_N
("matching subprogram #!", N
);
5784 Error_Msg_Sloc
:= Sloc
(Def_Id
);
5785 Error_Msg_N
("matching subprogram #!", N
);
5790 Hom_Id
:= Homonym
(Hom_Id
);
5793 -- See if we found an entry
5796 if not Ambiguous
then
5797 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
5799 ("pragma% cannot be given for generic subprogram");
5802 ("pragma% does not identify local subprogram");
5809 -- Import pragmas must be for imported entities
5811 if Prag_Id
= Pragma_Import_Function
5813 Prag_Id
= Pragma_Import_Procedure
5815 Prag_Id
= Pragma_Import_Valued_Procedure
5817 if not Is_Imported
(Ent
) then
5819 ("pragma Import or Interface must precede pragma%");
5822 -- Here we have the Export case which can set the entity as exported
5824 -- But does not do so if the specified external name is null, since
5825 -- that is taken as a signal in DEC Ada 83 (with which we want to be
5826 -- compatible) to request no external name.
5828 elsif Nkind
(Arg_External
) = N_String_Literal
5829 and then String_Length
(Strval
(Arg_External
)) = 0
5833 -- In all other cases, set entity as exported
5836 Set_Exported
(Ent
, Arg_Internal
);
5839 -- Special processing for Valued_Procedure cases
5841 if Prag_Id
= Pragma_Import_Valued_Procedure
5843 Prag_Id
= Pragma_Export_Valued_Procedure
5845 Formal
:= First_Formal
(Ent
);
5848 Error_Pragma
("at least one parameter required for pragma%");
5850 elsif Ekind
(Formal
) /= E_Out_Parameter
then
5851 Error_Pragma
("first parameter must have mode out for pragma%");
5854 Set_Is_Valued_Procedure
(Ent
);
5858 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
5860 -- Process Result_Mechanism argument if present. We have already
5861 -- checked that this is only allowed for the function case.
5863 if Present
(Arg_Result_Mechanism
) then
5864 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
5867 -- Process Mechanism parameter if present. Note that this parameter
5868 -- is not analyzed, and must not be analyzed since it is semantic
5869 -- nonsense, so we get it in exactly as the parser left it.
5871 if Present
(Arg_Mechanism
) then
5879 -- A single mechanism association without a formal parameter
5880 -- name is parsed as a parenthesized expression. All other
5881 -- cases are parsed as aggregates, so we rewrite the single
5882 -- parameter case as an aggregate for consistency.
5884 if Nkind
(Arg_Mechanism
) /= N_Aggregate
5885 and then Paren_Count
(Arg_Mechanism
) = 1
5887 Rewrite
(Arg_Mechanism
,
5888 Make_Aggregate
(Sloc
(Arg_Mechanism
),
5889 Expressions
=> New_List
(
5890 Relocate_Node
(Arg_Mechanism
))));
5893 -- Case of only mechanism name given, applies to all formals
5895 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
5896 Formal
:= First_Formal
(Ent
);
5897 while Present
(Formal
) loop
5898 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
5899 Next_Formal
(Formal
);
5902 -- Case of list of mechanism associations given
5905 if Null_Record_Present
(Arg_Mechanism
) then
5907 ("inappropriate form for Mechanism parameter",
5911 -- Deal with positional ones first
5913 Formal
:= First_Formal
(Ent
);
5915 if Present
(Expressions
(Arg_Mechanism
)) then
5916 Mname
:= First
(Expressions
(Arg_Mechanism
));
5917 while Present
(Mname
) loop
5920 ("too many mechanism associations", Mname
);
5923 Set_Mechanism_Value
(Formal
, Mname
);
5924 Next_Formal
(Formal
);
5929 -- Deal with named entries
5931 if Present
(Component_Associations
(Arg_Mechanism
)) then
5932 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
5933 while Present
(Massoc
) loop
5934 Choice
:= First
(Choices
(Massoc
));
5936 if Nkind
(Choice
) /= N_Identifier
5937 or else Present
(Next
(Choice
))
5940 ("incorrect form for mechanism association",
5944 Formal
:= First_Formal
(Ent
);
5948 ("parameter name & not present", Choice
);
5951 if Chars
(Choice
) = Chars
(Formal
) then
5953 (Formal
, Expression
(Massoc
));
5955 -- Set entity on identifier (needed by ASIS)
5957 Set_Entity
(Choice
, Formal
);
5962 Next_Formal
(Formal
);
5972 -- Process First_Optional_Parameter argument if present. We have
5973 -- already checked that this is only allowed for the Import case.
5975 if Present
(Arg_First_Optional_Parameter
) then
5976 if Nkind
(Arg_First_Optional_Parameter
) /= N_Identifier
then
5978 ("first optional parameter must be formal parameter name",
5979 Arg_First_Optional_Parameter
);
5982 Formal
:= First_Formal
(Ent
);
5986 ("specified formal parameter& not found",
5987 Arg_First_Optional_Parameter
);
5990 exit when Chars
(Formal
) =
5991 Chars
(Arg_First_Optional_Parameter
);
5993 Next_Formal
(Formal
);
5996 Set_First_Optional_Parameter
(Ent
, Formal
);
5998 -- Check specified and all remaining formals have right form
6000 while Present
(Formal
) loop
6001 if Ekind
(Formal
) /= E_In_Parameter
then
6003 ("optional formal& is not of mode in!",
6004 Arg_First_Optional_Parameter
, Formal
);
6007 Dval
:= Default_Value
(Formal
);
6011 ("optional formal& does not have default value!",
6012 Arg_First_Optional_Parameter
, Formal
);
6014 elsif Compile_Time_Known_Value_Or_Aggr
(Dval
) then
6019 ("default value for optional formal& is non-static!",
6020 Arg_First_Optional_Parameter
, Formal
);
6024 Set_Is_Optional_Parameter
(Formal
);
6025 Next_Formal
(Formal
);
6028 end Process_Extended_Import_Export_Subprogram_Pragma
;
6030 --------------------------
6031 -- Process_Generic_List --
6032 --------------------------
6034 procedure Process_Generic_List
is
6039 Check_No_Identifiers
;
6040 Check_At_Least_N_Arguments
(1);
6042 -- Check all arguments are names of generic units or instances
6045 while Present
(Arg
) loop
6046 Exp
:= Get_Pragma_Arg
(Arg
);
6049 if not Is_Entity_Name
(Exp
)
6051 (not Is_Generic_Instance
(Entity
(Exp
))
6053 not Is_Generic_Unit
(Entity
(Exp
)))
6056 ("pragma% argument must be name of generic unit/instance",
6062 end Process_Generic_List
;
6064 ------------------------------------
6065 -- Process_Import_Predefined_Type --
6066 ------------------------------------
6068 procedure Process_Import_Predefined_Type
is
6069 Loc
: constant Source_Ptr
:= Sloc
(N
);
6071 Ftyp
: Node_Id
:= Empty
;
6077 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
6080 Elmt
:= First_Elmt
(Predefined_Float_Types
);
6081 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
6085 Ftyp
:= Node
(Elmt
);
6087 if Present
(Ftyp
) then
6089 -- Don't build a derived type declaration, because predefined C
6090 -- types have no declaration anywhere, so cannot really be named.
6091 -- Instead build a full type declaration, starting with an
6092 -- appropriate type definition is built
6094 if Is_Floating_Point_Type
(Ftyp
) then
6095 Def
:= Make_Floating_Point_Definition
(Loc
,
6096 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
6097 Make_Real_Range_Specification
(Loc
,
6098 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
6099 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
6101 -- Should never have a predefined type we cannot handle
6104 raise Program_Error
;
6107 -- Build and insert a Full_Type_Declaration, which will be
6108 -- analyzed as soon as this list entry has been analyzed.
6110 Decl
:= Make_Full_Type_Declaration
(Loc
,
6111 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
6112 Type_Definition
=> Def
);
6114 Insert_After
(N
, Decl
);
6115 Mark_Rewrite_Insertion
(Decl
);
6118 Error_Pragma_Arg
("no matching type found for pragma%",
6121 end Process_Import_Predefined_Type
;
6123 ---------------------------------
6124 -- Process_Import_Or_Interface --
6125 ---------------------------------
6127 procedure Process_Import_Or_Interface
is
6133 Process_Convention
(C
, Def_Id
);
6134 Kill_Size_Check_Code
(Def_Id
);
6135 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
6137 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
6139 -- We do not permit Import to apply to a renaming declaration
6141 if Present
(Renamed_Object
(Def_Id
)) then
6143 ("pragma% not allowed for object renaming", Arg2
);
6145 -- User initialization is not allowed for imported object, but
6146 -- the object declaration may contain a default initialization,
6147 -- that will be discarded. Note that an explicit initialization
6148 -- only counts if it comes from source, otherwise it is simply
6149 -- the code generator making an implicit initialization explicit.
6151 elsif Present
(Expression
(Parent
(Def_Id
)))
6152 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
6154 Error_Msg_Sloc
:= Sloc
(Def_Id
);
6156 ("no initialization allowed for declaration of& #",
6157 "\imported entities cannot be initialized (RM B.1(24))",
6161 Set_Imported
(Def_Id
);
6162 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
6164 -- Note that we do not set Is_Public here. That's because we
6165 -- only want to set it if there is no address clause, and we
6166 -- don't know that yet, so we delay that processing till
6169 -- pragma Import completes deferred constants
6171 if Ekind
(Def_Id
) = E_Constant
then
6172 Set_Has_Completion
(Def_Id
);
6175 -- It is not possible to import a constant of an unconstrained
6176 -- array type (e.g. string) because there is no simple way to
6177 -- write a meaningful subtype for it.
6179 if Is_Array_Type
(Etype
(Def_Id
))
6180 and then not Is_Constrained
(Etype
(Def_Id
))
6183 ("imported constant& must have a constrained subtype",
6188 elsif Is_Subprogram
(Def_Id
)
6189 or else Is_Generic_Subprogram
(Def_Id
)
6191 -- If the name is overloaded, pragma applies to all of the denoted
6192 -- entities in the same declarative part, unless the pragma comes
6193 -- from an aspect specification.
6196 while Present
(Hom_Id
) loop
6198 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
6200 -- Ignore inherited subprograms because the pragma will apply
6201 -- to the parent operation, which is the one called.
6203 if Is_Overloadable
(Def_Id
)
6204 and then Present
(Alias
(Def_Id
))
6208 -- If it is not a subprogram, it must be in an outer scope and
6209 -- pragma does not apply.
6211 elsif not Is_Subprogram
(Def_Id
)
6212 and then not Is_Generic_Subprogram
(Def_Id
)
6216 -- The pragma does not apply to primitives of interfaces
6218 elsif Is_Dispatching_Operation
(Def_Id
)
6219 and then Present
(Find_Dispatching_Type
(Def_Id
))
6220 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
6224 -- Verify that the homonym is in the same declarative part (not
6225 -- just the same scope). If the pragma comes from an aspect
6226 -- specification we know that it is part of the declaration.
6228 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
6229 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
6230 and then not From_Aspect_Specification
(N
)
6235 Set_Imported
(Def_Id
);
6237 -- Reject an Import applied to an abstract subprogram
6239 if Is_Subprogram
(Def_Id
)
6240 and then Is_Abstract_Subprogram
(Def_Id
)
6242 Error_Msg_Sloc
:= Sloc
(Def_Id
);
6244 ("cannot import abstract subprogram& declared#",
6248 -- Special processing for Convention_Intrinsic
6250 if C
= Convention_Intrinsic
then
6252 -- Link_Name argument not allowed for intrinsic
6256 Set_Is_Intrinsic_Subprogram
(Def_Id
);
6258 -- If no external name is present, then check that this
6259 -- is a valid intrinsic subprogram. If an external name
6260 -- is present, then this is handled by the back end.
6263 Check_Intrinsic_Subprogram
6264 (Def_Id
, Get_Pragma_Arg
(Arg2
));
6268 -- All interfaced procedures need an external symbol created
6269 -- for them since they are always referenced from another
6272 Set_Is_Public
(Def_Id
);
6274 -- Verify that the subprogram does not have a completion
6275 -- through a renaming declaration. For other completions the
6276 -- pragma appears as a too late representation.
6279 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
6283 and then Nkind
(Decl
) = N_Subprogram_Declaration
6284 and then Present
(Corresponding_Body
(Decl
))
6285 and then Nkind
(Unit_Declaration_Node
6286 (Corresponding_Body
(Decl
))) =
6287 N_Subprogram_Renaming_Declaration
6289 Error_Msg_Sloc
:= Sloc
(Def_Id
);
6291 ("cannot import&, renaming already provided for "
6292 & "declaration #", N
, Def_Id
);
6296 Set_Has_Completion
(Def_Id
);
6297 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
6300 if Is_Compilation_Unit
(Hom_Id
) then
6302 -- Its possible homonyms are not affected by the pragma.
6303 -- Such homonyms might be present in the context of other
6304 -- units being compiled.
6308 elsif From_Aspect_Specification
(N
) then
6312 Hom_Id
:= Homonym
(Hom_Id
);
6316 -- When the convention is Java or CIL, we also allow Import to
6317 -- be given for packages, generic packages, exceptions, record
6318 -- components, and access to subprograms.
6320 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
6322 (Is_Package_Or_Generic_Package
(Def_Id
)
6323 or else Ekind
(Def_Id
) = E_Exception
6324 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
6325 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
6327 Set_Imported
(Def_Id
);
6328 Set_Is_Public
(Def_Id
);
6329 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
6331 -- Import a CPP class
6333 elsif C
= Convention_CPP
6334 and then (Is_Record_Type
(Def_Id
)
6335 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
6337 if Ekind
(Def_Id
) = E_Incomplete_Type
then
6338 if Present
(Full_View
(Def_Id
)) then
6339 Def_Id
:= Full_View
(Def_Id
);
6343 ("cannot import 'C'P'P type before full declaration seen",
6344 Get_Pragma_Arg
(Arg2
));
6346 -- Although we have reported the error we decorate it as
6347 -- CPP_Class to avoid reporting spurious errors
6349 Set_Is_CPP_Class
(Def_Id
);
6354 -- Types treated as CPP classes must be declared limited (note:
6355 -- this used to be a warning but there is no real benefit to it
6356 -- since we did effectively intend to treat the type as limited
6359 if not Is_Limited_Type
(Def_Id
) then
6361 ("imported 'C'P'P type must be limited",
6362 Get_Pragma_Arg
(Arg2
));
6365 if Etype
(Def_Id
) /= Def_Id
6366 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
6368 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
6371 Set_Is_CPP_Class
(Def_Id
);
6373 -- Imported CPP types must not have discriminants (because C++
6374 -- classes do not have discriminants).
6376 if Has_Discriminants
(Def_Id
) then
6378 ("imported 'C'P'P type cannot have discriminants",
6379 First
(Discriminant_Specifications
6380 (Declaration_Node
(Def_Id
))));
6383 -- Check that components of imported CPP types do not have default
6384 -- expressions. For private types this check is performed when the
6385 -- full view is analyzed (see Process_Full_View).
6387 if not Is_Private_Type
(Def_Id
) then
6388 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
6391 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
6393 Check_Arg_Count
(3);
6394 Check_Arg_Is_Static_Expression
(Arg3
, Standard_String
);
6396 Process_Import_Predefined_Type
;
6400 ("second argument of pragma% must be object, subprogram "
6401 & "or incomplete type",
6405 -- If this pragma applies to a compilation unit, then the unit, which
6406 -- is a subprogram, does not require (or allow) a body. We also do
6407 -- not need to elaborate imported procedures.
6409 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
6411 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
6413 Set_Body_Required
(Cunit
, False);
6416 end Process_Import_Or_Interface
;
6418 --------------------
6419 -- Process_Inline --
6420 --------------------
6422 procedure Process_Inline
(Status
: Inline_Status
) is
6429 Effective
: Boolean := False;
6430 -- Set True if inline has some effect, i.e. if there is at least one
6431 -- subprogram set as inlined as a result of the use of the pragma.
6433 procedure Make_Inline
(Subp
: Entity_Id
);
6434 -- Subp is the defining unit name of the subprogram declaration. Set
6435 -- the flag, as well as the flag in the corresponding body, if there
6438 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
6439 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
6440 -- Has_Pragma_Inline_Always for the Inline_Always case.
6442 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
6443 -- Returns True if it can be determined at this stage that inlining
6444 -- is not possible, for example if the body is available and contains
6445 -- exception handlers, we prevent inlining, since otherwise we can
6446 -- get undefined symbols at link time. This function also emits a
6447 -- warning if front-end inlining is enabled and the pragma appears
6450 -- ??? is business with link symbols still valid, or does it relate
6451 -- to front end ZCX which is being phased out ???
6453 ---------------------------
6454 -- Inlining_Not_Possible --
6455 ---------------------------
6457 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
6458 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
6462 if Nkind
(Decl
) = N_Subprogram_Body
then
6463 Stats
:= Handled_Statement_Sequence
(Decl
);
6464 return Present
(Exception_Handlers
(Stats
))
6465 or else Present
(At_End_Proc
(Stats
));
6467 elsif Nkind
(Decl
) = N_Subprogram_Declaration
6468 and then Present
(Corresponding_Body
(Decl
))
6470 if Front_End_Inlining
6471 and then Analyzed
(Corresponding_Body
(Decl
))
6473 Error_Msg_N
("pragma appears too late, ignored??", N
);
6476 -- If the subprogram is a renaming as body, the body is just a
6477 -- call to the renamed subprogram, and inlining is trivially
6481 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
6482 N_Subprogram_Renaming_Declaration
6488 Handled_Statement_Sequence
6489 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
6492 Present
(Exception_Handlers
(Stats
))
6493 or else Present
(At_End_Proc
(Stats
));
6497 -- If body is not available, assume the best, the check is
6498 -- performed again when compiling enclosing package bodies.
6502 end Inlining_Not_Possible
;
6508 procedure Make_Inline
(Subp
: Entity_Id
) is
6509 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
6510 Inner_Subp
: Entity_Id
:= Subp
;
6513 -- Ignore if bad type, avoid cascaded error
6515 if Etype
(Subp
) = Any_Type
then
6519 -- Ignore if all inlining is suppressed
6521 elsif Suppress_All_Inlining
then
6525 -- If inlining is not possible, for now do not treat as an error
6527 elsif Status
/= Suppressed
6528 and then Inlining_Not_Possible
(Subp
)
6533 -- Here we have a candidate for inlining, but we must exclude
6534 -- derived operations. Otherwise we would end up trying to inline
6535 -- a phantom declaration, and the result would be to drag in a
6536 -- body which has no direct inlining associated with it. That
6537 -- would not only be inefficient but would also result in the
6538 -- backend doing cross-unit inlining in cases where it was
6539 -- definitely inappropriate to do so.
6541 -- However, a simple Comes_From_Source test is insufficient, since
6542 -- we do want to allow inlining of generic instances which also do
6543 -- not come from source. We also need to recognize specs generated
6544 -- by the front-end for bodies that carry the pragma. Finally,
6545 -- predefined operators do not come from source but are not
6546 -- inlineable either.
6548 elsif Is_Generic_Instance
(Subp
)
6549 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
6553 elsif not Comes_From_Source
(Subp
)
6554 and then Scope
(Subp
) /= Standard_Standard
6560 -- The referenced entity must either be the enclosing entity, or
6561 -- an entity declared within the current open scope.
6563 if Present
(Scope
(Subp
))
6564 and then Scope
(Subp
) /= Current_Scope
6565 and then Subp
/= Current_Scope
6568 ("argument of% must be entity in current scope", Assoc
);
6572 -- Processing for procedure, operator or function. If subprogram
6573 -- is aliased (as for an instance) indicate that the renamed
6574 -- entity (if declared in the same unit) is inlined.
6576 if Is_Subprogram
(Subp
) then
6577 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
6579 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
6580 Set_Inline_Flags
(Inner_Subp
);
6582 Decl
:= Parent
(Parent
(Inner_Subp
));
6584 if Nkind
(Decl
) = N_Subprogram_Declaration
6585 and then Present
(Corresponding_Body
(Decl
))
6587 Set_Inline_Flags
(Corresponding_Body
(Decl
));
6589 elsif Is_Generic_Instance
(Subp
) then
6591 -- Indicate that the body needs to be created for
6592 -- inlining subsequent calls. The instantiation node
6593 -- follows the declaration of the wrapper package
6596 if Scope
(Subp
) /= Standard_Standard
6598 Need_Subprogram_Instance_Body
6599 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
6605 -- Inline is a program unit pragma (RM 10.1.5) and cannot
6606 -- appear in a formal part to apply to a formal subprogram.
6607 -- Do not apply check within an instance or a formal package
6608 -- the test will have been applied to the original generic.
6610 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
6611 and then List_Containing
(Decl
) = List_Containing
(N
)
6612 and then not In_Instance
6615 ("Inline cannot apply to a formal subprogram", N
);
6617 -- If Subp is a renaming, it is the renamed entity that
6618 -- will appear in any call, and be inlined. However, for
6619 -- ASIS uses it is convenient to indicate that the renaming
6620 -- itself is an inlined subprogram, so that some gnatcheck
6621 -- rules can be applied in the absence of expansion.
6623 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
6624 Set_Inline_Flags
(Subp
);
6630 -- For a generic subprogram set flag as well, for use at the point
6631 -- of instantiation, to determine whether the body should be
6634 elsif Is_Generic_Subprogram
(Subp
) then
6635 Set_Inline_Flags
(Subp
);
6638 -- Literals are by definition inlined
6640 elsif Kind
= E_Enumeration_Literal
then
6643 -- Anything else is an error
6647 ("expect subprogram name for pragma%", Assoc
);
6651 ----------------------
6652 -- Set_Inline_Flags --
6653 ----------------------
6655 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
6657 -- First set the Has_Pragma_XXX flags and issue the appropriate
6658 -- errors and warnings for suspicious combinations.
6660 if Prag_Id
= Pragma_No_Inline
then
6661 if Has_Pragma_Inline_Always
(Subp
) then
6663 ("Inline_Always and No_Inline are mutually exclusive", N
);
6664 elsif Has_Pragma_Inline
(Subp
) then
6666 ("Inline and No_Inline both specified for& ??",
6667 N
, Entity
(Subp_Id
));
6670 Set_Has_Pragma_No_Inline
(Subp
);
6672 if Prag_Id
= Pragma_Inline_Always
then
6673 if Has_Pragma_No_Inline
(Subp
) then
6675 ("Inline_Always and No_Inline are mutually exclusive",
6679 Set_Has_Pragma_Inline_Always
(Subp
);
6681 if Has_Pragma_No_Inline
(Subp
) then
6683 ("Inline and No_Inline both specified for& ??",
6684 N
, Entity
(Subp_Id
));
6688 if not Has_Pragma_Inline
(Subp
) then
6689 Set_Has_Pragma_Inline
(Subp
);
6694 -- Then adjust the Is_Inlined flag. It can never be set if the
6695 -- subprogram is subject to pragma No_Inline.
6699 Set_Is_Inlined
(Subp
, False);
6703 if not Has_Pragma_No_Inline
(Subp
) then
6704 Set_Is_Inlined
(Subp
, True);
6707 end Set_Inline_Flags
;
6709 -- Start of processing for Process_Inline
6712 Check_No_Identifiers
;
6713 Check_At_Least_N_Arguments
(1);
6715 if Status
= Enabled
then
6716 Inline_Processing_Required
:= True;
6720 while Present
(Assoc
) loop
6721 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
6725 if Is_Entity_Name
(Subp_Id
) then
6726 Subp
:= Entity
(Subp_Id
);
6728 if Subp
= Any_Id
then
6730 -- If previous error, avoid cascaded errors
6732 Check_Error_Detected
;
6739 -- For the pragma case, climb homonym chain. This is
6740 -- what implements allowing the pragma in the renaming
6741 -- case, with the result applying to the ancestors, and
6742 -- also allows Inline to apply to all previous homonyms.
6744 if not From_Aspect_Specification
(N
) then
6745 while Present
(Homonym
(Subp
))
6746 and then Scope
(Homonym
(Subp
)) = Current_Scope
6748 Make_Inline
(Homonym
(Subp
));
6749 Subp
:= Homonym
(Subp
);
6757 ("inappropriate argument for pragma%", Assoc
);
6760 and then Warn_On_Redundant_Constructs
6761 and then not (Status
= Suppressed
or else Suppress_All_Inlining
)
6763 if Inlining_Not_Possible
(Subp
) then
6765 ("pragma Inline for& is ignored?r?",
6766 N
, Entity
(Subp_Id
));
6769 ("pragma Inline for& is redundant?r?",
6770 N
, Entity
(Subp_Id
));
6778 ----------------------------
6779 -- Process_Interface_Name --
6780 ----------------------------
6782 procedure Process_Interface_Name
6783 (Subprogram_Def
: Entity_Id
;
6789 String_Val
: String_Id
;
6791 procedure Check_Form_Of_Interface_Name
6793 Ext_Name_Case
: Boolean);
6794 -- SN is a string literal node for an interface name. This routine
6795 -- performs some minimal checks that the name is reasonable. In
6796 -- particular that no spaces or other obviously incorrect characters
6797 -- appear. This is only a warning, since any characters are allowed.
6798 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
6800 ----------------------------------
6801 -- Check_Form_Of_Interface_Name --
6802 ----------------------------------
6804 procedure Check_Form_Of_Interface_Name
6806 Ext_Name_Case
: Boolean)
6808 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
6809 SL
: constant Nat
:= String_Length
(S
);
6814 Error_Msg_N
("interface name cannot be null string", SN
);
6817 for J
in 1 .. SL
loop
6818 C
:= Get_String_Char
(S
, J
);
6820 -- Look for dubious character and issue unconditional warning.
6821 -- Definitely dubious if not in character range.
6823 if not In_Character_Range
(C
)
6825 -- For all cases except CLI target,
6826 -- commas, spaces and slashes are dubious (in CLI, we use
6827 -- commas and backslashes in external names to specify
6828 -- assembly version and public key, while slashes and spaces
6829 -- can be used in names to mark nested classes and
6832 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
6833 and then (Get_Character
(C
) = ','
6835 Get_Character
(C
) = '\'))
6836 or else (VM_Target
/= CLI_Target
6837 and then (Get_Character
(C
) = ' '
6839 Get_Character
(C
) = '/'))
6842 ("??interface name contains illegal character",
6843 Sloc
(SN
) + Source_Ptr
(J
));
6846 end Check_Form_Of_Interface_Name
;
6848 -- Start of processing for Process_Interface_Name
6851 if No
(Link_Arg
) then
6852 if No
(Ext_Arg
) then
6853 if VM_Target
= CLI_Target
6854 and then Ekind
(Subprogram_Def
) = E_Package
6855 and then Nkind
(Parent
(Subprogram_Def
)) =
6856 N_Package_Specification
6857 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
6862 (Generic_Parent
(Parent
(Subprogram_Def
))));
6867 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
6869 Link_Nam
:= Expression
(Ext_Arg
);
6872 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
6873 Ext_Nam
:= Expression
(Ext_Arg
);
6878 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
6879 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
6880 Ext_Nam
:= Expression
(Ext_Arg
);
6881 Link_Nam
:= Expression
(Link_Arg
);
6884 -- Check expressions for external name and link name are static
6886 if Present
(Ext_Nam
) then
6887 Check_Arg_Is_Static_Expression
(Ext_Nam
, Standard_String
);
6888 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
6890 -- Verify that external name is not the name of a local entity,
6891 -- which would hide the imported one and could lead to run-time
6892 -- surprises. The problem can only arise for entities declared in
6893 -- a package body (otherwise the external name is fully qualified
6894 -- and will not conflict).
6902 if Prag_Id
= Pragma_Import
then
6903 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
6905 E
:= Entity_Id
(Get_Name_Table_Info
(Nam
));
6907 if Nam
/= Chars
(Subprogram_Def
)
6908 and then Present
(E
)
6909 and then not Is_Overloadable
(E
)
6910 and then Is_Immediately_Visible
(E
)
6911 and then not Is_Imported
(E
)
6912 and then Ekind
(Scope
(E
)) = E_Package
6915 while Present
(Par
) loop
6916 if Nkind
(Par
) = N_Package_Body
then
6917 Error_Msg_Sloc
:= Sloc
(E
);
6919 ("imported entity is hidden by & declared#",
6924 Par
:= Parent
(Par
);
6931 if Present
(Link_Nam
) then
6932 Check_Arg_Is_Static_Expression
(Link_Nam
, Standard_String
);
6933 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
6936 -- If there is no link name, just set the external name
6938 if No
(Link_Nam
) then
6939 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
6941 -- For the Link_Name case, the given literal is preceded by an
6942 -- asterisk, which indicates to GCC that the given name should be
6943 -- taken literally, and in particular that no prepending of
6944 -- underlines should occur, even in systems where this is the
6950 if VM_Target
= No_VM
then
6951 Store_String_Char
(Get_Char_Code
('*'));
6954 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
6955 Store_String_Chars
(String_Val
);
6957 Make_String_Literal
(Sloc
(Link_Nam
),
6958 Strval
=> End_String
);
6961 -- Set the interface name. If the entity is a generic instance, use
6962 -- its alias, which is the callable entity.
6964 if Is_Generic_Instance
(Subprogram_Def
) then
6965 Set_Encoded_Interface_Name
6966 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
6968 Set_Encoded_Interface_Name
6969 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
6972 -- We allow duplicated export names in CIL/Java, as they are always
6973 -- enclosed in a namespace that differentiates them, and overloaded
6974 -- entities are supported by the VM.
6976 if Convention
(Subprogram_Def
) /= Convention_CIL
6978 Convention
(Subprogram_Def
) /= Convention_Java
6980 Check_Duplicated_Export_Name
(Link_Nam
);
6982 end Process_Interface_Name
;
6984 -----------------------------------------
6985 -- Process_Interrupt_Or_Attach_Handler --
6986 -----------------------------------------
6988 procedure Process_Interrupt_Or_Attach_Handler
is
6989 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6990 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
6991 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
6994 Set_Is_Interrupt_Handler
(Handler_Proc
);
6996 -- If the pragma is not associated with a handler procedure within a
6997 -- protected type, then it must be for a nonprotected procedure for
6998 -- the AAMP target, in which case we don't associate a representation
6999 -- item with the procedure's scope.
7001 if Ekind
(Proc_Scope
) = E_Protected_Type
then
7002 if Prag_Id
= Pragma_Interrupt_Handler
7004 Prag_Id
= Pragma_Attach_Handler
7006 Record_Rep_Item
(Proc_Scope
, N
);
7009 end Process_Interrupt_Or_Attach_Handler
;
7011 --------------------------------------------------
7012 -- Process_Restrictions_Or_Restriction_Warnings --
7013 --------------------------------------------------
7015 -- Note: some of the simple identifier cases were handled in par-prag,
7016 -- but it is harmless (and more straightforward) to simply handle all
7017 -- cases here, even if it means we repeat a bit of work in some cases.
7019 procedure Process_Restrictions_Or_Restriction_Warnings
7023 R_Id
: Restriction_Id
;
7029 -- Ignore all Restrictions pragmas in CodePeer mode
7031 if CodePeer_Mode
then
7035 Check_Ada_83_Warning
;
7036 Check_At_Least_N_Arguments
(1);
7037 Check_Valid_Configuration_Pragma
;
7040 while Present
(Arg
) loop
7042 Expr
:= Get_Pragma_Arg
(Arg
);
7044 -- Case of no restriction identifier present
7046 if Id
= No_Name
then
7047 if Nkind
(Expr
) /= N_Identifier
then
7049 ("invalid form for restriction", Arg
);
7054 (Process_Restriction_Synonyms
(Expr
));
7056 if R_Id
not in All_Boolean_Restrictions
then
7057 Error_Msg_Name_1
:= Pname
;
7059 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
7061 -- Check for possible misspelling
7063 for J
in Restriction_Id
loop
7065 Rnm
: constant String := Restriction_Id
'Image (J
);
7068 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
7069 Name_Len
:= Rnm
'Length;
7070 Set_Casing
(All_Lower_Case
);
7072 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
7074 (Identifier_Casing
(Current_Source_File
));
7075 Error_Msg_String
(1 .. Rnm
'Length) :=
7076 Name_Buffer
(1 .. Name_Len
);
7077 Error_Msg_Strlen
:= Rnm
'Length;
7078 Error_Msg_N
-- CODEFIX
7079 ("\possible misspelling of ""~""",
7080 Get_Pragma_Arg
(Arg
));
7089 if Implementation_Restriction
(R_Id
) then
7090 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
7093 -- Special processing for No_Elaboration_Code restriction
7095 if R_Id
= No_Elaboration_Code
then
7097 -- Restriction is only recognized within a configuration
7098 -- pragma file, or within a unit of the main extended
7099 -- program. Note: the test for Main_Unit is needed to
7100 -- properly include the case of configuration pragma files.
7102 if not (Current_Sem_Unit
= Main_Unit
7103 or else In_Extended_Main_Source_Unit
(N
))
7107 -- Don't allow in a subunit unless already specified in
7110 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
7111 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
7112 and then not Restriction_Active
(No_Elaboration_Code
)
7115 ("invalid specification of ""No_Elaboration_Code""",
7118 ("\restriction cannot be specified in a subunit", N
);
7120 ("\unless also specified in body or spec", N
);
7123 -- If we have a No_Elaboration_Code pragma that we
7124 -- accept, then it needs to be added to the configuration
7125 -- restrcition set so that we get proper application to
7126 -- other units in the main extended source as required.
7129 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
7133 -- If this is a warning, then set the warning unless we already
7134 -- have a real restriction active (we never want a warning to
7135 -- override a real restriction).
7138 if not Restriction_Active
(R_Id
) then
7139 Set_Restriction
(R_Id
, N
);
7140 Restriction_Warnings
(R_Id
) := True;
7143 -- If real restriction case, then set it and make sure that the
7144 -- restriction warning flag is off, since a real restriction
7145 -- always overrides a warning.
7148 Set_Restriction
(R_Id
, N
);
7149 Restriction_Warnings
(R_Id
) := False;
7152 -- Check for obsolescent restrictions in Ada 2005 mode
7155 and then Ada_Version
>= Ada_2005
7156 and then (R_Id
= No_Asynchronous_Control
7158 R_Id
= No_Unchecked_Deallocation
7160 R_Id
= No_Unchecked_Conversion
)
7162 Check_Restriction
(No_Obsolescent_Features
, N
);
7165 -- A very special case that must be processed here: pragma
7166 -- Restrictions (No_Exceptions) turns off all run-time
7167 -- checking. This is a bit dubious in terms of the formal
7168 -- language definition, but it is what is intended by RM
7169 -- H.4(12). Restriction_Warnings never affects generated code
7170 -- so this is done only in the real restriction case.
7172 -- Atomic_Synchronization is not a real check, so it is not
7173 -- affected by this processing).
7175 if R_Id
= No_Exceptions
and then not Warn
then
7176 for J
in Scope_Suppress
.Suppress
'Range loop
7177 if J
/= Atomic_Synchronization
then
7178 Scope_Suppress
.Suppress
(J
) := True;
7183 -- Case of No_Dependence => unit-name. Note that the parser
7184 -- already made the necessary entry in the No_Dependence table.
7186 elsif Id
= Name_No_Dependence
then
7187 if not OK_No_Dependence_Unit_Name
(Expr
) then
7191 -- Case of No_Specification_Of_Aspect => Identifier.
7193 elsif Id
= Name_No_Specification_Of_Aspect
then
7198 if Nkind
(Expr
) /= N_Identifier
then
7201 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
7204 if A_Id
= No_Aspect
then
7205 Error_Pragma_Arg
("invalid restriction name", Arg
);
7207 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
7211 elsif Id
= Name_No_Use_Of_Attribute
then
7212 if Nkind
(Expr
) /= N_Identifier
7213 or else not Is_Attribute_Name
(Chars
(Expr
))
7215 Error_Msg_N
("unknown attribute name?", Expr
);
7218 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
7221 elsif Id
= Name_No_Use_Of_Pragma
then
7222 if Nkind
(Expr
) /= N_Identifier
7223 or else not Is_Pragma_Name
(Chars
(Expr
))
7225 Error_Msg_N
("unknown pragma name?", Expr
);
7228 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
7231 -- All other cases of restriction identifier present
7234 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
7235 Analyze_And_Resolve
(Expr
, Any_Integer
);
7237 if R_Id
not in All_Parameter_Restrictions
then
7239 ("invalid restriction parameter identifier", Arg
);
7241 elsif not Is_OK_Static_Expression
(Expr
) then
7242 Flag_Non_Static_Expr
7243 ("value must be static expression!", Expr
);
7246 elsif not Is_Integer_Type
(Etype
(Expr
))
7247 or else Expr_Value
(Expr
) < 0
7250 ("value must be non-negative integer", Arg
);
7253 -- Restriction pragma is active
7255 Val
:= Expr_Value
(Expr
);
7257 if not UI_Is_In_Int_Range
(Val
) then
7259 ("pragma ignored, value too large??", Arg
);
7262 -- Warning case. If the real restriction is active, then we
7263 -- ignore the request, since warning never overrides a real
7264 -- restriction. Otherwise we set the proper warning. Note that
7265 -- this circuit sets the warning again if it is already set,
7266 -- which is what we want, since the constant may have changed.
7269 if not Restriction_Active
(R_Id
) then
7271 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
7272 Restriction_Warnings
(R_Id
) := True;
7275 -- Real restriction case, set restriction and make sure warning
7276 -- flag is off since real restriction always overrides warning.
7279 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
7280 Restriction_Warnings
(R_Id
) := False;
7286 end Process_Restrictions_Or_Restriction_Warnings
;
7288 ---------------------------------
7289 -- Process_Suppress_Unsuppress --
7290 ---------------------------------
7292 -- Note: this procedure makes entries in the check suppress data
7293 -- structures managed by Sem. See spec of package Sem for full
7294 -- details on how we handle recording of check suppression.
7296 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
7301 In_Package_Spec
: constant Boolean :=
7302 Is_Package_Or_Generic_Package
(Current_Scope
)
7303 and then not In_Package_Body
(Current_Scope
);
7305 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
7306 -- Used to suppress a single check on the given entity
7308 --------------------------------
7309 -- Suppress_Unsuppress_Echeck --
7310 --------------------------------
7312 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
7314 -- Check for error of trying to set atomic synchronization for
7315 -- a non-atomic variable.
7317 if C
= Atomic_Synchronization
7318 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
7321 ("pragma & requires atomic type or variable",
7322 Pragma_Identifier
(Original_Node
(N
)));
7325 Set_Checks_May_Be_Suppressed
(E
);
7327 if In_Package_Spec
then
7328 Push_Global_Suppress_Stack_Entry
7331 Suppress
=> Suppress_Case
);
7333 Push_Local_Suppress_Stack_Entry
7336 Suppress
=> Suppress_Case
);
7339 -- If this is a first subtype, and the base type is distinct,
7340 -- then also set the suppress flags on the base type.
7342 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
7343 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
7345 end Suppress_Unsuppress_Echeck
;
7347 -- Start of processing for Process_Suppress_Unsuppress
7350 -- Ignore pragma Suppress/Unsuppress in CodePeer and SPARK modes on
7351 -- user code: we want to generate checks for analysis purposes, as
7352 -- set respectively by -gnatC and -gnatd.F
7354 if (CodePeer_Mode
or SPARK_Mode
) and then Comes_From_Source
(N
) then
7358 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
7359 -- declarative part or a package spec (RM 11.5(5)).
7361 if not Is_Configuration_Pragma
then
7362 Check_Is_In_Decl_Part_Or_Package_Spec
;
7365 Check_At_Least_N_Arguments
(1);
7366 Check_At_Most_N_Arguments
(2);
7367 Check_No_Identifier
(Arg1
);
7368 Check_Arg_Is_Identifier
(Arg1
);
7370 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7372 if C
= No_Check_Id
then
7374 ("argument of pragma% is not valid check name", Arg1
);
7377 if Arg_Count
= 1 then
7379 -- Make an entry in the local scope suppress table. This is the
7380 -- table that directly shows the current value of the scope
7381 -- suppress check for any check id value.
7383 if C
= All_Checks
then
7385 -- For All_Checks, we set all specific predefined checks with
7386 -- the exception of Elaboration_Check, which is handled
7387 -- specially because of not wanting All_Checks to have the
7388 -- effect of deactivating static elaboration order processing.
7389 -- Atomic_Synchronization is also not affected, since this is
7390 -- not a real check.
7392 for J
in Scope_Suppress
.Suppress
'Range loop
7393 if J
/= Elaboration_Check
7395 J
/= Atomic_Synchronization
7397 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
7401 -- If not All_Checks, and predefined check, then set appropriate
7402 -- scope entry. Note that we will set Elaboration_Check if this
7403 -- is explicitly specified. Atomic_Synchronization is allowed
7404 -- only if internally generated and entity is atomic.
7406 elsif C
in Predefined_Check_Id
7407 and then (not Comes_From_Source
(N
)
7408 or else C
/= Atomic_Synchronization
)
7410 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
7413 -- Also make an entry in the Local_Entity_Suppress table
7415 Push_Local_Suppress_Stack_Entry
7418 Suppress
=> Suppress_Case
);
7420 -- Case of two arguments present, where the check is suppressed for
7421 -- a specified entity (given as the second argument of the pragma)
7424 -- This is obsolescent in Ada 2005 mode
7426 if Ada_Version
>= Ada_2005
then
7427 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
7430 Check_Optional_Identifier
(Arg2
, Name_On
);
7431 E_Id
:= Get_Pragma_Arg
(Arg2
);
7434 if not Is_Entity_Name
(E_Id
) then
7436 ("second argument of pragma% must be entity name", Arg2
);
7445 -- Enforce RM 11.5(7) which requires that for a pragma that
7446 -- appears within a package spec, the named entity must be
7447 -- within the package spec. We allow the package name itself
7448 -- to be mentioned since that makes sense, although it is not
7449 -- strictly allowed by 11.5(7).
7452 and then E
/= Current_Scope
7453 and then Scope
(E
) /= Current_Scope
7456 ("entity in pragma% is not in package spec (RM 11.5(7))",
7460 -- Loop through homonyms. As noted below, in the case of a package
7461 -- spec, only homonyms within the package spec are considered.
7464 Suppress_Unsuppress_Echeck
(E
, C
);
7466 if Is_Generic_Instance
(E
)
7467 and then Is_Subprogram
(E
)
7468 and then Present
(Alias
(E
))
7470 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
7473 -- Move to next homonym if not aspect spec case
7475 exit when From_Aspect_Specification
(N
);
7479 -- If we are within a package specification, the pragma only
7480 -- applies to homonyms in the same scope.
7482 exit when In_Package_Spec
7483 and then Scope
(E
) /= Current_Scope
;
7486 end Process_Suppress_Unsuppress
;
7492 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
7494 if Is_Imported
(E
) then
7496 ("cannot export entity& that was previously imported", Arg
);
7498 elsif Present
(Address_Clause
(E
))
7499 and then not Relaxed_RM_Semantics
7502 ("cannot export entity& that has an address clause", Arg
);
7505 Set_Is_Exported
(E
);
7507 -- Generate a reference for entity explicitly, because the
7508 -- identifier may be overloaded and name resolution will not
7511 Generate_Reference
(E
, Arg
);
7513 -- Deal with exporting non-library level entity
7515 if not Is_Library_Level_Entity
(E
) then
7517 -- Not allowed at all for subprograms
7519 if Is_Subprogram
(E
) then
7520 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
7522 -- Otherwise set public and statically allocated
7526 Set_Is_Statically_Allocated
(E
);
7528 -- Warn if the corresponding W flag is set and the pragma comes
7529 -- from source. The latter may not be true e.g. on VMS where we
7530 -- expand export pragmas for exception codes associated with
7531 -- imported or exported exceptions. We do not want to generate
7532 -- a warning for something that the user did not write.
7534 if Warn_On_Export_Import
7535 and then Comes_From_Source
(Arg
)
7538 ("?x?& has been made static as a result of Export",
7541 ("\?x?this usage is non-standard and non-portable",
7547 if Warn_On_Export_Import
and then Is_Type
(E
) then
7548 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
7551 if Warn_On_Export_Import
and Inside_A_Generic
then
7553 ("all instances of& will have the same external name?x?",
7558 ----------------------------------------------
7559 -- Set_Extended_Import_Export_External_Name --
7560 ----------------------------------------------
7562 procedure Set_Extended_Import_Export_External_Name
7563 (Internal_Ent
: Entity_Id
;
7564 Arg_External
: Node_Id
)
7566 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
7570 if No
(Arg_External
) then
7574 Check_Arg_Is_External_Name
(Arg_External
);
7576 if Nkind
(Arg_External
) = N_String_Literal
then
7577 if String_Length
(Strval
(Arg_External
)) = 0 then
7580 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
7583 elsif Nkind
(Arg_External
) = N_Identifier
then
7584 New_Name
:= Get_Default_External_Name
(Arg_External
);
7586 -- Check_Arg_Is_External_Name should let through only identifiers and
7587 -- string literals or static string expressions (which are folded to
7588 -- string literals).
7591 raise Program_Error
;
7594 -- If we already have an external name set (by a prior normal Import
7595 -- or Export pragma), then the external names must match
7597 if Present
(Interface_Name
(Internal_Ent
)) then
7598 Check_Matching_Internal_Names
: declare
7599 S1
: constant String_Id
:= Strval
(Old_Name
);
7600 S2
: constant String_Id
:= Strval
(New_Name
);
7603 pragma No_Return
(Mismatch
);
7604 -- Called if names do not match
7610 procedure Mismatch
is
7612 Error_Msg_Sloc
:= Sloc
(Old_Name
);
7614 ("external name does not match that given #",
7618 -- Start of processing for Check_Matching_Internal_Names
7621 if String_Length
(S1
) /= String_Length
(S2
) then
7625 for J
in 1 .. String_Length
(S1
) loop
7626 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
7631 end Check_Matching_Internal_Names
;
7633 -- Otherwise set the given name
7636 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
7637 Check_Duplicated_Export_Name
(New_Name
);
7639 end Set_Extended_Import_Export_External_Name
;
7645 procedure Set_Imported
(E
: Entity_Id
) is
7647 -- Error message if already imported or exported
7649 if Is_Exported
(E
) or else Is_Imported
(E
) then
7651 -- Error if being set Exported twice
7653 if Is_Exported
(E
) then
7654 Error_Msg_NE
("entity& was previously exported", N
, E
);
7656 -- Ignore error in CodePeer mode where we treat all imported
7657 -- subprograms as unknown.
7659 elsif CodePeer_Mode
then
7662 -- OK if Import/Interface case
7664 elsif Import_Interface_Present
(N
) then
7667 -- Error if being set Imported twice
7670 Error_Msg_NE
("entity& was previously imported", N
, E
);
7673 Error_Msg_Name_1
:= Pname
;
7675 ("\(pragma% applies to all previous entities)", N
);
7677 Error_Msg_Sloc
:= Sloc
(E
);
7678 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
7680 -- Here if not previously imported or exported, OK to import
7683 Set_Is_Imported
(E
);
7685 -- If the entity is an object that is not at the library level,
7686 -- then it is statically allocated. We do not worry about objects
7687 -- with address clauses in this context since they are not really
7688 -- imported in the linker sense.
7691 and then not Is_Library_Level_Entity
(E
)
7692 and then No
(Address_Clause
(E
))
7694 Set_Is_Statically_Allocated
(E
);
7701 -------------------------
7702 -- Set_Mechanism_Value --
7703 -------------------------
7705 -- Note: the mechanism name has not been analyzed (and cannot indeed be
7706 -- analyzed, since it is semantic nonsense), so we get it in the exact
7707 -- form created by the parser.
7709 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
7712 Mech_Name_Id
: Name_Id
;
7714 procedure Bad_Class
;
7715 pragma No_Return
(Bad_Class
);
7716 -- Signal bad descriptor class name
7718 procedure Bad_Mechanism
;
7719 pragma No_Return
(Bad_Mechanism
);
7720 -- Signal bad mechanism name
7726 procedure Bad_Class
is
7728 Error_Pragma_Arg
("unrecognized descriptor class name", Class
);
7731 -------------------------
7732 -- Bad_Mechanism_Value --
7733 -------------------------
7735 procedure Bad_Mechanism
is
7737 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
7740 -- Start of processing for Set_Mechanism_Value
7743 if Mechanism
(Ent
) /= Default_Mechanism
then
7745 ("mechanism for & has already been set", Mech_Name
, Ent
);
7748 -- MECHANISM_NAME ::= value | reference | descriptor |
7751 if Nkind
(Mech_Name
) = N_Identifier
then
7752 if Chars
(Mech_Name
) = Name_Value
then
7753 Set_Mechanism
(Ent
, By_Copy
);
7756 elsif Chars
(Mech_Name
) = Name_Reference
then
7757 Set_Mechanism
(Ent
, By_Reference
);
7760 elsif Chars
(Mech_Name
) = Name_Descriptor
then
7761 Check_VMS
(Mech_Name
);
7763 -- Descriptor => Short_Descriptor if pragma was given
7765 if Short_Descriptors
then
7766 Set_Mechanism
(Ent
, By_Short_Descriptor
);
7768 Set_Mechanism
(Ent
, By_Descriptor
);
7773 elsif Chars
(Mech_Name
) = Name_Short_Descriptor
then
7774 Check_VMS
(Mech_Name
);
7775 Set_Mechanism
(Ent
, By_Short_Descriptor
);
7778 elsif Chars
(Mech_Name
) = Name_Copy
then
7780 ("bad mechanism name, Value assumed", Mech_Name
);
7786 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
7787 -- short_descriptor (CLASS_NAME)
7788 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7790 -- Note: this form is parsed as an indexed component
7792 elsif Nkind
(Mech_Name
) = N_Indexed_Component
then
7793 Class
:= First
(Expressions
(Mech_Name
));
7795 if Nkind
(Prefix
(Mech_Name
)) /= N_Identifier
7797 not Nam_In
(Chars
(Prefix
(Mech_Name
)), Name_Descriptor
,
7798 Name_Short_Descriptor
)
7799 or else Present
(Next
(Class
))
7803 Mech_Name_Id
:= Chars
(Prefix
(Mech_Name
));
7805 -- Change Descriptor => Short_Descriptor if pragma was given
7807 if Mech_Name_Id
= Name_Descriptor
7808 and then Short_Descriptors
7810 Mech_Name_Id
:= Name_Short_Descriptor
;
7814 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
7815 -- short_descriptor (Class => CLASS_NAME)
7816 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7818 -- Note: this form is parsed as a function call
7820 elsif Nkind
(Mech_Name
) = N_Function_Call
then
7821 Param
:= First
(Parameter_Associations
(Mech_Name
));
7823 if Nkind
(Name
(Mech_Name
)) /= N_Identifier
7825 not Nam_In
(Chars
(Name
(Mech_Name
)), Name_Descriptor
,
7826 Name_Short_Descriptor
)
7827 or else Present
(Next
(Param
))
7828 or else No
(Selector_Name
(Param
))
7829 or else Chars
(Selector_Name
(Param
)) /= Name_Class
7833 Class
:= Explicit_Actual_Parameter
(Param
);
7834 Mech_Name_Id
:= Chars
(Name
(Mech_Name
));
7841 -- Fall through here with Class set to descriptor class name
7843 Check_VMS
(Mech_Name
);
7845 if Nkind
(Class
) /= N_Identifier
then
7848 elsif Mech_Name_Id
= Name_Descriptor
7849 and then Chars
(Class
) = Name_UBS
7851 Set_Mechanism
(Ent
, By_Descriptor_UBS
);
7853 elsif Mech_Name_Id
= Name_Descriptor
7854 and then Chars
(Class
) = Name_UBSB
7856 Set_Mechanism
(Ent
, By_Descriptor_UBSB
);
7858 elsif Mech_Name_Id
= Name_Descriptor
7859 and then Chars
(Class
) = Name_UBA
7861 Set_Mechanism
(Ent
, By_Descriptor_UBA
);
7863 elsif Mech_Name_Id
= Name_Descriptor
7864 and then Chars
(Class
) = Name_S
7866 Set_Mechanism
(Ent
, By_Descriptor_S
);
7868 elsif Mech_Name_Id
= Name_Descriptor
7869 and then Chars
(Class
) = Name_SB
7871 Set_Mechanism
(Ent
, By_Descriptor_SB
);
7873 elsif Mech_Name_Id
= Name_Descriptor
7874 and then Chars
(Class
) = Name_A
7876 Set_Mechanism
(Ent
, By_Descriptor_A
);
7878 elsif Mech_Name_Id
= Name_Descriptor
7879 and then Chars
(Class
) = Name_NCA
7881 Set_Mechanism
(Ent
, By_Descriptor_NCA
);
7883 elsif Mech_Name_Id
= Name_Short_Descriptor
7884 and then Chars
(Class
) = Name_UBS
7886 Set_Mechanism
(Ent
, By_Short_Descriptor_UBS
);
7888 elsif Mech_Name_Id
= Name_Short_Descriptor
7889 and then Chars
(Class
) = Name_UBSB
7891 Set_Mechanism
(Ent
, By_Short_Descriptor_UBSB
);
7893 elsif Mech_Name_Id
= Name_Short_Descriptor
7894 and then Chars
(Class
) = Name_UBA
7896 Set_Mechanism
(Ent
, By_Short_Descriptor_UBA
);
7898 elsif Mech_Name_Id
= Name_Short_Descriptor
7899 and then Chars
(Class
) = Name_S
7901 Set_Mechanism
(Ent
, By_Short_Descriptor_S
);
7903 elsif Mech_Name_Id
= Name_Short_Descriptor
7904 and then Chars
(Class
) = Name_SB
7906 Set_Mechanism
(Ent
, By_Short_Descriptor_SB
);
7908 elsif Mech_Name_Id
= Name_Short_Descriptor
7909 and then Chars
(Class
) = Name_A
7911 Set_Mechanism
(Ent
, By_Short_Descriptor_A
);
7913 elsif Mech_Name_Id
= Name_Short_Descriptor
7914 and then Chars
(Class
) = Name_NCA
7916 Set_Mechanism
(Ent
, By_Short_Descriptor_NCA
);
7921 end Set_Mechanism_Value
;
7923 --------------------------
7924 -- Set_Rational_Profile --
7925 --------------------------
7927 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
7928 -- and extension to the semantics of renaming declarations.
7930 procedure Set_Rational_Profile
is
7932 Implicit_Packing
:= True;
7933 Overriding_Renamings
:= True;
7934 Use_VADS_Size
:= True;
7935 end Set_Rational_Profile
;
7937 ---------------------------
7938 -- Set_Ravenscar_Profile --
7939 ---------------------------
7941 -- The tasks to be done here are
7943 -- Set required policies
7945 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
7946 -- pragma Locking_Policy (Ceiling_Locking)
7948 -- Set Detect_Blocking mode
7950 -- Set required restrictions (see System.Rident for detailed list)
7952 -- Set the No_Dependence rules
7953 -- No_Dependence => Ada.Asynchronous_Task_Control
7954 -- No_Dependence => Ada.Calendar
7955 -- No_Dependence => Ada.Execution_Time.Group_Budget
7956 -- No_Dependence => Ada.Execution_Time.Timers
7957 -- No_Dependence => Ada.Task_Attributes
7958 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
7960 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
7961 Prefix_Entity
: Entity_Id
;
7962 Selector_Entity
: Entity_Id
;
7963 Prefix_Node
: Node_Id
;
7967 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
7969 if Task_Dispatching_Policy
/= ' '
7970 and then Task_Dispatching_Policy
/= 'F'
7972 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
7973 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
7975 -- Set the FIFO_Within_Priorities policy, but always preserve
7976 -- System_Location since we like the error message with the run time
7980 Task_Dispatching_Policy
:= 'F';
7982 if Task_Dispatching_Policy_Sloc
/= System_Location
then
7983 Task_Dispatching_Policy_Sloc
:= Loc
;
7987 -- pragma Locking_Policy (Ceiling_Locking)
7989 if Locking_Policy
/= ' '
7990 and then Locking_Policy
/= 'C'
7992 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
7993 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
7995 -- Set the Ceiling_Locking policy, but preserve System_Location since
7996 -- we like the error message with the run time name.
7999 Locking_Policy
:= 'C';
8001 if Locking_Policy_Sloc
/= System_Location
then
8002 Locking_Policy_Sloc
:= Loc
;
8006 -- pragma Detect_Blocking
8008 Detect_Blocking
:= True;
8010 -- Set the corresponding restrictions
8012 Set_Profile_Restrictions
8013 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
8015 -- Set the No_Dependence restrictions
8017 -- The following No_Dependence restrictions:
8018 -- No_Dependence => Ada.Asynchronous_Task_Control
8019 -- No_Dependence => Ada.Calendar
8020 -- No_Dependence => Ada.Task_Attributes
8021 -- are already set by previous call to Set_Profile_Restrictions.
8023 -- Set the following restrictions which were added to Ada 2005:
8024 -- No_Dependence => Ada.Execution_Time.Group_Budget
8025 -- No_Dependence => Ada.Execution_Time.Timers
8027 if Ada_Version
>= Ada_2005
then
8028 Name_Buffer
(1 .. 3) := "ada";
8031 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
8033 Name_Buffer
(1 .. 14) := "execution_time";
8036 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
8039 Make_Selected_Component
8041 Prefix
=> Prefix_Entity
,
8042 Selector_Name
=> Selector_Entity
);
8044 Name_Buffer
(1 .. 13) := "group_budgets";
8047 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
8050 Make_Selected_Component
8052 Prefix
=> Prefix_Node
,
8053 Selector_Name
=> Selector_Entity
);
8055 Set_Restriction_No_Dependence
8057 Warn
=> Treat_Restrictions_As_Warnings
,
8058 Profile
=> Ravenscar
);
8060 Name_Buffer
(1 .. 6) := "timers";
8063 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
8066 Make_Selected_Component
8068 Prefix
=> Prefix_Node
,
8069 Selector_Name
=> Selector_Entity
);
8071 Set_Restriction_No_Dependence
8073 Warn
=> Treat_Restrictions_As_Warnings
,
8074 Profile
=> Ravenscar
);
8077 -- Set the following restrictions which was added to Ada 2012 (see
8079 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
8081 if Ada_Version
>= Ada_2012
then
8082 Name_Buffer
(1 .. 6) := "system";
8085 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
8087 Name_Buffer
(1 .. 15) := "multiprocessors";
8090 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
8093 Make_Selected_Component
8095 Prefix
=> Prefix_Entity
,
8096 Selector_Name
=> Selector_Entity
);
8098 Name_Buffer
(1 .. 19) := "dispatching_domains";
8101 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
8104 Make_Selected_Component
8106 Prefix
=> Prefix_Node
,
8107 Selector_Name
=> Selector_Entity
);
8109 Set_Restriction_No_Dependence
8111 Warn
=> Treat_Restrictions_As_Warnings
,
8112 Profile
=> Ravenscar
);
8114 end Set_Ravenscar_Profile
;
8120 procedure S14_Pragma
is
8122 if not Formal_Extensions
then
8123 Error_Pragma
("pragma% requires the use of debug switch -gnatd.V");
8127 -- Start of processing for Analyze_Pragma
8130 -- The following code is a defense against recursion. Not clear that
8131 -- this can happen legitimately, but perhaps some error situations
8132 -- can cause it, and we did see this recursion during testing.
8134 if Analyzed
(N
) then
8137 Set_Analyzed
(N
, True);
8140 -- Deal with unrecognized pragma
8142 Pname
:= Pragma_Name
(N
);
8144 if not Is_Pragma_Name
(Pname
) then
8145 if Warn_On_Unrecognized_Pragma
then
8146 Error_Msg_Name_1
:= Pname
;
8147 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
8149 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
8150 if Is_Bad_Spelling_Of
(Pname
, PN
) then
8151 Error_Msg_Name_1
:= PN
;
8152 Error_Msg_N
-- CODEFIX
8153 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
8162 -- Here to start processing for recognized pragma
8164 Prag_Id
:= Get_Pragma_Id
(Pname
);
8165 Pname
:= Original_Name
(N
);
8167 -- Check applicable policy. We skip this for a pragma that came from
8168 -- an aspect, since we already dealt with the Disable case, and we set
8169 -- the Is_Ignored flag at the time the aspect was analyzed.
8171 if not From_Aspect_Specification
(N
) then
8172 Check_Applicable_Policy
(N
);
8174 -- If pragma is disabled, rewrite as NULL and skip analysis
8176 if Is_Disabled
(N
) then
8177 Rewrite
(N
, Make_Null_Statement
(Loc
));
8191 if Present
(Pragma_Argument_Associations
(N
)) then
8192 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
8193 Arg1
:= First
(Pragma_Argument_Associations
(N
));
8195 if Present
(Arg1
) then
8196 Arg2
:= Next
(Arg1
);
8198 if Present
(Arg2
) then
8199 Arg3
:= Next
(Arg2
);
8201 if Present
(Arg3
) then
8202 Arg4
:= Next
(Arg3
);
8208 Check_Restriction_No_Use_Of_Pragma
(N
);
8210 -- An enumeration type defines the pragmas that are supported by the
8211 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
8212 -- into the corresponding enumeration value for the following case.
8220 -- pragma Abort_Defer;
8222 when Pragma_Abort_Defer
=>
8224 Check_Arg_Count
(0);
8226 -- The only required semantic processing is to check the
8227 -- placement. This pragma must appear at the start of the
8228 -- statement sequence of a handled sequence of statements.
8230 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
8231 or else N
/= First
(Statements
(Parent
(N
)))
8236 --------------------
8237 -- Abstract_State --
8238 --------------------
8240 -- pragma Abstract_State (ABSTRACT_STATE_LIST)
8242 -- ABSTRACT_STATE_LIST ::=
8244 -- | STATE_NAME_WITH_PROPERTIES {, STATE_NAME_WITH_PROPERTIES}
8246 -- STATE_NAME_WITH_PROPERTIES ::=
8248 -- | (STATE_NAME with PROPERTY_LIST)
8250 -- PROPERTY_LIST ::= PROPERTY {, PROPERTY}
8251 -- PROPERTY ::= SIMPLE_PROPERTY | NAME_VALUE_PROPERTY
8253 -- SIMPLE_PROPERTY ::= IDENTIFIER
8254 -- NAME_VALUE_PROPERTY ::= IDENTIFIER => EXPRESSION
8256 -- STATE_NAME ::= DEFINING_IDENTIFIER
8258 when Pragma_Abstract_State
=> Abstract_State
: declare
8259 Pack_Id
: Entity_Id
;
8261 -- Flags used to verify the consistency of states
8263 Non_Null_Seen
: Boolean := False;
8264 Null_Seen
: Boolean := False;
8266 procedure Analyze_Abstract_State
(State
: Node_Id
);
8267 -- Verify the legality of a single state declaration. Create and
8268 -- decorate a state abstraction entity and introduce it into the
8269 -- visibility chain.
8271 ----------------------------
8272 -- Analyze_Abstract_State --
8273 ----------------------------
8275 procedure Analyze_Abstract_State
(State
: Node_Id
) is
8276 procedure Check_Duplicate_Property
8278 Status
: in out Boolean);
8279 -- Flag Status denotes whether a particular property has been
8280 -- seen while processing a state. This routine verifies that
8281 -- Prop is not a duplicate property and sets the flag Status.
8283 ------------------------------
8284 -- Check_Duplicate_Property --
8285 ------------------------------
8287 procedure Check_Duplicate_Property
8289 Status
: in out Boolean)
8293 Error_Msg_N
("duplicate state property", Prop
);
8297 end Check_Duplicate_Property
;
8301 Errors
: constant Nat
:= Serious_Errors_Detected
;
8302 Loc
: constant Source_Ptr
:= Sloc
(State
);
8305 Is_Null
: Boolean := False;
8306 Level
: Uint
:= Uint_0
;
8310 -- Flags used to verify the consistency of properties
8312 Input_Seen
: Boolean := False;
8313 Integrity_Seen
: Boolean := False;
8314 Output_Seen
: Boolean := False;
8315 Volatile_Seen
: Boolean := False;
8317 -- Start of processing for Analyze_Abstract_State
8320 -- A package with a null abstract state is not allowed to
8321 -- declare additional states.
8325 ("package & has null abstract state", State
, Pack_Id
);
8327 -- Null states appear as internally generated entities
8329 elsif Nkind
(State
) = N_Null
then
8330 Name
:= New_Internal_Name
('S');
8334 -- Catch a case where a null state appears in a list of
8337 if Non_Null_Seen
then
8339 ("package & has non-null abstract state",
8343 -- Simple state declaration
8345 elsif Nkind
(State
) = N_Identifier
then
8346 Name
:= Chars
(State
);
8347 Non_Null_Seen
:= True;
8349 -- State declaration with various properties. This construct
8350 -- appears as an extension aggregate in the tree.
8352 elsif Nkind
(State
) = N_Extension_Aggregate
then
8353 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
8354 Name
:= Chars
(Ancestor_Part
(State
));
8355 Non_Null_Seen
:= True;
8358 ("state name must be an identifier",
8359 Ancestor_Part
(State
));
8362 -- Process properties Input, Output and Volatile. Ensure
8363 -- that none of them appear more than once.
8365 Prop
:= First
(Expressions
(State
));
8366 while Present
(Prop
) loop
8367 if Nkind
(Prop
) = N_Identifier
then
8368 if Chars
(Prop
) = Name_Input
then
8369 Check_Duplicate_Property
(Prop
, Input_Seen
);
8370 elsif Chars
(Prop
) = Name_Output
then
8371 Check_Duplicate_Property
(Prop
, Output_Seen
);
8372 elsif Chars
(Prop
) = Name_Volatile
then
8373 Check_Duplicate_Property
(Prop
, Volatile_Seen
);
8375 Error_Msg_N
("invalid state property", Prop
);
8378 Error_Msg_N
("invalid state property", Prop
);
8384 -- Volatile requires exactly one Input or Output
8386 if Volatile_Seen
and then Input_Seen
= Output_Seen
then
8388 ("property Volatile requires exactly one Input or "
8392 -- Either Input or Output require Volatile
8394 if (Input_Seen
or Output_Seen
)
8395 and then not Volatile_Seen
8398 ("properties Input and Output require Volatile", State
);
8401 -- State property Integrity appears as a component
8404 Assoc
:= First
(Component_Associations
(State
));
8405 while Present
(Assoc
) loop
8406 Prop
:= First
(Choices
(Assoc
));
8407 while Present
(Prop
) loop
8408 if Nkind
(Prop
) = N_Identifier
8409 and then Chars
(Prop
) = Name_Integrity
8411 Check_Duplicate_Property
(Prop
, Integrity_Seen
);
8413 Error_Msg_N
("invalid state property", Prop
);
8419 if Nkind
(Expression
(Assoc
)) = N_Integer_Literal
then
8420 Level
:= Intval
(Expression
(Assoc
));
8423 ("integrity level must be an integer literal",
8424 Expression
(Assoc
));
8430 -- Any other attempt to declare a state is erroneous
8433 Error_Msg_N
("malformed abstract state declaration", State
);
8436 -- Do not generate a state abstraction entity if it was not
8437 -- properly declared.
8439 if Serious_Errors_Detected
> Errors
then
8443 -- The generated state abstraction reuses the same characters
8444 -- from the original state declaration. Decorate the entity.
8446 Id
:= Make_Defining_Identifier
(Loc
, New_External_Name
(Name
));
8447 Set_Comes_From_Source
(Id
, not Is_Null
);
8448 Set_Parent
(Id
, State
);
8449 Set_Ekind
(Id
, E_Abstract_State
);
8450 Set_Etype
(Id
, Standard_Void_Type
);
8451 Set_Integrity_Level
(Id
, Level
);
8452 Set_Refined_State
(Id
, Empty
);
8454 -- Every non-null state must be nameable and resolvable the
8455 -- same way a constant is.
8458 Push_Scope
(Pack_Id
);
8463 -- Verify whether the state introduces an illegal hidden state
8464 -- within a package subject to a null abstract state.
8466 if Formal_Extensions
then
8467 Check_No_Hidden_State
(Id
);
8470 -- Associate the state with its related package
8472 if No
(Abstract_States
(Pack_Id
)) then
8473 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
8476 Append_Elmt
(Id
, Abstract_States
(Pack_Id
));
8477 end Analyze_Abstract_State
;
8484 -- Start of processing for Abstract_State
8489 Check_Arg_Count
(1);
8491 -- Ensure the proper placement of the pragma. Abstract states must
8492 -- be associated with a package declaration.
8494 if From_Aspect_Specification
(N
) then
8495 Par
:= Parent
(Corresponding_Aspect
(N
));
8497 Par
:= Parent
(Parent
(N
));
8500 if Nkind
(Par
) = N_Compilation_Unit
then
8504 if not Nkind_In
(Par
, N_Generic_Package_Declaration
,
8505 N_Package_Declaration
)
8511 Pack_Id
:= Defining_Entity
(Par
);
8512 State
:= Expression
(Arg1
);
8514 -- Multiple abstract states appear as an aggregate
8516 if Nkind
(State
) = N_Aggregate
then
8517 State
:= First
(Expressions
(State
));
8518 while Present
(State
) loop
8519 Analyze_Abstract_State
(State
);
8524 -- Various forms of a single abstract state. Note that these may
8525 -- include malformed state declarations.
8528 Analyze_Abstract_State
(State
);
8538 -- Note: this pragma also has some specific processing in Par.Prag
8539 -- because we want to set the Ada version mode during parsing.
8541 when Pragma_Ada_83
=>
8543 Check_Arg_Count
(0);
8545 -- We really should check unconditionally for proper configuration
8546 -- pragma placement, since we really don't want mixed Ada modes
8547 -- within a single unit, and the GNAT reference manual has always
8548 -- said this was a configuration pragma, but we did not check and
8549 -- are hesitant to add the check now.
8551 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
8552 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
8553 -- or Ada 2012 mode.
8555 if Ada_Version
>= Ada_2005
then
8556 Check_Valid_Configuration_Pragma
;
8559 -- Now set Ada 83 mode
8561 Ada_Version
:= Ada_83
;
8562 Ada_Version_Explicit
:= Ada_Version
;
8570 -- Note: this pragma also has some specific processing in Par.Prag
8571 -- because we want to set the Ada 83 version mode during parsing.
8573 when Pragma_Ada_95
=>
8575 Check_Arg_Count
(0);
8577 -- We really should check unconditionally for proper configuration
8578 -- pragma placement, since we really don't want mixed Ada modes
8579 -- within a single unit, and the GNAT reference manual has always
8580 -- said this was a configuration pragma, but we did not check and
8581 -- are hesitant to add the check now.
8583 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
8584 -- or Ada 95, so we must check if we are in Ada 2005 mode.
8586 if Ada_Version
>= Ada_2005
then
8587 Check_Valid_Configuration_Pragma
;
8590 -- Now set Ada 95 mode
8592 Ada_Version
:= Ada_95
;
8593 Ada_Version_Explicit
:= Ada_Version
;
8595 ---------------------
8596 -- Ada_05/Ada_2005 --
8597 ---------------------
8600 -- pragma Ada_05 (LOCAL_NAME);
8603 -- pragma Ada_2005 (LOCAL_NAME):
8605 -- Note: these pragmas also have some specific processing in Par.Prag
8606 -- because we want to set the Ada 2005 version mode during parsing.
8608 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
8614 if Arg_Count
= 1 then
8615 Check_Arg_Is_Local_Name
(Arg1
);
8616 E_Id
:= Get_Pragma_Arg
(Arg1
);
8618 if Etype
(E_Id
) = Any_Type
then
8622 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
8623 Record_Rep_Item
(Entity
(E_Id
), N
);
8626 Check_Arg_Count
(0);
8628 -- For Ada_2005 we unconditionally enforce the documented
8629 -- configuration pragma placement, since we do not want to
8630 -- tolerate mixed modes in a unit involving Ada 2005. That
8631 -- would cause real difficulties for those cases where there
8632 -- are incompatibilities between Ada 95 and Ada 2005.
8634 Check_Valid_Configuration_Pragma
;
8636 -- Now set appropriate Ada mode
8638 Ada_Version
:= Ada_2005
;
8639 Ada_Version_Explicit
:= Ada_2005
;
8643 ---------------------
8644 -- Ada_12/Ada_2012 --
8645 ---------------------
8648 -- pragma Ada_12 (LOCAL_NAME);
8651 -- pragma Ada_2012 (LOCAL_NAME):
8653 -- Note: these pragmas also have some specific processing in Par.Prag
8654 -- because we want to set the Ada 2012 version mode during parsing.
8656 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
8662 if Arg_Count
= 1 then
8663 Check_Arg_Is_Local_Name
(Arg1
);
8664 E_Id
:= Get_Pragma_Arg
(Arg1
);
8666 if Etype
(E_Id
) = Any_Type
then
8670 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
8671 Record_Rep_Item
(Entity
(E_Id
), N
);
8674 Check_Arg_Count
(0);
8676 -- For Ada_2012 we unconditionally enforce the documented
8677 -- configuration pragma placement, since we do not want to
8678 -- tolerate mixed modes in a unit involving Ada 2012. That
8679 -- would cause real difficulties for those cases where there
8680 -- are incompatibilities between Ada 95 and Ada 2012. We could
8681 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
8683 Check_Valid_Configuration_Pragma
;
8685 -- Now set appropriate Ada mode
8687 Ada_Version
:= Ada_2012
;
8688 Ada_Version_Explicit
:= Ada_2012
;
8692 ----------------------
8693 -- All_Calls_Remote --
8694 ----------------------
8696 -- pragma All_Calls_Remote [(library_package_NAME)];
8698 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
8699 Lib_Entity
: Entity_Id
;
8702 Check_Ada_83_Warning
;
8703 Check_Valid_Library_Unit_Pragma
;
8705 if Nkind
(N
) = N_Null_Statement
then
8709 Lib_Entity
:= Find_Lib_Unit_Name
;
8711 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
8713 if Present
(Lib_Entity
)
8714 and then not Debug_Flag_U
8716 if not Is_Remote_Call_Interface
(Lib_Entity
) then
8717 Error_Pragma
("pragma% only apply to rci unit");
8719 -- Set flag for entity of the library unit
8722 Set_Has_All_Calls_Remote
(Lib_Entity
);
8726 end All_Calls_Remote
;
8732 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
8733 -- ARG ::= NAME | EXPRESSION
8735 -- The first two arguments are by convention intended to refer to an
8736 -- external tool and a tool-specific function. These arguments are
8739 when Pragma_Annotate
=> Annotate
: declare
8745 Check_At_Least_N_Arguments
(1);
8746 Check_Arg_Is_Identifier
(Arg1
);
8747 Check_No_Identifiers
;
8750 -- Second parameter is optional, it is never analyzed
8755 -- Here if we have a second parameter
8758 -- Second parameter must be identifier
8760 Check_Arg_Is_Identifier
(Arg2
);
8762 -- Process remaining parameters if any
8765 while Present
(Arg
) loop
8766 Exp
:= Get_Pragma_Arg
(Arg
);
8769 if Is_Entity_Name
(Exp
) then
8772 -- For string literals, we assume Standard_String as the
8773 -- type, unless the string contains wide or wide_wide
8776 elsif Nkind
(Exp
) = N_String_Literal
then
8777 if Has_Wide_Wide_Character
(Exp
) then
8778 Resolve
(Exp
, Standard_Wide_Wide_String
);
8779 elsif Has_Wide_Character
(Exp
) then
8780 Resolve
(Exp
, Standard_Wide_String
);
8782 Resolve
(Exp
, Standard_String
);
8785 elsif Is_Overloaded
(Exp
) then
8787 ("ambiguous argument for pragma%", Exp
);
8798 -------------------------------------------------
8799 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
8800 -------------------------------------------------
8803 -- ( [Check => ] Boolean_EXPRESSION
8804 -- [, [Message =>] Static_String_EXPRESSION]);
8806 -- pragma Assert_And_Cut
8807 -- ( [Check => ] Boolean_EXPRESSION
8808 -- [, [Message =>] Static_String_EXPRESSION]);
8811 -- ( [Check => ] Boolean_EXPRESSION
8812 -- [, [Message =>] Static_String_EXPRESSION]);
8814 -- pragma Loop_Invariant
8815 -- ( [Check => ] Boolean_EXPRESSION
8816 -- [, [Message =>] Static_String_EXPRESSION]);
8818 when Pragma_Assert |
8819 Pragma_Assert_And_Cut |
8821 Pragma_Loop_Invariant
=>
8827 -- Assert is an Ada 2005 RM-defined pragma
8829 if Prag_Id
= Pragma_Assert
then
8832 -- The remaining ones are GNAT pragmas
8838 Check_At_Least_N_Arguments
(1);
8839 Check_At_Most_N_Arguments
(2);
8840 Check_Arg_Order
((Name_Check
, Name_Message
));
8841 Check_Optional_Identifier
(Arg1
, Name_Check
);
8843 -- Special processing for Loop_Invariant
8845 if Prag_Id
= Pragma_Loop_Invariant
then
8847 -- Check restricted placement, must be within a loop
8849 Check_Loop_Pragma_Placement
;
8851 -- Do preanalyze to deal with embedded Loop_Entry attribute
8853 Preanalyze_Assert_Expression
(Expression
(Arg1
), Any_Boolean
);
8856 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
8857 -- a corresponding Check pragma:
8859 -- pragma Check (name, condition [, msg]);
8861 -- Where name is the identifier matching the pragma name. So
8862 -- rewrite pragma in this manner, transfer the message argument
8863 -- if present, and analyze the result
8865 -- Note: When dealing with a semantically analyzed tree, the
8866 -- information that a Check node N corresponds to a source Assert,
8867 -- Assume, or Assert_And_Cut pragma can be retrieved from the
8868 -- pragma kind of Original_Node(N).
8870 Expr
:= Get_Pragma_Arg
(Arg1
);
8872 Make_Pragma_Argument_Association
(Loc
,
8873 Expression
=> Make_Identifier
(Loc
, Pname
)),
8874 Make_Pragma_Argument_Association
(Sloc
(Expr
),
8875 Expression
=> Expr
));
8877 if Arg_Count
> 1 then
8878 Check_Optional_Identifier
(Arg2
, Name_Message
);
8879 Append_To
(Newa
, New_Copy_Tree
(Arg2
));
8884 Chars
=> Name_Check
,
8885 Pragma_Argument_Associations
=> Newa
));
8889 ----------------------
8890 -- Assertion_Policy --
8891 ----------------------
8893 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
8895 -- The following form is Ada 2012 only, but we allow it in all modes
8897 -- Pragma Assertion_Policy (
8898 -- ASSERTION_KIND => POLICY_IDENTIFIER
8899 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
8901 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
8903 -- RM_ASSERTION_KIND ::= Assert |
8904 -- Static_Predicate |
8905 -- Dynamic_Predicate |
8911 -- Type_Invariant'Class
8913 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
8922 -- Statement_Assertions
8924 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
8925 -- ID_ASSERTION_KIND list contains implementation-defined additions
8926 -- recognized by GNAT. The effect is to control the behavior of
8927 -- identically named aspects and pragmas, depending on the specified
8928 -- policy identifier:
8930 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
8932 -- Note: Check and Ignore are language-defined. Disable is a GNAT
8933 -- implementation defined addition that results in totally ignoring
8934 -- the corresponding assertion. If Disable is specified, then the
8935 -- argument of the assertion is not even analyzed. This is useful
8936 -- when the aspect/pragma argument references entities in a with'ed
8937 -- package that is replaced by a dummy package in the final build.
8939 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
8940 -- and Type_Invariant'Class were recognized by the parser and
8941 -- transformed into references to the special internal identifiers
8942 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
8943 -- processing is required here.
8945 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
8954 -- This can always appear as a configuration pragma
8956 if Is_Configuration_Pragma
then
8959 -- It can also appear in a declarative part or package spec in Ada
8960 -- 2012 mode. We allow this in other modes, but in that case we
8961 -- consider that we have an Ada 2012 pragma on our hands.
8964 Check_Is_In_Decl_Part_Or_Package_Spec
;
8968 -- One argument case with no identifier (first form above)
8971 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
8972 or else Chars
(Arg1
) = No_Name
)
8975 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
8977 -- Treat one argument Assertion_Policy as equivalent to:
8979 -- pragma Check_Policy (Assertion, policy)
8981 -- So rewrite pragma in that manner and link on to the chain
8982 -- of Check_Policy pragmas, marking the pragma as analyzed.
8984 Policy
:= Get_Pragma_Arg
(Arg1
);
8988 Chars
=> Name_Check_Policy
,
8989 Pragma_Argument_Associations
=> New_List
(
8990 Make_Pragma_Argument_Association
(Loc
,
8991 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
8993 Make_Pragma_Argument_Association
(Loc
,
8995 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
8998 -- Here if we have two or more arguments
9001 Check_At_Least_N_Arguments
(1);
9004 -- Loop through arguments
9007 while Present
(Arg
) loop
9010 -- Kind must be specified
9012 if Nkind
(Arg
) /= N_Pragma_Argument_Association
9013 or else Chars
(Arg
) = No_Name
9016 ("missing assertion kind for pragma%", Arg
);
9019 -- Check Kind and Policy have allowed forms
9021 Kind
:= Chars
(Arg
);
9023 if not Is_Valid_Assertion_Kind
(Kind
) then
9025 ("invalid assertion kind for pragma%", Arg
);
9029 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
9031 -- We rewrite the Assertion_Policy pragma as a series of
9032 -- Check_Policy pragmas:
9034 -- Check_Policy (Kind, Policy);
9038 Chars
=> Name_Check_Policy
,
9039 Pragma_Argument_Associations
=> New_List
(
9040 Make_Pragma_Argument_Association
(LocP
,
9041 Expression
=> Make_Identifier
(LocP
, Kind
)),
9042 Make_Pragma_Argument_Association
(LocP
,
9043 Expression
=> Get_Pragma_Arg
(Arg
)))));
9048 -- Rewrite the Assertion_Policy pragma as null since we have
9049 -- now inserted all the equivalent Check pragmas.
9051 Rewrite
(N
, Make_Null_Statement
(Loc
));
9054 end Assertion_Policy
;
9056 ------------------------------
9057 -- Assume_No_Invalid_Values --
9058 ------------------------------
9060 -- pragma Assume_No_Invalid_Values (On | Off);
9062 when Pragma_Assume_No_Invalid_Values
=>
9064 Check_Valid_Configuration_Pragma
;
9065 Check_Arg_Count
(1);
9066 Check_No_Identifiers
;
9067 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
9069 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
9070 Assume_No_Invalid_Values
:= True;
9072 Assume_No_Invalid_Values
:= False;
9075 --------------------------
9076 -- Attribute_Definition --
9077 --------------------------
9079 -- pragma Attribute_Definition
9080 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
9081 -- [Entity =>] LOCAL_NAME,
9082 -- [Expression =>] EXPRESSION | NAME);
9084 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
9085 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
9090 Check_Arg_Count
(3);
9091 Check_Optional_Identifier
(Arg1
, "attribute");
9092 Check_Optional_Identifier
(Arg2
, "entity");
9093 Check_Optional_Identifier
(Arg3
, "expression");
9095 if Nkind
(Attribute_Designator
) /= N_Identifier
then
9096 Error_Msg_N
("attribute name expected", Attribute_Designator
);
9100 Check_Arg_Is_Local_Name
(Arg2
);
9102 -- If the attribute is not recognized, then issue a warning (not
9103 -- an error), and ignore the pragma.
9105 Aname
:= Chars
(Attribute_Designator
);
9107 if not Is_Attribute_Name
(Aname
) then
9108 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
9112 -- Otherwise, rewrite the pragma as an attribute definition clause
9115 Make_Attribute_Definition_Clause
(Loc
,
9116 Name
=> Get_Pragma_Arg
(Arg2
),
9118 Expression
=> Get_Pragma_Arg
(Arg3
)));
9120 end Attribute_Definition
;
9126 -- pragma AST_Entry (entry_IDENTIFIER);
9128 when Pragma_AST_Entry
=> AST_Entry
: declare
9134 Check_Arg_Count
(1);
9135 Check_No_Identifiers
;
9136 Check_Arg_Is_Local_Name
(Arg1
);
9137 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
9139 -- Note: the implementation of the AST_Entry pragma could handle
9140 -- the entry family case fine, but for now we are consistent with
9141 -- the DEC rules, and do not allow the pragma, which of course
9142 -- has the effect of also forbidding the attribute.
9144 if Ekind
(Ent
) /= E_Entry
then
9146 ("pragma% argument must be simple entry name", Arg1
);
9148 elsif Is_AST_Entry
(Ent
) then
9150 ("duplicate % pragma for entry", Arg1
);
9152 elsif Has_Homonym
(Ent
) then
9154 ("pragma% argument cannot specify overloaded entry", Arg1
);
9158 FF
: constant Entity_Id
:= First_Formal
(Ent
);
9161 if Present
(FF
) then
9162 if Present
(Next_Formal
(FF
)) then
9164 ("entry for pragma% can have only one argument",
9167 elsif Parameter_Mode
(FF
) /= E_In_Parameter
then
9169 ("entry parameter for pragma% must have mode IN",
9175 Set_Is_AST_Entry
(Ent
);
9183 -- pragma Asynchronous (LOCAL_NAME);
9185 when Pragma_Asynchronous
=> Asynchronous
: declare
9193 procedure Process_Async_Pragma
;
9194 -- Common processing for procedure and access-to-procedure case
9196 --------------------------
9197 -- Process_Async_Pragma --
9198 --------------------------
9200 procedure Process_Async_Pragma
is
9203 Set_Is_Asynchronous
(Nm
);
9207 -- The formals should be of mode IN (RM E.4.1(6))
9210 while Present
(S
) loop
9211 Formal
:= Defining_Identifier
(S
);
9213 if Nkind
(Formal
) = N_Defining_Identifier
9214 and then Ekind
(Formal
) /= E_In_Parameter
9217 ("pragma% procedure can only have IN parameter",
9224 Set_Is_Asynchronous
(Nm
);
9225 end Process_Async_Pragma
;
9227 -- Start of processing for pragma Asynchronous
9230 Check_Ada_83_Warning
;
9231 Check_No_Identifiers
;
9232 Check_Arg_Count
(1);
9233 Check_Arg_Is_Local_Name
(Arg1
);
9235 if Debug_Flag_U
then
9239 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
9240 Analyze
(Get_Pragma_Arg
(Arg1
));
9241 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
9243 if not Is_Remote_Call_Interface
(C_Ent
)
9244 and then not Is_Remote_Types
(C_Ent
)
9246 -- This pragma should only appear in an RCI or Remote Types
9247 -- unit (RM E.4.1(4)).
9250 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
9253 if Ekind
(Nm
) = E_Procedure
9254 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
9256 if not Is_Remote_Call_Interface
(Nm
) then
9258 ("pragma% cannot be applied on non-remote procedure",
9262 L
:= Parameter_Specifications
(Parent
(Nm
));
9263 Process_Async_Pragma
;
9266 elsif Ekind
(Nm
) = E_Function
then
9268 ("pragma% cannot be applied to function", Arg1
);
9270 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
9271 if Is_Record_Type
(Nm
) then
9273 -- A record type that is the Equivalent_Type for a remote
9274 -- access-to-subprogram type.
9276 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
9279 -- A non-expanded RAS type (distribution is not enabled)
9281 N
:= Declaration_Node
(Nm
);
9284 if Nkind
(N
) = N_Full_Type_Declaration
9285 and then Nkind
(Type_Definition
(N
)) =
9286 N_Access_Procedure_Definition
9288 L
:= Parameter_Specifications
(Type_Definition
(N
));
9289 Process_Async_Pragma
;
9291 if Is_Asynchronous
(Nm
)
9292 and then Expander_Active
9293 and then Get_PCS_Name
/= Name_No_DSA
9295 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
9300 ("pragma% cannot reference access-to-function type",
9304 -- Only other possibility is Access-to-class-wide type
9306 elsif Is_Access_Type
(Nm
)
9307 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
9309 Check_First_Subtype
(Arg1
);
9310 Set_Is_Asynchronous
(Nm
);
9311 if Expander_Active
then
9312 RACW_Type_Is_Asynchronous
(Nm
);
9316 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
9324 -- pragma Atomic (LOCAL_NAME);
9326 when Pragma_Atomic
=>
9327 Process_Atomic_Shared_Volatile
;
9329 -----------------------
9330 -- Atomic_Components --
9331 -----------------------
9333 -- pragma Atomic_Components (array_LOCAL_NAME);
9335 -- This processing is shared by Volatile_Components
9337 when Pragma_Atomic_Components |
9338 Pragma_Volatile_Components
=>
9340 Atomic_Components
: declare
9347 Check_Ada_83_Warning
;
9348 Check_No_Identifiers
;
9349 Check_Arg_Count
(1);
9350 Check_Arg_Is_Local_Name
(Arg1
);
9351 E_Id
:= Get_Pragma_Arg
(Arg1
);
9353 if Etype
(E_Id
) = Any_Type
then
9359 Check_Duplicate_Pragma
(E
);
9361 if Rep_Item_Too_Early
(E
, N
)
9363 Rep_Item_Too_Late
(E
, N
)
9368 D
:= Declaration_Node
(E
);
9371 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
9373 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
9374 and then Nkind
(D
) = N_Object_Declaration
9375 and then Nkind
(Object_Definition
(D
)) =
9376 N_Constrained_Array_Definition
)
9378 -- The flag is set on the object, or on the base type
9380 if Nkind
(D
) /= N_Object_Declaration
then
9384 Set_Has_Volatile_Components
(E
);
9386 if Prag_Id
= Pragma_Atomic_Components
then
9387 Set_Has_Atomic_Components
(E
);
9391 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
9393 end Atomic_Components
;
9395 --------------------
9396 -- Attach_Handler --
9397 --------------------
9399 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
9401 when Pragma_Attach_Handler
=>
9402 Check_Ada_83_Warning
;
9403 Check_No_Identifiers
;
9404 Check_Arg_Count
(2);
9406 if No_Run_Time_Mode
then
9407 Error_Msg_CRT
("Attach_Handler pragma", N
);
9409 Check_Interrupt_Or_Attach_Handler
;
9411 -- The expression that designates the attribute may depend on a
9412 -- discriminant, and is therefore a per-object expression, to
9413 -- be expanded in the init proc. If expansion is enabled, then
9414 -- perform semantic checks on a copy only.
9416 if Expander_Active
then
9418 Temp
: constant Node_Id
:=
9419 New_Copy_Tree
(Get_Pragma_Arg
(Arg2
));
9421 Set_Parent
(Temp
, N
);
9422 Preanalyze_And_Resolve
(Temp
, RTE
(RE_Interrupt_ID
));
9426 Analyze
(Get_Pragma_Arg
(Arg2
));
9427 Resolve
(Get_Pragma_Arg
(Arg2
), RTE
(RE_Interrupt_ID
));
9430 Process_Interrupt_Or_Attach_Handler
;
9433 --------------------
9434 -- C_Pass_By_Copy --
9435 --------------------
9437 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
9439 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
9445 Check_Valid_Configuration_Pragma
;
9446 Check_Arg_Count
(1);
9447 Check_Optional_Identifier
(Arg1
, "max_size");
9449 Arg
:= Get_Pragma_Arg
(Arg1
);
9450 Check_Arg_Is_Static_Expression
(Arg
, Any_Integer
);
9452 Val
:= Expr_Value
(Arg
);
9456 ("maximum size for pragma% must be positive", Arg1
);
9458 elsif UI_Is_In_Int_Range
(Val
) then
9459 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
9461 -- If a giant value is given, Int'Last will do well enough.
9462 -- If sometime someone complains that a record larger than
9463 -- two gigabytes is not copied, we will worry about it then!
9466 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
9474 -- pragma Check ([Name =>] CHECK_KIND,
9475 -- [Check =>] Boolean_EXPRESSION
9476 -- [,[Message =>] String_EXPRESSION]);
9478 -- CHECK_KIND ::= IDENTIFIER |
9481 -- Invariant'Class |
9482 -- Type_Invariant'Class
9484 -- The identifiers Assertions and Statement_Assertions are not
9485 -- allowed, since they have special meaning for Check_Policy.
9487 when Pragma_Check
=> Check
: declare
9494 -- Set True if category of assertions referenced by Name enabled
9498 Check_At_Least_N_Arguments
(2);
9499 Check_At_Most_N_Arguments
(3);
9500 Check_Optional_Identifier
(Arg1
, Name_Name
);
9501 Check_Optional_Identifier
(Arg2
, Name_Check
);
9503 if Arg_Count
= 3 then
9504 Check_Optional_Identifier
(Arg3
, Name_Message
);
9505 Str
:= Get_Pragma_Arg
(Arg3
);
9508 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
9509 Check_Arg_Is_Identifier
(Arg1
);
9510 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
9512 -- Check forbidden name Assertions or Statement_Assertions
9515 when Name_Assertions
=>
9517 ("""Assertions"" is not allowed as a check kind "
9518 & "for pragma%", Arg1
);
9520 when Name_Statement_Assertions
=>
9522 ("""Statement_Assertions"" is not allowed as a check kind "
9523 & "for pragma%", Arg1
);
9529 -- Set Check_On to indicate check status
9531 -- If this comes from an aspect, we have already taken care of
9532 -- the policy active when the aspect was analyzed, and Is_Ignored
9533 -- is set appropriately already.
9535 if From_Aspect_Specification
(N
) then
9536 Check_On
:= not Is_Ignored
(N
);
9538 -- Otherwise check the status right now
9541 case Check_Kind
(Cname
) is
9548 -- For disable, rewrite pragma as null statement and skip
9549 -- rest of the analysis of the pragma.
9551 when Name_Disable
=>
9552 Rewrite
(N
, Make_Null_Statement
(Loc
));
9556 -- No other possibilities
9559 raise Program_Error
;
9563 -- If check kind was not Disable, then continue pragma analysis
9565 Expr
:= Get_Pragma_Arg
(Arg2
);
9567 -- Deal with SCO generation
9570 when Name_Predicate |
9573 -- Nothing to do: since checks occur in client units,
9574 -- the SCO for the aspect in the declaration unit is
9575 -- conservatively always enabled.
9581 if Check_On
and then not Split_PPC
(N
) then
9583 -- Mark pragma/aspect SCO as enabled
9585 Set_SCO_Pragma_Enabled
(Loc
);
9589 -- Deal with analyzing the string argument.
9591 if Arg_Count
= 3 then
9593 -- If checks are not on we don't want any expansion (since
9594 -- such expansion would not get properly deleted) but
9595 -- we do want to analyze (to get proper references).
9596 -- The Preanalyze_And_Resolve routine does just what we want
9598 if not Check_On
then
9599 Preanalyze_And_Resolve
(Str
, Standard_String
);
9601 -- Otherwise we need a proper analysis and expansion
9604 Analyze_And_Resolve
(Str
, Standard_String
);
9608 -- Now you might think we could just do the same with the Boolean
9609 -- expression if checks are off (and expansion is on) and then
9610 -- rewrite the check as a null statement. This would work but we
9611 -- would lose the useful warnings about an assertion being bound
9612 -- to fail even if assertions are turned off.
9614 -- So instead we wrap the boolean expression in an if statement
9617 -- if False and then condition then
9621 -- The reason we do this rewriting during semantic analysis
9622 -- rather than as part of normal expansion is that we cannot
9623 -- analyze and expand the code for the boolean expression
9624 -- directly, or it may cause insertion of actions that would
9625 -- escape the attempt to suppress the check code.
9627 -- Note that the Sloc for the if statement corresponds to the
9628 -- argument condition, not the pragma itself. The reason for
9629 -- this is that we may generate a warning if the condition is
9630 -- False at compile time, and we do not want to delete this
9631 -- warning when we delete the if statement.
9633 if Expander_Active
and not Check_On
then
9634 Eloc
:= Sloc
(Expr
);
9637 Make_If_Statement
(Eloc
,
9639 Make_And_Then
(Eloc
,
9640 Left_Opnd
=> New_Occurrence_Of
(Standard_False
, Eloc
),
9641 Right_Opnd
=> Expr
),
9642 Then_Statements
=> New_List
(
9643 Make_Null_Statement
(Eloc
))));
9645 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
9647 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
9649 -- Check is active or expansion not active. In these cases we can
9650 -- just go ahead and analyze the boolean with no worries.
9653 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
9654 Analyze_And_Resolve
(Expr
, Any_Boolean
);
9655 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
9659 --------------------------
9660 -- Check_Float_Overflow --
9661 --------------------------
9663 -- pragma Check_Float_Overflow;
9665 when Pragma_Check_Float_Overflow
=>
9667 Check_Valid_Configuration_Pragma
;
9668 Check_Arg_Count
(0);
9669 Check_Float_Overflow
:= True;
9675 -- pragma Check_Name (check_IDENTIFIER);
9677 when Pragma_Check_Name
=>
9679 Check_No_Identifiers
;
9680 Check_Valid_Configuration_Pragma
;
9681 Check_Arg_Count
(1);
9682 Check_Arg_Is_Identifier
(Arg1
);
9685 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
9688 for J
in Check_Names
.First
.. Check_Names
.Last
loop
9689 if Check_Names
.Table
(J
) = Nam
then
9694 Check_Names
.Append
(Nam
);
9701 -- This is the old style syntax, which is still allowed in all modes:
9703 -- pragma Check_Policy ([Name =>] CHECK_KIND
9704 -- [Policy =>] POLICY_IDENTIFIER);
9706 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
9708 -- CHECK_KIND ::= IDENTIFIER |
9711 -- Type_Invariant'Class |
9714 -- This is the new style syntax, compatible with Assertion_Policy
9715 -- and also allowed in all modes.
9717 -- Pragma Check_Policy (
9718 -- CHECK_KIND => POLICY_IDENTIFIER
9719 -- {, CHECK_KIND => POLICY_IDENTIFIER});
9721 -- Note: the identifiers Name and Policy are not allowed as
9722 -- Check_Kind values. This avoids ambiguities between the old and
9725 when Pragma_Check_Policy
=> Check_Policy
: declare
9730 Check_At_Least_N_Arguments
(1);
9732 -- A Check_Policy pragma can appear either as a configuration
9733 -- pragma, or in a declarative part or a package spec (see RM
9734 -- 11.5(5) for rules for Suppress/Unsuppress which are also
9735 -- followed for Check_Policy).
9737 if not Is_Configuration_Pragma
then
9738 Check_Is_In_Decl_Part_Or_Package_Spec
;
9741 -- Figure out if we have the old or new syntax. We have the
9742 -- old syntax if the first argument has no identifier, or the
9743 -- identifier is Name.
9745 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
9746 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
9750 Check_Arg_Count
(2);
9751 Check_Optional_Identifier
(Arg1
, Name_Name
);
9752 Kind
:= Get_Pragma_Arg
(Arg1
);
9753 Rewrite_Assertion_Kind
(Kind
);
9754 Check_Arg_Is_Identifier
(Arg1
);
9756 -- Check forbidden check kind
9758 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
9759 Error_Msg_Name_2
:= Chars
(Kind
);
9761 ("pragma% does not allow% as check name", Arg1
);
9766 Check_Optional_Identifier
(Arg2
, Name_Policy
);
9769 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
9771 -- And chain pragma on the Check_Policy_List for search
9773 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
9774 Opt
.Check_Policy_List
:= N
;
9776 -- For the new syntax, what we do is to convert each argument to
9777 -- an old syntax equivalent. We do that because we want to chain
9778 -- old style Check_Policy pragmas for the search (we don't want
9779 -- to have to deal with multiple arguments in the search).
9789 while Present
(Arg
) loop
9791 Argx
:= Get_Pragma_Arg
(Arg
);
9793 -- Kind must be specified
9795 if Nkind
(Arg
) /= N_Pragma_Argument_Association
9796 or else Chars
(Arg
) = No_Name
9799 ("missing assertion kind for pragma%", Arg
);
9802 -- Construct equivalent old form syntax Check_Policy
9803 -- pragma and insert it to get remaining checks.
9807 Chars
=> Name_Check_Policy
,
9808 Pragma_Argument_Associations
=> New_List
(
9809 Make_Pragma_Argument_Association
(LocP
,
9811 Make_Identifier
(LocP
, Chars
(Arg
))),
9812 Make_Pragma_Argument_Association
(Sloc
(Argx
),
9813 Expression
=> Argx
))));
9818 -- Rewrite original Check_Policy pragma to null, since we
9819 -- have converted it into a series of old syntax pragmas.
9821 Rewrite
(N
, Make_Null_Statement
(Loc
));
9827 ---------------------
9828 -- CIL_Constructor --
9829 ---------------------
9831 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
9833 -- Processing for this pragma is shared with Java_Constructor
9839 -- pragma Comment (static_string_EXPRESSION)
9841 -- Processing for pragma Comment shares the circuitry for pragma
9842 -- Ident. The only differences are that Ident enforces a limit of 31
9843 -- characters on its argument, and also enforces limitations on
9844 -- placement for DEC compatibility. Pragma Comment shares neither of
9845 -- these restrictions.
9851 -- pragma Common_Object (
9852 -- [Internal =>] LOCAL_NAME
9853 -- [, [External =>] EXTERNAL_SYMBOL]
9854 -- [, [Size =>] EXTERNAL_SYMBOL]);
9856 -- Processing for this pragma is shared with Psect_Object
9858 ------------------------
9859 -- Compile_Time_Error --
9860 ------------------------
9862 -- pragma Compile_Time_Error
9863 -- (boolean_EXPRESSION, static_string_EXPRESSION);
9865 when Pragma_Compile_Time_Error
=>
9867 Process_Compile_Time_Warning_Or_Error
;
9869 --------------------------
9870 -- Compile_Time_Warning --
9871 --------------------------
9873 -- pragma Compile_Time_Warning
9874 -- (boolean_EXPRESSION, static_string_EXPRESSION);
9876 when Pragma_Compile_Time_Warning
=>
9878 Process_Compile_Time_Warning_Or_Error
;
9884 when Pragma_Compiler_Unit
=>
9886 Check_Arg_Count
(0);
9887 Set_Is_Compiler_Unit
(Get_Source_Unit
(N
));
9889 -----------------------------
9890 -- Complete_Representation --
9891 -----------------------------
9893 -- pragma Complete_Representation;
9895 when Pragma_Complete_Representation
=>
9897 Check_Arg_Count
(0);
9899 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
9901 ("pragma & must appear within record representation clause");
9904 ----------------------------
9905 -- Complex_Representation --
9906 ----------------------------
9908 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
9910 when Pragma_Complex_Representation
=> Complex_Representation
: declare
9917 Check_Arg_Count
(1);
9918 Check_Optional_Identifier
(Arg1
, Name_Entity
);
9919 Check_Arg_Is_Local_Name
(Arg1
);
9920 E_Id
:= Get_Pragma_Arg
(Arg1
);
9922 if Etype
(E_Id
) = Any_Type
then
9928 if not Is_Record_Type
(E
) then
9930 ("argument for pragma% must be record type", Arg1
);
9933 Ent
:= First_Entity
(E
);
9936 or else No
(Next_Entity
(Ent
))
9937 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
9938 or else not Is_Floating_Point_Type
(Etype
(Ent
))
9939 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
9942 ("record for pragma% must have two fields of the same "
9943 & "floating-point type", Arg1
);
9946 Set_Has_Complex_Representation
(Base_Type
(E
));
9948 -- We need to treat the type has having a non-standard
9949 -- representation, for back-end purposes, even though in
9950 -- general a complex will have the default representation
9951 -- of a record with two real components.
9953 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
9955 end Complex_Representation
;
9957 -------------------------
9958 -- Component_Alignment --
9959 -------------------------
9961 -- pragma Component_Alignment (
9962 -- [Form =>] ALIGNMENT_CHOICE
9963 -- [, [Name =>] type_LOCAL_NAME]);
9965 -- ALIGNMENT_CHOICE ::=
9967 -- | Component_Size_4
9971 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
9972 Args
: Args_List
(1 .. 2);
9973 Names
: constant Name_List
(1 .. 2) := (
9977 Form
: Node_Id
renames Args
(1);
9978 Name
: Node_Id
renames Args
(2);
9980 Atype
: Component_Alignment_Kind
;
9985 Gather_Associations
(Names
, Args
);
9988 Error_Pragma
("missing Form argument for pragma%");
9991 Check_Arg_Is_Identifier
(Form
);
9993 -- Get proper alignment, note that Default = Component_Size on all
9994 -- machines we have so far, and we want to set this value rather
9995 -- than the default value to indicate that it has been explicitly
9996 -- set (and thus will not get overridden by the default component
9997 -- alignment for the current scope)
9999 if Chars
(Form
) = Name_Component_Size
then
10000 Atype
:= Calign_Component_Size
;
10002 elsif Chars
(Form
) = Name_Component_Size_4
then
10003 Atype
:= Calign_Component_Size_4
;
10005 elsif Chars
(Form
) = Name_Default
then
10006 Atype
:= Calign_Component_Size
;
10008 elsif Chars
(Form
) = Name_Storage_Unit
then
10009 Atype
:= Calign_Storage_Unit
;
10013 ("invalid Form parameter for pragma%", Form
);
10016 -- Case with no name, supplied, affects scope table entry
10020 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
10022 -- Case of name supplied
10025 Check_Arg_Is_Local_Name
(Name
);
10027 Typ
:= Entity
(Name
);
10030 or else Rep_Item_Too_Early
(Typ
, N
)
10034 Typ
:= Underlying_Type
(Typ
);
10037 if not Is_Record_Type
(Typ
)
10038 and then not Is_Array_Type
(Typ
)
10041 ("Name parameter of pragma% must identify record or "
10042 & "array type", Name
);
10045 -- An explicit Component_Alignment pragma overrides an
10046 -- implicit pragma Pack, but not an explicit one.
10048 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
10049 Set_Is_Packed
(Base_Type
(Typ
), False);
10050 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
10053 end Component_AlignmentP
;
10055 --------------------
10056 -- Contract_Cases --
10057 --------------------
10059 -- pragma Contract_Cases (CONTRACT_CASE_LIST);
10061 -- CONTRACT_CASE_LIST ::= CONTRACT_CASE {, CONTRACT_CASE}
10063 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
10065 -- CASE_GUARD ::= boolean_EXPRESSION | others
10067 -- CONSEQUENCE ::= boolean_EXPRESSION
10069 when Pragma_Contract_Cases
=> Contract_Cases
: declare
10070 Subp_Decl
: Node_Id
;
10071 Subp_Id
: Entity_Id
;
10075 Check_Arg_Count
(1);
10077 -- Ensure the proper placement of the pragma. Contract_Cases must
10078 -- be associated with a subprogram declaration or a body that acts
10081 Subp_Decl
:= Find_Related_Subprogram
(N
, Check_Duplicates
=> True);
10083 if Nkind
(Subp_Decl
) /= N_Subprogram_Declaration
10084 and then (Nkind
(Subp_Decl
) /= N_Subprogram_Body
10085 or else not Acts_As_Spec
(Subp_Decl
))
10091 Subp_Id
:= Defining_Unit_Name
(Specification
(Subp_Decl
));
10093 -- The pragma is analyzed at the end of the declarative part which
10094 -- contains the related subprogram. Reset the analyzed flag.
10096 Set_Analyzed
(N
, False);
10098 -- When the aspect/pragma appears on a subprogram body, perform
10099 -- the full analysis now.
10101 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
10102 Analyze_Contract_Cases_In_Decl_Part
(N
);
10104 -- When Contract_Cases applies to a subprogram compilation unit,
10105 -- the corresponding pragma is placed after the unit's declaration
10106 -- node and needs to be analyzed immediately.
10108 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
10109 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
10111 Analyze_Contract_Cases_In_Decl_Part
(N
);
10114 -- Chain the pragma on the contract for further processing
10116 Add_Contract_Item
(N
, Subp_Id
);
10117 end Contract_Cases
;
10123 -- pragma Controlled (first_subtype_LOCAL_NAME);
10125 when Pragma_Controlled
=> Controlled
: declare
10129 Check_No_Identifiers
;
10130 Check_Arg_Count
(1);
10131 Check_Arg_Is_Local_Name
(Arg1
);
10132 Arg
:= Get_Pragma_Arg
(Arg1
);
10134 if not Is_Entity_Name
(Arg
)
10135 or else not Is_Access_Type
(Entity
(Arg
))
10137 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
10139 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
10147 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
10148 -- [Entity =>] LOCAL_NAME);
10150 when Pragma_Convention
=> Convention
: declare
10153 pragma Warnings
(Off
, C
);
10154 pragma Warnings
(Off
, E
);
10156 Check_Arg_Order
((Name_Convention
, Name_Entity
));
10157 Check_Ada_83_Warning
;
10158 Check_Arg_Count
(2);
10159 Process_Convention
(C
, E
);
10162 ---------------------------
10163 -- Convention_Identifier --
10164 ---------------------------
10166 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
10167 -- [Convention =>] convention_IDENTIFIER);
10169 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
10175 Check_Arg_Order
((Name_Name
, Name_Convention
));
10176 Check_Arg_Count
(2);
10177 Check_Optional_Identifier
(Arg1
, Name_Name
);
10178 Check_Optional_Identifier
(Arg2
, Name_Convention
);
10179 Check_Arg_Is_Identifier
(Arg1
);
10180 Check_Arg_Is_Identifier
(Arg2
);
10181 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
10182 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
10184 if Is_Convention_Name
(Cname
) then
10185 Record_Convention_Identifier
10186 (Idnam
, Get_Convention_Id
(Cname
));
10189 ("second arg for % pragma must be convention", Arg2
);
10191 end Convention_Identifier
;
10197 -- pragma CPP_Class ([Entity =>] local_NAME)
10199 when Pragma_CPP_Class
=> CPP_Class
: declare
10203 if Warn_On_Obsolescent_Feature
then
10205 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
10206 & "effect; replace it by pragma import?j?", N
);
10209 Check_Arg_Count
(1);
10213 Chars
=> Name_Import
,
10214 Pragma_Argument_Associations
=> New_List
(
10215 Make_Pragma_Argument_Association
(Loc
,
10216 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
10217 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
10221 ---------------------
10222 -- CPP_Constructor --
10223 ---------------------
10225 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
10226 -- [, [External_Name =>] static_string_EXPRESSION ]
10227 -- [, [Link_Name =>] static_string_EXPRESSION ]);
10229 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
10232 Def_Id
: Entity_Id
;
10233 Tag_Typ
: Entity_Id
;
10237 Check_At_Least_N_Arguments
(1);
10238 Check_At_Most_N_Arguments
(3);
10239 Check_Optional_Identifier
(Arg1
, Name_Entity
);
10240 Check_Arg_Is_Local_Name
(Arg1
);
10242 Id
:= Get_Pragma_Arg
(Arg1
);
10243 Find_Program_Unit_Name
(Id
);
10245 -- If we did not find the name, we are done
10247 if Etype
(Id
) = Any_Type
then
10251 Def_Id
:= Entity
(Id
);
10253 -- Check if already defined as constructor
10255 if Is_Constructor
(Def_Id
) then
10257 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
10261 if Ekind
(Def_Id
) = E_Function
10262 and then (Is_CPP_Class
(Etype
(Def_Id
))
10263 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
10265 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
10267 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
10269 ("'C'P'P constructor must be defined in the scope of "
10270 & "its returned type", Arg1
);
10273 if Arg_Count
>= 2 then
10274 Set_Imported
(Def_Id
);
10275 Set_Is_Public
(Def_Id
);
10276 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
10279 Set_Has_Completion
(Def_Id
);
10280 Set_Is_Constructor
(Def_Id
);
10281 Set_Convention
(Def_Id
, Convention_CPP
);
10283 -- Imported C++ constructors are not dispatching primitives
10284 -- because in C++ they don't have a dispatch table slot.
10285 -- However, in Ada the constructor has the profile of a
10286 -- function that returns a tagged type and therefore it has
10287 -- been treated as a primitive operation during semantic
10288 -- analysis. We now remove it from the list of primitive
10289 -- operations of the type.
10291 if Is_Tagged_Type
(Etype
(Def_Id
))
10292 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
10293 and then Is_Dispatching_Operation
(Def_Id
)
10295 Tag_Typ
:= Etype
(Def_Id
);
10297 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
10298 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
10302 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
10303 Set_Is_Dispatching_Operation
(Def_Id
, False);
10306 -- For backward compatibility, if the constructor returns a
10307 -- class wide type, and we internally change the return type to
10308 -- the corresponding root type.
10310 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
10311 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
10315 ("pragma% requires function returning a 'C'P'P_Class type",
10318 end CPP_Constructor
;
10324 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
10328 if Warn_On_Obsolescent_Feature
then
10330 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
10339 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
10343 if Warn_On_Obsolescent_Feature
then
10345 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
10354 -- pragma CPU (EXPRESSION);
10356 when Pragma_CPU
=> CPU
: declare
10357 P
: constant Node_Id
:= Parent
(N
);
10363 Check_No_Identifiers
;
10364 Check_Arg_Count
(1);
10368 if Nkind
(P
) = N_Subprogram_Body
then
10369 Check_In_Main_Program
;
10371 Arg
:= Get_Pragma_Arg
(Arg1
);
10372 Analyze_And_Resolve
(Arg
, Any_Integer
);
10374 Ent
:= Defining_Unit_Name
(Specification
(P
));
10376 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
10377 Ent
:= Defining_Identifier
(Ent
);
10382 if not Is_Static_Expression
(Arg
) then
10383 Flag_Non_Static_Expr
10384 ("main subprogram affinity is not static!", Arg
);
10387 -- If constraint error, then we already signalled an error
10389 elsif Raises_Constraint_Error
(Arg
) then
10392 -- Otherwise check in range
10396 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
10397 -- This is the entity System.Multiprocessors.CPU_Range;
10399 Val
: constant Uint
:= Expr_Value
(Arg
);
10402 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
10404 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
10407 ("main subprogram CPU is out of range", Arg1
);
10413 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
10417 elsif Nkind
(P
) = N_Task_Definition
then
10418 Arg
:= Get_Pragma_Arg
(Arg1
);
10419 Ent
:= Defining_Identifier
(Parent
(P
));
10421 -- The expression must be analyzed in the special manner
10422 -- described in "Handling of Default and Per-Object
10423 -- Expressions" in sem.ads.
10425 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
10427 -- Anything else is incorrect
10433 -- Check duplicate pragma before we chain the pragma in the Rep
10434 -- Item chain of Ent.
10436 Check_Duplicate_Pragma
(Ent
);
10437 Record_Rep_Item
(Ent
, N
);
10444 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
10446 when Pragma_Debug
=> Debug
: declare
10453 -- The condition for executing the call is that the expander
10454 -- is active and that we are not ignoring this debug pragma.
10459 (Expander_Active
and then not Is_Ignored
(N
)),
10462 if not Is_Ignored
(N
) then
10463 Set_SCO_Pragma_Enabled
(Loc
);
10466 if Arg_Count
= 2 then
10468 Make_And_Then
(Loc
,
10469 Left_Opnd
=> Relocate_Node
(Cond
),
10470 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
10471 Call
:= Get_Pragma_Arg
(Arg2
);
10473 Call
:= Get_Pragma_Arg
(Arg1
);
10477 N_Indexed_Component
,
10481 N_Selected_Component
)
10483 -- If this pragma Debug comes from source, its argument was
10484 -- parsed as a name form (which is syntactically identical).
10485 -- In a generic context a parameterless call will be left as
10486 -- an expanded name (if global) or selected_component if local.
10487 -- Change it to a procedure call statement now.
10489 Change_Name_To_Procedure_Call_Statement
(Call
);
10491 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
10493 -- Already in the form of a procedure call statement: nothing
10494 -- to do (could happen in case of an internally generated
10500 -- All other cases: diagnose error
10503 ("argument of pragma ""Debug"" is not procedure call",
10508 -- Rewrite into a conditional with an appropriate condition. We
10509 -- wrap the procedure call in a block so that overhead from e.g.
10510 -- use of the secondary stack does not generate execution overhead
10511 -- for suppressed conditions.
10513 -- Normally the analysis that follows will freeze the subprogram
10514 -- being called. However, if the call is to a null procedure,
10515 -- we want to freeze it before creating the block, because the
10516 -- analysis that follows may be done with expansion disabled, in
10517 -- which case the body will not be generated, leading to spurious
10520 if Nkind
(Call
) = N_Procedure_Call_Statement
10521 and then Is_Entity_Name
(Name
(Call
))
10523 Analyze
(Name
(Call
));
10524 Freeze_Before
(N
, Entity
(Name
(Call
)));
10527 Rewrite
(N
, Make_Implicit_If_Statement
(N
,
10529 Then_Statements
=> New_List
(
10530 Make_Block_Statement
(Loc
,
10531 Handled_Statement_Sequence
=>
10532 Make_Handled_Sequence_Of_Statements
(Loc
,
10533 Statements
=> New_List
(Relocate_Node
(Call
)))))));
10541 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
10543 when Pragma_Debug_Policy
=>
10545 Check_Arg_Count
(1);
10546 Check_No_Identifiers
;
10547 Check_Arg_Is_Identifier
(Arg1
);
10549 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
10550 -- rewrite it that way, and let the rest of the checking come
10551 -- from analyzing the rewritten pragma.
10555 Chars
=> Name_Check_Policy
,
10556 Pragma_Argument_Associations
=> New_List
(
10557 Make_Pragma_Argument_Association
(Loc
,
10558 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
10560 Make_Pragma_Argument_Association
(Loc
,
10561 Expression
=> Get_Pragma_Arg
(Arg1
)))));
10568 -- pragma Depends (DEPENDENCY_RELATION);
10570 -- DEPENDENCY_RELATION ::=
10572 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}
10574 -- DEPENDENCY_CLAUSE ::=
10575 -- OUTPUT_LIST =>[+] INPUT_LIST
10576 -- | NULL_DEPENDENCY_CLAUSE
10578 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
10580 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
10582 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
10584 -- OUTPUT ::= NAME | FUNCTION_RESULT
10587 -- where FUNCTION_RESULT is a function Result attribute_reference
10589 when Pragma_Depends
=> Depends
: declare
10590 Subp_Decl
: Node_Id
;
10591 Subp_Id
: Entity_Id
;
10596 Check_Arg_Count
(1);
10598 -- Ensure the proper placement of the pragma. Depends must be
10599 -- associated with a subprogram declaration or a body that acts
10602 Subp_Decl
:= Find_Related_Subprogram
(N
, Check_Duplicates
=> True);
10604 if Nkind
(Subp_Decl
) /= N_Subprogram_Declaration
10605 and then (Nkind
(Subp_Decl
) /= N_Subprogram_Body
10606 or else not Acts_As_Spec
(Subp_Decl
))
10612 Subp_Id
:= Defining_Unit_Name
(Specification
(Subp_Decl
));
10614 -- When the aspect/pragma appears on a subprogram body, perform
10615 -- the full analysis now.
10617 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
10618 Analyze_Depends_In_Decl_Part
(N
);
10620 -- When Depends applies to a subprogram compilation unit, the
10621 -- corresponding pragma is placed after the unit's declaration
10622 -- node and needs to be analyzed immediately.
10624 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
10625 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
10627 Analyze_Depends_In_Decl_Part
(N
);
10630 -- Chain the pragma on the contract for further processing
10632 Add_Contract_Item
(N
, Subp_Id
);
10635 ---------------------
10636 -- Detect_Blocking --
10637 ---------------------
10639 -- pragma Detect_Blocking;
10641 when Pragma_Detect_Blocking
=>
10643 Check_Arg_Count
(0);
10644 Check_Valid_Configuration_Pragma
;
10645 Detect_Blocking
:= True;
10647 --------------------------
10648 -- Default_Storage_Pool --
10649 --------------------------
10651 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
10653 when Pragma_Default_Storage_Pool
=>
10655 Check_Arg_Count
(1);
10657 -- Default_Storage_Pool can appear as a configuration pragma, or
10658 -- in a declarative part or a package spec.
10660 if not Is_Configuration_Pragma
then
10661 Check_Is_In_Decl_Part_Or_Package_Spec
;
10664 -- Case of Default_Storage_Pool (null);
10666 if Nkind
(Expression
(Arg1
)) = N_Null
then
10667 Analyze
(Expression
(Arg1
));
10669 -- This is an odd case, this is not really an expression, so
10670 -- we don't have a type for it. So just set the type to Empty.
10672 Set_Etype
(Expression
(Arg1
), Empty
);
10674 -- Case of Default_Storage_Pool (storage_pool_NAME);
10677 -- If it's a configuration pragma, then the only allowed
10678 -- argument is "null".
10680 if Is_Configuration_Pragma
then
10681 Error_Pragma_Arg
("NULL expected", Arg1
);
10684 -- The expected type for a non-"null" argument is
10685 -- Root_Storage_Pool'Class.
10687 Analyze_And_Resolve
10688 (Get_Pragma_Arg
(Arg1
),
10689 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
10692 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
10693 -- for an access type will use this information to set the
10694 -- appropriate attributes of the access type.
10696 Default_Pool
:= Expression
(Arg1
);
10698 ------------------------------------
10699 -- Disable_Atomic_Synchronization --
10700 ------------------------------------
10702 -- pragma Disable_Atomic_Synchronization [(Entity)];
10704 when Pragma_Disable_Atomic_Synchronization
=>
10706 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
10708 -------------------
10709 -- Discard_Names --
10710 -------------------
10712 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
10714 when Pragma_Discard_Names
=> Discard_Names
: declare
10719 Check_Ada_83_Warning
;
10721 -- Deal with configuration pragma case
10723 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
10724 Global_Discard_Names
:= True;
10727 -- Otherwise, check correct appropriate context
10730 Check_Is_In_Decl_Part_Or_Package_Spec
;
10732 if Arg_Count
= 0 then
10734 -- If there is no parameter, then from now on this pragma
10735 -- applies to any enumeration, exception or tagged type
10736 -- defined in the current declarative part, and recursively
10737 -- to any nested scope.
10739 Set_Discard_Names
(Current_Scope
);
10743 Check_Arg_Count
(1);
10744 Check_Optional_Identifier
(Arg1
, Name_On
);
10745 Check_Arg_Is_Local_Name
(Arg1
);
10747 E_Id
:= Get_Pragma_Arg
(Arg1
);
10749 if Etype
(E_Id
) = Any_Type
then
10752 E
:= Entity
(E_Id
);
10755 if (Is_First_Subtype
(E
)
10757 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
10758 or else Ekind
(E
) = E_Exception
10760 Set_Discard_Names
(E
);
10761 Record_Rep_Item
(E
, N
);
10765 ("inappropriate entity for pragma%", Arg1
);
10772 ------------------------
10773 -- Dispatching_Domain --
10774 ------------------------
10776 -- pragma Dispatching_Domain (EXPRESSION);
10778 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
10779 P
: constant Node_Id
:= Parent
(N
);
10785 Check_No_Identifiers
;
10786 Check_Arg_Count
(1);
10788 -- This pragma is born obsolete, but not the aspect
10790 if not From_Aspect_Specification
(N
) then
10792 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
10795 if Nkind
(P
) = N_Task_Definition
then
10796 Arg
:= Get_Pragma_Arg
(Arg1
);
10797 Ent
:= Defining_Identifier
(Parent
(P
));
10799 -- The expression must be analyzed in the special manner
10800 -- described in "Handling of Default and Per-Object
10801 -- Expressions" in sem.ads.
10803 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
10805 -- Check duplicate pragma before we chain the pragma in the Rep
10806 -- Item chain of Ent.
10808 Check_Duplicate_Pragma
(Ent
);
10809 Record_Rep_Item
(Ent
, N
);
10811 -- Anything else is incorrect
10816 end Dispatching_Domain
;
10822 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
10824 when Pragma_Elaborate
=> Elaborate
: declare
10829 -- Pragma must be in context items list of a compilation unit
10831 if not Is_In_Context_Clause
then
10835 -- Must be at least one argument
10837 if Arg_Count
= 0 then
10838 Error_Pragma
("pragma% requires at least one argument");
10841 -- In Ada 83 mode, there can be no items following it in the
10842 -- context list except other pragmas and implicit with clauses
10843 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
10844 -- placement rule does not apply.
10846 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
10848 while Present
(Citem
) loop
10849 if Nkind
(Citem
) = N_Pragma
10850 or else (Nkind
(Citem
) = N_With_Clause
10851 and then Implicit_With
(Citem
))
10856 ("(Ada 83) pragma% must be at end of context clause");
10863 -- Finally, the arguments must all be units mentioned in a with
10864 -- clause in the same context clause. Note we already checked (in
10865 -- Par.Prag) that the arguments are all identifiers or selected
10869 Outer
: while Present
(Arg
) loop
10870 Citem
:= First
(List_Containing
(N
));
10871 Inner
: while Citem
/= N
loop
10872 if Nkind
(Citem
) = N_With_Clause
10873 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
10875 Set_Elaborate_Present
(Citem
, True);
10876 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
10877 Generate_Reference
(Entity
(Name
(Citem
)), Citem
);
10879 -- With the pragma present, elaboration calls on
10880 -- subprograms from the named unit need no further
10881 -- checks, as long as the pragma appears in the current
10882 -- compilation unit. If the pragma appears in some unit
10883 -- in the context, there might still be a need for an
10884 -- Elaborate_All_Desirable from the current compilation
10885 -- to the named unit, so we keep the check enabled.
10887 if In_Extended_Main_Source_Unit
(N
) then
10888 Set_Suppress_Elaboration_Warnings
10889 (Entity
(Name
(Citem
)));
10900 ("argument of pragma% is not withed unit", Arg
);
10906 -- Give a warning if operating in static mode with -gnatwl
10907 -- (elaboration warnings enabled) switch set.
10909 if Elab_Warnings
and not Dynamic_Elaboration_Checks
then
10911 ("?l?use of pragma Elaborate may not be safe", N
);
10913 ("?l?use pragma Elaborate_All instead if possible", N
);
10917 -------------------
10918 -- Elaborate_All --
10919 -------------------
10921 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
10923 when Pragma_Elaborate_All
=> Elaborate_All
: declare
10928 Check_Ada_83_Warning
;
10930 -- Pragma must be in context items list of a compilation unit
10932 if not Is_In_Context_Clause
then
10936 -- Must be at least one argument
10938 if Arg_Count
= 0 then
10939 Error_Pragma
("pragma% requires at least one argument");
10942 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
10943 -- have to appear at the end of the context clause, but may
10944 -- appear mixed in with other items, even in Ada 83 mode.
10946 -- Final check: the arguments must all be units mentioned in
10947 -- a with clause in the same context clause. Note that we
10948 -- already checked (in Par.Prag) that all the arguments are
10949 -- either identifiers or selected components.
10952 Outr
: while Present
(Arg
) loop
10953 Citem
:= First
(List_Containing
(N
));
10954 Innr
: while Citem
/= N
loop
10955 if Nkind
(Citem
) = N_With_Clause
10956 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
10958 Set_Elaborate_All_Present
(Citem
, True);
10959 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
10961 -- Suppress warnings and elaboration checks on the named
10962 -- unit if the pragma is in the current compilation, as
10963 -- for pragma Elaborate.
10965 if In_Extended_Main_Source_Unit
(N
) then
10966 Set_Suppress_Elaboration_Warnings
10967 (Entity
(Name
(Citem
)));
10976 Set_Error_Posted
(N
);
10978 ("argument of pragma% is not withed unit", Arg
);
10985 --------------------
10986 -- Elaborate_Body --
10987 --------------------
10989 -- pragma Elaborate_Body [( library_unit_NAME )];
10991 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
10992 Cunit_Node
: Node_Id
;
10993 Cunit_Ent
: Entity_Id
;
10996 Check_Ada_83_Warning
;
10997 Check_Valid_Library_Unit_Pragma
;
10999 if Nkind
(N
) = N_Null_Statement
then
11003 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
11004 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11006 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
11009 Error_Pragma
("pragma% must refer to a spec, not a body");
11011 Set_Body_Required
(Cunit_Node
, True);
11012 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
11014 -- If we are in dynamic elaboration mode, then we suppress
11015 -- elaboration warnings for the unit, since it is definitely
11016 -- fine NOT to do dynamic checks at the first level (and such
11017 -- checks will be suppressed because no elaboration boolean
11018 -- is created for Elaborate_Body packages).
11020 -- But in the static model of elaboration, Elaborate_Body is
11021 -- definitely NOT good enough to ensure elaboration safety on
11022 -- its own, since the body may WITH other units that are not
11023 -- safe from an elaboration point of view, so a client must
11024 -- still do an Elaborate_All on such units.
11026 -- Debug flag -gnatdD restores the old behavior of 3.13, where
11027 -- Elaborate_Body always suppressed elab warnings.
11029 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
11030 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
11033 end Elaborate_Body
;
11035 ------------------------
11036 -- Elaboration_Checks --
11037 ------------------------
11039 -- pragma Elaboration_Checks (Static | Dynamic);
11041 when Pragma_Elaboration_Checks
=>
11043 Check_Arg_Count
(1);
11044 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
11045 Dynamic_Elaboration_Checks
:=
11046 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
);
11052 -- pragma Eliminate (
11053 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
11054 -- [,[Entity =>] IDENTIFIER |
11055 -- SELECTED_COMPONENT |
11057 -- [, OVERLOADING_RESOLUTION]);
11059 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
11062 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
11063 -- FUNCTION_PROFILE
11065 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
11067 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
11068 -- Result_Type => result_SUBTYPE_NAME]
11070 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
11071 -- SUBTYPE_NAME ::= STRING_LITERAL
11073 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
11074 -- SOURCE_TRACE ::= STRING_LITERAL
11076 when Pragma_Eliminate
=> Eliminate
: declare
11077 Args
: Args_List
(1 .. 5);
11078 Names
: constant Name_List
(1 .. 5) := (
11081 Name_Parameter_Types
,
11083 Name_Source_Location
);
11085 Unit_Name
: Node_Id
renames Args
(1);
11086 Entity
: Node_Id
renames Args
(2);
11087 Parameter_Types
: Node_Id
renames Args
(3);
11088 Result_Type
: Node_Id
renames Args
(4);
11089 Source_Location
: Node_Id
renames Args
(5);
11093 Check_Valid_Configuration_Pragma
;
11094 Gather_Associations
(Names
, Args
);
11096 if No
(Unit_Name
) then
11097 Error_Pragma
("missing Unit_Name argument for pragma%");
11101 and then (Present
(Parameter_Types
)
11103 Present
(Result_Type
)
11105 Present
(Source_Location
))
11107 Error_Pragma
("missing Entity argument for pragma%");
11110 if (Present
(Parameter_Types
)
11112 Present
(Result_Type
))
11114 Present
(Source_Location
)
11117 ("parameter profile and source location cannot be used "
11118 & "together in pragma%");
11121 Process_Eliminate_Pragma
11130 -----------------------------------
11131 -- Enable_Atomic_Synchronization --
11132 -----------------------------------
11134 -- pragma Enable_Atomic_Synchronization [(Entity)];
11136 when Pragma_Enable_Atomic_Synchronization
=>
11138 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
11145 -- [ Convention =>] convention_IDENTIFIER,
11146 -- [ Entity =>] local_NAME
11147 -- [, [External_Name =>] static_string_EXPRESSION ]
11148 -- [, [Link_Name =>] static_string_EXPRESSION ]);
11150 when Pragma_Export
=> Export
: declare
11152 Def_Id
: Entity_Id
;
11154 pragma Warnings
(Off
, C
);
11157 Check_Ada_83_Warning
;
11161 Name_External_Name
,
11164 Check_At_Least_N_Arguments
(2);
11166 Check_At_Most_N_Arguments
(4);
11167 Process_Convention
(C
, Def_Id
);
11169 if Ekind
(Def_Id
) /= E_Constant
then
11170 Note_Possible_Modification
11171 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
11174 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
11175 Set_Exported
(Def_Id
, Arg2
);
11177 -- If the entity is a deferred constant, propagate the information
11178 -- to the full view, because gigi elaborates the full view only.
11180 if Ekind
(Def_Id
) = E_Constant
11181 and then Present
(Full_View
(Def_Id
))
11184 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
11186 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
11187 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
11188 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
11193 ----------------------
11194 -- Export_Exception --
11195 ----------------------
11197 -- pragma Export_Exception (
11198 -- [Internal =>] LOCAL_NAME
11199 -- [, [External =>] EXTERNAL_SYMBOL]
11200 -- [, [Form =>] Ada | VMS]
11201 -- [, [Code =>] static_integer_EXPRESSION]);
11203 when Pragma_Export_Exception
=> Export_Exception
: declare
11204 Args
: Args_List
(1 .. 4);
11205 Names
: constant Name_List
(1 .. 4) := (
11211 Internal
: Node_Id
renames Args
(1);
11212 External
: Node_Id
renames Args
(2);
11213 Form
: Node_Id
renames Args
(3);
11214 Code
: Node_Id
renames Args
(4);
11219 if Inside_A_Generic
then
11220 Error_Pragma
("pragma% cannot be used for generic entities");
11223 Gather_Associations
(Names
, Args
);
11224 Process_Extended_Import_Export_Exception_Pragma
(
11225 Arg_Internal
=> Internal
,
11226 Arg_External
=> External
,
11230 if not Is_VMS_Exception
(Entity
(Internal
)) then
11231 Set_Exported
(Entity
(Internal
), Internal
);
11233 end Export_Exception
;
11235 ---------------------
11236 -- Export_Function --
11237 ---------------------
11239 -- pragma Export_Function (
11240 -- [Internal =>] LOCAL_NAME
11241 -- [, [External =>] EXTERNAL_SYMBOL]
11242 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
11243 -- [, [Result_Type =>] TYPE_DESIGNATOR]
11244 -- [, [Mechanism =>] MECHANISM]
11245 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
11247 -- EXTERNAL_SYMBOL ::=
11249 -- | static_string_EXPRESSION
11251 -- PARAMETER_TYPES ::=
11253 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
11255 -- TYPE_DESIGNATOR ::=
11257 -- | subtype_Name ' Access
11261 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
11263 -- MECHANISM_ASSOCIATION ::=
11264 -- [formal_parameter_NAME =>] MECHANISM_NAME
11266 -- MECHANISM_NAME ::=
11269 -- | Descriptor [([Class =>] CLASS_NAME)]
11271 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
11273 when Pragma_Export_Function
=> Export_Function
: declare
11274 Args
: Args_List
(1 .. 6);
11275 Names
: constant Name_List
(1 .. 6) := (
11278 Name_Parameter_Types
,
11281 Name_Result_Mechanism
);
11283 Internal
: Node_Id
renames Args
(1);
11284 External
: Node_Id
renames Args
(2);
11285 Parameter_Types
: Node_Id
renames Args
(3);
11286 Result_Type
: Node_Id
renames Args
(4);
11287 Mechanism
: Node_Id
renames Args
(5);
11288 Result_Mechanism
: Node_Id
renames Args
(6);
11292 Gather_Associations
(Names
, Args
);
11293 Process_Extended_Import_Export_Subprogram_Pragma
(
11294 Arg_Internal
=> Internal
,
11295 Arg_External
=> External
,
11296 Arg_Parameter_Types
=> Parameter_Types
,
11297 Arg_Result_Type
=> Result_Type
,
11298 Arg_Mechanism
=> Mechanism
,
11299 Arg_Result_Mechanism
=> Result_Mechanism
);
11300 end Export_Function
;
11302 -------------------
11303 -- Export_Object --
11304 -------------------
11306 -- pragma Export_Object (
11307 -- [Internal =>] LOCAL_NAME
11308 -- [, [External =>] EXTERNAL_SYMBOL]
11309 -- [, [Size =>] EXTERNAL_SYMBOL]);
11311 -- EXTERNAL_SYMBOL ::=
11313 -- | static_string_EXPRESSION
11315 -- PARAMETER_TYPES ::=
11317 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
11319 -- TYPE_DESIGNATOR ::=
11321 -- | subtype_Name ' Access
11325 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
11327 -- MECHANISM_ASSOCIATION ::=
11328 -- [formal_parameter_NAME =>] MECHANISM_NAME
11330 -- MECHANISM_NAME ::=
11333 -- | Descriptor [([Class =>] CLASS_NAME)]
11335 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
11337 when Pragma_Export_Object
=> Export_Object
: declare
11338 Args
: Args_List
(1 .. 3);
11339 Names
: constant Name_List
(1 .. 3) := (
11344 Internal
: Node_Id
renames Args
(1);
11345 External
: Node_Id
renames Args
(2);
11346 Size
: Node_Id
renames Args
(3);
11350 Gather_Associations
(Names
, Args
);
11351 Process_Extended_Import_Export_Object_Pragma
(
11352 Arg_Internal
=> Internal
,
11353 Arg_External
=> External
,
11357 ----------------------
11358 -- Export_Procedure --
11359 ----------------------
11361 -- pragma Export_Procedure (
11362 -- [Internal =>] LOCAL_NAME
11363 -- [, [External =>] EXTERNAL_SYMBOL]
11364 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
11365 -- [, [Mechanism =>] MECHANISM]);
11367 -- EXTERNAL_SYMBOL ::=
11369 -- | static_string_EXPRESSION
11371 -- PARAMETER_TYPES ::=
11373 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
11375 -- TYPE_DESIGNATOR ::=
11377 -- | subtype_Name ' Access
11381 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
11383 -- MECHANISM_ASSOCIATION ::=
11384 -- [formal_parameter_NAME =>] MECHANISM_NAME
11386 -- MECHANISM_NAME ::=
11389 -- | Descriptor [([Class =>] CLASS_NAME)]
11391 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
11393 when Pragma_Export_Procedure
=> Export_Procedure
: declare
11394 Args
: Args_List
(1 .. 4);
11395 Names
: constant Name_List
(1 .. 4) := (
11398 Name_Parameter_Types
,
11401 Internal
: Node_Id
renames Args
(1);
11402 External
: Node_Id
renames Args
(2);
11403 Parameter_Types
: Node_Id
renames Args
(3);
11404 Mechanism
: Node_Id
renames Args
(4);
11408 Gather_Associations
(Names
, Args
);
11409 Process_Extended_Import_Export_Subprogram_Pragma
(
11410 Arg_Internal
=> Internal
,
11411 Arg_External
=> External
,
11412 Arg_Parameter_Types
=> Parameter_Types
,
11413 Arg_Mechanism
=> Mechanism
);
11414 end Export_Procedure
;
11420 -- pragma Export_Value (
11421 -- [Value =>] static_integer_EXPRESSION,
11422 -- [Link_Name =>] static_string_EXPRESSION);
11424 when Pragma_Export_Value
=>
11426 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
11427 Check_Arg_Count
(2);
11429 Check_Optional_Identifier
(Arg1
, Name_Value
);
11430 Check_Arg_Is_Static_Expression
(Arg1
, Any_Integer
);
11432 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
11433 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
11435 -----------------------------
11436 -- Export_Valued_Procedure --
11437 -----------------------------
11439 -- pragma Export_Valued_Procedure (
11440 -- [Internal =>] LOCAL_NAME
11441 -- [, [External =>] EXTERNAL_SYMBOL,]
11442 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
11443 -- [, [Mechanism =>] MECHANISM]);
11445 -- EXTERNAL_SYMBOL ::=
11447 -- | static_string_EXPRESSION
11449 -- PARAMETER_TYPES ::=
11451 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
11453 -- TYPE_DESIGNATOR ::=
11455 -- | subtype_Name ' Access
11459 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
11461 -- MECHANISM_ASSOCIATION ::=
11462 -- [formal_parameter_NAME =>] MECHANISM_NAME
11464 -- MECHANISM_NAME ::=
11467 -- | Descriptor [([Class =>] CLASS_NAME)]
11469 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
11471 when Pragma_Export_Valued_Procedure
=>
11472 Export_Valued_Procedure
: declare
11473 Args
: Args_List
(1 .. 4);
11474 Names
: constant Name_List
(1 .. 4) := (
11477 Name_Parameter_Types
,
11480 Internal
: Node_Id
renames Args
(1);
11481 External
: Node_Id
renames Args
(2);
11482 Parameter_Types
: Node_Id
renames Args
(3);
11483 Mechanism
: Node_Id
renames Args
(4);
11487 Gather_Associations
(Names
, Args
);
11488 Process_Extended_Import_Export_Subprogram_Pragma
(
11489 Arg_Internal
=> Internal
,
11490 Arg_External
=> External
,
11491 Arg_Parameter_Types
=> Parameter_Types
,
11492 Arg_Mechanism
=> Mechanism
);
11493 end Export_Valued_Procedure
;
11495 -------------------
11496 -- Extend_System --
11497 -------------------
11499 -- pragma Extend_System ([Name =>] Identifier);
11501 when Pragma_Extend_System
=> Extend_System
: declare
11504 Check_Valid_Configuration_Pragma
;
11505 Check_Arg_Count
(1);
11506 Check_Optional_Identifier
(Arg1
, Name_Name
);
11507 Check_Arg_Is_Identifier
(Arg1
);
11509 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
11512 and then Name_Buffer
(1 .. 4) = "aux_"
11514 if Present
(System_Extend_Pragma_Arg
) then
11515 if Chars
(Get_Pragma_Arg
(Arg1
)) =
11516 Chars
(Expression
(System_Extend_Pragma_Arg
))
11520 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
11521 Error_Pragma
("pragma% conflicts with that #");
11525 System_Extend_Pragma_Arg
:= Arg1
;
11527 if not GNAT_Mode
then
11528 System_Extend_Unit
:= Arg1
;
11532 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
11536 ------------------------
11537 -- Extensions_Allowed --
11538 ------------------------
11540 -- pragma Extensions_Allowed (ON | OFF);
11542 when Pragma_Extensions_Allowed
=>
11544 Check_Arg_Count
(1);
11545 Check_No_Identifiers
;
11546 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11548 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11549 Extensions_Allowed
:= True;
11550 Ada_Version
:= Ada_Version_Type
'Last;
11553 Extensions_Allowed
:= False;
11554 Ada_Version
:= Ada_Version_Explicit
;
11561 -- pragma External (
11562 -- [ Convention =>] convention_IDENTIFIER,
11563 -- [ Entity =>] local_NAME
11564 -- [, [External_Name =>] static_string_EXPRESSION ]
11565 -- [, [Link_Name =>] static_string_EXPRESSION ]);
11567 when Pragma_External
=> External
: declare
11568 Def_Id
: Entity_Id
;
11571 pragma Warnings
(Off
, C
);
11578 Name_External_Name
,
11580 Check_At_Least_N_Arguments
(2);
11581 Check_At_Most_N_Arguments
(4);
11582 Process_Convention
(C
, Def_Id
);
11583 Note_Possible_Modification
11584 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
11585 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
11586 Set_Exported
(Def_Id
, Arg2
);
11589 --------------------------
11590 -- External_Name_Casing --
11591 --------------------------
11593 -- pragma External_Name_Casing (
11594 -- UPPERCASE | LOWERCASE
11595 -- [, AS_IS | UPPERCASE | LOWERCASE]);
11597 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
11600 Check_No_Identifiers
;
11602 if Arg_Count
= 2 then
11603 Check_Arg_Is_One_Of
11604 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
11606 case Chars
(Get_Pragma_Arg
(Arg2
)) is
11608 Opt
.External_Name_Exp_Casing
:= As_Is
;
11610 when Name_Uppercase
=>
11611 Opt
.External_Name_Exp_Casing
:= Uppercase
;
11613 when Name_Lowercase
=>
11614 Opt
.External_Name_Exp_Casing
:= Lowercase
;
11621 Check_Arg_Count
(1);
11624 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
11626 case Chars
(Get_Pragma_Arg
(Arg1
)) is
11627 when Name_Uppercase
=>
11628 Opt
.External_Name_Imp_Casing
:= Uppercase
;
11630 when Name_Lowercase
=>
11631 Opt
.External_Name_Imp_Casing
:= Lowercase
;
11636 end External_Name_Casing
;
11642 -- pragma Fast_Math;
11644 when Pragma_Fast_Math
=>
11646 Check_No_Identifiers
;
11647 Check_Valid_Configuration_Pragma
;
11650 --------------------------
11651 -- Favor_Top_Level --
11652 --------------------------
11654 -- pragma Favor_Top_Level (type_NAME);
11656 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
11657 Named_Entity
: Entity_Id
;
11661 Check_No_Identifiers
;
11662 Check_Arg_Count
(1);
11663 Check_Arg_Is_Local_Name
(Arg1
);
11664 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
11666 -- If it's an access-to-subprogram type (in particular, not a
11667 -- subtype), set the flag on that type.
11669 if Is_Access_Subprogram_Type
(Named_Entity
) then
11670 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
11672 -- Otherwise it's an error (name denotes the wrong sort of entity)
11676 ("access-to-subprogram type expected",
11677 Get_Pragma_Arg
(Arg1
));
11679 end Favor_Top_Level
;
11681 ---------------------------
11682 -- Finalize_Storage_Only --
11683 ---------------------------
11685 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
11687 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
11688 Assoc
: constant Node_Id
:= Arg1
;
11689 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
11694 Check_No_Identifiers
;
11695 Check_Arg_Count
(1);
11696 Check_Arg_Is_Local_Name
(Arg1
);
11698 Find_Type
(Type_Id
);
11699 Typ
:= Entity
(Type_Id
);
11702 or else Rep_Item_Too_Early
(Typ
, N
)
11706 Typ
:= Underlying_Type
(Typ
);
11709 if not Is_Controlled
(Typ
) then
11710 Error_Pragma
("pragma% must specify controlled type");
11713 Check_First_Subtype
(Arg1
);
11715 if Finalize_Storage_Only
(Typ
) then
11716 Error_Pragma
("duplicate pragma%, only one allowed");
11718 elsif not Rep_Item_Too_Late
(Typ
, N
) then
11719 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
11721 end Finalize_Storage
;
11723 --------------------------
11724 -- Float_Representation --
11725 --------------------------
11727 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
11729 -- FLOAT_REP ::= VAX_Float | IEEE_Float
11731 when Pragma_Float_Representation
=> Float_Representation
: declare
11739 if Arg_Count
= 1 then
11740 Check_Valid_Configuration_Pragma
;
11742 Check_Arg_Count
(2);
11743 Check_Optional_Identifier
(Arg2
, Name_Entity
);
11744 Check_Arg_Is_Local_Name
(Arg2
);
11747 Check_No_Identifier
(Arg1
);
11748 Check_Arg_Is_One_Of
(Arg1
, Name_VAX_Float
, Name_IEEE_Float
);
11750 if not OpenVMS_On_Target
then
11751 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_VAX_Float
then
11753 ("??pragma% ignored (applies only to Open'V'M'S)");
11759 -- One argument case
11761 if Arg_Count
= 1 then
11762 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_VAX_Float
then
11763 if Opt
.Float_Format
= 'I' then
11764 Error_Pragma
("'I'E'E'E format previously specified");
11767 Opt
.Float_Format
:= 'V';
11770 if Opt
.Float_Format
= 'V' then
11771 Error_Pragma
("'V'A'X format previously specified");
11774 Opt
.Float_Format
:= 'I';
11777 Set_Standard_Fpt_Formats
;
11779 -- Two argument case
11782 Argx
:= Get_Pragma_Arg
(Arg2
);
11784 if not Is_Entity_Name
(Argx
)
11785 or else not Is_Floating_Point_Type
(Entity
(Argx
))
11788 ("second argument of% pragma must be floating-point type",
11792 Ent
:= Entity
(Argx
);
11793 Digs
:= UI_To_Int
(Digits_Value
(Ent
));
11795 -- Two arguments, VAX_Float case
11797 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_VAX_Float
then
11799 when 6 => Set_F_Float
(Ent
);
11800 when 9 => Set_D_Float
(Ent
);
11801 when 15 => Set_G_Float
(Ent
);
11805 ("wrong digits value, must be 6,9 or 15", Arg2
);
11808 -- Two arguments, IEEE_Float case
11812 when 6 => Set_IEEE_Short
(Ent
);
11813 when 15 => Set_IEEE_Long
(Ent
);
11817 ("wrong digits value, must be 6 or 15", Arg2
);
11821 end Float_Representation
;
11827 -- pragma Global (GLOBAL_SPECIFICATION)
11829 -- GLOBAL_SPECIFICATION ::=
11832 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}
11834 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
11836 -- MODE_SELECTOR ::= Input | Output | In_Out | Contract_In
11837 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
11838 -- GLOBAL_ITEM ::= NAME
11840 when Pragma_Global
=> Global
: declare
11841 Subp_Decl
: Node_Id
;
11842 Subp_Id
: Entity_Id
;
11847 Check_Arg_Count
(1);
11849 -- Ensure the proper placement of the pragma. Global must be
11850 -- associated with a subprogram declaration or a body that acts
11853 Subp_Decl
:= Find_Related_Subprogram
(N
, Check_Duplicates
=> True);
11855 if Nkind
(Subp_Decl
) /= N_Subprogram_Declaration
11856 and then (Nkind
(Subp_Decl
) /= N_Subprogram_Body
11857 or else not Acts_As_Spec
(Subp_Decl
))
11863 Subp_Id
:= Defining_Unit_Name
(Specification
(Subp_Decl
));
11865 -- When the aspect/pragma appears on a subprogram body, perform
11866 -- the full analysis now.
11868 if Nkind
(Subp_Decl
) = N_Subprogram_Body
then
11869 Analyze_Global_In_Decl_Part
(N
);
11871 -- When Global applies to a subprogram compilation unit, the
11872 -- corresponding pragma is placed after the unit's declaration
11873 -- node and needs to be analyzed immediately.
11875 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
11876 and then Nkind
(Parent
(Subp_Decl
)) = N_Compilation_Unit
11878 Analyze_Global_In_Decl_Part
(N
);
11881 -- Chain the pragma on the contract for further processing
11883 Add_Contract_Item
(N
, Subp_Id
);
11890 -- pragma Ident (static_string_EXPRESSION)
11892 -- Note: pragma Comment shares this processing. Pragma Comment is
11893 -- identical to Ident, except that the restriction of the argument to
11894 -- 31 characters and the placement restrictions are not enforced for
11897 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
11902 Check_Arg_Count
(1);
11903 Check_No_Identifiers
;
11904 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
11907 -- For pragma Ident, preserve DEC compatibility by requiring the
11908 -- pragma to appear in a declarative part or package spec.
11910 if Prag_Id
= Pragma_Ident
then
11911 Check_Is_In_Decl_Part_Or_Package_Spec
;
11914 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
11921 GP
:= Parent
(Parent
(N
));
11923 if Nkind_In
(GP
, N_Package_Declaration
,
11924 N_Generic_Package_Declaration
)
11929 -- If we have a compilation unit, then record the ident value,
11930 -- checking for improper duplication.
11932 if Nkind
(GP
) = N_Compilation_Unit
then
11933 CS
:= Ident_String
(Current_Sem_Unit
);
11935 if Present
(CS
) then
11937 -- For Ident, we do not permit multiple instances
11939 if Prag_Id
= Pragma_Ident
then
11940 Error_Pragma
("duplicate% pragma not permitted");
11942 -- For Comment, we concatenate the string, unless we want
11943 -- to preserve the tree structure for ASIS.
11945 elsif not ASIS_Mode
then
11946 Start_String
(Strval
(CS
));
11947 Store_String_Char
(' ');
11948 Store_String_Chars
(Strval
(Str
));
11949 Set_Strval
(CS
, End_String
);
11953 -- In VMS, the effect of IDENT is achieved by passing
11954 -- --identification=name as a --for-linker switch.
11956 if OpenVMS_On_Target
then
11959 ("--for-linker=--identification=");
11960 String_To_Name_Buffer
(Strval
(Str
));
11961 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
11963 -- Only the last processed IDENT is saved. The main
11964 -- purpose is so an IDENT associated with a main
11965 -- procedure will be used in preference to an IDENT
11966 -- associated with a with'd package.
11968 Replace_Linker_Option_String
11969 (End_String
, "--for-linker=--identification=");
11972 Set_Ident_String
(Current_Sem_Unit
, Str
);
11975 -- For subunits, we just ignore the Ident, since in GNAT these
11976 -- are not separate object files, and hence not separate units
11977 -- in the unit table.
11979 elsif Nkind
(GP
) = N_Subunit
then
11982 -- Otherwise we have a misplaced pragma Ident, but we ignore
11983 -- this if we are in an instantiation, since it comes from
11984 -- a generic, and has no relevance to the instantiation.
11986 elsif Prag_Id
= Pragma_Ident
then
11987 if Instantiation_Location
(Loc
) = No_Location
then
11988 Error_Pragma
("pragma% only allowed at outer level");
11994 ----------------------------
11995 -- Implementation_Defined --
11996 ----------------------------
11998 -- pragma Implementation_Defined (local_NAME);
12000 -- Marks previously declared entity as implementation defined. For
12001 -- an overloaded entity, applies to the most recent homonym.
12003 -- pragma Implementation_Defined;
12005 -- The form with no arguments appears anywhere within a scope, most
12006 -- typically a package spec, and indicates that all entities that are
12007 -- defined within the package spec are Implementation_Defined.
12009 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
12014 Check_No_Identifiers
;
12016 -- Form with no arguments
12018 if Arg_Count
= 0 then
12019 Set_Is_Implementation_Defined
(Current_Scope
);
12021 -- Form with one argument
12024 Check_Arg_Count
(1);
12025 Check_Arg_Is_Local_Name
(Arg1
);
12026 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
12027 Set_Is_Implementation_Defined
(Ent
);
12029 end Implementation_Defined
;
12035 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
12037 -- IMPLEMENTATION_KIND ::=
12038 -- By_Entry | By_Protected_Procedure | By_Any | Optional
12040 -- "By_Any" and "Optional" are treated as synonyms in order to
12041 -- support Ada 2012 aspect Synchronization.
12043 when Pragma_Implemented
=> Implemented
: declare
12044 Proc_Id
: Entity_Id
;
12049 Check_Arg_Count
(2);
12050 Check_No_Identifiers
;
12051 Check_Arg_Is_Identifier
(Arg1
);
12052 Check_Arg_Is_Local_Name
(Arg1
);
12053 Check_Arg_Is_One_Of
(Arg2
,
12056 Name_By_Protected_Procedure
,
12059 -- Extract the name of the local procedure
12061 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
12063 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
12064 -- primitive procedure of a synchronized tagged type.
12066 if Ekind
(Proc_Id
) = E_Procedure
12067 and then Is_Primitive
(Proc_Id
)
12068 and then Present
(First_Formal
(Proc_Id
))
12070 Typ
:= Etype
(First_Formal
(Proc_Id
));
12072 if Is_Tagged_Type
(Typ
)
12075 -- Check for a protected, a synchronized or a task interface
12077 ((Is_Interface
(Typ
)
12078 and then Is_Synchronized_Interface
(Typ
))
12080 -- Check for a protected type or a task type that implements
12084 (Is_Concurrent_Record_Type
(Typ
)
12085 and then Present
(Interfaces
(Typ
)))
12087 -- Check for a private record extension with keyword
12091 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
12092 E_Record_Subtype_With_Private
)
12093 and then Synchronized_Present
(Parent
(Typ
))))
12098 ("controlling formal must be of synchronized tagged type",
12103 -- Procedures declared inside a protected type must be accepted
12105 elsif Ekind
(Proc_Id
) = E_Procedure
12106 and then Is_Protected_Type
(Scope
(Proc_Id
))
12110 -- The first argument is not a primitive procedure
12114 ("pragma % must be applied to a primitive procedure", Arg1
);
12118 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
12119 -- By_Protected_Procedure to the primitive procedure of a task
12122 if Chars
(Arg2
) = Name_By_Protected_Procedure
12123 and then Is_Interface
(Typ
)
12124 and then Is_Task_Interface
(Typ
)
12127 ("implementation kind By_Protected_Procedure cannot be "
12128 & "applied to a task interface primitive", Arg2
);
12132 Record_Rep_Item
(Proc_Id
, N
);
12135 ----------------------
12136 -- Implicit_Packing --
12137 ----------------------
12139 -- pragma Implicit_Packing;
12141 when Pragma_Implicit_Packing
=>
12143 Check_Arg_Count
(0);
12144 Implicit_Packing
:= True;
12151 -- [Convention =>] convention_IDENTIFIER,
12152 -- [Entity =>] local_NAME
12153 -- [, [External_Name =>] static_string_EXPRESSION ]
12154 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12156 when Pragma_Import
=>
12157 Check_Ada_83_Warning
;
12161 Name_External_Name
,
12164 Check_At_Least_N_Arguments
(2);
12165 Check_At_Most_N_Arguments
(4);
12166 Process_Import_Or_Interface
;
12168 ----------------------
12169 -- Import_Exception --
12170 ----------------------
12172 -- pragma Import_Exception (
12173 -- [Internal =>] LOCAL_NAME
12174 -- [, [External =>] EXTERNAL_SYMBOL]
12175 -- [, [Form =>] Ada | VMS]
12176 -- [, [Code =>] static_integer_EXPRESSION]);
12178 when Pragma_Import_Exception
=> Import_Exception
: declare
12179 Args
: Args_List
(1 .. 4);
12180 Names
: constant Name_List
(1 .. 4) := (
12186 Internal
: Node_Id
renames Args
(1);
12187 External
: Node_Id
renames Args
(2);
12188 Form
: Node_Id
renames Args
(3);
12189 Code
: Node_Id
renames Args
(4);
12193 Gather_Associations
(Names
, Args
);
12195 if Present
(External
) and then Present
(Code
) then
12197 ("cannot give both External and Code options for pragma%");
12200 Process_Extended_Import_Export_Exception_Pragma
(
12201 Arg_Internal
=> Internal
,
12202 Arg_External
=> External
,
12206 if not Is_VMS_Exception
(Entity
(Internal
)) then
12207 Set_Imported
(Entity
(Internal
));
12209 end Import_Exception
;
12211 ---------------------
12212 -- Import_Function --
12213 ---------------------
12215 -- pragma Import_Function (
12216 -- [Internal =>] LOCAL_NAME,
12217 -- [, [External =>] EXTERNAL_SYMBOL]
12218 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12219 -- [, [Result_Type =>] SUBTYPE_MARK]
12220 -- [, [Mechanism =>] MECHANISM]
12221 -- [, [Result_Mechanism =>] MECHANISM_NAME]
12222 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
12224 -- EXTERNAL_SYMBOL ::=
12226 -- | static_string_EXPRESSION
12228 -- PARAMETER_TYPES ::=
12230 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12232 -- TYPE_DESIGNATOR ::=
12234 -- | subtype_Name ' Access
12238 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12240 -- MECHANISM_ASSOCIATION ::=
12241 -- [formal_parameter_NAME =>] MECHANISM_NAME
12243 -- MECHANISM_NAME ::=
12246 -- | Descriptor [([Class =>] CLASS_NAME)]
12248 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12250 when Pragma_Import_Function
=> Import_Function
: declare
12251 Args
: Args_List
(1 .. 7);
12252 Names
: constant Name_List
(1 .. 7) := (
12255 Name_Parameter_Types
,
12258 Name_Result_Mechanism
,
12259 Name_First_Optional_Parameter
);
12261 Internal
: Node_Id
renames Args
(1);
12262 External
: Node_Id
renames Args
(2);
12263 Parameter_Types
: Node_Id
renames Args
(3);
12264 Result_Type
: Node_Id
renames Args
(4);
12265 Mechanism
: Node_Id
renames Args
(5);
12266 Result_Mechanism
: Node_Id
renames Args
(6);
12267 First_Optional_Parameter
: Node_Id
renames Args
(7);
12271 Gather_Associations
(Names
, Args
);
12272 Process_Extended_Import_Export_Subprogram_Pragma
(
12273 Arg_Internal
=> Internal
,
12274 Arg_External
=> External
,
12275 Arg_Parameter_Types
=> Parameter_Types
,
12276 Arg_Result_Type
=> Result_Type
,
12277 Arg_Mechanism
=> Mechanism
,
12278 Arg_Result_Mechanism
=> Result_Mechanism
,
12279 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
12280 end Import_Function
;
12282 -------------------
12283 -- Import_Object --
12284 -------------------
12286 -- pragma Import_Object (
12287 -- [Internal =>] LOCAL_NAME
12288 -- [, [External =>] EXTERNAL_SYMBOL]
12289 -- [, [Size =>] EXTERNAL_SYMBOL]);
12291 -- EXTERNAL_SYMBOL ::=
12293 -- | static_string_EXPRESSION
12295 when Pragma_Import_Object
=> Import_Object
: declare
12296 Args
: Args_List
(1 .. 3);
12297 Names
: constant Name_List
(1 .. 3) := (
12302 Internal
: Node_Id
renames Args
(1);
12303 External
: Node_Id
renames Args
(2);
12304 Size
: Node_Id
renames Args
(3);
12308 Gather_Associations
(Names
, Args
);
12309 Process_Extended_Import_Export_Object_Pragma
(
12310 Arg_Internal
=> Internal
,
12311 Arg_External
=> External
,
12315 ----------------------
12316 -- Import_Procedure --
12317 ----------------------
12319 -- pragma Import_Procedure (
12320 -- [Internal =>] LOCAL_NAME
12321 -- [, [External =>] EXTERNAL_SYMBOL]
12322 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12323 -- [, [Mechanism =>] MECHANISM]
12324 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
12326 -- EXTERNAL_SYMBOL ::=
12328 -- | static_string_EXPRESSION
12330 -- PARAMETER_TYPES ::=
12332 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12334 -- TYPE_DESIGNATOR ::=
12336 -- | subtype_Name ' Access
12340 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12342 -- MECHANISM_ASSOCIATION ::=
12343 -- [formal_parameter_NAME =>] MECHANISM_NAME
12345 -- MECHANISM_NAME ::=
12348 -- | Descriptor [([Class =>] CLASS_NAME)]
12350 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12352 when Pragma_Import_Procedure
=> Import_Procedure
: declare
12353 Args
: Args_List
(1 .. 5);
12354 Names
: constant Name_List
(1 .. 5) := (
12357 Name_Parameter_Types
,
12359 Name_First_Optional_Parameter
);
12361 Internal
: Node_Id
renames Args
(1);
12362 External
: Node_Id
renames Args
(2);
12363 Parameter_Types
: Node_Id
renames Args
(3);
12364 Mechanism
: Node_Id
renames Args
(4);
12365 First_Optional_Parameter
: Node_Id
renames Args
(5);
12369 Gather_Associations
(Names
, Args
);
12370 Process_Extended_Import_Export_Subprogram_Pragma
(
12371 Arg_Internal
=> Internal
,
12372 Arg_External
=> External
,
12373 Arg_Parameter_Types
=> Parameter_Types
,
12374 Arg_Mechanism
=> Mechanism
,
12375 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
12376 end Import_Procedure
;
12378 -----------------------------
12379 -- Import_Valued_Procedure --
12380 -----------------------------
12382 -- pragma Import_Valued_Procedure (
12383 -- [Internal =>] LOCAL_NAME
12384 -- [, [External =>] EXTERNAL_SYMBOL]
12385 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
12386 -- [, [Mechanism =>] MECHANISM]
12387 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
12389 -- EXTERNAL_SYMBOL ::=
12391 -- | static_string_EXPRESSION
12393 -- PARAMETER_TYPES ::=
12395 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
12397 -- TYPE_DESIGNATOR ::=
12399 -- | subtype_Name ' Access
12403 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
12405 -- MECHANISM_ASSOCIATION ::=
12406 -- [formal_parameter_NAME =>] MECHANISM_NAME
12408 -- MECHANISM_NAME ::=
12411 -- | Descriptor [([Class =>] CLASS_NAME)]
12413 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
12415 when Pragma_Import_Valued_Procedure
=>
12416 Import_Valued_Procedure
: declare
12417 Args
: Args_List
(1 .. 5);
12418 Names
: constant Name_List
(1 .. 5) := (
12421 Name_Parameter_Types
,
12423 Name_First_Optional_Parameter
);
12425 Internal
: Node_Id
renames Args
(1);
12426 External
: Node_Id
renames Args
(2);
12427 Parameter_Types
: Node_Id
renames Args
(3);
12428 Mechanism
: Node_Id
renames Args
(4);
12429 First_Optional_Parameter
: Node_Id
renames Args
(5);
12433 Gather_Associations
(Names
, Args
);
12434 Process_Extended_Import_Export_Subprogram_Pragma
(
12435 Arg_Internal
=> Internal
,
12436 Arg_External
=> External
,
12437 Arg_Parameter_Types
=> Parameter_Types
,
12438 Arg_Mechanism
=> Mechanism
,
12439 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
12440 end Import_Valued_Procedure
;
12446 -- pragma Independent (LOCAL_NAME);
12448 when Pragma_Independent
=> Independent
: declare
12455 Check_Ada_83_Warning
;
12457 Check_No_Identifiers
;
12458 Check_Arg_Count
(1);
12459 Check_Arg_Is_Local_Name
(Arg1
);
12460 E_Id
:= Get_Pragma_Arg
(Arg1
);
12462 if Etype
(E_Id
) = Any_Type
then
12466 E
:= Entity
(E_Id
);
12467 D
:= Declaration_Node
(E
);
12470 -- Check duplicate before we chain ourselves!
12472 Check_Duplicate_Pragma
(E
);
12474 -- Check appropriate entity
12476 if Is_Type
(E
) then
12477 if Rep_Item_Too_Early
(E
, N
)
12479 Rep_Item_Too_Late
(E
, N
)
12483 Check_First_Subtype
(Arg1
);
12486 elsif K
= N_Object_Declaration
12487 or else (K
= N_Component_Declaration
12488 and then Original_Record_Component
(E
) = E
)
12490 if Rep_Item_Too_Late
(E
, N
) then
12496 ("inappropriate entity for pragma%", Arg1
);
12499 Independence_Checks
.Append
((N
, E
));
12502 ----------------------------
12503 -- Independent_Components --
12504 ----------------------------
12506 -- pragma Atomic_Components (array_LOCAL_NAME);
12508 -- This processing is shared by Volatile_Components
12510 when Pragma_Independent_Components
=> Independent_Components
: declare
12517 Check_Ada_83_Warning
;
12519 Check_No_Identifiers
;
12520 Check_Arg_Count
(1);
12521 Check_Arg_Is_Local_Name
(Arg1
);
12522 E_Id
:= Get_Pragma_Arg
(Arg1
);
12524 if Etype
(E_Id
) = Any_Type
then
12528 E
:= Entity
(E_Id
);
12530 -- Check duplicate before we chain ourselves!
12532 Check_Duplicate_Pragma
(E
);
12534 -- Check appropriate entity
12536 if Rep_Item_Too_Early
(E
, N
)
12538 Rep_Item_Too_Late
(E
, N
)
12543 D
:= Declaration_Node
(E
);
12546 if K
= N_Full_Type_Declaration
12547 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
12549 Independence_Checks
.Append
((N
, E
));
12550 Set_Has_Independent_Components
(Base_Type
(E
));
12552 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
12553 and then Nkind
(D
) = N_Object_Declaration
12554 and then Nkind
(Object_Definition
(D
)) =
12555 N_Constrained_Array_Definition
12557 Independence_Checks
.Append
((N
, E
));
12558 Set_Has_Independent_Components
(E
);
12561 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
12563 end Independent_Components
;
12565 ------------------------
12566 -- Initialize_Scalars --
12567 ------------------------
12569 -- pragma Initialize_Scalars;
12571 when Pragma_Initialize_Scalars
=>
12573 Check_Arg_Count
(0);
12574 Check_Valid_Configuration_Pragma
;
12575 Check_Restriction
(No_Initialize_Scalars
, N
);
12577 -- Initialize_Scalars creates false positives in CodePeer, and
12578 -- incorrect negative results in SPARK mode, so ignore this pragma
12581 if not Restriction_Active
(No_Initialize_Scalars
)
12582 and then not (CodePeer_Mode
or SPARK_Mode
)
12584 Init_Or_Norm_Scalars
:= True;
12585 Initialize_Scalars
:= True;
12592 -- pragma Inline ( NAME {, NAME} );
12594 when Pragma_Inline
=>
12596 -- Inline status is Enabled if inlining option is active
12598 if Inline_Active
then
12599 Process_Inline
(Enabled
);
12601 Process_Inline
(Disabled
);
12604 -------------------
12605 -- Inline_Always --
12606 -------------------
12608 -- pragma Inline_Always ( NAME {, NAME} );
12610 when Pragma_Inline_Always
=>
12613 -- Pragma always active unless in CodePeer or SPARK mode, since
12614 -- this causes walk order issues.
12616 if not (CodePeer_Mode
or SPARK_Mode
) then
12617 Process_Inline
(Enabled
);
12620 --------------------
12621 -- Inline_Generic --
12622 --------------------
12624 -- pragma Inline_Generic (NAME {, NAME});
12626 when Pragma_Inline_Generic
=>
12628 Process_Generic_List
;
12630 ----------------------
12631 -- Inspection_Point --
12632 ----------------------
12634 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
12636 when Pragma_Inspection_Point
=> Inspection_Point
: declare
12641 if Arg_Count
> 0 then
12644 Exp
:= Get_Pragma_Arg
(Arg
);
12647 if not Is_Entity_Name
(Exp
)
12648 or else not Is_Object
(Entity
(Exp
))
12650 Error_Pragma_Arg
("object name required", Arg
);
12654 exit when No
(Arg
);
12657 end Inspection_Point
;
12663 -- pragma Interface (
12664 -- [ Convention =>] convention_IDENTIFIER,
12665 -- [ Entity =>] local_NAME
12666 -- [, [External_Name =>] static_string_EXPRESSION ]
12667 -- [, [Link_Name =>] static_string_EXPRESSION ]);
12669 when Pragma_Interface
=>
12674 Name_External_Name
,
12676 Check_At_Least_N_Arguments
(2);
12677 Check_At_Most_N_Arguments
(4);
12678 Process_Import_Or_Interface
;
12680 -- In Ada 2005, the permission to use Interface (a reserved word)
12681 -- as a pragma name is considered an obsolescent feature, and this
12682 -- pragma was already obsolescent in Ada 95.
12684 if Ada_Version
>= Ada_95
then
12686 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
12688 if Warn_On_Obsolescent_Feature
then
12690 ("pragma Interface is an obsolescent feature?j?", N
);
12692 ("|use pragma Import instead?j?", N
);
12696 --------------------
12697 -- Interface_Name --
12698 --------------------
12700 -- pragma Interface_Name (
12701 -- [ Entity =>] local_NAME
12702 -- [,[External_Name =>] static_string_EXPRESSION ]
12703 -- [,[Link_Name =>] static_string_EXPRESSION ]);
12705 when Pragma_Interface_Name
=> Interface_Name
: declare
12707 Def_Id
: Entity_Id
;
12708 Hom_Id
: Entity_Id
;
12714 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
12715 Check_At_Least_N_Arguments
(2);
12716 Check_At_Most_N_Arguments
(3);
12717 Id
:= Get_Pragma_Arg
(Arg1
);
12720 -- This is obsolete from Ada 95 on, but it is an implementation
12721 -- defined pragma, so we do not consider that it violates the
12722 -- restriction (No_Obsolescent_Features).
12724 if Ada_Version
>= Ada_95
then
12725 if Warn_On_Obsolescent_Feature
then
12727 ("pragma Interface_Name is an obsolescent feature?j?", N
);
12729 ("|use pragma Import instead?j?", N
);
12733 if not Is_Entity_Name
(Id
) then
12735 ("first argument for pragma% must be entity name", Arg1
);
12736 elsif Etype
(Id
) = Any_Type
then
12739 Def_Id
:= Entity
(Id
);
12742 -- Special DEC-compatible processing for the object case, forces
12743 -- object to be imported.
12745 if Ekind
(Def_Id
) = E_Variable
then
12746 Kill_Size_Check_Code
(Def_Id
);
12747 Note_Possible_Modification
(Id
, Sure
=> False);
12749 -- Initialization is not allowed for imported variable
12751 if Present
(Expression
(Parent
(Def_Id
)))
12752 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
12754 Error_Msg_Sloc
:= Sloc
(Def_Id
);
12756 ("no initialization allowed for declaration of& #",
12760 -- For compatibility, support VADS usage of providing both
12761 -- pragmas Interface and Interface_Name to obtain the effect
12762 -- of a single Import pragma.
12764 if Is_Imported
(Def_Id
)
12765 and then Present
(First_Rep_Item
(Def_Id
))
12766 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
12768 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
12772 Set_Imported
(Def_Id
);
12775 Set_Is_Public
(Def_Id
);
12776 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12779 -- Otherwise must be subprogram
12781 elsif not Is_Subprogram
(Def_Id
) then
12783 ("argument of pragma% is not subprogram", Arg1
);
12786 Check_At_Most_N_Arguments
(3);
12790 -- Loop through homonyms
12793 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
12795 if Is_Imported
(Def_Id
) then
12796 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
12800 exit when From_Aspect_Specification
(N
);
12801 Hom_Id
:= Homonym
(Hom_Id
);
12803 exit when No
(Hom_Id
)
12804 or else Scope
(Hom_Id
) /= Current_Scope
;
12809 ("argument of pragma% is not imported subprogram",
12813 end Interface_Name
;
12815 -----------------------
12816 -- Interrupt_Handler --
12817 -----------------------
12819 -- pragma Interrupt_Handler (handler_NAME);
12821 when Pragma_Interrupt_Handler
=>
12822 Check_Ada_83_Warning
;
12823 Check_Arg_Count
(1);
12824 Check_No_Identifiers
;
12826 if No_Run_Time_Mode
then
12827 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
12829 Check_Interrupt_Or_Attach_Handler
;
12830 Process_Interrupt_Or_Attach_Handler
;
12833 ------------------------
12834 -- Interrupt_Priority --
12835 ------------------------
12837 -- pragma Interrupt_Priority [(EXPRESSION)];
12839 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
12840 P
: constant Node_Id
:= Parent
(N
);
12845 Check_Ada_83_Warning
;
12847 if Arg_Count
/= 0 then
12848 Arg
:= Get_Pragma_Arg
(Arg1
);
12849 Check_Arg_Count
(1);
12850 Check_No_Identifiers
;
12852 -- The expression must be analyzed in the special manner
12853 -- described in "Handling of Default and Per-Object
12854 -- Expressions" in sem.ads.
12856 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
12859 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
12864 Ent
:= Defining_Identifier
(Parent
(P
));
12866 -- Check duplicate pragma before we chain the pragma in the Rep
12867 -- Item chain of Ent.
12869 Check_Duplicate_Pragma
(Ent
);
12870 Record_Rep_Item
(Ent
, N
);
12872 end Interrupt_Priority
;
12874 ---------------------
12875 -- Interrupt_State --
12876 ---------------------
12878 -- pragma Interrupt_State (
12879 -- [Name =>] INTERRUPT_ID,
12880 -- [State =>] INTERRUPT_STATE);
12882 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
12883 -- INTERRUPT_STATE => System | Runtime | User
12885 -- Note: if the interrupt id is given as an identifier, then it must
12886 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
12887 -- given as a static integer expression which must be in the range of
12888 -- Ada.Interrupts.Interrupt_ID.
12890 when Pragma_Interrupt_State
=> Interrupt_State
: declare
12892 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
12893 -- This is the entity Ada.Interrupts.Interrupt_ID;
12895 State_Type
: Character;
12896 -- Set to 's'/'r'/'u' for System/Runtime/User
12899 -- Index to entry in Interrupt_States table
12902 -- Value of interrupt
12904 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
12905 -- The first argument to the pragma
12907 Int_Ent
: Entity_Id
;
12908 -- Interrupt entity in Ada.Interrupts.Names
12912 Check_Arg_Order
((Name_Name
, Name_State
));
12913 Check_Arg_Count
(2);
12915 Check_Optional_Identifier
(Arg1
, Name_Name
);
12916 Check_Optional_Identifier
(Arg2
, Name_State
);
12917 Check_Arg_Is_Identifier
(Arg2
);
12919 -- First argument is identifier
12921 if Nkind
(Arg1X
) = N_Identifier
then
12923 -- Search list of names in Ada.Interrupts.Names
12925 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
12927 if No
(Int_Ent
) then
12928 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
12930 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
12931 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
12935 Next_Entity
(Int_Ent
);
12938 -- First argument is not an identifier, so it must be a static
12939 -- expression of type Ada.Interrupts.Interrupt_ID.
12942 Check_Arg_Is_Static_Expression
(Arg1
, Any_Integer
);
12943 Int_Val
:= Expr_Value
(Arg1X
);
12945 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
12947 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
12950 ("value not in range of type "
12951 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
12957 case Chars
(Get_Pragma_Arg
(Arg2
)) is
12958 when Name_Runtime
=> State_Type
:= 'r';
12959 when Name_System
=> State_Type
:= 's';
12960 when Name_User
=> State_Type
:= 'u';
12963 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
12966 -- Check if entry is already stored
12968 IST_Num
:= Interrupt_States
.First
;
12970 -- If entry not found, add it
12972 if IST_Num
> Interrupt_States
.Last
then
12973 Interrupt_States
.Append
12974 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
12975 Interrupt_State
=> State_Type
,
12976 Pragma_Loc
=> Loc
));
12979 -- Case of entry for the same entry
12981 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
12984 -- If state matches, done, no need to make redundant entry
12987 State_Type
= Interrupt_States
.Table
(IST_Num
).
12990 -- Otherwise if state does not match, error
12993 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
12995 ("state conflicts with that given #", Arg2
);
12999 IST_Num
:= IST_Num
+ 1;
13001 end Interrupt_State
;
13007 -- pragma Invariant
13008 -- ([Entity =>] type_LOCAL_NAME,
13009 -- [Check =>] EXPRESSION
13010 -- [,[Message =>] String_Expression]);
13012 when Pragma_Invariant
=> Invariant
: declare
13018 pragma Unreferenced
(Discard
);
13022 Check_At_Least_N_Arguments
(2);
13023 Check_At_Most_N_Arguments
(3);
13024 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13025 Check_Optional_Identifier
(Arg2
, Name_Check
);
13027 if Arg_Count
= 3 then
13028 Check_Optional_Identifier
(Arg3
, Name_Message
);
13029 Check_Arg_Is_Static_Expression
(Arg3
, Standard_String
);
13032 Check_Arg_Is_Local_Name
(Arg1
);
13034 Type_Id
:= Get_Pragma_Arg
(Arg1
);
13035 Find_Type
(Type_Id
);
13036 Typ
:= Entity
(Type_Id
);
13038 if Typ
= Any_Type
then
13041 -- An invariant must apply to a private type, or appear in the
13042 -- private part of a package spec and apply to a completion.
13044 elsif Ekind_In
(Typ
, E_Private_Type
,
13045 E_Record_Type_With_Private
,
13046 E_Limited_Private_Type
)
13050 elsif In_Private_Part
(Current_Scope
)
13051 and then Has_Private_Declaration
(Typ
)
13055 elsif In_Private_Part
(Current_Scope
) then
13057 ("pragma% only allowed for private type declared in "
13058 & "visible part", Arg1
);
13062 ("pragma% only allowed for private type", Arg1
);
13065 -- Note that the type has at least one invariant, and also that
13066 -- it has inheritable invariants if we have Invariant'Class
13067 -- or Type_Invariant'Class. Build the corresponding invariant
13068 -- procedure declaration, so that calls to it can be generated
13069 -- before the body is built (e.g. within an expression function).
13071 PDecl
:= Build_Invariant_Procedure_Declaration
(Typ
);
13073 Insert_After
(N
, PDecl
);
13076 if Class_Present
(N
) then
13077 Set_Has_Inheritable_Invariants
(Typ
);
13080 -- The remaining processing is simply to link the pragma on to
13081 -- the rep item chain, for processing when the type is frozen.
13082 -- This is accomplished by a call to Rep_Item_Too_Late.
13084 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
13087 ----------------------
13088 -- Java_Constructor --
13089 ----------------------
13091 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
13093 -- Also handles pragma CIL_Constructor
13095 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
13096 Java_Constructor
: declare
13097 Convention
: Convention_Id
;
13098 Def_Id
: Entity_Id
;
13099 Hom_Id
: Entity_Id
;
13101 This_Formal
: Entity_Id
;
13105 Check_Arg_Count
(1);
13106 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13107 Check_Arg_Is_Local_Name
(Arg1
);
13109 Id
:= Get_Pragma_Arg
(Arg1
);
13110 Find_Program_Unit_Name
(Id
);
13112 -- If we did not find the name, we are done
13114 if Etype
(Id
) = Any_Type
then
13118 -- Check wrong use of pragma in wrong VM target
13120 if VM_Target
= No_VM
then
13123 elsif VM_Target
= CLI_Target
13124 and then Prag_Id
= Pragma_Java_Constructor
13126 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
13128 elsif VM_Target
= JVM_Target
13129 and then Prag_Id
= Pragma_CIL_Constructor
13131 Error_Pragma
("must use pragma 'Java_'Constructor");
13135 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
13136 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
13137 when others => null;
13140 Hom_Id
:= Entity
(Id
);
13142 -- Loop through homonyms
13145 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
13147 -- The constructor is required to be a function
13149 if Ekind
(Def_Id
) /= E_Function
then
13150 if VM_Target
= JVM_Target
then
13152 ("pragma% requires function returning a 'Java access "
13156 ("pragma% requires function returning a 'C'I'L access "
13161 -- Check arguments: For tagged type the first formal must be
13162 -- named "this" and its type must be a named access type
13163 -- designating a class-wide tagged type that has convention
13164 -- CIL/Java. The first formal must also have a null default
13165 -- value. For example:
13167 -- type Typ is tagged ...
13168 -- type Ref is access all Typ;
13169 -- pragma Convention (CIL, Typ);
13171 -- function New_Typ (This : Ref) return Ref;
13172 -- function New_Typ (This : Ref; I : Integer) return Ref;
13173 -- pragma Cil_Constructor (New_Typ);
13175 -- Reason: The first formal must NOT be a primitive of the
13178 -- This rule also applies to constructors of delegates used
13179 -- to interface with standard target libraries. For example:
13181 -- type Delegate is access procedure ...
13182 -- pragma Import (CIL, Delegate, ...);
13184 -- function new_Delegate
13185 -- (This : Delegate := null; ... ) return Delegate;
13187 -- For value-types this rule does not apply.
13189 if not Is_Value_Type
(Etype
(Def_Id
)) then
13190 if No
(First_Formal
(Def_Id
)) then
13191 Error_Msg_Name_1
:= Pname
;
13192 Error_Msg_N
("% function must have parameters", Def_Id
);
13196 -- In the JRE library we have several occurrences in which
13197 -- the "this" parameter is not the first formal.
13199 This_Formal
:= First_Formal
(Def_Id
);
13201 -- In the JRE library we have several occurrences in which
13202 -- the "this" parameter is not the first formal. Search for
13205 if VM_Target
= JVM_Target
then
13206 while Present
(This_Formal
)
13207 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
13209 Next_Formal
(This_Formal
);
13212 if No
(This_Formal
) then
13213 This_Formal
:= First_Formal
(Def_Id
);
13217 -- Warning: The first parameter should be named "this".
13218 -- We temporarily allow it because we have the following
13219 -- case in the Java runtime (file s-osinte.ads) ???
13221 -- function new_Thread
13222 -- (Self_Id : System.Address) return Thread_Id;
13223 -- pragma Java_Constructor (new_Thread);
13225 if VM_Target
= JVM_Target
13226 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
13228 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
13232 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
13233 Error_Msg_Name_1
:= Pname
;
13235 ("first formal of % function must be named `this`",
13236 Parent
(This_Formal
));
13238 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
13239 Error_Msg_Name_1
:= Pname
;
13241 ("first formal of % function must be an access type",
13242 Parameter_Type
(Parent
(This_Formal
)));
13244 -- For delegates the type of the first formal must be a
13245 -- named access-to-subprogram type (see previous example)
13247 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
13248 and then Ekind
(Etype
(This_Formal
))
13249 /= E_Access_Subprogram_Type
13251 Error_Msg_Name_1
:= Pname
;
13253 ("first formal of % function must be a named access "
13254 & "to subprogram type",
13255 Parameter_Type
(Parent
(This_Formal
)));
13257 -- Warning: We should reject anonymous access types because
13258 -- the constructor must not be handled as a primitive of the
13259 -- tagged type. We temporarily allow it because this profile
13260 -- is currently generated by cil2ada???
13262 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
13263 and then not Ekind_In
(Etype
(This_Formal
),
13265 E_General_Access_Type
,
13266 E_Anonymous_Access_Type
)
13268 Error_Msg_Name_1
:= Pname
;
13270 ("first formal of % function must be a named access "
13271 & "type", Parameter_Type
(Parent
(This_Formal
)));
13273 elsif Atree
.Convention
13274 (Designated_Type
(Etype
(This_Formal
))) /= Convention
13276 Error_Msg_Name_1
:= Pname
;
13278 if Convention
= Convention_Java
then
13280 ("pragma% requires convention 'Cil in designated "
13281 & "type", Parameter_Type
(Parent
(This_Formal
)));
13284 ("pragma% requires convention 'Java in designated "
13285 & "type", Parameter_Type
(Parent
(This_Formal
)));
13288 elsif No
(Expression
(Parent
(This_Formal
)))
13289 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
13291 Error_Msg_Name_1
:= Pname
;
13293 ("pragma% requires first formal with default `null`",
13294 Parameter_Type
(Parent
(This_Formal
)));
13298 -- Check result type: the constructor must be a function
13300 -- * a value type (only allowed in the CIL compiler)
13301 -- * an access-to-subprogram type with convention Java/CIL
13302 -- * an access-type designating a type that has convention
13305 if Is_Value_Type
(Etype
(Def_Id
)) then
13308 -- Access-to-subprogram type with convention Java/CIL
13310 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
13311 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
13312 if Convention
= Convention_Java
then
13314 ("pragma% requires function returning a 'Java "
13315 & "access type", Arg1
);
13317 pragma Assert
(Convention
= Convention_CIL
);
13319 ("pragma% requires function returning a 'C'I'L "
13320 & "access type", Arg1
);
13324 elsif Ekind
(Etype
(Def_Id
)) in Access_Kind
then
13325 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
13326 E_General_Access_Type
)
13329 (Designated_Type
(Etype
(Def_Id
))) /= Convention
13331 Error_Msg_Name_1
:= Pname
;
13333 if Convention
= Convention_Java
then
13335 ("pragma% requires function returning a named "
13336 & "'Java access type", Arg1
);
13339 ("pragma% requires function returning a named "
13340 & "'C'I'L access type", Arg1
);
13345 Set_Is_Constructor
(Def_Id
);
13346 Set_Convention
(Def_Id
, Convention
);
13347 Set_Is_Imported
(Def_Id
);
13349 exit when From_Aspect_Specification
(N
);
13350 Hom_Id
:= Homonym
(Hom_Id
);
13352 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
13354 end Java_Constructor
;
13356 ----------------------
13357 -- Java_Interface --
13358 ----------------------
13360 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
13362 when Pragma_Java_Interface
=> Java_Interface
: declare
13368 Check_Arg_Count
(1);
13369 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13370 Check_Arg_Is_Local_Name
(Arg1
);
13372 Arg
:= Get_Pragma_Arg
(Arg1
);
13375 if Etype
(Arg
) = Any_Type
then
13379 if not Is_Entity_Name
(Arg
)
13380 or else not Is_Type
(Entity
(Arg
))
13382 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
13385 Typ
:= Underlying_Type
(Entity
(Arg
));
13387 -- For now simply check some of the semantic constraints on the
13388 -- type. This currently leaves out some restrictions on interface
13389 -- types, namely that the parent type must be java.lang.Object.Typ
13390 -- and that all primitives of the type should be declared
13393 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
13395 ("pragma% requires an abstract tagged type", Arg1
);
13397 elsif not Has_Discriminants
(Typ
)
13398 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
13399 /= E_Anonymous_Access_Type
13401 not Is_Class_Wide_Type
13402 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
13405 ("type must have a class-wide access discriminant", Arg1
);
13407 end Java_Interface
;
13413 -- pragma Keep_Names ([On => ] local_NAME);
13415 when Pragma_Keep_Names
=> Keep_Names
: declare
13420 Check_Arg_Count
(1);
13421 Check_Optional_Identifier
(Arg1
, Name_On
);
13422 Check_Arg_Is_Local_Name
(Arg1
);
13424 Arg
:= Get_Pragma_Arg
(Arg1
);
13427 if Etype
(Arg
) = Any_Type
then
13431 if not Is_Entity_Name
(Arg
)
13432 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
13435 ("pragma% requires a local enumeration type", Arg1
);
13438 Set_Discard_Names
(Entity
(Arg
), False);
13445 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
13447 when Pragma_License
=>
13449 Check_Arg_Count
(1);
13450 Check_No_Identifiers
;
13451 Check_Valid_Configuration_Pragma
;
13452 Check_Arg_Is_Identifier
(Arg1
);
13455 Sind
: constant Source_File_Index
:=
13456 Source_Index
(Current_Sem_Unit
);
13459 case Chars
(Get_Pragma_Arg
(Arg1
)) is
13461 Set_License
(Sind
, GPL
);
13463 when Name_Modified_GPL
=>
13464 Set_License
(Sind
, Modified_GPL
);
13466 when Name_Restricted
=>
13467 Set_License
(Sind
, Restricted
);
13469 when Name_Unrestricted
=>
13470 Set_License
(Sind
, Unrestricted
);
13473 Error_Pragma_Arg
("invalid license name", Arg1
);
13481 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
13483 when Pragma_Link_With
=> Link_With
: declare
13489 if Operating_Mode
= Generate_Code
13490 and then In_Extended_Main_Source_Unit
(N
)
13492 Check_At_Least_N_Arguments
(1);
13493 Check_No_Identifiers
;
13494 Check_Is_In_Decl_Part_Or_Package_Spec
;
13495 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
13499 while Present
(Arg
) loop
13500 Check_Arg_Is_Static_Expression
(Arg
, Standard_String
);
13502 -- Store argument, converting sequences of spaces to a
13503 -- single null character (this is one of the differences
13504 -- in processing between Link_With and Linker_Options).
13506 Arg_Store
: declare
13507 C
: constant Char_Code
:= Get_Char_Code
(' ');
13508 S
: constant String_Id
:=
13509 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
13510 L
: constant Nat
:= String_Length
(S
);
13513 procedure Skip_Spaces
;
13514 -- Advance F past any spaces
13520 procedure Skip_Spaces
is
13522 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
13527 -- Start of processing for Arg_Store
13530 Skip_Spaces
; -- skip leading spaces
13532 -- Loop through characters, changing any embedded
13533 -- sequence of spaces to a single null character (this
13534 -- is how Link_With/Linker_Options differ)
13537 if Get_String_Char
(S
, F
) = C
then
13540 Store_String_Char
(ASCII
.NUL
);
13543 Store_String_Char
(Get_String_Char
(S
, F
));
13551 if Present
(Arg
) then
13552 Store_String_Char
(ASCII
.NUL
);
13556 Store_Linker_Option_String
(End_String
);
13564 -- pragma Linker_Alias (
13565 -- [Entity =>] LOCAL_NAME
13566 -- [Target =>] static_string_EXPRESSION);
13568 when Pragma_Linker_Alias
=>
13570 Check_Arg_Order
((Name_Entity
, Name_Target
));
13571 Check_Arg_Count
(2);
13572 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13573 Check_Optional_Identifier
(Arg2
, Name_Target
);
13574 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
13575 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
13577 -- The only processing required is to link this item on to the
13578 -- list of rep items for the given entity. This is accomplished
13579 -- by the call to Rep_Item_Too_Late (when no error is detected
13580 -- and False is returned).
13582 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
13585 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
13588 ------------------------
13589 -- Linker_Constructor --
13590 ------------------------
13592 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
13594 -- Code is shared with Linker_Destructor
13596 -----------------------
13597 -- Linker_Destructor --
13598 -----------------------
13600 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
13602 when Pragma_Linker_Constructor |
13603 Pragma_Linker_Destructor
=>
13604 Linker_Constructor
: declare
13610 Check_Arg_Count
(1);
13611 Check_No_Identifiers
;
13612 Check_Arg_Is_Local_Name
(Arg1
);
13613 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
13615 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
13617 if not Is_Library_Level_Entity
(Proc
) then
13619 ("argument for pragma% must be library level entity", Arg1
);
13622 -- The only processing required is to link this item on to the
13623 -- list of rep items for the given entity. This is accomplished
13624 -- by the call to Rep_Item_Too_Late (when no error is detected
13625 -- and False is returned).
13627 if Rep_Item_Too_Late
(Proc
, N
) then
13630 Set_Has_Gigi_Rep_Item
(Proc
);
13632 end Linker_Constructor
;
13634 --------------------
13635 -- Linker_Options --
13636 --------------------
13638 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
13640 when Pragma_Linker_Options
=> Linker_Options
: declare
13644 Check_Ada_83_Warning
;
13645 Check_No_Identifiers
;
13646 Check_Arg_Count
(1);
13647 Check_Is_In_Decl_Part_Or_Package_Spec
;
13648 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
13649 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
13652 while Present
(Arg
) loop
13653 Check_Arg_Is_Static_Expression
(Arg
, Standard_String
);
13654 Store_String_Char
(ASCII
.NUL
);
13656 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
13660 if Operating_Mode
= Generate_Code
13661 and then In_Extended_Main_Source_Unit
(N
)
13663 Store_Linker_Option_String
(End_String
);
13665 end Linker_Options
;
13667 --------------------
13668 -- Linker_Section --
13669 --------------------
13671 -- pragma Linker_Section (
13672 -- [Entity =>] LOCAL_NAME
13673 -- [Section =>] static_string_EXPRESSION);
13675 when Pragma_Linker_Section
=>
13677 Check_Arg_Order
((Name_Entity
, Name_Section
));
13678 Check_Arg_Count
(2);
13679 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13680 Check_Optional_Identifier
(Arg2
, Name_Section
);
13681 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
13682 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
13684 -- This pragma applies only to objects
13686 if not Is_Object
(Entity
(Get_Pragma_Arg
(Arg1
))) then
13687 Error_Pragma_Arg
("pragma% applies only to objects", Arg1
);
13690 -- The only processing required is to link this item on to the
13691 -- list of rep items for the given entity. This is accomplished
13692 -- by the call to Rep_Item_Too_Late (when no error is detected
13693 -- and False is returned).
13695 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
13698 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
13705 -- pragma List (On | Off)
13707 -- There is nothing to do here, since we did all the processing for
13708 -- this pragma in Par.Prag (so that it works properly even in syntax
13711 when Pragma_List
=>
13718 -- pragma Lock_Free [(Boolean_EXPRESSION)];
13720 when Pragma_Lock_Free
=> Lock_Free
: declare
13721 P
: constant Node_Id
:= Parent
(N
);
13727 Check_No_Identifiers
;
13728 Check_At_Most_N_Arguments
(1);
13730 -- Protected definition case
13732 if Nkind
(P
) = N_Protected_Definition
then
13733 Ent
:= Defining_Identifier
(Parent
(P
));
13737 if Arg_Count
= 1 then
13738 Arg
:= Get_Pragma_Arg
(Arg1
);
13739 Val
:= Is_True
(Static_Boolean
(Arg
));
13741 -- No arguments (expression is considered to be True)
13747 -- Check duplicate pragma before we chain the pragma in the Rep
13748 -- Item chain of Ent.
13750 Check_Duplicate_Pragma
(Ent
);
13751 Record_Rep_Item
(Ent
, N
);
13752 Set_Uses_Lock_Free
(Ent
, Val
);
13754 -- Anything else is incorrect placement
13761 --------------------
13762 -- Locking_Policy --
13763 --------------------
13765 -- pragma Locking_Policy (policy_IDENTIFIER);
13767 when Pragma_Locking_Policy
=> declare
13768 subtype LP_Range
is Name_Id
13769 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
13774 Check_Ada_83_Warning
;
13775 Check_Arg_Count
(1);
13776 Check_No_Identifiers
;
13777 Check_Arg_Is_Locking_Policy
(Arg1
);
13778 Check_Valid_Configuration_Pragma
;
13779 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
13782 when Name_Ceiling_Locking
=>
13784 when Name_Inheritance_Locking
=>
13786 when Name_Concurrent_Readers_Locking
=>
13790 if Locking_Policy
/= ' '
13791 and then Locking_Policy
/= LP
13793 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
13794 Error_Pragma
("locking policy incompatible with policy#");
13796 -- Set new policy, but always preserve System_Location since we
13797 -- like the error message with the run time name.
13800 Locking_Policy
:= LP
;
13802 if Locking_Policy_Sloc
/= System_Location
then
13803 Locking_Policy_Sloc
:= Loc
;
13812 -- pragma Long_Float (D_Float | G_Float);
13814 when Pragma_Long_Float
=> Long_Float : declare
13817 Check_Valid_Configuration_Pragma
;
13818 Check_Arg_Count
(1);
13819 Check_No_Identifier
(Arg1
);
13820 Check_Arg_Is_One_Of
(Arg1
, Name_D_Float
, Name_G_Float
);
13822 if not OpenVMS_On_Target
then
13823 Error_Pragma
("??pragma% ignored (applies only to Open'V'M'S)");
13828 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_D_Float
then
13829 if Opt
.Float_Format_Long
= 'G' then
13831 ("G_Float previously specified", Arg1
);
13833 elsif Current_Sem_Unit
/= Main_Unit
13834 and then Opt
.Float_Format_Long
/= 'D'
13837 ("main unit not compiled with pragma Long_Float (D_Float)",
13838 "\pragma% must be used consistently for whole partition",
13842 Opt
.Float_Format_Long
:= 'D';
13845 -- G_Float case (this is the default, does not need overriding)
13848 if Opt
.Float_Format_Long
= 'D' then
13849 Error_Pragma
("D_Float previously specified");
13851 elsif Current_Sem_Unit
/= Main_Unit
13852 and then Opt
.Float_Format_Long
/= 'G'
13855 ("main unit not compiled with pragma Long_Float (G_Float)",
13856 "\pragma% must be used consistently for whole partition",
13860 Opt
.Float_Format_Long
:= 'G';
13864 Set_Standard_Fpt_Formats
;
13867 -------------------
13868 -- Loop_Optimize --
13869 -------------------
13871 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
13873 -- OPTIMIZATION_HINT ::= No_Unroll | Unroll | No_Vector | Vector
13875 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
13880 Check_At_Least_N_Arguments
(1);
13881 Check_No_Identifiers
;
13883 Hint
:= First
(Pragma_Argument_Associations
(N
));
13884 while Present
(Hint
) loop
13885 Check_Arg_Is_One_Of
(Hint
,
13886 Name_No_Unroll
, Name_Unroll
, Name_No_Vector
, Name_Vector
);
13890 Check_Loop_Pragma_Placement
;
13897 -- pragma Loop_Variant
13898 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
13900 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
13902 -- CHANGE_DIRECTION ::= Increases | Decreases
13904 when Pragma_Loop_Variant
=> Loop_Variant
: declare
13909 Check_At_Least_N_Arguments
(1);
13910 Check_Loop_Pragma_Placement
;
13912 -- Process all increasing / decreasing expressions
13914 Variant
:= First
(Pragma_Argument_Associations
(N
));
13915 while Present
(Variant
) loop
13916 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
13919 Error_Pragma_Arg
("wrong change modifier", Variant
);
13922 Preanalyze_Assert_Expression
13923 (Expression
(Variant
), Any_Discrete
);
13929 -----------------------
13930 -- Machine_Attribute --
13931 -----------------------
13933 -- pragma Machine_Attribute (
13934 -- [Entity =>] LOCAL_NAME,
13935 -- [Attribute_Name =>] static_string_EXPRESSION
13936 -- [, [Info =>] static_EXPRESSION] );
13938 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
13939 Def_Id
: Entity_Id
;
13943 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
13945 if Arg_Count
= 3 then
13946 Check_Optional_Identifier
(Arg3
, Name_Info
);
13947 Check_Arg_Is_Static_Expression
(Arg3
);
13949 Check_Arg_Count
(2);
13952 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13953 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
13954 Check_Arg_Is_Local_Name
(Arg1
);
13955 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
13956 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
13958 if Is_Access_Type
(Def_Id
) then
13959 Def_Id
:= Designated_Type
(Def_Id
);
13962 if Rep_Item_Too_Early
(Def_Id
, N
) then
13966 Def_Id
:= Underlying_Type
(Def_Id
);
13968 -- The only processing required is to link this item on to the
13969 -- list of rep items for the given entity. This is accomplished
13970 -- by the call to Rep_Item_Too_Late (when no error is detected
13971 -- and False is returned).
13973 if Rep_Item_Too_Late
(Def_Id
, N
) then
13976 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
13978 end Machine_Attribute
;
13985 -- (MAIN_OPTION [, MAIN_OPTION]);
13988 -- [STACK_SIZE =>] static_integer_EXPRESSION
13989 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
13990 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
13992 when Pragma_Main
=> Main
: declare
13993 Args
: Args_List
(1 .. 3);
13994 Names
: constant Name_List
(1 .. 3) := (
13996 Name_Task_Stack_Size_Default
,
13997 Name_Time_Slicing_Enabled
);
14003 Gather_Associations
(Names
, Args
);
14005 for J
in 1 .. 2 loop
14006 if Present
(Args
(J
)) then
14007 Check_Arg_Is_Static_Expression
(Args
(J
), Any_Integer
);
14011 if Present
(Args
(3)) then
14012 Check_Arg_Is_Static_Expression
(Args
(3), Standard_Boolean
);
14016 while Present
(Nod
) loop
14017 if Nkind
(Nod
) = N_Pragma
14018 and then Pragma_Name
(Nod
) = Name_Main
14020 Error_Msg_Name_1
:= Pname
;
14021 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
14032 -- pragma Main_Storage
14033 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
14035 -- MAIN_STORAGE_OPTION ::=
14036 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
14037 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
14039 when Pragma_Main_Storage
=> Main_Storage
: declare
14040 Args
: Args_List
(1 .. 2);
14041 Names
: constant Name_List
(1 .. 2) := (
14042 Name_Working_Storage
,
14049 Gather_Associations
(Names
, Args
);
14051 for J
in 1 .. 2 loop
14052 if Present
(Args
(J
)) then
14053 Check_Arg_Is_Static_Expression
(Args
(J
), Any_Integer
);
14057 Check_In_Main_Program
;
14060 while Present
(Nod
) loop
14061 if Nkind
(Nod
) = N_Pragma
14062 and then Pragma_Name
(Nod
) = Name_Main_Storage
14064 Error_Msg_Name_1
:= Pname
;
14065 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
14076 -- pragma Memory_Size (NUMERIC_LITERAL)
14078 when Pragma_Memory_Size
=>
14081 -- Memory size is simply ignored
14083 Check_No_Identifiers
;
14084 Check_Arg_Count
(1);
14085 Check_Arg_Is_Integer_Literal
(Arg1
);
14093 -- The only correct use of this pragma is on its own in a file, in
14094 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
14095 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
14096 -- check for a file containing nothing but a No_Body pragma). If we
14097 -- attempt to process it during normal semantics processing, it means
14098 -- it was misplaced.
14100 when Pragma_No_Body
=>
14108 -- pragma No_Inline ( NAME {, NAME} );
14110 when Pragma_No_Inline
=>
14112 Process_Inline
(Suppressed
);
14118 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
14120 when Pragma_No_Return
=> No_Return
: declare
14128 Check_At_Least_N_Arguments
(1);
14130 -- Loop through arguments of pragma
14133 while Present
(Arg
) loop
14134 Check_Arg_Is_Local_Name
(Arg
);
14135 Id
:= Get_Pragma_Arg
(Arg
);
14138 if not Is_Entity_Name
(Id
) then
14139 Error_Pragma_Arg
("entity name required", Arg
);
14142 if Etype
(Id
) = Any_Type
then
14146 -- Loop to find matching procedures
14151 and then Scope
(E
) = Current_Scope
14153 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
14156 -- Set flag on any alias as well
14158 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
14159 Set_No_Return
(Alias
(E
));
14165 exit when From_Aspect_Specification
(N
);
14170 Error_Pragma_Arg
("no procedure & found for pragma%", Arg
);
14181 -- pragma No_Run_Time;
14183 -- Note: this pragma is retained for backwards compatibility. See
14184 -- body of Rtsfind for full details on its handling.
14186 when Pragma_No_Run_Time
=>
14188 Check_Valid_Configuration_Pragma
;
14189 Check_Arg_Count
(0);
14191 No_Run_Time_Mode
:= True;
14192 Configurable_Run_Time_Mode
:= True;
14194 -- Set Duration to 32 bits if word size is 32
14196 if Ttypes
.System_Word_Size
= 32 then
14197 Duration_32_Bits_On_Target
:= True;
14200 -- Set appropriate restrictions
14202 Set_Restriction
(No_Finalization
, N
);
14203 Set_Restriction
(No_Exception_Handlers
, N
);
14204 Set_Restriction
(Max_Tasks
, N
, 0);
14205 Set_Restriction
(No_Tasking
, N
);
14207 ------------------------
14208 -- No_Strict_Aliasing --
14209 ------------------------
14211 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
14213 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
14218 Check_At_Most_N_Arguments
(1);
14220 if Arg_Count
= 0 then
14221 Check_Valid_Configuration_Pragma
;
14222 Opt
.No_Strict_Aliasing
:= True;
14225 Check_Optional_Identifier
(Arg2
, Name_Entity
);
14226 Check_Arg_Is_Local_Name
(Arg1
);
14227 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14229 if E_Id
= Any_Type
then
14231 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
14232 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
14235 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
14237 end No_Strict_Aliasing
;
14239 -----------------------
14240 -- Normalize_Scalars --
14241 -----------------------
14243 -- pragma Normalize_Scalars;
14245 when Pragma_Normalize_Scalars
=>
14246 Check_Ada_83_Warning
;
14247 Check_Arg_Count
(0);
14248 Check_Valid_Configuration_Pragma
;
14250 -- Normalize_Scalars creates false positives in CodePeer, and
14251 -- incorrect negative results in SPARK mode, so ignore this pragma
14254 if not (CodePeer_Mode
or SPARK_Mode
) then
14255 Normalize_Scalars
:= True;
14256 Init_Or_Norm_Scalars
:= True;
14263 -- pragma Obsolescent;
14265 -- pragma Obsolescent (
14266 -- [Message =>] static_string_EXPRESSION
14267 -- [,[Version =>] Ada_05]]);
14269 -- pragma Obsolescent (
14270 -- [Entity =>] NAME
14271 -- [,[Message =>] static_string_EXPRESSION
14272 -- [,[Version =>] Ada_05]] );
14274 when Pragma_Obsolescent
=> Obsolescent
: declare
14278 procedure Set_Obsolescent
(E
: Entity_Id
);
14279 -- Given an entity Ent, mark it as obsolescent if appropriate
14281 ---------------------
14282 -- Set_Obsolescent --
14283 ---------------------
14285 procedure Set_Obsolescent
(E
: Entity_Id
) is
14294 -- Entity name was given
14296 if Present
(Ename
) then
14298 -- If entity name matches, we are fine. Save entity in
14299 -- pragma argument, for ASIS use.
14301 if Chars
(Ename
) = Chars
(Ent
) then
14302 Set_Entity
(Ename
, Ent
);
14303 Generate_Reference
(Ent
, Ename
);
14305 -- If entity name does not match, only possibility is an
14306 -- enumeration literal from an enumeration type declaration.
14308 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
14310 ("pragma % entity name does not match declaration");
14313 Ent
:= First_Literal
(E
);
14317 ("pragma % entity name does not match any "
14318 & "enumeration literal");
14320 elsif Chars
(Ent
) = Chars
(Ename
) then
14321 Set_Entity
(Ename
, Ent
);
14322 Generate_Reference
(Ent
, Ename
);
14326 Ent
:= Next_Literal
(Ent
);
14332 -- Ent points to entity to be marked
14334 if Arg_Count
>= 1 then
14336 -- Deal with static string argument
14338 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
14339 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
14341 for J
in 1 .. String_Length
(S
) loop
14342 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
14344 ("pragma% argument does not allow wide characters",
14349 Obsolescent_Warnings
.Append
14350 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
14352 -- Check for Ada_05 parameter
14354 if Arg_Count
/= 1 then
14355 Check_Arg_Count
(2);
14358 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
14361 Check_Arg_Is_Identifier
(Argx
);
14363 if Chars
(Argx
) /= Name_Ada_05
then
14364 Error_Msg_Name_2
:= Name_Ada_05
;
14366 ("only allowed argument for pragma% is %", Argx
);
14369 if Ada_Version_Explicit
< Ada_2005
14370 or else not Warn_On_Ada_2005_Compatibility
14378 -- Set flag if pragma active
14381 Set_Is_Obsolescent
(Ent
);
14385 end Set_Obsolescent
;
14387 -- Start of processing for pragma Obsolescent
14392 Check_At_Most_N_Arguments
(3);
14394 -- See if first argument specifies an entity name
14398 (Chars
(Arg1
) = Name_Entity
14400 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
14402 N_Operator_Symbol
))
14404 Ename
:= Get_Pragma_Arg
(Arg1
);
14406 -- Eliminate first argument, so we can share processing
14410 Arg_Count
:= Arg_Count
- 1;
14412 -- No Entity name argument given
14418 if Arg_Count
>= 1 then
14419 Check_Optional_Identifier
(Arg1
, Name_Message
);
14421 if Arg_Count
= 2 then
14422 Check_Optional_Identifier
(Arg2
, Name_Version
);
14426 -- Get immediately preceding declaration
14429 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
14433 -- Cases where we do not follow anything other than another pragma
14437 -- First case: library level compilation unit declaration with
14438 -- the pragma immediately following the declaration.
14440 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
14442 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
14445 -- Case 2: library unit placement for package
14449 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
14451 if Is_Package_Or_Generic_Package
(Ent
) then
14452 Set_Obsolescent
(Ent
);
14458 -- Cases where we must follow a declaration
14461 if Nkind
(Decl
) not in N_Declaration
14462 and then Nkind
(Decl
) not in N_Later_Decl_Item
14463 and then Nkind
(Decl
) not in N_Generic_Declaration
14464 and then Nkind
(Decl
) not in N_Renaming_Declaration
14467 ("pragma% misplaced, "
14468 & "must immediately follow a declaration");
14471 Set_Obsolescent
(Defining_Entity
(Decl
));
14481 -- pragma Optimize (Time | Space | Off);
14483 -- The actual check for optimize is done in Gigi. Note that this
14484 -- pragma does not actually change the optimization setting, it
14485 -- simply checks that it is consistent with the pragma.
14487 when Pragma_Optimize
=>
14488 Check_No_Identifiers
;
14489 Check_Arg_Count
(1);
14490 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
14492 ------------------------
14493 -- Optimize_Alignment --
14494 ------------------------
14496 -- pragma Optimize_Alignment (Time | Space | Off);
14498 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
14500 Check_No_Identifiers
;
14501 Check_Arg_Count
(1);
14502 Check_Valid_Configuration_Pragma
;
14505 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
14509 Opt
.Optimize_Alignment
:= 'T';
14511 Opt
.Optimize_Alignment
:= 'S';
14513 Opt
.Optimize_Alignment
:= 'O';
14515 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
14519 -- Set indication that mode is set locally. If we are in fact in a
14520 -- configuration pragma file, this setting is harmless since the
14521 -- switch will get reset anyway at the start of each unit.
14523 Optimize_Alignment_Local
:= True;
14524 end Optimize_Alignment
;
14530 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
14532 when Pragma_Ordered
=> Ordered
: declare
14533 Assoc
: constant Node_Id
:= Arg1
;
14539 Check_No_Identifiers
;
14540 Check_Arg_Count
(1);
14541 Check_Arg_Is_Local_Name
(Arg1
);
14543 Type_Id
:= Get_Pragma_Arg
(Assoc
);
14544 Find_Type
(Type_Id
);
14545 Typ
:= Entity
(Type_Id
);
14547 if Typ
= Any_Type
then
14550 Typ
:= Underlying_Type
(Typ
);
14553 if not Is_Enumeration_Type
(Typ
) then
14554 Error_Pragma
("pragma% must specify enumeration type");
14557 Check_First_Subtype
(Arg1
);
14558 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
14561 -------------------
14562 -- Overflow_Mode --
14563 -------------------
14565 -- pragma Overflow_Mode
14566 -- ([General => ] MODE [, [Assertions => ] MODE]);
14568 -- MODE := STRICT | MINIMIZED | ELIMINATED
14570 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
14571 -- since System.Bignums makes this assumption. This is true of nearly
14572 -- all (all?) targets.
14574 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
14575 function Get_Overflow_Mode
14577 Arg
: Node_Id
) return Overflow_Mode_Type
;
14578 -- Function to process one pragma argument, Arg. If an identifier
14579 -- is present, it must be Name. Mode type is returned if a valid
14580 -- argument exists, otherwise an error is signalled.
14582 -----------------------
14583 -- Get_Overflow_Mode --
14584 -----------------------
14586 function Get_Overflow_Mode
14588 Arg
: Node_Id
) return Overflow_Mode_Type
14590 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
14593 Check_Optional_Identifier
(Arg
, Name
);
14594 Check_Arg_Is_Identifier
(Argx
);
14596 if Chars
(Argx
) = Name_Strict
then
14599 elsif Chars
(Argx
) = Name_Minimized
then
14602 elsif Chars
(Argx
) = Name_Eliminated
then
14603 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
14605 ("Eliminated not implemented on this target", Argx
);
14611 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
14613 end Get_Overflow_Mode
;
14615 -- Start of processing for Overflow_Mode
14619 Check_At_Least_N_Arguments
(1);
14620 Check_At_Most_N_Arguments
(2);
14622 -- Process first argument
14624 Scope_Suppress
.Overflow_Mode_General
:=
14625 Get_Overflow_Mode
(Name_General
, Arg1
);
14627 -- Case of only one argument
14629 if Arg_Count
= 1 then
14630 Scope_Suppress
.Overflow_Mode_Assertions
:=
14631 Scope_Suppress
.Overflow_Mode_General
;
14633 -- Case of two arguments present
14636 Scope_Suppress
.Overflow_Mode_Assertions
:=
14637 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
14641 --------------------------
14642 -- Overriding Renamings --
14643 --------------------------
14645 -- pragma Overriding_Renamings;
14647 when Pragma_Overriding_Renamings
=>
14649 Check_Arg_Count
(0);
14650 Check_Valid_Configuration_Pragma
;
14651 Overriding_Renamings
:= True;
14657 -- pragma Pack (first_subtype_LOCAL_NAME);
14659 when Pragma_Pack
=> Pack
: declare
14660 Assoc
: constant Node_Id
:= Arg1
;
14664 Ignore
: Boolean := False;
14667 Check_No_Identifiers
;
14668 Check_Arg_Count
(1);
14669 Check_Arg_Is_Local_Name
(Arg1
);
14671 Type_Id
:= Get_Pragma_Arg
(Assoc
);
14672 Find_Type
(Type_Id
);
14673 Typ
:= Entity
(Type_Id
);
14676 or else Rep_Item_Too_Early
(Typ
, N
)
14680 Typ
:= Underlying_Type
(Typ
);
14683 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
14684 Error_Pragma
("pragma% must specify array or record type");
14687 Check_First_Subtype
(Arg1
);
14688 Check_Duplicate_Pragma
(Typ
);
14692 if Is_Array_Type
(Typ
) then
14693 Ctyp
:= Component_Type
(Typ
);
14695 -- Ignore pack that does nothing
14697 if Known_Static_Esize
(Ctyp
)
14698 and then Known_Static_RM_Size
(Ctyp
)
14699 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
14700 and then Addressable
(Esize
(Ctyp
))
14705 -- Process OK pragma Pack. Note that if there is a separate
14706 -- component clause present, the Pack will be cancelled. This
14707 -- processing is in Freeze.
14709 if not Rep_Item_Too_Late
(Typ
, N
) then
14711 -- In the context of static code analysis, we do not need
14712 -- complex front-end expansions related to pragma Pack,
14713 -- so disable handling of pragma Pack in these cases.
14715 if CodePeer_Mode
or SPARK_Mode
then
14718 -- Don't attempt any packing for VM targets. We possibly
14719 -- could deal with some cases of array bit-packing, but we
14720 -- don't bother, since this is not a typical kind of
14721 -- representation in the VM context anyway (and would not
14722 -- for example work nicely with the debugger).
14724 elsif VM_Target
/= No_VM
then
14725 if not GNAT_Mode
then
14727 ("??pragma% ignored in this configuration");
14730 -- Normal case where we do the pack action
14734 Set_Is_Packed
(Base_Type
(Typ
));
14735 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
14738 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
14742 -- For record types, the pack is always effective
14744 else pragma Assert
(Is_Record_Type
(Typ
));
14745 if not Rep_Item_Too_Late
(Typ
, N
) then
14747 -- Ignore pack request with warning in VM mode (skip warning
14748 -- if we are compiling GNAT run time library).
14750 if VM_Target
/= No_VM
then
14751 if not GNAT_Mode
then
14753 ("??pragma% ignored in this configuration");
14756 -- Normal case of pack request active
14759 Set_Is_Packed
(Base_Type
(Typ
));
14760 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
14761 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
14773 -- There is nothing to do here, since we did all the processing for
14774 -- this pragma in Par.Prag (so that it works properly even in syntax
14777 when Pragma_Page
=>
14780 ----------------------------------
14781 -- Partition_Elaboration_Policy --
14782 ----------------------------------
14784 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
14786 when Pragma_Partition_Elaboration_Policy
=> declare
14787 subtype PEP_Range
is Name_Id
14788 range First_Partition_Elaboration_Policy_Name
14789 .. Last_Partition_Elaboration_Policy_Name
;
14790 PEP_Val
: PEP_Range
;
14795 Check_Arg_Count
(1);
14796 Check_No_Identifiers
;
14797 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
14798 Check_Valid_Configuration_Pragma
;
14799 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
14802 when Name_Concurrent
=>
14804 when Name_Sequential
=>
14808 if Partition_Elaboration_Policy
/= ' '
14809 and then Partition_Elaboration_Policy
/= PEP
14811 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
14813 ("partition elaboration policy incompatible with policy#");
14815 -- Set new policy, but always preserve System_Location since we
14816 -- like the error message with the run time name.
14819 Partition_Elaboration_Policy
:= PEP
;
14821 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
14822 Partition_Elaboration_Policy_Sloc
:= Loc
;
14831 -- pragma Passive [(PASSIVE_FORM)];
14833 -- PASSIVE_FORM ::= Semaphore | No
14835 when Pragma_Passive
=>
14838 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
14839 Error_Pragma
("pragma% must be within task definition");
14842 if Arg_Count
/= 0 then
14843 Check_Arg_Count
(1);
14844 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
14847 ----------------------------------
14848 -- Preelaborable_Initialization --
14849 ----------------------------------
14851 -- pragma Preelaborable_Initialization (DIRECT_NAME);
14853 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
14858 Check_Arg_Count
(1);
14859 Check_No_Identifiers
;
14860 Check_Arg_Is_Identifier
(Arg1
);
14861 Check_Arg_Is_Local_Name
(Arg1
);
14862 Check_First_Subtype
(Arg1
);
14863 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14865 -- The pragma may come from an aspect on a private declaration,
14866 -- even if the freeze point at which this is analyzed in the
14867 -- private part after the full view.
14869 if Has_Private_Declaration
(Ent
)
14870 and then From_Aspect_Specification
(N
)
14874 elsif Is_Private_Type
(Ent
)
14875 or else Is_Protected_Type
(Ent
)
14876 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
14882 ("pragma % can only be applied to private, formal derived or "
14883 & "protected type",
14887 -- Give an error if the pragma is applied to a protected type that
14888 -- does not qualify (due to having entries, or due to components
14889 -- that do not qualify).
14891 if Is_Protected_Type
(Ent
)
14892 and then not Has_Preelaborable_Initialization
(Ent
)
14895 ("protected type & does not have preelaborable "
14896 & "initialization", Ent
);
14898 -- Otherwise mark the type as definitely having preelaborable
14902 Set_Known_To_Have_Preelab_Init
(Ent
);
14905 if Has_Pragma_Preelab_Init
(Ent
)
14906 and then Warn_On_Redundant_Constructs
14908 Error_Pragma
("?r?duplicate pragma%!");
14910 Set_Has_Pragma_Preelab_Init
(Ent
);
14914 --------------------
14915 -- Persistent_BSS --
14916 --------------------
14918 -- pragma Persistent_BSS [(object_NAME)];
14920 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
14927 Check_At_Most_N_Arguments
(1);
14929 -- Case of application to specific object (one argument)
14931 if Arg_Count
= 1 then
14932 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
14934 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
14936 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
14939 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
14942 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14943 Decl
:= Parent
(Ent
);
14945 -- Check for duplication before inserting in list of
14946 -- representation items.
14948 Check_Duplicate_Pragma
(Ent
);
14950 if Rep_Item_Too_Late
(Ent
, N
) then
14954 if Present
(Expression
(Decl
)) then
14956 ("object for pragma% cannot have initialization", Arg1
);
14959 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
14961 ("object type for pragma% is not potentially persistent",
14966 Make_Linker_Section_Pragma
14967 (Ent
, Sloc
(N
), ".persistent.bss");
14968 Insert_After
(N
, Prag
);
14971 -- Case of use as configuration pragma with no arguments
14974 Check_Valid_Configuration_Pragma
;
14975 Persistent_BSS_Mode
:= True;
14977 end Persistent_BSS
;
14983 -- pragma Polling (ON | OFF);
14985 when Pragma_Polling
=>
14987 Check_Arg_Count
(1);
14988 Check_No_Identifiers
;
14989 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
14990 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
14992 -------------------
14993 -- Postcondition --
14994 -------------------
14996 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
14997 -- [,[Message =>] String_EXPRESSION]);
14999 when Pragma_Postcondition
=> Postcondition
: declare
15004 Check_At_Least_N_Arguments
(1);
15005 Check_At_Most_N_Arguments
(2);
15006 Check_Optional_Identifier
(Arg1
, Name_Check
);
15008 -- Verify the proper placement of the pragma. The remainder of the
15009 -- processing is found in Sem_Ch6/Sem_Ch7.
15011 Check_Precondition_Postcondition
(In_Body
);
15013 -- When the pragma is a source construct appearing inside a body,
15014 -- preanalyze the boolean_expression to detect illegal forward
15018 -- pragma Postcondition (X'Old ...);
15021 if Comes_From_Source
(N
) and then In_Body
then
15022 Preanalyze_Spec_Expression
(Expression
(Arg1
), Any_Boolean
);
15030 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
15031 -- [,[Message =>] String_EXPRESSION]);
15033 when Pragma_Precondition
=> Precondition
: declare
15038 Check_At_Least_N_Arguments
(1);
15039 Check_At_Most_N_Arguments
(2);
15040 Check_Optional_Identifier
(Arg1
, Name_Check
);
15041 Check_Precondition_Postcondition
(In_Body
);
15043 -- If in spec, nothing more to do. If in body, then we convert the
15044 -- pragma to an equivalent pragam Check. Note we do this whether
15045 -- or not precondition checks are enabled. That works fine since
15046 -- pragma Check will do this check, and will also analyze the
15047 -- condition itself in the proper context.
15049 -- The form of the pragma Check is either:
15051 -- pragma Check (Precondition, cond [, msg])
15053 -- pragma Check (Pre, cond [, msg])
15055 -- We use the Pre form if this pragma derived from a Pre aspect.
15056 -- This is needed to make sure that the right set of Policy
15057 -- pragmas are checked.
15062 Chars
=> Name_Check
,
15063 Pragma_Argument_Associations
=> New_List
(
15064 Make_Pragma_Argument_Association
(Loc
,
15065 Expression
=> Make_Identifier
(Loc
, Pname
)),
15067 Make_Pragma_Argument_Association
(Sloc
(Arg1
),
15068 Expression
=> Relocate_Node
(Get_Pragma_Arg
(Arg1
))))));
15070 if Arg_Count
= 2 then
15071 Append_To
(Pragma_Argument_Associations
(N
),
15072 Make_Pragma_Argument_Association
(Sloc
(Arg2
),
15073 Expression
=> Relocate_Node
(Get_Pragma_Arg
(Arg2
))));
15084 -- pragma Predicate
15085 -- ([Entity =>] type_LOCAL_NAME,
15086 -- [Check =>] boolean_EXPRESSION);
15088 when Pragma_Predicate
=> Predicate
: declare
15093 pragma Unreferenced
(Discard
);
15097 Check_Arg_Count
(2);
15098 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15099 Check_Optional_Identifier
(Arg2
, Name_Check
);
15101 Check_Arg_Is_Local_Name
(Arg1
);
15103 Type_Id
:= Get_Pragma_Arg
(Arg1
);
15104 Find_Type
(Type_Id
);
15105 Typ
:= Entity
(Type_Id
);
15107 if Typ
= Any_Type
then
15111 -- The remaining processing is simply to link the pragma on to
15112 -- the rep item chain, for processing when the type is frozen.
15113 -- This is accomplished by a call to Rep_Item_Too_Late. We also
15114 -- mark the type as having predicates.
15116 Set_Has_Predicates
(Typ
);
15117 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15124 -- pragma Preelaborate [(library_unit_NAME)];
15126 -- Set the flag Is_Preelaborated of program unit name entity
15128 when Pragma_Preelaborate
=> Preelaborate
: declare
15129 Pa
: constant Node_Id
:= Parent
(N
);
15130 Pk
: constant Node_Kind
:= Nkind
(Pa
);
15134 Check_Ada_83_Warning
;
15135 Check_Valid_Library_Unit_Pragma
;
15137 if Nkind
(N
) = N_Null_Statement
then
15141 Ent
:= Find_Lib_Unit_Name
;
15142 Check_Duplicate_Pragma
(Ent
);
15144 -- This filters out pragmas inside generic parent then
15145 -- show up inside instantiation
15148 and then not (Pk
= N_Package_Specification
15149 and then Present
(Generic_Parent
(Pa
)))
15151 if not Debug_Flag_U
then
15152 Set_Is_Preelaborated
(Ent
);
15153 Set_Suppress_Elaboration_Warnings
(Ent
);
15158 ---------------------
15159 -- Preelaborate_05 --
15160 ---------------------
15162 -- pragma Preelaborate_05 [(library_unit_NAME)];
15164 -- This pragma is useable only in GNAT_Mode, where it is used like
15165 -- pragma Preelaborate but it is only effective in Ada 2005 mode
15166 -- (otherwise it is ignored). This is used to implement AI-362 which
15167 -- recategorizes some run-time packages in Ada 2005 mode.
15169 when Pragma_Preelaborate_05
=> Preelaborate_05
: declare
15174 Check_Valid_Library_Unit_Pragma
;
15176 if not GNAT_Mode
then
15177 Error_Pragma
("pragma% only available in GNAT mode");
15180 if Nkind
(N
) = N_Null_Statement
then
15184 -- This is one of the few cases where we need to test the value of
15185 -- Ada_Version_Explicit rather than Ada_Version (which is always
15186 -- set to Ada_2012 in a predefined unit), we need to know the
15187 -- explicit version set to know if this pragma is active.
15189 if Ada_Version_Explicit
>= Ada_2005
then
15190 Ent
:= Find_Lib_Unit_Name
;
15191 Set_Is_Preelaborated
(Ent
);
15192 Set_Suppress_Elaboration_Warnings
(Ent
);
15194 end Preelaborate_05
;
15200 -- pragma Priority (EXPRESSION);
15202 when Pragma_Priority
=> Priority
: declare
15203 P
: constant Node_Id
:= Parent
(N
);
15208 Check_No_Identifiers
;
15209 Check_Arg_Count
(1);
15213 if Nkind
(P
) = N_Subprogram_Body
then
15214 Check_In_Main_Program
;
15216 Ent
:= Defining_Unit_Name
(Specification
(P
));
15218 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
15219 Ent
:= Defining_Identifier
(Ent
);
15222 Arg
:= Get_Pragma_Arg
(Arg1
);
15223 Analyze_And_Resolve
(Arg
, Standard_Integer
);
15227 if not Is_Static_Expression
(Arg
) then
15228 Flag_Non_Static_Expr
15229 ("main subprogram priority is not static!", Arg
);
15232 -- If constraint error, then we already signalled an error
15234 elsif Raises_Constraint_Error
(Arg
) then
15237 -- Otherwise check in range
15241 Val
: constant Uint
:= Expr_Value
(Arg
);
15245 or else Val
> Expr_Value
(Expression
15246 (Parent
(RTE
(RE_Max_Priority
))))
15249 ("main subprogram priority is out of range", Arg1
);
15255 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
15257 -- Load an arbitrary entity from System.Tasking to make sure
15258 -- this package is implicitly with'ed, since we need to have
15259 -- the tasking run-time active for the pragma Priority to have
15263 Discard
: Entity_Id
;
15264 pragma Warnings
(Off
, Discard
);
15266 Discard
:= RTE
(RE_Task_List
);
15269 -- Task or Protected, must be of type Integer
15271 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
15272 Arg
:= Get_Pragma_Arg
(Arg1
);
15273 Ent
:= Defining_Identifier
(Parent
(P
));
15275 -- The expression must be analyzed in the special manner
15276 -- described in "Handling of Default and Per-Object
15277 -- Expressions" in sem.ads.
15279 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
15281 if not Is_Static_Expression
(Arg
) then
15282 Check_Restriction
(Static_Priorities
, Arg
);
15285 -- Anything else is incorrect
15291 -- Check duplicate pragma before we chain the pragma in the Rep
15292 -- Item chain of Ent.
15294 Check_Duplicate_Pragma
(Ent
);
15295 Record_Rep_Item
(Ent
, N
);
15298 -----------------------------------
15299 -- Priority_Specific_Dispatching --
15300 -----------------------------------
15302 -- pragma Priority_Specific_Dispatching (
15303 -- policy_IDENTIFIER,
15304 -- first_priority_EXPRESSION,
15305 -- last_priority_EXPRESSION);
15307 when Pragma_Priority_Specific_Dispatching
=>
15308 Priority_Specific_Dispatching
: declare
15309 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
15310 -- This is the entity System.Any_Priority;
15313 Lower_Bound
: Node_Id
;
15314 Upper_Bound
: Node_Id
;
15320 Check_Arg_Count
(3);
15321 Check_No_Identifiers
;
15322 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
15323 Check_Valid_Configuration_Pragma
;
15324 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15325 DP
:= Fold_Upper
(Name_Buffer
(1));
15327 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
15328 Check_Arg_Is_Static_Expression
(Lower_Bound
, Standard_Integer
);
15329 Lower_Val
:= Expr_Value
(Lower_Bound
);
15331 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
15332 Check_Arg_Is_Static_Expression
(Upper_Bound
, Standard_Integer
);
15333 Upper_Val
:= Expr_Value
(Upper_Bound
);
15335 -- It is not allowed to use Task_Dispatching_Policy and
15336 -- Priority_Specific_Dispatching in the same partition.
15338 if Task_Dispatching_Policy
/= ' ' then
15339 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
15341 ("pragma% incompatible with Task_Dispatching_Policy#");
15343 -- Check lower bound in range
15345 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
15347 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
15350 ("first_priority is out of range", Arg2
);
15352 -- Check upper bound in range
15354 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
15356 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
15359 ("last_priority is out of range", Arg3
);
15361 -- Check that the priority range is valid
15363 elsif Lower_Val
> Upper_Val
then
15365 ("last_priority_expression must be greater than or equal to "
15366 & "first_priority_expression");
15368 -- Store the new policy, but always preserve System_Location since
15369 -- we like the error message with the run-time name.
15372 -- Check overlapping in the priority ranges specified in other
15373 -- Priority_Specific_Dispatching pragmas within the same
15374 -- partition. We can only check those we know about!
15377 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
15379 if Specific_Dispatching
.Table
(J
).First_Priority
in
15380 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
15381 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
15382 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
15385 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
15387 ("priority range overlaps with "
15388 & "Priority_Specific_Dispatching#");
15392 -- The use of Priority_Specific_Dispatching is incompatible
15393 -- with Task_Dispatching_Policy.
15395 if Task_Dispatching_Policy
/= ' ' then
15396 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
15398 ("Priority_Specific_Dispatching incompatible "
15399 & "with Task_Dispatching_Policy#");
15402 -- The use of Priority_Specific_Dispatching forces ceiling
15405 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
15406 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
15408 ("Priority_Specific_Dispatching incompatible "
15409 & "with Locking_Policy#");
15411 -- Set the Ceiling_Locking policy, but preserve System_Location
15412 -- since we like the error message with the run time name.
15415 Locking_Policy
:= 'C';
15417 if Locking_Policy_Sloc
/= System_Location
then
15418 Locking_Policy_Sloc
:= Loc
;
15422 -- Add entry in the table
15424 Specific_Dispatching
.Append
15425 ((Dispatching_Policy
=> DP
,
15426 First_Priority
=> UI_To_Int
(Lower_Val
),
15427 Last_Priority
=> UI_To_Int
(Upper_Val
),
15428 Pragma_Loc
=> Loc
));
15430 end Priority_Specific_Dispatching
;
15436 -- pragma Profile (profile_IDENTIFIER);
15438 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
15440 when Pragma_Profile
=>
15442 Check_Arg_Count
(1);
15443 Check_Valid_Configuration_Pragma
;
15444 Check_No_Identifiers
;
15447 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15450 if Chars
(Argx
) = Name_Ravenscar
then
15451 Set_Ravenscar_Profile
(N
);
15453 elsif Chars
(Argx
) = Name_Restricted
then
15454 Set_Profile_Restrictions
15456 N
, Warn
=> Treat_Restrictions_As_Warnings
);
15458 elsif Chars
(Argx
) = Name_Rational
then
15459 Set_Rational_Profile
;
15461 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
15462 Set_Profile_Restrictions
15463 (No_Implementation_Extensions
,
15464 N
, Warn
=> Treat_Restrictions_As_Warnings
);
15467 Error_Pragma_Arg
("& is not a valid profile", Argx
);
15471 ----------------------
15472 -- Profile_Warnings --
15473 ----------------------
15475 -- pragma Profile_Warnings (profile_IDENTIFIER);
15477 -- profile_IDENTIFIER => Restricted | Ravenscar
15479 when Pragma_Profile_Warnings
=>
15481 Check_Arg_Count
(1);
15482 Check_Valid_Configuration_Pragma
;
15483 Check_No_Identifiers
;
15486 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15489 if Chars
(Argx
) = Name_Ravenscar
then
15490 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
15492 elsif Chars
(Argx
) = Name_Restricted
then
15493 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
15495 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
15496 Set_Profile_Restrictions
15497 (No_Implementation_Extensions
, N
, Warn
=> True);
15500 Error_Pragma_Arg
("& is not a valid profile", Argx
);
15504 --------------------------
15505 -- Propagate_Exceptions --
15506 --------------------------
15508 -- pragma Propagate_Exceptions;
15510 -- Note: this pragma is obsolete and has no effect
15512 when Pragma_Propagate_Exceptions
=>
15514 Check_Arg_Count
(0);
15516 if Warn_On_Obsolescent_Feature
then
15518 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
15519 "and has no effect?j?", N
);
15526 -- pragma Psect_Object (
15527 -- [Internal =>] LOCAL_NAME,
15528 -- [, [External =>] EXTERNAL_SYMBOL]
15529 -- [, [Size =>] EXTERNAL_SYMBOL]);
15531 when Pragma_Psect_Object | Pragma_Common_Object
=>
15532 Psect_Object
: declare
15533 Args
: Args_List
(1 .. 3);
15534 Names
: constant Name_List
(1 .. 3) := (
15539 Internal
: Node_Id
renames Args
(1);
15540 External
: Node_Id
renames Args
(2);
15541 Size
: Node_Id
renames Args
(3);
15543 Def_Id
: Entity_Id
;
15545 procedure Check_Too_Long
(Arg
: Node_Id
);
15546 -- Posts message if the argument is an identifier with more
15547 -- than 31 characters, or a string literal with more than
15548 -- 31 characters, and we are operating under VMS
15550 --------------------
15551 -- Check_Too_Long --
15552 --------------------
15554 procedure Check_Too_Long
(Arg
: Node_Id
) is
15555 X
: constant Node_Id
:= Original_Node
(Arg
);
15558 if not Nkind_In
(X
, N_String_Literal
, N_Identifier
) then
15560 ("inappropriate argument for pragma %", Arg
);
15563 if OpenVMS_On_Target
then
15564 if (Nkind
(X
) = N_String_Literal
15565 and then String_Length
(Strval
(X
)) > 31)
15567 (Nkind
(X
) = N_Identifier
15568 and then Length_Of_Name
(Chars
(X
)) > 31)
15571 ("argument for pragma % is longer than 31 characters",
15575 end Check_Too_Long
;
15577 -- Start of processing for Common_Object/Psect_Object
15581 Gather_Associations
(Names
, Args
);
15582 Process_Extended_Import_Export_Internal_Arg
(Internal
);
15584 Def_Id
:= Entity
(Internal
);
15586 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
15588 ("pragma% must designate an object", Internal
);
15591 Check_Too_Long
(Internal
);
15593 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
15595 ("cannot use pragma% for imported/exported object",
15599 if Is_Concurrent_Type
(Etype
(Internal
)) then
15601 ("cannot specify pragma % for task/protected object",
15605 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
15607 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
15609 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
15612 if Ekind
(Def_Id
) = E_Constant
then
15614 ("cannot specify pragma % for a constant", Internal
);
15617 if Is_Record_Type
(Etype
(Internal
)) then
15623 Ent
:= First_Entity
(Etype
(Internal
));
15624 while Present
(Ent
) loop
15625 Decl
:= Declaration_Node
(Ent
);
15627 if Ekind
(Ent
) = E_Component
15628 and then Nkind
(Decl
) = N_Component_Declaration
15629 and then Present
(Expression
(Decl
))
15630 and then Warn_On_Export_Import
15633 ("?x?object for pragma % has defaults", Internal
);
15643 if Present
(Size
) then
15644 Check_Too_Long
(Size
);
15647 if Present
(External
) then
15648 Check_Arg_Is_External_Name
(External
);
15649 Check_Too_Long
(External
);
15652 -- If all error tests pass, link pragma on to the rep item chain
15654 Record_Rep_Item
(Def_Id
, N
);
15661 -- pragma Pure [(library_unit_NAME)];
15663 when Pragma_Pure
=> Pure
: declare
15667 Check_Ada_83_Warning
;
15668 Check_Valid_Library_Unit_Pragma
;
15670 if Nkind
(N
) = N_Null_Statement
then
15674 Ent
:= Find_Lib_Unit_Name
;
15676 Set_Has_Pragma_Pure
(Ent
);
15677 Set_Suppress_Elaboration_Warnings
(Ent
);
15684 -- pragma Pure_05 [(library_unit_NAME)];
15686 -- This pragma is useable only in GNAT_Mode, where it is used like
15687 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
15688 -- it is ignored). It may be used after a pragma Preelaborate, in
15689 -- which case it overrides the effect of the pragma Preelaborate.
15690 -- This is used to implement AI-362 which recategorizes some run-time
15691 -- packages in Ada 2005 mode.
15693 when Pragma_Pure_05
=> Pure_05
: declare
15698 Check_Valid_Library_Unit_Pragma
;
15700 if not GNAT_Mode
then
15701 Error_Pragma
("pragma% only available in GNAT mode");
15704 if Nkind
(N
) = N_Null_Statement
then
15708 -- This is one of the few cases where we need to test the value of
15709 -- Ada_Version_Explicit rather than Ada_Version (which is always
15710 -- set to Ada_2012 in a predefined unit), we need to know the
15711 -- explicit version set to know if this pragma is active.
15713 if Ada_Version_Explicit
>= Ada_2005
then
15714 Ent
:= Find_Lib_Unit_Name
;
15715 Set_Is_Preelaborated
(Ent
, False);
15717 Set_Suppress_Elaboration_Warnings
(Ent
);
15725 -- pragma Pure_12 [(library_unit_NAME)];
15727 -- This pragma is useable only in GNAT_Mode, where it is used like
15728 -- pragma Pure but it is only effective in Ada 2012 mode (otherwise
15729 -- it is ignored). It may be used after a pragma Preelaborate, in
15730 -- which case it overrides the effect of the pragma Preelaborate.
15731 -- This is used to implement AI05-0212 which recategorizes some
15732 -- run-time packages in Ada 2012 mode.
15734 when Pragma_Pure_12
=> Pure_12
: declare
15739 Check_Valid_Library_Unit_Pragma
;
15741 if not GNAT_Mode
then
15742 Error_Pragma
("pragma% only available in GNAT mode");
15745 if Nkind
(N
) = N_Null_Statement
then
15749 -- This is one of the few cases where we need to test the value of
15750 -- Ada_Version_Explicit rather than Ada_Version (which is always
15751 -- set to Ada_2012 in a predefined unit), we need to know the
15752 -- explicit version set to know if this pragma is active.
15754 if Ada_Version_Explicit
>= Ada_2012
then
15755 Ent
:= Find_Lib_Unit_Name
;
15756 Set_Is_Preelaborated
(Ent
, False);
15758 Set_Suppress_Elaboration_Warnings
(Ent
);
15762 -------------------
15763 -- Pure_Function --
15764 -------------------
15766 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
15768 when Pragma_Pure_Function
=> Pure_Function
: declare
15771 Def_Id
: Entity_Id
;
15772 Effective
: Boolean := False;
15776 Check_Arg_Count
(1);
15777 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15778 Check_Arg_Is_Local_Name
(Arg1
);
15779 E_Id
:= Get_Pragma_Arg
(Arg1
);
15781 if Error_Posted
(E_Id
) then
15785 -- Loop through homonyms (overloadings) of referenced entity
15787 E
:= Entity
(E_Id
);
15789 if Present
(E
) then
15791 Def_Id
:= Get_Base_Subprogram
(E
);
15793 if not Ekind_In
(Def_Id
, E_Function
,
15794 E_Generic_Function
,
15798 ("pragma% requires a function name", Arg1
);
15801 Set_Is_Pure
(Def_Id
);
15803 if not Has_Pragma_Pure_Function
(Def_Id
) then
15804 Set_Has_Pragma_Pure_Function
(Def_Id
);
15808 exit when From_Aspect_Specification
(N
);
15810 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
15814 and then Warn_On_Redundant_Constructs
15817 ("pragma Pure_Function on& is redundant?r?",
15823 --------------------
15824 -- Queuing_Policy --
15825 --------------------
15827 -- pragma Queuing_Policy (policy_IDENTIFIER);
15829 when Pragma_Queuing_Policy
=> declare
15833 Check_Ada_83_Warning
;
15834 Check_Arg_Count
(1);
15835 Check_No_Identifiers
;
15836 Check_Arg_Is_Queuing_Policy
(Arg1
);
15837 Check_Valid_Configuration_Pragma
;
15838 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15839 QP
:= Fold_Upper
(Name_Buffer
(1));
15841 if Queuing_Policy
/= ' '
15842 and then Queuing_Policy
/= QP
15844 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
15845 Error_Pragma
("queuing policy incompatible with policy#");
15847 -- Set new policy, but always preserve System_Location since we
15848 -- like the error message with the run time name.
15851 Queuing_Policy
:= QP
;
15853 if Queuing_Policy_Sloc
/= System_Location
then
15854 Queuing_Policy_Sloc
:= Loc
;
15863 -- pragma Rational, for compatibility with foreign compiler
15865 when Pragma_Rational
=>
15866 Set_Rational_Profile
;
15868 -----------------------
15869 -- Relative_Deadline --
15870 -----------------------
15872 -- pragma Relative_Deadline (time_span_EXPRESSION);
15874 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
15875 P
: constant Node_Id
:= Parent
(N
);
15880 Check_No_Identifiers
;
15881 Check_Arg_Count
(1);
15883 Arg
:= Get_Pragma_Arg
(Arg1
);
15885 -- The expression must be analyzed in the special manner described
15886 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15888 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
15892 if Nkind
(P
) = N_Subprogram_Body
then
15893 Check_In_Main_Program
;
15895 -- Only Task and subprogram cases allowed
15897 elsif Nkind
(P
) /= N_Task_Definition
then
15901 -- Check duplicate pragma before we set the corresponding flag
15903 if Has_Relative_Deadline_Pragma
(P
) then
15904 Error_Pragma
("duplicate pragma% not allowed");
15907 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
15908 -- Relative_Deadline pragma node cannot be inserted in the Rep
15909 -- Item chain of Ent since it is rewritten by the expander as a
15910 -- procedure call statement that will break the chain.
15912 Set_Has_Relative_Deadline_Pragma
(P
, True);
15913 end Relative_Deadline
;
15915 ------------------------
15916 -- Remote_Access_Type --
15917 ------------------------
15919 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
15921 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
15926 Check_Arg_Count
(1);
15927 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15928 Check_Arg_Is_Local_Name
(Arg1
);
15930 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
15932 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
15933 and then Ekind
(E
) = E_General_Access_Type
15934 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
15935 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
15937 and then Is_Valid_Remote_Object_Type
15938 (Root_Type
(Directly_Designated_Type
(E
)))
15940 Set_Is_Remote_Types
(E
);
15944 ("pragma% applies only to formal access to classwide types",
15947 end Remote_Access_Type
;
15949 ---------------------------
15950 -- Remote_Call_Interface --
15951 ---------------------------
15953 -- pragma Remote_Call_Interface [(library_unit_NAME)];
15955 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
15956 Cunit_Node
: Node_Id
;
15957 Cunit_Ent
: Entity_Id
;
15961 Check_Ada_83_Warning
;
15962 Check_Valid_Library_Unit_Pragma
;
15964 if Nkind
(N
) = N_Null_Statement
then
15968 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
15969 K
:= Nkind
(Unit
(Cunit_Node
));
15970 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
15972 if K
= N_Package_Declaration
15973 or else K
= N_Generic_Package_Declaration
15974 or else K
= N_Subprogram_Declaration
15975 or else K
= N_Generic_Subprogram_Declaration
15976 or else (K
= N_Subprogram_Body
15977 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
15982 "pragma% must apply to package or subprogram declaration");
15985 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
15986 end Remote_Call_Interface
;
15992 -- pragma Remote_Types [(library_unit_NAME)];
15994 when Pragma_Remote_Types
=> Remote_Types
: declare
15995 Cunit_Node
: Node_Id
;
15996 Cunit_Ent
: Entity_Id
;
15999 Check_Ada_83_Warning
;
16000 Check_Valid_Library_Unit_Pragma
;
16002 if Nkind
(N
) = N_Null_Statement
then
16006 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
16007 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
16009 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
16010 N_Generic_Package_Declaration
)
16013 ("pragma% can only apply to a package declaration");
16016 Set_Is_Remote_Types
(Cunit_Ent
);
16023 -- pragma Ravenscar;
16025 when Pragma_Ravenscar
=>
16027 Check_Arg_Count
(0);
16028 Check_Valid_Configuration_Pragma
;
16029 Set_Ravenscar_Profile
(N
);
16031 if Warn_On_Obsolescent_Feature
then
16033 ("pragma Ravenscar is an obsolescent feature?j?", N
);
16035 ("|use pragma Profile (Ravenscar) instead?j?", N
);
16038 -------------------------
16039 -- Restricted_Run_Time --
16040 -------------------------
16042 -- pragma Restricted_Run_Time;
16044 when Pragma_Restricted_Run_Time
=>
16046 Check_Arg_Count
(0);
16047 Check_Valid_Configuration_Pragma
;
16048 Set_Profile_Restrictions
16049 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
16051 if Warn_On_Obsolescent_Feature
then
16053 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
16056 ("|use pragma Profile (Restricted) instead?j?", N
);
16063 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
16066 -- restriction_IDENTIFIER
16067 -- | restriction_parameter_IDENTIFIER => EXPRESSION
16069 when Pragma_Restrictions
=>
16070 Process_Restrictions_Or_Restriction_Warnings
16071 (Warn
=> Treat_Restrictions_As_Warnings
);
16073 --------------------------
16074 -- Restriction_Warnings --
16075 --------------------------
16077 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
16080 -- restriction_IDENTIFIER
16081 -- | restriction_parameter_IDENTIFIER => EXPRESSION
16083 when Pragma_Restriction_Warnings
=>
16085 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
16091 -- pragma Reviewable;
16093 when Pragma_Reviewable
=>
16094 Check_Ada_83_Warning
;
16095 Check_Arg_Count
(0);
16097 -- Call dummy debugging function rv. This is done to assist front
16098 -- end debugging. By placing a Reviewable pragma in the source
16099 -- program, a breakpoint on rv catches this place in the source,
16100 -- allowing convenient stepping to the point of interest.
16104 --------------------------
16105 -- Short_Circuit_And_Or --
16106 --------------------------
16108 -- pragma Short_Circuit_And_Or;
16110 when Pragma_Short_Circuit_And_Or
=>
16112 Check_Arg_Count
(0);
16113 Check_Valid_Configuration_Pragma
;
16114 Short_Circuit_And_Or
:= True;
16116 -------------------
16117 -- Share_Generic --
16118 -------------------
16120 -- pragma Share_Generic (GNAME {, GNAME});
16122 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
16124 when Pragma_Share_Generic
=>
16126 Process_Generic_List
;
16132 -- pragma Shared (LOCAL_NAME);
16134 when Pragma_Shared
=>
16136 Process_Atomic_Shared_Volatile
;
16138 --------------------
16139 -- Shared_Passive --
16140 --------------------
16142 -- pragma Shared_Passive [(library_unit_NAME)];
16144 -- Set the flag Is_Shared_Passive of program unit name entity
16146 when Pragma_Shared_Passive
=> Shared_Passive
: declare
16147 Cunit_Node
: Node_Id
;
16148 Cunit_Ent
: Entity_Id
;
16151 Check_Ada_83_Warning
;
16152 Check_Valid_Library_Unit_Pragma
;
16154 if Nkind
(N
) = N_Null_Statement
then
16158 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
16159 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
16161 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
16162 N_Generic_Package_Declaration
)
16165 ("pragma% can only apply to a package declaration");
16168 Set_Is_Shared_Passive
(Cunit_Ent
);
16169 end Shared_Passive
;
16171 -----------------------
16172 -- Short_Descriptors --
16173 -----------------------
16175 -- pragma Short_Descriptors;
16177 when Pragma_Short_Descriptors
=>
16179 Check_Arg_Count
(0);
16180 Check_Valid_Configuration_Pragma
;
16181 Short_Descriptors
:= True;
16183 ------------------------------
16184 -- Simple_Storage_Pool_Type --
16185 ------------------------------
16187 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
16189 when Pragma_Simple_Storage_Pool_Type
=>
16190 Simple_Storage_Pool_Type
: declare
16196 Check_Arg_Count
(1);
16197 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16199 Type_Id
:= Get_Pragma_Arg
(Arg1
);
16200 Find_Type
(Type_Id
);
16201 Typ
:= Entity
(Type_Id
);
16203 if Typ
= Any_Type
then
16207 -- We require the pragma to apply to a type declared in a package
16208 -- declaration, but not (immediately) within a package body.
16210 if Ekind
(Current_Scope
) /= E_Package
16211 or else In_Package_Body
(Current_Scope
)
16214 ("pragma% can only apply to type declared immediately "
16215 & "within a package declaration");
16218 -- A simple storage pool type must be an immutably limited record
16219 -- or private type. If the pragma is given for a private type,
16220 -- the full type is similarly restricted (which is checked later
16221 -- in Freeze_Entity).
16223 if Is_Record_Type
(Typ
)
16224 and then not Is_Immutably_Limited_Type
(Typ
)
16227 ("pragma% can only apply to explicitly limited record type");
16229 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
16231 ("pragma% can only apply to a private type that is limited");
16233 elsif not Is_Record_Type
(Typ
)
16234 and then not Is_Private_Type
(Typ
)
16237 ("pragma% can only apply to limited record or private type");
16240 Record_Rep_Item
(Typ
, N
);
16241 end Simple_Storage_Pool_Type
;
16243 ----------------------
16244 -- Source_File_Name --
16245 ----------------------
16247 -- There are five forms for this pragma:
16249 -- pragma Source_File_Name (
16250 -- [UNIT_NAME =>] unit_NAME,
16251 -- BODY_FILE_NAME => STRING_LITERAL
16252 -- [, [INDEX =>] INTEGER_LITERAL]);
16254 -- pragma Source_File_Name (
16255 -- [UNIT_NAME =>] unit_NAME,
16256 -- SPEC_FILE_NAME => STRING_LITERAL
16257 -- [, [INDEX =>] INTEGER_LITERAL]);
16259 -- pragma Source_File_Name (
16260 -- BODY_FILE_NAME => STRING_LITERAL
16261 -- [, DOT_REPLACEMENT => STRING_LITERAL]
16262 -- [, CASING => CASING_SPEC]);
16264 -- pragma Source_File_Name (
16265 -- SPEC_FILE_NAME => STRING_LITERAL
16266 -- [, DOT_REPLACEMENT => STRING_LITERAL]
16267 -- [, CASING => CASING_SPEC]);
16269 -- pragma Source_File_Name (
16270 -- SUBUNIT_FILE_NAME => STRING_LITERAL
16271 -- [, DOT_REPLACEMENT => STRING_LITERAL]
16272 -- [, CASING => CASING_SPEC]);
16274 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
16276 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
16277 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
16278 -- only be used when no project file is used, while SFNP can only be
16279 -- used when a project file is used.
16281 -- No processing here. Processing was completed during parsing, since
16282 -- we need to have file names set as early as possible. Units are
16283 -- loaded well before semantic processing starts.
16285 -- The only processing we defer to this point is the check for
16286 -- correct placement.
16288 when Pragma_Source_File_Name
=>
16290 Check_Valid_Configuration_Pragma
;
16292 ------------------------------
16293 -- Source_File_Name_Project --
16294 ------------------------------
16296 -- See Source_File_Name for syntax
16298 -- No processing here. Processing was completed during parsing, since
16299 -- we need to have file names set as early as possible. Units are
16300 -- loaded well before semantic processing starts.
16302 -- The only processing we defer to this point is the check for
16303 -- correct placement.
16305 when Pragma_Source_File_Name_Project
=>
16307 Check_Valid_Configuration_Pragma
;
16309 -- Check that a pragma Source_File_Name_Project is used only in a
16310 -- configuration pragmas file.
16312 -- Pragmas Source_File_Name_Project should only be generated by
16313 -- the Project Manager in configuration pragmas files.
16315 -- This is really an ugly test. It seems to depend on some
16316 -- accidental and undocumented property. At the very least it
16317 -- needs to be documented, but it would be better to have a
16318 -- clean way of testing if we are in a configuration file???
16320 if Present
(Parent
(N
)) then
16322 ("pragma% can only appear in a configuration pragmas file");
16325 ----------------------
16326 -- Source_Reference --
16327 ----------------------
16329 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
16331 -- Nothing to do, all processing completed in Par.Prag, since we need
16332 -- the information for possible parser messages that are output.
16334 when Pragma_Source_Reference
=>
16341 -- pragma SPARK_Mode (On | Off | Auto);
16343 when Pragma_SPARK_Mode
=> SPARK_Mod
: declare
16344 procedure Chain_Pragma
(Context
: Entity_Id
; Prag
: Node_Id
);
16345 -- Associate a SPARK_Mode pragma with the context where it lives.
16346 -- If the context is a package spec or a body, the routine checks
16347 -- the consistency between modes of visible/private declarations
16348 -- and body declarations/statements.
16350 procedure Check_Conformance
16351 (Governing_Id
: Entity_Id
;
16352 New_Id
: Entity_Id
);
16353 -- Verify the "monotonicity" of SPARK modes between two entities.
16354 -- The order of modes is Off < Auto < On. Governing_Id establishes
16355 -- the mode of the context. New_Id attempts to redefine the known
16358 procedure Check_Pragma_Conformance
16359 (Governing_Mode
: Node_Id
;
16360 New_Mode
: Node_Id
);
16361 -- Verify the "monotonicity" of two SPARK_Mode pragmas. The order
16362 -- of modes is Off < Auto < On. Governing_Mode is the established
16363 -- mode dictated by the context. New_Mode attempts to redefine the
16366 function Get_SPARK_Mode_Name
(Id
: SPARK_Mode_Id
) return Name_Id
;
16367 -- Convert a value of type SPARK_Mode_Id into a corresponding name
16373 procedure Chain_Pragma
(Context
: Entity_Id
; Prag
: Node_Id
) is
16374 Existing_Prag
: constant Node_Id
:=
16375 SPARK_Mode_Pragmas
(Context
);
16377 -- The context does not have a prior mode defined
16379 if No
(Existing_Prag
) then
16380 Set_SPARK_Mode_Pragmas
(Context
, Prag
);
16382 -- Chain the new mode on the list of SPARK_Mode pragmas. Verify
16383 -- the consistency between the existing mode and the new one.
16386 Set_Next_Pragma
(Existing_Prag
, Prag
);
16388 Check_Pragma_Conformance
16389 (Governing_Mode
=> Existing_Prag
,
16394 -----------------------
16395 -- Check_Conformance --
16396 -----------------------
16398 procedure Check_Conformance
16399 (Governing_Id
: Entity_Id
;
16400 New_Id
: Entity_Id
)
16402 Gov_Prag
: constant Node_Id
:=
16403 SPARK_Mode_Pragmas
(Governing_Id
);
16404 New_Prag
: constant Node_Id
:= SPARK_Mode_Pragmas
(New_Id
);
16407 -- Nothing to do when one or both entities lack a mode
16409 if No
(Gov_Prag
) or else No
(New_Prag
) then
16413 -- Do not compare the modes of a package spec and body when the
16414 -- spec mode appears in the private part. In this case the spec
16415 -- mode does not affect the body.
16417 if Ekind_In
(Governing_Id
, E_Generic_Package
, E_Package
)
16418 and then Ekind
(New_Id
) = E_Package_Body
16419 and then Is_Private_SPARK_Mode
(Gov_Prag
)
16423 -- Test the pragmas
16426 Check_Pragma_Conformance
16427 (Governing_Mode
=> Gov_Prag
,
16428 New_Mode
=> New_Prag
);
16430 end Check_Conformance
;
16432 ------------------------------
16433 -- Check_Pragma_Conformance --
16434 ------------------------------
16436 procedure Check_Pragma_Conformance
16437 (Governing_Mode
: Node_Id
;
16438 New_Mode
: Node_Id
)
16440 Gov_M
: constant SPARK_Mode_Id
:=
16441 Get_SPARK_Mode_Id
(Governing_Mode
);
16442 New_M
: constant SPARK_Mode_Id
:= Get_SPARK_Mode_Id
(New_Mode
);
16445 -- The new mode is less restrictive than the established mode
16447 if Gov_M
< New_M
then
16448 Error_Msg_Name_1
:= Get_SPARK_Mode_Name
(New_M
);
16449 Error_Msg_N
("cannot define 'S'P'A'R'K mode %", New_Mode
);
16451 Error_Msg_Name_1
:= Get_SPARK_Mode_Name
(Gov_M
);
16452 Error_Msg_Sloc
:= Sloc
(Governing_Mode
);
16454 ("\mode is less restrictive than mode % defined #",
16457 end Check_Pragma_Conformance
;
16459 -------------------------
16460 -- Get_SPARK_Mode_Name --
16461 -------------------------
16463 function Get_SPARK_Mode_Name
(Id
: SPARK_Mode_Id
) return Name_Id
is
16465 if Id
= SPARK_On
then
16467 elsif Id
= SPARK_Off
then
16469 elsif Id
= SPARK_Auto
then
16472 -- Mode "None" should never be used in error message generation
16475 raise Program_Error
;
16477 end Get_SPARK_Mode_Name
;
16481 Body_Id
: Entity_Id
;
16484 Mode_Id
: SPARK_Mode_Id
;
16485 Spec_Id
: Entity_Id
;
16488 -- Start of processing for SPARK_Mode
16492 Check_No_Identifiers
;
16493 Check_At_Most_N_Arguments
(1);
16495 -- Check the legality of the mode
16497 if Arg_Count
= 1 then
16498 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
, Name_Auto
);
16499 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
16501 -- A SPARK_Mode without an argument defaults to "On"
16507 Mode_Id
:= Get_SPARK_Mode_Id
(Mode
);
16508 Context
:= Parent
(N
);
16510 -- The pragma appears in a configuration file
16512 if No
(Context
) then
16513 Check_Valid_Configuration_Pragma
;
16514 Global_SPARK_Mode
:= Mode_Id
;
16516 -- When the pragma is placed before the declaration of a unit, it
16517 -- configures the whole unit.
16519 elsif Nkind
(Context
) = N_Compilation_Unit
then
16520 Check_Valid_Configuration_Pragma
;
16521 Set_SPARK_Mode_Pragma
(Current_Sem_Unit
, N
);
16523 -- The pragma applies to a [library unit] subprogram or package
16526 -- Mode "Auto" cannot be used in nested subprograms or packages
16528 if Mode_Id
= SPARK_Auto
then
16530 ("mode `Auto` can only apply to the configuration variant "
16531 & "of pragma %", Arg1
);
16534 -- Verify the placement of the pragma with respect to package
16535 -- or subprogram declarations and detect duplicates.
16538 while Present
(Stmt
) loop
16540 -- Skip prior pragmas, but check for duplicates
16542 if Nkind
(Stmt
) = N_Pragma
then
16543 if Pragma_Name
(Stmt
) = Pname
then
16544 Error_Msg_Name_1
:= Pname
;
16545 Error_Msg_Sloc
:= Sloc
(Stmt
);
16547 ("pragma % duplicates pragma declared #", N
);
16550 -- Skip internally generated code
16552 elsif not Comes_From_Source
(Stmt
) then
16555 -- The pragma applies to a package or subprogram declaration
16557 elsif Nkind_In
(Stmt
, N_Generic_Package_Declaration
,
16558 N_Generic_Subprogram_Declaration
,
16559 N_Package_Declaration
,
16560 N_Subprogram_Declaration
)
16562 Spec_Id
:= Defining_Unit_Name
(Specification
(Stmt
));
16563 Chain_Pragma
(Spec_Id
, N
);
16566 -- The pragma does not apply to a legal construct, issue an
16567 -- error and stop the analysis.
16574 Stmt
:= Prev
(Stmt
);
16577 -- If we get here, then we ran out of preceding statements. The
16578 -- pragma is immediately within a body.
16580 if Nkind_In
(Context
, N_Package_Body
,
16583 Spec_Id
:= Corresponding_Spec
(Context
);
16585 if Nkind
(Context
) = N_Subprogram_Body
then
16586 Context
:= Specification
(Context
);
16589 Body_Id
:= Defining_Unit_Name
(Context
);
16591 Chain_Pragma
(Body_Id
, N
);
16592 Check_Conformance
(Spec_Id
, Body_Id
);
16594 -- The pragma is at the top level of a package spec
16596 elsif Nkind
(Context
) = N_Package_Specification
then
16597 Spec_Id
:= Defining_Unit_Name
(Context
);
16598 Chain_Pragma
(Spec_Id
, N
);
16600 -- The pragma applies to the statements of a package body
16602 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
16603 and then Nkind
(Parent
(Context
)) = N_Package_Body
16605 Context
:= Parent
(Context
);
16606 Spec_Id
:= Corresponding_Spec
(Context
);
16607 Body_Id
:= Defining_Unit_Name
(Context
);
16609 Chain_Pragma
(Body_Id
, N
);
16610 Check_Conformance
(Spec_Id
, Body_Id
);
16612 -- The pragma does not apply to a legal construct, issue an
16621 --------------------------------
16622 -- Static_Elaboration_Desired --
16623 --------------------------------
16625 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
16627 when Pragma_Static_Elaboration_Desired
=>
16629 Check_At_Most_N_Arguments
(1);
16631 if Is_Compilation_Unit
(Current_Scope
)
16632 and then Ekind
(Current_Scope
) = E_Package
16634 Set_Static_Elaboration_Desired
(Current_Scope
, True);
16636 Error_Pragma
("pragma% must apply to a library-level package");
16643 -- pragma Storage_Size (EXPRESSION);
16645 when Pragma_Storage_Size
=> Storage_Size
: declare
16646 P
: constant Node_Id
:= Parent
(N
);
16650 Check_No_Identifiers
;
16651 Check_Arg_Count
(1);
16653 -- The expression must be analyzed in the special manner described
16654 -- in "Handling of Default Expressions" in sem.ads.
16656 Arg
:= Get_Pragma_Arg
(Arg1
);
16657 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
16659 if not Is_Static_Expression
(Arg
) then
16660 Check_Restriction
(Static_Storage_Size
, Arg
);
16663 if Nkind
(P
) /= N_Task_Definition
then
16668 if Has_Storage_Size_Pragma
(P
) then
16669 Error_Pragma
("duplicate pragma% not allowed");
16671 Set_Has_Storage_Size_Pragma
(P
, True);
16674 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
16682 -- pragma Storage_Unit (NUMERIC_LITERAL);
16684 -- Only permitted argument is System'Storage_Unit value
16686 when Pragma_Storage_Unit
=>
16687 Check_No_Identifiers
;
16688 Check_Arg_Count
(1);
16689 Check_Arg_Is_Integer_Literal
(Arg1
);
16691 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
16692 UI_From_Int
(Ttypes
.System_Storage_Unit
)
16694 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
16696 ("the only allowed argument for pragma% is ^", Arg1
);
16699 --------------------
16700 -- Stream_Convert --
16701 --------------------
16703 -- pragma Stream_Convert (
16704 -- [Entity =>] type_LOCAL_NAME,
16705 -- [Read =>] function_NAME,
16706 -- [Write =>] function NAME);
16708 when Pragma_Stream_Convert
=> Stream_Convert
: declare
16710 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
16711 -- Check that the given argument is the name of a local function
16712 -- of one argument that is not overloaded earlier in the current
16713 -- local scope. A check is also made that the argument is a
16714 -- function with one parameter.
16716 --------------------------------------
16717 -- Check_OK_Stream_Convert_Function --
16718 --------------------------------------
16720 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
16724 Check_Arg_Is_Local_Name
(Arg
);
16725 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
16727 if Has_Homonym
(Ent
) then
16729 ("argument for pragma% may not be overloaded", Arg
);
16732 if Ekind
(Ent
) /= E_Function
16733 or else No
(First_Formal
(Ent
))
16734 or else Present
(Next_Formal
(First_Formal
(Ent
)))
16737 ("argument for pragma% must be function of one argument",
16740 end Check_OK_Stream_Convert_Function
;
16742 -- Start of processing for Stream_Convert
16746 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
16747 Check_Arg_Count
(3);
16748 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16749 Check_Optional_Identifier
(Arg2
, Name_Read
);
16750 Check_Optional_Identifier
(Arg3
, Name_Write
);
16751 Check_Arg_Is_Local_Name
(Arg1
);
16752 Check_OK_Stream_Convert_Function
(Arg2
);
16753 Check_OK_Stream_Convert_Function
(Arg3
);
16756 Typ
: constant Entity_Id
:=
16757 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
16758 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
16759 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
16762 Check_First_Subtype
(Arg1
);
16764 -- Check for too early or too late. Note that we don't enforce
16765 -- the rule about primitive operations in this case, since, as
16766 -- is the case for explicit stream attributes themselves, these
16767 -- restrictions are not appropriate. Note that the chaining of
16768 -- the pragma by Rep_Item_Too_Late is actually the critical
16769 -- processing done for this pragma.
16771 if Rep_Item_Too_Early
(Typ
, N
)
16773 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
16778 -- Return if previous error
16780 if Etype
(Typ
) = Any_Type
16782 Etype
(Read
) = Any_Type
16784 Etype
(Write
) = Any_Type
16791 if Underlying_Type
(Etype
(Read
)) /= Typ
then
16793 ("incorrect return type for function&", Arg2
);
16796 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
16798 ("incorrect parameter type for function&", Arg3
);
16801 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
16802 Underlying_Type
(Etype
(Write
))
16805 ("result type of & does not match Read parameter type",
16809 end Stream_Convert
;
16815 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
16817 -- This is processed by the parser since some of the style checks
16818 -- take place during source scanning and parsing. This means that
16819 -- we don't need to issue error messages here.
16821 when Pragma_Style_Checks
=> Style_Checks
: declare
16822 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
16828 Check_No_Identifiers
;
16830 -- Two argument form
16832 if Arg_Count
= 2 then
16833 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
16840 E_Id
:= Get_Pragma_Arg
(Arg2
);
16843 if not Is_Entity_Name
(E_Id
) then
16845 ("second argument of pragma% must be entity name",
16849 E
:= Entity
(E_Id
);
16851 if not Ignore_Style_Checks_Pragmas
then
16856 Set_Suppress_Style_Checks
16857 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
16858 exit when No
(Homonym
(E
));
16865 -- One argument form
16868 Check_Arg_Count
(1);
16870 if Nkind
(A
) = N_String_Literal
then
16874 Slen
: constant Natural := Natural (String_Length
(S
));
16875 Options
: String (1 .. Slen
);
16881 C
:= Get_String_Char
(S
, Int
(J
));
16882 exit when not In_Character_Range
(C
);
16883 Options
(J
) := Get_Character
(C
);
16885 -- If at end of string, set options. As per discussion
16886 -- above, no need to check for errors, since we issued
16887 -- them in the parser.
16890 if not Ignore_Style_Checks_Pragmas
then
16891 Set_Style_Check_Options
(Options
);
16901 elsif Nkind
(A
) = N_Identifier
then
16902 if Chars
(A
) = Name_All_Checks
then
16903 if not Ignore_Style_Checks_Pragmas
then
16905 Set_GNAT_Style_Check_Options
;
16907 Set_Default_Style_Check_Options
;
16911 elsif Chars
(A
) = Name_On
then
16912 if not Ignore_Style_Checks_Pragmas
then
16913 Style_Check
:= True;
16916 elsif Chars
(A
) = Name_Off
then
16917 if not Ignore_Style_Checks_Pragmas
then
16918 Style_Check
:= False;
16929 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
16931 when Pragma_Subtitle
=>
16933 Check_Arg_Count
(1);
16934 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
16935 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
16942 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
16944 when Pragma_Suppress
=>
16945 Process_Suppress_Unsuppress
(True);
16951 -- pragma Suppress_All;
16953 -- The only check made here is that the pragma has no arguments.
16954 -- There are no placement rules, and the processing required (setting
16955 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
16956 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
16957 -- then creates and inserts a pragma Suppress (All_Checks).
16959 when Pragma_Suppress_All
=>
16961 Check_Arg_Count
(0);
16963 -------------------------
16964 -- Suppress_Debug_Info --
16965 -------------------------
16967 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
16969 when Pragma_Suppress_Debug_Info
=>
16971 Check_Arg_Count
(1);
16972 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16973 Check_Arg_Is_Local_Name
(Arg1
);
16974 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
16976 ----------------------------------
16977 -- Suppress_Exception_Locations --
16978 ----------------------------------
16980 -- pragma Suppress_Exception_Locations;
16982 when Pragma_Suppress_Exception_Locations
=>
16984 Check_Arg_Count
(0);
16985 Check_Valid_Configuration_Pragma
;
16986 Exception_Locations_Suppressed
:= True;
16988 -----------------------------
16989 -- Suppress_Initialization --
16990 -----------------------------
16992 -- pragma Suppress_Initialization ([Entity =>] type_Name);
16994 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
17000 Check_Arg_Count
(1);
17001 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17002 Check_Arg_Is_Local_Name
(Arg1
);
17004 E_Id
:= Get_Pragma_Arg
(Arg1
);
17006 if Etype
(E_Id
) = Any_Type
then
17010 E
:= Entity
(E_Id
);
17012 if not Is_Type
(E
) then
17013 Error_Pragma_Arg
("pragma% requires type or subtype", Arg1
);
17016 if Rep_Item_Too_Early
(E
, N
)
17018 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
17023 -- For incomplete/private type, set flag on full view
17025 if Is_Incomplete_Or_Private_Type
(E
) then
17026 if No
(Full_View
(Base_Type
(E
))) then
17028 ("argument of pragma% cannot be an incomplete type", Arg1
);
17030 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
17033 -- For first subtype, set flag on base type
17035 elsif Is_First_Subtype
(E
) then
17036 Set_Suppress_Initialization
(Base_Type
(E
));
17038 -- For other than first subtype, set flag on subtype itself
17041 Set_Suppress_Initialization
(E
);
17049 -- pragma System_Name (DIRECT_NAME);
17051 -- Syntax check: one argument, which must be the identifier GNAT or
17052 -- the identifier GCC, no other identifiers are acceptable.
17054 when Pragma_System_Name
=>
17056 Check_No_Identifiers
;
17057 Check_Arg_Count
(1);
17058 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
17060 -----------------------------
17061 -- Task_Dispatching_Policy --
17062 -----------------------------
17064 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
17066 when Pragma_Task_Dispatching_Policy
=> declare
17070 Check_Ada_83_Warning
;
17071 Check_Arg_Count
(1);
17072 Check_No_Identifiers
;
17073 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
17074 Check_Valid_Configuration_Pragma
;
17075 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
17076 DP
:= Fold_Upper
(Name_Buffer
(1));
17078 if Task_Dispatching_Policy
/= ' '
17079 and then Task_Dispatching_Policy
/= DP
17081 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
17083 ("task dispatching policy incompatible with policy#");
17085 -- Set new policy, but always preserve System_Location since we
17086 -- like the error message with the run time name.
17089 Task_Dispatching_Policy
:= DP
;
17091 if Task_Dispatching_Policy_Sloc
/= System_Location
then
17092 Task_Dispatching_Policy_Sloc
:= Loc
;
17101 -- pragma Task_Info (EXPRESSION);
17103 when Pragma_Task_Info
=> Task_Info
: declare
17104 P
: constant Node_Id
:= Parent
(N
);
17110 if Nkind
(P
) /= N_Task_Definition
then
17111 Error_Pragma
("pragma% must appear in task definition");
17114 Check_No_Identifiers
;
17115 Check_Arg_Count
(1);
17117 Analyze_And_Resolve
17118 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
17120 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
17124 Ent
:= Defining_Identifier
(Parent
(P
));
17126 -- Check duplicate pragma before we chain the pragma in the Rep
17127 -- Item chain of Ent.
17130 (Ent
, Name_Task_Info
, Check_Parents
=> False)
17132 Error_Pragma
("duplicate pragma% not allowed");
17135 Record_Rep_Item
(Ent
, N
);
17142 -- pragma Task_Name (string_EXPRESSION);
17144 when Pragma_Task_Name
=> Task_Name
: declare
17145 P
: constant Node_Id
:= Parent
(N
);
17150 Check_No_Identifiers
;
17151 Check_Arg_Count
(1);
17153 Arg
:= Get_Pragma_Arg
(Arg1
);
17155 -- The expression is used in the call to Create_Task, and must be
17156 -- expanded there, not in the context of the current spec. It must
17157 -- however be analyzed to capture global references, in case it
17158 -- appears in a generic context.
17160 Preanalyze_And_Resolve
(Arg
, Standard_String
);
17162 if Nkind
(P
) /= N_Task_Definition
then
17166 Ent
:= Defining_Identifier
(Parent
(P
));
17168 -- Check duplicate pragma before we chain the pragma in the Rep
17169 -- Item chain of Ent.
17172 (Ent
, Name_Task_Name
, Check_Parents
=> False)
17174 Error_Pragma
("duplicate pragma% not allowed");
17177 Record_Rep_Item
(Ent
, N
);
17184 -- pragma Task_Storage (
17185 -- [Task_Type =>] LOCAL_NAME,
17186 -- [Top_Guard =>] static_integer_EXPRESSION);
17188 when Pragma_Task_Storage
=> Task_Storage
: declare
17189 Args
: Args_List
(1 .. 2);
17190 Names
: constant Name_List
(1 .. 2) := (
17194 Task_Type
: Node_Id
renames Args
(1);
17195 Top_Guard
: Node_Id
renames Args
(2);
17201 Gather_Associations
(Names
, Args
);
17203 if No
(Task_Type
) then
17205 ("missing task_type argument for pragma%");
17208 Check_Arg_Is_Local_Name
(Task_Type
);
17210 Ent
:= Entity
(Task_Type
);
17212 if not Is_Task_Type
(Ent
) then
17214 ("argument for pragma% must be task type", Task_Type
);
17217 if No
(Top_Guard
) then
17219 ("pragma% takes two arguments", Task_Type
);
17221 Check_Arg_Is_Static_Expression
(Top_Guard
, Any_Integer
);
17224 Check_First_Subtype
(Task_Type
);
17226 if Rep_Item_Too_Late
(Ent
, N
) then
17235 -- pragma Test_Case
17236 -- ([Name =>] Static_String_EXPRESSION
17237 -- ,[Mode =>] MODE_TYPE
17238 -- [, Requires => Boolean_EXPRESSION]
17239 -- [, Ensures => Boolean_EXPRESSION]);
17241 -- MODE_TYPE ::= Nominal | Robustness
17243 when Pragma_Test_Case
=>
17247 --------------------------
17248 -- Thread_Local_Storage --
17249 --------------------------
17251 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
17253 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
17259 Check_Arg_Count
(1);
17260 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17261 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17263 Id
:= Get_Pragma_Arg
(Arg1
);
17266 if not Is_Entity_Name
(Id
)
17267 or else Ekind
(Entity
(Id
)) /= E_Variable
17269 Error_Pragma_Arg
("local variable name required", Arg1
);
17274 if Rep_Item_Too_Early
(E
, N
)
17275 or else Rep_Item_Too_Late
(E
, N
)
17280 Set_Has_Pragma_Thread_Local_Storage
(E
);
17281 Set_Has_Gigi_Rep_Item
(E
);
17282 end Thread_Local_Storage
;
17288 -- pragma Time_Slice (static_duration_EXPRESSION);
17290 when Pragma_Time_Slice
=> Time_Slice
: declare
17296 Check_Arg_Count
(1);
17297 Check_No_Identifiers
;
17298 Check_In_Main_Program
;
17299 Check_Arg_Is_Static_Expression
(Arg1
, Standard_Duration
);
17301 if not Error_Posted
(Arg1
) then
17303 while Present
(Nod
) loop
17304 if Nkind
(Nod
) = N_Pragma
17305 and then Pragma_Name
(Nod
) = Name_Time_Slice
17307 Error_Msg_Name_1
:= Pname
;
17308 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17315 -- Process only if in main unit
17317 if Get_Source_Unit
(Loc
) = Main_Unit
then
17318 Opt
.Time_Slice_Set
:= True;
17319 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
17321 if Val
<= Ureal_0
then
17322 Opt
.Time_Slice_Value
:= 0;
17324 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
17325 Opt
.Time_Slice_Value
:= 1_000_000_000
;
17328 Opt
.Time_Slice_Value
:=
17329 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
17338 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
17340 -- TITLING_OPTION ::=
17341 -- [Title =>] STRING_LITERAL
17342 -- | [Subtitle =>] STRING_LITERAL
17344 when Pragma_Title
=> Title
: declare
17345 Args
: Args_List
(1 .. 2);
17346 Names
: constant Name_List
(1 .. 2) := (
17352 Gather_Associations
(Names
, Args
);
17355 for J
in 1 .. 2 loop
17356 if Present
(Args
(J
)) then
17357 Check_Arg_Is_Static_Expression
(Args
(J
), Standard_String
);
17362 ---------------------
17363 -- Unchecked_Union --
17364 ---------------------
17366 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
17368 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
17369 Assoc
: constant Node_Id
:= Arg1
;
17370 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
17380 Check_No_Identifiers
;
17381 Check_Arg_Count
(1);
17382 Check_Arg_Is_Local_Name
(Arg1
);
17384 Find_Type
(Type_Id
);
17386 Typ
:= Entity
(Type_Id
);
17389 or else Rep_Item_Too_Early
(Typ
, N
)
17393 Typ
:= Underlying_Type
(Typ
);
17396 if Rep_Item_Too_Late
(Typ
, N
) then
17400 Check_First_Subtype
(Arg1
);
17402 -- Note remaining cases are references to a type in the current
17403 -- declarative part. If we find an error, we post the error on
17404 -- the relevant type declaration at an appropriate point.
17406 if not Is_Record_Type
(Typ
) then
17407 Error_Msg_N
("unchecked union must be record type", Typ
);
17410 elsif Is_Tagged_Type
(Typ
) then
17411 Error_Msg_N
("unchecked union must not be tagged", Typ
);
17414 elsif not Has_Discriminants
(Typ
) then
17416 ("unchecked union must have one discriminant", Typ
);
17419 -- Note: in previous versions of GNAT we used to check for limited
17420 -- types and give an error, but in fact the standard does allow
17421 -- Unchecked_Union on limited types, so this check was removed.
17423 -- Similarly, GNAT used to require that all discriminants have
17424 -- default values, but this is not mandated by the RM.
17426 -- Proceed with basic error checks completed
17429 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
17430 Clist
:= Component_List
(Tdef
);
17432 -- Check presence of component list and variant part
17434 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
17436 ("unchecked union must have variant part", Tdef
);
17440 -- Check components
17442 Comp
:= First
(Component_Items
(Clist
));
17443 while Present
(Comp
) loop
17444 Check_Component
(Comp
, Typ
);
17448 -- Check variant part
17450 Vpart
:= Variant_Part
(Clist
);
17452 Variant
:= First
(Variants
(Vpart
));
17453 while Present
(Variant
) loop
17454 Check_Variant
(Variant
, Typ
);
17459 Set_Is_Unchecked_Union
(Typ
);
17460 Set_Convention
(Typ
, Convention_C
);
17461 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
17462 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
17463 end Unchecked_Union
;
17465 ------------------------
17466 -- Unimplemented_Unit --
17467 ------------------------
17469 -- pragma Unimplemented_Unit;
17471 -- Note: this only gives an error if we are generating code, or if
17472 -- we are in a generic library unit (where the pragma appears in the
17473 -- body, not in the spec).
17475 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
17476 Cunitent
: constant Entity_Id
:=
17477 Cunit_Entity
(Get_Source_Unit
(Loc
));
17478 Ent_Kind
: constant Entity_Kind
:=
17483 Check_Arg_Count
(0);
17485 if Operating_Mode
= Generate_Code
17486 or else Ent_Kind
= E_Generic_Function
17487 or else Ent_Kind
= E_Generic_Procedure
17488 or else Ent_Kind
= E_Generic_Package
17490 Get_Name_String
(Chars
(Cunitent
));
17491 Set_Casing
(Mixed_Case
);
17492 Write_Str
(Name_Buffer
(1 .. Name_Len
));
17493 Write_Str
(" is not supported in this configuration");
17495 raise Unrecoverable_Error
;
17497 end Unimplemented_Unit
;
17499 ------------------------
17500 -- Universal_Aliasing --
17501 ------------------------
17503 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
17505 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
17510 Check_Arg_Count
(1);
17511 Check_Optional_Identifier
(Arg2
, Name_Entity
);
17512 Check_Arg_Is_Local_Name
(Arg1
);
17513 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17515 if E_Id
= Any_Type
then
17517 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
17518 Error_Pragma_Arg
("pragma% requires type", Arg1
);
17521 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
17522 Record_Rep_Item
(E_Id
, N
);
17523 end Universal_Alias
;
17525 --------------------
17526 -- Universal_Data --
17527 --------------------
17529 -- pragma Universal_Data [(library_unit_NAME)];
17531 when Pragma_Universal_Data
=>
17534 -- If this is a configuration pragma, then set the universal
17535 -- addressing option, otherwise confirm that the pragma satisfies
17536 -- the requirements of library unit pragma placement and leave it
17537 -- to the GNAAMP back end to detect the pragma (avoids transitive
17538 -- setting of the option due to withed units).
17540 if Is_Configuration_Pragma
then
17541 Universal_Addressing_On_AAMP
:= True;
17543 Check_Valid_Library_Unit_Pragma
;
17546 if not AAMP_On_Target
then
17547 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
17554 -- pragma Unmodified (local_Name {, local_Name});
17556 when Pragma_Unmodified
=> Unmodified
: declare
17557 Arg_Node
: Node_Id
;
17558 Arg_Expr
: Node_Id
;
17559 Arg_Ent
: Entity_Id
;
17563 Check_At_Least_N_Arguments
(1);
17565 -- Loop through arguments
17568 while Present
(Arg_Node
) loop
17569 Check_No_Identifier
(Arg_Node
);
17571 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
17572 -- in fact generate reference, so that the entity will have a
17573 -- reference, which will inhibit any warnings about it not
17574 -- being referenced, and also properly show up in the ali file
17575 -- as a reference. But this reference is recorded before the
17576 -- Has_Pragma_Unreferenced flag is set, so that no warning is
17577 -- generated for this reference.
17579 Check_Arg_Is_Local_Name
(Arg_Node
);
17580 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
17582 if Is_Entity_Name
(Arg_Expr
) then
17583 Arg_Ent
:= Entity
(Arg_Expr
);
17585 if not Is_Assignable
(Arg_Ent
) then
17587 ("pragma% can only be applied to a variable",
17590 Set_Has_Pragma_Unmodified
(Arg_Ent
);
17602 -- pragma Unreferenced (local_Name {, local_Name});
17604 -- or when used in a context clause:
17606 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
17608 when Pragma_Unreferenced
=> Unreferenced
: declare
17609 Arg_Node
: Node_Id
;
17610 Arg_Expr
: Node_Id
;
17611 Arg_Ent
: Entity_Id
;
17616 Check_At_Least_N_Arguments
(1);
17618 -- Check case of appearing within context clause
17620 if Is_In_Context_Clause
then
17622 -- The arguments must all be units mentioned in a with clause
17623 -- in the same context clause. Note we already checked (in
17624 -- Par.Prag) that the arguments are either identifiers or
17625 -- selected components.
17628 while Present
(Arg_Node
) loop
17629 Citem
:= First
(List_Containing
(N
));
17630 while Citem
/= N
loop
17631 if Nkind
(Citem
) = N_With_Clause
17633 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
17635 Set_Has_Pragma_Unreferenced
17638 (Library_Unit
(Citem
))));
17640 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
17649 ("argument of pragma% is not withed unit", Arg_Node
);
17655 -- Case of not in list of context items
17659 while Present
(Arg_Node
) loop
17660 Check_No_Identifier
(Arg_Node
);
17662 -- Note: the analyze call done by Check_Arg_Is_Local_Name
17663 -- will in fact generate reference, so that the entity will
17664 -- have a reference, which will inhibit any warnings about
17665 -- it not being referenced, and also properly show up in the
17666 -- ali file as a reference. But this reference is recorded
17667 -- before the Has_Pragma_Unreferenced flag is set, so that
17668 -- no warning is generated for this reference.
17670 Check_Arg_Is_Local_Name
(Arg_Node
);
17671 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
17673 if Is_Entity_Name
(Arg_Expr
) then
17674 Arg_Ent
:= Entity
(Arg_Expr
);
17676 -- If the entity is overloaded, the pragma applies to the
17677 -- most recent overloading, as documented. In this case,
17678 -- name resolution does not generate a reference, so it
17679 -- must be done here explicitly.
17681 if Is_Overloaded
(Arg_Expr
) then
17682 Generate_Reference
(Arg_Ent
, N
);
17685 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
17693 --------------------------
17694 -- Unreferenced_Objects --
17695 --------------------------
17697 -- pragma Unreferenced_Objects (local_Name {, local_Name});
17699 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
17700 Arg_Node
: Node_Id
;
17701 Arg_Expr
: Node_Id
;
17705 Check_At_Least_N_Arguments
(1);
17708 while Present
(Arg_Node
) loop
17709 Check_No_Identifier
(Arg_Node
);
17710 Check_Arg_Is_Local_Name
(Arg_Node
);
17711 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
17713 if not Is_Entity_Name
(Arg_Expr
)
17714 or else not Is_Type
(Entity
(Arg_Expr
))
17717 ("argument for pragma% must be type or subtype", Arg_Node
);
17720 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
17723 end Unreferenced_Objects
;
17725 ------------------------------
17726 -- Unreserve_All_Interrupts --
17727 ------------------------------
17729 -- pragma Unreserve_All_Interrupts;
17731 when Pragma_Unreserve_All_Interrupts
=>
17733 Check_Arg_Count
(0);
17735 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
17736 Unreserve_All_Interrupts
:= True;
17743 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
17745 when Pragma_Unsuppress
=>
17747 Process_Suppress_Unsuppress
(False);
17749 -------------------
17750 -- Use_VADS_Size --
17751 -------------------
17753 -- pragma Use_VADS_Size;
17755 when Pragma_Use_VADS_Size
=>
17757 Check_Arg_Count
(0);
17758 Check_Valid_Configuration_Pragma
;
17759 Use_VADS_Size
:= True;
17761 ---------------------
17762 -- Validity_Checks --
17763 ---------------------
17765 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
17767 when Pragma_Validity_Checks
=> Validity_Checks
: declare
17768 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
17774 Check_Arg_Count
(1);
17775 Check_No_Identifiers
;
17777 if Nkind
(A
) = N_String_Literal
then
17781 Slen
: constant Natural := Natural (String_Length
(S
));
17782 Options
: String (1 .. Slen
);
17788 C
:= Get_String_Char
(S
, Int
(J
));
17789 exit when not In_Character_Range
(C
);
17790 Options
(J
) := Get_Character
(C
);
17793 Set_Validity_Check_Options
(Options
);
17801 elsif Nkind
(A
) = N_Identifier
then
17802 if Chars
(A
) = Name_All_Checks
then
17803 Set_Validity_Check_Options
("a");
17804 elsif Chars
(A
) = Name_On
then
17805 Validity_Checks_On
:= True;
17806 elsif Chars
(A
) = Name_Off
then
17807 Validity_Checks_On
:= False;
17810 end Validity_Checks
;
17816 -- pragma Volatile (LOCAL_NAME);
17818 when Pragma_Volatile
=>
17819 Process_Atomic_Shared_Volatile
;
17821 -------------------------
17822 -- Volatile_Components --
17823 -------------------------
17825 -- pragma Volatile_Components (array_LOCAL_NAME);
17827 -- Volatile is handled by the same circuit as Atomic_Components
17833 -- pragma Warnings (On | Off [,REASON]);
17834 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
17835 -- pragma Warnings (static_string_EXPRESSION [,REASON]);
17836 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
17838 -- REASON ::= Reason => Static_String_Expression
17840 when Pragma_Warnings
=> Warnings
: begin
17842 Check_At_Least_N_Arguments
(1);
17844 -- See if last argument is labeled Reason. If so, make sure we
17845 -- have a static string expression, but otherwise just ignore
17846 -- the REASON argument by decreasing Num_Args by 1 (all the
17847 -- remaining tests look only at the first Num_Args arguments).
17850 Last_Arg
: constant Node_Id
:=
17851 Last
(Pragma_Argument_Associations
(N
));
17853 if Nkind
(Last_Arg
) = N_Pragma_Argument_Association
17854 and then Chars
(Last_Arg
) = Name_Reason
17856 Check_Arg_Is_Static_Expression
(Last_Arg
, Standard_String
);
17857 Arg_Count
:= Arg_Count
- 1;
17861 -- Now proceed with REASON taken care of and eliminated
17863 Check_No_Identifiers
;
17865 -- If debug flag -gnatd.i is set, pragma is ignored
17867 if Debug_Flag_Dot_I
then
17871 -- Process various forms of the pragma
17874 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
17877 -- One argument case
17879 if Arg_Count
= 1 then
17881 -- On/Off one argument case was processed by parser
17883 if Nkind
(Argx
) = N_Identifier
17884 and then Nam_In
(Chars
(Argx
), Name_On
, Name_Off
)
17888 -- One argument case must be ON/OFF or static string expr
17890 elsif not Is_Static_String_Expression
(Arg1
) then
17892 ("argument of pragma% must be On/Off or static string "
17893 & "expression", Arg1
);
17895 -- One argument string expression case
17899 Lit
: constant Node_Id
:= Expr_Value_S
(Argx
);
17900 Str
: constant String_Id
:= Strval
(Lit
);
17901 Len
: constant Nat
:= String_Length
(Str
);
17909 while J
<= Len
loop
17910 C
:= Get_String_Char
(Str
, J
);
17911 OK
:= In_Character_Range
(C
);
17914 Chr
:= Get_Character
(C
);
17916 -- Dash case: only -Wxxx is accepted
17923 C
:= Get_String_Char
(Str
, J
);
17924 Chr
:= Get_Character
(C
);
17925 exit when Chr
= 'W';
17930 elsif J
< Len
and then Chr
= '.' then
17932 C
:= Get_String_Char
(Str
, J
);
17933 Chr
:= Get_Character
(C
);
17935 if not Set_Dot_Warning_Switch
(Chr
) then
17937 ("invalid warning switch character "
17938 & '.' & Chr
, Arg1
);
17944 OK
:= Set_Warning_Switch
(Chr
);
17950 ("invalid warning switch character " & Chr
,
17959 -- Two or more arguments (must be two)
17962 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
17963 Check_At_Most_N_Arguments
(2);
17971 E_Id
:= Get_Pragma_Arg
(Arg2
);
17974 -- In the expansion of an inlined body, a reference to
17975 -- the formal may be wrapped in a conversion if the
17976 -- actual is a conversion. Retrieve the real entity name.
17978 if (In_Instance_Body
or In_Inlined_Body
)
17979 and then Nkind
(E_Id
) = N_Unchecked_Type_Conversion
17981 E_Id
:= Expression
(E_Id
);
17984 -- Entity name case
17986 if Is_Entity_Name
(E_Id
) then
17987 E
:= Entity
(E_Id
);
17994 (E
, (Chars
(Get_Pragma_Arg
(Arg1
)) =
17997 -- For OFF case, make entry in warnings off
17998 -- pragma table for later processing. But we do
17999 -- not do that within an instance, since these
18000 -- warnings are about what is needed in the
18001 -- template, not an instance of it.
18003 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
18004 and then Warn_On_Warnings_Off
18005 and then not In_Instance
18007 Warnings_Off_Pragmas
.Append
((N
, E
));
18010 if Is_Enumeration_Type
(E
) then
18014 Lit
:= First_Literal
(E
);
18015 while Present
(Lit
) loop
18016 Set_Warnings_Off
(Lit
);
18017 Next_Literal
(Lit
);
18022 exit when No
(Homonym
(E
));
18027 -- Error if not entity or static string literal case
18029 elsif not Is_Static_String_Expression
(Arg2
) then
18031 ("second argument of pragma% must be entity name "
18032 & "or static string expression", Arg2
);
18034 -- String literal case
18037 String_To_Name_Buffer
18038 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg2
))));
18040 -- Note on configuration pragma case: If this is a
18041 -- configuration pragma, then for an OFF pragma, we
18042 -- just set Config True in the call, which is all
18043 -- that needs to be done. For the case of ON, this
18044 -- is normally an error, unless it is canceling the
18045 -- effect of a previous OFF pragma in the same file.
18046 -- In any other case, an error will be signalled (ON
18047 -- with no matching OFF).
18049 -- Note: We set Used if we are inside a generic to
18050 -- disable the test that the non-config case actually
18051 -- cancels a warning. That's because we can't be sure
18052 -- there isn't an instantiation in some other unit
18053 -- where a warning is suppressed.
18055 -- We could do a little better here by checking if the
18056 -- generic unit we are inside is public, but for now
18057 -- we don't bother with that refinement.
18059 if Chars
(Argx
) = Name_Off
then
18060 Set_Specific_Warning_Off
18061 (Loc
, Name_Buffer
(1 .. Name_Len
),
18062 Config
=> Is_Configuration_Pragma
,
18063 Used
=> Inside_A_Generic
or else In_Instance
);
18065 elsif Chars
(Argx
) = Name_On
then
18066 Set_Specific_Warning_On
18067 (Loc
, Name_Buffer
(1 .. Name_Len
), Err
);
18071 ("??pragma Warnings On with no matching "
18072 & "Warnings Off", Loc
);
18081 -------------------
18082 -- Weak_External --
18083 -------------------
18085 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
18087 when Pragma_Weak_External
=> Weak_External
: declare
18092 Check_Arg_Count
(1);
18093 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18094 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18095 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18097 if Rep_Item_Too_Early
(Ent
, N
) then
18100 Ent
:= Underlying_Type
(Ent
);
18103 -- The only processing required is to link this item on to the
18104 -- list of rep items for the given entity. This is accomplished
18105 -- by the call to Rep_Item_Too_Late (when no error is detected
18106 -- and False is returned).
18108 if Rep_Item_Too_Late
(Ent
, N
) then
18111 Set_Has_Gigi_Rep_Item
(Ent
);
18115 -----------------------------
18116 -- Wide_Character_Encoding --
18117 -----------------------------
18119 -- pragma Wide_Character_Encoding (IDENTIFIER);
18121 when Pragma_Wide_Character_Encoding
=>
18124 -- Nothing to do, handled in parser. Note that we do not enforce
18125 -- configuration pragma placement, this pragma can appear at any
18126 -- place in the source, allowing mixed encodings within a single
18131 --------------------
18132 -- Unknown_Pragma --
18133 --------------------
18135 -- Should be impossible, since the case of an unknown pragma is
18136 -- separately processed before the case statement is entered.
18138 when Unknown_Pragma
=>
18139 raise Program_Error
;
18142 -- AI05-0144: detect dangerous order dependence. Disabled for now,
18143 -- until AI is formally approved.
18145 -- Check_Order_Dependence;
18148 when Pragma_Exit
=> null;
18149 end Analyze_Pragma
;
18151 ------------------------------------
18152 -- Analyze_Test_Case_In_Decl_Part --
18153 ------------------------------------
18155 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
18157 -- Install formals and push subprogram spec onto scope stack so that we
18158 -- can see the formals from the pragma.
18161 Install_Formals
(S
);
18163 -- Preanalyze the boolean expressions, we treat these as spec
18164 -- expressions (i.e. similar to a default expression).
18166 if Pragma_Name
(N
) = Name_Test_Case
then
18167 Preanalyze_CTC_Args
18169 Get_Requires_From_CTC_Pragma
(N
),
18170 Get_Ensures_From_CTC_Pragma
(N
));
18173 -- Remove the subprogram from the scope stack now that the pre-analysis
18174 -- of the expressions in the contract case or test case is done.
18177 end Analyze_Test_Case_In_Decl_Part
;
18183 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
18188 if Present
(List
) then
18189 Elmt
:= First_Elmt
(List
);
18190 while Present
(Elmt
) loop
18191 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
18194 Id
:= Entity
(Node
(Elmt
));
18197 if Id
= Item_Id
then
18212 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
18216 -- Loop through entries in check policy list
18218 PP
:= Opt
.Check_Policy_List
;
18219 while Present
(PP
) loop
18221 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
18222 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
18226 or else (Pnm
= Name_Assertion
18227 and then Is_Valid_Assertion_Kind
(Nam
))
18228 or else (Pnm
= Name_Statement_Assertions
18229 and then Nam_In
(Nam
, Name_Assert
,
18230 Name_Assert_And_Cut
,
18232 Name_Loop_Invariant
))
18234 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
18235 when Name_On | Name_Check
=>
18237 when Name_Off | Name_Ignore
=>
18238 return Name_Ignore
;
18239 when Name_Disable
=>
18240 return Name_Disable
;
18242 raise Program_Error
;
18246 PP
:= Next_Pragma
(PP
);
18251 -- If there are no specific entries that matched, then we let the
18252 -- setting of assertions govern. Note that this provides the needed
18253 -- compatibility with the RM for the cases of assertion, invariant,
18254 -- precondition, predicate, and postcondition.
18256 if Assertions_Enabled
then
18259 return Name_Ignore
;
18263 -----------------------------
18264 -- Check_Applicable_Policy --
18265 -----------------------------
18267 procedure Check_Applicable_Policy
(N
: Node_Id
) is
18271 Ename
: constant Name_Id
:= Original_Name
(N
);
18274 -- No effect if not valid assertion kind name
18276 if not Is_Valid_Assertion_Kind
(Ename
) then
18280 -- Loop through entries in check policy list
18282 PP
:= Opt
.Check_Policy_List
;
18283 while Present
(PP
) loop
18285 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
18286 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
18289 if Ename
= Pnm
or else Pnm
= Name_Assertion
then
18290 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
18293 when Name_Off | Name_Ignore
=>
18294 Set_Is_Ignored
(N
, True);
18296 when Name_Disable
=>
18297 Set_Is_Ignored
(N
, True);
18298 Set_Is_Disabled
(N
, True);
18307 PP
:= Next_Pragma
(PP
);
18311 -- If there are no specific entries that matched, then we let the
18312 -- setting of assertions govern. Note that this provides the needed
18313 -- compatibility with the RM for the cases of assertion, invariant,
18314 -- precondition, predicate, and postcondition.
18316 if not Assertions_Enabled
then
18317 Set_Is_Ignored
(N
);
18319 end Check_Applicable_Policy
;
18321 ---------------------------------------
18322 -- Collect_Subprogram_Inputs_Outputs --
18323 ---------------------------------------
18325 procedure Collect_Subprogram_Inputs_Outputs
18326 (Subp_Id
: Entity_Id
;
18327 Subp_Inputs
: in out Elist_Id
;
18328 Subp_Outputs
: in out Elist_Id
;
18329 Global_Seen
: out Boolean)
18331 procedure Collect_Global_List
18333 Mode
: Name_Id
:= Name_Input
);
18334 -- Collect all relevant items from a global list
18336 -------------------------
18337 -- Collect_Global_List --
18338 -------------------------
18340 procedure Collect_Global_List
18342 Mode
: Name_Id
:= Name_Input
)
18344 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
18345 -- Add an item to the proper subprogram input or output collection
18347 -------------------------
18348 -- Collect_Global_Item --
18349 -------------------------
18351 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
18353 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
18354 Add_Item
(Item
, Subp_Inputs
);
18357 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
18358 Add_Item
(Item
, Subp_Outputs
);
18360 end Collect_Global_Item
;
18367 -- Start of processing for Collect_Global_List
18370 -- Single global item declaration
18372 if Nkind_In
(List
, N_Identifier
, N_Selected_Component
) then
18373 Collect_Global_Item
(List
, Mode
);
18375 -- Simple global list or moded global list declaration
18378 if Present
(Expressions
(List
)) then
18379 Item
:= First
(Expressions
(List
));
18380 while Present
(Item
) loop
18381 Collect_Global_Item
(Item
, Mode
);
18386 Assoc
:= First
(Component_Associations
(List
));
18387 while Present
(Assoc
) loop
18388 Collect_Global_List
18389 (List
=> Expression
(Assoc
),
18390 Mode
=> Chars
(First
(Choices
(Assoc
))));
18395 end Collect_Global_List
;
18399 Formal
: Entity_Id
;
18403 -- Start of processing for Collect_Subprogram_Inputs_Outputs
18406 Global_Seen
:= False;
18408 -- Process all formal parameters
18410 Formal
:= First_Formal
(Subp_Id
);
18411 while Present
(Formal
) loop
18412 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
18413 Add_Item
(Formal
, Subp_Inputs
);
18416 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
18417 Add_Item
(Formal
, Subp_Outputs
);
18420 Next_Formal
(Formal
);
18423 -- If the subprogram is subject to pragma Global, traverse all global
18424 -- lists and gather the relevant items.
18426 Global
:= Find_Aspect
(Subp_Id
, Aspect_Global
);
18427 if Present
(Global
) then
18428 Global_Seen
:= True;
18430 -- Retrieve the pragma as it contains the analyzed lists
18432 Global
:= Aspect_Rep_Item
(Global
);
18433 List
:= Expression
(First
(Pragma_Argument_Associations
(Global
)));
18435 -- The pragma may not have been analyzed because of the arbitrary
18436 -- declaration order of aspects. Make sure that it is analyzed for
18437 -- the purposes of item extraction.
18439 if not Analyzed
(List
) then
18440 Analyze_Global_In_Decl_Part
(Global
);
18443 -- Nothing to be done for a null global list
18445 if Nkind
(List
) /= N_Null
then
18446 Collect_Global_List
(List
);
18449 end Collect_Subprogram_Inputs_Outputs
;
18451 ---------------------------------
18452 -- Delay_Config_Pragma_Analyze --
18453 ---------------------------------
18455 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
18457 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
18458 Name_Priority_Specific_Dispatching
);
18459 end Delay_Config_Pragma_Analyze
;
18461 -----------------------------
18462 -- Find_Related_Subprogram --
18463 -----------------------------
18465 function Find_Related_Subprogram
18467 Check_Duplicates
: Boolean := False) return Node_Id
18469 Context
: constant Node_Id
:= Parent
(Prag
);
18470 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
18472 Subp_Decl
: Node_Id
;
18475 pragma Assert
(Nkind
(Prag
) = N_Pragma
);
18477 -- If the pragma comes from an aspect, then what we want is the
18478 -- declaration to which the aspect is attached, i.e. its parent.
18480 if Present
(Corresponding_Aspect
(Prag
)) then
18481 return Parent
(Corresponding_Aspect
(Prag
));
18484 -- Otherwise the pragma must be a list element, and the first thing to
18485 -- do is to position past any previous pragmas or generated code. What
18486 -- we are doing here is looking for the preceding declaration. This is
18487 -- also where we will check for a duplicate pragma.
18489 pragma Assert
(Is_List_Member
(Prag
));
18493 Elmt
:= Prev
(Elmt
);
18494 exit when No
(Elmt
);
18496 -- Typically want we will want is the declaration original node. But
18497 -- for the generic subprogram case, don't go to to the original node,
18498 -- which is the unanalyzed tree: we need to attach the pre- and post-
18499 -- conditions to the analyzed version at this point. They propagate
18500 -- to the original tree when analyzing the corresponding body.
18502 if Nkind
(Elmt
) not in N_Generic_Declaration
then
18503 Subp_Decl
:= Original_Node
(Elmt
);
18508 -- Skip prior pragmas
18510 if Nkind
(Subp_Decl
) = N_Pragma
then
18511 if Check_Duplicates
and then Pragma_Name
(Subp_Decl
) = Nam
then
18512 Error_Msg_Name_1
:= Nam
;
18513 Error_Msg_Sloc
:= Sloc
(Subp_Decl
);
18514 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
18517 -- Skip internally generated code
18519 elsif not Comes_From_Source
(Subp_Decl
) then
18522 -- Otherwise we have a declaration to return
18529 -- We fell through, which means there was no declaration preceding the
18530 -- pragma (either it was the first element of the list, or we only had
18531 -- other pragmas and generated code before it).
18533 -- The pragma is associated with a library-level subprogram
18535 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
18536 return Unit
(Parent
(Context
));
18538 -- The pragma appears inside the declarative part of a subprogram body
18540 elsif Nkind
(Context
) = N_Subprogram_Body
then
18543 -- Otherwise no subprogram found, return original pragma
18548 end Find_Related_Subprogram
;
18550 -------------------------
18551 -- Get_Base_Subprogram --
18552 -------------------------
18554 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
18555 Result
: Entity_Id
;
18558 -- Follow subprogram renaming chain
18562 if Is_Subprogram
(Result
)
18564 Nkind
(Parent
(Declaration_Node
(Result
))) =
18565 N_Subprogram_Renaming_Declaration
18566 and then Present
(Alias
(Result
))
18568 Result
:= Alias
(Result
);
18572 end Get_Base_Subprogram
;
18574 -----------------------
18575 -- Get_SPARK_Mode_Id --
18576 -----------------------
18578 function Get_SPARK_Mode_Id
(N
: Name_Id
) return SPARK_Mode_Id
is
18580 if N
= Name_On
then
18582 elsif N
= Name_Off
then
18584 elsif N
= Name_Auto
then
18587 -- Any other argument is erroneous
18590 raise Program_Error
;
18592 end Get_SPARK_Mode_Id
;
18594 -----------------------
18595 -- Get_SPARK_Mode_Id --
18596 -----------------------
18598 function Get_SPARK_Mode_Id
(N
: Node_Id
) return SPARK_Mode_Id
is
18603 (Nkind
(N
) = N_Pragma
18604 and then Present
(Pragma_Argument_Associations
(N
)));
18606 Mode
:= First
(Pragma_Argument_Associations
(N
));
18608 return Get_SPARK_Mode_Id
(Chars
(Get_Pragma_Arg
(Mode
)));
18609 end Get_SPARK_Mode_Id
;
18615 procedure Initialize
is
18620 -----------------------------
18621 -- Is_Config_Static_String --
18622 -----------------------------
18624 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
18626 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
18627 -- This is an internal recursive function that is just like the outer
18628 -- function except that it adds the string to the name buffer rather
18629 -- than placing the string in the name buffer.
18631 ------------------------------
18632 -- Add_Config_Static_String --
18633 ------------------------------
18635 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
18642 if Nkind
(N
) = N_Op_Concat
then
18643 if Add_Config_Static_String
(Left_Opnd
(N
)) then
18644 N
:= Right_Opnd
(N
);
18650 if Nkind
(N
) /= N_String_Literal
then
18651 Error_Msg_N
("string literal expected for pragma argument", N
);
18655 for J
in 1 .. String_Length
(Strval
(N
)) loop
18656 C
:= Get_String_Char
(Strval
(N
), J
);
18658 if not In_Character_Range
(C
) then
18660 ("string literal contains invalid wide character",
18661 Sloc
(N
) + 1 + Source_Ptr
(J
));
18665 Add_Char_To_Name_Buffer
(Get_Character
(C
));
18670 end Add_Config_Static_String
;
18672 -- Start of processing for Is_Config_Static_String
18677 return Add_Config_Static_String
(Arg
);
18678 end Is_Config_Static_String
;
18680 -------------------------------
18681 -- Is_Elaboration_SPARK_Mode --
18682 -------------------------------
18684 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
18687 (Nkind
(N
) = N_Pragma
18688 and then Pragma_Name
(N
) = Name_SPARK_Mode
18689 and then Is_List_Member
(N
));
18691 -- Pragma SPARK_Mode affects the elaboration of a package body when it
18692 -- appears in the statement part of the body.
18695 Present
(Parent
(N
))
18696 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
18697 and then List_Containing
(N
) = Statements
(Parent
(N
))
18698 and then Present
(Parent
(Parent
(N
)))
18699 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
18700 end Is_Elaboration_SPARK_Mode
;
18702 -----------------------------------------
18703 -- Is_Non_Significant_Pragma_Reference --
18704 -----------------------------------------
18706 -- This function makes use of the following static table which indicates
18707 -- whether appearance of some name in a given pragma is to be considered
18708 -- as a reference for the purposes of warnings about unreferenced objects.
18710 -- -1 indicates that references in any argument position are significant
18711 -- 0 indicates that appearance in any argument is not significant
18712 -- +n indicates that appearance as argument n is significant, but all
18713 -- other arguments are not significant
18714 -- 99 special processing required (e.g. for pragma Check)
18716 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
18717 (Pragma_AST_Entry
=> -1,
18718 Pragma_Abort_Defer
=> -1,
18719 Pragma_Abstract_State
=> -1,
18720 Pragma_Ada_83
=> -1,
18721 Pragma_Ada_95
=> -1,
18722 Pragma_Ada_05
=> -1,
18723 Pragma_Ada_2005
=> -1,
18724 Pragma_Ada_12
=> -1,
18725 Pragma_Ada_2012
=> -1,
18726 Pragma_All_Calls_Remote
=> -1,
18727 Pragma_Annotate
=> -1,
18728 Pragma_Assert
=> -1,
18729 Pragma_Assert_And_Cut
=> -1,
18730 Pragma_Assertion_Policy
=> 0,
18731 Pragma_Assume
=> -1,
18732 Pragma_Assume_No_Invalid_Values
=> 0,
18733 Pragma_Attribute_Definition
=> +3,
18734 Pragma_Asynchronous
=> -1,
18735 Pragma_Atomic
=> 0,
18736 Pragma_Atomic_Components
=> 0,
18737 Pragma_Attach_Handler
=> -1,
18738 Pragma_Check
=> 99,
18739 Pragma_Check_Float_Overflow
=> 0,
18740 Pragma_Check_Name
=> 0,
18741 Pragma_Check_Policy
=> 0,
18742 Pragma_CIL_Constructor
=> -1,
18743 Pragma_CPP_Class
=> 0,
18744 Pragma_CPP_Constructor
=> 0,
18745 Pragma_CPP_Virtual
=> 0,
18746 Pragma_CPP_Vtable
=> 0,
18748 Pragma_C_Pass_By_Copy
=> 0,
18749 Pragma_Comment
=> 0,
18750 Pragma_Common_Object
=> -1,
18751 Pragma_Compile_Time_Error
=> -1,
18752 Pragma_Compile_Time_Warning
=> -1,
18753 Pragma_Compiler_Unit
=> 0,
18754 Pragma_Complete_Representation
=> 0,
18755 Pragma_Complex_Representation
=> 0,
18756 Pragma_Component_Alignment
=> -1,
18757 Pragma_Contract_Cases
=> -1,
18758 Pragma_Controlled
=> 0,
18759 Pragma_Convention
=> 0,
18760 Pragma_Convention_Identifier
=> 0,
18761 Pragma_Debug
=> -1,
18762 Pragma_Debug_Policy
=> 0,
18763 Pragma_Detect_Blocking
=> -1,
18764 Pragma_Default_Storage_Pool
=> -1,
18765 Pragma_Depends
=> -1,
18766 Pragma_Disable_Atomic_Synchronization
=> -1,
18767 Pragma_Discard_Names
=> 0,
18768 Pragma_Dispatching_Domain
=> -1,
18769 Pragma_Elaborate
=> -1,
18770 Pragma_Elaborate_All
=> -1,
18771 Pragma_Elaborate_Body
=> -1,
18772 Pragma_Elaboration_Checks
=> -1,
18773 Pragma_Eliminate
=> -1,
18774 Pragma_Enable_Atomic_Synchronization
=> -1,
18775 Pragma_Export
=> -1,
18776 Pragma_Export_Exception
=> -1,
18777 Pragma_Export_Function
=> -1,
18778 Pragma_Export_Object
=> -1,
18779 Pragma_Export_Procedure
=> -1,
18780 Pragma_Export_Value
=> -1,
18781 Pragma_Export_Valued_Procedure
=> -1,
18782 Pragma_Extend_System
=> -1,
18783 Pragma_Extensions_Allowed
=> -1,
18784 Pragma_External
=> -1,
18785 Pragma_Favor_Top_Level
=> -1,
18786 Pragma_External_Name_Casing
=> -1,
18787 Pragma_Fast_Math
=> -1,
18788 Pragma_Finalize_Storage_Only
=> 0,
18789 Pragma_Float_Representation
=> 0,
18790 Pragma_Global
=> -1,
18791 Pragma_Ident
=> -1,
18792 Pragma_Implementation_Defined
=> -1,
18793 Pragma_Implemented
=> -1,
18794 Pragma_Implicit_Packing
=> 0,
18795 Pragma_Import
=> +2,
18796 Pragma_Import_Exception
=> 0,
18797 Pragma_Import_Function
=> 0,
18798 Pragma_Import_Object
=> 0,
18799 Pragma_Import_Procedure
=> 0,
18800 Pragma_Import_Valued_Procedure
=> 0,
18801 Pragma_Independent
=> 0,
18802 Pragma_Independent_Components
=> 0,
18803 Pragma_Initialize_Scalars
=> -1,
18804 Pragma_Inline
=> 0,
18805 Pragma_Inline_Always
=> 0,
18806 Pragma_Inline_Generic
=> 0,
18807 Pragma_Inspection_Point
=> -1,
18808 Pragma_Interface
=> +2,
18809 Pragma_Interface_Name
=> +2,
18810 Pragma_Interrupt_Handler
=> -1,
18811 Pragma_Interrupt_Priority
=> -1,
18812 Pragma_Interrupt_State
=> -1,
18813 Pragma_Invariant
=> -1,
18814 Pragma_Java_Constructor
=> -1,
18815 Pragma_Java_Interface
=> -1,
18816 Pragma_Keep_Names
=> 0,
18817 Pragma_License
=> -1,
18818 Pragma_Link_With
=> -1,
18819 Pragma_Linker_Alias
=> -1,
18820 Pragma_Linker_Constructor
=> -1,
18821 Pragma_Linker_Destructor
=> -1,
18822 Pragma_Linker_Options
=> -1,
18823 Pragma_Linker_Section
=> -1,
18825 Pragma_Lock_Free
=> -1,
18826 Pragma_Locking_Policy
=> -1,
18827 Pragma_Long_Float
=> -1,
18828 Pragma_Loop_Invariant
=> -1,
18829 Pragma_Loop_Optimize
=> -1,
18830 Pragma_Loop_Variant
=> -1,
18831 Pragma_Machine_Attribute
=> -1,
18833 Pragma_Main_Storage
=> -1,
18834 Pragma_Memory_Size
=> -1,
18835 Pragma_No_Return
=> 0,
18836 Pragma_No_Body
=> 0,
18837 Pragma_No_Inline
=> 0,
18838 Pragma_No_Run_Time
=> -1,
18839 Pragma_No_Strict_Aliasing
=> -1,
18840 Pragma_Normalize_Scalars
=> -1,
18841 Pragma_Obsolescent
=> 0,
18842 Pragma_Optimize
=> -1,
18843 Pragma_Optimize_Alignment
=> -1,
18844 Pragma_Overflow_Mode
=> 0,
18845 Pragma_Overriding_Renamings
=> 0,
18846 Pragma_Ordered
=> 0,
18849 Pragma_Partition_Elaboration_Policy
=> -1,
18850 Pragma_Passive
=> -1,
18851 Pragma_Preelaborable_Initialization
=> -1,
18852 Pragma_Polling
=> -1,
18853 Pragma_Persistent_BSS
=> 0,
18854 Pragma_Postcondition
=> -1,
18855 Pragma_Precondition
=> -1,
18856 Pragma_Predicate
=> -1,
18857 Pragma_Preelaborate
=> -1,
18858 Pragma_Preelaborate_05
=> -1,
18859 Pragma_Priority
=> -1,
18860 Pragma_Priority_Specific_Dispatching
=> -1,
18861 Pragma_Profile
=> 0,
18862 Pragma_Profile_Warnings
=> 0,
18863 Pragma_Propagate_Exceptions
=> -1,
18864 Pragma_Psect_Object
=> -1,
18866 Pragma_Pure_05
=> -1,
18867 Pragma_Pure_12
=> -1,
18868 Pragma_Pure_Function
=> -1,
18869 Pragma_Queuing_Policy
=> -1,
18870 Pragma_Rational
=> -1,
18871 Pragma_Ravenscar
=> -1,
18872 Pragma_Relative_Deadline
=> -1,
18873 Pragma_Remote_Access_Type
=> -1,
18874 Pragma_Remote_Call_Interface
=> -1,
18875 Pragma_Remote_Types
=> -1,
18876 Pragma_Restricted_Run_Time
=> -1,
18877 Pragma_Restriction_Warnings
=> -1,
18878 Pragma_Restrictions
=> -1,
18879 Pragma_Reviewable
=> -1,
18880 Pragma_Short_Circuit_And_Or
=> -1,
18881 Pragma_Share_Generic
=> -1,
18882 Pragma_Shared
=> -1,
18883 Pragma_Shared_Passive
=> -1,
18884 Pragma_Short_Descriptors
=> 0,
18885 Pragma_Simple_Storage_Pool_Type
=> 0,
18886 Pragma_Source_File_Name
=> -1,
18887 Pragma_Source_File_Name_Project
=> -1,
18888 Pragma_Source_Reference
=> -1,
18889 Pragma_SPARK_Mode
=> 0,
18890 Pragma_Storage_Size
=> -1,
18891 Pragma_Storage_Unit
=> -1,
18892 Pragma_Static_Elaboration_Desired
=> -1,
18893 Pragma_Stream_Convert
=> -1,
18894 Pragma_Style_Checks
=> -1,
18895 Pragma_Subtitle
=> -1,
18896 Pragma_Suppress
=> 0,
18897 Pragma_Suppress_Exception_Locations
=> 0,
18898 Pragma_Suppress_All
=> -1,
18899 Pragma_Suppress_Debug_Info
=> 0,
18900 Pragma_Suppress_Initialization
=> 0,
18901 Pragma_System_Name
=> -1,
18902 Pragma_Task_Dispatching_Policy
=> -1,
18903 Pragma_Task_Info
=> -1,
18904 Pragma_Task_Name
=> -1,
18905 Pragma_Task_Storage
=> 0,
18906 Pragma_Test_Case
=> -1,
18907 Pragma_Thread_Local_Storage
=> 0,
18908 Pragma_Time_Slice
=> -1,
18909 Pragma_Title
=> -1,
18910 Pragma_Unchecked_Union
=> 0,
18911 Pragma_Unimplemented_Unit
=> -1,
18912 Pragma_Universal_Aliasing
=> -1,
18913 Pragma_Universal_Data
=> -1,
18914 Pragma_Unmodified
=> -1,
18915 Pragma_Unreferenced
=> -1,
18916 Pragma_Unreferenced_Objects
=> -1,
18917 Pragma_Unreserve_All_Interrupts
=> -1,
18918 Pragma_Unsuppress
=> 0,
18919 Pragma_Use_VADS_Size
=> -1,
18920 Pragma_Validity_Checks
=> -1,
18921 Pragma_Volatile
=> 0,
18922 Pragma_Volatile_Components
=> 0,
18923 Pragma_Warnings
=> -1,
18924 Pragma_Weak_External
=> -1,
18925 Pragma_Wide_Character_Encoding
=> 0,
18926 Unknown_Pragma
=> 0);
18928 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
18937 if Nkind
(P
) /= N_Pragma_Argument_Association
then
18941 Id
:= Get_Pragma_Id
(Parent
(P
));
18942 C
:= Sig_Flags
(Id
);
18954 -- For pragma Check, the first argument is not significant,
18955 -- the second and the third (if present) arguments are
18958 when Pragma_Check
=>
18960 P
= First
(Pragma_Argument_Associations
(Parent
(P
)));
18963 raise Program_Error
;
18967 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
18968 for J
in 1 .. C
- 1 loop
18976 return A
= P
; -- is this wrong way round ???
18979 end Is_Non_Significant_Pragma_Reference
;
18981 ------------------------------
18982 -- Is_Pragma_String_Literal --
18983 ------------------------------
18985 -- This function returns true if the corresponding pragma argument is a
18986 -- static string expression. These are the only cases in which string
18987 -- literals can appear as pragma arguments. We also allow a string literal
18988 -- as the first argument to pragma Assert (although it will of course
18989 -- always generate a type error).
18991 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
18992 Pragn
: constant Node_Id
:= Parent
(Par
);
18993 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
18994 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
19000 N
:= First
(Assoc
);
19007 if Pname
= Name_Assert
then
19010 elsif Pname
= Name_Export
then
19013 elsif Pname
= Name_Ident
then
19016 elsif Pname
= Name_Import
then
19019 elsif Pname
= Name_Interface_Name
then
19022 elsif Pname
= Name_Linker_Alias
then
19025 elsif Pname
= Name_Linker_Section
then
19028 elsif Pname
= Name_Machine_Attribute
then
19031 elsif Pname
= Name_Source_File_Name
then
19034 elsif Pname
= Name_Source_Reference
then
19037 elsif Pname
= Name_Title
then
19040 elsif Pname
= Name_Subtitle
then
19046 end Is_Pragma_String_Literal
;
19048 ---------------------------
19049 -- Is_Private_SPARK_Mode --
19050 ---------------------------
19052 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
19055 (Nkind
(N
) = N_Pragma
19056 and then Pragma_Name
(N
) = Name_SPARK_Mode
19057 and then Is_List_Member
(N
));
19059 -- For pragma SPARK_Mode to be private, it has to appear in the private
19060 -- declarations of a package.
19063 Present
(Parent
(N
))
19064 and then Nkind
(Parent
(N
)) = N_Package_Specification
19065 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
19066 end Is_Private_SPARK_Mode
;
19068 -----------------------------
19069 -- Is_Valid_Assertion_Kind --
19070 -----------------------------
19072 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
19079 Name_Static_Predicate |
19080 Name_Dynamic_Predicate |
19085 Name_Type_Invariant |
19086 Name_uType_Invariant |
19090 Name_Assert_And_Cut |
19092 Name_Contract_Cases |
19096 Name_Loop_Invariant |
19097 Name_Loop_Variant |
19098 Name_Postcondition |
19099 Name_Precondition |
19101 Name_Statement_Assertions
=> return True;
19103 when others => return False;
19105 end Is_Valid_Assertion_Kind
;
19107 -----------------------------------------
19108 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
19109 -----------------------------------------
19111 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl
(Decl
: Node_Id
) is
19112 Aspects
: constant List_Id
:= New_List
;
19113 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
19114 Or_Decl
: constant Node_Id
:= Original_Node
(Decl
);
19116 Original_Aspects
: List_Id
;
19117 -- To capture global references, a copy of the created aspects must be
19118 -- inserted in the original tree.
19121 Prag_Arg_Ass
: Node_Id
;
19122 Prag_Id
: Pragma_Id
;
19125 -- Check for any PPC pragmas that appear within Decl
19127 Prag
:= Next
(Decl
);
19128 while Nkind
(Prag
) = N_Pragma
loop
19129 Prag_Id
:= Get_Pragma_Id
(Chars
(Pragma_Identifier
(Prag
)));
19132 when Pragma_Postcondition | Pragma_Precondition
=>
19133 Prag_Arg_Ass
:= First
(Pragma_Argument_Associations
(Prag
));
19135 -- Make an aspect from any PPC pragma
19137 Append_To
(Aspects
,
19138 Make_Aspect_Specification
(Loc
,
19140 Make_Identifier
(Loc
, Chars
(Pragma_Identifier
(Prag
))),
19142 Copy_Separate_Tree
(Expression
(Prag_Arg_Ass
))));
19144 -- Generate the analysis information in the pragma expression
19145 -- and then set the pragma node analyzed to avoid any further
19148 Analyze
(Expression
(Prag_Arg_Ass
));
19149 Set_Analyzed
(Prag
, True);
19151 when others => null;
19157 -- Set all new aspects into the generic declaration node
19159 if Is_Non_Empty_List
(Aspects
) then
19161 -- Create the list of aspects to be inserted in the original tree
19163 Original_Aspects
:= Copy_Separate_List
(Aspects
);
19165 -- Check if Decl already has aspects
19167 -- Attach the new lists of aspects to both the generic copy and the
19170 if Has_Aspects
(Decl
) then
19171 Append_List
(Aspects
, Aspect_Specifications
(Decl
));
19172 Append_List
(Original_Aspects
, Aspect_Specifications
(Or_Decl
));
19175 Set_Parent
(Aspects
, Decl
);
19176 Set_Aspect_Specifications
(Decl
, Aspects
);
19177 Set_Parent
(Original_Aspects
, Or_Decl
);
19178 Set_Aspect_Specifications
(Or_Decl
, Original_Aspects
);
19181 end Make_Aspect_For_PPC_In_Gen_Sub_Decl
;
19183 -------------------
19184 -- Original_Name --
19185 -------------------
19187 function Original_Name
(N
: Node_Id
) return Name_Id
is
19192 pragma Assert
(Nkind_In
(N
, N_Aspect_Specification
, N_Pragma
));
19195 if Is_Rewrite_Substitution
(Pras
)
19196 and then Nkind
(Original_Node
(Pras
)) = N_Pragma
19198 Pras
:= Original_Node
(Pras
);
19201 -- Case where we came from aspect specication
19203 if Nkind
(Pras
) = N_Pragma
and then From_Aspect_Specification
(Pras
) then
19204 Pras
:= Corresponding_Aspect
(Pras
);
19207 -- Get name from aspect or pragma
19209 if Nkind
(Pras
) = N_Pragma
then
19210 Name
:= Pragma_Name
(Pras
);
19212 Name
:= Chars
(Identifier
(Pras
));
19215 -- Deal with 'Class
19217 if Class_Present
(Pras
) then
19220 -- Names that need converting to special _xxx form
19222 when Name_Pre
=> Name
:= Name_uPre
;
19223 when Name_Post
=> Name
:= Name_uPost
;
19224 when Name_Invariant
=> Name
:= Name_uInvariant
;
19225 when Name_Type_Invariant
=> Name
:= Name_uType_Invariant
;
19227 -- Names already in special _xxx form (leave them alone)
19229 when Name_uPre
=> null;
19230 when Name_uPost
=> null;
19231 when Name_uInvariant
=> null;
19232 when Name_uType_Invariant
=> null;
19234 -- Anything else is impossible with Class_Present set True
19236 when others => raise Program_Error
;
19243 -------------------------
19244 -- Preanalyze_CTC_Args --
19245 -------------------------
19247 procedure Preanalyze_CTC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
) is
19249 -- Preanalyze the boolean expressions, we treat these as spec
19250 -- expressions (i.e. similar to a default expression).
19252 if Present
(Arg_Req
) then
19253 Preanalyze_Assert_Expression
19254 (Get_Pragma_Arg
(Arg_Req
), Standard_Boolean
);
19256 -- In ASIS mode, for a pragma generated from a source aspect, also
19257 -- analyze the original aspect expression.
19259 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
19260 Preanalyze_Assert_Expression
19261 (Original_Node
(Get_Pragma_Arg
(Arg_Req
)), Standard_Boolean
);
19265 if Present
(Arg_Ens
) then
19266 Preanalyze_Assert_Expression
19267 (Get_Pragma_Arg
(Arg_Ens
), Standard_Boolean
);
19269 -- In ASIS mode, for a pragma generated from a source aspect, also
19270 -- analyze the original aspect expression.
19272 if ASIS_Mode
and then Present
(Corresponding_Aspect
(N
)) then
19273 Preanalyze_Assert_Expression
19274 (Original_Node
(Get_Pragma_Arg
(Arg_Ens
)), Standard_Boolean
);
19277 end Preanalyze_CTC_Args
;
19279 --------------------------------------
19280 -- Process_Compilation_Unit_Pragmas --
19281 --------------------------------------
19283 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
19285 -- A special check for pragma Suppress_All, a very strange DEC pragma,
19286 -- strange because it comes at the end of the unit. Rational has the
19287 -- same name for a pragma, but treats it as a program unit pragma, In
19288 -- GNAT we just decide to allow it anywhere at all. If it appeared then
19289 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
19290 -- node, and we insert a pragma Suppress (All_Checks) at the start of
19291 -- the context clause to ensure the correct processing.
19293 if Has_Pragma_Suppress_All
(N
) then
19294 Prepend_To
(Context_Items
(N
),
19295 Make_Pragma
(Sloc
(N
),
19296 Chars
=> Name_Suppress
,
19297 Pragma_Argument_Associations
=> New_List
(
19298 Make_Pragma_Argument_Association
(Sloc
(N
),
19299 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
19302 -- Nothing else to do at the current time!
19304 end Process_Compilation_Unit_Pragmas
;
19306 ----------------------------
19307 -- Rewrite_Assertion_Kind --
19308 ----------------------------
19310 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
19314 if Nkind
(N
) = N_Attribute_Reference
19315 and then Attribute_Name
(N
) = Name_Class
19316 and then Nkind
(Prefix
(N
)) = N_Identifier
19318 case Chars
(Prefix
(N
)) is
19323 when Name_Type_Invariant
=>
19324 Nam
:= Name_uType_Invariant
;
19325 when Name_Invariant
=>
19326 Nam
:= Name_uInvariant
;
19331 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
19333 end Rewrite_Assertion_Kind
;
19344 -----------------------------------
19345 -- Requires_Profile_Installation --
19346 -----------------------------------
19348 function Requires_Profile_Installation
19350 Subp
: Node_Id
) return Boolean
19353 -- When aspects Depends and Global are associated with a subprogram
19354 -- declaration, their corresponding pragmas are analyzed at the end of
19355 -- the declarative part. This is done out of context, therefore the
19356 -- formals must be installed in visibility.
19358 if Nkind
(Subp
) = N_Subprogram_Declaration
then
19361 -- When aspects Depends and Global are associated with a subprogram body
19362 -- which is also a compilation unit, their corresponding pragmas appear
19363 -- in the Pragmas_After list. The Pragmas_After collection is analyzed
19364 -- out of context and the formals must be installed in visibility. This
19365 -- does not apply when the pragma is a source construct.
19367 elsif Nkind
(Subp
) = N_Subprogram_Body
then
19368 if Nkind
(Parent
(Subp
)) = N_Compilation_Unit
then
19369 return Present
(Corresponding_Aspect
(Prag
));
19374 -- In all other cases the two corresponding pragmas are analyzed in
19375 -- context and the formals are already visibile.
19380 end Requires_Profile_Installation
;
19382 --------------------------------
19383 -- Set_Encoded_Interface_Name --
19384 --------------------------------
19386 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
19387 Str
: constant String_Id
:= Strval
(S
);
19388 Len
: constant Int
:= String_Length
(Str
);
19393 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
19396 -- Stores encoded value of character code CC. The encoding we use an
19397 -- underscore followed by four lower case hex digits.
19403 procedure Encode
is
19405 Store_String_Char
(Get_Char_Code
('_'));
19407 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
19409 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
19411 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
19413 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
19416 -- Start of processing for Set_Encoded_Interface_Name
19419 -- If first character is asterisk, this is a link name, and we leave it
19420 -- completely unmodified. We also ignore null strings (the latter case
19421 -- happens only in error cases) and no encoding should occur for Java or
19422 -- AAMP interface names.
19425 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
19426 or else VM_Target
/= No_VM
19427 or else AAMP_On_Target
19429 Set_Interface_Name
(E
, S
);
19434 CC
:= Get_String_Char
(Str
, J
);
19436 exit when not In_Character_Range
(CC
);
19438 C
:= Get_Character
(CC
);
19440 exit when C
/= '_' and then C
/= '$'
19441 and then C
not in '0' .. '9'
19442 and then C
not in 'a' .. 'z'
19443 and then C
not in 'A' .. 'Z';
19446 Set_Interface_Name
(E
, S
);
19454 -- Here we need to encode. The encoding we use as follows:
19455 -- three underscores + four hex digits (lower case)
19459 for J
in 1 .. String_Length
(Str
) loop
19460 CC
:= Get_String_Char
(Str
, J
);
19462 if not In_Character_Range
(CC
) then
19465 C
:= Get_Character
(CC
);
19467 if C
= '_' or else C
= '$'
19468 or else C
in '0' .. '9'
19469 or else C
in 'a' .. 'z'
19470 or else C
in 'A' .. 'Z'
19472 Store_String_Char
(CC
);
19479 Set_Interface_Name
(E
,
19480 Make_String_Literal
(Sloc
(S
),
19481 Strval
=> End_String
));
19483 end Set_Encoded_Interface_Name
;
19485 -------------------
19486 -- Set_Unit_Name --
19487 -------------------
19489 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
19494 if Nkind
(N
) = N_Identifier
19495 and then Nkind
(With_Item
) = N_Identifier
19497 Set_Entity
(N
, Entity
(With_Item
));
19499 elsif Nkind
(N
) = N_Selected_Component
then
19500 Change_Selected_Component_To_Expanded_Name
(N
);
19501 Set_Entity
(N
, Entity
(With_Item
));
19502 Set_Entity
(Selector_Name
(N
), Entity
(N
));
19504 Pref
:= Prefix
(N
);
19505 Scop
:= Scope
(Entity
(N
));
19506 while Nkind
(Pref
) = N_Selected_Component
loop
19507 Change_Selected_Component_To_Expanded_Name
(Pref
);
19508 Set_Entity
(Selector_Name
(Pref
), Scop
);
19509 Set_Entity
(Pref
, Scop
);
19510 Pref
:= Prefix
(Pref
);
19511 Scop
:= Scope
(Scop
);
19514 Set_Entity
(Pref
, Scop
);