1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 -- This unit contains the semantic processing for all pragmas, both language
28 -- and implementation defined. For most pragmas, the parser only does the
29 -- most basic job of checking the syntax, so Sem_Prag also contains the code
30 -- to complete the syntax checks. Certain pragmas are handled partially or
31 -- completely by the parser (see Par.Prag for further details).
33 with Atree
; use Atree
;
34 with Casing
; use Casing
;
35 with Csets
; use Csets
;
36 with Debug
; use Debug
;
37 with Einfo
; use Einfo
;
38 with Elists
; use Elists
;
39 with Errout
; use Errout
;
40 with Exp_Dist
; use Exp_Dist
;
41 with Hostparm
; use Hostparm
;
43 with Lib
.Writ
; use Lib
.Writ
;
44 with Lib
.Xref
; use Lib
.Xref
;
45 with Namet
; use Namet
;
46 with Nlists
; use Nlists
;
47 with Nmake
; use Nmake
;
49 with Output
; use Output
;
50 with Restrict
; use Restrict
;
51 with Rident
; use Rident
;
52 with Rtsfind
; use Rtsfind
;
54 with Sem_Ch3
; use Sem_Ch3
;
55 with Sem_Ch8
; use Sem_Ch8
;
56 with Sem_Ch13
; use Sem_Ch13
;
57 with Sem_Disp
; use Sem_Disp
;
58 with Sem_Dist
; use Sem_Dist
;
59 with Sem_Elim
; use Sem_Elim
;
60 with Sem_Eval
; use Sem_Eval
;
61 with Sem_Intr
; use Sem_Intr
;
62 with Sem_Mech
; use Sem_Mech
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Type
; use Sem_Type
;
65 with Sem_Util
; use Sem_Util
;
66 with Sem_VFpt
; use Sem_VFpt
;
67 with Stand
; use Stand
;
68 with Sinfo
; use Sinfo
;
69 with Sinfo
.CN
; use Sinfo
.CN
;
70 with Sinput
; use Sinput
;
71 with Snames
; use Snames
;
72 with Stringt
; use Stringt
;
73 with Stylesw
; use Stylesw
;
75 with Targparm
; use Targparm
;
76 with Tbuild
; use Tbuild
;
78 with Uintp
; use Uintp
;
79 with Urealp
; use Urealp
;
80 with Validsw
; use Validsw
;
82 with GNAT
.Spelling_Checker
; use GNAT
.Spelling_Checker
;
84 package body Sem_Prag
is
86 ----------------------------------------------
87 -- Common Handling of Import-Export Pragmas --
88 ----------------------------------------------
90 -- In the following section, a number of Import_xxx and Export_xxx
91 -- pragmas are defined by GNAT. These are compatible with the DEC
92 -- pragmas of the same name, and all have the following common
93 -- form and processing:
96 -- [Internal =>] LOCAL_NAME,
97 -- [, [External =>] EXTERNAL_SYMBOL]
98 -- [, other optional parameters ]);
101 -- [Internal =>] LOCAL_NAME,
102 -- [, [External =>] EXTERNAL_SYMBOL]
103 -- [, other optional parameters ]);
105 -- EXTERNAL_SYMBOL ::=
107 -- | static_string_EXPRESSION
109 -- The internal LOCAL_NAME designates the entity that is imported or
110 -- exported, and must refer to an entity in the current declarative
111 -- part (as required by the rules for LOCAL_NAME).
113 -- The external linker name is designated by the External parameter
114 -- if given, or the Internal parameter if not (if there is no External
115 -- parameter, the External parameter is a copy of the Internal name).
117 -- If the External parameter is given as a string, then this string
118 -- is treated as an external name (exactly as though it had been given
119 -- as an External_Name parameter for a normal Import pragma).
121 -- If the External parameter is given as an identifier (or there is no
122 -- External parameter, so that the Internal identifier is used), then
123 -- the external name is the characters of the identifier, translated
124 -- to all upper case letters for OpenVMS versions of GNAT, and to all
125 -- lower case letters for all other versions
127 -- Note: the external name specified or implied by any of these special
128 -- Import_xxx or Export_xxx pragmas override an external or link name
129 -- specified in a previous Import or Export pragma.
131 -- Note: these and all other DEC-compatible GNAT pragmas allow full
132 -- use of named notation, following the standard rules for subprogram
133 -- calls, i.e. parameters can be given in any order if named notation
134 -- is used, and positional and named notation can be mixed, subject to
135 -- the rule that all positional parameters must appear first.
137 -- Note: All these pragmas are implemented exactly following the DEC
138 -- design and implementation and are intended to be fully compatible
139 -- with the use of these pragmas in the DEC Ada compiler.
141 --------------------------------------------
142 -- Checking for Duplicated External Names --
143 --------------------------------------------
145 -- It is suspicious if two separate Export pragmas use the same external
146 -- name. The following table is used to diagnose this situation so that
147 -- an appropriate warning can be issued.
149 -- The Node_Id stored is for the N_String_Literal node created to
150 -- hold the value of the external name. The Sloc of this node is
151 -- used to cross-reference the location of the duplication.
153 package Externals
is new Table
.Table
(
154 Table_Component_Type
=> Node_Id
,
155 Table_Index_Type
=> Int
,
156 Table_Low_Bound
=> 0,
157 Table_Initial
=> 100,
158 Table_Increment
=> 100,
159 Table_Name
=> "Name_Externals");
161 -------------------------------------
162 -- Local Subprograms and Variables --
163 -------------------------------------
165 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
166 -- This routine is used for possible casing adjustment of an explicit
167 -- external name supplied as a string literal (the node N), according
168 -- to the casing requirement of Opt.External_Name_Casing. If this is
169 -- set to As_Is, then the string literal is returned unchanged, but if
170 -- it is set to Uppercase or Lowercase, then a new string literal with
171 -- appropriate casing is constructed.
173 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
174 -- If Def_Id refers to a renamed subprogram, then the base subprogram
175 -- (the original one, following the renaming chain) is returned.
176 -- Otherwise the entity is returned unchanged. Should be in Einfo???
178 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
179 -- Place semantic information on the argument of an Elaborate or
180 -- Elaborate_All pragma. Entity name for unit and its parents is
181 -- taken from item in previous with_clause that mentions the unit.
183 -------------------------------
184 -- Adjust_External_Name_Case --
185 -------------------------------
187 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
191 -- Adjust case of literal if required
193 if Opt
.External_Name_Exp_Casing
= As_Is
then
197 -- Copy existing string
203 for J
in 1 .. String_Length
(Strval
(N
)) loop
204 CC
:= Get_String_Char
(Strval
(N
), J
);
206 if Opt
.External_Name_Exp_Casing
= Uppercase
207 and then CC
>= Get_Char_Code
('a')
208 and then CC
<= Get_Char_Code
('z')
210 Store_String_Char
(CC
- 32);
212 elsif Opt
.External_Name_Exp_Casing
= Lowercase
213 and then CC
>= Get_Char_Code
('A')
214 and then CC
<= Get_Char_Code
('Z')
216 Store_String_Char
(CC
+ 32);
219 Store_String_Char
(CC
);
224 Make_String_Literal
(Sloc
(N
),
225 Strval
=> End_String
);
227 end Adjust_External_Name_Case
;
233 procedure Analyze_Pragma
(N
: Node_Id
) is
234 Loc
: constant Source_Ptr
:= Sloc
(N
);
237 Pragma_Exit
: exception;
238 -- This exception is used to exit pragma processing completely. It
239 -- is used when an error is detected, and in other situations where
240 -- it is known that no further processing is required.
243 -- Number of pragma argument associations
249 -- First four pragma arguments (pragma argument association nodes,
250 -- or Empty if the corresponding argument does not exist).
252 type Name_List
is array (Natural range <>) of Name_Id
;
253 type Args_List
is array (Natural range <>) of Node_Id
;
254 -- Types used for arguments to Check_Arg_Order and Gather_Associations
256 procedure Check_Ada_83_Warning
;
257 -- Issues a warning message for the current pragma if operating in Ada
258 -- 83 mode (used for language pragmas that are not a standard part of
259 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
262 procedure Check_Arg_Count
(Required
: Nat
);
263 -- Check argument count for pragma is equal to given parameter.
264 -- If not, then issue an error message and raise Pragma_Exit.
266 -- Note: all routines whose name is Check_Arg_Is_xxx take an
267 -- argument Arg which can either be a pragma argument association,
268 -- in which case the check is applied to the expression of the
269 -- association or an expression directly.
271 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
272 -- Check that an argument has the right form for an EXTERNAL_NAME
273 -- parameter of an extended import/export pragma. The rule is that
274 -- the name must be an identifier or string literal (in Ada 83 mode)
275 -- or a static string expression (in Ada 95 mode).
277 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
278 -- Check the specified argument Arg to make sure that it is an
279 -- identifier. If not give error and raise Pragma_Exit.
281 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
282 -- Check the specified argument Arg to make sure that it is an
283 -- integer literal. If not give error and raise Pragma_Exit.
285 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
286 -- Check the specified argument Arg to make sure that it has the
287 -- proper syntactic form for a local name and meets the semantic
288 -- requirements for a local name. The local name is analyzed as
289 -- part of the processing for this call. In addition, the local
290 -- name is required to represent an entity at the library level.
292 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
293 -- Check the specified argument Arg to make sure that it has the
294 -- proper syntactic form for a local name and meets the semantic
295 -- requirements for a local name. The local name is analyzed as
296 -- part of the processing for this call.
298 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
299 -- Check the specified argument Arg to make sure that it is a valid
300 -- locking policy name. If not give error and raise Pragma_Exit.
302 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
303 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
, N3
: Name_Id
);
304 -- Check the specified argument Arg to make sure that it is an
305 -- identifier whose name matches either N1 or N2 (or N3 if present).
306 -- If not then give error and raise Pragma_Exit.
308 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
309 -- Check the specified argument Arg to make sure that it is a valid
310 -- queuing policy name. If not give error and raise Pragma_Exit.
312 procedure Check_Arg_Is_Static_Expression
315 -- Check the specified argument Arg to make sure that it is a static
316 -- expression of the given type (i.e. it will be analyzed and resolved
317 -- using this type, which can be any valid argument to Resolve, e.g.
318 -- Any_Integer is OK). If not, given error and raise Pragma_Exit.
320 procedure Check_Arg_Is_String_Literal
(Arg
: Node_Id
);
321 -- Check the specified argument Arg to make sure that it is a
322 -- string literal. If not give error and raise Pragma_Exit
324 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
325 -- Check the specified argument Arg to make sure that it is a valid
326 -- valid task dispatching policy name. If not give error and raise
329 procedure Check_Arg_Order
(Names
: Name_List
);
330 -- Checks for an instance of two arguments with identifiers for the
331 -- current pragma which are not in the sequence indicated by Names,
332 -- and if so, generates a fatal message about bad order of arguments.
334 procedure Check_At_Least_N_Arguments
(N
: Nat
);
335 -- Check there are at least N arguments present
337 procedure Check_At_Most_N_Arguments
(N
: Nat
);
338 -- Check there are no more than N arguments present
340 procedure Check_Component
(Comp
: Node_Id
);
341 -- Examine Unchecked_Union component for correct use of per-object
342 -- constrained subtypes.
344 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
345 -- Nam is an N_String_Literal node containing the external name set
346 -- by an Import or Export pragma (or extended Import or Export pragma).
347 -- This procedure checks for possible duplications if this is the
348 -- export case, and if found, issues an appropriate error message.
350 procedure Check_First_Subtype
(Arg
: Node_Id
);
351 -- Checks that Arg, whose expression is an entity name referencing
352 -- a subtype, does not reference a type that is not a first subtype.
354 procedure Check_In_Main_Program
;
355 -- Common checks for pragmas that appear within a main program
356 -- (Priority, Main_Storage, Time_Slice).
358 procedure Check_Interrupt_Or_Attach_Handler
;
359 -- Common processing for first argument of pragma Interrupt_Handler
360 -- or pragma Attach_Handler.
362 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
363 -- Check that pragma appears in a declarative part, or in a package
364 -- specification, i.e. that it does not occur in a statement sequence
367 procedure Check_No_Identifier
(Arg
: Node_Id
);
368 -- Checks that the given argument does not have an identifier. If
369 -- an identifier is present, then an error message is issued, and
370 -- Pragma_Exit is raised.
372 procedure Check_No_Identifiers
;
373 -- Checks that none of the arguments to the pragma has an identifier.
374 -- If any argument has an identifier, then an error message is issued,
375 -- and Pragma_Exit is raised.
377 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
378 -- Checks if the given argument has an identifier, and if so, requires
379 -- it to match the given identifier name. If there is a non-matching
380 -- identifier, then an error message is given and Error_Pragmas raised.
382 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
383 -- Checks if the given argument has an identifier, and if so, requires
384 -- it to match the given identifier name. If there is a non-matching
385 -- identifier, then an error message is given and Error_Pragmas raised.
386 -- In this version of the procedure, the identifier name is given as
387 -- a string with lower case letters.
389 procedure Check_Static_Constraint
(Constr
: Node_Id
);
390 -- Constr is a constraint from an N_Subtype_Indication node from a
391 -- component constraint in an Unchecked_Union type. This routine checks
392 -- that the constraint is static as required by the restrictions for
395 procedure Check_Valid_Configuration_Pragma
;
396 -- Legality checks for placement of a configuration pragma
398 procedure Check_Valid_Library_Unit_Pragma
;
399 -- Legality checks for library unit pragmas. A special case arises for
400 -- pragmas in generic instances that come from copies of the original
401 -- library unit pragmas in the generic templates. In the case of other
402 -- than library level instantiations these can appear in contexts which
403 -- would normally be invalid (they only apply to the original template
404 -- and to library level instantiations), and they are simply ignored,
405 -- which is implemented by rewriting them as null statements.
407 procedure Check_Variant
(Variant
: Node_Id
);
408 -- Check Unchecked_Union variant for lack of nested variants and
409 -- presence of at least one component.
411 procedure Error_Pragma
(Msg
: String);
412 pragma No_Return
(Error_Pragma
);
413 -- Outputs error message for current pragma. The message contains an %
414 -- that will be replaced with the pragma name, and the flag is placed
415 -- on the pragma itself. Pragma_Exit is then raised.
417 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
418 pragma No_Return
(Error_Pragma_Arg
);
419 -- Outputs error message for current pragma. The message may contain
420 -- a % that will be replaced with the pragma name. The parameter Arg
421 -- may either be a pragma argument association, in which case the flag
422 -- is placed on the expression of this association, or an expression,
423 -- in which case the flag is placed directly on the expression. The
424 -- message is placed using Error_Msg_N, so the message may also contain
425 -- an & insertion character which will reference the given Arg value.
426 -- After placing the message, Pragma_Exit is raised.
428 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
429 pragma No_Return
(Error_Pragma_Arg
);
430 -- Similar to above form of Error_Pragma_Arg except that two messages
431 -- are provided, the second is a continuation comment starting with \.
433 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
434 pragma No_Return
(Error_Pragma_Arg_Ident
);
435 -- Outputs error message for current pragma. The message may contain
436 -- a % that will be replaced with the pragma name. The parameter Arg
437 -- must be a pragma argument association with a non-empty identifier
438 -- (i.e. its Chars field must be set), and the error message is placed
439 -- on the identifier. The message is placed using Error_Msg_N so
440 -- the message may also contain an & insertion character which will
441 -- reference the identifier. After placing the message, Pragma_Exit
444 function Find_Lib_Unit_Name
return Entity_Id
;
445 -- Used for a library unit pragma to find the entity to which the
446 -- library unit pragma applies, returns the entity found.
448 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
449 -- If the pragma is a compilation unit pragma, the id must denote the
450 -- compilation unit in the same compilation, and the pragma must appear
451 -- in the list of preceding or trailing pragmas. If it is a program
452 -- unit pragma that is not a compilation unit pragma, then the
453 -- identifier must be visible.
455 function Find_Unique_Parameterless_Procedure
457 Arg
: Node_Id
) return Entity_Id
;
458 -- Used for a procedure pragma to find the unique parameterless
459 -- procedure identified by Name, returns it if it exists, otherwise
460 -- errors out and uses Arg as the pragma argument for the message.
462 procedure Gather_Associations
464 Args
: out Args_List
);
465 -- This procedure is used to gather the arguments for a pragma that
466 -- permits arbitrary ordering of parameters using the normal rules
467 -- for named and positional parameters. The Names argument is a list
468 -- of Name_Id values that corresponds to the allowed pragma argument
469 -- association identifiers in order. The result returned in Args is
470 -- a list of corresponding expressions that are the pragma arguments.
471 -- Note that this is a list of expressions, not of pragma argument
472 -- associations (Gather_Associations has completely checked all the
473 -- optional identifiers when it returns). An entry in Args is Empty
474 -- on return if the corresponding argument is not present.
476 function Get_Pragma_Arg
(Arg
: Node_Id
) return Node_Id
;
477 -- All the routines that check pragma arguments take either a pragma
478 -- argument association (in which case the expression of the argument
479 -- association is checked), or the expression directly. The function
480 -- Get_Pragma_Arg is a utility used to deal with these two cases. If
481 -- Arg is a pragma argument association node, then its expression is
482 -- returned, otherwise Arg is returned unchanged.
484 procedure GNAT_Pragma
;
485 -- Called for all GNAT defined pragmas to note the use of the feature,
486 -- and also check the relevant restriction (No_Implementation_Pragmas).
488 function Is_Before_First_Decl
489 (Pragma_Node
: Node_Id
;
490 Decls
: List_Id
) return Boolean;
491 -- Return True if Pragma_Node is before the first declarative item in
492 -- Decls where Decls is the list of declarative items.
494 function Is_Configuration_Pragma
return Boolean;
495 -- Deterermines if the placement of the current pragma is appropriate
496 -- for a configuration pragma (precedes the current compilation unit)
498 procedure Pragma_Misplaced
;
499 -- Issue fatal error message for misplaced pragma
501 procedure Process_Atomic_Shared_Volatile
;
502 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
503 -- Shared is an obsolete Ada 83 pragma, treated as being identical
504 -- in effect to pragma Atomic.
506 procedure Process_Convention
(C
: out Convention_Id
; E
: out Entity_Id
);
507 -- Common procesing for Convention, Interface, Import and Export.
508 -- Checks first two arguments of pragma, and sets the appropriate
509 -- convention value in the specified entity or entities. On return
510 -- C is the convention, E is the referenced entity.
512 procedure Process_Extended_Import_Export_Exception_Pragma
513 (Arg_Internal
: Node_Id
;
514 Arg_External
: Node_Id
;
517 -- Common processing for the pragmas Import/Export_Exception.
518 -- The three arguments correspond to the three named parameters of
519 -- the pragma. An argument is empty if the corresponding parameter
520 -- is not present in the pragma.
522 procedure Process_Extended_Import_Export_Object_Pragma
523 (Arg_Internal
: Node_Id
;
524 Arg_External
: Node_Id
;
526 -- Common processing for the pragmass Import/Export_Object.
527 -- The three arguments correspond to the three named parameters
528 -- of the pragmas. An argument is empty if the corresponding
529 -- parameter is not present in the pragma.
531 procedure Process_Extended_Import_Export_Internal_Arg
532 (Arg_Internal
: Node_Id
:= Empty
);
533 -- Common processing for all extended Import and Export pragmas. The
534 -- argument is the pragma parameter for the Internal argument. If
535 -- Arg_Internal is empty or inappropriate, an error message is posted.
536 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
537 -- set to identify the referenced entity.
539 procedure Process_Extended_Import_Export_Subprogram_Pragma
540 (Arg_Internal
: Node_Id
;
541 Arg_External
: Node_Id
;
542 Arg_Parameter_Types
: Node_Id
;
543 Arg_Result_Type
: Node_Id
:= Empty
;
544 Arg_Mechanism
: Node_Id
;
545 Arg_Result_Mechanism
: Node_Id
:= Empty
;
546 Arg_First_Optional_Parameter
: Node_Id
:= Empty
);
547 -- Common processing for all extended Import and Export pragmas
548 -- applying to subprograms. The caller omits any arguments that do
549 -- bnot apply to the pragma in question (for example, Arg_Result_Type
550 -- can be non-Empty only in the Import_Function and Export_Function
551 -- cases). The argument names correspond to the allowed pragma
552 -- association identifiers.
554 procedure Process_Generic_List
;
555 -- Common processing for Share_Generic and Inline_Generic
557 procedure Process_Import_Or_Interface
;
558 -- Common processing for Import of Interface
560 procedure Process_Inline
(Active
: Boolean);
561 -- Common processing for Inline and Inline_Always. The parameter
562 -- indicates if the inline pragma is active, i.e. if it should
563 -- actually cause inlining to occur.
565 procedure Process_Interface_Name
566 (Subprogram_Def
: Entity_Id
;
569 -- Given the last two arguments of pragma Import, pragma Export, or
570 -- pragma Interface_Name, performs validity checks and sets the
571 -- Interface_Name field of the given subprogram entity to the
572 -- appropriate external or link name, depending on the arguments
573 -- given. Ext_Arg is always present, but Link_Arg may be missing.
574 -- Note that Ext_Arg may represent the Link_Name if Link_Arg is
575 -- missing, and appropriate named notation is used for Ext_Arg.
576 -- If neither Ext_Arg nor Link_Arg is present, the interface name
577 -- is set to the default from the subprogram name.
579 procedure Process_Interrupt_Or_Attach_Handler
;
580 -- Common processing for Interrupt and Attach_Handler pragmas
582 procedure Process_Restrictions_Or_Restriction_Warnings
;
583 -- Common processing for Restrictions and Restriction_Warnings pragmas
585 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
586 -- Common processing for Suppress and Unsuppress. The boolean parameter
587 -- Suppress_Case is True for the Suppress case, and False for the
590 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
591 -- This procedure sets the Is_Exported flag for the given entity,
592 -- checking that the entity was not previously imported. Arg is
593 -- the argument that specified the entity. A check is also made
594 -- for exporting inappropriate entities.
596 procedure Set_Extended_Import_Export_External_Name
597 (Internal_Ent
: Entity_Id
;
598 Arg_External
: Node_Id
);
599 -- Common processing for all extended import export pragmas. The first
600 -- argument, Internal_Ent, is the internal entity, which has already
601 -- been checked for validity by the caller. Arg_External is from the
602 -- Import or Export pragma, and may be null if no External parameter
603 -- was present. If Arg_External is present and is a non-null string
604 -- (a null string is treated as the default), then the Interface_Name
605 -- field of Internal_Ent is set appropriately.
607 procedure Set_Imported
(E
: Entity_Id
);
608 -- This procedure sets the Is_Imported flag for the given entity,
609 -- checking that it is not previously exported or imported.
611 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
612 -- Mech is a parameter passing mechanism (see Import_Function syntax
613 -- for MECHANISM_NAME). This routine checks that the mechanism argument
614 -- has the right form, and if not issues an error message. If the
615 -- argument has the right form then the Mechanism field of Ent is
616 -- set appropriately.
618 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
619 -- Activate the set of configuration pragmas and restrictions that
620 -- make up the Ravenscar Profile. N is the corresponding pragma
621 -- node, which is used for error messages on any constructs
622 -- that violate the profile.
624 --------------------------
625 -- Check_Ada_83_Warning --
626 --------------------------
628 procedure Check_Ada_83_Warning
is
630 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
631 Error_Msg_N
("(Ada 83) pragma& is non-standard?", N
);
633 end Check_Ada_83_Warning
;
635 ---------------------
636 -- Check_Arg_Count --
637 ---------------------
639 procedure Check_Arg_Count
(Required
: Nat
) is
641 if Arg_Count
/= Required
then
642 Error_Pragma
("wrong number of arguments for pragma%");
646 --------------------------------
647 -- Check_Arg_Is_External_Name --
648 --------------------------------
650 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
651 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
654 if Nkind
(Argx
) = N_Identifier
then
658 Analyze_And_Resolve
(Argx
, Standard_String
);
660 if Is_OK_Static_Expression
(Argx
) then
663 elsif Etype
(Argx
) = Any_Type
then
666 -- An interesting special case, if we have a string literal and
667 -- we are in Ada 83 mode, then we allow it even though it will
668 -- not be flagged as static. This allows expected Ada 83 mode
669 -- use of external names which are string literals, even though
670 -- technically these are not static in Ada 83.
672 elsif Ada_Version
= Ada_83
673 and then Nkind
(Argx
) = N_String_Literal
677 -- Static expression that raises Constraint_Error. This has
678 -- already been flagged, so just exit from pragma processing.
680 elsif Is_Static_Expression
(Argx
) then
683 -- Here we have a real error (non-static expression)
686 Error_Msg_Name_1
:= Chars
(N
);
688 ("argument for pragma% must be a identifier or " &
689 "static string expression!", Argx
);
693 end Check_Arg_Is_External_Name
;
695 -----------------------------
696 -- Check_Arg_Is_Identifier --
697 -----------------------------
699 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
700 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
702 if Nkind
(Argx
) /= N_Identifier
then
704 ("argument for pragma% must be identifier", Argx
);
706 end Check_Arg_Is_Identifier
;
708 ----------------------------------
709 -- Check_Arg_Is_Integer_Literal --
710 ----------------------------------
712 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
713 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
715 if Nkind
(Argx
) /= N_Integer_Literal
then
717 ("argument for pragma% must be integer literal", Argx
);
719 end Check_Arg_Is_Integer_Literal
;
721 -------------------------------------------
722 -- Check_Arg_Is_Library_Level_Local_Name --
723 -------------------------------------------
727 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
728 -- | library_unit_NAME
730 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
732 Check_Arg_Is_Local_Name
(Arg
);
734 if not Is_Library_Level_Entity
(Entity
(Expression
(Arg
)))
735 and then Comes_From_Source
(N
)
738 ("argument for pragma% must be library level entity", Arg
);
740 end Check_Arg_Is_Library_Level_Local_Name
;
742 -----------------------------
743 -- Check_Arg_Is_Local_Name --
744 -----------------------------
748 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
749 -- | library_unit_NAME
751 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
752 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
757 if Nkind
(Argx
) not in N_Direct_Name
758 and then (Nkind
(Argx
) /= N_Attribute_Reference
759 or else Present
(Expressions
(Argx
))
760 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
761 and then (not Is_Entity_Name
(Argx
)
762 or else not Is_Compilation_Unit
(Entity
(Argx
)))
764 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
767 if Is_Entity_Name
(Argx
)
768 and then Scope
(Entity
(Argx
)) /= Current_Scope
771 ("pragma% argument must be in same declarative part", Arg
);
773 end Check_Arg_Is_Local_Name
;
775 ---------------------------------
776 -- Check_Arg_Is_Locking_Policy --
777 ---------------------------------
779 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
780 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
783 Check_Arg_Is_Identifier
(Argx
);
785 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
787 ("& is not a valid locking policy name", Argx
);
789 end Check_Arg_Is_Locking_Policy
;
791 -------------------------
792 -- Check_Arg_Is_One_Of --
793 -------------------------
795 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
796 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
799 Check_Arg_Is_Identifier
(Argx
);
801 if Chars
(Argx
) /= N1
and then Chars
(Argx
) /= N2
then
802 Error_Msg_Name_2
:= N1
;
803 Error_Msg_Name_3
:= N2
;
804 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
806 end Check_Arg_Is_One_Of
;
808 procedure Check_Arg_Is_One_Of
810 N1
, N2
, N3
: Name_Id
)
812 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
815 Check_Arg_Is_Identifier
(Argx
);
817 if Chars
(Argx
) /= N1
818 and then Chars
(Argx
) /= N2
819 and then Chars
(Argx
) /= N3
821 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
823 end Check_Arg_Is_One_Of
;
825 ---------------------------------
826 -- Check_Arg_Is_Queuing_Policy --
827 ---------------------------------
829 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
830 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
833 Check_Arg_Is_Identifier
(Argx
);
835 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
837 ("& is not a valid queuing policy name", Argx
);
839 end Check_Arg_Is_Queuing_Policy
;
841 ------------------------------------
842 -- Check_Arg_Is_Static_Expression --
843 ------------------------------------
845 procedure Check_Arg_Is_Static_Expression
849 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
852 Analyze_And_Resolve
(Argx
, Typ
);
854 if Is_OK_Static_Expression
(Argx
) then
857 elsif Etype
(Argx
) = Any_Type
then
860 -- An interesting special case, if we have a string literal and
861 -- we are in Ada 83 mode, then we allow it even though it will
862 -- not be flagged as static. This allows the use of Ada 95
863 -- pragmas like Import in Ada 83 mode. They will of course be
864 -- flagged with warnings as usual, but will not cause errors.
866 elsif Ada_Version
= Ada_83
867 and then Nkind
(Argx
) = N_String_Literal
871 -- Static expression that raises Constraint_Error. This has
872 -- already been flagged, so just exit from pragma processing.
874 elsif Is_Static_Expression
(Argx
) then
877 -- Finally, we have a real error
880 Error_Msg_Name_1
:= Chars
(N
);
882 ("argument for pragma% must be a static expression!", Argx
);
885 end Check_Arg_Is_Static_Expression
;
887 ---------------------------------
888 -- Check_Arg_Is_String_Literal --
889 ---------------------------------
891 procedure Check_Arg_Is_String_Literal
(Arg
: Node_Id
) is
892 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
894 if Nkind
(Argx
) /= N_String_Literal
then
896 ("argument for pragma% must be string literal", Argx
);
898 end Check_Arg_Is_String_Literal
;
900 ------------------------------------------
901 -- Check_Arg_Is_Task_Dispatching_Policy --
902 ------------------------------------------
904 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
905 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
908 Check_Arg_Is_Identifier
(Argx
);
910 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
912 ("& is not a valid task dispatching policy name", Argx
);
914 end Check_Arg_Is_Task_Dispatching_Policy
;
916 ---------------------
917 -- Check_Arg_Order --
918 ---------------------
920 procedure Check_Arg_Order
(Names
: Name_List
) is
923 Highest_So_Far
: Natural := 0;
924 -- Highest index in Names seen do far
928 for J
in 1 .. Arg_Count
loop
929 if Chars
(Arg
) /= No_Name
then
930 for K
in Names
'Range loop
931 if Chars
(Arg
) = Names
(K
) then
932 if K
< Highest_So_Far
then
933 Error_Msg_Name_1
:= Chars
(N
);
935 ("parameters out of order for pragma%", Arg
);
936 Error_Msg_Name_1
:= Names
(K
);
937 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
938 Error_Msg_N
("\% must appear before %", Arg
);
952 --------------------------------
953 -- Check_At_Least_N_Arguments --
954 --------------------------------
956 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
958 if Arg_Count
< N
then
959 Error_Pragma
("too few arguments for pragma%");
961 end Check_At_Least_N_Arguments
;
963 -------------------------------
964 -- Check_At_Most_N_Arguments --
965 -------------------------------
967 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
970 if Arg_Count
> N
then
974 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
977 end Check_At_Most_N_Arguments
;
979 ---------------------
980 -- Check_Component --
981 ---------------------
983 procedure Check_Component
(Comp
: Node_Id
) is
985 if Nkind
(Comp
) = N_Component_Declaration
then
987 Sindic
: constant Node_Id
:=
988 Subtype_Indication
(Component_Definition
(Comp
));
991 if Nkind
(Sindic
) = N_Subtype_Indication
then
993 -- Ada 2005 (AI-216): If a component subtype is subject to
994 -- a per-object constraint, then the component type shall
995 -- be an Unchecked_Union.
997 if Has_Per_Object_Constraint
(Defining_Identifier
(Comp
))
999 not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
1001 Error_Msg_N
("component subtype subject to per-object" &
1002 " constraint must be an Unchecked_Union", Comp
);
1007 end Check_Component
;
1009 ----------------------------------
1010 -- Check_Duplicated_Export_Name --
1011 ----------------------------------
1013 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
1014 String_Val
: constant String_Id
:= Strval
(Nam
);
1017 -- We are only interested in the export case, and in the case of
1018 -- generics, it is the instance, not the template, that is the
1019 -- problem (the template will generate a warning in any case).
1021 if not Inside_A_Generic
1022 and then (Prag_Id
= Pragma_Export
1024 Prag_Id
= Pragma_Export_Procedure
1026 Prag_Id
= Pragma_Export_Valued_Procedure
1028 Prag_Id
= Pragma_Export_Function
)
1030 for J
in Externals
.First
.. Externals
.Last
loop
1031 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
1032 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
1033 Error_Msg_N
("external name duplicates name given#", Nam
);
1038 Externals
.Append
(Nam
);
1040 end Check_Duplicated_Export_Name
;
1042 -------------------------
1043 -- Check_First_Subtype --
1044 -------------------------
1046 procedure Check_First_Subtype
(Arg
: Node_Id
) is
1047 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1049 if not Is_First_Subtype
(Entity
(Argx
)) then
1051 ("pragma% cannot apply to subtype", Argx
);
1053 end Check_First_Subtype
;
1055 ---------------------------
1056 -- Check_In_Main_Program --
1057 ---------------------------
1059 procedure Check_In_Main_Program
is
1060 P
: constant Node_Id
:= Parent
(N
);
1063 -- Must be at in subprogram body
1065 if Nkind
(P
) /= N_Subprogram_Body
then
1066 Error_Pragma
("% pragma allowed only in subprogram");
1068 -- Otherwise warn if obviously not main program
1070 elsif Present
(Parameter_Specifications
(Specification
(P
)))
1071 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
1073 Error_Msg_Name_1
:= Chars
(N
);
1075 ("?pragma% is only effective in main program", N
);
1077 end Check_In_Main_Program
;
1079 ---------------------------------------
1080 -- Check_Interrupt_Or_Attach_Handler --
1081 ---------------------------------------
1083 procedure Check_Interrupt_Or_Attach_Handler
is
1084 Arg1_X
: constant Node_Id
:= Expression
(Arg1
);
1085 Handler_Proc
, Proc_Scope
: Entity_Id
;
1090 if Prag_Id
= Pragma_Interrupt_Handler
then
1091 Check_Restriction
(No_Dynamic_Attachment
, N
);
1094 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
1095 Proc_Scope
:= Scope
(Handler_Proc
);
1097 -- On AAMP only, a pragma Interrupt_Handler is supported for
1098 -- nonprotected parameterless procedures.
1100 if not AAMP_On_Target
1101 or else Prag_Id
= Pragma_Attach_Handler
1103 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
1105 ("argument of pragma% must be protected procedure", Arg1
);
1108 if Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
)) then
1109 Error_Pragma
("pragma% must be in protected definition");
1113 if not Is_Library_Level_Entity
(Proc_Scope
)
1114 or else (AAMP_On_Target
1115 and then not Is_Library_Level_Entity
(Handler_Proc
))
1118 ("argument for pragma% must be library level entity", Arg1
);
1120 end Check_Interrupt_Or_Attach_Handler
;
1122 -------------------------------------------
1123 -- Check_Is_In_Decl_Part_Or_Package_Spec --
1124 -------------------------------------------
1126 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
1135 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
1138 elsif Nkind
(P
) = N_Package_Specification
then
1141 elsif Nkind
(P
) = N_Block_Statement
then
1144 -- Note: the following tests seem a little peculiar, because
1145 -- they test for bodies, but if we were in the statement part
1146 -- of the body, we would already have hit the handled statement
1147 -- sequence, so the only way we get here is by being in the
1148 -- declarative part of the body.
1150 elsif Nkind
(P
) = N_Subprogram_Body
1151 or else Nkind
(P
) = N_Package_Body
1152 or else Nkind
(P
) = N_Task_Body
1153 or else Nkind
(P
) = N_Entry_Body
1161 Error_Pragma
("pragma% is not in declarative part or package spec");
1162 end Check_Is_In_Decl_Part_Or_Package_Spec
;
1164 -------------------------
1165 -- Check_No_Identifier --
1166 -------------------------
1168 procedure Check_No_Identifier
(Arg
: Node_Id
) is
1170 if Chars
(Arg
) /= No_Name
then
1171 Error_Pragma_Arg_Ident
1172 ("pragma% does not permit identifier& here", Arg
);
1174 end Check_No_Identifier
;
1176 --------------------------
1177 -- Check_No_Identifiers --
1178 --------------------------
1180 procedure Check_No_Identifiers
is
1183 if Arg_Count
> 0 then
1185 while Present
(Arg_Node
) loop
1186 Check_No_Identifier
(Arg_Node
);
1190 end Check_No_Identifiers
;
1192 -------------------------------
1193 -- Check_Optional_Identifier --
1194 -------------------------------
1196 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
1198 if Present
(Arg
) and then Chars
(Arg
) /= No_Name
then
1199 if Chars
(Arg
) /= Id
then
1200 Error_Msg_Name_1
:= Chars
(N
);
1201 Error_Msg_Name_2
:= Id
;
1202 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
1206 end Check_Optional_Identifier
;
1208 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
1210 Name_Buffer
(1 .. Id
'Length) := Id
;
1211 Name_Len
:= Id
'Length;
1212 Check_Optional_Identifier
(Arg
, Name_Find
);
1213 end Check_Optional_Identifier
;
1215 -----------------------------
1216 -- Check_Static_Constraint --
1217 -----------------------------
1219 -- Note: for convenience in writing this procedure, in addition to
1220 -- the officially (i.e. by spec) allowed argument which is always
1221 -- a constraint, it also allows ranges and discriminant associations.
1222 -- Above is not clear ???
1224 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
1226 --------------------
1227 -- Require_Static --
1228 --------------------
1230 procedure Require_Static
(E
: Node_Id
);
1231 -- Require given expression to be static expression
1233 procedure Require_Static
(E
: Node_Id
) is
1235 if not Is_OK_Static_Expression
(E
) then
1236 Flag_Non_Static_Expr
1237 ("non-static constraint not allowed in Unchecked_Union!", E
);
1242 -- Start of processing for Check_Static_Constraint
1245 case Nkind
(Constr
) is
1246 when N_Discriminant_Association
=>
1247 Require_Static
(Expression
(Constr
));
1250 Require_Static
(Low_Bound
(Constr
));
1251 Require_Static
(High_Bound
(Constr
));
1253 when N_Attribute_Reference
=>
1254 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
1255 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
1257 when N_Range_Constraint
=>
1258 Check_Static_Constraint
(Range_Expression
(Constr
));
1260 when N_Index_Or_Discriminant_Constraint
=>
1264 IDC
:= First
(Constraints
(Constr
));
1265 while Present
(IDC
) loop
1266 Check_Static_Constraint
(IDC
);
1274 end Check_Static_Constraint
;
1276 --------------------------------------
1277 -- Check_Valid_Configuration_Pragma --
1278 --------------------------------------
1280 -- A configuration pragma must appear in the context clause of
1281 -- a compilation unit, at the start of the list (i.e. only other
1282 -- pragmas may precede it).
1284 procedure Check_Valid_Configuration_Pragma
is
1286 if not Is_Configuration_Pragma
then
1287 Error_Pragma
("incorrect placement for configuration pragma%");
1289 end Check_Valid_Configuration_Pragma
;
1291 -------------------------------------
1292 -- Check_Valid_Library_Unit_Pragma --
1293 -------------------------------------
1295 procedure Check_Valid_Library_Unit_Pragma
is
1297 Parent_Node
: Node_Id
;
1298 Unit_Name
: Entity_Id
;
1299 Unit_Kind
: Node_Kind
;
1300 Unit_Node
: Node_Id
;
1301 Sindex
: Source_File_Index
;
1304 if not Is_List_Member
(N
) then
1308 Plist
:= List_Containing
(N
);
1309 Parent_Node
:= Parent
(Plist
);
1311 if Parent_Node
= Empty
then
1314 -- Case of pragma appearing after a compilation unit. In this
1315 -- case it must have an argument with the corresponding name
1316 -- and must be part of the following pragmas of its parent.
1318 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
1319 if Plist
/= Pragmas_After
(Parent_Node
) then
1322 elsif Arg_Count
= 0 then
1324 ("argument required if outside compilation unit");
1327 Check_No_Identifiers
;
1328 Check_Arg_Count
(1);
1329 Unit_Node
:= Unit
(Parent
(Parent_Node
));
1330 Unit_Kind
:= Nkind
(Unit_Node
);
1332 Analyze
(Expression
(Arg1
));
1334 if Unit_Kind
= N_Generic_Subprogram_Declaration
1335 or else Unit_Kind
= N_Subprogram_Declaration
1337 Unit_Name
:= Defining_Entity
(Unit_Node
);
1339 elsif Unit_Kind
= N_Function_Instantiation
1340 or else Unit_Kind
= N_Package_Instantiation
1341 or else Unit_Kind
= N_Procedure_Instantiation
1343 Unit_Name
:= Defining_Entity
(Unit_Node
);
1346 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
1349 if Chars
(Unit_Name
) /=
1350 Chars
(Entity
(Expression
(Arg1
)))
1353 ("pragma% argument is not current unit name", Arg1
);
1356 if Ekind
(Unit_Name
) = E_Package
1357 and then Present
(Renamed_Entity
(Unit_Name
))
1359 Error_Pragma
("pragma% not allowed for renamed package");
1363 -- Pragma appears other than after a compilation unit
1366 -- Here we check for the generic instantiation case and also
1367 -- for the case of processing a generic formal package. We
1368 -- detect these cases by noting that the Sloc on the node
1369 -- does not belong to the current compilation unit.
1371 Sindex
:= Source_Index
(Current_Sem_Unit
);
1373 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
1374 Rewrite
(N
, Make_Null_Statement
(Loc
));
1377 -- If before first declaration, the pragma applies to the
1378 -- enclosing unit, and the name if present must be this name.
1380 elsif Is_Before_First_Decl
(N
, Plist
) then
1381 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
1382 Unit_Kind
:= Nkind
(Unit_Node
);
1384 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
1387 elsif Unit_Kind
= N_Subprogram_Body
1388 and then not Acts_As_Spec
(Unit_Node
)
1392 elsif Nkind
(Parent_Node
) = N_Package_Body
then
1395 elsif Nkind
(Parent_Node
) = N_Package_Specification
1396 and then Plist
= Private_Declarations
(Parent_Node
)
1400 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
1401 or else Nkind
(Parent_Node
)
1402 = N_Generic_Subprogram_Declaration
)
1403 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
1407 elsif Arg_Count
> 0 then
1408 Analyze
(Expression
(Arg1
));
1410 if Entity
(Expression
(Arg1
)) /= Current_Scope
then
1412 ("name in pragma% must be enclosing unit", Arg1
);
1415 -- It is legal to have no argument in this context
1421 -- Error if not before first declaration. This is because a
1422 -- library unit pragma argument must be the name of a library
1423 -- unit (RM 10.1.5(7)), but the only names permitted in this
1424 -- context are (RM 10.1.5(6)) names of subprogram declarations,
1425 -- generic subprogram declarations or generic instantiations.
1429 ("pragma% misplaced, must be before first declaration");
1433 end Check_Valid_Library_Unit_Pragma
;
1439 procedure Check_Variant
(Variant
: Node_Id
) is
1440 Clist
: constant Node_Id
:= Component_List
(Variant
);
1444 if Present
(Variant_Part
(Clist
)) then
1446 ("Unchecked_Union may not have nested variants",
1447 Variant_Part
(Clist
));
1450 if not Is_Non_Empty_List
(Component_Items
(Clist
)) then
1452 ("Unchecked_Union may not have empty component list",
1457 Comp
:= First
(Component_Items
(Clist
));
1458 while Present
(Comp
) loop
1459 Check_Component
(Comp
);
1468 procedure Error_Pragma
(Msg
: String) is
1470 Error_Msg_Name_1
:= Chars
(N
);
1471 Error_Msg_N
(Msg
, N
);
1475 ----------------------
1476 -- Error_Pragma_Arg --
1477 ----------------------
1479 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
1481 Error_Msg_Name_1
:= Chars
(N
);
1482 Error_Msg_N
(Msg
, Get_Pragma_Arg
(Arg
));
1484 end Error_Pragma_Arg
;
1486 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
1488 Error_Msg_Name_1
:= Chars
(N
);
1489 Error_Msg_N
(Msg1
, Get_Pragma_Arg
(Arg
));
1490 Error_Pragma_Arg
(Msg2
, Arg
);
1491 end Error_Pragma_Arg
;
1493 ----------------------------
1494 -- Error_Pragma_Arg_Ident --
1495 ----------------------------
1497 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
1499 Error_Msg_Name_1
:= Chars
(N
);
1500 Error_Msg_N
(Msg
, Arg
);
1502 end Error_Pragma_Arg_Ident
;
1504 ------------------------
1505 -- Find_Lib_Unit_Name --
1506 ------------------------
1508 function Find_Lib_Unit_Name
return Entity_Id
is
1510 -- Return inner compilation unit entity, for case of nested
1511 -- categorization pragmas. This happens in generic unit.
1513 if Nkind
(Parent
(N
)) = N_Package_Specification
1514 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
1516 return Defining_Entity
(Parent
(N
));
1518 return Current_Scope
;
1520 end Find_Lib_Unit_Name
;
1522 ----------------------------
1523 -- Find_Program_Unit_Name --
1524 ----------------------------
1526 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
1527 Unit_Name
: Entity_Id
;
1528 Unit_Kind
: Node_Kind
;
1529 P
: constant Node_Id
:= Parent
(N
);
1532 if Nkind
(P
) = N_Compilation_Unit
then
1533 Unit_Kind
:= Nkind
(Unit
(P
));
1535 if Unit_Kind
= N_Subprogram_Declaration
1536 or else Unit_Kind
= N_Package_Declaration
1537 or else Unit_Kind
in N_Generic_Declaration
1539 Unit_Name
:= Defining_Entity
(Unit
(P
));
1541 if Chars
(Id
) = Chars
(Unit_Name
) then
1542 Set_Entity
(Id
, Unit_Name
);
1543 Set_Etype
(Id
, Etype
(Unit_Name
));
1545 Set_Etype
(Id
, Any_Type
);
1547 ("cannot find program unit referenced by pragma%");
1551 Set_Etype
(Id
, Any_Type
);
1552 Error_Pragma
("pragma% inapplicable to this unit");
1558 end Find_Program_Unit_Name
;
1560 -----------------------------------------
1561 -- Find_Unique_Parameterless_Procedure --
1562 -----------------------------------------
1564 function Find_Unique_Parameterless_Procedure
1566 Arg
: Node_Id
) return Entity_Id
1568 Proc
: Entity_Id
:= Empty
;
1571 -- The body of this procedure needs some comments ???
1573 if not Is_Entity_Name
(Name
) then
1575 ("argument of pragma% must be entity name", Arg
);
1577 elsif not Is_Overloaded
(Name
) then
1578 Proc
:= Entity
(Name
);
1580 if Ekind
(Proc
) /= E_Procedure
1581 or else Present
(First_Formal
(Proc
)) then
1583 ("argument of pragma% must be parameterless procedure", Arg
);
1588 Found
: Boolean := False;
1590 Index
: Interp_Index
;
1593 Get_First_Interp
(Name
, Index
, It
);
1594 while Present
(It
.Nam
) loop
1597 if Ekind
(Proc
) = E_Procedure
1598 and then No
(First_Formal
(Proc
))
1602 Set_Entity
(Name
, Proc
);
1603 Set_Is_Overloaded
(Name
, False);
1606 ("ambiguous handler name for pragma% ", Arg
);
1610 Get_Next_Interp
(Index
, It
);
1615 ("argument of pragma% must be parameterless procedure",
1618 Proc
:= Entity
(Name
);
1624 end Find_Unique_Parameterless_Procedure
;
1626 -------------------------
1627 -- Gather_Associations --
1628 -------------------------
1630 procedure Gather_Associations
1632 Args
: out Args_List
)
1637 -- Initialize all parameters to Empty
1639 for J
in Args
'Range loop
1643 -- That's all we have to do if there are no argument associations
1645 if No
(Pragma_Argument_Associations
(N
)) then
1649 -- Otherwise first deal with any positional parameters present
1651 Arg
:= First
(Pragma_Argument_Associations
(N
));
1652 for Index
in Args
'Range loop
1653 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
1654 Args
(Index
) := Expression
(Arg
);
1658 -- Positional parameters all processed, if any left, then we
1659 -- have too many positional parameters.
1661 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
1663 ("too many positional associations for pragma%", Arg
);
1666 -- Process named parameters if any are present
1668 while Present
(Arg
) loop
1669 if Chars
(Arg
) = No_Name
then
1671 ("positional association cannot follow named association",
1675 for Index
in Names
'Range loop
1676 if Names
(Index
) = Chars
(Arg
) then
1677 if Present
(Args
(Index
)) then
1679 ("duplicate argument association for pragma%", Arg
);
1681 Args
(Index
) := Expression
(Arg
);
1686 if Index
= Names
'Last then
1687 Error_Msg_Name_1
:= Chars
(N
);
1688 Error_Msg_N
("pragma% does not allow & argument", Arg
);
1690 -- Check for possible misspelling
1692 for Index1
in Names
'Range loop
1693 if Is_Bad_Spelling_Of
1694 (Get_Name_String
(Chars
(Arg
)),
1695 Get_Name_String
(Names
(Index1
)))
1697 Error_Msg_Name_1
:= Names
(Index1
);
1698 Error_Msg_N
("\possible misspelling of%", Arg
);
1710 end Gather_Associations
;
1712 --------------------
1713 -- Get_Pragma_Arg --
1714 --------------------
1716 function Get_Pragma_Arg
(Arg
: Node_Id
) return Node_Id
is
1718 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
1719 return Expression
(Arg
);
1729 procedure GNAT_Pragma
is
1731 Check_Restriction
(No_Implementation_Pragmas
, N
);
1734 --------------------------
1735 -- Is_Before_First_Decl --
1736 --------------------------
1738 function Is_Before_First_Decl
1739 (Pragma_Node
: Node_Id
;
1740 Decls
: List_Id
) return Boolean
1742 Item
: Node_Id
:= First
(Decls
);
1745 -- Only other pragmas can come before this pragma
1748 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
1751 elsif Item
= Pragma_Node
then
1757 end Is_Before_First_Decl
;
1759 -----------------------------
1760 -- Is_Configuration_Pragma --
1761 -----------------------------
1763 -- A configuration pragma must appear in the context clause of
1764 -- a compilation unit, at the start of the list (i.e. only other
1765 -- pragmas may precede it).
1767 function Is_Configuration_Pragma
return Boolean is
1768 Lis
: constant List_Id
:= List_Containing
(N
);
1769 Par
: constant Node_Id
:= Parent
(N
);
1773 -- If no parent, then we are in the configuration pragma file,
1774 -- so the placement is definitely appropriate.
1779 -- Otherwise we must be in the context clause of a compilation unit
1780 -- and the only thing allowed before us in the context list is more
1781 -- configuration pragmas.
1783 elsif Nkind
(Par
) = N_Compilation_Unit
1784 and then Context_Items
(Par
) = Lis
1791 elsif Nkind
(Prg
) /= N_Pragma
then
1801 end Is_Configuration_Pragma
;
1803 ----------------------
1804 -- Pragma_Misplaced --
1805 ----------------------
1807 procedure Pragma_Misplaced
is
1809 Error_Pragma
("incorrect placement of pragma%");
1810 end Pragma_Misplaced
;
1812 ------------------------------------
1813 -- Process Atomic_Shared_Volatile --
1814 ------------------------------------
1816 procedure Process_Atomic_Shared_Volatile
is
1823 procedure Set_Atomic
(E
: Entity_Id
);
1824 -- Set given type as atomic, and if no explicit alignment was
1825 -- given, set alignment to unknown, since back end knows what
1826 -- the alignment requirements are for atomic arrays. Note that
1827 -- this step is necessary for derived types.
1833 procedure Set_Atomic
(E
: Entity_Id
) is
1837 if not Has_Alignment_Clause
(E
) then
1838 Set_Alignment
(E
, Uint_0
);
1842 -- Start of processing for Process_Atomic_Shared_Volatile
1845 Check_Ada_83_Warning
;
1846 Check_No_Identifiers
;
1847 Check_Arg_Count
(1);
1848 Check_Arg_Is_Local_Name
(Arg1
);
1849 E_Id
:= Expression
(Arg1
);
1851 if Etype
(E_Id
) = Any_Type
then
1856 D
:= Declaration_Node
(E
);
1860 if Rep_Item_Too_Early
(E
, N
)
1862 Rep_Item_Too_Late
(E
, N
)
1866 Check_First_Subtype
(Arg1
);
1869 if Prag_Id
/= Pragma_Volatile
then
1871 Set_Atomic
(Underlying_Type
(E
));
1872 Set_Atomic
(Base_Type
(E
));
1875 -- Attribute belongs on the base type. If the
1876 -- view of the type is currently private, it also
1877 -- belongs on the underlying type.
1879 Set_Is_Volatile
(Base_Type
(E
));
1880 Set_Is_Volatile
(Underlying_Type
(E
));
1882 Set_Treat_As_Volatile
(E
);
1883 Set_Treat_As_Volatile
(Underlying_Type
(E
));
1885 elsif K
= N_Object_Declaration
1886 or else (K
= N_Component_Declaration
1887 and then Original_Record_Component
(E
) = E
)
1889 if Rep_Item_Too_Late
(E
, N
) then
1893 if Prag_Id
/= Pragma_Volatile
then
1896 -- If the object declaration has an explicit
1897 -- initialization, a temporary may have to be
1898 -- created to hold the expression, to insure
1899 -- that access to the object remain atomic.
1901 if Nkind
(Parent
(E
)) = N_Object_Declaration
1902 and then Present
(Expression
(Parent
(E
)))
1904 Set_Has_Delayed_Freeze
(E
);
1907 -- An interesting improvement here. If an object of type X
1908 -- is declared atomic, and the type X is not atomic, that's
1909 -- a pity, since it may not have appropraite alignment etc.
1910 -- We can rescue this in the special case where the object
1911 -- and type are in the same unit by just setting the type
1912 -- as atomic, so that the back end will process it as atomic.
1914 Utyp
:= Underlying_Type
(Etype
(E
));
1917 and then Sloc
(E
) > No_Location
1918 and then Sloc
(Utyp
) > No_Location
1920 Get_Source_File_Index
(Sloc
(E
)) =
1921 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
1923 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
1927 Set_Is_Volatile
(E
);
1928 Set_Treat_As_Volatile
(E
);
1932 ("inappropriate entity for pragma%", Arg1
);
1934 end Process_Atomic_Shared_Volatile
;
1936 ------------------------
1937 -- Process_Convention --
1938 ------------------------
1940 procedure Process_Convention
1941 (C
: out Convention_Id
;
1947 Comp_Unit
: Unit_Number_Type
;
1949 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
1950 -- Set convention in entity E, and also flag that the entity has a
1951 -- convention pragma. If entity is for a private or incomplete type,
1952 -- also set convention and flag on underlying type. This procedure
1953 -- also deals with the special case of C_Pass_By_Copy convention.
1955 --------------------------------
1956 -- Set_Convention_From_Pragma --
1957 --------------------------------
1959 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
1961 Set_Convention
(E
, C
);
1962 Set_Has_Convention_Pragma
(E
);
1964 if Is_Incomplete_Or_Private_Type
(E
) then
1965 Set_Convention
(Underlying_Type
(E
), C
);
1966 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
1969 -- A class-wide type should inherit the convention of
1970 -- the specific root type (although this isn't specified
1971 -- clearly by the RM).
1973 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
1974 Set_Convention
(Class_Wide_Type
(E
), C
);
1977 -- If the entity is a record type, then check for special case
1978 -- of C_Pass_By_Copy, which is treated the same as C except that
1979 -- the special record flag is set. This convention is also only
1980 -- permitted on record types (see AI95-00131).
1982 if Cname
= Name_C_Pass_By_Copy
then
1983 if Is_Record_Type
(E
) then
1984 Set_C_Pass_By_Copy
(Base_Type
(E
));
1985 elsif Is_Incomplete_Or_Private_Type
(E
)
1986 and then Is_Record_Type
(Underlying_Type
(E
))
1988 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
1991 ("C_Pass_By_Copy convention allowed only for record type",
1996 -- If the entity is a derived boolean type, check for the
1997 -- special case of convention C, C++, or Fortran, where we
1998 -- consider any nonzero value to represent true.
2000 if Is_Discrete_Type
(E
)
2001 and then Root_Type
(Etype
(E
)) = Standard_Boolean
2007 C
= Convention_Fortran
)
2009 Set_Nonzero_Is_True
(Base_Type
(E
));
2011 end Set_Convention_From_Pragma
;
2013 -- Start of processing for Process_Convention
2016 Check_At_Least_N_Arguments
(2);
2017 Check_Optional_Identifier
(Arg1
, Name_Convention
);
2018 Check_Arg_Is_Identifier
(Arg1
);
2019 Cname
:= Chars
(Expression
(Arg1
));
2021 -- C_Pass_By_Copy is treated as a synonym for convention C
2022 -- (this is tested again below to set the critical flag)
2024 if Cname
= Name_C_Pass_By_Copy
then
2027 -- Otherwise we must have something in the standard convention list
2029 elsif Is_Convention_Name
(Cname
) then
2030 C
:= Get_Convention_Id
(Chars
(Expression
(Arg1
)));
2032 -- In DEC VMS, it seems that there is an undocumented feature
2033 -- that any unrecognized convention is treated as the default,
2034 -- which for us is convention C. It does not seem so terrible
2035 -- to do this unconditionally, silently in the VMS case, and
2036 -- with a warning in the non-VMS case.
2039 if Warn_On_Export_Import
and not OpenVMS_On_Target
then
2041 ("?unrecognized convention name, C assumed",
2048 Check_Optional_Identifier
(Arg2
, Name_Entity
);
2049 Check_Arg_Is_Local_Name
(Arg2
);
2051 Id
:= Expression
(Arg2
);
2054 if not Is_Entity_Name
(Id
) then
2055 Error_Pragma_Arg
("entity name required", Arg2
);
2060 -- Go to renamed subprogram if present, since convention applies
2061 -- to the actual renamed entity, not to the renaming entity.
2062 -- If subprogram is inherited, go to parent subprogram.
2064 if Is_Subprogram
(E
)
2065 and then Present
(Alias
(E
))
2067 if Nkind
(Parent
(Declaration_Node
(E
)))
2068 = N_Subprogram_Renaming_Declaration
2072 elsif Nkind
(Parent
(E
)) = N_Full_Type_Declaration
2073 and then Scope
(E
) = Scope
(Alias
(E
))
2079 -- Check that we are not applying this to a specless body
2081 if Is_Subprogram
(E
)
2082 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
2085 ("pragma% requires separate spec and must come before body");
2088 -- Check that we are not applying this to a named constant
2090 if Ekind
(E
) = E_Named_Integer
2092 Ekind
(E
) = E_Named_Real
2094 Error_Msg_Name_1
:= Chars
(N
);
2096 ("cannot apply pragma% to named constant!",
2097 Get_Pragma_Arg
(Arg2
));
2099 ("\supply appropriate type for&!", Arg2
);
2102 if Etype
(E
) = Any_Type
2103 or else Rep_Item_Too_Early
(E
, N
)
2107 E
:= Underlying_Type
(E
);
2110 if Rep_Item_Too_Late
(E
, N
) then
2114 if Has_Convention_Pragma
(E
) then
2116 ("at most one Convention/Export/Import pragma is allowed", Arg2
);
2118 elsif Convention
(E
) = Convention_Protected
2119 or else Ekind
(Scope
(E
)) = E_Protected_Type
2122 ("a protected operation cannot be given a different convention",
2126 -- For Intrinsic, a subprogram is required
2128 if C
= Convention_Intrinsic
2129 and then not Is_Subprogram
(E
)
2130 and then not Is_Generic_Subprogram
(E
)
2133 ("second argument of pragma% must be a subprogram", Arg2
);
2136 -- For Stdcall, a subprogram, variable or subprogram type is required
2138 if C
= Convention_Stdcall
2139 and then not Is_Subprogram
(E
)
2140 and then not Is_Generic_Subprogram
(E
)
2141 and then Ekind
(E
) /= E_Variable
2144 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
2147 ("second argument of pragma% must be subprogram (type)",
2151 if not Is_Subprogram
(E
)
2152 and then not Is_Generic_Subprogram
(E
)
2154 Set_Convention_From_Pragma
(E
);
2158 Check_First_Subtype
(Arg2
);
2159 Set_Convention_From_Pragma
(Base_Type
(E
));
2161 -- For subprograms, we must set the convention on the
2162 -- internally generated directly designated type as well.
2164 if Ekind
(E
) = E_Access_Subprogram_Type
then
2165 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
2169 -- For the subprogram case, set proper convention for all homonyms
2170 -- in same scope and the same declarative part, i.e. the same
2171 -- compilation unit.
2174 Comp_Unit
:= Get_Source_Unit
(E
);
2175 Set_Convention_From_Pragma
(E
);
2177 -- Treat a pragma Import as an implicit body, for GPS use
2179 if Prag_Id
= Pragma_Import
then
2180 Generate_Reference
(E
, Id
, 'b');
2186 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
2188 -- Note: below we are missing a check for Rep_Item_Too_Late.
2189 -- That is deliberate, we cannot chain the rep item on more
2190 -- than one Rep_Item chain, to be fixed later ???
2192 if Comes_From_Source
(E1
)
2193 and then Comp_Unit
= Get_Source_Unit
(E1
)
2194 and then Nkind
(Original_Node
(Parent
(E1
))) /=
2195 N_Full_Type_Declaration
2197 Set_Convention_From_Pragma
(E1
);
2199 if Prag_Id
= Pragma_Import
then
2200 Generate_Reference
(E
, Id
, 'b');
2205 end Process_Convention
;
2207 -----------------------------------------------------
2208 -- Process_Extended_Import_Export_Exception_Pragma --
2209 -----------------------------------------------------
2211 procedure Process_Extended_Import_Export_Exception_Pragma
2212 (Arg_Internal
: Node_Id
;
2213 Arg_External
: Node_Id
;
2223 if not OpenVMS_On_Target
then
2225 ("?pragma% ignored (applies only to Open'V'M'S)");
2228 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
2229 Def_Id
:= Entity
(Arg_Internal
);
2231 if Ekind
(Def_Id
) /= E_Exception
then
2233 ("pragma% must refer to declared exception", Arg_Internal
);
2236 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
2238 if Present
(Arg_Form
) then
2239 Check_Arg_Is_One_Of
(Arg_Form
, Name_Ada
, Name_VMS
);
2242 if Present
(Arg_Form
)
2243 and then Chars
(Arg_Form
) = Name_Ada
2247 Set_Is_VMS_Exception
(Def_Id
);
2248 Set_Exception_Code
(Def_Id
, No_Uint
);
2251 if Present
(Arg_Code
) then
2252 if not Is_VMS_Exception
(Def_Id
) then
2254 ("Code option for pragma% not allowed for Ada case",
2258 Check_Arg_Is_Static_Expression
(Arg_Code
, Any_Integer
);
2259 Code_Val
:= Expr_Value
(Arg_Code
);
2261 if not UI_Is_In_Int_Range
(Code_Val
) then
2263 ("Code option for pragma% must be in 32-bit range",
2267 Set_Exception_Code
(Def_Id
, Code_Val
);
2270 end Process_Extended_Import_Export_Exception_Pragma
;
2272 -------------------------------------------------
2273 -- Process_Extended_Import_Export_Internal_Arg --
2274 -------------------------------------------------
2276 procedure Process_Extended_Import_Export_Internal_Arg
2277 (Arg_Internal
: Node_Id
:= Empty
)
2282 if No
(Arg_Internal
) then
2283 Error_Pragma
("Internal parameter required for pragma%");
2286 if Nkind
(Arg_Internal
) = N_Identifier
then
2289 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
2290 and then (Prag_Id
= Pragma_Import_Function
2292 Prag_Id
= Pragma_Export_Function
)
2298 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
2301 Check_Arg_Is_Local_Name
(Arg_Internal
);
2302 end Process_Extended_Import_Export_Internal_Arg
;
2304 --------------------------------------------------
2305 -- Process_Extended_Import_Export_Object_Pragma --
2306 --------------------------------------------------
2308 procedure Process_Extended_Import_Export_Object_Pragma
2309 (Arg_Internal
: Node_Id
;
2310 Arg_External
: Node_Id
;
2316 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
2317 Def_Id
:= Entity
(Arg_Internal
);
2319 if Ekind
(Def_Id
) /= E_Constant
2320 and then Ekind
(Def_Id
) /= E_Variable
2323 ("pragma% must designate an object", Arg_Internal
);
2326 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
2328 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
2331 ("previous Common/Psect_Object applies, pragma % not permitted",
2335 if Rep_Item_Too_Late
(Def_Id
, N
) then
2339 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
2341 if Present
(Arg_Size
) then
2342 Check_Arg_Is_External_Name
(Arg_Size
);
2345 -- Export_Object case
2347 if Prag_Id
= Pragma_Export_Object
then
2348 if not Is_Library_Level_Entity
(Def_Id
) then
2350 ("argument for pragma% must be library level entity",
2354 if Ekind
(Current_Scope
) = E_Generic_Package
then
2355 Error_Pragma
("pragma& cannot appear in a generic unit");
2358 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
2360 ("exported object must have compile time known size",
2364 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
2366 ("?duplicate Export_Object pragma", N
);
2368 Set_Exported
(Def_Id
, Arg_Internal
);
2371 -- Import_Object case
2374 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
2376 ("cannot use pragma% for task/protected object",
2380 if Ekind
(Def_Id
) = E_Constant
then
2382 ("cannot import a constant", Arg_Internal
);
2385 if Warn_On_Export_Import
2386 and then Has_Discriminants
(Etype
(Def_Id
))
2389 ("imported value must be initialized?", Arg_Internal
);
2392 if Warn_On_Export_Import
2393 and then Is_Access_Type
(Etype
(Def_Id
))
2396 ("cannot import object of an access type?", Arg_Internal
);
2399 if Warn_On_Export_Import
2400 and then Is_Imported
(Def_Id
)
2403 ("?duplicate Import_Object pragma", N
);
2405 -- Check for explicit initialization present. Note that an
2406 -- initialization that generated by the code generator, e.g.
2407 -- for an access type, does not count here.
2409 elsif Present
(Expression
(Parent
(Def_Id
)))
2412 (Original_Node
(Expression
(Parent
(Def_Id
))))
2414 Error_Msg_Sloc
:= Sloc
(Def_Id
);
2416 ("no initialization allowed for declaration of& #",
2417 "\imported entities cannot be initialized ('R'M' 'B.1(24))",
2420 Set_Imported
(Def_Id
);
2421 Note_Possible_Modification
(Arg_Internal
);
2424 end Process_Extended_Import_Export_Object_Pragma
;
2426 ------------------------------------------------------
2427 -- Process_Extended_Import_Export_Subprogram_Pragma --
2428 ------------------------------------------------------
2430 procedure Process_Extended_Import_Export_Subprogram_Pragma
2431 (Arg_Internal
: Node_Id
;
2432 Arg_External
: Node_Id
;
2433 Arg_Parameter_Types
: Node_Id
;
2434 Arg_Result_Type
: Node_Id
:= Empty
;
2435 Arg_Mechanism
: Node_Id
;
2436 Arg_Result_Mechanism
: Node_Id
:= Empty
;
2437 Arg_First_Optional_Parameter
: Node_Id
:= Empty
)
2443 Ambiguous
: Boolean;
2447 function Same_Base_Type
2449 Formal
: Entity_Id
) return Boolean;
2450 -- Determines if Ptype references the type of Formal. Note that
2451 -- only the base types need to match according to the spec. Ptype
2452 -- here is the argument from the pragma, which is either a type
2453 -- name, or an access attribute.
2455 --------------------
2456 -- Same_Base_Type --
2457 --------------------
2459 function Same_Base_Type
2461 Formal
: Entity_Id
) return Boolean
2463 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
2467 -- Case where pragma argument is typ'Access
2469 if Nkind
(Ptype
) = N_Attribute_Reference
2470 and then Attribute_Name
(Ptype
) = Name_Access
2472 Pref
:= Prefix
(Ptype
);
2475 if not Is_Entity_Name
(Pref
)
2476 or else Entity
(Pref
) = Any_Type
2481 -- We have a match if the corresponding argument is of an
2482 -- anonymous access type, and its designicated type matches
2483 -- the type of the prefix of the access attribute
2485 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
2486 and then Base_Type
(Entity
(Pref
)) =
2487 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
2489 -- Case where pragma argument is a type name
2494 if not Is_Entity_Name
(Ptype
)
2495 or else Entity
(Ptype
) = Any_Type
2500 -- We have a match if the corresponding argument is of
2501 -- the type given in the pragma (comparing base types)
2503 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
2507 -- Start of processing for
2508 -- Process_Extended_Import_Export_Subprogram_Pragma
2511 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
2515 -- Loop through homonyms (overloadings) of the entity
2517 Hom_Id
:= Entity
(Arg_Internal
);
2518 while Present
(Hom_Id
) loop
2519 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
2521 -- We need a subprogram in the current scope
2523 if not Is_Subprogram
(Def_Id
)
2524 or else Scope
(Def_Id
) /= Current_Scope
2531 -- Pragma cannot apply to subprogram body
2533 if Is_Subprogram
(Def_Id
)
2536 (Declaration_Node
(Def_Id
))) = N_Subprogram_Body
2539 ("pragma% requires separate spec"
2540 & " and must come before body");
2543 -- Test result type if given, note that the result type
2544 -- parameter can only be present for the function cases.
2546 if Present
(Arg_Result_Type
)
2547 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
2551 elsif Etype
(Def_Id
) /= Standard_Void_Type
2553 (Chars
(N
) = Name_Export_Procedure
2554 or else Chars
(N
) = Name_Import_Procedure
)
2558 -- Test parameter types if given. Note that this parameter
2559 -- has not been analyzed (and must not be, since it is
2560 -- semantic nonsense), so we get it as the parser left it.
2562 elsif Present
(Arg_Parameter_Types
) then
2563 Check_Matching_Types
: declare
2568 Formal
:= First_Formal
(Def_Id
);
2570 if Nkind
(Arg_Parameter_Types
) = N_Null
then
2571 if Present
(Formal
) then
2575 -- A list of one type, e.g. (List) is parsed as
2576 -- a parenthesized expression.
2578 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
2579 and then Paren_Count
(Arg_Parameter_Types
) = 1
2582 or else Present
(Next_Formal
(Formal
))
2587 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
2590 -- A list of more than one type is parsed as a aggregate
2592 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
2593 and then Paren_Count
(Arg_Parameter_Types
) = 0
2595 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
2596 while Present
(Ptype
) or else Present
(Formal
) loop
2599 or else not Same_Base_Type
(Ptype
, Formal
)
2604 Next_Formal
(Formal
);
2609 -- Anything else is of the wrong form
2613 ("wrong form for Parameter_Types parameter",
2614 Arg_Parameter_Types
);
2616 end Check_Matching_Types
;
2619 -- Match is now False if the entry we found did not match
2620 -- either a supplied Parameter_Types or Result_Types argument
2626 -- Ambiguous case, the flag Ambiguous shows if we already
2627 -- detected this and output the initial messages.
2630 if not Ambiguous
then
2632 Error_Msg_Name_1
:= Chars
(N
);
2634 ("pragma% does not uniquely identify subprogram!",
2636 Error_Msg_Sloc
:= Sloc
(Ent
);
2637 Error_Msg_N
("matching subprogram #!", N
);
2641 Error_Msg_Sloc
:= Sloc
(Def_Id
);
2642 Error_Msg_N
("matching subprogram #!", N
);
2647 Hom_Id
:= Homonym
(Hom_Id
);
2650 -- See if we found an entry
2653 if not Ambiguous
then
2654 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
2656 ("pragma% cannot be given for generic subprogram");
2660 ("pragma% does not identify local subprogram");
2667 -- Import pragmas must be be for imported entities
2669 if Prag_Id
= Pragma_Import_Function
2671 Prag_Id
= Pragma_Import_Procedure
2673 Prag_Id
= Pragma_Import_Valued_Procedure
2675 if not Is_Imported
(Ent
) then
2677 ("pragma Import or Interface must precede pragma%");
2680 -- Here we have the Export case which can set the entity as exported
2682 -- But does not do so if the specified external name is null,
2683 -- since that is taken as a signal in DEC Ada 83 (with which
2684 -- we want to be compatible) to request no external name.
2686 elsif Nkind
(Arg_External
) = N_String_Literal
2687 and then String_Length
(Strval
(Arg_External
)) = 0
2691 -- In all other cases, set entit as exported
2694 Set_Exported
(Ent
, Arg_Internal
);
2697 -- Special processing for Valued_Procedure cases
2699 if Prag_Id
= Pragma_Import_Valued_Procedure
2701 Prag_Id
= Pragma_Export_Valued_Procedure
2703 Formal
:= First_Formal
(Ent
);
2707 ("at least one parameter required for pragma%");
2709 elsif Ekind
(Formal
) /= E_Out_Parameter
then
2711 ("first parameter must have mode out for pragma%");
2714 Set_Is_Valued_Procedure
(Ent
);
2718 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
2720 -- Process Result_Mechanism argument if present. We have already
2721 -- checked that this is only allowed for the function case.
2723 if Present
(Arg_Result_Mechanism
) then
2724 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
2727 -- Process Mechanism parameter if present. Note that this parameter
2728 -- is not analyzed, and must not be analyzed since it is semantic
2729 -- nonsense, so we get it in exactly as the parser left it.
2731 if Present
(Arg_Mechanism
) then
2739 -- A single mechanism association without a formal parameter
2740 -- name is parsed as a parenthesized expression. All other
2741 -- cases are parsed as aggregates, so we rewrite the single
2742 -- parameter case as an aggregate for consistency.
2744 if Nkind
(Arg_Mechanism
) /= N_Aggregate
2745 and then Paren_Count
(Arg_Mechanism
) = 1
2747 Rewrite
(Arg_Mechanism
,
2748 Make_Aggregate
(Sloc
(Arg_Mechanism
),
2749 Expressions
=> New_List
(
2750 Relocate_Node
(Arg_Mechanism
))));
2753 -- Case of only mechanism name given, applies to all formals
2755 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
2756 Formal
:= First_Formal
(Ent
);
2757 while Present
(Formal
) loop
2758 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
2759 Next_Formal
(Formal
);
2762 -- Case of list of mechanism associations given
2765 if Null_Record_Present
(Arg_Mechanism
) then
2767 ("inappropriate form for Mechanism parameter",
2771 -- Deal with positional ones first
2773 Formal
:= First_Formal
(Ent
);
2775 if Present
(Expressions
(Arg_Mechanism
)) then
2776 Mname
:= First
(Expressions
(Arg_Mechanism
));
2778 while Present
(Mname
) loop
2781 ("too many mechanism associations", Mname
);
2784 Set_Mechanism_Value
(Formal
, Mname
);
2785 Next_Formal
(Formal
);
2790 -- Deal with named entries
2792 if Present
(Component_Associations
(Arg_Mechanism
)) then
2793 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
2795 while Present
(Massoc
) loop
2796 Choice
:= First
(Choices
(Massoc
));
2798 if Nkind
(Choice
) /= N_Identifier
2799 or else Present
(Next
(Choice
))
2802 ("incorrect form for mechanism association",
2806 Formal
:= First_Formal
(Ent
);
2810 ("parameter name & not present", Choice
);
2813 if Chars
(Choice
) = Chars
(Formal
) then
2815 (Formal
, Expression
(Massoc
));
2819 Next_Formal
(Formal
);
2829 -- Process First_Optional_Parameter argument if present. We have
2830 -- already checked that this is only allowed for the Import case.
2832 if Present
(Arg_First_Optional_Parameter
) then
2833 if Nkind
(Arg_First_Optional_Parameter
) /= N_Identifier
then
2835 ("first optional parameter must be formal parameter name",
2836 Arg_First_Optional_Parameter
);
2839 Formal
:= First_Formal
(Ent
);
2843 ("specified formal parameter& not found",
2844 Arg_First_Optional_Parameter
);
2847 exit when Chars
(Formal
) =
2848 Chars
(Arg_First_Optional_Parameter
);
2850 Next_Formal
(Formal
);
2853 Set_First_Optional_Parameter
(Ent
, Formal
);
2855 -- Check specified and all remaining formals have right form
2857 while Present
(Formal
) loop
2858 if Ekind
(Formal
) /= E_In_Parameter
then
2860 ("optional formal& is not of mode in!",
2861 Arg_First_Optional_Parameter
, Formal
);
2864 Dval
:= Default_Value
(Formal
);
2866 if not Present
(Dval
) then
2868 ("optional formal& does not have default value!",
2869 Arg_First_Optional_Parameter
, Formal
);
2871 elsif Compile_Time_Known_Value_Or_Aggr
(Dval
) then
2876 ("default value for optional formal& is non-static!",
2877 Arg_First_Optional_Parameter
, Formal
);
2881 Set_Is_Optional_Parameter
(Formal
);
2882 Next_Formal
(Formal
);
2885 end Process_Extended_Import_Export_Subprogram_Pragma
;
2887 --------------------------
2888 -- Process_Generic_List --
2889 --------------------------
2891 procedure Process_Generic_List
is
2897 Check_No_Identifiers
;
2898 Check_At_Least_N_Arguments
(1);
2901 while Present
(Arg
) loop
2902 Exp
:= Expression
(Arg
);
2905 if not Is_Entity_Name
(Exp
)
2907 (not Is_Generic_Instance
(Entity
(Exp
))
2909 not Is_Generic_Unit
(Entity
(Exp
)))
2912 ("pragma% argument must be name of generic unit/instance",
2918 end Process_Generic_List
;
2920 ---------------------------------
2921 -- Process_Import_Or_Interface --
2922 ---------------------------------
2924 procedure Process_Import_Or_Interface
is
2930 Process_Convention
(C
, Def_Id
);
2931 Kill_Size_Check_Code
(Def_Id
);
2932 Note_Possible_Modification
(Expression
(Arg2
));
2934 if Ekind
(Def_Id
) = E_Variable
2936 Ekind
(Def_Id
) = E_Constant
2938 -- User initialization is not allowed for imported object, but
2939 -- the object declaration may contain a default initialization,
2940 -- that will be discarded. Note that an explicit initialization
2941 -- only counts if it comes from source, otherwise it is simply
2942 -- the code generator making an implicit initialization explicit.
2944 if Present
(Expression
(Parent
(Def_Id
)))
2945 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
2947 Error_Msg_Sloc
:= Sloc
(Def_Id
);
2949 ("no initialization allowed for declaration of& #",
2950 "\imported entities cannot be initialized ('R'M' 'B.1(24))",
2954 Set_Imported
(Def_Id
);
2955 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
2957 -- Note that we do not set Is_Public here. That's because we
2958 -- only want to set if if there is no address clause, and we
2959 -- don't know that yet, so we delay that processing till
2962 -- pragma Import completes deferred constants
2964 if Ekind
(Def_Id
) = E_Constant
then
2965 Set_Has_Completion
(Def_Id
);
2968 -- It is not possible to import a constant of an unconstrained
2969 -- array type (e.g. string) because there is no simple way to
2970 -- write a meaningful subtype for it.
2972 if Is_Array_Type
(Etype
(Def_Id
))
2973 and then not Is_Constrained
(Etype
(Def_Id
))
2976 ("imported constant& must have a constrained subtype",
2981 elsif Is_Subprogram
(Def_Id
)
2982 or else Is_Generic_Subprogram
(Def_Id
)
2984 -- If the name is overloaded, pragma applies to all of the
2985 -- denoted entities in the same declarative part.
2988 while Present
(Hom_Id
) loop
2989 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
2991 -- Ignore inherited subprograms because the pragma will
2992 -- apply to the parent operation, which is the one called.
2994 if Is_Overloadable
(Def_Id
)
2995 and then Present
(Alias
(Def_Id
))
2999 -- If it is not a subprogram, it must be in an outer
3000 -- scope and pragma does not apply.
3002 elsif not Is_Subprogram
(Def_Id
)
3003 and then not Is_Generic_Subprogram
(Def_Id
)
3007 -- Verify that the homonym is in the same declarative
3008 -- part (not just the same scope).
3010 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
3011 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
3016 Set_Imported
(Def_Id
);
3018 -- Special processing for Convention_Intrinsic
3020 if C
= Convention_Intrinsic
then
3022 -- Link_Name argument not allowed for intrinsic
3025 and then Chars
(Arg3
) = Name_Link_Name
3030 if Present
(Arg4
) then
3032 ("Link_Name argument not allowed for " &
3037 Set_Is_Intrinsic_Subprogram
(Def_Id
);
3039 -- If no external name is present, then check that
3040 -- this is a valid intrinsic subprogram. If an external
3041 -- name is present, then this is handled by the back end.
3044 Check_Intrinsic_Subprogram
(Def_Id
, Expression
(Arg2
));
3048 -- All interfaced procedures need an external symbol
3049 -- created for them since they are always referenced
3050 -- from another object file.
3052 Set_Is_Public
(Def_Id
);
3054 -- Verify that the subprogram does not have a completion
3055 -- through a renaming declaration. For other completions
3056 -- the pragma appears as a too late representation.
3059 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
3063 and then Nkind
(Decl
) = N_Subprogram_Declaration
3064 and then Present
(Corresponding_Body
(Decl
))
3067 (Unit_Declaration_Node
3068 (Corresponding_Body
(Decl
))) =
3069 N_Subprogram_Renaming_Declaration
3071 Error_Msg_Sloc
:= Sloc
(Def_Id
);
3072 Error_Msg_NE
("cannot import&#," &
3073 " already completed by a renaming",
3078 Set_Has_Completion
(Def_Id
);
3079 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
3082 if Is_Compilation_Unit
(Hom_Id
) then
3084 -- Its possible homonyms are not affected by the pragma.
3085 -- Such homonyms might be present in the context of other
3086 -- units being compiled.
3091 Hom_Id
:= Homonym
(Hom_Id
);
3095 -- When the convention is Java, we also allow Import to be given
3096 -- for packages, exceptions, and record components.
3098 elsif C
= Convention_Java
3100 (Ekind
(Def_Id
) = E_Package
3101 or else Ekind
(Def_Id
) = E_Exception
3102 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
3104 Set_Imported
(Def_Id
);
3105 Set_Is_Public
(Def_Id
);
3106 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
3110 ("second argument of pragma% must be object or subprogram",
3114 -- If this pragma applies to a compilation unit, then the unit,
3115 -- which is a subprogram, does not require (or allow) a body.
3116 -- We also do not need to elaborate imported procedures.
3118 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
3120 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
3122 Set_Body_Required
(Cunit
, False);
3125 end Process_Import_Or_Interface
;
3127 --------------------
3128 -- Process_Inline --
3129 --------------------
3131 procedure Process_Inline
(Active
: Boolean) is
3137 Effective
: Boolean := False;
3139 procedure Make_Inline
(Subp
: Entity_Id
);
3140 -- Subp is the defining unit name of the subprogram
3141 -- declaration. Set the flag, as well as the flag in the
3142 -- corresponding body, if there is one present.
3144 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
3145 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp
3147 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
3148 -- Returns True if it can be determined at this stage that inlining
3149 -- is not possible, for examle if the body is available and contains
3150 -- exception handlers, we prevent inlining, since otherwise we can
3151 -- get undefined symbols at link time. This function also emits a
3152 -- warning if front-end inlining is enabled and the pragma appears
3154 -- ??? is business with link symbols still valid, or does it relate
3155 -- to front end ZCX which is being phased out ???
3157 ---------------------------
3158 -- Inlining_Not_Possible --
3159 ---------------------------
3161 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
3162 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
3166 if Nkind
(Decl
) = N_Subprogram_Body
then
3167 Stats
:= Handled_Statement_Sequence
(Decl
);
3168 return Present
(Exception_Handlers
(Stats
))
3169 or else Present
(At_End_Proc
(Stats
));
3171 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3172 and then Present
(Corresponding_Body
(Decl
))
3174 if Front_End_Inlining
3175 and then Analyzed
(Corresponding_Body
(Decl
))
3177 Error_Msg_N
("pragma appears too late, ignored?", N
);
3180 -- If the subprogram is a renaming as body, the body is
3181 -- just a call to the renamed subprogram, and inlining is
3182 -- trivially possible.
3185 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
)))
3186 = N_Subprogram_Renaming_Declaration
3192 Handled_Statement_Sequence
3193 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
3196 Present
(Exception_Handlers
(Stats
))
3197 or else Present
(At_End_Proc
(Stats
));
3201 -- If body is not available, assume the best, the check is
3202 -- performed again when compiling enclosing package bodies.
3206 end Inlining_Not_Possible
;
3212 procedure Make_Inline
(Subp
: Entity_Id
) is
3213 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
3214 Inner_Subp
: Entity_Id
:= Subp
;
3217 if Etype
(Subp
) = Any_Type
then
3220 -- If inlining is not possible, for now do not treat as an error
3222 elsif Inlining_Not_Possible
(Subp
) then
3226 -- Here we have a candidate for inlining, but we must exclude
3227 -- derived operations. Otherwise we will end up trying to
3228 -- inline a phantom declaration, and the result would be to
3229 -- drag in a body which has no direct inlining associated with
3230 -- it. That would not only be inefficient but would also result
3231 -- in the backend doing cross-unit inlining in cases where it
3232 -- was definitely inappropriate to do so.
3234 -- However, a simple Comes_From_Source test is insufficient,
3235 -- since we do want to allow inlining of generic instances,
3236 -- which also do not come from source. Predefined operators do
3237 -- not come from source but are not inlineable either.
3239 elsif not Comes_From_Source
(Subp
)
3240 and then not Is_Generic_Instance
(Subp
)
3241 and then Scope
(Subp
) /= Standard_Standard
3246 -- The referenced entity must either be the enclosing entity,
3247 -- or an entity declared within the current open scope.
3249 elsif Present
(Scope
(Subp
))
3250 and then Scope
(Subp
) /= Current_Scope
3251 and then Subp
/= Current_Scope
3254 ("argument of% must be entity in current scope", Assoc
);
3258 -- Processing for procedure, operator or function.
3259 -- If subprogram is aliased (as for an instance) indicate
3260 -- that the renamed entity (if declared in the same unit)
3263 if Is_Subprogram
(Subp
) then
3264 while Present
(Alias
(Inner_Subp
)) loop
3265 Inner_Subp
:= Alias
(Inner_Subp
);
3268 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
3269 Set_Inline_Flags
(Inner_Subp
);
3271 Decl
:= Parent
(Parent
(Inner_Subp
));
3273 if Nkind
(Decl
) = N_Subprogram_Declaration
3274 and then Present
(Corresponding_Body
(Decl
))
3276 Set_Inline_Flags
(Corresponding_Body
(Decl
));
3282 -- For a generic subprogram set flag as well, for use at
3283 -- the point of instantiation, to determine whether the
3284 -- body should be generated.
3286 elsif Is_Generic_Subprogram
(Subp
) then
3287 Set_Inline_Flags
(Subp
);
3290 -- Literals are by definition inlined
3292 elsif Kind
= E_Enumeration_Literal
then
3295 -- Anything else is an error
3299 ("expect subprogram name for pragma%", Assoc
);
3303 ----------------------
3304 -- Set_Inline_Flags --
3305 ----------------------
3307 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
3310 Set_Is_Inlined
(Subp
, True);
3313 if not Has_Pragma_Inline
(Subp
) then
3314 Set_Has_Pragma_Inline
(Subp
);
3315 Set_Next_Rep_Item
(N
, First_Rep_Item
(Subp
));
3316 Set_First_Rep_Item
(Subp
, N
);
3319 end Set_Inline_Flags
;
3321 -- Start of processing for Process_Inline
3324 Check_No_Identifiers
;
3325 Check_At_Least_N_Arguments
(1);
3328 Inline_Processing_Required
:= True;
3332 while Present
(Assoc
) loop
3333 Subp_Id
:= Expression
(Assoc
);
3337 if Is_Entity_Name
(Subp_Id
) then
3338 Subp
:= Entity
(Subp_Id
);
3340 if Subp
= Any_Id
then
3342 -- If previous error, avoid cascaded errors
3350 while Present
(Homonym
(Subp
))
3351 and then Scope
(Homonym
(Subp
)) = Current_Scope
3353 Make_Inline
(Homonym
(Subp
));
3354 Subp
:= Homonym
(Subp
);
3361 ("inappropriate argument for pragma%", Assoc
);
3364 and then Warn_On_Redundant_Constructs
3366 if Inlining_Not_Possible
(Subp
) then
3368 ("pragma Inline for& is ignored?", N
, Entity
(Subp_Id
));
3371 ("pragma Inline for& is redundant?", N
, Entity
(Subp_Id
));
3379 ----------------------------
3380 -- Process_Interface_Name --
3381 ----------------------------
3383 procedure Process_Interface_Name
3384 (Subprogram_Def
: Entity_Id
;
3390 String_Val
: String_Id
;
3392 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
3393 -- SN is a string literal node for an interface name. This routine
3394 -- performs some minimal checks that the name is reasonable. In
3395 -- particular that no spaces or other obviously incorrect characters
3396 -- appear. This is only a warning, since any characters are allowed.
3398 ----------------------------------
3399 -- Check_Form_Of_Interface_Name --
3400 ----------------------------------
3402 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
3403 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
3404 SL
: constant Nat
:= String_Length
(S
);
3409 Error_Msg_N
("interface name cannot be null string", SN
);
3412 for J
in 1 .. SL
loop
3413 C
:= Get_String_Char
(S
, J
);
3415 if Warn_On_Export_Import
3416 and then (not In_Character_Range
(C
)
3417 or else Get_Character
(C
) = ' '
3418 or else Get_Character
(C
) = ',')
3421 ("?interface name contains illegal character", SN
);
3424 end Check_Form_Of_Interface_Name
;
3426 -- Start of processing for Process_Interface_Name
3429 if No
(Link_Arg
) then
3430 if No
(Ext_Arg
) then
3433 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
3435 Link_Nam
:= Expression
(Ext_Arg
);
3438 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
3439 Ext_Nam
:= Expression
(Ext_Arg
);
3444 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
3445 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
3446 Ext_Nam
:= Expression
(Ext_Arg
);
3447 Link_Nam
:= Expression
(Link_Arg
);
3450 -- Check expressions for external name and link name are static
3452 if Present
(Ext_Nam
) then
3453 Check_Arg_Is_Static_Expression
(Ext_Nam
, Standard_String
);
3454 Check_Form_Of_Interface_Name
(Ext_Nam
);
3456 -- Verify that the external name is not the name of a local
3457 -- entity, which would hide the imported one and lead to
3458 -- run-time surprises. The problem can only arise for entities
3459 -- declared in a package body (otherwise the external name is
3460 -- fully qualified and won't conflict).
3468 if Prag_Id
= Pragma_Import
then
3469 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
3471 E
:= Entity_Id
(Get_Name_Table_Info
(Nam
));
3473 if Nam
/= Chars
(Subprogram_Def
)
3474 and then Present
(E
)
3475 and then not Is_Overloadable
(E
)
3476 and then Is_Immediately_Visible
(E
)
3477 and then not Is_Imported
(E
)
3478 and then Ekind
(Scope
(E
)) = E_Package
3482 while Present
(Par
) loop
3483 if Nkind
(Par
) = N_Package_Body
then
3484 Error_Msg_Sloc
:= Sloc
(E
);
3486 ("imported entity is hidden by & declared#",
3491 Par
:= Parent
(Par
);
3498 if Present
(Link_Nam
) then
3499 Check_Arg_Is_Static_Expression
(Link_Nam
, Standard_String
);
3500 Check_Form_Of_Interface_Name
(Link_Nam
);
3503 -- If there is no link name, just set the external name
3505 if No
(Link_Nam
) then
3506 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
3508 -- For the Link_Name case, the given literal is preceded by an
3509 -- asterisk, which indicates to GCC that the given name should
3510 -- be taken literally, and in particular that no prepending of
3511 -- underlines should occur, even in systems where this is the
3516 Store_String_Char
(Get_Char_Code
('*'));
3517 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
3519 for J
in 1 .. String_Length
(String_Val
) loop
3520 Store_String_Char
(Get_String_Char
(String_Val
, J
));
3524 Make_String_Literal
(Sloc
(Link_Nam
), End_String
);
3527 Set_Encoded_Interface_Name
3528 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
3529 Check_Duplicated_Export_Name
(Link_Nam
);
3530 end Process_Interface_Name
;
3532 -----------------------------------------
3533 -- Process_Interrupt_Or_Attach_Handler --
3534 -----------------------------------------
3536 procedure Process_Interrupt_Or_Attach_Handler
is
3537 Arg1_X
: constant Node_Id
:= Expression
(Arg1
);
3538 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
3539 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
3542 Set_Is_Interrupt_Handler
(Handler_Proc
);
3544 -- If the pragma is not associated with a handler procedure
3545 -- within a protected type, then it must be for a nonprotected
3546 -- procedure for the AAMP target, in which case we don't
3547 -- associate a representation item with the procedure's scope.
3549 if Ekind
(Proc_Scope
) = E_Protected_Type
then
3550 if Prag_Id
= Pragma_Interrupt_Handler
3552 Prag_Id
= Pragma_Attach_Handler
3554 Record_Rep_Item
(Proc_Scope
, N
);
3557 end Process_Interrupt_Or_Attach_Handler
;
3559 --------------------------------------------------
3560 -- Process_Restrictions_Or_Restriction_Warnings --
3561 --------------------------------------------------
3563 -- Note: some of the simple identifier cases were handled in par-prag,
3564 -- but it is harmless (and more straightforward) to simply handle all
3565 -- cases here, even if it means we repeat a bit of work in some cases.
3567 procedure Process_Restrictions_Or_Restriction_Warnings
is
3569 R_Id
: Restriction_Id
;
3574 procedure Check_Unit_Name
(N
: Node_Id
);
3575 -- Checks unit name parameter for No_Dependence. Returns if it has
3576 -- an appropriate form, otherwise raises pragma argument error.
3578 procedure Set_Warning
(R
: All_Restrictions
);
3579 -- If this is a Restriction_Warnings pragma, set warning flag,
3580 -- otherwise reset the flag.
3582 ---------------------
3583 -- Check_Unit_Name --
3584 ---------------------
3586 procedure Check_Unit_Name
(N
: Node_Id
) is
3588 if Nkind
(N
) = N_Selected_Component
then
3589 Check_Unit_Name
(Prefix
(N
));
3590 Check_Unit_Name
(Selector_Name
(N
));
3592 elsif Nkind
(N
) = N_Identifier
then
3597 ("wrong form for unit name for No_Dependence", N
);
3599 end Check_Unit_Name
;
3605 procedure Set_Warning
(R
: All_Restrictions
) is
3607 if Prag_Id
= Pragma_Restriction_Warnings
then
3608 Restriction_Warnings
(R
) := True;
3610 Restriction_Warnings
(R
) := False;
3614 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
3617 Check_Ada_83_Warning
;
3618 Check_At_Least_N_Arguments
(1);
3619 Check_Valid_Configuration_Pragma
;
3622 while Present
(Arg
) loop
3624 Expr
:= Expression
(Arg
);
3626 -- Case of no restriction identifier present
3628 if Id
= No_Name
then
3629 if Nkind
(Expr
) /= N_Identifier
then
3631 ("invalid form for restriction", Arg
);
3636 (Process_Restriction_Synonyms
(Expr
));
3638 if R_Id
not in All_Boolean_Restrictions
then
3640 ("invalid restriction identifier", Arg
);
3643 if Implementation_Restriction
(R_Id
) then
3645 (No_Implementation_Restrictions
, Arg
);
3648 Set_Restriction
(R_Id
, N
);
3651 -- A very special case that must be processed here:
3652 -- pragma Restrictions (No_Exceptions) turns off
3653 -- all run-time checking. This is a bit dubious in
3654 -- terms of the formal language definition, but it
3655 -- is what is intended by RM H.4(12).
3657 if R_Id
= No_Exceptions
then
3658 Scope_Suppress
:= (others => True);
3661 -- Case of No_Dependence => unit-name. Note that the parser
3662 -- already made the necessary entry in the No_Dependence table.
3664 elsif Id
= Name_No_Dependence
then
3665 Check_Unit_Name
(Expr
);
3667 -- All other cases of restriction identifier present
3670 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
3671 Analyze_And_Resolve
(Expr
, Any_Integer
);
3673 if R_Id
not in All_Parameter_Restrictions
then
3675 ("invalid restriction parameter identifier", Arg
);
3677 elsif not Is_OK_Static_Expression
(Expr
) then
3678 Flag_Non_Static_Expr
3679 ("value must be static expression!", Expr
);
3682 elsif not Is_Integer_Type
(Etype
(Expr
))
3683 or else Expr_Value
(Expr
) < 0
3686 ("value must be non-negative integer", Arg
);
3688 -- Restriction pragma is active
3691 Val
:= Expr_Value
(Expr
);
3693 if not UI_Is_In_Int_Range
(Val
) then
3695 ("pragma ignored, value too large?", Arg
);
3697 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
3705 end Process_Restrictions_Or_Restriction_Warnings
;
3707 ---------------------------------
3708 -- Process_Suppress_Unsuppress --
3709 ---------------------------------
3711 -- Note: this procedure makes entries in the check suppress data
3712 -- structures managed by Sem. See spec of package Sem for full
3713 -- details on how we handle recording of check suppression.
3715 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
3720 In_Package_Spec
: constant Boolean :=
3721 (Ekind
(Current_Scope
) = E_Package
3723 Ekind
(Current_Scope
) = E_Generic_Package
)
3724 and then not In_Package_Body
(Current_Scope
);
3726 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
3727 -- Used to suppress a single check on the given entity
3729 --------------------------------
3730 -- Suppress_Unsuppress_Echeck --
3731 --------------------------------
3733 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
3734 ESR
: constant Entity_Check_Suppress_Record
:=
3737 Suppress
=> Suppress_Case
);
3740 Set_Checks_May_Be_Suppressed
(E
);
3742 if In_Package_Spec
then
3743 Global_Entity_Suppress
.Append
(ESR
);
3745 Local_Entity_Suppress
.Append
(ESR
);
3748 -- If this is a first subtype, and the base type is distinct,
3749 -- then also set the suppress flags on the base type.
3751 if Is_First_Subtype
(E
)
3752 and then Etype
(E
) /= E
3754 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
3756 end Suppress_Unsuppress_Echeck
;
3758 -- Start of processing for Process_Suppress_Unsuppress
3761 -- Suppress/Unsuppress can appear as a configuration pragma,
3762 -- or in a declarative part or a package spec (RM 11.5(5))
3764 if not Is_Configuration_Pragma
then
3765 Check_Is_In_Decl_Part_Or_Package_Spec
;
3768 Check_At_Least_N_Arguments
(1);
3769 Check_At_Most_N_Arguments
(2);
3770 Check_No_Identifier
(Arg1
);
3771 Check_Arg_Is_Identifier
(Arg1
);
3773 if not Is_Check_Name
(Chars
(Expression
(Arg1
))) then
3775 ("argument of pragma% is not valid check name", Arg1
);
3777 C
:= Get_Check_Id
(Chars
(Expression
(Arg1
)));
3780 if Arg_Count
= 1 then
3782 -- Make an entry in the local scope suppress table. This is the
3783 -- table that directly shows the current value of the scope
3784 -- suppress check for any check id value.
3786 if C
= All_Checks
then
3787 for J
in Scope_Suppress
'Range loop
3788 Scope_Suppress
(J
) := Suppress_Case
;
3791 Scope_Suppress
(C
) := Suppress_Case
;
3794 -- Also make an entry in the Local_Entity_Suppress table. See
3795 -- extended description in the package spec of Sem for details.
3797 Local_Entity_Suppress
.Append
3800 Suppress
=> Suppress_Case
));
3802 -- Case of two arguments present, where the check is
3803 -- suppressed for a specified entity (given as the second
3804 -- argument of the pragma)
3807 Check_Optional_Identifier
(Arg2
, Name_On
);
3808 E_Id
:= Expression
(Arg2
);
3811 if not Is_Entity_Name
(E_Id
) then
3813 ("second argument of pragma% must be entity name", Arg2
);
3822 -- Enforce RM 11.5(7) which requires that for a pragma that
3823 -- appears within a package spec, the named entity must be
3824 -- within the package spec. We allow the package name itself
3825 -- to be mentioned since that makes sense, although it is not
3826 -- strictly allowed by 11.5(7).
3829 and then E
/= Current_Scope
3830 and then Scope
(E
) /= Current_Scope
3833 ("entity in pragma% is not in package spec ('R'M 11.5(7))",
3837 -- Loop through homonyms. As noted below, in the case of a package
3838 -- spec, only homonyms within the package spec are considered.
3841 Suppress_Unsuppress_Echeck
(E
, C
);
3843 if Is_Generic_Instance
(E
)
3844 and then Is_Subprogram
(E
)
3845 and then Present
(Alias
(E
))
3847 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
3850 -- Move to next homonym
3855 -- If we are within a package specification, the
3856 -- pragma only applies to homonyms in the same scope.
3858 exit when In_Package_Spec
3859 and then Scope
(E
) /= Current_Scope
;
3862 end Process_Suppress_Unsuppress
;
3868 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
3870 if Is_Imported
(E
) then
3872 ("cannot export entity& that was previously imported", Arg
);
3874 elsif Present
(Address_Clause
(E
)) then
3876 ("cannot export entity& that has an address clause", Arg
);
3879 Set_Is_Exported
(E
);
3881 -- Generate a reference for entity explicitly, because the
3882 -- identifier may be overloaded and name resolution will not
3885 Generate_Reference
(E
, Arg
);
3887 -- Deal with exporting non-library level entity
3889 if not Is_Library_Level_Entity
(E
) then
3891 -- Not allowed at all for subprograms
3893 if Is_Subprogram
(E
) then
3894 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
3896 -- Otherwise set public and statically allocated
3900 Set_Is_Statically_Allocated
(E
);
3902 -- Warn if the corresponding W flag is set and the pragma
3903 -- comes from source. The latter may not be true e.g. on
3904 -- VMS where we expand export pragmas for exception codes
3905 -- associated with imported or exported exceptions. We do
3906 -- not want to generate a warning for something that the
3907 -- user did not write.
3909 if Warn_On_Export_Import
3910 and then Comes_From_Source
(Arg
)
3913 ("?& has been made static as a result of Export", Arg
, E
);
3915 ("\this usage is non-standard and non-portable", Arg
);
3920 if Warn_On_Export_Import
and then Is_Type
(E
) then
3922 ("exporting a type has no effect?", Arg
, E
);
3925 if Warn_On_Export_Import
and Inside_A_Generic
then
3927 ("all instances of& will have the same external name?", Arg
, E
);
3931 ----------------------------------------------
3932 -- Set_Extended_Import_Export_External_Name --
3933 ----------------------------------------------
3935 procedure Set_Extended_Import_Export_External_Name
3936 (Internal_Ent
: Entity_Id
;
3937 Arg_External
: Node_Id
)
3939 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
3943 if No
(Arg_External
) then
3947 Check_Arg_Is_External_Name
(Arg_External
);
3949 if Nkind
(Arg_External
) = N_String_Literal
then
3950 if String_Length
(Strval
(Arg_External
)) = 0 then
3953 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
3956 elsif Nkind
(Arg_External
) = N_Identifier
then
3957 New_Name
:= Get_Default_External_Name
(Arg_External
);
3959 -- Check_Arg_Is_External_Name should let through only
3960 -- identifiers and string literals or static string
3961 -- expressions (which are folded to string literals).
3964 raise Program_Error
;
3967 -- If we already have an external name set (by a prior normal
3968 -- Import or Export pragma), then the external names must match
3970 if Present
(Interface_Name
(Internal_Ent
)) then
3971 Check_Matching_Internal_Names
: declare
3972 S1
: constant String_Id
:= Strval
(Old_Name
);
3973 S2
: constant String_Id
:= Strval
(New_Name
);
3976 -- Called if names do not match
3982 procedure Mismatch
is
3984 Error_Msg_Sloc
:= Sloc
(Old_Name
);
3986 ("external name does not match that given #",
3990 -- Start of processing for Check_Matching_Internal_Names
3993 if String_Length
(S1
) /= String_Length
(S2
) then
3997 for J
in 1 .. String_Length
(S1
) loop
3998 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
4003 end Check_Matching_Internal_Names
;
4005 -- Otherwise set the given name
4008 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
4009 Check_Duplicated_Export_Name
(New_Name
);
4011 end Set_Extended_Import_Export_External_Name
;
4017 procedure Set_Imported
(E
: Entity_Id
) is
4019 Error_Msg_Sloc
:= Sloc
(E
);
4021 if Is_Exported
(E
) or else Is_Imported
(E
) then
4022 Error_Msg_NE
("import of& declared# not allowed", N
, E
);
4024 if Is_Exported
(E
) then
4025 Error_Msg_N
("\entity was previously exported", N
);
4027 Error_Msg_N
("\entity was previously imported", N
);
4030 Error_Pragma
("\(pragma% applies to all previous entities)");
4033 Set_Is_Imported
(E
);
4035 -- If the entity is an object that is not at the library
4036 -- level, then it is statically allocated. We do not worry
4037 -- about objects with address clauses in this context since
4038 -- they are not really imported in the linker sense.
4041 and then not Is_Library_Level_Entity
(E
)
4042 and then No
(Address_Clause
(E
))
4044 Set_Is_Statically_Allocated
(E
);
4049 -------------------------
4050 -- Set_Mechanism_Value --
4051 -------------------------
4053 -- Note: the mechanism name has not been analyzed (and cannot indeed
4054 -- be analyzed, since it is semantic nonsense), so we get it in the
4055 -- exact form created by the parser.
4057 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
4061 procedure Bad_Class
;
4062 -- Signal bad descriptor class name
4064 procedure Bad_Mechanism
;
4065 -- Signal bad mechanism name
4071 procedure Bad_Class
is
4073 Error_Pragma_Arg
("unrecognized descriptor class name", Class
);
4076 -------------------------
4077 -- Bad_Mechanism_Value --
4078 -------------------------
4080 procedure Bad_Mechanism
is
4082 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
4085 -- Start of processing for Set_Mechanism_Value
4088 if Mechanism
(Ent
) /= Default_Mechanism
then
4090 ("mechanism for & has already been set", Mech_Name
, Ent
);
4093 -- MECHANISM_NAME ::= value | reference | descriptor
4095 if Nkind
(Mech_Name
) = N_Identifier
then
4096 if Chars
(Mech_Name
) = Name_Value
then
4097 Set_Mechanism
(Ent
, By_Copy
);
4100 elsif Chars
(Mech_Name
) = Name_Reference
then
4101 Set_Mechanism
(Ent
, By_Reference
);
4104 elsif Chars
(Mech_Name
) = Name_Descriptor
then
4105 Check_VMS
(Mech_Name
);
4106 Set_Mechanism
(Ent
, By_Descriptor
);
4109 elsif Chars
(Mech_Name
) = Name_Copy
then
4111 ("bad mechanism name, Value assumed", Mech_Name
);
4117 -- MECHANISM_NAME ::= descriptor (CLASS_NAME)
4118 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
4120 -- Note: this form is parsed as an indexed component
4122 elsif Nkind
(Mech_Name
) = N_Indexed_Component
then
4123 Class
:= First
(Expressions
(Mech_Name
));
4125 if Nkind
(Prefix
(Mech_Name
)) /= N_Identifier
4126 or else Chars
(Prefix
(Mech_Name
)) /= Name_Descriptor
4127 or else Present
(Next
(Class
))
4132 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
4133 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
4135 -- Note: this form is parsed as a function call
4137 elsif Nkind
(Mech_Name
) = N_Function_Call
then
4139 Param
:= First
(Parameter_Associations
(Mech_Name
));
4141 if Nkind
(Name
(Mech_Name
)) /= N_Identifier
4142 or else Chars
(Name
(Mech_Name
)) /= Name_Descriptor
4143 or else Present
(Next
(Param
))
4144 or else No
(Selector_Name
(Param
))
4145 or else Chars
(Selector_Name
(Param
)) /= Name_Class
4149 Class
:= Explicit_Actual_Parameter
(Param
);
4156 -- Fall through here with Class set to descriptor class name
4158 Check_VMS
(Mech_Name
);
4160 if Nkind
(Class
) /= N_Identifier
then
4163 elsif Chars
(Class
) = Name_UBS
then
4164 Set_Mechanism
(Ent
, By_Descriptor_UBS
);
4166 elsif Chars
(Class
) = Name_UBSB
then
4167 Set_Mechanism
(Ent
, By_Descriptor_UBSB
);
4169 elsif Chars
(Class
) = Name_UBA
then
4170 Set_Mechanism
(Ent
, By_Descriptor_UBA
);
4172 elsif Chars
(Class
) = Name_S
then
4173 Set_Mechanism
(Ent
, By_Descriptor_S
);
4175 elsif Chars
(Class
) = Name_SB
then
4176 Set_Mechanism
(Ent
, By_Descriptor_SB
);
4178 elsif Chars
(Class
) = Name_A
then
4179 Set_Mechanism
(Ent
, By_Descriptor_A
);
4181 elsif Chars
(Class
) = Name_NCA
then
4182 Set_Mechanism
(Ent
, By_Descriptor_NCA
);
4187 end Set_Mechanism_Value
;
4189 ---------------------------
4190 -- Set_Ravenscar_Profile --
4191 ---------------------------
4193 -- The tasks to be done here are
4195 -- Set required policies
4197 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
4198 -- pragma Locking_Policy (Ceiling_Locking)
4200 -- Set Detect_Blocking mode
4202 -- Set required restrictions (see System.Rident for detailed list)
4204 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
4206 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
4208 if Task_Dispatching_Policy
/= ' '
4209 and then Task_Dispatching_Policy
/= 'F'
4211 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
4212 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
4214 -- Set the FIFO_Within_Priorities policy, but always
4215 -- preserve System_Location since we like the error
4216 -- message with the run time name.
4219 Task_Dispatching_Policy
:= 'F';
4221 if Task_Dispatching_Policy_Sloc
/= System_Location
then
4222 Task_Dispatching_Policy_Sloc
:= Loc
;
4226 -- pragma Locking_Policy (Ceiling_Locking)
4228 if Locking_Policy
/= ' '
4229 and then Locking_Policy
/= 'C'
4231 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
4232 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
4234 -- Set the Ceiling_Locking policy, but always preserve
4235 -- System_Location since we like the error message with the
4239 Locking_Policy
:= 'C';
4241 if Locking_Policy_Sloc
/= System_Location
then
4242 Locking_Policy_Sloc
:= Loc
;
4246 -- pragma Detect_Blocking
4248 Detect_Blocking
:= True;
4250 -- Set the corresponding restrictions
4252 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> False);
4253 end Set_Ravenscar_Profile
;
4255 -- Start of processing for Analyze_Pragma
4258 if not Is_Pragma_Name
(Chars
(N
)) then
4259 if Warn_On_Unrecognized_Pragma
then
4260 Error_Pragma
("unrecognized pragma%!?");
4265 Prag_Id
:= Get_Pragma_Id
(Chars
(N
));
4275 if Present
(Pragma_Argument_Associations
(N
)) then
4276 Arg1
:= First
(Pragma_Argument_Associations
(N
));
4278 if Present
(Arg1
) then
4279 Arg2
:= Next
(Arg1
);
4281 if Present
(Arg2
) then
4282 Arg3
:= Next
(Arg2
);
4284 if Present
(Arg3
) then
4285 Arg4
:= Next
(Arg3
);
4291 -- Count number of arguments
4298 while Present
(Arg_Node
) loop
4299 Arg_Count
:= Arg_Count
+ 1;
4304 -- An enumeration type defines the pragmas that are supported by the
4305 -- implementation. Get_Pragma_Id (in package Prag) transorms a name
4306 -- into the corresponding enumeration value for the following case.
4314 -- pragma Abort_Defer;
4316 when Pragma_Abort_Defer
=>
4318 Check_Arg_Count
(0);
4320 -- The only required semantic processing is to check the
4321 -- placement. This pragma must appear at the start of the
4322 -- statement sequence of a handled sequence of statements.
4324 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
4325 or else N
/= First
(Statements
(Parent
(N
)))
4336 -- Note: this pragma also has some specific processing in Par.Prag
4337 -- because we want to set the Ada version mode during parsing.
4339 when Pragma_Ada_83
=>
4341 Ada_Version
:= Ada_83
;
4342 Ada_Version_Explicit
:= Ada_Version
;
4343 Check_Arg_Count
(0);
4351 -- Note: this pragma also has some specific processing in Par.Prag
4352 -- because we want to set the Ada 83 version mode during parsing.
4354 when Pragma_Ada_95
=>
4356 Ada_Version
:= Ada_95
;
4357 Ada_Version_Explicit
:= Ada_Version
;
4358 Check_Arg_Count
(0);
4365 -- pragma Ada_05 (LOCAL_NAME);
4367 -- Note: this pragma also has some specific processing in Par.Prag
4368 -- because we want to set the Ada 2005 version mode during parsing.
4370 when Pragma_Ada_05
=> declare
4376 if Arg_Count
= 1 then
4377 Check_Arg_Is_Local_Name
(Arg1
);
4378 E_Id
:= Expression
(Arg1
);
4380 if Etype
(E_Id
) = Any_Type
then
4384 Set_Is_Ada_2005
(Entity
(E_Id
));
4387 Check_Arg_Count
(0);
4388 Ada_Version
:= Ada_05
;
4389 Ada_Version_Explicit
:= Ada_Version
;
4393 ----------------------
4394 -- All_Calls_Remote --
4395 ----------------------
4397 -- pragma All_Calls_Remote [(library_package_NAME)];
4399 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
4400 Lib_Entity
: Entity_Id
;
4403 Check_Ada_83_Warning
;
4404 Check_Valid_Library_Unit_Pragma
;
4406 if Nkind
(N
) = N_Null_Statement
then
4410 Lib_Entity
:= Find_Lib_Unit_Name
;
4412 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
4414 if Present
(Lib_Entity
)
4415 and then not Debug_Flag_U
4417 if not Is_Remote_Call_Interface
(Lib_Entity
) then
4418 Error_Pragma
("pragma% only apply to rci unit");
4420 -- Set flag for entity of the library unit
4423 Set_Has_All_Calls_Remote
(Lib_Entity
);
4427 end All_Calls_Remote
;
4433 -- pragma Annotate (IDENTIFIER {, ARG});
4434 -- ARG ::= NAME | EXPRESSION
4436 when Pragma_Annotate
=> Annotate
: begin
4438 Check_At_Least_N_Arguments
(1);
4439 Check_Arg_Is_Identifier
(Arg1
);
4442 Arg
: Node_Id
:= Arg2
;
4446 while Present
(Arg
) loop
4447 Exp
:= Expression
(Arg
);
4450 if Is_Entity_Name
(Exp
) then
4453 elsif Nkind
(Exp
) = N_String_Literal
then
4454 Resolve
(Exp
, Standard_String
);
4456 elsif Is_Overloaded
(Exp
) then
4457 Error_Pragma_Arg
("ambiguous argument for pragma%", Exp
);
4472 -- pragma Assert ([Check =>] Boolean_EXPRESSION
4473 -- [, [Message =>] Static_String_EXPRESSION]);
4475 when Pragma_Assert
=>
4476 Check_At_Least_N_Arguments
(1);
4477 Check_At_Most_N_Arguments
(2);
4478 Check_Arg_Order
((Name_Check
, Name_Message
));
4479 Check_Optional_Identifier
(Arg1
, Name_Check
);
4481 if Arg_Count
> 1 then
4482 Check_Optional_Identifier
(Arg2
, Name_Message
);
4483 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
4486 -- If expansion is active and assertions are inactive, then
4487 -- we rewrite the Assertion as:
4489 -- if False and then condition then
4493 -- The reason we do this rewriting during semantic analysis
4494 -- rather than as part of normal expansion is that we cannot
4495 -- analyze and expand the code for the boolean expression
4496 -- directly, or it may cause insertion of actions that would
4497 -- escape the attempt to suppress the assertion code.
4499 if Expander_Active
and not Assertions_Enabled
then
4501 Make_If_Statement
(Loc
,
4504 Left_Opnd
=> New_Occurrence_Of
(Standard_False
, Loc
),
4505 Right_Opnd
=> Get_Pragma_Arg
(Arg1
)),
4506 Then_Statements
=> New_List
(
4507 Make_Null_Statement
(Loc
))));
4511 -- Otherwise (if assertions are enabled, or if we are not
4512 -- operating with expansion active), then we just analyze
4513 -- and resolve the expression.
4516 Analyze_And_Resolve
(Expression
(Arg1
), Any_Boolean
);
4519 ----------------------
4520 -- Assertion_Policy --
4521 ----------------------
4523 -- pragma Assertion_Policy (Check | Ignore)
4525 when Pragma_Assertion_Policy
=>
4526 Check_Arg_Count
(1);
4527 Check_Arg_Is_One_Of
(Arg1
, Name_Check
, Name_Ignore
);
4528 Assertions_Enabled
:= Chars
(Expression
(Arg1
)) = Name_Check
;
4534 -- pragma AST_Entry (entry_IDENTIFIER);
4536 when Pragma_AST_Entry
=> AST_Entry
: declare
4542 Check_Arg_Count
(1);
4543 Check_No_Identifiers
;
4544 Check_Arg_Is_Local_Name
(Arg1
);
4545 Ent
:= Entity
(Expression
(Arg1
));
4547 -- Note: the implementation of the AST_Entry pragma could handle
4548 -- the entry family case fine, but for now we are consistent with
4549 -- the DEC rules, and do not allow the pragma, which of course
4550 -- has the effect of also forbidding the attribute.
4552 if Ekind
(Ent
) /= E_Entry
then
4554 ("pragma% argument must be simple entry name", Arg1
);
4556 elsif Is_AST_Entry
(Ent
) then
4558 ("duplicate % pragma for entry", Arg1
);
4560 elsif Has_Homonym
(Ent
) then
4562 ("pragma% argument cannot specify overloaded entry", Arg1
);
4566 FF
: constant Entity_Id
:= First_Formal
(Ent
);
4569 if Present
(FF
) then
4570 if Present
(Next_Formal
(FF
)) then
4572 ("entry for pragma% can have only one argument",
4575 elsif Parameter_Mode
(FF
) /= E_In_Parameter
then
4577 ("entry parameter for pragma% must have mode IN",
4583 Set_Is_AST_Entry
(Ent
);
4591 -- pragma Asynchronous (LOCAL_NAME);
4593 when Pragma_Asynchronous
=> Asynchronous
: declare
4601 procedure Process_Async_Pragma
;
4602 -- Common processing for procedure and access-to-procedure case
4604 --------------------------
4605 -- Process_Async_Pragma --
4606 --------------------------
4608 procedure Process_Async_Pragma
is
4610 if not Present
(L
) then
4611 Set_Is_Asynchronous
(Nm
);
4615 -- The formals should be of mode IN (RM E.4.1(6))
4618 while Present
(S
) loop
4619 Formal
:= Defining_Identifier
(S
);
4621 if Nkind
(Formal
) = N_Defining_Identifier
4622 and then Ekind
(Formal
) /= E_In_Parameter
4625 ("pragma% procedure can only have IN parameter",
4632 Set_Is_Asynchronous
(Nm
);
4633 end Process_Async_Pragma
;
4635 -- Start of processing for pragma Asynchronous
4638 Check_Ada_83_Warning
;
4639 Check_No_Identifiers
;
4640 Check_Arg_Count
(1);
4641 Check_Arg_Is_Local_Name
(Arg1
);
4643 if Debug_Flag_U
then
4647 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
4648 Analyze
(Expression
(Arg1
));
4649 Nm
:= Entity
(Expression
(Arg1
));
4651 if not Is_Remote_Call_Interface
(C_Ent
)
4652 and then not Is_Remote_Types
(C_Ent
)
4654 -- This pragma should only appear in an RCI or Remote Types
4655 -- unit (RM E.4.1(4))
4658 ("pragma% not in Remote_Call_Interface or " &
4659 "Remote_Types unit");
4662 if Ekind
(Nm
) = E_Procedure
4663 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
4665 if not Is_Remote_Call_Interface
(Nm
) then
4667 ("pragma% cannot be applied on non-remote procedure",
4671 L
:= Parameter_Specifications
(Parent
(Nm
));
4672 Process_Async_Pragma
;
4675 elsif Ekind
(Nm
) = E_Function
then
4677 ("pragma% cannot be applied to function", Arg1
);
4679 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
4681 if Is_Record_Type
(Nm
) then
4682 -- A record type that is the Equivalent_Type for
4683 -- a remote access-to-subprogram type.
4685 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
4688 -- A non-expanded RAS type (case where distribution is
4691 N
:= Declaration_Node
(Nm
);
4694 if Nkind
(N
) = N_Full_Type_Declaration
4695 and then Nkind
(Type_Definition
(N
)) =
4696 N_Access_Procedure_Definition
4698 L
:= Parameter_Specifications
(Type_Definition
(N
));
4699 Process_Async_Pragma
;
4701 if Is_Asynchronous
(Nm
)
4702 and then Expander_Active
4703 and then Get_PCS_Name
/= Name_No_DSA
4705 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
4710 ("pragma% cannot reference access-to-function type",
4714 -- Only other possibility is Access-to-class-wide type
4716 elsif Is_Access_Type
(Nm
)
4717 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
4719 Check_First_Subtype
(Arg1
);
4720 Set_Is_Asynchronous
(Nm
);
4721 if Expander_Active
then
4722 RACW_Type_Is_Asynchronous
(Nm
);
4726 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
4734 -- pragma Atomic (LOCAL_NAME);
4736 when Pragma_Atomic
=>
4737 Process_Atomic_Shared_Volatile
;
4739 -----------------------
4740 -- Atomic_Components --
4741 -----------------------
4743 -- pragma Atomic_Components (array_LOCAL_NAME);
4745 -- This processing is shared by Volatile_Components
4747 when Pragma_Atomic_Components |
4748 Pragma_Volatile_Components
=>
4750 Atomic_Components
: declare
4757 Check_Ada_83_Warning
;
4758 Check_No_Identifiers
;
4759 Check_Arg_Count
(1);
4760 Check_Arg_Is_Local_Name
(Arg1
);
4761 E_Id
:= Expression
(Arg1
);
4763 if Etype
(E_Id
) = Any_Type
then
4769 if Rep_Item_Too_Early
(E
, N
)
4771 Rep_Item_Too_Late
(E
, N
)
4776 D
:= Declaration_Node
(E
);
4779 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
4781 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
4782 and then Nkind
(D
) = N_Object_Declaration
4783 and then Nkind
(Object_Definition
(D
)) =
4784 N_Constrained_Array_Definition
)
4786 -- The flag is set on the object, or on the base type
4788 if Nkind
(D
) /= N_Object_Declaration
then
4792 Set_Has_Volatile_Components
(E
);
4794 if Prag_Id
= Pragma_Atomic_Components
then
4795 Set_Has_Atomic_Components
(E
);
4797 if Is_Packed
(E
) then
4798 Set_Is_Packed
(E
, False);
4801 ("?Pack canceled, cannot pack atomic components",
4807 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
4809 end Atomic_Components
;
4811 --------------------
4812 -- Attach_Handler --
4813 --------------------
4815 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
4817 when Pragma_Attach_Handler
=>
4818 Check_Ada_83_Warning
;
4819 Check_No_Identifiers
;
4820 Check_Arg_Count
(2);
4822 if No_Run_Time_Mode
then
4823 Error_Msg_CRT
("Attach_Handler pragma", N
);
4825 Check_Interrupt_Or_Attach_Handler
;
4827 -- The expression that designates the attribute may
4828 -- depend on a discriminant, and is therefore a per-
4829 -- object expression, to be expanded in the init proc.
4830 -- If expansion is enabled, perform semantic checks
4833 if Expander_Active
then
4835 Temp
: constant Node_Id
:=
4836 New_Copy_Tree
(Expression
(Arg2
));
4838 Set_Parent
(Temp
, N
);
4839 Pre_Analyze_And_Resolve
(Temp
, RTE
(RE_Interrupt_ID
));
4843 Analyze
(Expression
(Arg2
));
4844 Resolve
(Expression
(Arg2
), RTE
(RE_Interrupt_ID
));
4847 Process_Interrupt_Or_Attach_Handler
;
4850 --------------------
4851 -- C_Pass_By_Copy --
4852 --------------------
4854 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
4856 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
4862 Check_Valid_Configuration_Pragma
;
4863 Check_Arg_Count
(1);
4864 Check_Optional_Identifier
(Arg1
, "max_size");
4866 Arg
:= Expression
(Arg1
);
4867 Check_Arg_Is_Static_Expression
(Arg
, Any_Integer
);
4869 Val
:= Expr_Value
(Arg
);
4873 ("maximum size for pragma% must be positive", Arg1
);
4875 elsif UI_Is_In_Int_Range
(Val
) then
4876 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
4878 -- If a giant value is given, Int'Last will do well enough.
4879 -- If sometime someone complains that a record larger than
4880 -- two gigabytes is not copied, we will worry about it then!
4883 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
4891 -- pragma Comment (static_string_EXPRESSION)
4893 -- Processing for pragma Comment shares the circuitry for
4894 -- pragma Ident. The only differences are that Ident enforces
4895 -- a limit of 31 characters on its argument, and also enforces
4896 -- limitations on placement for DEC compatibility. Pragma
4897 -- Comment shares neither of these restrictions.
4903 -- pragma Common_Object (
4904 -- [Internal =>] LOCAL_NAME,
4905 -- [, [External =>] EXTERNAL_SYMBOL]
4906 -- [, [Size =>] EXTERNAL_SYMBOL]);
4908 -- Processing for this pragma is shared with Psect_Object
4910 --------------------------
4911 -- Compile_Time_Warning --
4912 --------------------------
4914 -- pragma Compile_Time_Warning
4915 -- (boolean_EXPRESSION, static_string_EXPRESSION);
4917 when Pragma_Compile_Time_Warning
=> Compile_Time_Warning
: declare
4918 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
4922 Check_Arg_Count
(2);
4923 Check_No_Identifiers
;
4924 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
4925 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
4927 if Compile_Time_Known_Value
(Arg1x
) then
4928 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
4929 String_To_Name_Buffer
(Strval
(Get_Pragma_Arg
(Arg2
)));
4930 Add_Char_To_Name_Buffer
('?');
4933 Msg
: String (1 .. Name_Len
) :=
4934 Name_Buffer
(1 .. Name_Len
);
4939 -- This loop looks for multiple lines separated by
4940 -- ASCII.LF and breaks them into continuation error
4941 -- messages marked with the usual back slash.
4944 for S
in 2 .. Msg
'Length - 1 loop
4945 if Msg
(S
) = ASCII
.LF
then
4947 Error_Msg_N
(Msg
(B
.. S
), Arg1
);
4953 Error_Msg_N
(Msg
(B
.. Msg
'Length), Arg1
);
4957 end Compile_Time_Warning
;
4959 ----------------------------
4960 -- Complex_Representation --
4961 ----------------------------
4963 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
4965 when Pragma_Complex_Representation
=> Complex_Representation
: declare
4972 Check_Arg_Count
(1);
4973 Check_Optional_Identifier
(Arg1
, Name_Entity
);
4974 Check_Arg_Is_Local_Name
(Arg1
);
4975 E_Id
:= Expression
(Arg1
);
4977 if Etype
(E_Id
) = Any_Type
then
4983 if not Is_Record_Type
(E
) then
4985 ("argument for pragma% must be record type", Arg1
);
4988 Ent
:= First_Entity
(E
);
4991 or else No
(Next_Entity
(Ent
))
4992 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
4993 or else not Is_Floating_Point_Type
(Etype
(Ent
))
4994 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
4997 ("record for pragma% must have two fields of same fpt type",
5001 Set_Has_Complex_Representation
(Base_Type
(E
));
5003 end Complex_Representation
;
5005 -------------------------
5006 -- Component_Alignment --
5007 -------------------------
5009 -- pragma Component_Alignment (
5010 -- [Form =>] ALIGNMENT_CHOICE
5011 -- [, [Name =>] type_LOCAL_NAME]);
5013 -- ALIGNMENT_CHOICE ::=
5015 -- | Component_Size_4
5019 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
5020 Args
: Args_List
(1 .. 2);
5021 Names
: constant Name_List
(1 .. 2) := (
5025 Form
: Node_Id
renames Args
(1);
5026 Name
: Node_Id
renames Args
(2);
5028 Atype
: Component_Alignment_Kind
;
5033 Gather_Associations
(Names
, Args
);
5036 Error_Pragma
("missing Form argument for pragma%");
5039 Check_Arg_Is_Identifier
(Form
);
5041 -- Get proper alignment, note that Default = Component_Size
5042 -- on all machines we have so far, and we want to set this
5043 -- value rather than the default value to indicate that it
5044 -- has been explicitly set (and thus will not get overridden
5045 -- by the default component alignment for the current scope)
5047 if Chars
(Form
) = Name_Component_Size
then
5048 Atype
:= Calign_Component_Size
;
5050 elsif Chars
(Form
) = Name_Component_Size_4
then
5051 Atype
:= Calign_Component_Size_4
;
5053 elsif Chars
(Form
) = Name_Default
then
5054 Atype
:= Calign_Component_Size
;
5056 elsif Chars
(Form
) = Name_Storage_Unit
then
5057 Atype
:= Calign_Storage_Unit
;
5061 ("invalid Form parameter for pragma%", Form
);
5064 -- Case with no name, supplied, affects scope table entry
5068 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
5070 -- Case of name supplied
5073 Check_Arg_Is_Local_Name
(Name
);
5075 Typ
:= Entity
(Name
);
5078 or else Rep_Item_Too_Early
(Typ
, N
)
5082 Typ
:= Underlying_Type
(Typ
);
5085 if not Is_Record_Type
(Typ
)
5086 and then not Is_Array_Type
(Typ
)
5089 ("Name parameter of pragma% must identify record or " &
5090 "array type", Name
);
5093 -- An explicit Component_Alignment pragma overrides an
5094 -- implicit pragma Pack, but not an explicit one.
5096 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
5097 Set_Is_Packed
(Base_Type
(Typ
), False);
5098 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
5101 end Component_AlignmentP
;
5107 -- pragma Controlled (first_subtype_LOCAL_NAME);
5109 when Pragma_Controlled
=> Controlled
: declare
5113 Check_No_Identifiers
;
5114 Check_Arg_Count
(1);
5115 Check_Arg_Is_Local_Name
(Arg1
);
5116 Arg
:= Expression
(Arg1
);
5118 if not Is_Entity_Name
(Arg
)
5119 or else not Is_Access_Type
(Entity
(Arg
))
5121 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
5123 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
5131 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
5132 -- [Entity =>] LOCAL_NAME);
5134 when Pragma_Convention
=> Convention
: declare
5138 Check_Arg_Order
((Name_Convention
, Name_Entity
));
5139 Check_Ada_83_Warning
;
5140 Check_Arg_Count
(2);
5141 Process_Convention
(C
, E
);
5144 ---------------------------
5145 -- Convention_Identifier --
5146 ---------------------------
5148 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
5149 -- [Convention =>] convention_IDENTIFIER);
5151 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
5157 Check_Arg_Order
((Name_Name
, Name_Convention
));
5158 Check_Arg_Count
(2);
5159 Check_Optional_Identifier
(Arg1
, Name_Name
);
5160 Check_Optional_Identifier
(Arg2
, Name_Convention
);
5161 Check_Arg_Is_Identifier
(Arg1
);
5162 Check_Arg_Is_Identifier
(Arg1
);
5163 Idnam
:= Chars
(Expression
(Arg1
));
5164 Cname
:= Chars
(Expression
(Arg2
));
5166 if Is_Convention_Name
(Cname
) then
5167 Record_Convention_Identifier
5168 (Idnam
, Get_Convention_Id
(Cname
));
5171 ("second arg for % pragma must be convention", Arg2
);
5173 end Convention_Identifier
;
5179 -- pragma CPP_Class ([Entity =>] local_NAME)
5181 when Pragma_CPP_Class
=> CPP_Class
: declare
5184 Default_DTC
: Entity_Id
:= Empty
;
5185 VTP_Type
: constant Entity_Id
:= RTE
(RE_Vtable_Ptr
);
5191 Check_Arg_Count
(1);
5192 Check_Optional_Identifier
(Arg1
, Name_Entity
);
5193 Check_Arg_Is_Local_Name
(Arg1
);
5195 Arg
:= Expression
(Arg1
);
5198 if Etype
(Arg
) = Any_Type
then
5202 if not Is_Entity_Name
(Arg
)
5203 or else not Is_Type
(Entity
(Arg
))
5205 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
5208 Typ
:= Entity
(Arg
);
5210 if not Is_Record_Type
(Typ
) then
5211 Error_Pragma_Arg
("pragma% applicable to a record, "
5212 & "tagged record or record extension", Arg1
);
5215 Default_DTC
:= First_Component
(Typ
);
5216 while Present
(Default_DTC
)
5217 and then Etype
(Default_DTC
) /= VTP_Type
5219 Next_Component
(Default_DTC
);
5222 -- Case of non tagged type
5224 if not Is_Tagged_Type
(Typ
) then
5225 Set_Is_CPP_Class
(Typ
);
5227 if Present
(Default_DTC
) then
5229 ("only tagged records can contain vtable pointers", Arg1
);
5232 -- Case of tagged type with no vtable ptr
5234 -- What is test for Typ = Root_Typ (Typ) about here ???
5236 elsif Is_Tagged_Type
(Typ
)
5237 and then Typ
= Root_Type
(Typ
)
5238 and then No
(Default_DTC
)
5241 ("a cpp_class must contain a vtable pointer", Arg1
);
5243 -- Tagged type that has a vtable ptr
5245 elsif Present
(Default_DTC
) then
5246 Set_Is_CPP_Class
(Typ
);
5247 Set_Is_Limited_Record
(Typ
);
5248 Set_Is_Tag
(Default_DTC
);
5249 Set_DT_Entry_Count
(Default_DTC
, No_Uint
);
5251 -- Since a CPP type has no direct link to its associated tag
5252 -- most tags checks cannot be performed
5254 Set_Kill_Tag_Checks
(Typ
);
5255 Set_Kill_Tag_Checks
(Class_Wide_Type
(Typ
));
5257 -- Get rid of the _tag component when there was one.
5258 -- It is only useful for regular tagged types
5260 if Expander_Active
and then Typ
= Root_Type
(Typ
) then
5262 Tag_C
:= First_Tag_Component
(Typ
);
5263 C
:= First_Entity
(Typ
);
5266 Set_First_Entity
(Typ
, Next_Entity
(Tag_C
));
5269 while Next_Entity
(C
) /= Tag_C
loop
5273 Set_Next_Entity
(C
, Next_Entity
(Tag_C
));
5279 ---------------------
5280 -- CPP_Constructor --
5281 ---------------------
5283 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME);
5285 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
5291 Check_Arg_Count
(1);
5292 Check_Optional_Identifier
(Arg1
, Name_Entity
);
5293 Check_Arg_Is_Local_Name
(Arg1
);
5295 Id
:= Expression
(Arg1
);
5296 Find_Program_Unit_Name
(Id
);
5298 -- If we did not find the name, we are done
5300 if Etype
(Id
) = Any_Type
then
5304 Def_Id
:= Entity
(Id
);
5306 if Ekind
(Def_Id
) = E_Function
5307 and then Is_Class_Wide_Type
(Etype
(Def_Id
))
5308 and then Is_CPP_Class
(Etype
(Etype
(Def_Id
)))
5310 -- What the heck is this??? this pragma allows only 1 arg
5312 if Arg_Count
>= 2 then
5313 Check_At_Most_N_Arguments
(3);
5314 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
5317 if No
(Parameter_Specifications
(Parent
(Def_Id
))) then
5318 Set_Has_Completion
(Def_Id
);
5319 Set_Is_Constructor
(Def_Id
);
5322 ("non-default constructors not implemented", Arg1
);
5327 ("pragma% requires function returning a 'C'P'P_Class type",
5330 end CPP_Constructor
;
5336 -- pragma CPP_Virtual
5337 -- [Entity =>] LOCAL_NAME
5338 -- [ [Vtable_Ptr =>] LOCAL_NAME,
5339 -- [Position =>] static_integer_EXPRESSION]);
5341 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
5345 VTP_Type
: constant Entity_Id
:= RTE
(RE_Vtable_Ptr
);
5351 Check_Arg_Order
((Name_Entity
, Name_Vtable_Ptr
, Name_Position
));
5353 if Arg_Count
= 3 then
5354 Check_Optional_Identifier
(Arg2
, Name_Vtable_Ptr
);
5356 -- We allow Entry_Count as well as Position for the third
5357 -- parameter for back compatibility with versions of GNAT
5358 -- before version 3.12. The documentation has always said
5359 -- Position, but the code up to 3.12 said Entry_Count.
5361 if Chars
(Arg3
) /= Name_Entry_Count
then
5362 Check_Optional_Identifier
(Arg3
, Name_Position
);
5366 Check_Arg_Count
(1);
5369 Check_Optional_Identifier
(Arg1
, Name_Entity
);
5370 Check_Arg_Is_Local_Name
(Arg1
);
5372 -- First argument must be a subprogram name
5374 Arg
:= Expression
(Arg1
);
5375 Find_Program_Unit_Name
(Arg
);
5377 if Etype
(Arg
) = Any_Type
then
5380 Subp
:= Entity
(Arg
);
5383 if not (Is_Subprogram
(Subp
)
5384 and then Is_Dispatching_Operation
(Subp
))
5387 ("pragma% must reference a primitive operation", Arg1
);
5390 Typ
:= Find_Dispatching_Type
(Subp
);
5392 -- If only one Argument defaults are :
5393 -- . DTC_Entity is the default Vtable pointer
5394 -- . DT_Position will be set at the freezing point
5396 if Arg_Count
= 1 then
5397 Set_DTC_Entity
(Subp
, First_Tag_Component
(Typ
));
5401 -- Second argument is a component name of type Vtable_Ptr
5403 Arg
:= Expression
(Arg2
);
5405 if Nkind
(Arg
) /= N_Identifier
then
5406 Error_Msg_NE
("must be a& component name", Arg
, Typ
);
5410 DTC
:= First_Component
(Typ
);
5411 while Present
(DTC
) and then Chars
(DTC
) /= Chars
(Arg
) loop
5412 Next_Component
(DTC
);
5416 Error_Msg_NE
("must be a& component name", Arg
, Typ
);
5419 elsif Etype
(DTC
) /= VTP_Type
then
5420 Wrong_Type
(Arg
, VTP_Type
);
5424 -- Third argument is an integer (DT_Position)
5426 Arg
:= Expression
(Arg3
);
5427 Analyze_And_Resolve
(Arg
, Any_Integer
);
5429 if not Is_Static_Expression
(Arg
) then
5430 Flag_Non_Static_Expr
5431 ("third argument of pragma CPP_Virtual must be static!",
5436 V
:= Expr_Value
(Expression
(Arg3
));
5440 ("third argument of pragma% must be positive",
5444 Set_DTC_Entity
(Subp
, DTC
);
5445 Set_DT_Position
(Subp
, V
);
5454 -- pragma CPP_Vtable (
5455 -- [Entity =>] LOCAL_NAME
5456 -- [Vtable_Ptr =>] LOCAL_NAME,
5457 -- [Entry_Count =>] static_integer_EXPRESSION);
5459 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
5462 VTP_Type
: constant Entity_Id
:= RTE
(RE_Vtable_Ptr
);
5469 Check_Arg_Order
((Name_Entity
, Name_Vtable_Ptr
, Name_Entry_Count
));
5470 Check_Arg_Count
(3);
5471 Check_Optional_Identifier
(Arg1
, Name_Entity
);
5472 Check_Optional_Identifier
(Arg2
, Name_Vtable_Ptr
);
5473 Check_Optional_Identifier
(Arg3
, Name_Entry_Count
);
5474 Check_Arg_Is_Local_Name
(Arg1
);
5476 -- First argument is a record type name
5478 Arg
:= Expression
(Arg1
);
5481 if Etype
(Arg
) = Any_Type
then
5484 Typ
:= Entity
(Arg
);
5487 if not (Is_Tagged_Type
(Typ
) and then Is_CPP_Class
(Typ
)) then
5488 Error_Pragma_Arg
("'C'P'P_Class tagged type expected", Arg1
);
5491 -- Second argument is a component name of type Vtable_Ptr
5493 Arg
:= Expression
(Arg2
);
5495 if Nkind
(Arg
) /= N_Identifier
then
5496 Error_Msg_NE
("must be a& component name", Arg
, Typ
);
5500 DTC
:= First_Component
(Typ
);
5501 while Present
(DTC
) and then Chars
(DTC
) /= Chars
(Arg
) loop
5502 Next_Component
(DTC
);
5506 Error_Msg_NE
("must be a& component name", Arg
, Typ
);
5509 elsif Etype
(DTC
) /= VTP_Type
then
5510 Wrong_Type
(DTC
, VTP_Type
);
5513 -- If it is the first pragma Vtable, This becomes the default tag
5515 elsif (not Is_Tag
(DTC
))
5516 and then DT_Entry_Count
(First_Tag_Component
(Typ
)) = No_Uint
5518 Set_Is_Tag
(First_Tag_Component
(Typ
), False);
5519 Set_Is_Tag
(DTC
, True);
5520 Set_DT_Entry_Count
(DTC
, No_Uint
);
5523 -- Those pragmas must appear before any primitive operation
5524 -- definition (except inherited ones) otherwise the default
5527 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
5528 while Present
(Elmt
) loop
5529 if No
(Alias
(Node
(Elmt
))) then
5530 Error_Msg_Sloc
:= Sloc
(Node
(Elmt
));
5532 ("pragma% must appear before this primitive operation");
5538 -- Third argument is an integer (DT_Entry_Count)
5540 Arg
:= Expression
(Arg3
);
5541 Analyze_And_Resolve
(Arg
, Any_Integer
);
5543 if not Is_Static_Expression
(Arg
) then
5544 Flag_Non_Static_Expr
5545 ("entry count for pragma CPP_Vtable must be a static " &
5546 "expression!", Arg3
);
5550 V
:= Expr_Value
(Expression
(Arg3
));
5554 ("entry count for pragma% must be positive", Arg3
);
5556 Set_DT_Entry_Count
(DTC
, V
);
5565 -- pragma Debug (PROCEDURE_CALL_STATEMENT);
5567 when Pragma_Debug
=> Debug
: begin
5570 -- Rewrite into a conditional with a static condition
5572 Rewrite
(N
, Make_Implicit_If_Statement
(N
,
5573 Condition
=> New_Occurrence_Of
(Boolean_Literals
(
5574 Debug_Pragmas_Enabled
and Expander_Active
), Loc
),
5575 Then_Statements
=> New_List
(
5576 Relocate_Node
(Debug_Statement
(N
)))));
5584 -- pragma Debug_Policy (Check | Ignore)
5586 when Pragma_Debug_Policy
=>
5588 Check_Arg_Count
(1);
5589 Check_Arg_Is_One_Of
(Arg1
, Name_Check
, Name_Ignore
);
5590 Debug_Pragmas_Enabled
:= Chars
(Expression
(Arg1
)) = Name_Check
;
5592 ---------------------
5593 -- Detect_Blocking --
5594 ---------------------
5596 -- pragma Detect_Blocking;
5598 when Pragma_Detect_Blocking
=>
5600 Check_Arg_Count
(0);
5601 Check_Valid_Configuration_Pragma
;
5602 Detect_Blocking
:= True;
5608 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
5610 when Pragma_Discard_Names
=> Discard_Names
: declare
5615 Check_Ada_83_Warning
;
5617 -- Deal with configuration pragma case
5619 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
5620 Global_Discard_Names
:= True;
5623 -- Otherwise, check correct appropriate context
5626 Check_Is_In_Decl_Part_Or_Package_Spec
;
5628 if Arg_Count
= 0 then
5630 -- If there is no parameter, then from now on this pragma
5631 -- applies to any enumeration, exception or tagged type
5632 -- defined in the current declarative part.
5634 Set_Discard_Names
(Current_Scope
);
5638 Check_Arg_Count
(1);
5639 Check_Optional_Identifier
(Arg1
, Name_On
);
5640 Check_Arg_Is_Local_Name
(Arg1
);
5641 E_Id
:= Expression
(Arg1
);
5643 if Etype
(E_Id
) = Any_Type
then
5649 if (Is_First_Subtype
(E
)
5650 and then (Is_Enumeration_Type
(E
)
5651 or else Is_Tagged_Type
(E
)))
5652 or else Ekind
(E
) = E_Exception
5654 Set_Discard_Names
(E
);
5657 ("inappropriate entity for pragma%", Arg1
);
5667 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
5669 when Pragma_Elaborate
=> Elaborate
: declare
5671 Parent_Node
: Node_Id
;
5676 -- Pragma must be in context items list of a compilation unit
5678 if not Is_List_Member
(N
) then
5683 Plist
:= List_Containing
(N
);
5684 Parent_Node
:= Parent
(Plist
);
5686 if Parent_Node
= Empty
5687 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
5688 or else Context_Items
(Parent_Node
) /= Plist
5695 -- Must be at least one argument
5697 if Arg_Count
= 0 then
5698 Error_Pragma
("pragma% requires at least one argument");
5701 -- In Ada 83 mode, there can be no items following it in the
5702 -- context list except other pragmas and implicit with clauses
5703 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
5704 -- placement rule does not apply.
5706 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
5709 while Present
(Citem
) loop
5710 if Nkind
(Citem
) = N_Pragma
5711 or else (Nkind
(Citem
) = N_With_Clause
5712 and then Implicit_With
(Citem
))
5717 ("(Ada 83) pragma% must be at end of context clause");
5724 -- Finally, the arguments must all be units mentioned in a with
5725 -- clause in the same context clause. Note we already checked
5726 -- (in Par.Prag) that the arguments are either identifiers or
5729 Outer
: while Present
(Arg
) loop
5730 Citem
:= First
(Plist
);
5732 Inner
: while Citem
/= N
loop
5733 if Nkind
(Citem
) = N_With_Clause
5734 and then Same_Name
(Name
(Citem
), Expression
(Arg
))
5736 Set_Elaborate_Present
(Citem
, True);
5737 Set_Unit_Name
(Expression
(Arg
), Name
(Citem
));
5739 -- With the pragma present, elaboration calls on
5740 -- subprograms from the named unit need no further
5741 -- checks, as long as the pragma appears in the current
5742 -- compilation unit. If the pragma appears in some unit
5743 -- in the context, there might still be a need for an
5744 -- Elaborate_All_Desirable from the current compilation
5745 -- to the the named unit, so we keep the check enabled.
5747 if In_Extended_Main_Source_Unit
(N
) then
5748 Set_Suppress_Elaboration_Warnings
5749 (Entity
(Name
(Citem
)));
5759 ("argument of pragma% is not with'ed unit", Arg
);
5765 -- Give a warning if operating in static mode with -gnatwl
5766 -- (elaboration warnings eanbled) switch set.
5768 if Elab_Warnings
and not Dynamic_Elaboration_Checks
then
5770 ("?use of pragma Elaborate may not be safe", N
);
5772 ("?use pragma Elaborate_All instead if possible", N
);
5780 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
5782 when Pragma_Elaborate_All
=> Elaborate_All
: declare
5784 Parent_Node
: Node_Id
;
5789 Check_Ada_83_Warning
;
5791 -- Pragma must be in context items list of a compilation unit
5793 if not Is_List_Member
(N
) then
5798 Plist
:= List_Containing
(N
);
5799 Parent_Node
:= Parent
(Plist
);
5801 if Parent_Node
= Empty
5802 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
5803 or else Context_Items
(Parent_Node
) /= Plist
5810 -- Must be at least one argument
5812 if Arg_Count
= 0 then
5813 Error_Pragma
("pragma% requires at least one argument");
5816 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
5817 -- have to appear at the end of the context clause, but may
5818 -- appear mixed in with other items, even in Ada 83 mode.
5820 -- Final check: the arguments must all be units mentioned in
5821 -- a with clause in the same context clause. Note that we
5822 -- already checked (in Par.Prag) that all the arguments are
5823 -- either identifiers or selected components.
5826 Outr
: while Present
(Arg
) loop
5827 Citem
:= First
(Plist
);
5829 Innr
: while Citem
/= N
loop
5830 if Nkind
(Citem
) = N_With_Clause
5831 and then Same_Name
(Name
(Citem
), Expression
(Arg
))
5833 Set_Elaborate_All_Present
(Citem
, True);
5834 Set_Unit_Name
(Expression
(Arg
), Name
(Citem
));
5836 -- Suppress warnings and elaboration checks on the named
5837 -- unit if the pragma is in the current compilation, as
5838 -- for pragma Elaborate.
5840 if In_Extended_Main_Source_Unit
(N
) then
5841 Set_Suppress_Elaboration_Warnings
5842 (Entity
(Name
(Citem
)));
5851 Set_Error_Posted
(N
);
5853 ("argument of pragma% is not with'ed unit", Arg
);
5860 --------------------
5861 -- Elaborate_Body --
5862 --------------------
5864 -- pragma Elaborate_Body [( library_unit_NAME )];
5866 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
5867 Cunit_Node
: Node_Id
;
5868 Cunit_Ent
: Entity_Id
;
5871 Check_Ada_83_Warning
;
5872 Check_Valid_Library_Unit_Pragma
;
5874 if Nkind
(N
) = N_Null_Statement
then
5878 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
5879 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
5881 if Nkind
(Unit
(Cunit_Node
)) = N_Package_Body
5883 Nkind
(Unit
(Cunit_Node
)) = N_Subprogram_Body
5885 Error_Pragma
("pragma% must refer to a spec, not a body");
5887 Set_Body_Required
(Cunit_Node
, True);
5888 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
5890 -- If we are in dynamic elaboration mode, then we suppress
5891 -- elaboration warnings for the unit, since it is definitely
5892 -- fine NOT to do dynamic checks at the first level (and such
5893 -- checks will be suppressed because no elaboration boolean
5894 -- is created for Elaborate_Body packages).
5896 -- But in the static model of elaboration, Elaborate_Body is
5897 -- definitely NOT good enough to ensure elaboration safety on
5898 -- its own, since the body may WITH other units that are not
5899 -- safe from an elaboration point of view, so a client must
5900 -- still do an Elaborate_All on such units.
5902 -- Debug flag -gnatdD restores the old behavior of 3.13,
5903 -- where Elaborate_Body always suppressed elab warnings.
5905 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
5906 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
5911 ------------------------
5912 -- Elaboration_Checks --
5913 ------------------------
5915 -- pragma Elaboration_Checks (Static | Dynamic);
5917 when Pragma_Elaboration_Checks
=>
5919 Check_Arg_Count
(1);
5920 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
5921 Dynamic_Elaboration_Checks
:=
5922 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
);
5928 -- pragma Eliminate (
5929 -- [Unit_Name =>] IDENTIFIER |
5930 -- SELECTED_COMPONENT
5931 -- [,[Entity =>] IDENTIFIER |
5932 -- SELECTED_COMPONENT |
5934 -- [,]OVERLOADING_RESOLUTION);
5936 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
5939 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
5942 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
5944 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
5945 -- Result_Type => result_SUBTYPE_NAME]
5947 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
5948 -- SUBTYPE_NAME ::= STRING_LITERAL
5950 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
5951 -- SOURCE_TRACE ::= STRING_LITERAL
5953 when Pragma_Eliminate
=> Eliminate
: declare
5954 Args
: Args_List
(1 .. 5);
5955 Names
: constant Name_List
(1 .. 5) := (
5958 Name_Parameter_Types
,
5960 Name_Source_Location
);
5962 Unit_Name
: Node_Id
renames Args
(1);
5963 Entity
: Node_Id
renames Args
(2);
5964 Parameter_Types
: Node_Id
renames Args
(3);
5965 Result_Type
: Node_Id
renames Args
(4);
5966 Source_Location
: Node_Id
renames Args
(5);
5970 Check_Valid_Configuration_Pragma
;
5971 Gather_Associations
(Names
, Args
);
5973 if No
(Unit_Name
) then
5974 Error_Pragma
("missing Unit_Name argument for pragma%");
5978 and then (Present
(Parameter_Types
)
5980 Present
(Result_Type
)
5982 Present
(Source_Location
))
5984 Error_Pragma
("missing Entity argument for pragma%");
5987 if (Present
(Parameter_Types
)
5989 Present
(Result_Type
))
5991 Present
(Source_Location
)
5994 ("parameter profile and source location can not " &
5995 "be used together in pragma%");
5998 Process_Eliminate_Pragma
6007 -------------------------
6008 -- Explicit_Overriding --
6009 -------------------------
6011 when Pragma_Explicit_Overriding
=>
6012 Check_Valid_Configuration_Pragma
;
6013 Check_Arg_Count
(0);
6014 Explicit_Overriding
:= True;
6021 -- [ Convention =>] convention_IDENTIFIER,
6022 -- [ Entity =>] local_NAME
6023 -- [, [External_Name =>] static_string_EXPRESSION ]
6024 -- [, [Link_Name =>] static_string_EXPRESSION ]);
6026 when Pragma_Export
=> Export
: declare
6031 Check_Ada_83_Warning
;
6037 Check_At_Least_N_Arguments
(2);
6038 Check_At_Most_N_Arguments
(4);
6039 Process_Convention
(C
, Def_Id
);
6041 if Ekind
(Def_Id
) /= E_Constant
then
6042 Note_Possible_Modification
(Expression
(Arg2
));
6045 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
6046 Set_Exported
(Def_Id
, Arg2
);
6049 ----------------------
6050 -- Export_Exception --
6051 ----------------------
6053 -- pragma Export_Exception (
6054 -- [Internal =>] LOCAL_NAME,
6055 -- [, [External =>] EXTERNAL_SYMBOL,]
6056 -- [, [Form =>] Ada | VMS]
6057 -- [, [Code =>] static_integer_EXPRESSION]);
6059 when Pragma_Export_Exception
=> Export_Exception
: declare
6060 Args
: Args_List
(1 .. 4);
6061 Names
: constant Name_List
(1 .. 4) := (
6067 Internal
: Node_Id
renames Args
(1);
6068 External
: Node_Id
renames Args
(2);
6069 Form
: Node_Id
renames Args
(3);
6070 Code
: Node_Id
renames Args
(4);
6073 if Inside_A_Generic
then
6074 Error_Pragma
("pragma% cannot be used for generic entities");
6077 Gather_Associations
(Names
, Args
);
6078 Process_Extended_Import_Export_Exception_Pragma
(
6079 Arg_Internal
=> Internal
,
6080 Arg_External
=> External
,
6084 if not Is_VMS_Exception
(Entity
(Internal
)) then
6085 Set_Exported
(Entity
(Internal
), Internal
);
6087 end Export_Exception
;
6089 ---------------------
6090 -- Export_Function --
6091 ---------------------
6093 -- pragma Export_Function (
6094 -- [Internal =>] LOCAL_NAME,
6095 -- [, [External =>] EXTERNAL_SYMBOL,]
6096 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
6097 -- [, [Result_Type =>] TYPE_DESIGNATOR]
6098 -- [, [Mechanism =>] MECHANISM]
6099 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
6101 -- EXTERNAL_SYMBOL ::=
6103 -- | static_string_EXPRESSION
6105 -- PARAMETER_TYPES ::=
6107 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6109 -- TYPE_DESIGNATOR ::=
6111 -- | subtype_Name ' Access
6115 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6117 -- MECHANISM_ASSOCIATION ::=
6118 -- [formal_parameter_NAME =>] MECHANISM_NAME
6120 -- MECHANISM_NAME ::=
6123 -- | Descriptor [([Class =>] CLASS_NAME)]
6125 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6127 when Pragma_Export_Function
=> Export_Function
: declare
6128 Args
: Args_List
(1 .. 6);
6129 Names
: constant Name_List
(1 .. 6) := (
6132 Name_Parameter_Types
,
6135 Name_Result_Mechanism
);
6137 Internal
: Node_Id
renames Args
(1);
6138 External
: Node_Id
renames Args
(2);
6139 Parameter_Types
: Node_Id
renames Args
(3);
6140 Result_Type
: Node_Id
renames Args
(4);
6141 Mechanism
: Node_Id
renames Args
(5);
6142 Result_Mechanism
: Node_Id
renames Args
(6);
6146 Gather_Associations
(Names
, Args
);
6147 Process_Extended_Import_Export_Subprogram_Pragma
(
6148 Arg_Internal
=> Internal
,
6149 Arg_External
=> External
,
6150 Arg_Parameter_Types
=> Parameter_Types
,
6151 Arg_Result_Type
=> Result_Type
,
6152 Arg_Mechanism
=> Mechanism
,
6153 Arg_Result_Mechanism
=> Result_Mechanism
);
6154 end Export_Function
;
6160 -- pragma Export_Object (
6161 -- [Internal =>] LOCAL_NAME,
6162 -- [, [External =>] EXTERNAL_SYMBOL]
6163 -- [, [Size =>] EXTERNAL_SYMBOL]);
6165 -- EXTERNAL_SYMBOL ::=
6167 -- | static_string_EXPRESSION
6169 -- PARAMETER_TYPES ::=
6171 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6173 -- TYPE_DESIGNATOR ::=
6175 -- | subtype_Name ' Access
6179 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6181 -- MECHANISM_ASSOCIATION ::=
6182 -- [formal_parameter_NAME =>] MECHANISM_NAME
6184 -- MECHANISM_NAME ::=
6187 -- | Descriptor [([Class =>] CLASS_NAME)]
6189 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6191 when Pragma_Export_Object
=> Export_Object
: declare
6192 Args
: Args_List
(1 .. 3);
6193 Names
: constant Name_List
(1 .. 3) := (
6198 Internal
: Node_Id
renames Args
(1);
6199 External
: Node_Id
renames Args
(2);
6200 Size
: Node_Id
renames Args
(3);
6204 Gather_Associations
(Names
, Args
);
6205 Process_Extended_Import_Export_Object_Pragma
(
6206 Arg_Internal
=> Internal
,
6207 Arg_External
=> External
,
6211 ----------------------
6212 -- Export_Procedure --
6213 ----------------------
6215 -- pragma Export_Procedure (
6216 -- [Internal =>] LOCAL_NAME,
6217 -- [, [External =>] EXTERNAL_SYMBOL,]
6218 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
6219 -- [, [Mechanism =>] MECHANISM]);
6221 -- EXTERNAL_SYMBOL ::=
6223 -- | static_string_EXPRESSION
6225 -- PARAMETER_TYPES ::=
6227 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6229 -- TYPE_DESIGNATOR ::=
6231 -- | subtype_Name ' Access
6235 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6237 -- MECHANISM_ASSOCIATION ::=
6238 -- [formal_parameter_NAME =>] MECHANISM_NAME
6240 -- MECHANISM_NAME ::=
6243 -- | Descriptor [([Class =>] CLASS_NAME)]
6245 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6247 when Pragma_Export_Procedure
=> Export_Procedure
: declare
6248 Args
: Args_List
(1 .. 4);
6249 Names
: constant Name_List
(1 .. 4) := (
6252 Name_Parameter_Types
,
6255 Internal
: Node_Id
renames Args
(1);
6256 External
: Node_Id
renames Args
(2);
6257 Parameter_Types
: Node_Id
renames Args
(3);
6258 Mechanism
: Node_Id
renames Args
(4);
6262 Gather_Associations
(Names
, Args
);
6263 Process_Extended_Import_Export_Subprogram_Pragma
(
6264 Arg_Internal
=> Internal
,
6265 Arg_External
=> External
,
6266 Arg_Parameter_Types
=> Parameter_Types
,
6267 Arg_Mechanism
=> Mechanism
);
6268 end Export_Procedure
;
6274 -- pragma Export_Value (
6275 -- [Value =>] static_integer_EXPRESSION,
6276 -- [Link_Name =>] static_string_EXPRESSION);
6278 when Pragma_Export_Value
=>
6280 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
6281 Check_Arg_Count
(2);
6283 Check_Optional_Identifier
(Arg1
, Name_Value
);
6284 Check_Arg_Is_Static_Expression
(Arg1
, Any_Integer
);
6286 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
6287 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
6289 -----------------------------
6290 -- Export_Valued_Procedure --
6291 -----------------------------
6293 -- pragma Export_Valued_Procedure (
6294 -- [Internal =>] LOCAL_NAME,
6295 -- [, [External =>] EXTERNAL_SYMBOL,]
6296 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
6297 -- [, [Mechanism =>] MECHANISM]);
6299 -- EXTERNAL_SYMBOL ::=
6301 -- | static_string_EXPRESSION
6303 -- PARAMETER_TYPES ::=
6305 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6307 -- TYPE_DESIGNATOR ::=
6309 -- | subtype_Name ' Access
6313 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6315 -- MECHANISM_ASSOCIATION ::=
6316 -- [formal_parameter_NAME =>] MECHANISM_NAME
6318 -- MECHANISM_NAME ::=
6321 -- | Descriptor [([Class =>] CLASS_NAME)]
6323 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6325 when Pragma_Export_Valued_Procedure
=>
6326 Export_Valued_Procedure
: declare
6327 Args
: Args_List
(1 .. 4);
6328 Names
: constant Name_List
(1 .. 4) := (
6331 Name_Parameter_Types
,
6334 Internal
: Node_Id
renames Args
(1);
6335 External
: Node_Id
renames Args
(2);
6336 Parameter_Types
: Node_Id
renames Args
(3);
6337 Mechanism
: Node_Id
renames Args
(4);
6341 Gather_Associations
(Names
, Args
);
6342 Process_Extended_Import_Export_Subprogram_Pragma
(
6343 Arg_Internal
=> Internal
,
6344 Arg_External
=> External
,
6345 Arg_Parameter_Types
=> Parameter_Types
,
6346 Arg_Mechanism
=> Mechanism
);
6347 end Export_Valued_Procedure
;
6353 -- pragma Extend_System ([Name =>] Identifier);
6355 when Pragma_Extend_System
=> Extend_System
: declare
6358 Check_Valid_Configuration_Pragma
;
6359 Check_Arg_Count
(1);
6360 Check_Optional_Identifier
(Arg1
, Name_Name
);
6361 Check_Arg_Is_Identifier
(Arg1
);
6363 Get_Name_String
(Chars
(Expression
(Arg1
)));
6366 and then Name_Buffer
(1 .. 4) = "aux_"
6368 if Present
(System_Extend_Pragma_Arg
) then
6369 if Chars
(Expression
(Arg1
)) =
6370 Chars
(Expression
(System_Extend_Pragma_Arg
))
6374 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
6375 Error_Pragma
("pragma% conflicts with that at#");
6379 System_Extend_Pragma_Arg
:= Arg1
;
6381 if not GNAT_Mode
then
6382 System_Extend_Unit
:= Arg1
;
6386 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
6390 ------------------------
6391 -- Extensions_Allowed --
6392 ------------------------
6394 -- pragma Extensions_Allowed (ON | OFF);
6396 when Pragma_Extensions_Allowed
=>
6398 Check_Arg_Count
(1);
6399 Check_No_Identifiers
;
6400 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
6402 if Chars
(Expression
(Arg1
)) = Name_On
then
6403 Extensions_Allowed
:= True;
6404 Ada_Version
:= Ada_Version_Type
'Last;
6406 Extensions_Allowed
:= False;
6407 Ada_Version
:= Ada_Version_Type
'Min (Ada_Version
, Ada_95
);
6410 Ada_Version_Explicit
:= Ada_Version
;
6416 -- pragma External (
6417 -- [ Convention =>] convention_IDENTIFIER,
6418 -- [ Entity =>] local_NAME
6419 -- [, [External_Name =>] static_string_EXPRESSION ]
6420 -- [, [Link_Name =>] static_string_EXPRESSION ]);
6422 when Pragma_External
=> External
: declare
6432 Check_At_Least_N_Arguments
(2);
6433 Check_At_Most_N_Arguments
(4);
6434 Process_Convention
(C
, Def_Id
);
6435 Note_Possible_Modification
(Expression
(Arg2
));
6436 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
6437 Set_Exported
(Def_Id
, Arg2
);
6440 --------------------------
6441 -- External_Name_Casing --
6442 --------------------------
6444 -- pragma External_Name_Casing (
6445 -- UPPERCASE | LOWERCASE
6446 -- [, AS_IS | UPPERCASE | LOWERCASE]);
6448 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
6451 Check_No_Identifiers
;
6453 if Arg_Count
= 2 then
6455 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
6457 case Chars
(Get_Pragma_Arg
(Arg2
)) is
6459 Opt
.External_Name_Exp_Casing
:= As_Is
;
6461 when Name_Uppercase
=>
6462 Opt
.External_Name_Exp_Casing
:= Uppercase
;
6464 when Name_Lowercase
=>
6465 Opt
.External_Name_Exp_Casing
:= Lowercase
;
6472 Check_Arg_Count
(1);
6475 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
6477 case Chars
(Get_Pragma_Arg
(Arg1
)) is
6478 when Name_Uppercase
=>
6479 Opt
.External_Name_Imp_Casing
:= Uppercase
;
6481 when Name_Lowercase
=>
6482 Opt
.External_Name_Imp_Casing
:= Lowercase
;
6487 end External_Name_Casing
;
6489 ---------------------------
6490 -- Finalize_Storage_Only --
6491 ---------------------------
6493 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
6495 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
6496 Assoc
: constant Node_Id
:= Arg1
;
6497 Type_Id
: constant Node_Id
:= Expression
(Assoc
);
6501 Check_No_Identifiers
;
6502 Check_Arg_Count
(1);
6503 Check_Arg_Is_Local_Name
(Arg1
);
6505 Find_Type
(Type_Id
);
6506 Typ
:= Entity
(Type_Id
);
6509 or else Rep_Item_Too_Early
(Typ
, N
)
6513 Typ
:= Underlying_Type
(Typ
);
6516 if not Is_Controlled
(Typ
) then
6517 Error_Pragma
("pragma% must specify controlled type");
6520 Check_First_Subtype
(Arg1
);
6522 if Finalize_Storage_Only
(Typ
) then
6523 Error_Pragma
("duplicate pragma%, only one allowed");
6525 elsif not Rep_Item_Too_Late
(Typ
, N
) then
6526 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
6528 end Finalize_Storage
;
6530 --------------------------
6531 -- Float_Representation --
6532 --------------------------
6534 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
6536 -- FLOAT_REP ::= VAX_Float | IEEE_Float
6538 when Pragma_Float_Representation
=> Float_Representation
: declare
6546 if Arg_Count
= 1 then
6547 Check_Valid_Configuration_Pragma
;
6549 Check_Arg_Count
(2);
6550 Check_Optional_Identifier
(Arg2
, Name_Entity
);
6551 Check_Arg_Is_Local_Name
(Arg2
);
6554 Check_No_Identifier
(Arg1
);
6555 Check_Arg_Is_One_Of
(Arg1
, Name_VAX_Float
, Name_IEEE_Float
);
6557 if not OpenVMS_On_Target
then
6558 if Chars
(Expression
(Arg1
)) = Name_VAX_Float
then
6560 ("?pragma% ignored (applies only to Open'V'M'S)");
6566 -- One argument case
6568 if Arg_Count
= 1 then
6569 if Chars
(Expression
(Arg1
)) = Name_VAX_Float
then
6570 if Opt
.Float_Format
= 'I' then
6571 Error_Pragma
("'I'E'E'E format previously specified");
6574 Opt
.Float_Format
:= 'V';
6577 if Opt
.Float_Format
= 'V' then
6578 Error_Pragma
("'V'A'X format previously specified");
6581 Opt
.Float_Format
:= 'I';
6584 Set_Standard_Fpt_Formats
;
6586 -- Two argument case
6589 Argx
:= Get_Pragma_Arg
(Arg2
);
6591 if not Is_Entity_Name
(Argx
)
6592 or else not Is_Floating_Point_Type
(Entity
(Argx
))
6595 ("second argument of% pragma must be floating-point type",
6599 Ent
:= Entity
(Argx
);
6600 Digs
:= UI_To_Int
(Digits_Value
(Ent
));
6602 -- Two arguments, VAX_Float case
6604 if Chars
(Expression
(Arg1
)) = Name_VAX_Float
then
6606 when 6 => Set_F_Float
(Ent
);
6607 when 9 => Set_D_Float
(Ent
);
6608 when 15 => Set_G_Float
(Ent
);
6612 ("wrong digits value, must be 6,9 or 15", Arg2
);
6615 -- Two arguments, IEEE_Float case
6619 when 6 => Set_IEEE_Short
(Ent
);
6620 when 15 => Set_IEEE_Long
(Ent
);
6624 ("wrong digits value, must be 6 or 15", Arg2
);
6628 end Float_Representation
;
6634 -- pragma Ident (static_string_EXPRESSION)
6636 -- Note: pragma Comment shares this processing. Pragma Comment
6637 -- is identical to Ident, except that the restriction of the
6638 -- argument to 31 characters and the placement restrictions
6639 -- are not enforced for pragma Comment.
6641 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
6646 Check_Arg_Count
(1);
6647 Check_No_Identifiers
;
6648 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
6650 -- For pragma Ident, preserve DEC compatibility by requiring
6651 -- the pragma to appear in a declarative part or package spec.
6653 if Prag_Id
= Pragma_Ident
then
6654 Check_Is_In_Decl_Part_Or_Package_Spec
;
6657 Str
:= Expr_Value_S
(Expression
(Arg1
));
6664 GP
:= Parent
(Parent
(N
));
6666 if Nkind
(GP
) = N_Package_Declaration
6668 Nkind
(GP
) = N_Generic_Package_Declaration
6673 -- If we have a compilation unit, then record the ident
6674 -- value, checking for improper duplication.
6676 if Nkind
(GP
) = N_Compilation_Unit
then
6677 CS
:= Ident_String
(Current_Sem_Unit
);
6679 if Present
(CS
) then
6681 -- For Ident, we do not permit multiple instances
6683 if Prag_Id
= Pragma_Ident
then
6684 Error_Pragma
("duplicate% pragma not permitted");
6686 -- For Comment, we concatenate the string, unless we
6687 -- want to preserve the tree structure for ASIS.
6689 elsif not ASIS_Mode
then
6690 Start_String
(Strval
(CS
));
6691 Store_String_Char
(' ');
6692 Store_String_Chars
(Strval
(Str
));
6693 Set_Strval
(CS
, End_String
);
6697 -- In VMS, the effect of IDENT is achieved by passing
6698 -- IDENTIFICATION=name as a --for-linker switch.
6700 if OpenVMS_On_Target
then
6703 ("--for-linker=IDENTIFICATION=");
6704 String_To_Name_Buffer
(Strval
(Str
));
6705 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
6707 -- Only the last processed IDENT is saved. The main
6708 -- purpose is so an IDENT associated with a main
6709 -- procedure will be used in preference to an IDENT
6710 -- associated with a with'd package.
6712 Replace_Linker_Option_String
6713 (End_String
, "--for-linker=IDENTIFICATION=");
6716 Set_Ident_String
(Current_Sem_Unit
, Str
);
6719 -- For subunits, we just ignore the Ident, since in GNAT
6720 -- these are not separate object files, and hence not
6721 -- separate units in the unit table.
6723 elsif Nkind
(GP
) = N_Subunit
then
6726 -- Otherwise we have a misplaced pragma Ident, but we ignore
6727 -- this if we are in an instantiation, since it comes from
6728 -- a generic, and has no relevance to the instantiation.
6730 elsif Prag_Id
= Pragma_Ident
then
6731 if Instantiation_Location
(Loc
) = No_Location
then
6732 Error_Pragma
("pragma% only allowed at outer level");
6743 -- [ Convention =>] convention_IDENTIFIER,
6744 -- [ Entity =>] local_NAME
6745 -- [, [External_Name =>] static_string_EXPRESSION ]
6746 -- [, [Link_Name =>] static_string_EXPRESSION ]);
6748 when Pragma_Import
=>
6749 Check_Ada_83_Warning
;
6755 Check_At_Least_N_Arguments
(2);
6756 Check_At_Most_N_Arguments
(4);
6757 Process_Import_Or_Interface
;
6759 ----------------------
6760 -- Import_Exception --
6761 ----------------------
6763 -- pragma Import_Exception (
6764 -- [Internal =>] LOCAL_NAME,
6765 -- [, [External =>] EXTERNAL_SYMBOL,]
6766 -- [, [Form =>] Ada | VMS]
6767 -- [, [Code =>] static_integer_EXPRESSION]);
6769 when Pragma_Import_Exception
=> Import_Exception
: declare
6770 Args
: Args_List
(1 .. 4);
6771 Names
: constant Name_List
(1 .. 4) := (
6777 Internal
: Node_Id
renames Args
(1);
6778 External
: Node_Id
renames Args
(2);
6779 Form
: Node_Id
renames Args
(3);
6780 Code
: Node_Id
renames Args
(4);
6783 Gather_Associations
(Names
, Args
);
6785 if Present
(External
) and then Present
(Code
) then
6787 ("cannot give both External and Code options for pragma%");
6790 Process_Extended_Import_Export_Exception_Pragma
(
6791 Arg_Internal
=> Internal
,
6792 Arg_External
=> External
,
6796 if not Is_VMS_Exception
(Entity
(Internal
)) then
6797 Set_Imported
(Entity
(Internal
));
6799 end Import_Exception
;
6801 ---------------------
6802 -- Import_Function --
6803 ---------------------
6805 -- pragma Import_Function (
6806 -- [Internal =>] LOCAL_NAME,
6807 -- [, [External =>] EXTERNAL_SYMBOL]
6808 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
6809 -- [, [Result_Type =>] SUBTYPE_MARK]
6810 -- [, [Mechanism =>] MECHANISM]
6811 -- [, [Result_Mechanism =>] MECHANISM_NAME]
6812 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
6814 -- EXTERNAL_SYMBOL ::=
6816 -- | static_string_EXPRESSION
6818 -- PARAMETER_TYPES ::=
6820 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6822 -- TYPE_DESIGNATOR ::=
6824 -- | subtype_Name ' Access
6828 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6830 -- MECHANISM_ASSOCIATION ::=
6831 -- [formal_parameter_NAME =>] MECHANISM_NAME
6833 -- MECHANISM_NAME ::=
6836 -- | Descriptor [([Class =>] CLASS_NAME)]
6838 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6840 when Pragma_Import_Function
=> Import_Function
: declare
6841 Args
: Args_List
(1 .. 7);
6842 Names
: constant Name_List
(1 .. 7) := (
6845 Name_Parameter_Types
,
6848 Name_Result_Mechanism
,
6849 Name_First_Optional_Parameter
);
6851 Internal
: Node_Id
renames Args
(1);
6852 External
: Node_Id
renames Args
(2);
6853 Parameter_Types
: Node_Id
renames Args
(3);
6854 Result_Type
: Node_Id
renames Args
(4);
6855 Mechanism
: Node_Id
renames Args
(5);
6856 Result_Mechanism
: Node_Id
renames Args
(6);
6857 First_Optional_Parameter
: Node_Id
renames Args
(7);
6861 Gather_Associations
(Names
, Args
);
6862 Process_Extended_Import_Export_Subprogram_Pragma
(
6863 Arg_Internal
=> Internal
,
6864 Arg_External
=> External
,
6865 Arg_Parameter_Types
=> Parameter_Types
,
6866 Arg_Result_Type
=> Result_Type
,
6867 Arg_Mechanism
=> Mechanism
,
6868 Arg_Result_Mechanism
=> Result_Mechanism
,
6869 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
6870 end Import_Function
;
6876 -- pragma Import_Object (
6877 -- [Internal =>] LOCAL_NAME,
6878 -- [, [External =>] EXTERNAL_SYMBOL]
6879 -- [, [Size =>] EXTERNAL_SYMBOL]);
6881 -- EXTERNAL_SYMBOL ::=
6883 -- | static_string_EXPRESSION
6885 when Pragma_Import_Object
=> Import_Object
: declare
6886 Args
: Args_List
(1 .. 3);
6887 Names
: constant Name_List
(1 .. 3) := (
6892 Internal
: Node_Id
renames Args
(1);
6893 External
: Node_Id
renames Args
(2);
6894 Size
: Node_Id
renames Args
(3);
6898 Gather_Associations
(Names
, Args
);
6899 Process_Extended_Import_Export_Object_Pragma
(
6900 Arg_Internal
=> Internal
,
6901 Arg_External
=> External
,
6905 ----------------------
6906 -- Import_Procedure --
6907 ----------------------
6909 -- pragma Import_Procedure (
6910 -- [Internal =>] LOCAL_NAME,
6911 -- [, [External =>] EXTERNAL_SYMBOL]
6912 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
6913 -- [, [Mechanism =>] MECHANISM]
6914 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
6916 -- EXTERNAL_SYMBOL ::=
6918 -- | static_string_EXPRESSION
6920 -- PARAMETER_TYPES ::=
6922 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6924 -- TYPE_DESIGNATOR ::=
6926 -- | subtype_Name ' Access
6930 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6932 -- MECHANISM_ASSOCIATION ::=
6933 -- [formal_parameter_NAME =>] MECHANISM_NAME
6935 -- MECHANISM_NAME ::=
6938 -- | Descriptor [([Class =>] CLASS_NAME)]
6940 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6942 when Pragma_Import_Procedure
=> Import_Procedure
: declare
6943 Args
: Args_List
(1 .. 5);
6944 Names
: constant Name_List
(1 .. 5) := (
6947 Name_Parameter_Types
,
6949 Name_First_Optional_Parameter
);
6951 Internal
: Node_Id
renames Args
(1);
6952 External
: Node_Id
renames Args
(2);
6953 Parameter_Types
: Node_Id
renames Args
(3);
6954 Mechanism
: Node_Id
renames Args
(4);
6955 First_Optional_Parameter
: Node_Id
renames Args
(5);
6959 Gather_Associations
(Names
, Args
);
6960 Process_Extended_Import_Export_Subprogram_Pragma
(
6961 Arg_Internal
=> Internal
,
6962 Arg_External
=> External
,
6963 Arg_Parameter_Types
=> Parameter_Types
,
6964 Arg_Mechanism
=> Mechanism
,
6965 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
6966 end Import_Procedure
;
6968 -----------------------------
6969 -- Import_Valued_Procedure --
6970 -----------------------------
6972 -- pragma Import_Valued_Procedure (
6973 -- [Internal =>] LOCAL_NAME,
6974 -- [, [External =>] EXTERNAL_SYMBOL]
6975 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
6976 -- [, [Mechanism =>] MECHANISM]
6977 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
6979 -- EXTERNAL_SYMBOL ::=
6981 -- | static_string_EXPRESSION
6983 -- PARAMETER_TYPES ::=
6985 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6987 -- TYPE_DESIGNATOR ::=
6989 -- | subtype_Name ' Access
6993 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6995 -- MECHANISM_ASSOCIATION ::=
6996 -- [formal_parameter_NAME =>] MECHANISM_NAME
6998 -- MECHANISM_NAME ::=
7001 -- | Descriptor [([Class =>] CLASS_NAME)]
7003 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7005 when Pragma_Import_Valued_Procedure
=>
7006 Import_Valued_Procedure
: declare
7007 Args
: Args_List
(1 .. 5);
7008 Names
: constant Name_List
(1 .. 5) := (
7011 Name_Parameter_Types
,
7013 Name_First_Optional_Parameter
);
7015 Internal
: Node_Id
renames Args
(1);
7016 External
: Node_Id
renames Args
(2);
7017 Parameter_Types
: Node_Id
renames Args
(3);
7018 Mechanism
: Node_Id
renames Args
(4);
7019 First_Optional_Parameter
: Node_Id
renames Args
(5);
7023 Gather_Associations
(Names
, Args
);
7024 Process_Extended_Import_Export_Subprogram_Pragma
(
7025 Arg_Internal
=> Internal
,
7026 Arg_External
=> External
,
7027 Arg_Parameter_Types
=> Parameter_Types
,
7028 Arg_Mechanism
=> Mechanism
,
7029 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
7030 end Import_Valued_Procedure
;
7032 ------------------------
7033 -- Initialize_Scalars --
7034 ------------------------
7036 -- pragma Initialize_Scalars;
7038 when Pragma_Initialize_Scalars
=>
7040 Check_Arg_Count
(0);
7041 Check_Valid_Configuration_Pragma
;
7042 Check_Restriction
(No_Initialize_Scalars
, N
);
7044 if not Restriction_Active
(No_Initialize_Scalars
) then
7045 Init_Or_Norm_Scalars
:= True;
7046 Initialize_Scalars
:= True;
7053 -- pragma Inline ( NAME {, NAME} );
7055 when Pragma_Inline
=>
7057 -- Pragma is active if inlining option is active
7059 Process_Inline
(Inline_Active
);
7065 -- pragma Inline_Always ( NAME {, NAME} );
7067 when Pragma_Inline_Always
=>
7068 Process_Inline
(True);
7070 --------------------
7071 -- Inline_Generic --
7072 --------------------
7074 -- pragma Inline_Generic (NAME {, NAME});
7076 when Pragma_Inline_Generic
=>
7077 Process_Generic_List
;
7079 ----------------------
7080 -- Inspection_Point --
7081 ----------------------
7083 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
7085 when Pragma_Inspection_Point
=> Inspection_Point
: declare
7090 if Arg_Count
> 0 then
7093 Exp
:= Expression
(Arg
);
7096 if not Is_Entity_Name
(Exp
)
7097 or else not Is_Object
(Entity
(Exp
))
7099 Error_Pragma_Arg
("object name required", Arg
);
7106 end Inspection_Point
;
7112 -- pragma Interface (
7113 -- convention_IDENTIFIER,
7116 when Pragma_Interface
=>
7118 Check_Arg_Count
(2);
7119 Check_No_Identifiers
;
7120 Process_Import_Or_Interface
;
7122 --------------------
7123 -- Interface_Name --
7124 --------------------
7126 -- pragma Interface_Name (
7127 -- [ Entity =>] local_NAME
7128 -- [,[External_Name =>] static_string_EXPRESSION ]
7129 -- [,[Link_Name =>] static_string_EXPRESSION ]);
7131 when Pragma_Interface_Name
=> Interface_Name
: declare
7140 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
7141 Check_At_Least_N_Arguments
(2);
7142 Check_At_Most_N_Arguments
(3);
7143 Id
:= Expression
(Arg1
);
7146 if not Is_Entity_Name
(Id
) then
7148 ("first argument for pragma% must be entity name", Arg1
);
7149 elsif Etype
(Id
) = Any_Type
then
7152 Def_Id
:= Entity
(Id
);
7155 -- Special DEC-compatible processing for the object case,
7156 -- forces object to be imported.
7158 if Ekind
(Def_Id
) = E_Variable
then
7159 Kill_Size_Check_Code
(Def_Id
);
7160 Note_Possible_Modification
(Id
);
7162 -- Initialization is not allowed for imported variable
7164 if Present
(Expression
(Parent
(Def_Id
)))
7165 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
7167 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7169 ("no initialization allowed for declaration of& #",
7173 -- For compatibility, support VADS usage of providing both
7174 -- pragmas Interface and Interface_Name to obtain the effect
7175 -- of a single Import pragma.
7177 if Is_Imported
(Def_Id
)
7178 and then Present
(First_Rep_Item
(Def_Id
))
7179 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
7180 and then Chars
(First_Rep_Item
(Def_Id
)) = Name_Interface
7184 Set_Imported
(Def_Id
);
7187 Set_Is_Public
(Def_Id
);
7188 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
7191 -- Otherwise must be subprogram
7193 elsif not Is_Subprogram
(Def_Id
) then
7195 ("argument of pragma% is not subprogram", Arg1
);
7198 Check_At_Most_N_Arguments
(3);
7202 -- Loop through homonyms
7205 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7207 if Is_Imported
(Def_Id
) then
7208 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
7212 Hom_Id
:= Homonym
(Hom_Id
);
7214 exit when No
(Hom_Id
)
7215 or else Scope
(Hom_Id
) /= Current_Scope
;
7220 ("argument of pragma% is not imported subprogram",
7226 -----------------------
7227 -- Interrupt_Handler --
7228 -----------------------
7230 -- pragma Interrupt_Handler (handler_NAME);
7232 when Pragma_Interrupt_Handler
=>
7233 Check_Ada_83_Warning
;
7234 Check_Arg_Count
(1);
7235 Check_No_Identifiers
;
7237 if No_Run_Time_Mode
then
7238 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
7240 Check_Interrupt_Or_Attach_Handler
;
7241 Process_Interrupt_Or_Attach_Handler
;
7244 ------------------------
7245 -- Interrupt_Priority --
7246 ------------------------
7248 -- pragma Interrupt_Priority [(EXPRESSION)];
7250 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
7251 P
: constant Node_Id
:= Parent
(N
);
7255 Check_Ada_83_Warning
;
7257 if Arg_Count
/= 0 then
7258 Arg
:= Expression
(Arg1
);
7259 Check_Arg_Count
(1);
7260 Check_No_Identifiers
;
7262 -- The expression must be analyzed in the special manner
7263 -- described in "Handling of Default and Per-Object
7264 -- Expressions" in sem.ads.
7266 Analyze_Per_Use_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
7269 if Nkind
(P
) /= N_Task_Definition
7270 and then Nkind
(P
) /= N_Protected_Definition
7275 elsif Has_Priority_Pragma
(P
) then
7276 Error_Pragma
("duplicate pragma% not allowed");
7279 Set_Has_Priority_Pragma
(P
, True);
7280 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
7282 end Interrupt_Priority
;
7284 ---------------------
7285 -- Interrupt_State --
7286 ---------------------
7288 -- pragma Interrupt_State (
7289 -- [Name =>] INTERRUPT_ID,
7290 -- [State =>] INTERRUPT_STATE);
7292 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
7293 -- INTERRUPT_STATE => System | Runtime | User
7295 -- Note: if the interrupt id is given as an identifier, then
7296 -- it must be one of the identifiers in Ada.Interrupts.Names.
7297 -- Otherwise it is given as a static integer expression which
7298 -- must be in the range of Ada.Interrupts.Interrupt_ID.
7300 when Pragma_Interrupt_State
=> Interrupt_State
: declare
7302 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
7303 -- This is the entity Ada.Interrupts.Interrupt_ID;
7305 State_Type
: Character;
7306 -- Set to 's'/'r'/'u' for System/Runtime/User
7309 -- Index to entry in Interrupt_States table
7312 -- Value of interrupt
7314 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7315 -- The first argument to the pragma
7317 Int_Ent
: Entity_Id
;
7318 -- Interrupt entity in Ada.Interrupts.Names
7322 Check_Arg_Order
((Name_Name
, Name_State
));
7323 Check_Arg_Count
(2);
7325 Check_Optional_Identifier
(Arg1
, Name_Name
);
7326 Check_Optional_Identifier
(Arg2
, Name_State
);
7327 Check_Arg_Is_Identifier
(Arg2
);
7329 -- First argument is identifier
7331 if Nkind
(Arg1X
) = N_Identifier
then
7333 -- Search list of names in Ada.Interrupts.Names
7335 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
7337 if No
(Int_Ent
) then
7338 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
7340 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
7341 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
7345 Next_Entity
(Int_Ent
);
7348 -- First argument is not an identifier, so it must be a
7349 -- static expression of type Ada.Interrupts.Interrupt_ID.
7352 Check_Arg_Is_Static_Expression
(Arg1
, Any_Integer
);
7353 Int_Val
:= Expr_Value
(Arg1X
);
7355 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
7357 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
7360 ("value not in range of type " &
7361 """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
7367 case Chars
(Get_Pragma_Arg
(Arg2
)) is
7368 when Name_Runtime
=> State_Type
:= 'r';
7369 when Name_System
=> State_Type
:= 's';
7370 when Name_User
=> State_Type
:= 'u';
7373 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
7376 -- Check if entry is already stored
7378 IST_Num
:= Interrupt_States
.First
;
7380 -- If entry not found, add it
7382 if IST_Num
> Interrupt_States
.Last
then
7383 Interrupt_States
.Append
7384 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
7385 Interrupt_State
=> State_Type
,
7386 Pragma_Loc
=> Loc
));
7389 -- Case of entry for the same entry
7391 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
7394 -- If state matches, done, no need to make redundant entry
7397 State_Type
= Interrupt_States
.Table
(IST_Num
).
7400 -- Otherwise if state does not match, error
7403 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
7405 ("state conflicts with that given at #", Arg2
);
7409 IST_Num
:= IST_Num
+ 1;
7411 end Interrupt_State
;
7413 ----------------------
7414 -- Java_Constructor --
7415 ----------------------
7417 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
7419 when Pragma_Java_Constructor
=> Java_Constructor
: declare
7426 Check_Arg_Count
(1);
7427 Check_Optional_Identifier
(Arg1
, Name_Entity
);
7428 Check_Arg_Is_Local_Name
(Arg1
);
7430 Id
:= Expression
(Arg1
);
7431 Find_Program_Unit_Name
(Id
);
7433 -- If we did not find the name, we are done
7435 if Etype
(Id
) = Any_Type
then
7439 Hom_Id
:= Entity
(Id
);
7441 -- Loop through homonyms
7444 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7446 -- The constructor is required to be a function returning
7447 -- an access type whose designated type has convention Java.
7449 if Ekind
(Def_Id
) = E_Function
7450 and then Ekind
(Etype
(Def_Id
)) in Access_Kind
7453 (Designated_Type
(Etype
(Def_Id
))) = Convention_Java
7456 (Root_Type
(Designated_Type
(Etype
(Def_Id
))))
7459 Set_Is_Constructor
(Def_Id
);
7460 Set_Convention
(Def_Id
, Convention_Java
);
7464 ("pragma% requires function returning a 'Java access type",
7468 Hom_Id
:= Homonym
(Hom_Id
);
7470 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
7472 end Java_Constructor
;
7474 ----------------------
7475 -- Java_Interface --
7476 ----------------------
7478 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
7480 when Pragma_Java_Interface
=> Java_Interface
: declare
7486 Check_Arg_Count
(1);
7487 Check_Optional_Identifier
(Arg1
, Name_Entity
);
7488 Check_Arg_Is_Local_Name
(Arg1
);
7490 Arg
:= Expression
(Arg1
);
7493 if Etype
(Arg
) = Any_Type
then
7497 if not Is_Entity_Name
(Arg
)
7498 or else not Is_Type
(Entity
(Arg
))
7500 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
7503 Typ
:= Underlying_Type
(Entity
(Arg
));
7505 -- For now we simply check some of the semantic constraints
7506 -- on the type. This currently leaves out some restrictions
7507 -- on interface types, namely that the parent type must be
7508 -- java.lang.Object.Typ and that all primitives of the type
7509 -- should be declared abstract. ???
7511 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract
(Typ
) then
7512 Error_Pragma_Arg
("pragma% requires an abstract "
7513 & "tagged type", Arg1
);
7515 elsif not Has_Discriminants
(Typ
)
7516 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
7517 /= E_Anonymous_Access_Type
7519 not Is_Class_Wide_Type
7520 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
7523 ("type must have a class-wide access discriminant", Arg1
);
7531 -- pragma Keep_Names ([On => ] local_NAME);
7533 when Pragma_Keep_Names
=> Keep_Names
: declare
7538 Check_Arg_Count
(1);
7539 Check_Optional_Identifier
(Arg1
, Name_On
);
7540 Check_Arg_Is_Local_Name
(Arg1
);
7542 Arg
:= Expression
(Arg1
);
7545 if Etype
(Arg
) = Any_Type
then
7549 if not Is_Entity_Name
(Arg
)
7550 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
7553 ("pragma% requires a local enumeration type", Arg1
);
7556 Set_Discard_Names
(Entity
(Arg
), False);
7563 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
7565 when Pragma_License
=>
7567 Check_Arg_Count
(1);
7568 Check_No_Identifiers
;
7569 Check_Valid_Configuration_Pragma
;
7570 Check_Arg_Is_Identifier
(Arg1
);
7573 Sind
: constant Source_File_Index
:=
7574 Source_Index
(Current_Sem_Unit
);
7577 case Chars
(Get_Pragma_Arg
(Arg1
)) is
7579 Set_License
(Sind
, GPL
);
7581 when Name_Modified_GPL
=>
7582 Set_License
(Sind
, Modified_GPL
);
7584 when Name_Restricted
=>
7585 Set_License
(Sind
, Restricted
);
7587 when Name_Unrestricted
=>
7588 Set_License
(Sind
, Unrestricted
);
7591 Error_Pragma_Arg
("invalid license name", Arg1
);
7599 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
7601 when Pragma_Link_With
=> Link_With
: declare
7607 if Operating_Mode
= Generate_Code
7608 and then In_Extended_Main_Source_Unit
(N
)
7610 Check_At_Least_N_Arguments
(1);
7611 Check_No_Identifiers
;
7612 Check_Is_In_Decl_Part_Or_Package_Spec
;
7613 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
7617 while Present
(Arg
) loop
7618 Check_Arg_Is_Static_Expression
(Arg
, Standard_String
);
7620 -- Store argument, converting sequences of spaces
7621 -- to a single null character (this is one of the
7622 -- differences in processing between Link_With
7623 -- and Linker_Options).
7626 C
: constant Char_Code
:= Get_Char_Code
(' ');
7627 S
: constant String_Id
:=
7628 Strval
(Expr_Value_S
(Expression
(Arg
)));
7629 L
: constant Nat
:= String_Length
(S
);
7632 procedure Skip_Spaces
;
7633 -- Advance F past any spaces
7635 procedure Skip_Spaces
is
7637 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
7643 Skip_Spaces
; -- skip leading spaces
7645 -- Loop through characters, changing any embedded
7646 -- sequence of spaces to a single null character
7647 -- (this is how Link_With/Linker_Options differ)
7650 if Get_String_Char
(S
, F
) = C
then
7653 Store_String_Char
(ASCII
.NUL
);
7656 Store_String_Char
(Get_String_Char
(S
, F
));
7664 if Present
(Arg
) then
7665 Store_String_Char
(ASCII
.NUL
);
7669 Store_Linker_Option_String
(End_String
);
7677 -- pragma Linker_Alias (
7678 -- [Entity =>] LOCAL_NAME
7679 -- [Target =>] static_string_EXPRESSION);
7681 when Pragma_Linker_Alias
=>
7683 Check_Arg_Order
((Name_Entity
, Name_Target
));
7684 Check_Arg_Count
(2);
7685 Check_Optional_Identifier
(Arg1
, Name_Entity
);
7686 Check_Optional_Identifier
(Arg2
, Name_Target
);
7687 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
7688 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
7690 -- The only processing required is to link this item on to the
7691 -- list of rep items for the given entity. This is accomplished
7692 -- by the call to Rep_Item_Too_Late (when no error is detected
7693 -- and False is returned).
7695 if Rep_Item_Too_Late
(Entity
(Expression
(Arg1
)), N
) then
7698 Set_Has_Gigi_Rep_Item
(Entity
(Expression
(Arg1
)));
7701 ------------------------
7702 -- Linker_Constructor --
7703 ------------------------
7705 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
7707 -- Code is shared with Linker_Destructor
7709 -----------------------
7710 -- Linker_Destructor --
7711 -----------------------
7713 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
7715 when Pragma_Linker_Constructor |
7716 Pragma_Linker_Destructor
=>
7717 Linker_Constructor
: declare
7723 Check_Arg_Count
(1);
7724 Check_No_Identifiers
;
7725 Check_Arg_Is_Local_Name
(Arg1
);
7726 Arg1_X
:= Expression
(Arg1
);
7728 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
7730 if not Is_Library_Level_Entity
(Proc
) then
7732 ("argument for pragma% must be library level entity", Arg1
);
7735 -- The only processing required is to link this item on to the
7736 -- list of rep items for the given entity. This is accomplished
7737 -- by the call to Rep_Item_Too_Late (when no error is detected
7738 -- and False is returned).
7740 if Rep_Item_Too_Late
(Proc
, N
) then
7743 Set_Has_Gigi_Rep_Item
(Proc
);
7745 end Linker_Constructor
;
7747 --------------------
7748 -- Linker_Options --
7749 --------------------
7751 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
7753 when Pragma_Linker_Options
=> Linker_Options
: declare
7757 Check_Ada_83_Warning
;
7758 Check_No_Identifiers
;
7759 Check_Arg_Count
(1);
7760 Check_Is_In_Decl_Part_Or_Package_Spec
;
7762 if Operating_Mode
= Generate_Code
7763 and then In_Extended_Main_Source_Unit
(N
)
7765 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
7766 Start_String
(Strval
(Expr_Value_S
(Expression
(Arg1
))));
7769 while Present
(Arg
) loop
7770 Check_Arg_Is_Static_Expression
(Arg
, Standard_String
);
7771 Store_String_Char
(ASCII
.NUL
);
7773 (Strval
(Expr_Value_S
(Expression
(Arg
))));
7777 Store_Linker_Option_String
(End_String
);
7781 --------------------
7782 -- Linker_Section --
7783 --------------------
7785 -- pragma Linker_Section (
7786 -- [Entity =>] LOCAL_NAME
7787 -- [Section =>] static_string_EXPRESSION);
7789 when Pragma_Linker_Section
=>
7791 Check_Arg_Order
((Name_Entity
, Name_Section
));
7792 Check_Arg_Count
(2);
7793 Check_Optional_Identifier
(Arg1
, Name_Entity
);
7794 Check_Optional_Identifier
(Arg2
, Name_Section
);
7795 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
7796 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
7798 -- The only processing required is to link this item on to the
7799 -- list of rep items for the given entity. This is accomplished
7800 -- by the call to Rep_Item_Too_Late (when no error is detected
7801 -- and False is returned).
7803 if Rep_Item_Too_Late
(Entity
(Expression
(Arg1
)), N
) then
7806 Set_Has_Gigi_Rep_Item
(Entity
(Expression
(Arg1
)));
7813 -- pragma List (On | Off)
7815 -- There is nothing to do here, since we did all the processing
7816 -- for this pragma in Par.Prag (so that it works properly even in
7817 -- syntax only mode)
7822 --------------------
7823 -- Locking_Policy --
7824 --------------------
7826 -- pragma Locking_Policy (policy_IDENTIFIER);
7828 when Pragma_Locking_Policy
=> declare
7832 Check_Ada_83_Warning
;
7833 Check_Arg_Count
(1);
7834 Check_No_Identifiers
;
7835 Check_Arg_Is_Locking_Policy
(Arg1
);
7836 Check_Valid_Configuration_Pragma
;
7837 Get_Name_String
(Chars
(Expression
(Arg1
)));
7838 LP
:= Fold_Upper
(Name_Buffer
(1));
7840 if Locking_Policy
/= ' '
7841 and then Locking_Policy
/= LP
7843 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
7844 Error_Pragma
("locking policy incompatible with policy#");
7846 -- Set new policy, but always preserve System_Location since
7847 -- we like the error message with the run time name.
7850 Locking_Policy
:= LP
;
7852 if Locking_Policy_Sloc
/= System_Location
then
7853 Locking_Policy_Sloc
:= Loc
;
7862 -- pragma Long_Float (D_Float | G_Float);
7864 when Pragma_Long_Float
=>
7866 Check_Valid_Configuration_Pragma
;
7867 Check_Arg_Count
(1);
7868 Check_No_Identifier
(Arg1
);
7869 Check_Arg_Is_One_Of
(Arg1
, Name_D_Float
, Name_G_Float
);
7871 if not OpenVMS_On_Target
then
7872 Error_Pragma
("?pragma% ignored (applies only to Open'V'M'S)");
7877 if Chars
(Expression
(Arg1
)) = Name_D_Float
then
7878 if Opt
.Float_Format_Long
= 'G' then
7879 Error_Pragma
("G_Float previously specified");
7882 Opt
.Float_Format_Long
:= 'D';
7884 -- G_Float case (this is the default, does not need overriding)
7887 if Opt
.Float_Format_Long
= 'D' then
7888 Error_Pragma
("D_Float previously specified");
7891 Opt
.Float_Format_Long
:= 'G';
7894 Set_Standard_Fpt_Formats
;
7896 -----------------------
7897 -- Machine_Attribute --
7898 -----------------------
7900 -- pragma Machine_Attribute (
7901 -- [Entity =>] LOCAL_NAME,
7902 -- [Attribute_Name =>] static_string_EXPRESSION
7903 -- [,[Info =>] static_string_EXPRESSION] );
7905 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
7910 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
7912 if Arg_Count
= 3 then
7913 Check_Optional_Identifier
(Arg3
, Name_Info
);
7914 Check_Arg_Is_Static_Expression
(Arg3
, Standard_String
);
7916 Check_Arg_Count
(2);
7919 Check_Optional_Identifier
(Arg1
, Name_Entity
);
7920 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
7921 Check_Arg_Is_Local_Name
(Arg1
);
7922 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
7923 Def_Id
:= Entity
(Expression
(Arg1
));
7925 if Is_Access_Type
(Def_Id
) then
7926 Def_Id
:= Designated_Type
(Def_Id
);
7929 if Rep_Item_Too_Early
(Def_Id
, N
) then
7933 Def_Id
:= Underlying_Type
(Def_Id
);
7935 -- The only processing required is to link this item on to the
7936 -- list of rep items for the given entity. This is accomplished
7937 -- by the call to Rep_Item_Too_Late (when no error is detected
7938 -- and False is returned).
7940 if Rep_Item_Too_Late
(Def_Id
, N
) then
7943 Set_Has_Gigi_Rep_Item
(Entity
(Expression
(Arg1
)));
7945 end Machine_Attribute
;
7951 -- pragma Main_Storage
7952 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
7954 -- MAIN_STORAGE_OPTION ::=
7955 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
7956 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
7958 when Pragma_Main
=> Main
: declare
7959 Args
: Args_List
(1 .. 3);
7960 Names
: constant Name_List
(1 .. 3) := (
7962 Name_Task_Stack_Size_Default
,
7963 Name_Time_Slicing_Enabled
);
7969 Gather_Associations
(Names
, Args
);
7971 for J
in 1 .. 2 loop
7972 if Present
(Args
(J
)) then
7973 Check_Arg_Is_Static_Expression
(Args
(J
), Any_Integer
);
7977 if Present
(Args
(3)) then
7978 Check_Arg_Is_Static_Expression
(Args
(3), Standard_Boolean
);
7982 while Present
(Nod
) loop
7983 if Nkind
(Nod
) = N_Pragma
7984 and then Chars
(Nod
) = Name_Main
7986 Error_Msg_Name_1
:= Chars
(N
);
7987 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
7998 -- pragma Main_Storage
7999 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
8001 -- MAIN_STORAGE_OPTION ::=
8002 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
8003 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
8005 when Pragma_Main_Storage
=> Main_Storage
: declare
8006 Args
: Args_List
(1 .. 2);
8007 Names
: constant Name_List
(1 .. 2) := (
8008 Name_Working_Storage
,
8015 Gather_Associations
(Names
, Args
);
8017 for J
in 1 .. 2 loop
8018 if Present
(Args
(J
)) then
8019 Check_Arg_Is_Static_Expression
(Args
(J
), Any_Integer
);
8023 Check_In_Main_Program
;
8026 while Present
(Nod
) loop
8027 if Nkind
(Nod
) = N_Pragma
8028 and then Chars
(Nod
) = Name_Main_Storage
8030 Error_Msg_Name_1
:= Chars
(N
);
8031 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
8042 -- pragma Memory_Size (NUMERIC_LITERAL)
8044 when Pragma_Memory_Size
=>
8047 -- Memory size is simply ignored
8049 Check_No_Identifiers
;
8050 Check_Arg_Count
(1);
8051 Check_Arg_Is_Integer_Literal
(Arg1
);
8057 -- pragma No_Return (procedure_LOCAL_NAME);
8059 when Pragma_No_Return
=> No_Return
: declare
8066 Check_Arg_Count
(1);
8067 Check_No_Identifiers
;
8068 Check_Arg_Is_Local_Name
(Arg1
);
8069 Id
:= Expression
(Arg1
);
8072 if not Is_Entity_Name
(Id
) then
8073 Error_Pragma_Arg
("entity name required", Arg1
);
8076 if Etype
(Id
) = Any_Type
then
8084 and then Scope
(E
) = Current_Scope
8086 if Ekind
(E
) = E_Procedure
8087 or else Ekind
(E
) = E_Generic_Procedure
8097 Error_Pragma
("no procedures found for pragma%");
8101 ------------------------
8102 -- No_Strict_Aliasing --
8103 ------------------------
8105 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
8107 when Pragma_No_Strict_Aliasing
=> No_Strict_Alias
: declare
8112 Check_At_Most_N_Arguments
(1);
8114 if Arg_Count
= 0 then
8115 Check_Valid_Configuration_Pragma
;
8116 Opt
.No_Strict_Aliasing
:= True;
8119 Check_Optional_Identifier
(Arg2
, Name_Entity
);
8120 Check_Arg_Is_Local_Name
(Arg1
);
8121 E_Id
:= Entity
(Expression
(Arg1
));
8123 if E_Id
= Any_Type
then
8125 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
8126 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
8129 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
8131 end No_Strict_Alias
;
8137 -- pragma Obsolescent [(static_string_EXPRESSION [, Ada_05])];
8139 when Pragma_Obsolescent
=> Obsolescent
: declare
8140 Subp
: Node_Or_Entity_Id
;
8142 Active
: Boolean := True;
8146 Check_At_Most_N_Arguments
(2);
8147 Check_No_Identifiers
;
8149 -- Check OK placement
8151 -- First possibility is within a declarative region, where the
8152 -- pragma immediately follows a subprogram declaration.
8154 if Present
(Prev
(N
)) then
8157 -- Second possibility, stand alone subprogram declaration with the
8158 -- pragma immediately following the declaration.
8161 and then Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
8163 Subp
:= Unit
(Parent
(Parent
(N
)));
8165 -- Any other possibility is a misplacement
8171 -- Check correct placement
8173 if Nkind
(Subp
) /= N_Subprogram_Declaration
then
8175 ("pragma% misplaced, must immediately " &
8176 "follow subprogram spec");
8179 -- If OK placement, acquire arguments
8181 Subp
:= Defining_Entity
(Subp
);
8183 if Arg_Count
>= 1 then
8185 -- Deal with static string argument
8187 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
8188 S
:= Strval
(Expression
(Arg1
));
8190 for J
in 1 .. String_Length
(S
) loop
8191 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
8193 ("pragma% argument does not allow wide characters",
8198 Set_Obsolescent_Warning
(Subp
, Expression
(Arg1
));
8200 -- Check for Ada_05 parameter
8202 if Arg_Count
/= 1 then
8203 Check_Arg_Count
(2);
8206 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
8209 Check_Arg_Is_Identifier
(Argx
);
8211 if Chars
(Argx
) /= Name_Ada_05
then
8212 Error_Msg_Name_2
:= Name_Ada_05
;
8214 ("only allowed argument for pragma% is %", Argx
);
8217 if Ada_Version_Explicit
< Ada_05
8218 or else not Warn_On_Ada_2005_Compatibility
8226 -- Set flag if pragma active
8229 Set_Is_Obsolescent
(Subp
);
8237 -- pragma No_Run_Time
8239 -- Note: this pragma is retained for backwards compatibiltiy.
8240 -- See body of Rtsfind for full details on its handling.
8242 when Pragma_No_Run_Time
=>
8244 Check_Valid_Configuration_Pragma
;
8245 Check_Arg_Count
(0);
8247 No_Run_Time_Mode
:= True;
8248 Configurable_Run_Time_Mode
:= True;
8251 Word32
: constant Boolean := Ttypes
.System_Word_Size
= 32;
8254 Duration_32_Bits_On_Target
:= True;
8258 Set_Restriction
(No_Finalization
, N
);
8259 Set_Restriction
(No_Exception_Handlers
, N
);
8260 Set_Restriction
(Max_Tasks
, N
, 0);
8261 Set_Restriction
(No_Tasking
, N
);
8263 -----------------------
8264 -- Normalize_Scalars --
8265 -----------------------
8267 -- pragma Normalize_Scalars;
8269 when Pragma_Normalize_Scalars
=>
8270 Check_Ada_83_Warning
;
8271 Check_Arg_Count
(0);
8272 Check_Valid_Configuration_Pragma
;
8273 Normalize_Scalars
:= True;
8274 Init_Or_Norm_Scalars
:= True;
8280 -- pragma Optimize (Time | Space);
8282 -- The actual check for optimize is done in Gigi. Note that this
8283 -- pragma does not actually change the optimization setting, it
8284 -- simply checks that it is consistent with the pragma.
8286 when Pragma_Optimize
=>
8287 Check_No_Identifiers
;
8288 Check_Arg_Count
(1);
8289 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
8291 -------------------------
8292 -- Optional_Overriding --
8293 -------------------------
8295 -- These pragmas are treated as part of the previous subprogram
8296 -- declaration, and analyzed immediately after it (see sem_ch6,
8297 -- Check_Overriding_Operation). If the pragma has not been analyzed
8298 -- yet, it appears in the wrong place.
8300 when Pragma_Optional_Overriding
=>
8301 Error_Msg_N
("pragma must appear immediately after subprogram", N
);
8307 -- pragma Pack (first_subtype_LOCAL_NAME);
8309 when Pragma_Pack
=> Pack
: declare
8310 Assoc
: constant Node_Id
:= Arg1
;
8315 Check_No_Identifiers
;
8316 Check_Arg_Count
(1);
8317 Check_Arg_Is_Local_Name
(Arg1
);
8319 Type_Id
:= Expression
(Assoc
);
8320 Find_Type
(Type_Id
);
8321 Typ
:= Entity
(Type_Id
);
8324 or else Rep_Item_Too_Early
(Typ
, N
)
8328 Typ
:= Underlying_Type
(Typ
);
8331 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
8332 Error_Pragma
("pragma% must specify array or record type");
8335 Check_First_Subtype
(Arg1
);
8337 if Has_Pragma_Pack
(Typ
) then
8338 Error_Pragma
("duplicate pragma%, only one allowed");
8342 elsif Is_Array_Type
(Typ
) then
8344 -- Pack not allowed for aliased or atomic components
8346 if Has_Aliased_Components
(Base_Type
(Typ
)) then
8348 ("pragma% ignored, cannot pack aliased components?");
8350 elsif Has_Atomic_Components
(Typ
)
8351 or else Is_Atomic
(Component_Type
(Typ
))
8354 ("?pragma% ignored, cannot pack atomic components");
8357 -- If we had an explicit component size given, then we do not
8358 -- let Pack override this given size. We also give a warning
8359 -- that Pack is being ignored unless we can tell for sure that
8360 -- the Pack would not have had any effect anyway.
8362 if Has_Component_Size_Clause
(Typ
) then
8363 if Known_Static_RM_Size
(Component_Type
(Typ
))
8365 RM_Size
(Component_Type
(Typ
)) = Component_Size
(Typ
)
8370 ("?pragma% ignored, explicit component size given");
8373 -- If no prior array component size given, Pack is effective
8376 if not Rep_Item_Too_Late
(Typ
, N
) then
8377 Set_Is_Packed
(Base_Type
(Typ
));
8378 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
8379 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
8383 -- For record types, the pack is always effective
8385 else pragma Assert
(Is_Record_Type
(Typ
));
8386 if not Rep_Item_Too_Late
(Typ
, N
) then
8387 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
8388 Set_Is_Packed
(Base_Type
(Typ
));
8389 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
8400 -- There is nothing to do here, since we did all the processing
8401 -- for this pragma in Par.Prag (so that it works properly even in
8402 -- syntax only mode)
8411 -- pragma Passive [(PASSIVE_FORM)];
8413 -- PASSIVE_FORM ::= Semaphore | No
8415 when Pragma_Passive
=>
8418 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
8419 Error_Pragma
("pragma% must be within task definition");
8422 if Arg_Count
/= 0 then
8423 Check_Arg_Count
(1);
8424 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
8431 -- pragma Polling (ON | OFF);
8433 when Pragma_Polling
=>
8435 Check_Arg_Count
(1);
8436 Check_No_Identifiers
;
8437 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
8438 Polling_Required
:= (Chars
(Expression
(Arg1
)) = Name_On
);
8440 --------------------
8441 -- Persistent_BSS --
8442 --------------------
8444 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
8451 Check_At_Most_N_Arguments
(1);
8453 -- Case of application to specific object (one argument)
8455 if Arg_Count
= 1 then
8456 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
8458 if not Is_Entity_Name
(Expression
(Arg1
))
8460 (Ekind
(Entity
(Expression
(Arg1
))) /= E_Variable
8461 and then Ekind
(Entity
(Expression
(Arg1
))) /= E_Constant
)
8463 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
8466 Ent
:= Entity
(Expression
(Arg1
));
8467 Decl
:= Parent
(Ent
);
8469 if Rep_Item_Too_Late
(Ent
, N
) then
8473 if Present
(Expression
(Decl
)) then
8475 ("object for pragma% cannot have initialization", Arg1
);
8478 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
8480 ("object type for pragma% is not potentially persistent",
8485 Make_Linker_Section_Pragma
8486 (Ent
, Sloc
(N
), ".persistent.bss");
8487 Insert_After
(N
, Prag
);
8490 -- Case of use as configuration pragma with no arguments
8493 Check_Valid_Configuration_Pragma
;
8494 Persistent_BSS_Mode
:= True;
8502 -- pragma Preelaborate [(library_unit_NAME)];
8504 -- Set the flag Is_Preelaborated of program unit name entity
8506 when Pragma_Preelaborate
=> Preelaborate
: declare
8507 Pa
: constant Node_Id
:= Parent
(N
);
8508 Pk
: constant Node_Kind
:= Nkind
(Pa
);
8512 Check_Ada_83_Warning
;
8513 Check_Valid_Library_Unit_Pragma
;
8515 if Nkind
(N
) = N_Null_Statement
then
8519 Ent
:= Find_Lib_Unit_Name
;
8521 -- This filters out pragmas inside generic parent then
8522 -- show up inside instantiation
8525 and then not (Pk
= N_Package_Specification
8526 and then Present
(Generic_Parent
(Pa
)))
8528 if not Debug_Flag_U
then
8529 Set_Is_Preelaborated
(Ent
);
8530 Set_Suppress_Elaboration_Warnings
(Ent
);
8535 ---------------------
8536 -- Preelaborate_05 --
8537 ---------------------
8539 -- pragma Preelaborate_05 [(library_unit_NAME)];
8541 -- This pragma is useable only in GNAT_Mode, where it is used like
8542 -- pragma Preelaborate but it is only effective in Ada 2005 mode
8543 -- (otherwise it is ignored). This is used to implement AI-362 which
8544 -- recategorizes some run-time packages in Ada 2005 mode.
8546 when Pragma_Preelaborate_05
=> Preelaborate_05
: declare
8551 Check_Valid_Library_Unit_Pragma
;
8553 if not GNAT_Mode
then
8554 Error_Pragma
("pragma% only available in GNAT mode");
8557 if Nkind
(N
) = N_Null_Statement
then
8561 -- This is one of the few cases where we need to test the value of
8562 -- Ada_Version_Explicit rather than Ada_Version (which is always
8563 -- set to Ada_05 in a predefined unit), we need to know the
8564 -- explicit version set to know if this pragma is active.
8566 if Ada_Version_Explicit
>= Ada_05
then
8567 Ent
:= Find_Lib_Unit_Name
;
8568 Set_Is_Preelaborated
(Ent
);
8569 Set_Suppress_Elaboration_Warnings
(Ent
);
8571 end Preelaborate_05
;
8577 -- pragma Priority (EXPRESSION);
8579 when Pragma_Priority
=> Priority
: declare
8580 P
: constant Node_Id
:= Parent
(N
);
8584 Check_No_Identifiers
;
8585 Check_Arg_Count
(1);
8589 if Nkind
(P
) = N_Subprogram_Body
then
8590 Check_In_Main_Program
;
8592 Arg
:= Expression
(Arg1
);
8593 Analyze_And_Resolve
(Arg
, Standard_Integer
);
8597 if not Is_Static_Expression
(Arg
) then
8598 Flag_Non_Static_Expr
8599 ("main subprogram priority is not static!", Arg
);
8602 -- If constraint error, then we already signalled an error
8604 elsif Raises_Constraint_Error
(Arg
) then
8607 -- Otherwise check in range
8611 Val
: constant Uint
:= Expr_Value
(Arg
);
8615 or else Val
> Expr_Value
(Expression
8616 (Parent
(RTE
(RE_Max_Priority
))))
8619 ("main subprogram priority is out of range", Arg1
);
8625 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
8627 -- Task or Protected, must be of type Integer
8629 elsif Nkind
(P
) = N_Protected_Definition
8631 Nkind
(P
) = N_Task_Definition
8633 Arg
:= Expression
(Arg1
);
8635 -- The expression must be analyzed in the special manner
8636 -- described in "Handling of Default and Per-Object
8637 -- Expressions" in sem.ads.
8639 Analyze_Per_Use_Expression
(Arg
, Standard_Integer
);
8641 if not Is_Static_Expression
(Arg
) then
8642 Check_Restriction
(Static_Priorities
, Arg
);
8645 -- Anything else is incorrect
8651 if Has_Priority_Pragma
(P
) then
8652 Error_Pragma
("duplicate pragma% not allowed");
8654 Set_Has_Priority_Pragma
(P
, True);
8656 if Nkind
(P
) = N_Protected_Definition
8658 Nkind
(P
) = N_Task_Definition
8660 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
8661 -- exp_ch9 should use this ???
8670 -- pragma Profile (profile_IDENTIFIER);
8672 -- profile_IDENTIFIER => Protected | Ravenscar
8674 when Pragma_Profile
=>
8675 Check_Arg_Count
(1);
8676 Check_Valid_Configuration_Pragma
;
8677 Check_No_Identifiers
;
8680 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8682 if Chars
(Argx
) = Name_Ravenscar
then
8683 Set_Ravenscar_Profile
(N
);
8685 elsif Chars
(Argx
) = Name_Restricted
then
8686 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> False);
8688 Error_Pragma_Arg
("& is not a valid profile", Argx
);
8692 ----------------------
8693 -- Profile_Warnings --
8694 ----------------------
8696 -- pragma Profile_Warnings (profile_IDENTIFIER);
8698 -- profile_IDENTIFIER => Protected | Ravenscar
8700 when Pragma_Profile_Warnings
=>
8702 Check_Arg_Count
(1);
8703 Check_Valid_Configuration_Pragma
;
8704 Check_No_Identifiers
;
8707 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8709 if Chars
(Argx
) = Name_Ravenscar
then
8710 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
8712 elsif Chars
(Argx
) = Name_Restricted
then
8713 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
8715 Error_Pragma_Arg
("& is not a valid profile", Argx
);
8719 --------------------------
8720 -- Propagate_Exceptions --
8721 --------------------------
8723 -- pragma Propagate_Exceptions;
8725 when Pragma_Propagate_Exceptions
=>
8727 Check_Arg_Count
(0);
8729 if In_Extended_Main_Source_Unit
(N
) then
8730 Propagate_Exceptions
:= True;
8737 -- pragma Psect_Object (
8738 -- [Internal =>] LOCAL_NAME,
8739 -- [, [External =>] EXTERNAL_SYMBOL]
8740 -- [, [Size =>] EXTERNAL_SYMBOL]);
8742 when Pragma_Psect_Object | Pragma_Common_Object
=>
8743 Psect_Object
: declare
8744 Args
: Args_List
(1 .. 3);
8745 Names
: constant Name_List
(1 .. 3) := (
8750 Internal
: Node_Id
renames Args
(1);
8751 External
: Node_Id
renames Args
(2);
8752 Size
: Node_Id
renames Args
(3);
8756 procedure Check_Too_Long
(Arg
: Node_Id
);
8757 -- Posts message if the argument is an identifier with more
8758 -- than 31 characters, or a string literal with more than
8759 -- 31 characters, and we are operating under VMS
8761 --------------------
8762 -- Check_Too_Long --
8763 --------------------
8765 procedure Check_Too_Long
(Arg
: Node_Id
) is
8766 X
: constant Node_Id
:= Original_Node
(Arg
);
8769 if Nkind
(X
) /= N_String_Literal
8771 Nkind
(X
) /= N_Identifier
8774 ("inappropriate argument for pragma %", Arg
);
8777 if OpenVMS_On_Target
then
8778 if (Nkind
(X
) = N_String_Literal
8779 and then String_Length
(Strval
(X
)) > 31)
8781 (Nkind
(X
) = N_Identifier
8782 and then Length_Of_Name
(Chars
(X
)) > 31)
8785 ("argument for pragma % is longer than 31 characters",
8791 -- Start of processing for Common_Object/Psect_Object
8795 Gather_Associations
(Names
, Args
);
8796 Process_Extended_Import_Export_Internal_Arg
(Internal
);
8798 Def_Id
:= Entity
(Internal
);
8800 if Ekind
(Def_Id
) /= E_Constant
8801 and then Ekind
(Def_Id
) /= E_Variable
8804 ("pragma% must designate an object", Internal
);
8807 Check_Too_Long
(Internal
);
8809 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
8811 ("cannot use pragma% for imported/exported object",
8815 if Is_Concurrent_Type
(Etype
(Internal
)) then
8817 ("cannot specify pragma % for task/protected object",
8821 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
8823 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
8825 Error_Msg_N
("?duplicate Common/Psect_Object pragma", N
);
8828 if Ekind
(Def_Id
) = E_Constant
then
8830 ("cannot specify pragma % for a constant", Internal
);
8833 if Is_Record_Type
(Etype
(Internal
)) then
8839 Ent
:= First_Entity
(Etype
(Internal
));
8840 while Present
(Ent
) loop
8841 Decl
:= Declaration_Node
(Ent
);
8843 if Ekind
(Ent
) = E_Component
8844 and then Nkind
(Decl
) = N_Component_Declaration
8845 and then Present
(Expression
(Decl
))
8846 and then Warn_On_Export_Import
8849 ("?object for pragma % has defaults", Internal
);
8859 if Present
(Size
) then
8860 Check_Too_Long
(Size
);
8863 if Present
(External
) then
8864 Check_Arg_Is_External_Name
(External
);
8865 Check_Too_Long
(External
);
8868 -- If all error tests pass, link pragma on to the rep item chain
8870 Record_Rep_Item
(Def_Id
, N
);
8877 -- pragma Pure [(library_unit_NAME)];
8879 when Pragma_Pure
=> Pure
: declare
8883 Check_Ada_83_Warning
;
8884 Check_Valid_Library_Unit_Pragma
;
8886 if Nkind
(N
) = N_Null_Statement
then
8890 Ent
:= Find_Lib_Unit_Name
;
8892 Set_Suppress_Elaboration_Warnings
(Ent
);
8899 -- pragma Pure_05 [(library_unit_NAME)];
8901 -- This pragma is useable only in GNAT_Mode, where it is used like
8902 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
8903 -- it is ignored). It may be used after a pragma Preelaborate, in
8904 -- which case it overrides the effect of the pragma Preelaborate.
8905 -- This is used to implement AI-362 which recategorizes some run-time
8906 -- packages in Ada 2005 mode.
8908 when Pragma_Pure_05
=> Pure_05
: declare
8913 Check_Valid_Library_Unit_Pragma
;
8915 if not GNAT_Mode
then
8916 Error_Pragma
("pragma% only available in GNAT mode");
8918 if Nkind
(N
) = N_Null_Statement
then
8922 -- This is one of the few cases where we need to test the value of
8923 -- Ada_Version_Explicit rather than Ada_Version (which is always
8924 -- set to Ada_05 in a predefined unit), we need to know the
8925 -- explicit version set to know if this pragma is active.
8927 if Ada_Version_Explicit
>= Ada_05
then
8928 Ent
:= Find_Lib_Unit_Name
;
8929 Set_Is_Preelaborated
(Ent
, False);
8931 Set_Suppress_Elaboration_Warnings
(Ent
);
8939 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
8941 when Pragma_Pure_Function
=> Pure_Function
: declare
8945 Effective
: Boolean := False;
8949 Check_Arg_Count
(1);
8950 Check_Optional_Identifier
(Arg1
, Name_Entity
);
8951 Check_Arg_Is_Local_Name
(Arg1
);
8952 E_Id
:= Expression
(Arg1
);
8954 if Error_Posted
(E_Id
) then
8958 -- Loop through homonyms (overloadings) of referenced entity
8964 Def_Id
:= Get_Base_Subprogram
(E
);
8966 if Ekind
(Def_Id
) /= E_Function
8967 and then Ekind
(Def_Id
) /= E_Generic_Function
8968 and then Ekind
(Def_Id
) /= E_Operator
8971 ("pragma% requires a function name", Arg1
);
8974 Set_Is_Pure
(Def_Id
);
8976 if not Has_Pragma_Pure_Function
(Def_Id
) then
8977 Set_Has_Pragma_Pure_Function
(Def_Id
);
8982 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
8986 and then Warn_On_Redundant_Constructs
8988 Error_Msg_NE
("pragma Pure_Function on& is redundant?",
8994 --------------------
8995 -- Queuing_Policy --
8996 --------------------
8998 -- pragma Queuing_Policy (policy_IDENTIFIER);
9000 when Pragma_Queuing_Policy
=> declare
9004 Check_Ada_83_Warning
;
9005 Check_Arg_Count
(1);
9006 Check_No_Identifiers
;
9007 Check_Arg_Is_Queuing_Policy
(Arg1
);
9008 Check_Valid_Configuration_Pragma
;
9009 Get_Name_String
(Chars
(Expression
(Arg1
)));
9010 QP
:= Fold_Upper
(Name_Buffer
(1));
9012 if Queuing_Policy
/= ' '
9013 and then Queuing_Policy
/= QP
9015 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
9016 Error_Pragma
("queuing policy incompatible with policy#");
9018 -- Set new policy, but always preserve System_Location since
9019 -- we like the error message with the run time name.
9022 Queuing_Policy
:= QP
;
9024 if Queuing_Policy_Sloc
/= System_Location
then
9025 Queuing_Policy_Sloc
:= Loc
;
9030 ---------------------------
9031 -- Remote_Call_Interface --
9032 ---------------------------
9034 -- pragma Remote_Call_Interface [(library_unit_NAME)];
9036 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
9037 Cunit_Node
: Node_Id
;
9038 Cunit_Ent
: Entity_Id
;
9042 Check_Ada_83_Warning
;
9043 Check_Valid_Library_Unit_Pragma
;
9045 if Nkind
(N
) = N_Null_Statement
then
9049 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
9050 K
:= Nkind
(Unit
(Cunit_Node
));
9051 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
9053 if K
= N_Package_Declaration
9054 or else K
= N_Generic_Package_Declaration
9055 or else K
= N_Subprogram_Declaration
9056 or else K
= N_Generic_Subprogram_Declaration
9057 or else (K
= N_Subprogram_Body
9058 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
9063 "pragma% must apply to package or subprogram declaration");
9066 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
9067 end Remote_Call_Interface
;
9073 -- pragma Remote_Types [(library_unit_NAME)];
9075 when Pragma_Remote_Types
=> Remote_Types
: declare
9076 Cunit_Node
: Node_Id
;
9077 Cunit_Ent
: Entity_Id
;
9080 Check_Ada_83_Warning
;
9081 Check_Valid_Library_Unit_Pragma
;
9083 if Nkind
(N
) = N_Null_Statement
then
9087 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
9088 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
9090 if Nkind
(Unit
(Cunit_Node
)) /= N_Package_Declaration
9092 Nkind
(Unit
(Cunit_Node
)) /= N_Generic_Package_Declaration
9095 "pragma% can only apply to a package declaration");
9098 Set_Is_Remote_Types
(Cunit_Ent
);
9105 -- pragma Ravenscar;
9107 when Pragma_Ravenscar
=>
9109 Check_Arg_Count
(0);
9110 Check_Valid_Configuration_Pragma
;
9111 Set_Ravenscar_Profile
(N
);
9113 if Warn_On_Obsolescent_Feature
then
9115 ("pragma Ravenscar is an obsolescent feature?", N
);
9117 ("|use pragma Profile (Ravenscar) instead", N
);
9120 -------------------------
9121 -- Restricted_Run_Time --
9122 -------------------------
9124 -- pragma Restricted_Run_Time;
9126 when Pragma_Restricted_Run_Time
=>
9128 Check_Arg_Count
(0);
9129 Check_Valid_Configuration_Pragma
;
9130 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> False);
9132 if Warn_On_Obsolescent_Feature
then
9134 ("pragma Restricted_Run_Time is an obsolescent feature?", N
);
9136 ("|use pragma Profile (Restricted) instead", N
);
9143 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
9146 -- restriction_IDENTIFIER
9147 -- | restriction_parameter_IDENTIFIER => EXPRESSION
9149 when Pragma_Restrictions
=>
9150 Process_Restrictions_Or_Restriction_Warnings
;
9152 --------------------------
9153 -- Restriction_Warnings --
9154 --------------------------
9156 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
9159 -- restriction_IDENTIFIER
9160 -- | restriction_parameter_IDENTIFIER => EXPRESSION
9162 when Pragma_Restriction_Warnings
=>
9163 Process_Restrictions_Or_Restriction_Warnings
;
9169 -- pragma Reviewable;
9171 when Pragma_Reviewable
=>
9172 Check_Ada_83_Warning
;
9173 Check_Arg_Count
(0);
9179 -- pragma Share_Generic (NAME {, NAME});
9181 when Pragma_Share_Generic
=>
9183 Process_Generic_List
;
9189 -- pragma Shared (LOCAL_NAME);
9191 when Pragma_Shared
=>
9193 Process_Atomic_Shared_Volatile
;
9195 --------------------
9196 -- Shared_Passive --
9197 --------------------
9199 -- pragma Shared_Passive [(library_unit_NAME)];
9201 -- Set the flag Is_Shared_Passive of program unit name entity
9203 when Pragma_Shared_Passive
=> Shared_Passive
: declare
9204 Cunit_Node
: Node_Id
;
9205 Cunit_Ent
: Entity_Id
;
9208 Check_Ada_83_Warning
;
9209 Check_Valid_Library_Unit_Pragma
;
9211 if Nkind
(N
) = N_Null_Statement
then
9215 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
9216 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
9218 if Nkind
(Unit
(Cunit_Node
)) /= N_Package_Declaration
9220 Nkind
(Unit
(Cunit_Node
)) /= N_Generic_Package_Declaration
9223 "pragma% can only apply to a package declaration");
9226 Set_Is_Shared_Passive
(Cunit_Ent
);
9229 ----------------------
9230 -- Source_File_Name --
9231 ----------------------
9233 -- There are five forms for this pragma:
9235 -- pragma Source_File_Name (
9236 -- [UNIT_NAME =>] unit_NAME,
9237 -- BODY_FILE_NAME => STRING_LITERAL
9238 -- [, [INDEX =>] INTEGER_LITERAL]);
9240 -- pragma Source_File_Name (
9241 -- [UNIT_NAME =>] unit_NAME,
9242 -- SPEC_FILE_NAME => STRING_LITERAL
9243 -- [, [INDEX =>] INTEGER_LITERAL]);
9245 -- pragma Source_File_Name (
9246 -- BODY_FILE_NAME => STRING_LITERAL
9247 -- [, DOT_REPLACEMENT => STRING_LITERAL]
9248 -- [, CASING => CASING_SPEC]);
9250 -- pragma Source_File_Name (
9251 -- SPEC_FILE_NAME => STRING_LITERAL
9252 -- [, DOT_REPLACEMENT => STRING_LITERAL]
9253 -- [, CASING => CASING_SPEC]);
9255 -- pragma Source_File_Name (
9256 -- SUBUNIT_FILE_NAME => STRING_LITERAL
9257 -- [, DOT_REPLACEMENT => STRING_LITERAL]
9258 -- [, CASING => CASING_SPEC]);
9260 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
9262 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
9263 -- Source_File_Name (SFN), however their usage is exclusive:
9264 -- SFN can only be used when no project file is used, while
9265 -- SFNP can only be used when a project file is used.
9267 -- No processing here. Processing was completed during parsing,
9268 -- since we need to have file names set as early as possible.
9269 -- Units are loaded well before semantic processing starts.
9271 -- The only processing we defer to this point is the check
9272 -- for correct placement.
9274 when Pragma_Source_File_Name
=>
9276 Check_Valid_Configuration_Pragma
;
9278 ------------------------------
9279 -- Source_File_Name_Project --
9280 ------------------------------
9282 -- See Source_File_Name for syntax
9284 -- No processing here. Processing was completed during parsing,
9285 -- since we need to have file names set as early as possible.
9286 -- Units are loaded well before semantic processing starts.
9288 -- The only processing we defer to this point is the check
9289 -- for correct placement.
9291 when Pragma_Source_File_Name_Project
=>
9293 Check_Valid_Configuration_Pragma
;
9295 -- Check that a pragma Source_File_Name_Project is used only
9296 -- in a configuration pragmas file.
9298 -- Pragmas Source_File_Name_Project should only be generated
9299 -- by the Project Manager in configuration pragmas files.
9301 -- This is really an ugly test. It seems to depend on some
9302 -- accidental and undocumented property. At the very least
9303 -- it needs to be documented, but it would be better to have
9304 -- a clean way of testing if we are in a configuration file???
9306 if Present
(Parent
(N
)) then
9308 ("pragma% can only appear in a configuration pragmas file");
9311 ----------------------
9312 -- Source_Reference --
9313 ----------------------
9315 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
9317 -- Nothing to do, all processing completed in Par.Prag, since we
9318 -- need the information for possible parser messages that are output
9320 when Pragma_Source_Reference
=>
9327 -- pragma Storage_Size (EXPRESSION);
9329 when Pragma_Storage_Size
=> Storage_Size
: declare
9330 P
: constant Node_Id
:= Parent
(N
);
9334 Check_No_Identifiers
;
9335 Check_Arg_Count
(1);
9337 -- The expression must be analyzed in the special manner
9338 -- described in "Handling of Default Expressions" in sem.ads.
9340 -- Set In_Default_Expression for per-object case ???
9342 Arg
:= Expression
(Arg1
);
9343 Analyze_Per_Use_Expression
(Arg
, Any_Integer
);
9345 if not Is_Static_Expression
(Arg
) then
9346 Check_Restriction
(Static_Storage_Size
, Arg
);
9349 if Nkind
(P
) /= N_Task_Definition
then
9354 if Has_Storage_Size_Pragma
(P
) then
9355 Error_Pragma
("duplicate pragma% not allowed");
9357 Set_Has_Storage_Size_Pragma
(P
, True);
9360 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
9361 -- ??? exp_ch9 should use this!
9369 -- pragma Storage_Unit (NUMERIC_LITERAL);
9371 -- Only permitted argument is System'Storage_Unit value
9373 when Pragma_Storage_Unit
=>
9374 Check_No_Identifiers
;
9375 Check_Arg_Count
(1);
9376 Check_Arg_Is_Integer_Literal
(Arg1
);
9378 if Intval
(Expression
(Arg1
)) /=
9379 UI_From_Int
(Ttypes
.System_Storage_Unit
)
9381 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
9383 ("the only allowed argument for pragma% is ^", Arg1
);
9386 --------------------
9387 -- Stream_Convert --
9388 --------------------
9390 -- pragma Stream_Convert (
9391 -- [Entity =>] type_LOCAL_NAME,
9392 -- [Read =>] function_NAME,
9393 -- [Write =>] function NAME);
9395 when Pragma_Stream_Convert
=> Stream_Convert
: declare
9397 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
9398 -- Check that the given argument is the name of a local
9399 -- function of one argument that is not overloaded earlier
9400 -- in the current local scope. A check is also made that the
9401 -- argument is a function with one parameter.
9403 --------------------------------------
9404 -- Check_OK_Stream_Convert_Function --
9405 --------------------------------------
9407 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
9411 Check_Arg_Is_Local_Name
(Arg
);
9412 Ent
:= Entity
(Expression
(Arg
));
9414 if Has_Homonym
(Ent
) then
9416 ("argument for pragma% may not be overloaded", Arg
);
9419 if Ekind
(Ent
) /= E_Function
9420 or else No
(First_Formal
(Ent
))
9421 or else Present
(Next_Formal
(First_Formal
(Ent
)))
9424 ("argument for pragma% must be" &
9425 " function of one argument", Arg
);
9427 end Check_OK_Stream_Convert_Function
;
9429 -- Start of procecessing for Stream_Convert
9433 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
9434 Check_Arg_Count
(3);
9435 Check_Optional_Identifier
(Arg1
, Name_Entity
);
9436 Check_Optional_Identifier
(Arg2
, Name_Read
);
9437 Check_Optional_Identifier
(Arg3
, Name_Write
);
9438 Check_Arg_Is_Local_Name
(Arg1
);
9439 Check_OK_Stream_Convert_Function
(Arg2
);
9440 Check_OK_Stream_Convert_Function
(Arg3
);
9443 Typ
: constant Entity_Id
:=
9444 Underlying_Type
(Entity
(Expression
(Arg1
)));
9445 Read
: constant Entity_Id
:= Entity
(Expression
(Arg2
));
9446 Write
: constant Entity_Id
:= Entity
(Expression
(Arg3
));
9449 if Etype
(Typ
) = Any_Type
9451 Etype
(Read
) = Any_Type
9453 Etype
(Write
) = Any_Type
9458 Check_First_Subtype
(Arg1
);
9460 if Rep_Item_Too_Early
(Typ
, N
)
9462 Rep_Item_Too_Late
(Typ
, N
)
9467 if Underlying_Type
(Etype
(Read
)) /= Typ
then
9469 ("incorrect return type for function&", Arg2
);
9472 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
9474 ("incorrect parameter type for function&", Arg3
);
9477 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
9478 Underlying_Type
(Etype
(Write
))
9481 ("result type of & does not match Read parameter type",
9487 -------------------------
9488 -- Style_Checks (GNAT) --
9489 -------------------------
9491 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
9493 -- This is processed by the parser since some of the style
9494 -- checks take place during source scanning and parsing. This
9495 -- means that we don't need to issue error messages here.
9497 when Pragma_Style_Checks
=> Style_Checks
: declare
9498 A
: constant Node_Id
:= Expression
(Arg1
);
9504 Check_No_Identifiers
;
9506 -- Two argument form
9508 if Arg_Count
= 2 then
9509 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
9516 E_Id
:= Expression
(Arg2
);
9519 if not Is_Entity_Name
(E_Id
) then
9521 ("second argument of pragma% must be entity name",
9531 Set_Suppress_Style_Checks
(E
,
9532 (Chars
(Expression
(Arg1
)) = Name_Off
));
9533 exit when No
(Homonym
(E
));
9539 -- One argument form
9542 Check_Arg_Count
(1);
9544 if Nkind
(A
) = N_String_Literal
then
9548 Slen
: constant Natural := Natural (String_Length
(S
));
9549 Options
: String (1 .. Slen
);
9555 C
:= Get_String_Char
(S
, Int
(J
));
9556 exit when not In_Character_Range
(C
);
9557 Options
(J
) := Get_Character
(C
);
9560 Set_Style_Check_Options
(Options
);
9568 elsif Nkind
(A
) = N_Identifier
then
9570 if Chars
(A
) = Name_All_Checks
then
9571 Set_Default_Style_Check_Options
;
9573 elsif Chars
(A
) = Name_On
then
9574 Style_Check
:= True;
9576 elsif Chars
(A
) = Name_Off
then
9577 Style_Check
:= False;
9588 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
9590 when Pragma_Subtitle
=>
9592 Check_Arg_Count
(1);
9593 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
9594 Check_Arg_Is_String_Literal
(Arg1
);
9600 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
9602 when Pragma_Suppress
=>
9603 Process_Suppress_Unsuppress
(True);
9609 -- pragma Suppress_All;
9611 -- The only check made here is that the pragma appears in the
9612 -- proper place, i.e. following a compilation unit. If indeed
9613 -- it appears in this context, then the parser has already
9614 -- inserted an equivalent pragma Suppress (All_Checks) to get
9615 -- the required effect.
9617 when Pragma_Suppress_All
=>
9619 Check_Arg_Count
(0);
9621 if Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
9622 or else not Is_List_Member
(N
)
9623 or else List_Containing
(N
) /= Pragmas_After
(Parent
(N
))
9626 ("misplaced pragma%, must follow compilation unit");
9629 -------------------------
9630 -- Suppress_Debug_Info --
9631 -------------------------
9633 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
9635 when Pragma_Suppress_Debug_Info
=>
9637 Check_Arg_Count
(1);
9638 Check_Optional_Identifier
(Arg1
, Name_Entity
);
9639 Check_Arg_Is_Local_Name
(Arg1
);
9640 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
9642 ----------------------------------
9643 -- Suppress_Exception_Locations --
9644 ----------------------------------
9646 -- pragma Suppress_Exception_Locations;
9648 when Pragma_Suppress_Exception_Locations
=>
9650 Check_Arg_Count
(0);
9651 Check_Valid_Configuration_Pragma
;
9652 Exception_Locations_Suppressed
:= True;
9654 -----------------------------
9655 -- Suppress_Initialization --
9656 -----------------------------
9658 -- pragma Suppress_Initialization ([Entity =>] type_Name);
9660 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
9666 Check_Arg_Count
(1);
9667 Check_Optional_Identifier
(Arg1
, Name_Entity
);
9668 Check_Arg_Is_Local_Name
(Arg1
);
9670 E_Id
:= Expression
(Arg1
);
9672 if Etype
(E_Id
) = Any_Type
then
9679 if Is_Incomplete_Or_Private_Type
(E
) then
9680 if No
(Full_View
(Base_Type
(E
))) then
9682 ("argument of pragma% cannot be an incomplete type",
9685 Set_Suppress_Init_Proc
(Full_View
(Base_Type
(E
)));
9688 Set_Suppress_Init_Proc
(Base_Type
(E
));
9693 ("pragma% requires argument that is a type name", Arg1
);
9701 -- pragma System_Name (DIRECT_NAME);
9703 -- Syntax check: one argument, which must be the identifier GNAT
9704 -- or the identifier GCC, no other identifiers are acceptable.
9706 when Pragma_System_Name
=>
9707 Check_No_Identifiers
;
9708 Check_Arg_Count
(1);
9709 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
9711 -----------------------------
9712 -- Task_Dispatching_Policy --
9713 -----------------------------
9715 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
9717 when Pragma_Task_Dispatching_Policy
=> declare
9721 Check_Ada_83_Warning
;
9722 Check_Arg_Count
(1);
9723 Check_No_Identifiers
;
9724 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
9725 Check_Valid_Configuration_Pragma
;
9726 Get_Name_String
(Chars
(Expression
(Arg1
)));
9727 DP
:= Fold_Upper
(Name_Buffer
(1));
9729 if Task_Dispatching_Policy
/= ' '
9730 and then Task_Dispatching_Policy
/= DP
9732 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9734 ("task dispatching policy incompatible with policy#");
9736 -- Set new policy, but always preserve System_Location since
9737 -- we like the error message with the run time name.
9740 Task_Dispatching_Policy
:= DP
;
9742 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9743 Task_Dispatching_Policy_Sloc
:= Loc
;
9752 -- pragma Task_Info (EXPRESSION);
9754 when Pragma_Task_Info
=> Task_Info
: declare
9755 P
: constant Node_Id
:= Parent
(N
);
9760 if Nkind
(P
) /= N_Task_Definition
then
9761 Error_Pragma
("pragma% must appear in task definition");
9764 Check_No_Identifiers
;
9765 Check_Arg_Count
(1);
9767 Analyze_And_Resolve
(Expression
(Arg1
), RTE
(RE_Task_Info_Type
));
9769 if Etype
(Expression
(Arg1
)) = Any_Type
then
9773 if Has_Task_Info_Pragma
(P
) then
9774 Error_Pragma
("duplicate pragma% not allowed");
9776 Set_Has_Task_Info_Pragma
(P
, True);
9784 -- pragma Task_Name (string_EXPRESSION);
9786 when Pragma_Task_Name
=> Task_Name
: declare
9787 -- pragma Priority (EXPRESSION);
9789 P
: constant Node_Id
:= Parent
(N
);
9793 Check_No_Identifiers
;
9794 Check_Arg_Count
(1);
9796 Arg
:= Expression
(Arg1
);
9797 Analyze_And_Resolve
(Arg
, Standard_String
);
9799 if Nkind
(P
) /= N_Task_Definition
then
9803 if Has_Task_Name_Pragma
(P
) then
9804 Error_Pragma
("duplicate pragma% not allowed");
9806 Set_Has_Task_Name_Pragma
(P
, True);
9807 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
9815 -- pragma Task_Storage (
9816 -- [Task_Type =>] LOCAL_NAME,
9817 -- [Top_Guard =>] static_integer_EXPRESSION);
9819 when Pragma_Task_Storage
=> Task_Storage
: declare
9820 Args
: Args_List
(1 .. 2);
9821 Names
: constant Name_List
(1 .. 2) := (
9825 Task_Type
: Node_Id
renames Args
(1);
9826 Top_Guard
: Node_Id
renames Args
(2);
9832 Gather_Associations
(Names
, Args
);
9834 if No
(Task_Type
) then
9836 ("missing task_type argument for pragma%");
9839 Check_Arg_Is_Local_Name
(Task_Type
);
9841 Ent
:= Entity
(Task_Type
);
9843 if not Is_Task_Type
(Ent
) then
9845 ("argument for pragma% must be task type", Task_Type
);
9848 if No
(Top_Guard
) then
9850 ("pragma% takes two arguments", Task_Type
);
9852 Check_Arg_Is_Static_Expression
(Top_Guard
, Any_Integer
);
9855 Check_First_Subtype
(Task_Type
);
9857 if Rep_Item_Too_Late
(Ent
, N
) then
9866 -- pragma Thread_Body
9867 -- ( [Entity =>] LOCAL_NAME
9868 -- [,[Secondary_Stack_Size =>] static_integer_EXPRESSION]);
9870 when Pragma_Thread_Body
=> Thread_Body
: declare
9877 Check_Arg_Order
((Name_Entity
, Name_Secondary_Stack_Size
));
9878 Check_At_Least_N_Arguments
(1);
9879 Check_At_Most_N_Arguments
(2);
9880 Check_Optional_Identifier
(Arg1
, Name_Entity
);
9881 Check_Arg_Is_Local_Name
(Arg1
);
9883 Id
:= Expression
(Arg1
);
9885 if not Is_Entity_Name
(Id
)
9886 or else not Is_Subprogram
(Entity
(Id
))
9888 Error_Pragma_Arg
("subprogram name required", Arg1
);
9893 -- Go to renamed subprogram if present, since Thread_Body applies
9894 -- to the actual renamed entity, not to the renaming entity.
9896 if Present
(Alias
(E
))
9897 and then Nkind
(Parent
(Declaration_Node
(E
))) =
9898 N_Subprogram_Renaming_Declaration
9903 -- Various error checks
9905 if Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
then
9907 ("pragma% requires separate spec and must come before body");
9909 elsif Rep_Item_Too_Early
(E
, N
)
9911 Rep_Item_Too_Late
(E
, N
)
9915 elsif Is_Thread_Body
(E
) then
9917 ("only one thread body pragma allowed", Arg1
);
9919 elsif Present
(Homonym
(E
))
9920 and then Scope
(Homonym
(E
)) = Current_Scope
9923 ("thread body subprogram must not be overloaded", Arg1
);
9926 Set_Is_Thread_Body
(E
);
9928 -- Deal with secondary stack argument
9930 if Arg_Count
= 2 then
9931 Check_Optional_Identifier
(Arg2
, Name_Secondary_Stack_Size
);
9932 SS
:= Expression
(Arg2
);
9933 Analyze_And_Resolve
(SS
, Any_Integer
);
9941 -- pragma Time_Slice (static_duration_EXPRESSION);
9943 when Pragma_Time_Slice
=> Time_Slice
: declare
9949 Check_Arg_Count
(1);
9950 Check_No_Identifiers
;
9951 Check_In_Main_Program
;
9952 Check_Arg_Is_Static_Expression
(Arg1
, Standard_Duration
);
9954 if not Error_Posted
(Arg1
) then
9956 while Present
(Nod
) loop
9957 if Nkind
(Nod
) = N_Pragma
9958 and then Chars
(Nod
) = Name_Time_Slice
9960 Error_Msg_Name_1
:= Chars
(N
);
9961 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
9968 -- Process only if in main unit
9970 if Get_Source_Unit
(Loc
) = Main_Unit
then
9971 Opt
.Time_Slice_Set
:= True;
9972 Val
:= Expr_Value_R
(Expression
(Arg1
));
9974 if Val
<= Ureal_0
then
9975 Opt
.Time_Slice_Value
:= 0;
9977 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
9978 Opt
.Time_Slice_Value
:= 1_000_000_000
;
9981 Opt
.Time_Slice_Value
:=
9982 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
9991 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
9993 -- TITLING_OPTION ::=
9994 -- [Title =>] STRING_LITERAL
9995 -- | [Subtitle =>] STRING_LITERAL
9997 when Pragma_Title
=> Title
: declare
9998 Args
: Args_List
(1 .. 2);
9999 Names
: constant Name_List
(1 .. 2) := (
10005 Gather_Associations
(Names
, Args
);
10007 for J
in 1 .. 2 loop
10008 if Present
(Args
(J
)) then
10009 Check_Arg_Is_String_Literal
(Args
(J
));
10014 ---------------------
10015 -- Unchecked_Union --
10016 ---------------------
10018 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
10020 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
10021 Assoc
: constant Node_Id
:= Arg1
;
10022 Type_Id
: constant Node_Id
:= Expression
(Assoc
);
10033 Check_No_Identifiers
;
10034 Check_Arg_Count
(1);
10035 Check_Arg_Is_Local_Name
(Arg1
);
10037 Find_Type
(Type_Id
);
10038 Typ
:= Entity
(Type_Id
);
10041 or else Rep_Item_Too_Early
(Typ
, N
)
10045 Typ
:= Underlying_Type
(Typ
);
10048 if Rep_Item_Too_Late
(Typ
, N
) then
10052 Check_First_Subtype
(Arg1
);
10054 -- Note remaining cases are references to a type in the current
10055 -- declarative part. If we find an error, we post the error on
10056 -- the relevant type declaration at an appropriate point.
10058 if not Is_Record_Type
(Typ
) then
10059 Error_Msg_N
("Unchecked_Union must be record type", Typ
);
10062 elsif Is_Tagged_Type
(Typ
) then
10063 Error_Msg_N
("Unchecked_Union must not be tagged", Typ
);
10066 elsif Is_Limited_Type
(Typ
) then
10068 ("Unchecked_Union must not be limited record type", Typ
);
10069 Explain_Limited_Type
(Typ
, Typ
);
10073 if not Has_Discriminants
(Typ
) then
10075 ("Unchecked_Union must have one discriminant", Typ
);
10079 Discr
:= First_Discriminant
(Typ
);
10081 if Present
(Next_Discriminant
(Discr
)) then
10083 ("Unchecked_Union must have exactly one discriminant",
10084 Next_Discriminant
(Discr
));
10088 if No
(Discriminant_Default_Value
(Discr
)) then
10090 ("Unchecked_Union discriminant must have default value",
10094 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
10095 Clist
:= Component_List
(Tdef
);
10097 Comp
:= First
(Component_Items
(Clist
));
10098 while Present
(Comp
) loop
10100 Check_Component
(Comp
);
10105 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
10107 ("Unchecked_Union must have variant part",
10112 Vpart
:= Variant_Part
(Clist
);
10114 Variant
:= First
(Variants
(Vpart
));
10115 while Present
(Variant
) loop
10116 Check_Variant
(Variant
);
10121 Set_Is_Unchecked_Union
(Typ
, True);
10122 Set_Convention
(Typ
, Convention_C
);
10124 Set_Has_Unchecked_Union
(Base_Type
(Typ
), True);
10125 Set_Is_Unchecked_Union
(Base_Type
(Typ
), True);
10126 end Unchecked_Union
;
10128 ------------------------
10129 -- Unimplemented_Unit --
10130 ------------------------
10132 -- pragma Unimplemented_Unit;
10134 -- Note: this only gives an error if we are generating code,
10135 -- or if we are in a generic library unit (where the pragma
10136 -- appears in the body, not in the spec).
10138 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
10139 Cunitent
: constant Entity_Id
:=
10140 Cunit_Entity
(Get_Source_Unit
(Loc
));
10141 Ent_Kind
: constant Entity_Kind
:=
10146 Check_Arg_Count
(0);
10148 if Operating_Mode
= Generate_Code
10149 or else Ent_Kind
= E_Generic_Function
10150 or else Ent_Kind
= E_Generic_Procedure
10151 or else Ent_Kind
= E_Generic_Package
10153 Get_Name_String
(Chars
(Cunitent
));
10154 Set_Casing
(Mixed_Case
);
10155 Write_Str
(Name_Buffer
(1 .. Name_Len
));
10156 Write_Str
(" is not implemented");
10158 raise Unrecoverable_Error
;
10160 end Unimplemented_Unit
;
10162 --------------------
10163 -- Universal_Data --
10164 --------------------
10166 -- pragma Universal_Data [(library_unit_NAME)];
10168 when Pragma_Universal_Data
=>
10171 -- If this is a configuration pragma, then set the universal
10172 -- addressing option, otherwise confirm that the pragma
10173 -- satisfies the requirements of library unit pragma placement
10174 -- and leave it to the GNAAMP back end to detect the pragma
10175 -- (avoids transitive setting of the option due to withed units).
10177 if Is_Configuration_Pragma
then
10178 Universal_Addressing_On_AAMP
:= True;
10180 Check_Valid_Library_Unit_Pragma
;
10183 if not AAMP_On_Target
then
10184 Error_Pragma
("?pragma% ignored (applies only to AAMP)");
10191 -- pragma Unreferenced (local_Name {, local_Name});
10193 when Pragma_Unreferenced
=> Unreferenced
: declare
10194 Arg_Node
: Node_Id
;
10195 Arg_Expr
: Node_Id
;
10196 Arg_Ent
: Entity_Id
;
10200 Check_At_Least_N_Arguments
(1);
10203 while Present
(Arg_Node
) loop
10204 Check_No_Identifier
(Arg_Node
);
10206 -- Note that the analyze call done by Check_Arg_Is_Local_Name
10207 -- will in fact generate a reference, so that the entity will
10208 -- have a reference, which will inhibit any warnings about it
10209 -- not being referenced, and also properly show up in the ali
10210 -- file as a reference. But this reference is recorded before
10211 -- the Has_Pragma_Unreferenced flag is set, so that no warning
10212 -- is generated for this reference.
10214 Check_Arg_Is_Local_Name
(Arg_Node
);
10215 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
10217 if Is_Entity_Name
(Arg_Expr
) then
10218 Arg_Ent
:= Entity
(Arg_Expr
);
10220 -- If the entity is overloaded, the pragma applies to the
10221 -- most recent overloading, as documented. In this case,
10222 -- name resolution does not generate a reference, so it
10223 -- must be done here explicitly.
10225 if Is_Overloaded
(Arg_Expr
) then
10226 Generate_Reference
(Arg_Ent
, N
);
10229 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
10236 ------------------------------
10237 -- Unreserve_All_Interrupts --
10238 ------------------------------
10240 -- pragma Unreserve_All_Interrupts;
10242 when Pragma_Unreserve_All_Interrupts
=>
10244 Check_Arg_Count
(0);
10246 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
10247 Unreserve_All_Interrupts
:= True;
10254 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
10256 when Pragma_Unsuppress
=>
10258 Process_Suppress_Unsuppress
(False);
10260 -------------------
10261 -- Use_VADS_Size --
10262 -------------------
10264 -- pragma Use_VADS_Size;
10266 when Pragma_Use_VADS_Size
=>
10268 Check_Arg_Count
(0);
10269 Check_Valid_Configuration_Pragma
;
10270 Use_VADS_Size
:= True;
10272 ---------------------
10273 -- Validity_Checks --
10274 ---------------------
10276 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
10278 when Pragma_Validity_Checks
=> Validity_Checks
: declare
10279 A
: constant Node_Id
:= Expression
(Arg1
);
10285 Check_Arg_Count
(1);
10286 Check_No_Identifiers
;
10288 if Nkind
(A
) = N_String_Literal
then
10292 Slen
: constant Natural := Natural (String_Length
(S
));
10293 Options
: String (1 .. Slen
);
10299 C
:= Get_String_Char
(S
, Int
(J
));
10300 exit when not In_Character_Range
(C
);
10301 Options
(J
) := Get_Character
(C
);
10304 Set_Validity_Check_Options
(Options
);
10312 elsif Nkind
(A
) = N_Identifier
then
10314 if Chars
(A
) = Name_All_Checks
then
10315 Set_Validity_Check_Options
("a");
10317 elsif Chars
(A
) = Name_On
then
10318 Validity_Checks_On
:= True;
10320 elsif Chars
(A
) = Name_Off
then
10321 Validity_Checks_On
:= False;
10325 end Validity_Checks
;
10331 -- pragma Volatile (LOCAL_NAME);
10333 when Pragma_Volatile
=>
10334 Process_Atomic_Shared_Volatile
;
10336 -------------------------
10337 -- Volatile_Components --
10338 -------------------------
10340 -- pragma Volatile_Components (array_LOCAL_NAME);
10342 -- Volatile is handled by the same circuit as Atomic_Components
10348 -- pragma Warnings (On | Off, [LOCAL_NAME])
10350 when Pragma_Warnings
=> Warnings
: begin
10352 Check_At_Least_N_Arguments
(1);
10353 Check_At_Most_N_Arguments
(2);
10354 Check_No_Identifiers
;
10356 -- One argument case was processed by parser in Par.Prag
10358 if Arg_Count
/= 1 then
10359 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
10360 Check_Arg_Count
(2);
10367 E_Id
:= Expression
(Arg2
);
10370 -- In the expansion of an inlined body, a reference to
10371 -- the formal may be wrapped in a conversion if the actual
10372 -- is a conversion. Retrieve the real entity name.
10374 if (In_Instance_Body
10375 or else In_Inlined_Body
)
10376 and then Nkind
(E_Id
) = N_Unchecked_Type_Conversion
10378 E_Id
:= Expression
(E_Id
);
10381 if not Is_Entity_Name
(E_Id
) then
10383 ("second argument of pragma% must be entity name",
10387 E
:= Entity
(E_Id
);
10393 Set_Warnings_Off
(E
,
10394 (Chars
(Expression
(Arg1
)) = Name_Off
));
10396 if Is_Enumeration_Type
(E
) then
10400 Lit
:= First_Literal
(E
);
10401 while Present
(Lit
) loop
10402 Set_Warnings_Off
(Lit
);
10403 Next_Literal
(Lit
);
10408 exit when No
(Homonym
(E
));
10416 -------------------
10417 -- Weak_External --
10418 -------------------
10420 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
10422 when Pragma_Weak_External
=> Weak_External
: declare
10427 Check_Arg_Count
(1);
10428 Check_Optional_Identifier
(Arg1
, Name_Entity
);
10429 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
10430 Ent
:= Entity
(Expression
(Arg1
));
10432 if Rep_Item_Too_Early
(Ent
, N
) then
10435 Ent
:= Underlying_Type
(Ent
);
10438 -- The only processing required is to link this item on to the
10439 -- list of rep items for the given entity. This is accomplished
10440 -- by the call to Rep_Item_Too_Late (when no error is detected
10441 -- and False is returned).
10443 if Rep_Item_Too_Late
(Ent
, N
) then
10446 Set_Has_Gigi_Rep_Item
(Ent
);
10450 --------------------
10451 -- Unknown_Pragma --
10452 --------------------
10454 -- Should be impossible, since the case of an unknown pragma is
10455 -- separately processed before the case statement is entered.
10457 when Unknown_Pragma
=>
10458 raise Program_Error
;
10462 when Pragma_Exit
=> null;
10463 end Analyze_Pragma
;
10465 ---------------------------------
10466 -- Delay_Config_Pragma_Analyze --
10467 ---------------------------------
10469 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
10471 return Chars
(N
) = Name_Interrupt_State
;
10472 end Delay_Config_Pragma_Analyze
;
10474 -------------------------
10475 -- Get_Base_Subprogram --
10476 -------------------------
10478 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
10479 Result
: Entity_Id
;
10482 -- Follow subprogram renaming chain
10485 while Is_Subprogram
(Result
)
10487 (Is_Generic_Instance
(Result
)
10488 or else Nkind
(Parent
(Declaration_Node
(Result
))) =
10489 N_Subprogram_Renaming_Declaration
)
10490 and then Present
(Alias
(Result
))
10492 Result
:= Alias
(Result
);
10496 end Get_Base_Subprogram
;
10498 -----------------------------
10499 -- Is_Config_Static_String --
10500 -----------------------------
10502 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
10504 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
10505 -- This is an internal recursive function that is just like the
10506 -- outer function except that it adds the string to the name buffer
10507 -- rather than placing the string in the name buffer.
10509 ------------------------------
10510 -- Add_Config_Static_String --
10511 ------------------------------
10513 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
10520 if Nkind
(N
) = N_Op_Concat
then
10521 if Add_Config_Static_String
(Left_Opnd
(N
)) then
10522 N
:= Right_Opnd
(N
);
10528 if Nkind
(N
) /= N_String_Literal
then
10529 Error_Msg_N
("string literal expected for pragma argument", N
);
10533 for J
in 1 .. String_Length
(Strval
(N
)) loop
10534 C
:= Get_String_Char
(Strval
(N
), J
);
10536 if not In_Character_Range
(C
) then
10538 ("string literal contains invalid wide character",
10539 Sloc
(N
) + 1 + Source_Ptr
(J
));
10543 Add_Char_To_Name_Buffer
(Get_Character
(C
));
10548 end Add_Config_Static_String
;
10550 -- Start of prorcessing for Is_Config_Static_String
10555 return Add_Config_Static_String
(Arg
);
10556 end Is_Config_Static_String
;
10558 -----------------------------------------
10559 -- Is_Non_Significant_Pragma_Reference --
10560 -----------------------------------------
10562 -- This function makes use of the following static table which indicates
10563 -- whether a given pragma is significant. A value of -1 in this table
10564 -- indicates that the reference is significant. A value of zero indicates
10565 -- than appearence as any argument is insignificant, a positive value
10566 -- indicates that appearence in that parameter position is significant.
10568 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
10570 (Pragma_AST_Entry
=> -1,
10571 Pragma_Abort_Defer
=> -1,
10572 Pragma_Ada_83
=> -1,
10573 Pragma_Ada_95
=> -1,
10574 Pragma_Ada_05
=> -1,
10575 Pragma_All_Calls_Remote
=> -1,
10576 Pragma_Annotate
=> -1,
10577 Pragma_Assert
=> -1,
10578 Pragma_Assertion_Policy
=> 0,
10579 Pragma_Asynchronous
=> -1,
10580 Pragma_Atomic
=> 0,
10581 Pragma_Atomic_Components
=> 0,
10582 Pragma_Attach_Handler
=> -1,
10583 Pragma_CPP_Class
=> 0,
10584 Pragma_CPP_Constructor
=> 0,
10585 Pragma_CPP_Virtual
=> 0,
10586 Pragma_CPP_Vtable
=> 0,
10587 Pragma_C_Pass_By_Copy
=> 0,
10588 Pragma_Comment
=> 0,
10589 Pragma_Common_Object
=> -1,
10590 Pragma_Compile_Time_Warning
=> -1,
10591 Pragma_Complex_Representation
=> 0,
10592 Pragma_Component_Alignment
=> -1,
10593 Pragma_Controlled
=> 0,
10594 Pragma_Convention
=> 0,
10595 Pragma_Convention_Identifier
=> 0,
10596 Pragma_Debug
=> -1,
10597 Pragma_Debug_Policy
=> 0,
10598 Pragma_Detect_Blocking
=> -1,
10599 Pragma_Discard_Names
=> 0,
10600 Pragma_Elaborate
=> -1,
10601 Pragma_Elaborate_All
=> -1,
10602 Pragma_Elaborate_Body
=> -1,
10603 Pragma_Elaboration_Checks
=> -1,
10604 Pragma_Eliminate
=> -1,
10605 Pragma_Explicit_Overriding
=> -1,
10606 Pragma_Export
=> -1,
10607 Pragma_Export_Exception
=> -1,
10608 Pragma_Export_Function
=> -1,
10609 Pragma_Export_Object
=> -1,
10610 Pragma_Export_Procedure
=> -1,
10611 Pragma_Export_Value
=> -1,
10612 Pragma_Export_Valued_Procedure
=> -1,
10613 Pragma_Extend_System
=> -1,
10614 Pragma_Extensions_Allowed
=> -1,
10615 Pragma_External
=> -1,
10616 Pragma_External_Name_Casing
=> -1,
10617 Pragma_Finalize_Storage_Only
=> 0,
10618 Pragma_Float_Representation
=> 0,
10619 Pragma_Ident
=> -1,
10620 Pragma_Import
=> +2,
10621 Pragma_Import_Exception
=> 0,
10622 Pragma_Import_Function
=> 0,
10623 Pragma_Import_Object
=> 0,
10624 Pragma_Import_Procedure
=> 0,
10625 Pragma_Import_Valued_Procedure
=> 0,
10626 Pragma_Initialize_Scalars
=> -1,
10627 Pragma_Inline
=> 0,
10628 Pragma_Inline_Always
=> 0,
10629 Pragma_Inline_Generic
=> 0,
10630 Pragma_Inspection_Point
=> -1,
10631 Pragma_Interface
=> +2,
10632 Pragma_Interface_Name
=> +2,
10633 Pragma_Interrupt_Handler
=> -1,
10634 Pragma_Interrupt_Priority
=> -1,
10635 Pragma_Interrupt_State
=> -1,
10636 Pragma_Java_Constructor
=> -1,
10637 Pragma_Java_Interface
=> -1,
10638 Pragma_Keep_Names
=> 0,
10639 Pragma_License
=> -1,
10640 Pragma_Link_With
=> -1,
10641 Pragma_Linker_Alias
=> -1,
10642 Pragma_Linker_Constructor
=> -1,
10643 Pragma_Linker_Destructor
=> -1,
10644 Pragma_Linker_Options
=> -1,
10645 Pragma_Linker_Section
=> -1,
10647 Pragma_Locking_Policy
=> -1,
10648 Pragma_Long_Float
=> -1,
10649 Pragma_Machine_Attribute
=> -1,
10651 Pragma_Main_Storage
=> -1,
10652 Pragma_Memory_Size
=> -1,
10653 Pragma_No_Return
=> 0,
10654 Pragma_No_Run_Time
=> -1,
10655 Pragma_No_Strict_Aliasing
=> -1,
10656 Pragma_Normalize_Scalars
=> -1,
10657 Pragma_Obsolescent
=> 0,
10658 Pragma_Optimize
=> -1,
10659 Pragma_Optional_Overriding
=> -1,
10662 Pragma_Passive
=> -1,
10663 Pragma_Polling
=> -1,
10664 Pragma_Persistent_BSS
=> 0,
10665 Pragma_Preelaborate
=> -1,
10666 Pragma_Preelaborate_05
=> -1,
10667 Pragma_Priority
=> -1,
10668 Pragma_Profile
=> 0,
10669 Pragma_Profile_Warnings
=> 0,
10670 Pragma_Propagate_Exceptions
=> -1,
10671 Pragma_Psect_Object
=> -1,
10673 Pragma_Pure_05
=> -1,
10674 Pragma_Pure_Function
=> -1,
10675 Pragma_Queuing_Policy
=> -1,
10676 Pragma_Ravenscar
=> -1,
10677 Pragma_Remote_Call_Interface
=> -1,
10678 Pragma_Remote_Types
=> -1,
10679 Pragma_Restricted_Run_Time
=> -1,
10680 Pragma_Restriction_Warnings
=> -1,
10681 Pragma_Restrictions
=> -1,
10682 Pragma_Reviewable
=> -1,
10683 Pragma_Share_Generic
=> -1,
10684 Pragma_Shared
=> -1,
10685 Pragma_Shared_Passive
=> -1,
10686 Pragma_Source_File_Name
=> -1,
10687 Pragma_Source_File_Name_Project
=> -1,
10688 Pragma_Source_Reference
=> -1,
10689 Pragma_Storage_Size
=> -1,
10690 Pragma_Storage_Unit
=> -1,
10691 Pragma_Stream_Convert
=> -1,
10692 Pragma_Style_Checks
=> -1,
10693 Pragma_Subtitle
=> -1,
10694 Pragma_Suppress
=> 0,
10695 Pragma_Suppress_Exception_Locations
=> 0,
10696 Pragma_Suppress_All
=> -1,
10697 Pragma_Suppress_Debug_Info
=> 0,
10698 Pragma_Suppress_Initialization
=> 0,
10699 Pragma_System_Name
=> -1,
10700 Pragma_Task_Dispatching_Policy
=> -1,
10701 Pragma_Task_Info
=> -1,
10702 Pragma_Task_Name
=> -1,
10703 Pragma_Task_Storage
=> 0,
10704 Pragma_Thread_Body
=> +2,
10705 Pragma_Time_Slice
=> -1,
10706 Pragma_Title
=> -1,
10707 Pragma_Unchecked_Union
=> 0,
10708 Pragma_Unimplemented_Unit
=> -1,
10709 Pragma_Universal_Data
=> -1,
10710 Pragma_Unreferenced
=> -1,
10711 Pragma_Unreserve_All_Interrupts
=> -1,
10712 Pragma_Unsuppress
=> 0,
10713 Pragma_Use_VADS_Size
=> -1,
10714 Pragma_Validity_Checks
=> -1,
10715 Pragma_Volatile
=> 0,
10716 Pragma_Volatile_Components
=> 0,
10717 Pragma_Warnings
=> -1,
10718 Pragma_Weak_External
=> 0,
10719 Unknown_Pragma
=> 0);
10721 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
10729 if Nkind
(P
) /= N_Pragma_Argument_Association
then
10733 C
:= Sig_Flags
(Get_Pragma_Id
(Chars
(Parent
(P
))));
10743 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
10744 for J
in 1 .. C
- 1 loop
10755 end Is_Non_Significant_Pragma_Reference
;
10757 ------------------------------
10758 -- Is_Pragma_String_Literal --
10759 ------------------------------
10761 -- This function returns true if the corresponding pragma argument is
10762 -- a static string expression. These are the only cases in which string
10763 -- literals can appear as pragma arguments. We also allow a string
10764 -- literal as the first argument to pragma Assert (although it will
10765 -- of course always generate a type error).
10767 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
10768 Pragn
: constant Node_Id
:= Parent
(Par
);
10769 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
10770 Pname
: constant Name_Id
:= Chars
(Pragn
);
10776 N
:= First
(Assoc
);
10783 if Pname
= Name_Assert
then
10786 elsif Pname
= Name_Export
then
10789 elsif Pname
= Name_Ident
then
10792 elsif Pname
= Name_Import
then
10795 elsif Pname
= Name_Interface_Name
then
10798 elsif Pname
= Name_Linker_Alias
then
10801 elsif Pname
= Name_Linker_Section
then
10804 elsif Pname
= Name_Machine_Attribute
then
10807 elsif Pname
= Name_Source_File_Name
then
10810 elsif Pname
= Name_Source_Reference
then
10813 elsif Pname
= Name_Title
then
10816 elsif Pname
= Name_Subtitle
then
10822 end Is_Pragma_String_Literal
;
10824 --------------------------------------
10825 -- Process_Compilation_Unit_Pragmas --
10826 --------------------------------------
10828 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
10830 -- A special check for pragma Suppress_All. This is a strange DEC
10831 -- pragma, strange because it comes at the end of the unit. If we
10832 -- have a pragma Suppress_All in the Pragmas_After of the current
10833 -- unit, then we insert a pragma Suppress (All_Checks) at the start
10834 -- of the context clause to ensure the correct processing.
10837 PA
: constant List_Id
:= Pragmas_After
(Aux_Decls_Node
(N
));
10841 if Present
(PA
) then
10843 while Present
(P
) loop
10844 if Chars
(P
) = Name_Suppress_All
then
10845 Prepend_To
(Context_Items
(N
),
10846 Make_Pragma
(Sloc
(P
),
10847 Chars
=> Name_Suppress
,
10848 Pragma_Argument_Associations
=> New_List
(
10849 Make_Pragma_Argument_Association
(Sloc
(P
),
10851 Make_Identifier
(Sloc
(P
),
10852 Chars
=> Name_All_Checks
)))));
10860 end Process_Compilation_Unit_Pragmas
;
10862 --------------------------------
10863 -- Set_Encoded_Interface_Name --
10864 --------------------------------
10866 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
10867 Str
: constant String_Id
:= Strval
(S
);
10868 Len
: constant Int
:= String_Length
(Str
);
10873 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
10876 -- Stores encoded value of character code CC. The encoding we
10877 -- use an underscore followed by four lower case hex digits.
10883 procedure Encode
is
10885 Store_String_Char
(Get_Char_Code
('_'));
10887 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
10889 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
10891 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
10893 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
10896 -- Start of processing for Set_Encoded_Interface_Name
10899 -- If first character is asterisk, this is a link name, and we
10900 -- leave it completely unmodified. We also ignore null strings
10901 -- (the latter case happens only in error cases) and no encoding
10902 -- should occur for Java interface names.
10905 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
10908 Set_Interface_Name
(E
, S
);
10913 CC
:= Get_String_Char
(Str
, J
);
10915 exit when not In_Character_Range
(CC
);
10917 C
:= Get_Character
(CC
);
10919 exit when C
/= '_' and then C
/= '$'
10920 and then C
not in '0' .. '9'
10921 and then C
not in 'a' .. 'z'
10922 and then C
not in 'A' .. 'Z';
10925 Set_Interface_Name
(E
, S
);
10933 -- Here we need to encode. The encoding we use as follows:
10934 -- three underscores + four hex digits (lower case)
10938 for J
in 1 .. String_Length
(Str
) loop
10939 CC
:= Get_String_Char
(Str
, J
);
10941 if not In_Character_Range
(CC
) then
10944 C
:= Get_Character
(CC
);
10946 if C
= '_' or else C
= '$'
10947 or else C
in '0' .. '9'
10948 or else C
in 'a' .. 'z'
10949 or else C
in 'A' .. 'Z'
10951 Store_String_Char
(CC
);
10958 Set_Interface_Name
(E
,
10959 Make_String_Literal
(Sloc
(S
),
10960 Strval
=> End_String
));
10962 end Set_Encoded_Interface_Name
;
10964 -------------------
10965 -- Set_Unit_Name --
10966 -------------------
10968 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
10973 if Nkind
(N
) = N_Identifier
10974 and then Nkind
(With_Item
) = N_Identifier
10976 Set_Entity
(N
, Entity
(With_Item
));
10978 elsif Nkind
(N
) = N_Selected_Component
then
10979 Change_Selected_Component_To_Expanded_Name
(N
);
10980 Set_Entity
(N
, Entity
(With_Item
));
10981 Set_Entity
(Selector_Name
(N
), Entity
(N
));
10983 Pref
:= Prefix
(N
);
10984 Scop
:= Scope
(Entity
(N
));
10985 while Nkind
(Pref
) = N_Selected_Component
loop
10986 Change_Selected_Component_To_Expanded_Name
(Pref
);
10987 Set_Entity
(Selector_Name
(Pref
), Scop
);
10988 Set_Entity
(Pref
, Scop
);
10989 Pref
:= Prefix
(Pref
);
10990 Scop
:= Scope
(Scop
);
10993 Set_Entity
(Pref
, Scop
);