1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects
; use Aspects
;
33 with Atree
; use Atree
;
34 with Casing
; use Casing
;
35 with Checks
; use Checks
;
36 with Csets
; use Csets
;
37 with Debug
; use Debug
;
38 with Einfo
; use Einfo
;
39 with Elists
; use Elists
;
40 with Errout
; use Errout
;
41 with Exp_Dist
; use Exp_Dist
;
42 with Exp_Util
; use Exp_Util
;
43 with Freeze
; use Freeze
;
45 with Lib
.Writ
; use Lib
.Writ
;
46 with Lib
.Xref
; use Lib
.Xref
;
47 with Namet
.Sp
; use Namet
.Sp
;
48 with Nlists
; use Nlists
;
49 with Nmake
; use Nmake
;
51 with Output
; use Output
;
52 with Par_SCO
; use Par_SCO
;
53 with Restrict
; use Restrict
;
54 with Rident
; use Rident
;
55 with Rtsfind
; use Rtsfind
;
57 with Sem_Aux
; use Sem_Aux
;
58 with Sem_Ch3
; use Sem_Ch3
;
59 with Sem_Ch6
; use Sem_Ch6
;
60 with Sem_Ch8
; use Sem_Ch8
;
61 with Sem_Ch12
; use Sem_Ch12
;
62 with Sem_Ch13
; use Sem_Ch13
;
63 with Sem_Disp
; use Sem_Disp
;
64 with Sem_Dist
; use Sem_Dist
;
65 with Sem_Elim
; use Sem_Elim
;
66 with Sem_Eval
; use Sem_Eval
;
67 with Sem_Intr
; use Sem_Intr
;
68 with Sem_Mech
; use Sem_Mech
;
69 with Sem_Res
; use Sem_Res
;
70 with Sem_Type
; use Sem_Type
;
71 with Sem_Util
; use Sem_Util
;
72 with Sem_VFpt
; use Sem_VFpt
;
73 with Sem_Warn
; use Sem_Warn
;
74 with Stand
; use Stand
;
75 with Sinfo
; use Sinfo
;
76 with Sinfo
.CN
; use Sinfo
.CN
;
77 with Sinput
; use Sinput
;
78 with Snames
; use Snames
;
79 with Stringt
; use Stringt
;
80 with Stylesw
; use Stylesw
;
82 with Targparm
; use Targparm
;
83 with Tbuild
; use Tbuild
;
85 with Uintp
; use Uintp
;
86 with Uname
; use Uname
;
87 with Urealp
; use Urealp
;
88 with Validsw
; use Validsw
;
89 with Warnsw
; use Warnsw
;
91 package body Sem_Prag
is
93 ----------------------------------------------
94 -- Common Handling of Import-Export Pragmas --
95 ----------------------------------------------
97 -- In the following section, a number of Import_xxx and Export_xxx pragmas
98 -- are defined by GNAT. These are compatible with the DEC pragmas of the
99 -- same name, and all have the following common form and processing:
102 -- [Internal =>] LOCAL_NAME
103 -- [, [External =>] EXTERNAL_SYMBOL]
104 -- [, other optional parameters ]);
107 -- [Internal =>] LOCAL_NAME
108 -- [, [External =>] EXTERNAL_SYMBOL]
109 -- [, other optional parameters ]);
111 -- EXTERNAL_SYMBOL ::=
113 -- | static_string_EXPRESSION
115 -- The internal LOCAL_NAME designates the entity that is imported or
116 -- exported, and must refer to an entity in the current declarative
117 -- part (as required by the rules for LOCAL_NAME).
119 -- The external linker name is designated by the External parameter if
120 -- given, or the Internal parameter if not (if there is no External
121 -- parameter, the External parameter is a copy of the Internal name).
123 -- If the External parameter is given as a string, then this string is
124 -- treated as an external name (exactly as though it had been given as an
125 -- External_Name parameter for a normal Import pragma).
127 -- If the External parameter is given as an identifier (or there is no
128 -- External parameter, so that the Internal identifier is used), then
129 -- the external name is the characters of the identifier, translated
130 -- to all upper case letters for OpenVMS versions of GNAT, and to all
131 -- lower case letters for all other versions
133 -- Note: the external name specified or implied by any of these special
134 -- Import_xxx or Export_xxx pragmas override an external or link name
135 -- specified in a previous Import or Export pragma.
137 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
138 -- named notation, following the standard rules for subprogram calls, i.e.
139 -- parameters can be given in any order if named notation is used, and
140 -- positional and named notation can be mixed, subject to the rule that all
141 -- positional parameters must appear first.
143 -- Note: All these pragmas are implemented exactly following the DEC design
144 -- and implementation and are intended to be fully compatible with the use
145 -- of these pragmas in the DEC Ada compiler.
147 --------------------------------------------
148 -- Checking for Duplicated External Names --
149 --------------------------------------------
151 -- It is suspicious if two separate Export pragmas use the same external
152 -- name. The following table is used to diagnose this situation so that
153 -- an appropriate warning can be issued.
155 -- The Node_Id stored is for the N_String_Literal node created to hold
156 -- the value of the external name. The Sloc of this node is used to
157 -- cross-reference the location of the duplication.
159 package Externals
is new Table
.Table
(
160 Table_Component_Type
=> Node_Id
,
161 Table_Index_Type
=> Int
,
162 Table_Low_Bound
=> 0,
163 Table_Initial
=> 100,
164 Table_Increment
=> 100,
165 Table_Name
=> "Name_Externals");
167 -------------------------------------
168 -- Local Subprograms and Variables --
169 -------------------------------------
171 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
172 -- This routine is used for possible casing adjustment of an explicit
173 -- external name supplied as a string literal (the node N), according to
174 -- the casing requirement of Opt.External_Name_Casing. If this is set to
175 -- As_Is, then the string literal is returned unchanged, but if it is set
176 -- to Uppercase or Lowercase, then a new string literal with appropriate
177 -- casing is constructed.
179 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
180 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
181 -- original one, following the renaming chain) is returned. Otherwise the
182 -- entity is returned unchanged. Should be in Einfo???
184 procedure Preanalyze_TC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
);
185 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
186 -- of a Test_Case pragma if present (possibly Empty). We treat these as
187 -- spec expressions (i.e. similar to a default expression).
190 -- This is a dummy function called by the processing for pragma Reviewable.
191 -- It is there for assisting front end debugging. By placing a Reviewable
192 -- pragma in the source program, a breakpoint on rv catches this place in
193 -- the source, allowing convenient stepping to the point of interest.
195 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
196 -- Place semantic information on the argument of an Elaborate/Elaborate_All
197 -- pragma. Entity name for unit and its parents is taken from item in
198 -- previous with_clause that mentions the unit.
200 -------------------------------
201 -- Adjust_External_Name_Case --
202 -------------------------------
204 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
208 -- Adjust case of literal if required
210 if Opt
.External_Name_Exp_Casing
= As_Is
then
214 -- Copy existing string
220 for J
in 1 .. String_Length
(Strval
(N
)) loop
221 CC
:= Get_String_Char
(Strval
(N
), J
);
223 if Opt
.External_Name_Exp_Casing
= Uppercase
224 and then CC
>= Get_Char_Code
('a')
225 and then CC
<= Get_Char_Code
('z')
227 Store_String_Char
(CC
- 32);
229 elsif Opt
.External_Name_Exp_Casing
= Lowercase
230 and then CC
>= Get_Char_Code
('A')
231 and then CC
<= Get_Char_Code
('Z')
233 Store_String_Char
(CC
+ 32);
236 Store_String_Char
(CC
);
241 Make_String_Literal
(Sloc
(N
),
242 Strval
=> End_String
);
244 end Adjust_External_Name_Case
;
246 ------------------------------
247 -- Analyze_PPC_In_Decl_Part --
248 ------------------------------
250 procedure Analyze_PPC_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
251 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
254 -- Install formals and push subprogram spec onto scope stack so that we
255 -- can see the formals from the pragma.
260 -- Preanalyze the boolean expression, we treat this as a spec expression
261 -- (i.e. similar to a default expression).
263 Preanalyze_Spec_Expression
(Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
265 -- In ASIS mode, for a pragma generated from a source aspect, also
266 -- analyze the original aspect expression.
269 and then Present
(Corresponding_Aspect
(N
))
271 Preanalyze_Spec_Expression
272 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
275 -- For a class-wide condition, a reference to a controlling formal must
276 -- be interpreted as having the class-wide type (or an access to such)
277 -- so that the inherited condition can be properly applied to any
278 -- overriding operation (see ARM12 6.6.1 (7)).
280 if Class_Present
(N
) then
282 T
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
284 ACW
: Entity_Id
:= Empty
;
285 -- Access to T'class, created if there is a controlling formal
286 -- that is an access parameter.
288 function Get_ACW
return Entity_Id
;
289 -- If the expression has a reference to an controlling access
290 -- parameter, create an access to T'class for the necessary
291 -- conversions if one does not exist.
293 function Process
(N
: Node_Id
) return Traverse_Result
;
294 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
295 -- aspect for a primitive subprogram of a tagged type T, a name
296 -- that denotes a formal parameter of type T is interpreted as
297 -- having type T'Class. Similarly, a name that denotes a formal
298 -- accessparameter of type access-to-T is interpreted as having
299 -- type access-to-T'Class. This ensures the expression is well-
300 -- defined for a primitive subprogram of a type descended from T.
306 function Get_ACW
return Entity_Id
is
307 Loc
: constant Source_Ptr
:= Sloc
(N
);
312 Decl
:= Make_Full_Type_Declaration
(Loc
,
313 Defining_Identifier
=> Make_Temporary
(Loc
, 'T'),
315 Make_Access_To_Object_Definition
(Loc
,
316 Subtype_Indication
=>
317 New_Occurrence_Of
(Class_Wide_Type
(T
), Loc
),
318 All_Present
=> True));
320 Insert_Before
(Unit_Declaration_Node
(S
), Decl
);
322 ACW
:= Defining_Identifier
(Decl
);
323 Freeze_Before
(Unit_Declaration_Node
(S
), ACW
);
333 function Process
(N
: Node_Id
) return Traverse_Result
is
334 Loc
: constant Source_Ptr
:= Sloc
(N
);
338 if Is_Entity_Name
(N
)
339 and then Is_Formal
(Entity
(N
))
340 and then Nkind
(Parent
(N
)) /= N_Type_Conversion
342 if Etype
(Entity
(N
)) = T
then
343 Typ
:= Class_Wide_Type
(T
);
345 elsif Is_Access_Type
(Etype
(Entity
(N
)))
346 and then Designated_Type
(Etype
(Entity
(N
))) = T
353 if Present
(Typ
) then
355 Make_Type_Conversion
(Loc
,
357 New_Occurrence_Of
(Typ
, Loc
),
358 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
366 procedure Replace_Type
is new Traverse_Proc
(Process
);
369 Replace_Type
(Get_Pragma_Arg
(Arg1
));
373 -- Remove the subprogram from the scope stack now that the pre-analysis
374 -- of the precondition/postcondition is done.
377 end Analyze_PPC_In_Decl_Part
;
383 procedure Analyze_Pragma
(N
: Node_Id
) is
384 Loc
: constant Source_Ptr
:= Sloc
(N
);
388 -- Name of the source pragma, or name of the corresponding aspect for
389 -- pragmas which originate in a source aspect. In the latter case, the
390 -- name may be different from the pragma name.
392 Pragma_Exit
: exception;
393 -- This exception is used to exit pragma processing completely. It is
394 -- used when an error is detected, and no further processing is
395 -- required. It is also used if an earlier error has left the tree in
396 -- a state where the pragma should not be processed.
399 -- Number of pragma argument associations
405 -- First four pragma arguments (pragma argument association nodes, or
406 -- Empty if the corresponding argument does not exist).
408 type Name_List
is array (Natural range <>) of Name_Id
;
409 type Args_List
is array (Natural range <>) of Node_Id
;
410 -- Types used for arguments to Check_Arg_Order and Gather_Associations
412 procedure Ada_2005_Pragma
;
413 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
414 -- Ada 95 mode, these are implementation defined pragmas, so should be
415 -- caught by the No_Implementation_Pragmas restriction.
417 procedure Ada_2012_Pragma
;
418 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
419 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
420 -- should be caught by the No_Implementation_Pragmas restriction.
422 procedure Check_Ada_83_Warning
;
423 -- Issues a warning message for the current pragma if operating in Ada
424 -- 83 mode (used for language pragmas that are not a standard part of
425 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
428 procedure Check_Arg_Count
(Required
: Nat
);
429 -- Check argument count for pragma is equal to given parameter. If not,
430 -- then issue an error message and raise Pragma_Exit.
432 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
433 -- Arg which can either be a pragma argument association, in which case
434 -- the check is applied to the expression of the association or an
435 -- expression directly.
437 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
438 -- Check that an argument has the right form for an EXTERNAL_NAME
439 -- parameter of an extended import/export pragma. The rule is that the
440 -- name must be an identifier or string literal (in Ada 83 mode) or a
441 -- static string expression (in Ada 95 mode).
443 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
444 -- Check the specified argument Arg to make sure that it is an
445 -- identifier. If not give error and raise Pragma_Exit.
447 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
448 -- Check the specified argument Arg to make sure that it is an integer
449 -- literal. If not give error and raise Pragma_Exit.
451 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
452 -- Check the specified argument Arg to make sure that it has the proper
453 -- syntactic form for a local name and meets the semantic requirements
454 -- for a local name. The local name is analyzed as part of the
455 -- processing for this call. In addition, the local name is required
456 -- to represent an entity at the library level.
458 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
459 -- Check the specified argument Arg to make sure that it has the proper
460 -- syntactic form for a local name and meets the semantic requirements
461 -- for a local name. The local name is analyzed as part of the
462 -- processing for this call.
464 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
465 -- Check the specified argument Arg to make sure that it is a valid
466 -- locking policy name. If not give error and raise Pragma_Exit.
468 procedure Check_Arg_Is_One_Of
471 procedure Check_Arg_Is_One_Of
473 N1
, N2
, N3
: Name_Id
);
474 procedure Check_Arg_Is_One_Of
476 N1
, N2
, N3
, N4
, N5
: Name_Id
);
477 -- Check the specified argument Arg to make sure that it is an
478 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
479 -- present). If not then give error and raise Pragma_Exit.
481 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
482 -- Check the specified argument Arg to make sure that it is a valid
483 -- queuing policy name. If not give error and raise Pragma_Exit.
485 procedure Check_Arg_Is_Static_Expression
487 Typ
: Entity_Id
:= Empty
);
488 -- Check the specified argument Arg to make sure that it is a static
489 -- expression of the given type (i.e. it will be analyzed and resolved
490 -- using this type, which can be any valid argument to Resolve, e.g.
491 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
492 -- Typ is left Empty, then any static expression is allowed.
494 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
495 -- Check the specified argument Arg to make sure that it is a valid task
496 -- dispatching policy name. If not give error and raise Pragma_Exit.
498 procedure Check_Arg_Order
(Names
: Name_List
);
499 -- Checks for an instance of two arguments with identifiers for the
500 -- current pragma which are not in the sequence indicated by Names,
501 -- and if so, generates a fatal message about bad order of arguments.
503 procedure Check_At_Least_N_Arguments
(N
: Nat
);
504 -- Check there are at least N arguments present
506 procedure Check_At_Most_N_Arguments
(N
: Nat
);
507 -- Check there are no more than N arguments present
509 procedure Check_Component
512 In_Variant_Part
: Boolean := False);
513 -- Examine an Unchecked_Union component for correct use of per-object
514 -- constrained subtypes, and for restrictions on finalizable components.
515 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
516 -- should be set when Comp comes from a record variant.
518 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
519 -- Check if a pragma of the same name as the current pragma is already
520 -- chained as a rep pragma to the given entity. If so give a message
521 -- about the duplicate, and then raise Pragma_Exit so does not return.
522 -- Also checks for delayed aspect specification node in the chain.
524 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
525 -- Nam is an N_String_Literal node containing the external name set by
526 -- an Import or Export pragma (or extended Import or Export pragma).
527 -- This procedure checks for possible duplications if this is the export
528 -- case, and if found, issues an appropriate error message.
530 procedure Check_Expr_Is_Static_Expression
532 Typ
: Entity_Id
:= Empty
);
533 -- Check the specified expression Expr to make sure that it is a static
534 -- expression of the given type (i.e. it will be analyzed and resolved
535 -- using this type, which can be any valid argument to Resolve, e.g.
536 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
537 -- Typ is left Empty, then any static expression is allowed.
539 procedure Check_First_Subtype
(Arg
: Node_Id
);
540 -- Checks that Arg, whose expression is an entity name, references a
543 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
544 -- Checks that the given argument has an identifier, and if so, requires
545 -- it to match the given identifier name. If there is no identifier, or
546 -- a non-matching identifier, then an error message is given and
547 -- Pragma_Exit is raised.
549 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
550 -- Checks that the given argument has an identifier, and if so, requires
551 -- it to match one of the given identifier names. If there is no
552 -- identifier, or a non-matching identifier, then an error message is
553 -- given and Pragma_Exit is raised.
555 procedure Check_In_Main_Program
;
556 -- Common checks for pragmas that appear within a main program
557 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
559 procedure Check_Interrupt_Or_Attach_Handler
;
560 -- Common processing for first argument of pragma Interrupt_Handler or
561 -- pragma Attach_Handler.
563 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
564 -- Check that pragma appears in a declarative part, or in a package
565 -- specification, i.e. that it does not occur in a statement sequence
568 procedure Check_No_Identifier
(Arg
: Node_Id
);
569 -- Checks that the given argument does not have an identifier. If
570 -- an identifier is present, then an error message is issued, and
571 -- Pragma_Exit is raised.
573 procedure Check_No_Identifiers
;
574 -- Checks that none of the arguments to the pragma has an identifier.
575 -- If any argument has an identifier, then an error message is issued,
576 -- and Pragma_Exit is raised.
578 procedure Check_No_Link_Name
;
579 -- Checks that no link name is specified
581 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
582 -- Checks if the given argument has an identifier, and if so, requires
583 -- it to match the given identifier name. If there is a non-matching
584 -- identifier, then an error message is given and Pragma_Exit is raised.
586 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
587 -- Checks if the given argument has an identifier, and if so, requires
588 -- it to match the given identifier name. If there is a non-matching
589 -- identifier, then an error message is given and Pragma_Exit is raised.
590 -- In this version of the procedure, the identifier name is given as
591 -- a string with lower case letters.
593 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean);
594 -- Called to process a precondition or postcondition pragma. There are
597 -- The pragma appears after a subprogram spec
599 -- If the corresponding check is not enabled, the pragma is analyzed
600 -- but otherwise ignored and control returns with In_Body set False.
602 -- If the check is enabled, then the first step is to analyze the
603 -- pragma, but this is skipped if the subprogram spec appears within
604 -- a package specification (because this is the case where we delay
605 -- analysis till the end of the spec). Then (whether or not it was
606 -- analyzed), the pragma is chained to the subprogram in question
607 -- (using Spec_PPC_List and Next_Pragma) and control returns to the
608 -- caller with In_Body set False.
610 -- The pragma appears at the start of subprogram body declarations
612 -- In this case an immediate return to the caller is made with
613 -- In_Body set True, and the pragma is NOT analyzed.
615 -- In all other cases, an error message for bad placement is given
617 procedure Check_Static_Constraint
(Constr
: Node_Id
);
618 -- Constr is a constraint from an N_Subtype_Indication node from a
619 -- component constraint in an Unchecked_Union type. This routine checks
620 -- that the constraint is static as required by the restrictions for
623 procedure Check_Test_Case
;
624 -- Called to process a test-case pragma. The treatment is similar to the
625 -- one for pre- and postcondition in Check_Precondition_Postcondition,
626 -- except the placement rules for the test-case pragma are stricter.
627 -- This pragma may only occur after a subprogram spec declared directly
628 -- in a package spec unit. In this case, the pragma is chained to the
629 -- subprogram in question (using Spec_TC_List and Next_Pragma) and
630 -- analysis of the pragma is delayed till the end of the spec. In
631 -- all other cases, an error message for bad placement is given.
633 procedure Check_Valid_Configuration_Pragma
;
634 -- Legality checks for placement of a configuration pragma
636 procedure Check_Valid_Library_Unit_Pragma
;
637 -- Legality checks for library unit pragmas. A special case arises for
638 -- pragmas in generic instances that come from copies of the original
639 -- library unit pragmas in the generic templates. In the case of other
640 -- than library level instantiations these can appear in contexts which
641 -- would normally be invalid (they only apply to the original template
642 -- and to library level instantiations), and they are simply ignored,
643 -- which is implemented by rewriting them as null statements.
645 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
646 -- Check an Unchecked_Union variant for lack of nested variants and
647 -- presence of at least one component. UU_Typ is the related Unchecked_
650 procedure Error_Pragma
(Msg
: String);
651 pragma No_Return
(Error_Pragma
);
652 -- Outputs error message for current pragma. The message contains a %
653 -- that will be replaced with the pragma name, and the flag is placed
654 -- on the pragma itself. Pragma_Exit is then raised.
656 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
657 pragma No_Return
(Error_Pragma_Arg
);
658 -- Outputs error message for current pragma. The message may contain
659 -- a % that will be replaced with the pragma name. The parameter Arg
660 -- may either be a pragma argument association, in which case the flag
661 -- is placed on the expression of this association, or an expression,
662 -- in which case the flag is placed directly on the expression. The
663 -- message is placed using Error_Msg_N, so the message may also contain
664 -- an & insertion character which will reference the given Arg value.
665 -- After placing the message, Pragma_Exit is raised.
667 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
668 pragma No_Return
(Error_Pragma_Arg
);
669 -- Similar to above form of Error_Pragma_Arg except that two messages
670 -- are provided, the second is a continuation comment starting with \.
672 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
673 pragma No_Return
(Error_Pragma_Arg_Ident
);
674 -- Outputs error message for current pragma. The message may contain
675 -- a % that will be replaced with the pragma name. The parameter Arg
676 -- must be a pragma argument association with a non-empty identifier
677 -- (i.e. its Chars field must be set), and the error message is placed
678 -- on the identifier. The message is placed using Error_Msg_N so
679 -- the message may also contain an & insertion character which will
680 -- reference the identifier. After placing the message, Pragma_Exit
683 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
684 pragma No_Return
(Error_Pragma_Ref
);
685 -- Outputs error message for current pragma. The message may contain
686 -- a % that will be replaced with the pragma name. The parameter Ref
687 -- must be an entity whose name can be referenced by & and sloc by #.
688 -- After placing the message, Pragma_Exit is raised.
690 function Find_Lib_Unit_Name
return Entity_Id
;
691 -- Used for a library unit pragma to find the entity to which the
692 -- library unit pragma applies, returns the entity found.
694 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
695 -- If the pragma is a compilation unit pragma, the id must denote the
696 -- compilation unit in the same compilation, and the pragma must appear
697 -- in the list of preceding or trailing pragmas. If it is a program
698 -- unit pragma that is not a compilation unit pragma, then the
699 -- identifier must be visible.
701 function Find_Unique_Parameterless_Procedure
703 Arg
: Node_Id
) return Entity_Id
;
704 -- Used for a procedure pragma to find the unique parameterless
705 -- procedure identified by Name, returns it if it exists, otherwise
706 -- errors out and uses Arg as the pragma argument for the message.
708 procedure Fix_Error
(Msg
: in out String);
709 -- This is called prior to issuing an error message. Msg is a string
710 -- which typically contains the substring pragma. If the current pragma
711 -- comes from an aspect, each such "pragma" substring is replaced with
712 -- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
713 -- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).
715 procedure Gather_Associations
717 Args
: out Args_List
);
718 -- This procedure is used to gather the arguments for a pragma that
719 -- permits arbitrary ordering of parameters using the normal rules
720 -- for named and positional parameters. The Names argument is a list
721 -- of Name_Id values that corresponds to the allowed pragma argument
722 -- association identifiers in order. The result returned in Args is
723 -- a list of corresponding expressions that are the pragma arguments.
724 -- Note that this is a list of expressions, not of pragma argument
725 -- associations (Gather_Associations has completely checked all the
726 -- optional identifiers when it returns). An entry in Args is Empty
727 -- on return if the corresponding argument is not present.
729 procedure GNAT_Pragma
;
730 -- Called for all GNAT defined pragmas to check the relevant restriction
731 -- (No_Implementation_Pragmas).
733 function Is_Before_First_Decl
734 (Pragma_Node
: Node_Id
;
735 Decls
: List_Id
) return Boolean;
736 -- Return True if Pragma_Node is before the first declarative item in
737 -- Decls where Decls is the list of declarative items.
739 function Is_Configuration_Pragma
return Boolean;
740 -- Determines if the placement of the current pragma is appropriate
741 -- for a configuration pragma.
743 function Is_In_Context_Clause
return Boolean;
744 -- Returns True if pragma appears within the context clause of a unit,
745 -- and False for any other placement (does not generate any messages).
747 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
748 -- Analyzes the argument, and determines if it is a static string
749 -- expression, returns True if so, False if non-static or not String.
751 procedure Pragma_Misplaced
;
752 pragma No_Return
(Pragma_Misplaced
);
753 -- Issue fatal error message for misplaced pragma
755 procedure Process_Atomic_Shared_Volatile
;
756 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
757 -- Shared is an obsolete Ada 83 pragma, treated as being identical
758 -- in effect to pragma Atomic.
760 procedure Process_Compile_Time_Warning_Or_Error
;
761 -- Common processing for Compile_Time_Error and Compile_Time_Warning
763 procedure Process_Convention
764 (C
: out Convention_Id
;
765 Ent
: out Entity_Id
);
766 -- Common processing for Convention, Interface, Import and Export.
767 -- Checks first two arguments of pragma, and sets the appropriate
768 -- convention value in the specified entity or entities. On return
769 -- C is the convention, Ent is the referenced entity.
771 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
772 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
773 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
775 procedure Process_Extended_Import_Export_Exception_Pragma
776 (Arg_Internal
: Node_Id
;
777 Arg_External
: Node_Id
;
780 -- Common processing for the pragmas Import/Export_Exception. The three
781 -- arguments correspond to the three named parameters of the pragma. An
782 -- argument is empty if the corresponding parameter is not present in
785 procedure Process_Extended_Import_Export_Object_Pragma
786 (Arg_Internal
: Node_Id
;
787 Arg_External
: Node_Id
;
789 -- Common processing for the pragmas Import/Export_Object. The three
790 -- arguments correspond to the three named parameters of the pragmas. An
791 -- argument is empty if the corresponding parameter is not present in
794 procedure Process_Extended_Import_Export_Internal_Arg
795 (Arg_Internal
: Node_Id
:= Empty
);
796 -- Common processing for all extended Import and Export pragmas. The
797 -- argument is the pragma parameter for the Internal argument. If
798 -- Arg_Internal is empty or inappropriate, an error message is posted.
799 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
800 -- set to identify the referenced entity.
802 procedure Process_Extended_Import_Export_Subprogram_Pragma
803 (Arg_Internal
: Node_Id
;
804 Arg_External
: Node_Id
;
805 Arg_Parameter_Types
: Node_Id
;
806 Arg_Result_Type
: Node_Id
:= Empty
;
807 Arg_Mechanism
: Node_Id
;
808 Arg_Result_Mechanism
: Node_Id
:= Empty
;
809 Arg_First_Optional_Parameter
: Node_Id
:= Empty
);
810 -- Common processing for all extended Import and Export pragmas applying
811 -- to subprograms. The caller omits any arguments that do not apply to
812 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
813 -- only in the Import_Function and Export_Function cases). The argument
814 -- names correspond to the allowed pragma association identifiers.
816 procedure Process_Generic_List
;
817 -- Common processing for Share_Generic and Inline_Generic
819 procedure Process_Import_Or_Interface
;
820 -- Common processing for Import of Interface
822 procedure Process_Import_Predefined_Type
;
823 -- Processing for completing a type with pragma Import. This is used
824 -- to declare types that match predefined C types, especially for cases
825 -- without corresponding Ada predefined type.
827 procedure Process_Inline
(Active
: Boolean);
828 -- Common processing for Inline and Inline_Always. The parameter
829 -- indicates if the inline pragma is active, i.e. if it should actually
830 -- cause inlining to occur.
832 procedure Process_Interface_Name
833 (Subprogram_Def
: Entity_Id
;
836 -- Given the last two arguments of pragma Import, pragma Export, or
837 -- pragma Interface_Name, performs validity checks and sets the
838 -- Interface_Name field of the given subprogram entity to the
839 -- appropriate external or link name, depending on the arguments given.
840 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
841 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
842 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
843 -- nor Link_Arg is present, the interface name is set to the default
844 -- from the subprogram name.
846 procedure Process_Interrupt_Or_Attach_Handler
;
847 -- Common processing for Interrupt and Attach_Handler pragmas
849 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
850 -- Common processing for Restrictions and Restriction_Warnings pragmas.
851 -- Warn is True for Restriction_Warnings, or for Restrictions if the
852 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
853 -- is not set in the Restrictions case.
855 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
856 -- Common processing for Suppress and Unsuppress. The boolean parameter
857 -- Suppress_Case is True for the Suppress case, and False for the
860 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
861 -- This procedure sets the Is_Exported flag for the given entity,
862 -- checking that the entity was not previously imported. Arg is
863 -- the argument that specified the entity. A check is also made
864 -- for exporting inappropriate entities.
866 procedure Set_Extended_Import_Export_External_Name
867 (Internal_Ent
: Entity_Id
;
868 Arg_External
: Node_Id
);
869 -- Common processing for all extended import export pragmas. The first
870 -- argument, Internal_Ent, is the internal entity, which has already
871 -- been checked for validity by the caller. Arg_External is from the
872 -- Import or Export pragma, and may be null if no External parameter
873 -- was present. If Arg_External is present and is a non-null string
874 -- (a null string is treated as the default), then the Interface_Name
875 -- field of Internal_Ent is set appropriately.
877 procedure Set_Imported
(E
: Entity_Id
);
878 -- This procedure sets the Is_Imported flag for the given entity,
879 -- checking that it is not previously exported or imported.
881 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
882 -- Mech is a parameter passing mechanism (see Import_Function syntax
883 -- for MECHANISM_NAME). This routine checks that the mechanism argument
884 -- has the right form, and if not issues an error message. If the
885 -- argument has the right form then the Mechanism field of Ent is
886 -- set appropriately.
888 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
889 -- Activate the set of configuration pragmas and restrictions that make
890 -- up the Ravenscar Profile. N is the corresponding pragma node, which
891 -- is used for error messages on any constructs that violate the
894 ---------------------
895 -- Ada_2005_Pragma --
896 ---------------------
898 procedure Ada_2005_Pragma
is
900 if Ada_Version
<= Ada_95
then
901 Check_Restriction
(No_Implementation_Pragmas
, N
);
905 ---------------------
906 -- Ada_2012_Pragma --
907 ---------------------
909 procedure Ada_2012_Pragma
is
911 if Ada_Version
<= Ada_2005
then
912 Check_Restriction
(No_Implementation_Pragmas
, N
);
916 --------------------------
917 -- Check_Ada_83_Warning --
918 --------------------------
920 procedure Check_Ada_83_Warning
is
922 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
923 Error_Msg_N
("(Ada 83) pragma& is non-standard?", N
);
925 end Check_Ada_83_Warning
;
927 ---------------------
928 -- Check_Arg_Count --
929 ---------------------
931 procedure Check_Arg_Count
(Required
: Nat
) is
933 if Arg_Count
/= Required
then
934 Error_Pragma
("wrong number of arguments for pragma%");
938 --------------------------------
939 -- Check_Arg_Is_External_Name --
940 --------------------------------
942 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
943 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
946 if Nkind
(Argx
) = N_Identifier
then
950 Analyze_And_Resolve
(Argx
, Standard_String
);
952 if Is_OK_Static_Expression
(Argx
) then
955 elsif Etype
(Argx
) = Any_Type
then
958 -- An interesting special case, if we have a string literal and
959 -- we are in Ada 83 mode, then we allow it even though it will
960 -- not be flagged as static. This allows expected Ada 83 mode
961 -- use of external names which are string literals, even though
962 -- technically these are not static in Ada 83.
964 elsif Ada_Version
= Ada_83
965 and then Nkind
(Argx
) = N_String_Literal
969 -- Static expression that raises Constraint_Error. This has
970 -- already been flagged, so just exit from pragma processing.
972 elsif Is_Static_Expression
(Argx
) then
975 -- Here we have a real error (non-static expression)
978 Error_Msg_Name_1
:= Pname
;
982 "argument for pragma% must be a identifier or "
983 & "static string expression!";
986 Flag_Non_Static_Expr
(Msg
, Argx
);
991 end Check_Arg_Is_External_Name
;
993 -----------------------------
994 -- Check_Arg_Is_Identifier --
995 -----------------------------
997 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
998 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1000 if Nkind
(Argx
) /= N_Identifier
then
1002 ("argument for pragma% must be identifier", Argx
);
1004 end Check_Arg_Is_Identifier
;
1006 ----------------------------------
1007 -- Check_Arg_Is_Integer_Literal --
1008 ----------------------------------
1010 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
1011 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1013 if Nkind
(Argx
) /= N_Integer_Literal
then
1015 ("argument for pragma% must be integer literal", Argx
);
1017 end Check_Arg_Is_Integer_Literal
;
1019 -------------------------------------------
1020 -- Check_Arg_Is_Library_Level_Local_Name --
1021 -------------------------------------------
1025 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
1026 -- | library_unit_NAME
1028 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
1030 Check_Arg_Is_Local_Name
(Arg
);
1032 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
1033 and then Comes_From_Source
(N
)
1036 ("argument for pragma% must be library level entity", Arg
);
1038 end Check_Arg_Is_Library_Level_Local_Name
;
1040 -----------------------------
1041 -- Check_Arg_Is_Local_Name --
1042 -----------------------------
1046 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
1047 -- | library_unit_NAME
1049 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
1050 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1055 if Nkind
(Argx
) not in N_Direct_Name
1056 and then (Nkind
(Argx
) /= N_Attribute_Reference
1057 or else Present
(Expressions
(Argx
))
1058 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
1059 and then (not Is_Entity_Name
(Argx
)
1060 or else not Is_Compilation_Unit
(Entity
(Argx
)))
1062 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
1065 -- No further check required if not an entity name
1067 if not Is_Entity_Name
(Argx
) then
1073 Ent
: constant Entity_Id
:= Entity
(Argx
);
1074 Scop
: constant Entity_Id
:= Scope
(Ent
);
1076 -- Case of a pragma applied to a compilation unit: pragma must
1077 -- occur immediately after the program unit in the compilation.
1079 if Is_Compilation_Unit
(Ent
) then
1081 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
1084 -- Case of pragma placed immediately after spec
1086 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
1089 -- Case of pragma placed immediately after body
1091 elsif Nkind
(Decl
) = N_Subprogram_Declaration
1092 and then Present
(Corresponding_Body
(Decl
))
1096 (Parent
(Unit_Declaration_Node
1097 (Corresponding_Body
(Decl
))));
1099 -- All other cases are illegal
1106 -- Special restricted placement rule from 10.2.1(11.8/2)
1108 elsif Is_Generic_Formal
(Ent
)
1109 and then Prag_Id
= Pragma_Preelaborable_Initialization
1111 OK
:= List_Containing
(N
) =
1112 Generic_Formal_Declarations
1113 (Unit_Declaration_Node
(Scop
));
1115 -- Default case, just check that the pragma occurs in the scope
1116 -- of the entity denoted by the name.
1119 OK
:= Current_Scope
= Scop
;
1124 ("pragma% argument must be in same declarative part", Arg
);
1128 end Check_Arg_Is_Local_Name
;
1130 ---------------------------------
1131 -- Check_Arg_Is_Locking_Policy --
1132 ---------------------------------
1134 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
1135 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1138 Check_Arg_Is_Identifier
(Argx
);
1140 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
1141 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
1143 end Check_Arg_Is_Locking_Policy
;
1145 -------------------------
1146 -- Check_Arg_Is_One_Of --
1147 -------------------------
1149 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
1150 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1153 Check_Arg_Is_Identifier
(Argx
);
1155 if Chars
(Argx
) /= N1
and then Chars
(Argx
) /= N2
then
1156 Error_Msg_Name_2
:= N1
;
1157 Error_Msg_Name_3
:= N2
;
1158 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
1160 end Check_Arg_Is_One_Of
;
1162 procedure Check_Arg_Is_One_Of
1164 N1
, N2
, N3
: Name_Id
)
1166 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1169 Check_Arg_Is_Identifier
(Argx
);
1171 if Chars
(Argx
) /= N1
1172 and then Chars
(Argx
) /= N2
1173 and then Chars
(Argx
) /= N3
1175 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
1177 end Check_Arg_Is_One_Of
;
1179 procedure Check_Arg_Is_One_Of
1181 N1
, N2
, N3
, N4
, N5
: Name_Id
)
1183 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1186 Check_Arg_Is_Identifier
(Argx
);
1188 if Chars
(Argx
) /= N1
1189 and then Chars
(Argx
) /= N2
1190 and then Chars
(Argx
) /= N3
1191 and then Chars
(Argx
) /= N4
1192 and then Chars
(Argx
) /= N5
1194 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
1196 end Check_Arg_Is_One_Of
;
1197 ---------------------------------
1198 -- Check_Arg_Is_Queuing_Policy --
1199 ---------------------------------
1201 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
1202 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1205 Check_Arg_Is_Identifier
(Argx
);
1207 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
1208 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
1210 end Check_Arg_Is_Queuing_Policy
;
1212 ------------------------------------
1213 -- Check_Arg_Is_Static_Expression --
1214 ------------------------------------
1216 procedure Check_Arg_Is_Static_Expression
1218 Typ
: Entity_Id
:= Empty
)
1221 Check_Expr_Is_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
1222 end Check_Arg_Is_Static_Expression
;
1224 ------------------------------------------
1225 -- Check_Arg_Is_Task_Dispatching_Policy --
1226 ------------------------------------------
1228 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
1229 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1232 Check_Arg_Is_Identifier
(Argx
);
1234 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
1236 ("& is not a valid task dispatching policy name", Argx
);
1238 end Check_Arg_Is_Task_Dispatching_Policy
;
1240 ---------------------
1241 -- Check_Arg_Order --
1242 ---------------------
1244 procedure Check_Arg_Order
(Names
: Name_List
) is
1247 Highest_So_Far
: Natural := 0;
1248 -- Highest index in Names seen do far
1252 for J
in 1 .. Arg_Count
loop
1253 if Chars
(Arg
) /= No_Name
then
1254 for K
in Names
'Range loop
1255 if Chars
(Arg
) = Names
(K
) then
1256 if K
< Highest_So_Far
then
1257 Error_Msg_Name_1
:= Pname
;
1259 ("parameters out of order for pragma%", Arg
);
1260 Error_Msg_Name_1
:= Names
(K
);
1261 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
1262 Error_Msg_N
("\% must appear before %", Arg
);
1266 Highest_So_Far
:= K
;
1274 end Check_Arg_Order
;
1276 --------------------------------
1277 -- Check_At_Least_N_Arguments --
1278 --------------------------------
1280 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
1282 if Arg_Count
< N
then
1283 Error_Pragma
("too few arguments for pragma%");
1285 end Check_At_Least_N_Arguments
;
1287 -------------------------------
1288 -- Check_At_Most_N_Arguments --
1289 -------------------------------
1291 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
1294 if Arg_Count
> N
then
1296 for J
in 1 .. N
loop
1298 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
1301 end Check_At_Most_N_Arguments
;
1303 ---------------------
1304 -- Check_Component --
1305 ---------------------
1307 procedure Check_Component
1310 In_Variant_Part
: Boolean := False)
1312 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
1313 Sindic
: constant Node_Id
:=
1314 Subtype_Indication
(Component_Definition
(Comp
));
1315 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
1317 function Inside_Generic_Body
(Id
: Entity_Id
) return Boolean;
1318 -- Determine whether entity Id appears inside a generic body.
1319 -- Shouldn't this be in a more general place ???
1321 -------------------------
1322 -- Inside_Generic_Body --
1323 -------------------------
1325 function Inside_Generic_Body
(Id
: Entity_Id
) return Boolean is
1330 while Present
(S
) and then S
/= Standard_Standard
loop
1331 if Ekind
(S
) = E_Generic_Package
1332 and then In_Package_Body
(S
)
1341 end Inside_Generic_Body
;
1343 -- Start of processing for Check_Component
1346 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
1347 -- object constraint, then the component type shall be an Unchecked_
1350 if Nkind
(Sindic
) = N_Subtype_Indication
1351 and then Has_Per_Object_Constraint
(Comp_Id
)
1352 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
1355 ("component subtype subject to per-object constraint " &
1356 "must be an Unchecked_Union", Comp
);
1358 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
1359 -- the body of a generic unit, or within the body of any of its
1360 -- descendant library units, no part of the type of a component
1361 -- declared in a variant_part of the unchecked union type shall be of
1362 -- a formal private type or formal private extension declared within
1363 -- the formal part of the generic unit.
1365 elsif Ada_Version
>= Ada_2012
1366 and then Inside_Generic_Body
(UU_Typ
)
1367 and then In_Variant_Part
1368 and then Is_Private_Type
(Typ
)
1369 and then Is_Generic_Type
(Typ
)
1372 ("component of Unchecked_Union cannot be of generic type", Comp
);
1374 elsif Needs_Finalization
(Typ
) then
1376 ("component of Unchecked_Union cannot be controlled", Comp
);
1378 elsif Has_Task
(Typ
) then
1380 ("component of Unchecked_Union cannot have tasks", Comp
);
1382 end Check_Component
;
1384 ----------------------------
1385 -- Check_Duplicate_Pragma --
1386 ----------------------------
1388 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
1392 -- Nothing to do if this pragma comes from an aspect specification,
1393 -- since we could not be duplicating a pragma, and we dealt with the
1394 -- case of duplicated aspects in Analyze_Aspect_Specifications.
1396 if From_Aspect_Specification
(N
) then
1400 -- Otherwise current pragma may duplicate previous pragma or a
1401 -- previously given aspect specification for the same pragma.
1403 P
:= Get_Rep_Item_For_Entity
(E
, Pragma_Name
(N
));
1406 Error_Msg_Name_1
:= Pragma_Name
(N
);
1407 Error_Msg_Sloc
:= Sloc
(P
);
1409 if Nkind
(P
) = N_Aspect_Specification
1410 or else From_Aspect_Specification
(P
)
1412 Error_Msg_NE
("aspect% for & previously given#", N
, E
);
1414 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, E
);
1419 end Check_Duplicate_Pragma
;
1421 ----------------------------------
1422 -- Check_Duplicated_Export_Name --
1423 ----------------------------------
1425 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
1426 String_Val
: constant String_Id
:= Strval
(Nam
);
1429 -- We are only interested in the export case, and in the case of
1430 -- generics, it is the instance, not the template, that is the
1431 -- problem (the template will generate a warning in any case).
1433 if not Inside_A_Generic
1434 and then (Prag_Id
= Pragma_Export
1436 Prag_Id
= Pragma_Export_Procedure
1438 Prag_Id
= Pragma_Export_Valued_Procedure
1440 Prag_Id
= Pragma_Export_Function
)
1442 for J
in Externals
.First
.. Externals
.Last
loop
1443 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
1444 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
1445 Error_Msg_N
("external name duplicates name given#", Nam
);
1450 Externals
.Append
(Nam
);
1452 end Check_Duplicated_Export_Name
;
1454 -------------------------------------
1455 -- Check_Expr_Is_Static_Expression --
1456 -------------------------------------
1458 procedure Check_Expr_Is_Static_Expression
1460 Typ
: Entity_Id
:= Empty
)
1463 if Present
(Typ
) then
1464 Analyze_And_Resolve
(Expr
, Typ
);
1466 Analyze_And_Resolve
(Expr
);
1469 if Is_OK_Static_Expression
(Expr
) then
1472 elsif Etype
(Expr
) = Any_Type
then
1475 -- An interesting special case, if we have a string literal and we
1476 -- are in Ada 83 mode, then we allow it even though it will not be
1477 -- flagged as static. This allows the use of Ada 95 pragmas like
1478 -- Import in Ada 83 mode. They will of course be flagged with
1479 -- warnings as usual, but will not cause errors.
1481 elsif Ada_Version
= Ada_83
1482 and then Nkind
(Expr
) = N_String_Literal
1486 -- Static expression that raises Constraint_Error. This has already
1487 -- been flagged, so just exit from pragma processing.
1489 elsif Is_Static_Expression
(Expr
) then
1492 -- Finally, we have a real error
1495 Error_Msg_Name_1
:= Pname
;
1499 "argument for pragma% must be a static expression!";
1502 Flag_Non_Static_Expr
(Msg
, Expr
);
1507 end Check_Expr_Is_Static_Expression
;
1509 -------------------------
1510 -- Check_First_Subtype --
1511 -------------------------
1513 procedure Check_First_Subtype
(Arg
: Node_Id
) is
1514 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1515 Ent
: constant Entity_Id
:= Entity
(Argx
);
1518 if Is_First_Subtype
(Ent
) then
1521 elsif Is_Type
(Ent
) then
1523 ("pragma% cannot apply to subtype", Argx
);
1525 elsif Is_Object
(Ent
) then
1527 ("pragma% cannot apply to object, requires a type", Argx
);
1531 ("pragma% cannot apply to&, requires a type", Argx
);
1533 end Check_First_Subtype
;
1535 ----------------------
1536 -- Check_Identifier --
1537 ----------------------
1539 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
1542 and then Nkind
(Arg
) = N_Pragma_Argument_Association
1544 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
1545 Error_Msg_Name_1
:= Pname
;
1546 Error_Msg_Name_2
:= Id
;
1547 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
1551 end Check_Identifier
;
1553 --------------------------------
1554 -- Check_Identifier_Is_One_Of --
1555 --------------------------------
1557 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
1560 and then Nkind
(Arg
) = N_Pragma_Argument_Association
1562 if Chars
(Arg
) = No_Name
then
1563 Error_Msg_Name_1
:= Pname
;
1564 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
1567 elsif Chars
(Arg
) /= N1
1568 and then Chars
(Arg
) /= N2
1570 Error_Msg_Name_1
:= Pname
;
1571 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
1575 end Check_Identifier_Is_One_Of
;
1577 ---------------------------
1578 -- Check_In_Main_Program --
1579 ---------------------------
1581 procedure Check_In_Main_Program
is
1582 P
: constant Node_Id
:= Parent
(N
);
1585 -- Must be at in subprogram body
1587 if Nkind
(P
) /= N_Subprogram_Body
then
1588 Error_Pragma
("% pragma allowed only in subprogram");
1590 -- Otherwise warn if obviously not main program
1592 elsif Present
(Parameter_Specifications
(Specification
(P
)))
1593 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
1595 Error_Msg_Name_1
:= Pname
;
1597 ("?pragma% is only effective in main program", N
);
1599 end Check_In_Main_Program
;
1601 ---------------------------------------
1602 -- Check_Interrupt_Or_Attach_Handler --
1603 ---------------------------------------
1605 procedure Check_Interrupt_Or_Attach_Handler
is
1606 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
1607 Handler_Proc
, Proc_Scope
: Entity_Id
;
1612 if Prag_Id
= Pragma_Interrupt_Handler
then
1613 Check_Restriction
(No_Dynamic_Attachment
, N
);
1616 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
1617 Proc_Scope
:= Scope
(Handler_Proc
);
1619 -- On AAMP only, a pragma Interrupt_Handler is supported for
1620 -- nonprotected parameterless procedures.
1622 if not AAMP_On_Target
1623 or else Prag_Id
= Pragma_Attach_Handler
1625 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
1627 ("argument of pragma% must be protected procedure", Arg1
);
1630 if Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
)) then
1631 Error_Pragma
("pragma% must be in protected definition");
1635 if not Is_Library_Level_Entity
(Proc_Scope
)
1636 or else (AAMP_On_Target
1637 and then not Is_Library_Level_Entity
(Handler_Proc
))
1640 ("argument for pragma% must be library level entity", Arg1
);
1643 -- AI05-0033: A pragma cannot appear within a generic body, because
1644 -- instance can be in a nested scope. The check that protected type
1645 -- is itself a library-level declaration is done elsewhere.
1647 -- Note: we omit this check in Codepeer mode to properly handle code
1648 -- prior to AI-0033 (pragmas don't matter to codepeer in any case).
1650 if Inside_A_Generic
then
1651 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
1652 and then In_Package_Body
(Scope
(Current_Scope
))
1653 and then not CodePeer_Mode
1655 Error_Pragma
("pragma% cannot be used inside a generic");
1658 end Check_Interrupt_Or_Attach_Handler
;
1660 -------------------------------------------
1661 -- Check_Is_In_Decl_Part_Or_Package_Spec --
1662 -------------------------------------------
1664 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
1673 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
1676 elsif Nkind_In
(P
, N_Package_Specification
,
1681 -- Note: the following tests seem a little peculiar, because
1682 -- they test for bodies, but if we were in the statement part
1683 -- of the body, we would already have hit the handled statement
1684 -- sequence, so the only way we get here is by being in the
1685 -- declarative part of the body.
1687 elsif Nkind_In
(P
, N_Subprogram_Body
,
1698 Error_Pragma
("pragma% is not in declarative part or package spec");
1699 end Check_Is_In_Decl_Part_Or_Package_Spec
;
1701 -------------------------
1702 -- Check_No_Identifier --
1703 -------------------------
1705 procedure Check_No_Identifier
(Arg
: Node_Id
) is
1707 if Nkind
(Arg
) = N_Pragma_Argument_Association
1708 and then Chars
(Arg
) /= No_Name
1710 Error_Pragma_Arg_Ident
1711 ("pragma% does not permit identifier& here", Arg
);
1713 end Check_No_Identifier
;
1715 --------------------------
1716 -- Check_No_Identifiers --
1717 --------------------------
1719 procedure Check_No_Identifiers
is
1722 if Arg_Count
> 0 then
1724 while Present
(Arg_Node
) loop
1725 Check_No_Identifier
(Arg_Node
);
1729 end Check_No_Identifiers
;
1731 ------------------------
1732 -- Check_No_Link_Name --
1733 ------------------------
1735 procedure Check_No_Link_Name
is
1738 and then Chars
(Arg3
) = Name_Link_Name
1743 if Present
(Arg4
) then
1745 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
1747 end Check_No_Link_Name
;
1749 -------------------------------
1750 -- Check_Optional_Identifier --
1751 -------------------------------
1753 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
1756 and then Nkind
(Arg
) = N_Pragma_Argument_Association
1757 and then Chars
(Arg
) /= No_Name
1759 if Chars
(Arg
) /= Id
then
1760 Error_Msg_Name_1
:= Pname
;
1761 Error_Msg_Name_2
:= Id
;
1762 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
1766 end Check_Optional_Identifier
;
1768 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
1770 Name_Buffer
(1 .. Id
'Length) := Id
;
1771 Name_Len
:= Id
'Length;
1772 Check_Optional_Identifier
(Arg
, Name_Find
);
1773 end Check_Optional_Identifier
;
1775 --------------------------------------
1776 -- Check_Precondition_Postcondition --
1777 --------------------------------------
1779 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean) is
1783 procedure Chain_PPC
(PO
: Node_Id
);
1784 -- If PO is an entry or a [generic] subprogram declaration node, then
1785 -- the precondition/postcondition applies to this subprogram and the
1786 -- processing for the pragma is completed. Otherwise the pragma is
1793 procedure Chain_PPC
(PO
: Node_Id
) is
1798 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
1799 if not From_Aspect_Specification
(N
) then
1801 ("pragma% cannot be applied to abstract subprogram");
1803 elsif Class_Present
(N
) then
1808 ("aspect % requires ''Class for abstract subprogram");
1811 -- AI05-0230: The same restriction applies to null procedures. For
1812 -- compatibility with earlier uses of the Ada pragma, apply this
1813 -- rule only to aspect specifications.
1815 -- The above discrpency needs documentation. Robert is dubious
1816 -- about whether it is a good idea ???
1818 elsif Nkind
(PO
) = N_Subprogram_Declaration
1819 and then Nkind
(Specification
(PO
)) = N_Procedure_Specification
1820 and then Null_Present
(Specification
(PO
))
1821 and then From_Aspect_Specification
(N
)
1822 and then not Class_Present
(N
)
1825 ("aspect % requires ''Class for null procedure");
1827 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
1828 N_Generic_Subprogram_Declaration
,
1829 N_Entry_Declaration
)
1834 -- Here if we have [generic] subprogram or entry declaration
1836 if Nkind
(PO
) = N_Entry_Declaration
then
1837 S
:= Defining_Entity
(PO
);
1839 S
:= Defining_Unit_Name
(Specification
(PO
));
1842 -- Make sure we do not have the case of a precondition pragma when
1843 -- the Pre'Class aspect is present.
1845 -- We do this by looking at pragmas already chained to the entity
1846 -- since the aspect derived pragma will be put on this list first.
1848 if Pragma_Name
(N
) = Name_Precondition
then
1849 if not From_Aspect_Specification
(N
) then
1850 P
:= Spec_PPC_List
(Contract
(S
));
1851 while Present
(P
) loop
1852 if Pragma_Name
(P
) = Name_Precondition
1853 and then From_Aspect_Specification
(P
)
1854 and then Class_Present
(P
)
1856 Error_Msg_Sloc
:= Sloc
(P
);
1858 ("pragma% not allowed, `Pre''Class` aspect given#");
1861 P
:= Next_Pragma
(P
);
1866 -- Similarly check for Pre with inherited Pre'Class. Note that
1867 -- we cover the aspect case as well here.
1869 if Pragma_Name
(N
) = Name_Precondition
1870 and then not Class_Present
(N
)
1873 Inherited
: constant Subprogram_List
:=
1874 Inherited_Subprograms
(S
);
1878 for J
in Inherited
'Range loop
1879 P
:= Spec_PPC_List
(Contract
(Inherited
(J
)));
1880 while Present
(P
) loop
1881 if Pragma_Name
(P
) = Name_Precondition
1882 and then Class_Present
(P
)
1884 Error_Msg_Sloc
:= Sloc
(P
);
1886 ("pragma% not allowed, `Pre''Class` "
1887 & "aspect inherited from#");
1890 P
:= Next_Pragma
(P
);
1896 -- Note: we do not analyze the pragma at this point. Instead we
1897 -- delay this analysis until the end of the declarative part in
1898 -- which the pragma appears. This implements the required delay
1899 -- in this analysis, allowing forward references. The analysis
1900 -- happens at the end of Analyze_Declarations.
1902 -- Chain spec PPC pragma to list for subprogram
1904 Set_Next_Pragma
(N
, Spec_PPC_List
(Contract
(S
)));
1905 Set_Spec_PPC_List
(Contract
(S
), N
);
1907 -- Return indicating spec case
1913 -- Start of processing for Check_Precondition_Postcondition
1916 if not Is_List_Member
(N
) then
1920 -- Preanalyze message argument if present. Visibility in this
1921 -- argument is established at the point of pragma occurrence.
1923 if Arg_Count
= 2 then
1924 Check_Optional_Identifier
(Arg2
, Name_Message
);
1925 Preanalyze_Spec_Expression
1926 (Get_Pragma_Arg
(Arg2
), Standard_String
);
1929 -- Record if pragma is disabled
1931 if Check_Enabled
(Pname
) then
1932 Set_SCO_Pragma_Enabled
(Loc
);
1935 -- If we are within an inlined body, the legality of the pragma
1936 -- has been checked already.
1938 if In_Inlined_Body
then
1943 -- Search prior declarations
1946 while Present
(Prev
(P
)) loop
1949 -- If the previous node is a generic subprogram, do not go to to
1950 -- the original node, which is the unanalyzed tree: we need to
1951 -- attach the pre/postconditions to the analyzed version at this
1952 -- point. They get propagated to the original tree when analyzing
1953 -- the corresponding body.
1955 if Nkind
(P
) not in N_Generic_Declaration
then
1956 PO
:= Original_Node
(P
);
1961 -- Skip past prior pragma
1963 if Nkind
(PO
) = N_Pragma
then
1966 -- Skip stuff not coming from source
1968 elsif not Comes_From_Source
(PO
) then
1970 -- The condition may apply to a subprogram instantiation
1972 if Nkind
(PO
) = N_Subprogram_Declaration
1973 and then Present
(Generic_Parent
(Specification
(PO
)))
1978 elsif Nkind
(PO
) = N_Subprogram_Declaration
1979 and then In_Instance
1984 -- For all other cases of non source code, do nothing
1990 -- Only remaining possibility is subprogram declaration
1998 -- If we fall through loop, pragma is at start of list, so see if it
1999 -- is at the start of declarations of a subprogram body.
2001 if Nkind
(Parent
(N
)) = N_Subprogram_Body
2002 and then List_Containing
(N
) = Declarations
(Parent
(N
))
2004 if Operating_Mode
/= Generate_Code
2005 or else Inside_A_Generic
2007 -- Analyze pragma expression for correctness and for ASIS use
2009 Preanalyze_Spec_Expression
2010 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
2012 -- In ASIS mode, for a pragma generated from a source aspect,
2013 -- also analyze the original aspect expression.
2016 and then Present
(Corresponding_Aspect
(N
))
2018 Preanalyze_Spec_Expression
2019 (Expression
(Corresponding_Aspect
(N
)), Standard_Boolean
);
2026 -- See if it is in the pragmas after a library level subprogram
2028 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
2030 -- In formal verification mode, analyze pragma expression for
2031 -- correctness, as it is not expanded later.
2034 Analyze_PPC_In_Decl_Part
2035 (N
, Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
2038 Chain_PPC
(Unit
(Parent
(Parent
(N
))));
2042 -- If we fall through, pragma was misplaced
2045 end Check_Precondition_Postcondition
;
2047 -----------------------------
2048 -- Check_Static_Constraint --
2049 -----------------------------
2051 -- Note: for convenience in writing this procedure, in addition to
2052 -- the officially (i.e. by spec) allowed argument which is always a
2053 -- constraint, it also allows ranges and discriminant associations.
2054 -- Above is not clear ???
2056 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
2058 procedure Require_Static
(E
: Node_Id
);
2059 -- Require given expression to be static expression
2061 --------------------
2062 -- Require_Static --
2063 --------------------
2065 procedure Require_Static
(E
: Node_Id
) is
2067 if not Is_OK_Static_Expression
(E
) then
2068 Flag_Non_Static_Expr
2069 ("non-static constraint not allowed in Unchecked_Union!", E
);
2074 -- Start of processing for Check_Static_Constraint
2077 case Nkind
(Constr
) is
2078 when N_Discriminant_Association
=>
2079 Require_Static
(Expression
(Constr
));
2082 Require_Static
(Low_Bound
(Constr
));
2083 Require_Static
(High_Bound
(Constr
));
2085 when N_Attribute_Reference
=>
2086 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
2087 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
2089 when N_Range_Constraint
=>
2090 Check_Static_Constraint
(Range_Expression
(Constr
));
2092 when N_Index_Or_Discriminant_Constraint
=>
2096 IDC
:= First
(Constraints
(Constr
));
2097 while Present
(IDC
) loop
2098 Check_Static_Constraint
(IDC
);
2106 end Check_Static_Constraint
;
2108 ---------------------
2109 -- Check_Test_Case --
2110 ---------------------
2112 procedure Check_Test_Case
is
2116 procedure Chain_TC
(PO
: Node_Id
);
2117 -- If PO is a [generic] subprogram declaration node, then the
2118 -- test-case applies to this subprogram and the processing for the
2119 -- pragma is completed. Otherwise the pragma is misplaced.
2125 procedure Chain_TC
(PO
: Node_Id
) is
2129 if Nkind
(PO
) = N_Abstract_Subprogram_Declaration
then
2130 if From_Aspect_Specification
(N
) then
2132 ("aspect% cannot be applied to abstract subprogram");
2135 ("pragma% cannot be applied to abstract subprogram");
2138 elsif Nkind
(PO
) = N_Entry_Declaration
then
2139 if From_Aspect_Specification
(N
) then
2140 Error_Pragma
("aspect% cannot be applied to entry");
2142 Error_Pragma
("pragma% cannot be applied to entry");
2145 elsif not Nkind_In
(PO
, N_Subprogram_Declaration
,
2146 N_Generic_Subprogram_Declaration
)
2151 -- Here if we have [generic] subprogram declaration
2153 S
:= Defining_Unit_Name
(Specification
(PO
));
2155 -- Note: we do not analyze the pragma at this point. Instead we
2156 -- delay this analysis until the end of the declarative part in
2157 -- which the pragma appears. This implements the required delay
2158 -- in this analysis, allowing forward references. The analysis
2159 -- happens at the end of Analyze_Declarations.
2161 -- There should not be another test case with the same name
2162 -- associated to this subprogram.
2165 Name
: constant String_Id
:= Get_Name_From_Test_Case_Pragma
(N
);
2169 TC
:= Spec_TC_List
(Contract
(S
));
2170 while Present
(TC
) loop
2173 (Name
, Get_Name_From_Test_Case_Pragma
(TC
))
2175 Error_Msg_Sloc
:= Sloc
(TC
);
2177 if From_Aspect_Specification
(N
) then
2178 Error_Pragma
("name for aspect% is already used#");
2180 Error_Pragma
("name for pragma% is already used#");
2184 TC
:= Next_Pragma
(TC
);
2188 -- Chain spec TC pragma to list for subprogram
2190 Set_Next_Pragma
(N
, Spec_TC_List
(Contract
(S
)));
2191 Set_Spec_TC_List
(Contract
(S
), N
);
2194 -- Start of processing for Check_Test_Case
2197 if not Is_List_Member
(N
) then
2201 -- Test cases should only appear in package spec unit
2203 if Get_Source_Unit
(N
) = No_Unit
2204 or else not Nkind_In
(Sinfo
.Unit
(Cunit
(Get_Source_Unit
(N
))),
2205 N_Package_Declaration
,
2206 N_Generic_Package_Declaration
)
2211 -- Search prior declarations
2214 while Present
(Prev
(P
)) loop
2217 -- If the previous node is a generic subprogram, do not go to to
2218 -- the original node, which is the unanalyzed tree: we need to
2219 -- attach the test-case to the analyzed version at this point.
2220 -- They get propagated to the original tree when analyzing the
2221 -- corresponding body.
2223 if Nkind
(P
) not in N_Generic_Declaration
then
2224 PO
:= Original_Node
(P
);
2229 -- Skip past prior pragma
2231 if Nkind
(PO
) = N_Pragma
then
2234 -- Skip stuff not coming from source
2236 elsif not Comes_From_Source
(PO
) then
2239 -- Only remaining possibility is subprogram declaration. First
2240 -- check that it is declared directly in a package declaration.
2241 -- This may be either the package declaration for the current unit
2242 -- being defined or a local package declaration.
2244 elsif not Present
(Parent
(Parent
(PO
)))
2245 or else not Present
(Parent
(Parent
(Parent
(PO
))))
2246 or else not Nkind_In
(Parent
(Parent
(PO
)),
2247 N_Package_Declaration
,
2248 N_Generic_Package_Declaration
)
2258 -- If we fall through, pragma was misplaced
2261 end Check_Test_Case
;
2263 --------------------------------------
2264 -- Check_Valid_Configuration_Pragma --
2265 --------------------------------------
2267 -- A configuration pragma must appear in the context clause of a
2268 -- compilation unit, and only other pragmas may precede it. Note that
2269 -- the test also allows use in a configuration pragma file.
2271 procedure Check_Valid_Configuration_Pragma
is
2273 if not Is_Configuration_Pragma
then
2274 Error_Pragma
("incorrect placement for configuration pragma%");
2276 end Check_Valid_Configuration_Pragma
;
2278 -------------------------------------
2279 -- Check_Valid_Library_Unit_Pragma --
2280 -------------------------------------
2282 procedure Check_Valid_Library_Unit_Pragma
is
2284 Parent_Node
: Node_Id
;
2285 Unit_Name
: Entity_Id
;
2286 Unit_Kind
: Node_Kind
;
2287 Unit_Node
: Node_Id
;
2288 Sindex
: Source_File_Index
;
2291 if not Is_List_Member
(N
) then
2295 Plist
:= List_Containing
(N
);
2296 Parent_Node
:= Parent
(Plist
);
2298 if Parent_Node
= Empty
then
2301 -- Case of pragma appearing after a compilation unit. In this case
2302 -- it must have an argument with the corresponding name and must
2303 -- be part of the following pragmas of its parent.
2305 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
2306 if Plist
/= Pragmas_After
(Parent_Node
) then
2309 elsif Arg_Count
= 0 then
2311 ("argument required if outside compilation unit");
2314 Check_No_Identifiers
;
2315 Check_Arg_Count
(1);
2316 Unit_Node
:= Unit
(Parent
(Parent_Node
));
2317 Unit_Kind
:= Nkind
(Unit_Node
);
2319 Analyze
(Get_Pragma_Arg
(Arg1
));
2321 if Unit_Kind
= N_Generic_Subprogram_Declaration
2322 or else Unit_Kind
= N_Subprogram_Declaration
2324 Unit_Name
:= Defining_Entity
(Unit_Node
);
2326 elsif Unit_Kind
in N_Generic_Instantiation
then
2327 Unit_Name
:= Defining_Entity
(Unit_Node
);
2330 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
2333 if Chars
(Unit_Name
) /=
2334 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
2337 ("pragma% argument is not current unit name", Arg1
);
2340 if Ekind
(Unit_Name
) = E_Package
2341 and then Present
(Renamed_Entity
(Unit_Name
))
2343 Error_Pragma
("pragma% not allowed for renamed package");
2347 -- Pragma appears other than after a compilation unit
2350 -- Here we check for the generic instantiation case and also
2351 -- for the case of processing a generic formal package. We
2352 -- detect these cases by noting that the Sloc on the node
2353 -- does not belong to the current compilation unit.
2355 Sindex
:= Source_Index
(Current_Sem_Unit
);
2357 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
2358 Rewrite
(N
, Make_Null_Statement
(Loc
));
2361 -- If before first declaration, the pragma applies to the
2362 -- enclosing unit, and the name if present must be this name.
2364 elsif Is_Before_First_Decl
(N
, Plist
) then
2365 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
2366 Unit_Kind
:= Nkind
(Unit_Node
);
2368 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
2371 elsif Unit_Kind
= N_Subprogram_Body
2372 and then not Acts_As_Spec
(Unit_Node
)
2376 elsif Nkind
(Parent_Node
) = N_Package_Body
then
2379 elsif Nkind
(Parent_Node
) = N_Package_Specification
2380 and then Plist
= Private_Declarations
(Parent_Node
)
2384 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
2385 or else Nkind
(Parent_Node
) =
2386 N_Generic_Subprogram_Declaration
)
2387 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
2391 elsif Arg_Count
> 0 then
2392 Analyze
(Get_Pragma_Arg
(Arg1
));
2394 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
2396 ("name in pragma% must be enclosing unit", Arg1
);
2399 -- It is legal to have no argument in this context
2405 -- Error if not before first declaration. This is because a
2406 -- library unit pragma argument must be the name of a library
2407 -- unit (RM 10.1.5(7)), but the only names permitted in this
2408 -- context are (RM 10.1.5(6)) names of subprogram declarations,
2409 -- generic subprogram declarations or generic instantiations.
2413 ("pragma% misplaced, must be before first declaration");
2417 end Check_Valid_Library_Unit_Pragma
;
2423 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
2424 Clist
: constant Node_Id
:= Component_List
(Variant
);
2428 if not Is_Non_Empty_List
(Component_Items
(Clist
)) then
2430 ("Unchecked_Union may not have empty component list",
2435 Comp
:= First
(Component_Items
(Clist
));
2436 while Present
(Comp
) loop
2437 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
2446 procedure Error_Pragma
(Msg
: String) is
2447 MsgF
: String := Msg
;
2449 Error_Msg_Name_1
:= Pname
;
2451 Error_Msg_N
(MsgF
, N
);
2455 ----------------------
2456 -- Error_Pragma_Arg --
2457 ----------------------
2459 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
2460 MsgF
: String := Msg
;
2462 Error_Msg_Name_1
:= Pname
;
2464 Error_Msg_N
(MsgF
, Get_Pragma_Arg
(Arg
));
2466 end Error_Pragma_Arg
;
2468 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
2469 MsgF
: String := Msg1
;
2471 Error_Msg_Name_1
:= Pname
;
2473 Error_Msg_N
(MsgF
, Get_Pragma_Arg
(Arg
));
2474 Error_Pragma_Arg
(Msg2
, Arg
);
2475 end Error_Pragma_Arg
;
2477 ----------------------------
2478 -- Error_Pragma_Arg_Ident --
2479 ----------------------------
2481 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
2482 MsgF
: String := Msg
;
2484 Error_Msg_Name_1
:= Pname
;
2486 Error_Msg_N
(MsgF
, Arg
);
2488 end Error_Pragma_Arg_Ident
;
2490 ----------------------
2491 -- Error_Pragma_Ref --
2492 ----------------------
2494 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
2495 MsgF
: String := Msg
;
2497 Error_Msg_Name_1
:= Pname
;
2499 Error_Msg_Sloc
:= Sloc
(Ref
);
2500 Error_Msg_NE
(MsgF
, N
, Ref
);
2502 end Error_Pragma_Ref
;
2504 ------------------------
2505 -- Find_Lib_Unit_Name --
2506 ------------------------
2508 function Find_Lib_Unit_Name
return Entity_Id
is
2510 -- Return inner compilation unit entity, for case of nested
2511 -- categorization pragmas. This happens in generic unit.
2513 if Nkind
(Parent
(N
)) = N_Package_Specification
2514 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
2516 return Defining_Entity
(Parent
(N
));
2518 return Current_Scope
;
2520 end Find_Lib_Unit_Name
;
2522 ----------------------------
2523 -- Find_Program_Unit_Name --
2524 ----------------------------
2526 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
2527 Unit_Name
: Entity_Id
;
2528 Unit_Kind
: Node_Kind
;
2529 P
: constant Node_Id
:= Parent
(N
);
2532 if Nkind
(P
) = N_Compilation_Unit
then
2533 Unit_Kind
:= Nkind
(Unit
(P
));
2535 if Unit_Kind
= N_Subprogram_Declaration
2536 or else Unit_Kind
= N_Package_Declaration
2537 or else Unit_Kind
in N_Generic_Declaration
2539 Unit_Name
:= Defining_Entity
(Unit
(P
));
2541 if Chars
(Id
) = Chars
(Unit_Name
) then
2542 Set_Entity
(Id
, Unit_Name
);
2543 Set_Etype
(Id
, Etype
(Unit_Name
));
2545 Set_Etype
(Id
, Any_Type
);
2547 ("cannot find program unit referenced by pragma%");
2551 Set_Etype
(Id
, Any_Type
);
2552 Error_Pragma
("pragma% inapplicable to this unit");
2558 end Find_Program_Unit_Name
;
2560 -----------------------------------------
2561 -- Find_Unique_Parameterless_Procedure --
2562 -----------------------------------------
2564 function Find_Unique_Parameterless_Procedure
2566 Arg
: Node_Id
) return Entity_Id
2568 Proc
: Entity_Id
:= Empty
;
2571 -- The body of this procedure needs some comments ???
2573 if not Is_Entity_Name
(Name
) then
2575 ("argument of pragma% must be entity name", Arg
);
2577 elsif not Is_Overloaded
(Name
) then
2578 Proc
:= Entity
(Name
);
2580 if Ekind
(Proc
) /= E_Procedure
2581 or else Present
(First_Formal
(Proc
))
2584 ("argument of pragma% must be parameterless procedure", Arg
);
2589 Found
: Boolean := False;
2591 Index
: Interp_Index
;
2594 Get_First_Interp
(Name
, Index
, It
);
2595 while Present
(It
.Nam
) loop
2598 if Ekind
(Proc
) = E_Procedure
2599 and then No
(First_Formal
(Proc
))
2603 Set_Entity
(Name
, Proc
);
2604 Set_Is_Overloaded
(Name
, False);
2607 ("ambiguous handler name for pragma% ", Arg
);
2611 Get_Next_Interp
(Index
, It
);
2616 ("argument of pragma% must be parameterless procedure",
2619 Proc
:= Entity
(Name
);
2625 end Find_Unique_Parameterless_Procedure
;
2631 procedure Fix_Error
(Msg
: in out String) is
2633 if From_Aspect_Specification
(N
) then
2634 for J
in Msg
'First .. Msg
'Last - 5 loop
2635 if Msg
(J
.. J
+ 5) = "pragma" then
2636 Msg
(J
.. J
+ 5) := "aspect";
2640 if Error_Msg_Name_1
= Name_Precondition
then
2641 Error_Msg_Name_1
:= Name_Pre
;
2642 elsif Error_Msg_Name_1
= Name_Postcondition
then
2643 Error_Msg_Name_1
:= Name_Post
;
2648 -------------------------
2649 -- Gather_Associations --
2650 -------------------------
2652 procedure Gather_Associations
2654 Args
: out Args_List
)
2659 -- Initialize all parameters to Empty
2661 for J
in Args
'Range loop
2665 -- That's all we have to do if there are no argument associations
2667 if No
(Pragma_Argument_Associations
(N
)) then
2671 -- Otherwise first deal with any positional parameters present
2673 Arg
:= First
(Pragma_Argument_Associations
(N
));
2674 for Index
in Args
'Range loop
2675 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
2676 Args
(Index
) := Get_Pragma_Arg
(Arg
);
2680 -- Positional parameters all processed, if any left, then we
2681 -- have too many positional parameters.
2683 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
2685 ("too many positional associations for pragma%", Arg
);
2688 -- Process named parameters if any are present
2690 while Present
(Arg
) loop
2691 if Chars
(Arg
) = No_Name
then
2693 ("positional association cannot follow named association",
2697 for Index
in Names
'Range loop
2698 if Names
(Index
) = Chars
(Arg
) then
2699 if Present
(Args
(Index
)) then
2701 ("duplicate argument association for pragma%", Arg
);
2703 Args
(Index
) := Get_Pragma_Arg
(Arg
);
2708 if Index
= Names
'Last then
2709 Error_Msg_Name_1
:= Pname
;
2710 Error_Msg_N
("pragma% does not allow & argument", Arg
);
2712 -- Check for possible misspelling
2714 for Index1
in Names
'Range loop
2715 if Is_Bad_Spelling_Of
2716 (Chars
(Arg
), Names
(Index1
))
2718 Error_Msg_Name_1
:= Names
(Index1
);
2719 Error_Msg_N
-- CODEFIX
2720 ("\possible misspelling of%", Arg
);
2732 end Gather_Associations
;
2738 procedure GNAT_Pragma
is
2740 Check_Restriction
(No_Implementation_Pragmas
, N
);
2743 --------------------------
2744 -- Is_Before_First_Decl --
2745 --------------------------
2747 function Is_Before_First_Decl
2748 (Pragma_Node
: Node_Id
;
2749 Decls
: List_Id
) return Boolean
2751 Item
: Node_Id
:= First
(Decls
);
2754 -- Only other pragmas can come before this pragma
2757 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
2760 elsif Item
= Pragma_Node
then
2766 end Is_Before_First_Decl
;
2768 -----------------------------
2769 -- Is_Configuration_Pragma --
2770 -----------------------------
2772 -- A configuration pragma must appear in the context clause of a
2773 -- compilation unit, and only other pragmas may precede it. Note that
2774 -- the test below also permits use in a configuration pragma file.
2776 function Is_Configuration_Pragma
return Boolean is
2777 Lis
: constant List_Id
:= List_Containing
(N
);
2778 Par
: constant Node_Id
:= Parent
(N
);
2782 -- If no parent, then we are in the configuration pragma file,
2783 -- so the placement is definitely appropriate.
2788 -- Otherwise we must be in the context clause of a compilation unit
2789 -- and the only thing allowed before us in the context list is more
2790 -- configuration pragmas.
2792 elsif Nkind
(Par
) = N_Compilation_Unit
2793 and then Context_Items
(Par
) = Lis
2800 elsif Nkind
(Prg
) /= N_Pragma
then
2810 end Is_Configuration_Pragma
;
2812 --------------------------
2813 -- Is_In_Context_Clause --
2814 --------------------------
2816 function Is_In_Context_Clause
return Boolean is
2818 Parent_Node
: Node_Id
;
2821 if not Is_List_Member
(N
) then
2825 Plist
:= List_Containing
(N
);
2826 Parent_Node
:= Parent
(Plist
);
2828 if Parent_Node
= Empty
2829 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
2830 or else Context_Items
(Parent_Node
) /= Plist
2837 end Is_In_Context_Clause
;
2839 ---------------------------------
2840 -- Is_Static_String_Expression --
2841 ---------------------------------
2843 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
2844 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2847 Analyze_And_Resolve
(Argx
);
2848 return Is_OK_Static_Expression
(Argx
)
2849 and then Nkind
(Argx
) = N_String_Literal
;
2850 end Is_Static_String_Expression
;
2852 ----------------------
2853 -- Pragma_Misplaced --
2854 ----------------------
2856 procedure Pragma_Misplaced
is
2858 Error_Pragma
("incorrect placement of pragma%");
2859 end Pragma_Misplaced
;
2861 ------------------------------------
2862 -- Process Atomic_Shared_Volatile --
2863 ------------------------------------
2865 procedure Process_Atomic_Shared_Volatile
is
2872 procedure Set_Atomic
(E
: Entity_Id
);
2873 -- Set given type as atomic, and if no explicit alignment was given,
2874 -- set alignment to unknown, since back end knows what the alignment
2875 -- requirements are for atomic arrays. Note: this step is necessary
2876 -- for derived types.
2882 procedure Set_Atomic
(E
: Entity_Id
) is
2886 if not Has_Alignment_Clause
(E
) then
2887 Set_Alignment
(E
, Uint_0
);
2891 -- Start of processing for Process_Atomic_Shared_Volatile
2894 Check_Ada_83_Warning
;
2895 Check_No_Identifiers
;
2896 Check_Arg_Count
(1);
2897 Check_Arg_Is_Local_Name
(Arg1
);
2898 E_Id
:= Get_Pragma_Arg
(Arg1
);
2900 if Etype
(E_Id
) = Any_Type
then
2905 D
:= Declaration_Node
(E
);
2908 -- Check duplicate before we chain ourselves!
2910 Check_Duplicate_Pragma
(E
);
2912 -- Now check appropriateness of the entity
2915 if Rep_Item_Too_Early
(E
, N
)
2917 Rep_Item_Too_Late
(E
, N
)
2921 Check_First_Subtype
(Arg1
);
2924 if Prag_Id
/= Pragma_Volatile
then
2926 Set_Atomic
(Underlying_Type
(E
));
2927 Set_Atomic
(Base_Type
(E
));
2930 -- Attribute belongs on the base type. If the view of the type is
2931 -- currently private, it also belongs on the underlying type.
2933 Set_Is_Volatile
(Base_Type
(E
));
2934 Set_Is_Volatile
(Underlying_Type
(E
));
2936 Set_Treat_As_Volatile
(E
);
2937 Set_Treat_As_Volatile
(Underlying_Type
(E
));
2939 elsif K
= N_Object_Declaration
2940 or else (K
= N_Component_Declaration
2941 and then Original_Record_Component
(E
) = E
)
2943 if Rep_Item_Too_Late
(E
, N
) then
2947 if Prag_Id
/= Pragma_Volatile
then
2950 -- If the object declaration has an explicit initialization, a
2951 -- temporary may have to be created to hold the expression, to
2952 -- ensure that access to the object remain atomic.
2954 if Nkind
(Parent
(E
)) = N_Object_Declaration
2955 and then Present
(Expression
(Parent
(E
)))
2957 Set_Has_Delayed_Freeze
(E
);
2960 -- An interesting improvement here. If an object of type X is
2961 -- declared atomic, and the type X is not atomic, that's a
2962 -- pity, since it may not have appropriate alignment etc. We
2963 -- can rescue this in the special case where the object and
2964 -- type are in the same unit by just setting the type as
2965 -- atomic, so that the back end will process it as atomic.
2967 Utyp
:= Underlying_Type
(Etype
(E
));
2970 and then Sloc
(E
) > No_Location
2971 and then Sloc
(Utyp
) > No_Location
2973 Get_Source_File_Index
(Sloc
(E
)) =
2974 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
2976 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
2980 Set_Is_Volatile
(E
);
2981 Set_Treat_As_Volatile
(E
);
2985 ("inappropriate entity for pragma%", Arg1
);
2987 end Process_Atomic_Shared_Volatile
;
2989 -------------------------------------------
2990 -- Process_Compile_Time_Warning_Or_Error --
2991 -------------------------------------------
2993 procedure Process_Compile_Time_Warning_Or_Error
is
2994 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
2997 Check_Arg_Count
(2);
2998 Check_No_Identifiers
;
2999 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
3000 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
3002 if Compile_Time_Known_Value
(Arg1x
) then
3003 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
3005 Str
: constant String_Id
:=
3006 Strval
(Get_Pragma_Arg
(Arg2
));
3007 Len
: constant Int
:= String_Length
(Str
);
3012 Cent
: constant Entity_Id
:=
3013 Cunit_Entity
(Current_Sem_Unit
);
3015 Force
: constant Boolean :=
3016 Prag_Id
= Pragma_Compile_Time_Warning
3018 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
3019 and then (Ekind
(Cent
) /= E_Package
3020 or else not In_Private_Part
(Cent
));
3021 -- Set True if this is the warning case, and we are in the
3022 -- visible part of a package spec, or in a subprogram spec,
3023 -- in which case we want to force the client to see the
3024 -- warning, even though it is not in the main unit.
3027 -- Loop through segments of message separated by line feeds.
3028 -- We output these segments as separate messages with
3029 -- continuation marks for all but the first.
3034 Error_Msg_Strlen
:= 0;
3036 -- Loop to copy characters from argument to error message
3040 exit when Ptr
> Len
;
3041 CC
:= Get_String_Char
(Str
, Ptr
);
3044 -- Ignore wide chars ??? else store character
3046 if In_Character_Range
(CC
) then
3047 C
:= Get_Character
(CC
);
3048 exit when C
= ASCII
.LF
;
3049 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
3050 Error_Msg_String
(Error_Msg_Strlen
) := C
;
3054 -- Here with one line ready to go
3056 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
3058 -- If this is a warning in a spec, then we want clients
3059 -- to see the warning, so mark the message with the
3060 -- special sequence !! to force the warning. In the case
3061 -- of a package spec, we do not force this if we are in
3062 -- the private part of the spec.
3065 if Cont
= False then
3066 Error_Msg_N
("<~!!", Arg1
);
3069 Error_Msg_N
("\<~!!", Arg1
);
3072 -- Error, rather than warning, or in a body, so we do not
3073 -- need to force visibility for client (error will be
3074 -- output in any case, and this is the situation in which
3075 -- we do not want a client to get a warning, since the
3076 -- warning is in the body or the spec private part).
3079 if Cont
= False then
3080 Error_Msg_N
("<~", Arg1
);
3083 Error_Msg_N
("\<~", Arg1
);
3087 exit when Ptr
> Len
;
3092 end Process_Compile_Time_Warning_Or_Error
;
3094 ------------------------
3095 -- Process_Convention --
3096 ------------------------
3098 procedure Process_Convention
3099 (C
: out Convention_Id
;
3100 Ent
: out Entity_Id
)
3106 Comp_Unit
: Unit_Number_Type
;
3108 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
3109 -- Called if we have more than one Export/Import/Convention pragma.
3110 -- This is generally illegal, but we have a special case of allowing
3111 -- Import and Interface to coexist if they specify the convention in
3112 -- a consistent manner. We are allowed to do this, since Interface is
3113 -- an implementation defined pragma, and we choose to do it since we
3114 -- know Rational allows this combination. S is the entity id of the
3115 -- subprogram in question. This procedure also sets the special flag
3116 -- Import_Interface_Present in both pragmas in the case where we do
3117 -- have matching Import and Interface pragmas.
3119 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
3120 -- Set convention in entity E, and also flag that the entity has a
3121 -- convention pragma. If entity is for a private or incomplete type,
3122 -- also set convention and flag on underlying type. This procedure
3123 -- also deals with the special case of C_Pass_By_Copy convention.
3125 -------------------------------
3126 -- Diagnose_Multiple_Pragmas --
3127 -------------------------------
3129 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
3130 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
3134 function Same_Convention
(Decl
: Node_Id
) return Boolean;
3135 -- Decl is a pragma node. This function returns True if this
3136 -- pragma has a first argument that is an identifier with a
3137 -- Chars field corresponding to the Convention_Id C.
3139 function Same_Name
(Decl
: Node_Id
) return Boolean;
3140 -- Decl is a pragma node. This function returns True if this
3141 -- pragma has a second argument that is an identifier with a
3142 -- Chars field that matches the Chars of the current subprogram.
3144 ---------------------
3145 -- Same_Convention --
3146 ---------------------
3148 function Same_Convention
(Decl
: Node_Id
) return Boolean is
3149 Arg1
: constant Node_Id
:=
3150 First
(Pragma_Argument_Associations
(Decl
));
3153 if Present
(Arg1
) then
3155 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
3157 if Nkind
(Arg
) = N_Identifier
3158 and then Is_Convention_Name
(Chars
(Arg
))
3159 and then Get_Convention_Id
(Chars
(Arg
)) = C
3167 end Same_Convention
;
3173 function Same_Name
(Decl
: Node_Id
) return Boolean is
3174 Arg1
: constant Node_Id
:=
3175 First
(Pragma_Argument_Associations
(Decl
));
3183 Arg2
:= Next
(Arg1
);
3190 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
3192 if Nkind
(Arg
) = N_Identifier
3193 and then Chars
(Arg
) = Chars
(S
)
3202 -- Start of processing for Diagnose_Multiple_Pragmas
3207 -- Definitely give message if we have Convention/Export here
3209 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
3212 -- If we have an Import or Export, scan back from pragma to
3213 -- find any previous pragma applying to the same procedure.
3214 -- The scan will be terminated by the start of the list, or
3215 -- hitting the subprogram declaration. This won't allow one
3216 -- pragma to appear in the public part and one in the private
3217 -- part, but that seems very unlikely in practice.
3221 while Present
(Decl
) and then Decl
/= Pdec
loop
3223 -- Look for pragma with same name as us
3225 if Nkind
(Decl
) = N_Pragma
3226 and then Same_Name
(Decl
)
3228 -- Give error if same as our pragma or Export/Convention
3230 if Pragma_Name
(Decl
) = Name_Export
3232 Pragma_Name
(Decl
) = Name_Convention
3234 Pragma_Name
(Decl
) = Pragma_Name
(N
)
3238 -- Case of Import/Interface or the other way round
3240 elsif Pragma_Name
(Decl
) = Name_Interface
3242 Pragma_Name
(Decl
) = Name_Import
3244 -- Here we know that we have Import and Interface. It
3245 -- doesn't matter which way round they are. See if
3246 -- they specify the same convention. If so, all OK,
3247 -- and set special flags to stop other messages
3249 if Same_Convention
(Decl
) then
3250 Set_Import_Interface_Present
(N
);
3251 Set_Import_Interface_Present
(Decl
);
3254 -- If different conventions, special message
3257 Error_Msg_Sloc
:= Sloc
(Decl
);
3259 ("convention differs from that given#", Arg1
);
3269 -- Give message if needed if we fall through those tests
3273 ("at most one Convention/Export/Import pragma is allowed",
3276 end Diagnose_Multiple_Pragmas
;
3278 --------------------------------
3279 -- Set_Convention_From_Pragma --
3280 --------------------------------
3282 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
3284 -- Ada 2005 (AI-430): Check invalid attempt to change convention
3285 -- for an overridden dispatching operation. Technically this is
3286 -- an amendment and should only be done in Ada 2005 mode. However,
3287 -- this is clearly a mistake, since the problem that is addressed
3288 -- by this AI is that there is a clear gap in the RM!
3290 if Is_Dispatching_Operation
(E
)
3291 and then Present
(Overridden_Operation
(E
))
3292 and then C
/= Convention
(Overridden_Operation
(E
))
3295 ("cannot change convention for " &
3296 "overridden dispatching operation",
3300 -- Set the convention
3302 Set_Convention
(E
, C
);
3303 Set_Has_Convention_Pragma
(E
);
3305 if Is_Incomplete_Or_Private_Type
(E
)
3306 and then Present
(Underlying_Type
(E
))
3308 Set_Convention
(Underlying_Type
(E
), C
);
3309 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
3312 -- A class-wide type should inherit the convention of the specific
3313 -- root type (although this isn't specified clearly by the RM).
3315 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
3316 Set_Convention
(Class_Wide_Type
(E
), C
);
3319 -- If the entity is a record type, then check for special case of
3320 -- C_Pass_By_Copy, which is treated the same as C except that the
3321 -- special record flag is set. This convention is only permitted
3322 -- on record types (see AI95-00131).
3324 if Cname
= Name_C_Pass_By_Copy
then
3325 if Is_Record_Type
(E
) then
3326 Set_C_Pass_By_Copy
(Base_Type
(E
));
3327 elsif Is_Incomplete_Or_Private_Type
(E
)
3328 and then Is_Record_Type
(Underlying_Type
(E
))
3330 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
3333 ("C_Pass_By_Copy convention allowed only for record type",
3338 -- If the entity is a derived boolean type, check for the special
3339 -- case of convention C, C++, or Fortran, where we consider any
3340 -- nonzero value to represent true.
3342 if Is_Discrete_Type
(E
)
3343 and then Root_Type
(Etype
(E
)) = Standard_Boolean
3349 C
= Convention_Fortran
)
3351 Set_Nonzero_Is_True
(Base_Type
(E
));
3353 end Set_Convention_From_Pragma
;
3355 -- Start of processing for Process_Convention
3358 Check_At_Least_N_Arguments
(2);
3359 Check_Optional_Identifier
(Arg1
, Name_Convention
);
3360 Check_Arg_Is_Identifier
(Arg1
);
3361 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
3363 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
3364 -- tested again below to set the critical flag).
3366 if Cname
= Name_C_Pass_By_Copy
then
3369 -- Otherwise we must have something in the standard convention list
3371 elsif Is_Convention_Name
(Cname
) then
3372 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
3374 -- In DEC VMS, it seems that there is an undocumented feature that
3375 -- any unrecognized convention is treated as the default, which for
3376 -- us is convention C. It does not seem so terrible to do this
3377 -- unconditionally, silently in the VMS case, and with a warning
3378 -- in the non-VMS case.
3381 if Warn_On_Export_Import
and not OpenVMS_On_Target
then
3383 ("?unrecognized convention name, C assumed",
3384 Get_Pragma_Arg
(Arg1
));
3390 Check_Optional_Identifier
(Arg2
, Name_Entity
);
3391 Check_Arg_Is_Local_Name
(Arg2
);
3393 Id
:= Get_Pragma_Arg
(Arg2
);
3396 if not Is_Entity_Name
(Id
) then
3397 Error_Pragma_Arg
("entity name required", Arg2
);
3402 -- Set entity to return
3406 -- Ada_Pass_By_Copy special checking
3408 if C
= Convention_Ada_Pass_By_Copy
then
3409 if not Is_First_Subtype
(E
) then
3411 ("convention `Ada_Pass_By_Copy` only "
3412 & "allowed for types", Arg2
);
3415 if Is_By_Reference_Type
(E
) then
3417 ("convention `Ada_Pass_By_Copy` not allowed for "
3418 & "by-reference type", Arg1
);
3422 -- Ada_Pass_By_Reference special checking
3424 if C
= Convention_Ada_Pass_By_Reference
then
3425 if not Is_First_Subtype
(E
) then
3427 ("convention `Ada_Pass_By_Reference` only "
3428 & "allowed for types", Arg2
);
3431 if Is_By_Copy_Type
(E
) then
3433 ("convention `Ada_Pass_By_Reference` not allowed for "
3434 & "by-copy type", Arg1
);
3438 -- Go to renamed subprogram if present, since convention applies to
3439 -- the actual renamed entity, not to the renaming entity. If the
3440 -- subprogram is inherited, go to parent subprogram.
3442 if Is_Subprogram
(E
)
3443 and then Present
(Alias
(E
))
3445 if Nkind
(Parent
(Declaration_Node
(E
))) =
3446 N_Subprogram_Renaming_Declaration
3448 if Scope
(E
) /= Scope
(Alias
(E
)) then
3450 ("cannot apply pragma% to non-local entity&#", E
);
3455 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
3456 N_Private_Extension_Declaration
)
3457 and then Scope
(E
) = Scope
(Alias
(E
))
3461 -- Return the parent subprogram the entity was inherited from
3467 -- Check that we are not applying this to a specless body
3469 if Is_Subprogram
(E
)
3470 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
3473 ("pragma% requires separate spec and must come before body");
3476 -- Check that we are not applying this to a named constant
3478 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
3479 Error_Msg_Name_1
:= Pname
;
3481 ("cannot apply pragma% to named constant!",
3482 Get_Pragma_Arg
(Arg2
));
3484 ("\supply appropriate type for&!", Arg2
);
3487 if Ekind
(E
) = E_Enumeration_Literal
then
3488 Error_Pragma
("enumeration literal not allowed for pragma%");
3491 -- Check for rep item appearing too early or too late
3493 if Etype
(E
) = Any_Type
3494 or else Rep_Item_Too_Early
(E
, N
)
3498 elsif Present
(Underlying_Type
(E
)) then
3499 E
:= Underlying_Type
(E
);
3502 if Rep_Item_Too_Late
(E
, N
) then
3506 if Has_Convention_Pragma
(E
) then
3507 Diagnose_Multiple_Pragmas
(E
);
3509 elsif Convention
(E
) = Convention_Protected
3510 or else Ekind
(Scope
(E
)) = E_Protected_Type
3513 ("a protected operation cannot be given a different convention",
3517 -- For Intrinsic, a subprogram is required
3519 if C
= Convention_Intrinsic
3520 and then not Is_Subprogram
(E
)
3521 and then not Is_Generic_Subprogram
(E
)
3524 ("second argument of pragma% must be a subprogram", Arg2
);
3527 -- For Stdcall, a subprogram, variable or subprogram type is required
3529 if C
= Convention_Stdcall
3530 and then not Is_Subprogram
(E
)
3531 and then not Is_Generic_Subprogram
(E
)
3532 and then Ekind
(E
) /= E_Variable
3535 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
3538 ("second argument of pragma% must be subprogram (type)",
3542 if not Is_Subprogram
(E
)
3543 and then not Is_Generic_Subprogram
(E
)
3545 Set_Convention_From_Pragma
(E
);
3548 Check_First_Subtype
(Arg2
);
3549 Set_Convention_From_Pragma
(Base_Type
(E
));
3551 -- For subprograms, we must set the convention on the
3552 -- internally generated directly designated type as well.
3554 if Ekind
(E
) = E_Access_Subprogram_Type
then
3555 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
3559 -- For the subprogram case, set proper convention for all homonyms
3560 -- in same scope and the same declarative part, i.e. the same
3561 -- compilation unit.
3564 Comp_Unit
:= Get_Source_Unit
(E
);
3565 Set_Convention_From_Pragma
(E
);
3567 -- Treat a pragma Import as an implicit body, for GPS use
3569 if Prag_Id
= Pragma_Import
then
3570 Generate_Reference
(E
, Id
, 'b');
3573 -- Loop through the homonyms of the pragma argument's entity
3578 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
3580 -- Do not set the pragma on inherited operations or on formal
3583 if Comes_From_Source
(E1
)
3584 and then Comp_Unit
= Get_Source_Unit
(E1
)
3585 and then not Is_Formal_Subprogram
(E1
)
3586 and then Nkind
(Original_Node
(Parent
(E1
))) /=
3587 N_Full_Type_Declaration
3589 if Present
(Alias
(E1
))
3590 and then Scope
(E1
) /= Scope
(Alias
(E1
))
3593 ("cannot apply pragma% to non-local entity& declared#",
3597 Set_Convention_From_Pragma
(E1
);
3599 if Prag_Id
= Pragma_Import
then
3600 Generate_Reference
(E1
, Id
, 'b');
3604 -- For aspect case, do NOT apply to homonyms
3606 exit when From_Aspect_Specification
(N
);
3609 end Process_Convention
;
3611 ----------------------------------------
3612 -- Process_Disable_Enable_Atomic_Sync --
3613 ----------------------------------------
3615 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
3618 Check_No_Identifiers
;
3619 Check_At_Most_N_Arguments
(1);
3621 -- Modeled internally as
3622 -- pragma Unsuppress (Atomic_Synchronization [,Entity])
3626 Pragma_Identifier
=>
3627 Make_Identifier
(Loc
, Nam
),
3628 Pragma_Argument_Associations
=> New_List
(
3629 Make_Pragma_Argument_Association
(Loc
,
3631 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
3633 if Present
(Arg1
) then
3634 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
3638 end Process_Disable_Enable_Atomic_Sync
;
3640 -----------------------------------------------------
3641 -- Process_Extended_Import_Export_Exception_Pragma --
3642 -----------------------------------------------------
3644 procedure Process_Extended_Import_Export_Exception_Pragma
3645 (Arg_Internal
: Node_Id
;
3646 Arg_External
: Node_Id
;
3654 if not OpenVMS_On_Target
then
3656 ("?pragma% ignored (applies only to Open'V'M'S)");
3659 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
3660 Def_Id
:= Entity
(Arg_Internal
);
3662 if Ekind
(Def_Id
) /= E_Exception
then
3664 ("pragma% must refer to declared exception", Arg_Internal
);
3667 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
3669 if Present
(Arg_Form
) then
3670 Check_Arg_Is_One_Of
(Arg_Form
, Name_Ada
, Name_VMS
);
3673 if Present
(Arg_Form
)
3674 and then Chars
(Arg_Form
) = Name_Ada
3678 Set_Is_VMS_Exception
(Def_Id
);
3679 Set_Exception_Code
(Def_Id
, No_Uint
);
3682 if Present
(Arg_Code
) then
3683 if not Is_VMS_Exception
(Def_Id
) then
3685 ("Code option for pragma% not allowed for Ada case",
3689 Check_Arg_Is_Static_Expression
(Arg_Code
, Any_Integer
);
3690 Code_Val
:= Expr_Value
(Arg_Code
);
3692 if not UI_Is_In_Int_Range
(Code_Val
) then
3694 ("Code option for pragma% must be in 32-bit range",
3698 Set_Exception_Code
(Def_Id
, Code_Val
);
3701 end Process_Extended_Import_Export_Exception_Pragma
;
3703 -------------------------------------------------
3704 -- Process_Extended_Import_Export_Internal_Arg --
3705 -------------------------------------------------
3707 procedure Process_Extended_Import_Export_Internal_Arg
3708 (Arg_Internal
: Node_Id
:= Empty
)
3711 if No
(Arg_Internal
) then
3712 Error_Pragma
("Internal parameter required for pragma%");
3715 if Nkind
(Arg_Internal
) = N_Identifier
then
3718 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
3719 and then (Prag_Id
= Pragma_Import_Function
3721 Prag_Id
= Pragma_Export_Function
)
3727 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
3730 Check_Arg_Is_Local_Name
(Arg_Internal
);
3731 end Process_Extended_Import_Export_Internal_Arg
;
3733 --------------------------------------------------
3734 -- Process_Extended_Import_Export_Object_Pragma --
3735 --------------------------------------------------
3737 procedure Process_Extended_Import_Export_Object_Pragma
3738 (Arg_Internal
: Node_Id
;
3739 Arg_External
: Node_Id
;
3745 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
3746 Def_Id
:= Entity
(Arg_Internal
);
3748 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
3750 ("pragma% must designate an object", Arg_Internal
);
3753 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
3755 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
3758 ("previous Common/Psect_Object applies, pragma % not permitted",
3762 if Rep_Item_Too_Late
(Def_Id
, N
) then
3766 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
3768 if Present
(Arg_Size
) then
3769 Check_Arg_Is_External_Name
(Arg_Size
);
3772 -- Export_Object case
3774 if Prag_Id
= Pragma_Export_Object
then
3775 if not Is_Library_Level_Entity
(Def_Id
) then
3777 ("argument for pragma% must be library level entity",
3781 if Ekind
(Current_Scope
) = E_Generic_Package
then
3782 Error_Pragma
("pragma& cannot appear in a generic unit");
3785 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
3787 ("exported object must have compile time known size",
3791 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
3792 Error_Msg_N
("?duplicate Export_Object pragma", N
);
3794 Set_Exported
(Def_Id
, Arg_Internal
);
3797 -- Import_Object case
3800 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
3802 ("cannot use pragma% for task/protected object",
3806 if Ekind
(Def_Id
) = E_Constant
then
3808 ("cannot import a constant", Arg_Internal
);
3811 if Warn_On_Export_Import
3812 and then Has_Discriminants
(Etype
(Def_Id
))
3815 ("imported value must be initialized?", Arg_Internal
);
3818 if Warn_On_Export_Import
3819 and then Is_Access_Type
(Etype
(Def_Id
))
3822 ("cannot import object of an access type?", Arg_Internal
);
3825 if Warn_On_Export_Import
3826 and then Is_Imported
(Def_Id
)
3829 ("?duplicate Import_Object pragma", N
);
3831 -- Check for explicit initialization present. Note that an
3832 -- initialization generated by the code generator, e.g. for an
3833 -- access type, does not count here.
3835 elsif Present
(Expression
(Parent
(Def_Id
)))
3838 (Original_Node
(Expression
(Parent
(Def_Id
))))
3840 Error_Msg_Sloc
:= Sloc
(Def_Id
);
3842 ("imported entities cannot be initialized (RM B.1(24))",
3843 "\no initialization allowed for & declared#", Arg1
);
3845 Set_Imported
(Def_Id
);
3846 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
3849 end Process_Extended_Import_Export_Object_Pragma
;
3851 ------------------------------------------------------
3852 -- Process_Extended_Import_Export_Subprogram_Pragma --
3853 ------------------------------------------------------
3855 procedure Process_Extended_Import_Export_Subprogram_Pragma
3856 (Arg_Internal
: Node_Id
;
3857 Arg_External
: Node_Id
;
3858 Arg_Parameter_Types
: Node_Id
;
3859 Arg_Result_Type
: Node_Id
:= Empty
;
3860 Arg_Mechanism
: Node_Id
;
3861 Arg_Result_Mechanism
: Node_Id
:= Empty
;
3862 Arg_First_Optional_Parameter
: Node_Id
:= Empty
)
3868 Ambiguous
: Boolean;
3872 function Same_Base_Type
3874 Formal
: Entity_Id
) return Boolean;
3875 -- Determines if Ptype references the type of Formal. Note that only
3876 -- the base types need to match according to the spec. Ptype here is
3877 -- the argument from the pragma, which is either a type name, or an
3878 -- access attribute.
3880 --------------------
3881 -- Same_Base_Type --
3882 --------------------
3884 function Same_Base_Type
3886 Formal
: Entity_Id
) return Boolean
3888 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
3892 -- Case where pragma argument is typ'Access
3894 if Nkind
(Ptype
) = N_Attribute_Reference
3895 and then Attribute_Name
(Ptype
) = Name_Access
3897 Pref
:= Prefix
(Ptype
);
3900 if not Is_Entity_Name
(Pref
)
3901 or else Entity
(Pref
) = Any_Type
3906 -- We have a match if the corresponding argument is of an
3907 -- anonymous access type, and its designated type matches the
3908 -- type of the prefix of the access attribute
3910 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
3911 and then Base_Type
(Entity
(Pref
)) =
3912 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
3914 -- Case where pragma argument is a type name
3919 if not Is_Entity_Name
(Ptype
)
3920 or else Entity
(Ptype
) = Any_Type
3925 -- We have a match if the corresponding argument is of the type
3926 -- given in the pragma (comparing base types)
3928 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
3932 -- Start of processing for
3933 -- Process_Extended_Import_Export_Subprogram_Pragma
3936 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
3940 -- Loop through homonyms (overloadings) of the entity
3942 Hom_Id
:= Entity
(Arg_Internal
);
3943 while Present
(Hom_Id
) loop
3944 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
3946 -- We need a subprogram in the current scope
3948 if not Is_Subprogram
(Def_Id
)
3949 or else Scope
(Def_Id
) /= Current_Scope
3956 -- Pragma cannot apply to subprogram body
3958 if Is_Subprogram
(Def_Id
)
3959 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
3963 ("pragma% requires separate spec"
3964 & " and must come before body");
3967 -- Test result type if given, note that the result type
3968 -- parameter can only be present for the function cases.
3970 if Present
(Arg_Result_Type
)
3971 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
3975 elsif Etype
(Def_Id
) /= Standard_Void_Type
3977 (Pname
= Name_Export_Procedure
3979 Pname
= Name_Import_Procedure
)
3983 -- Test parameter types if given. Note that this parameter
3984 -- has not been analyzed (and must not be, since it is
3985 -- semantic nonsense), so we get it as the parser left it.
3987 elsif Present
(Arg_Parameter_Types
) then
3988 Check_Matching_Types
: declare
3993 Formal
:= First_Formal
(Def_Id
);
3995 if Nkind
(Arg_Parameter_Types
) = N_Null
then
3996 if Present
(Formal
) then
4000 -- A list of one type, e.g. (List) is parsed as
4001 -- a parenthesized expression.
4003 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
4004 and then Paren_Count
(Arg_Parameter_Types
) = 1
4007 or else Present
(Next_Formal
(Formal
))
4012 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
4015 -- A list of more than one type is parsed as a aggregate
4017 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
4018 and then Paren_Count
(Arg_Parameter_Types
) = 0
4020 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
4021 while Present
(Ptype
) or else Present
(Formal
) loop
4024 or else not Same_Base_Type
(Ptype
, Formal
)
4029 Next_Formal
(Formal
);
4034 -- Anything else is of the wrong form
4038 ("wrong form for Parameter_Types parameter",
4039 Arg_Parameter_Types
);
4041 end Check_Matching_Types
;
4044 -- Match is now False if the entry we found did not match
4045 -- either a supplied Parameter_Types or Result_Types argument
4051 -- Ambiguous case, the flag Ambiguous shows if we already
4052 -- detected this and output the initial messages.
4055 if not Ambiguous
then
4057 Error_Msg_Name_1
:= Pname
;
4059 ("pragma% does not uniquely identify subprogram!",
4061 Error_Msg_Sloc
:= Sloc
(Ent
);
4062 Error_Msg_N
("matching subprogram #!", N
);
4066 Error_Msg_Sloc
:= Sloc
(Def_Id
);
4067 Error_Msg_N
("matching subprogram #!", N
);
4072 Hom_Id
:= Homonym
(Hom_Id
);
4075 -- See if we found an entry
4078 if not Ambiguous
then
4079 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
4081 ("pragma% cannot be given for generic subprogram");
4084 ("pragma% does not identify local subprogram");
4091 -- Import pragmas must be for imported entities
4093 if Prag_Id
= Pragma_Import_Function
4095 Prag_Id
= Pragma_Import_Procedure
4097 Prag_Id
= Pragma_Import_Valued_Procedure
4099 if not Is_Imported
(Ent
) then
4101 ("pragma Import or Interface must precede pragma%");
4104 -- Here we have the Export case which can set the entity as exported
4106 -- But does not do so if the specified external name is null, since
4107 -- that is taken as a signal in DEC Ada 83 (with which we want to be
4108 -- compatible) to request no external name.
4110 elsif Nkind
(Arg_External
) = N_String_Literal
4111 and then String_Length
(Strval
(Arg_External
)) = 0
4115 -- In all other cases, set entity as exported
4118 Set_Exported
(Ent
, Arg_Internal
);
4121 -- Special processing for Valued_Procedure cases
4123 if Prag_Id
= Pragma_Import_Valued_Procedure
4125 Prag_Id
= Pragma_Export_Valued_Procedure
4127 Formal
:= First_Formal
(Ent
);
4130 Error_Pragma
("at least one parameter required for pragma%");
4132 elsif Ekind
(Formal
) /= E_Out_Parameter
then
4133 Error_Pragma
("first parameter must have mode out for pragma%");
4136 Set_Is_Valued_Procedure
(Ent
);
4140 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
4142 -- Process Result_Mechanism argument if present. We have already
4143 -- checked that this is only allowed for the function case.
4145 if Present
(Arg_Result_Mechanism
) then
4146 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
4149 -- Process Mechanism parameter if present. Note that this parameter
4150 -- is not analyzed, and must not be analyzed since it is semantic
4151 -- nonsense, so we get it in exactly as the parser left it.
4153 if Present
(Arg_Mechanism
) then
4161 -- A single mechanism association without a formal parameter
4162 -- name is parsed as a parenthesized expression. All other
4163 -- cases are parsed as aggregates, so we rewrite the single
4164 -- parameter case as an aggregate for consistency.
4166 if Nkind
(Arg_Mechanism
) /= N_Aggregate
4167 and then Paren_Count
(Arg_Mechanism
) = 1
4169 Rewrite
(Arg_Mechanism
,
4170 Make_Aggregate
(Sloc
(Arg_Mechanism
),
4171 Expressions
=> New_List
(
4172 Relocate_Node
(Arg_Mechanism
))));
4175 -- Case of only mechanism name given, applies to all formals
4177 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
4178 Formal
:= First_Formal
(Ent
);
4179 while Present
(Formal
) loop
4180 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
4181 Next_Formal
(Formal
);
4184 -- Case of list of mechanism associations given
4187 if Null_Record_Present
(Arg_Mechanism
) then
4189 ("inappropriate form for Mechanism parameter",
4193 -- Deal with positional ones first
4195 Formal
:= First_Formal
(Ent
);
4197 if Present
(Expressions
(Arg_Mechanism
)) then
4198 Mname
:= First
(Expressions
(Arg_Mechanism
));
4199 while Present
(Mname
) loop
4202 ("too many mechanism associations", Mname
);
4205 Set_Mechanism_Value
(Formal
, Mname
);
4206 Next_Formal
(Formal
);
4211 -- Deal with named entries
4213 if Present
(Component_Associations
(Arg_Mechanism
)) then
4214 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
4215 while Present
(Massoc
) loop
4216 Choice
:= First
(Choices
(Massoc
));
4218 if Nkind
(Choice
) /= N_Identifier
4219 or else Present
(Next
(Choice
))
4222 ("incorrect form for mechanism association",
4226 Formal
:= First_Formal
(Ent
);
4230 ("parameter name & not present", Choice
);
4233 if Chars
(Choice
) = Chars
(Formal
) then
4235 (Formal
, Expression
(Massoc
));
4237 -- Set entity on identifier (needed by ASIS)
4239 Set_Entity
(Choice
, Formal
);
4244 Next_Formal
(Formal
);
4254 -- Process First_Optional_Parameter argument if present. We have
4255 -- already checked that this is only allowed for the Import case.
4257 if Present
(Arg_First_Optional_Parameter
) then
4258 if Nkind
(Arg_First_Optional_Parameter
) /= N_Identifier
then
4260 ("first optional parameter must be formal parameter name",
4261 Arg_First_Optional_Parameter
);
4264 Formal
:= First_Formal
(Ent
);
4268 ("specified formal parameter& not found",
4269 Arg_First_Optional_Parameter
);
4272 exit when Chars
(Formal
) =
4273 Chars
(Arg_First_Optional_Parameter
);
4275 Next_Formal
(Formal
);
4278 Set_First_Optional_Parameter
(Ent
, Formal
);
4280 -- Check specified and all remaining formals have right form
4282 while Present
(Formal
) loop
4283 if Ekind
(Formal
) /= E_In_Parameter
then
4285 ("optional formal& is not of mode in!",
4286 Arg_First_Optional_Parameter
, Formal
);
4289 Dval
:= Default_Value
(Formal
);
4293 ("optional formal& does not have default value!",
4294 Arg_First_Optional_Parameter
, Formal
);
4296 elsif Compile_Time_Known_Value_Or_Aggr
(Dval
) then
4301 ("default value for optional formal& is non-static!",
4302 Arg_First_Optional_Parameter
, Formal
);
4306 Set_Is_Optional_Parameter
(Formal
);
4307 Next_Formal
(Formal
);
4310 end Process_Extended_Import_Export_Subprogram_Pragma
;
4312 --------------------------
4313 -- Process_Generic_List --
4314 --------------------------
4316 procedure Process_Generic_List
is
4321 Check_No_Identifiers
;
4322 Check_At_Least_N_Arguments
(1);
4325 while Present
(Arg
) loop
4326 Exp
:= Get_Pragma_Arg
(Arg
);
4329 if not Is_Entity_Name
(Exp
)
4331 (not Is_Generic_Instance
(Entity
(Exp
))
4333 not Is_Generic_Unit
(Entity
(Exp
)))
4336 ("pragma% argument must be name of generic unit/instance",
4342 end Process_Generic_List
;
4344 ------------------------------------
4345 -- Process_Import_Predefined_Type --
4346 ------------------------------------
4348 procedure Process_Import_Predefined_Type
is
4349 Loc
: constant Source_Ptr
:= Sloc
(N
);
4351 Ftyp
: Node_Id
:= Empty
;
4357 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
4360 Elmt
:= First_Elmt
(Predefined_Float_Types
);
4361 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
4365 Ftyp
:= Node
(Elmt
);
4367 if Present
(Ftyp
) then
4369 -- Don't build a derived type declaration, because predefined C
4370 -- types have no declaration anywhere, so cannot really be named.
4371 -- Instead build a full type declaration, starting with an
4372 -- appropriate type definition is built
4374 if Is_Floating_Point_Type
(Ftyp
) then
4375 Def
:= Make_Floating_Point_Definition
(Loc
,
4376 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
4377 Make_Real_Range_Specification
(Loc
,
4378 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
4379 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
4381 -- Should never have a predefined type we cannot handle
4384 raise Program_Error
;
4387 -- Build and insert a Full_Type_Declaration, which will be
4388 -- analyzed as soon as this list entry has been analyzed.
4390 Decl
:= Make_Full_Type_Declaration
(Loc
,
4391 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
4392 Type_Definition
=> Def
);
4394 Insert_After
(N
, Decl
);
4395 Mark_Rewrite_Insertion
(Decl
);
4398 Error_Pragma_Arg
("no matching type found for pragma%",
4401 end Process_Import_Predefined_Type
;
4403 ---------------------------------
4404 -- Process_Import_Or_Interface --
4405 ---------------------------------
4407 procedure Process_Import_Or_Interface
is
4413 Process_Convention
(C
, Def_Id
);
4414 Kill_Size_Check_Code
(Def_Id
);
4415 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
4417 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
4419 -- We do not permit Import to apply to a renaming declaration
4421 if Present
(Renamed_Object
(Def_Id
)) then
4423 ("pragma% not allowed for object renaming", Arg2
);
4425 -- User initialization is not allowed for imported object, but
4426 -- the object declaration may contain a default initialization,
4427 -- that will be discarded. Note that an explicit initialization
4428 -- only counts if it comes from source, otherwise it is simply
4429 -- the code generator making an implicit initialization explicit.
4431 elsif Present
(Expression
(Parent
(Def_Id
)))
4432 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
4434 Error_Msg_Sloc
:= Sloc
(Def_Id
);
4436 ("no initialization allowed for declaration of& #",
4437 "\imported entities cannot be initialized (RM B.1(24))",
4441 Set_Imported
(Def_Id
);
4442 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
4444 -- Note that we do not set Is_Public here. That's because we
4445 -- only want to set it if there is no address clause, and we
4446 -- don't know that yet, so we delay that processing till
4449 -- pragma Import completes deferred constants
4451 if Ekind
(Def_Id
) = E_Constant
then
4452 Set_Has_Completion
(Def_Id
);
4455 -- It is not possible to import a constant of an unconstrained
4456 -- array type (e.g. string) because there is no simple way to
4457 -- write a meaningful subtype for it.
4459 if Is_Array_Type
(Etype
(Def_Id
))
4460 and then not Is_Constrained
(Etype
(Def_Id
))
4463 ("imported constant& must have a constrained subtype",
4468 elsif Is_Subprogram
(Def_Id
)
4469 or else Is_Generic_Subprogram
(Def_Id
)
4471 -- If the name is overloaded, pragma applies to all of the denoted
4472 -- entities in the same declarative part.
4475 while Present
(Hom_Id
) loop
4476 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
4478 -- Ignore inherited subprograms because the pragma will apply
4479 -- to the parent operation, which is the one called.
4481 if Is_Overloadable
(Def_Id
)
4482 and then Present
(Alias
(Def_Id
))
4486 -- If it is not a subprogram, it must be in an outer scope and
4487 -- pragma does not apply.
4489 elsif not Is_Subprogram
(Def_Id
)
4490 and then not Is_Generic_Subprogram
(Def_Id
)
4494 -- The pragma does not apply to primitives of interfaces
4496 elsif Is_Dispatching_Operation
(Def_Id
)
4497 and then Present
(Find_Dispatching_Type
(Def_Id
))
4498 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
4502 -- Verify that the homonym is in the same declarative part (not
4503 -- just the same scope).
4505 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
4506 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
4511 Set_Imported
(Def_Id
);
4513 -- Reject an Import applied to an abstract subprogram
4515 if Is_Subprogram
(Def_Id
)
4516 and then Is_Abstract_Subprogram
(Def_Id
)
4518 Error_Msg_Sloc
:= Sloc
(Def_Id
);
4520 ("cannot import abstract subprogram& declared#",
4524 -- Special processing for Convention_Intrinsic
4526 if C
= Convention_Intrinsic
then
4528 -- Link_Name argument not allowed for intrinsic
4532 Set_Is_Intrinsic_Subprogram
(Def_Id
);
4534 -- If no external name is present, then check that this
4535 -- is a valid intrinsic subprogram. If an external name
4536 -- is present, then this is handled by the back end.
4539 Check_Intrinsic_Subprogram
4540 (Def_Id
, Get_Pragma_Arg
(Arg2
));
4544 -- All interfaced procedures need an external symbol created
4545 -- for them since they are always referenced from another
4548 Set_Is_Public
(Def_Id
);
4550 -- Verify that the subprogram does not have a completion
4551 -- through a renaming declaration. For other completions the
4552 -- pragma appears as a too late representation.
4555 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
4559 and then Nkind
(Decl
) = N_Subprogram_Declaration
4560 and then Present
(Corresponding_Body
(Decl
))
4561 and then Nkind
(Unit_Declaration_Node
4562 (Corresponding_Body
(Decl
))) =
4563 N_Subprogram_Renaming_Declaration
4565 Error_Msg_Sloc
:= Sloc
(Def_Id
);
4567 ("cannot import&, renaming already provided for " &
4568 "declaration #", N
, Def_Id
);
4572 Set_Has_Completion
(Def_Id
);
4573 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
4576 if Is_Compilation_Unit
(Hom_Id
) then
4578 -- Its possible homonyms are not affected by the pragma.
4579 -- Such homonyms might be present in the context of other
4580 -- units being compiled.
4585 Hom_Id
:= Homonym
(Hom_Id
);
4589 -- When the convention is Java or CIL, we also allow Import to be
4590 -- given for packages, generic packages, exceptions, record
4591 -- components, and access to subprograms.
4593 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
4595 (Is_Package_Or_Generic_Package
(Def_Id
)
4596 or else Ekind
(Def_Id
) = E_Exception
4597 or else Ekind
(Def_Id
) = E_Access_Subprogram_Type
4598 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
4600 Set_Imported
(Def_Id
);
4601 Set_Is_Public
(Def_Id
);
4602 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
4604 -- Import a CPP class
4606 elsif Is_Record_Type
(Def_Id
)
4607 and then C
= Convention_CPP
4609 -- Types treated as CPP classes must be declared limited (note:
4610 -- this used to be a warning but there is no real benefit to it
4611 -- since we did effectively intend to treat the type as limited
4614 if not Is_Limited_Type
(Def_Id
) then
4616 ("imported 'C'P'P type must be limited",
4617 Get_Pragma_Arg
(Arg2
));
4620 Set_Is_CPP_Class
(Def_Id
);
4622 -- Imported CPP types must not have discriminants (because C++
4623 -- classes do not have discriminants).
4625 if Has_Discriminants
(Def_Id
) then
4627 ("imported 'C'P'P type cannot have discriminants",
4628 First
(Discriminant_Specifications
4629 (Declaration_Node
(Def_Id
))));
4632 -- Components of imported CPP types must not have default
4633 -- expressions because the constructor (if any) is on the
4637 Tdef
: constant Node_Id
:=
4638 Type_Definition
(Declaration_Node
(Def_Id
));
4643 if Nkind
(Tdef
) = N_Record_Definition
then
4644 Clist
:= Component_List
(Tdef
);
4647 pragma Assert
(Nkind
(Tdef
) = N_Derived_Type_Definition
);
4648 Clist
:= Component_List
(Record_Extension_Part
(Tdef
));
4651 if Present
(Clist
) then
4652 Comp
:= First
(Component_Items
(Clist
));
4653 while Present
(Comp
) loop
4654 if Present
(Expression
(Comp
)) then
4656 ("component of imported 'C'P'P type cannot have" &
4657 " default expression", Expression
(Comp
));
4665 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
4667 Check_Arg_Count
(3);
4668 Check_Arg_Is_Static_Expression
(Arg3
, Standard_String
);
4670 Process_Import_Predefined_Type
;
4674 ("second argument of pragma% must be object, subprogram" &
4675 " or incomplete type",
4679 -- If this pragma applies to a compilation unit, then the unit, which
4680 -- is a subprogram, does not require (or allow) a body. We also do
4681 -- not need to elaborate imported procedures.
4683 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
4685 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
4687 Set_Body_Required
(Cunit
, False);
4690 end Process_Import_Or_Interface
;
4692 --------------------
4693 -- Process_Inline --
4694 --------------------
4696 procedure Process_Inline
(Active
: Boolean) is
4703 Effective
: Boolean := False;
4704 -- Set True if inline has some effect, i.e. if there is at least one
4705 -- subprogram set as inlined as a result of the use of the pragma.
4707 procedure Make_Inline
(Subp
: Entity_Id
);
4708 -- Subp is the defining unit name of the subprogram declaration. Set
4709 -- the flag, as well as the flag in the corresponding body, if there
4712 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
4713 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
4714 -- Has_Pragma_Inline_Always for the Inline_Always case.
4716 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
4717 -- Returns True if it can be determined at this stage that inlining
4718 -- is not possible, for example if the body is available and contains
4719 -- exception handlers, we prevent inlining, since otherwise we can
4720 -- get undefined symbols at link time. This function also emits a
4721 -- warning if front-end inlining is enabled and the pragma appears
4724 -- ??? is business with link symbols still valid, or does it relate
4725 -- to front end ZCX which is being phased out ???
4727 ---------------------------
4728 -- Inlining_Not_Possible --
4729 ---------------------------
4731 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
4732 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
4736 if Nkind
(Decl
) = N_Subprogram_Body
then
4737 Stats
:= Handled_Statement_Sequence
(Decl
);
4738 return Present
(Exception_Handlers
(Stats
))
4739 or else Present
(At_End_Proc
(Stats
));
4741 elsif Nkind
(Decl
) = N_Subprogram_Declaration
4742 and then Present
(Corresponding_Body
(Decl
))
4744 if Front_End_Inlining
4745 and then Analyzed
(Corresponding_Body
(Decl
))
4747 Error_Msg_N
("pragma appears too late, ignored?", N
);
4750 -- If the subprogram is a renaming as body, the body is just a
4751 -- call to the renamed subprogram, and inlining is trivially
4755 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
4756 N_Subprogram_Renaming_Declaration
4762 Handled_Statement_Sequence
4763 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
4766 Present
(Exception_Handlers
(Stats
))
4767 or else Present
(At_End_Proc
(Stats
));
4771 -- If body is not available, assume the best, the check is
4772 -- performed again when compiling enclosing package bodies.
4776 end Inlining_Not_Possible
;
4782 procedure Make_Inline
(Subp
: Entity_Id
) is
4783 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
4784 Inner_Subp
: Entity_Id
:= Subp
;
4787 -- Ignore if bad type, avoid cascaded error
4789 if Etype
(Subp
) = Any_Type
then
4793 -- Ignore if all inlining is suppressed
4795 elsif Suppress_All_Inlining
then
4799 -- If inlining is not possible, for now do not treat as an error
4801 elsif Inlining_Not_Possible
(Subp
) then
4805 -- Here we have a candidate for inlining, but we must exclude
4806 -- derived operations. Otherwise we would end up trying to inline
4807 -- a phantom declaration, and the result would be to drag in a
4808 -- body which has no direct inlining associated with it. That
4809 -- would not only be inefficient but would also result in the
4810 -- backend doing cross-unit inlining in cases where it was
4811 -- definitely inappropriate to do so.
4813 -- However, a simple Comes_From_Source test is insufficient, since
4814 -- we do want to allow inlining of generic instances which also do
4815 -- not come from source. We also need to recognize specs generated
4816 -- by the front-end for bodies that carry the pragma. Finally,
4817 -- predefined operators do not come from source but are not
4818 -- inlineable either.
4820 elsif Is_Generic_Instance
(Subp
)
4821 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
4825 elsif not Comes_From_Source
(Subp
)
4826 and then Scope
(Subp
) /= Standard_Standard
4832 -- The referenced entity must either be the enclosing entity, or
4833 -- an entity declared within the current open scope.
4835 if Present
(Scope
(Subp
))
4836 and then Scope
(Subp
) /= Current_Scope
4837 and then Subp
/= Current_Scope
4840 ("argument of% must be entity in current scope", Assoc
);
4844 -- Processing for procedure, operator or function. If subprogram
4845 -- is aliased (as for an instance) indicate that the renamed
4846 -- entity (if declared in the same unit) is inlined.
4848 if Is_Subprogram
(Subp
) then
4849 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
4851 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
4852 Set_Inline_Flags
(Inner_Subp
);
4854 Decl
:= Parent
(Parent
(Inner_Subp
));
4856 if Nkind
(Decl
) = N_Subprogram_Declaration
4857 and then Present
(Corresponding_Body
(Decl
))
4859 Set_Inline_Flags
(Corresponding_Body
(Decl
));
4861 elsif Is_Generic_Instance
(Subp
) then
4863 -- Indicate that the body needs to be created for
4864 -- inlining subsequent calls. The instantiation node
4865 -- follows the declaration of the wrapper package
4868 if Scope
(Subp
) /= Standard_Standard
4870 Need_Subprogram_Instance_Body
4871 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
4877 -- Inline is a program unit pragma (RM 10.1.5) and cannot
4878 -- appear in a formal part to apply to a formal subprogram.
4879 -- Do not apply check within an instance or a formal package
4880 -- the test will have been applied to the original generic.
4882 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
4883 and then List_Containing
(Decl
) = List_Containing
(N
)
4884 and then not In_Instance
4887 ("Inline cannot apply to a formal subprogram", N
);
4893 -- For a generic subprogram set flag as well, for use at the point
4894 -- of instantiation, to determine whether the body should be
4897 elsif Is_Generic_Subprogram
(Subp
) then
4898 Set_Inline_Flags
(Subp
);
4901 -- Literals are by definition inlined
4903 elsif Kind
= E_Enumeration_Literal
then
4906 -- Anything else is an error
4910 ("expect subprogram name for pragma%", Assoc
);
4914 ----------------------
4915 -- Set_Inline_Flags --
4916 ----------------------
4918 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
4921 Set_Is_Inlined
(Subp
);
4924 if not Has_Pragma_Inline
(Subp
) then
4925 Set_Has_Pragma_Inline
(Subp
);
4929 if Prag_Id
= Pragma_Inline_Always
then
4930 Set_Has_Pragma_Inline_Always
(Subp
);
4932 end Set_Inline_Flags
;
4934 -- Start of processing for Process_Inline
4937 Check_No_Identifiers
;
4938 Check_At_Least_N_Arguments
(1);
4941 Inline_Processing_Required
:= True;
4945 while Present
(Assoc
) loop
4946 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
4950 if Is_Entity_Name
(Subp_Id
) then
4951 Subp
:= Entity
(Subp_Id
);
4953 if Subp
= Any_Id
then
4955 -- If previous error, avoid cascaded errors
4963 -- For the pragma case, climb homonym chain. This is
4964 -- what implements allowing the pragma in the renaming
4965 -- case, with the result applying to the ancestors, and
4966 -- also allows Inline to apply to all previous homonyms.
4968 if not From_Aspect_Specification
(N
) then
4969 while Present
(Homonym
(Subp
))
4970 and then Scope
(Homonym
(Subp
)) = Current_Scope
4972 Make_Inline
(Homonym
(Subp
));
4973 Subp
:= Homonym
(Subp
);
4981 ("inappropriate argument for pragma%", Assoc
);
4984 and then Warn_On_Redundant_Constructs
4985 and then not Suppress_All_Inlining
4987 if Inlining_Not_Possible
(Subp
) then
4989 ("pragma Inline for& is ignored?", N
, Entity
(Subp_Id
));
4992 ("pragma Inline for& is redundant?", N
, Entity
(Subp_Id
));
5000 ----------------------------
5001 -- Process_Interface_Name --
5002 ----------------------------
5004 procedure Process_Interface_Name
5005 (Subprogram_Def
: Entity_Id
;
5011 String_Val
: String_Id
;
5013 procedure Check_Form_Of_Interface_Name
5015 Ext_Name_Case
: Boolean);
5016 -- SN is a string literal node for an interface name. This routine
5017 -- performs some minimal checks that the name is reasonable. In
5018 -- particular that no spaces or other obviously incorrect characters
5019 -- appear. This is only a warning, since any characters are allowed.
5020 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
5022 ----------------------------------
5023 -- Check_Form_Of_Interface_Name --
5024 ----------------------------------
5026 procedure Check_Form_Of_Interface_Name
5028 Ext_Name_Case
: Boolean)
5030 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
5031 SL
: constant Nat
:= String_Length
(S
);
5036 Error_Msg_N
("interface name cannot be null string", SN
);
5039 for J
in 1 .. SL
loop
5040 C
:= Get_String_Char
(S
, J
);
5042 -- Look for dubious character and issue unconditional warning.
5043 -- Definitely dubious if not in character range.
5045 if not In_Character_Range
(C
)
5047 -- For all cases except CLI target,
5048 -- commas, spaces and slashes are dubious (in CLI, we use
5049 -- commas and backslashes in external names to specify
5050 -- assembly version and public key, while slashes and spaces
5051 -- can be used in names to mark nested classes and
5054 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
5055 and then (Get_Character
(C
) = ','
5057 Get_Character
(C
) = '\'))
5058 or else (VM_Target
/= CLI_Target
5059 and then (Get_Character
(C
) = ' '
5061 Get_Character
(C
) = '/'))
5064 ("?interface name contains illegal character",
5065 Sloc
(SN
) + Source_Ptr
(J
));
5068 end Check_Form_Of_Interface_Name
;
5070 -- Start of processing for Process_Interface_Name
5073 if No
(Link_Arg
) then
5074 if No
(Ext_Arg
) then
5075 if VM_Target
= CLI_Target
5076 and then Ekind
(Subprogram_Def
) = E_Package
5077 and then Nkind
(Parent
(Subprogram_Def
)) =
5078 N_Package_Specification
5079 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
5084 (Generic_Parent
(Parent
(Subprogram_Def
))));
5089 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
5091 Link_Nam
:= Expression
(Ext_Arg
);
5094 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
5095 Ext_Nam
:= Expression
(Ext_Arg
);
5100 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
5101 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
5102 Ext_Nam
:= Expression
(Ext_Arg
);
5103 Link_Nam
:= Expression
(Link_Arg
);
5106 -- Check expressions for external name and link name are static
5108 if Present
(Ext_Nam
) then
5109 Check_Arg_Is_Static_Expression
(Ext_Nam
, Standard_String
);
5110 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
5112 -- Verify that external name is not the name of a local entity,
5113 -- which would hide the imported one and could lead to run-time
5114 -- surprises. The problem can only arise for entities declared in
5115 -- a package body (otherwise the external name is fully qualified
5116 -- and will not conflict).
5124 if Prag_Id
= Pragma_Import
then
5125 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
5127 E
:= Entity_Id
(Get_Name_Table_Info
(Nam
));
5129 if Nam
/= Chars
(Subprogram_Def
)
5130 and then Present
(E
)
5131 and then not Is_Overloadable
(E
)
5132 and then Is_Immediately_Visible
(E
)
5133 and then not Is_Imported
(E
)
5134 and then Ekind
(Scope
(E
)) = E_Package
5137 while Present
(Par
) loop
5138 if Nkind
(Par
) = N_Package_Body
then
5139 Error_Msg_Sloc
:= Sloc
(E
);
5141 ("imported entity is hidden by & declared#",
5146 Par
:= Parent
(Par
);
5153 if Present
(Link_Nam
) then
5154 Check_Arg_Is_Static_Expression
(Link_Nam
, Standard_String
);
5155 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
5158 -- If there is no link name, just set the external name
5160 if No
(Link_Nam
) then
5161 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
5163 -- For the Link_Name case, the given literal is preceded by an
5164 -- asterisk, which indicates to GCC that the given name should be
5165 -- taken literally, and in particular that no prepending of
5166 -- underlines should occur, even in systems where this is the
5172 if VM_Target
= No_VM
then
5173 Store_String_Char
(Get_Char_Code
('*'));
5176 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
5177 Store_String_Chars
(String_Val
);
5179 Make_String_Literal
(Sloc
(Link_Nam
),
5180 Strval
=> End_String
);
5183 -- Set the interface name. If the entity is a generic instance, use
5184 -- its alias, which is the callable entity.
5186 if Is_Generic_Instance
(Subprogram_Def
) then
5187 Set_Encoded_Interface_Name
5188 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
5190 Set_Encoded_Interface_Name
5191 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
5194 -- We allow duplicated export names in CIL/Java, as they are always
5195 -- enclosed in a namespace that differentiates them, and overloaded
5196 -- entities are supported by the VM.
5198 if Convention
(Subprogram_Def
) /= Convention_CIL
5200 Convention
(Subprogram_Def
) /= Convention_Java
5202 Check_Duplicated_Export_Name
(Link_Nam
);
5204 end Process_Interface_Name
;
5206 -----------------------------------------
5207 -- Process_Interrupt_Or_Attach_Handler --
5208 -----------------------------------------
5210 procedure Process_Interrupt_Or_Attach_Handler
is
5211 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5212 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
5213 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
5216 Set_Is_Interrupt_Handler
(Handler_Proc
);
5218 -- If the pragma is not associated with a handler procedure within a
5219 -- protected type, then it must be for a nonprotected procedure for
5220 -- the AAMP target, in which case we don't associate a representation
5221 -- item with the procedure's scope.
5223 if Ekind
(Proc_Scope
) = E_Protected_Type
then
5224 if Prag_Id
= Pragma_Interrupt_Handler
5226 Prag_Id
= Pragma_Attach_Handler
5228 Record_Rep_Item
(Proc_Scope
, N
);
5231 end Process_Interrupt_Or_Attach_Handler
;
5233 --------------------------------------------------
5234 -- Process_Restrictions_Or_Restriction_Warnings --
5235 --------------------------------------------------
5237 -- Note: some of the simple identifier cases were handled in par-prag,
5238 -- but it is harmless (and more straightforward) to simply handle all
5239 -- cases here, even if it means we repeat a bit of work in some cases.
5241 procedure Process_Restrictions_Or_Restriction_Warnings
5245 R_Id
: Restriction_Id
;
5250 procedure Check_Unit_Name
(N
: Node_Id
);
5251 -- Checks unit name parameter for No_Dependence. Returns if it has
5252 -- an appropriate form, otherwise raises pragma argument error.
5254 ---------------------
5255 -- Check_Unit_Name --
5256 ---------------------
5258 procedure Check_Unit_Name
(N
: Node_Id
) is
5260 if Nkind
(N
) = N_Selected_Component
then
5261 Check_Unit_Name
(Prefix
(N
));
5262 Check_Unit_Name
(Selector_Name
(N
));
5264 elsif Nkind
(N
) = N_Identifier
then
5269 ("wrong form for unit name for No_Dependence", N
);
5271 end Check_Unit_Name
;
5273 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
5276 -- Ignore all Restrictions pragma in CodePeer mode
5278 if CodePeer_Mode
then
5282 Check_Ada_83_Warning
;
5283 Check_At_Least_N_Arguments
(1);
5284 Check_Valid_Configuration_Pragma
;
5287 while Present
(Arg
) loop
5289 Expr
:= Get_Pragma_Arg
(Arg
);
5291 -- Case of no restriction identifier present
5293 if Id
= No_Name
then
5294 if Nkind
(Expr
) /= N_Identifier
then
5296 ("invalid form for restriction", Arg
);
5301 (Process_Restriction_Synonyms
(Expr
));
5303 if R_Id
not in All_Boolean_Restrictions
then
5304 Error_Msg_Name_1
:= Pname
;
5306 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
5308 -- Check for possible misspelling
5310 for J
in Restriction_Id
loop
5312 Rnm
: constant String := Restriction_Id
'Image (J
);
5315 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
5316 Name_Len
:= Rnm
'Length;
5317 Set_Casing
(All_Lower_Case
);
5319 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
5321 (Identifier_Casing
(Current_Source_File
));
5322 Error_Msg_String
(1 .. Rnm
'Length) :=
5323 Name_Buffer
(1 .. Name_Len
);
5324 Error_Msg_Strlen
:= Rnm
'Length;
5325 Error_Msg_N
-- CODEFIX
5326 ("\possible misspelling of ""~""",
5327 Get_Pragma_Arg
(Arg
));
5336 if Implementation_Restriction
(R_Id
) then
5337 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
5340 -- If this is a warning, then set the warning unless we already
5341 -- have a real restriction active (we never want a warning to
5342 -- override a real restriction).
5345 if not Restriction_Active
(R_Id
) then
5346 Set_Restriction
(R_Id
, N
);
5347 Restriction_Warnings
(R_Id
) := True;
5350 -- If real restriction case, then set it and make sure that the
5351 -- restriction warning flag is off, since a real restriction
5352 -- always overrides a warning.
5355 Set_Restriction
(R_Id
, N
);
5356 Restriction_Warnings
(R_Id
) := False;
5359 -- Check for obsolescent restrictions in Ada 2005 mode
5362 and then Ada_Version
>= Ada_2005
5363 and then (R_Id
= No_Asynchronous_Control
5365 R_Id
= No_Unchecked_Deallocation
5367 R_Id
= No_Unchecked_Conversion
)
5369 Check_Restriction
(No_Obsolescent_Features
, N
);
5372 -- A very special case that must be processed here: pragma
5373 -- Restrictions (No_Exceptions) turns off all run-time
5374 -- checking. This is a bit dubious in terms of the formal
5375 -- language definition, but it is what is intended by RM
5376 -- H.4(12). Restriction_Warnings never affects generated code
5377 -- so this is done only in the real restriction case.
5379 -- Atomic_Synchronization is not a real check, so it is not
5380 -- affected by this processing).
5382 if R_Id
= No_Exceptions
and then not Warn
then
5383 for J
in Scope_Suppress
'Range loop
5384 if J
/= Atomic_Synchronization
then
5385 Scope_Suppress
(J
) := True;
5390 -- Case of No_Dependence => unit-name. Note that the parser
5391 -- already made the necessary entry in the No_Dependence table.
5393 elsif Id
= Name_No_Dependence
then
5394 Check_Unit_Name
(Expr
);
5396 -- Case of No_Specification_Of_Aspect => Identifier.
5398 elsif Id
= Name_No_Specification_Of_Aspect
then
5403 if Nkind
(Expr
) /= N_Identifier
then
5406 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
5409 if A_Id
= No_Aspect
then
5410 Error_Pragma_Arg
("invalid restriction name", Arg
);
5412 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
5416 -- All other cases of restriction identifier present
5419 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
5420 Analyze_And_Resolve
(Expr
, Any_Integer
);
5422 if R_Id
not in All_Parameter_Restrictions
then
5424 ("invalid restriction parameter identifier", Arg
);
5426 elsif not Is_OK_Static_Expression
(Expr
) then
5427 Flag_Non_Static_Expr
5428 ("value must be static expression!", Expr
);
5431 elsif not Is_Integer_Type
(Etype
(Expr
))
5432 or else Expr_Value
(Expr
) < 0
5435 ("value must be non-negative integer", Arg
);
5438 -- Restriction pragma is active
5440 Val
:= Expr_Value
(Expr
);
5442 if not UI_Is_In_Int_Range
(Val
) then
5444 ("pragma ignored, value too large?", Arg
);
5447 -- Warning case. If the real restriction is active, then we
5448 -- ignore the request, since warning never overrides a real
5449 -- restriction. Otherwise we set the proper warning. Note that
5450 -- this circuit sets the warning again if it is already set,
5451 -- which is what we want, since the constant may have changed.
5454 if not Restriction_Active
(R_Id
) then
5456 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
5457 Restriction_Warnings
(R_Id
) := True;
5460 -- Real restriction case, set restriction and make sure warning
5461 -- flag is off since real restriction always overrides warning.
5464 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
5465 Restriction_Warnings
(R_Id
) := False;
5471 end Process_Restrictions_Or_Restriction_Warnings
;
5473 ---------------------------------
5474 -- Process_Suppress_Unsuppress --
5475 ---------------------------------
5477 -- Note: this procedure makes entries in the check suppress data
5478 -- structures managed by Sem. See spec of package Sem for full
5479 -- details on how we handle recording of check suppression.
5481 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
5486 In_Package_Spec
: constant Boolean :=
5487 Is_Package_Or_Generic_Package
(Current_Scope
)
5488 and then not In_Package_Body
(Current_Scope
);
5490 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
5491 -- Used to suppress a single check on the given entity
5493 --------------------------------
5494 -- Suppress_Unsuppress_Echeck --
5495 --------------------------------
5497 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
5499 -- Check for error of trying to set atomic synchronization for
5500 -- a non-atomic variable.
5502 if C
= Atomic_Synchronization
5503 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
5506 ("pragma & requires atomic type or variable",
5507 Pragma_Identifier
(Original_Node
(N
)));
5510 Set_Checks_May_Be_Suppressed
(E
);
5512 if In_Package_Spec
then
5513 Push_Global_Suppress_Stack_Entry
5516 Suppress
=> Suppress_Case
);
5518 Push_Local_Suppress_Stack_Entry
5521 Suppress
=> Suppress_Case
);
5524 -- If this is a first subtype, and the base type is distinct,
5525 -- then also set the suppress flags on the base type.
5527 if Is_First_Subtype
(E
)
5528 and then Etype
(E
) /= E
5530 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
5532 end Suppress_Unsuppress_Echeck
;
5534 -- Start of processing for Process_Suppress_Unsuppress
5537 -- Ignore pragma Suppress/Unsuppress in CodePeer and Alfa modes on
5538 -- user code: we want to generate checks for analysis purposes, as
5539 -- set respectively by -gnatC and -gnatd.F
5541 if (CodePeer_Mode
or Alfa_Mode
)
5542 and then Comes_From_Source
(N
)
5547 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
5548 -- declarative part or a package spec (RM 11.5(5)).
5550 if not Is_Configuration_Pragma
then
5551 Check_Is_In_Decl_Part_Or_Package_Spec
;
5554 Check_At_Least_N_Arguments
(1);
5555 Check_At_Most_N_Arguments
(2);
5556 Check_No_Identifier
(Arg1
);
5557 Check_Arg_Is_Identifier
(Arg1
);
5559 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
5561 if C
= No_Check_Id
then
5563 ("argument of pragma% is not valid check name", Arg1
);
5566 if not Suppress_Case
5567 and then (C
= All_Checks
or else C
= Overflow_Check
)
5569 Opt
.Overflow_Checks_Unsuppressed
:= True;
5572 if Arg_Count
= 1 then
5574 -- Make an entry in the local scope suppress table. This is the
5575 -- table that directly shows the current value of the scope
5576 -- suppress check for any check id value.
5578 if C
= All_Checks
then
5580 -- For All_Checks, we set all specific predefined checks with
5581 -- the exception of Elaboration_Check, which is handled
5582 -- specially because of not wanting All_Checks to have the
5583 -- effect of deactivating static elaboration order processing.
5584 -- Atomic_Synchronization is also not affected, since this is
5585 -- not a real check.
5587 for J
in Scope_Suppress
'Range loop
5588 if J
/= Elaboration_Check
5589 and then J
/= Atomic_Synchronization
5591 Scope_Suppress
(J
) := Suppress_Case
;
5595 -- If not All_Checks, and predefined check, then set appropriate
5596 -- scope entry. Note that we will set Elaboration_Check if this
5597 -- is explicitly specified. Atomic_Synchronization is allowed
5598 -- only if internally generated and entity is atomic.
5600 elsif C
in Predefined_Check_Id
5601 and then (not Comes_From_Source
(N
)
5602 or else C
/= Atomic_Synchronization
)
5604 Scope_Suppress
(C
) := Suppress_Case
;
5607 -- Also make an entry in the Local_Entity_Suppress table
5609 Push_Local_Suppress_Stack_Entry
5612 Suppress
=> Suppress_Case
);
5614 -- Case of two arguments present, where the check is suppressed for
5615 -- a specified entity (given as the second argument of the pragma)
5618 -- This is obsolescent in Ada 2005 mode
5620 if Ada_Version
>= Ada_2005
then
5621 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
5624 Check_Optional_Identifier
(Arg2
, Name_On
);
5625 E_Id
:= Get_Pragma_Arg
(Arg2
);
5628 if not Is_Entity_Name
(E_Id
) then
5630 ("second argument of pragma% must be entity name", Arg2
);
5639 -- Enforce RM 11.5(7) which requires that for a pragma that
5640 -- appears within a package spec, the named entity must be
5641 -- within the package spec. We allow the package name itself
5642 -- to be mentioned since that makes sense, although it is not
5643 -- strictly allowed by 11.5(7).
5646 and then E
/= Current_Scope
5647 and then Scope
(E
) /= Current_Scope
5650 ("entity in pragma% is not in package spec (RM 11.5(7))",
5654 -- Loop through homonyms. As noted below, in the case of a package
5655 -- spec, only homonyms within the package spec are considered.
5658 Suppress_Unsuppress_Echeck
(E
, C
);
5660 if Is_Generic_Instance
(E
)
5661 and then Is_Subprogram
(E
)
5662 and then Present
(Alias
(E
))
5664 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
5667 -- Move to next homonym if not aspect spec case
5669 exit when From_Aspect_Specification
(N
);
5673 -- If we are within a package specification, the pragma only
5674 -- applies to homonyms in the same scope.
5676 exit when In_Package_Spec
5677 and then Scope
(E
) /= Current_Scope
;
5680 end Process_Suppress_Unsuppress
;
5686 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
5688 if Is_Imported
(E
) then
5690 ("cannot export entity& that was previously imported", Arg
);
5692 elsif Present
(Address_Clause
(E
)) and then not CodePeer_Mode
then
5694 ("cannot export entity& that has an address clause", Arg
);
5697 Set_Is_Exported
(E
);
5699 -- Generate a reference for entity explicitly, because the
5700 -- identifier may be overloaded and name resolution will not
5703 Generate_Reference
(E
, Arg
);
5705 -- Deal with exporting non-library level entity
5707 if not Is_Library_Level_Entity
(E
) then
5709 -- Not allowed at all for subprograms
5711 if Is_Subprogram
(E
) then
5712 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
5714 -- Otherwise set public and statically allocated
5718 Set_Is_Statically_Allocated
(E
);
5720 -- Warn if the corresponding W flag is set and the pragma comes
5721 -- from source. The latter may not be true e.g. on VMS where we
5722 -- expand export pragmas for exception codes associated with
5723 -- imported or exported exceptions. We do not want to generate
5724 -- a warning for something that the user did not write.
5726 if Warn_On_Export_Import
5727 and then Comes_From_Source
(Arg
)
5730 ("?& has been made static as a result of Export", Arg
, E
);
5732 ("\this usage is non-standard and non-portable", Arg
);
5737 if Warn_On_Export_Import
and then Is_Type
(E
) then
5738 Error_Msg_NE
("exporting a type has no effect?", Arg
, E
);
5741 if Warn_On_Export_Import
and Inside_A_Generic
then
5743 ("all instances of& will have the same external name?", Arg
, E
);
5747 ----------------------------------------------
5748 -- Set_Extended_Import_Export_External_Name --
5749 ----------------------------------------------
5751 procedure Set_Extended_Import_Export_External_Name
5752 (Internal_Ent
: Entity_Id
;
5753 Arg_External
: Node_Id
)
5755 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
5759 if No
(Arg_External
) then
5763 Check_Arg_Is_External_Name
(Arg_External
);
5765 if Nkind
(Arg_External
) = N_String_Literal
then
5766 if String_Length
(Strval
(Arg_External
)) = 0 then
5769 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
5772 elsif Nkind
(Arg_External
) = N_Identifier
then
5773 New_Name
:= Get_Default_External_Name
(Arg_External
);
5775 -- Check_Arg_Is_External_Name should let through only identifiers and
5776 -- string literals or static string expressions (which are folded to
5777 -- string literals).
5780 raise Program_Error
;
5783 -- If we already have an external name set (by a prior normal Import
5784 -- or Export pragma), then the external names must match
5786 if Present
(Interface_Name
(Internal_Ent
)) then
5787 Check_Matching_Internal_Names
: declare
5788 S1
: constant String_Id
:= Strval
(Old_Name
);
5789 S2
: constant String_Id
:= Strval
(New_Name
);
5792 -- Called if names do not match
5798 procedure Mismatch
is
5800 Error_Msg_Sloc
:= Sloc
(Old_Name
);
5802 ("external name does not match that given #",
5806 -- Start of processing for Check_Matching_Internal_Names
5809 if String_Length
(S1
) /= String_Length
(S2
) then
5813 for J
in 1 .. String_Length
(S1
) loop
5814 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
5819 end Check_Matching_Internal_Names
;
5821 -- Otherwise set the given name
5824 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
5825 Check_Duplicated_Export_Name
(New_Name
);
5827 end Set_Extended_Import_Export_External_Name
;
5833 procedure Set_Imported
(E
: Entity_Id
) is
5835 -- Error message if already imported or exported
5837 if Is_Exported
(E
) or else Is_Imported
(E
) then
5839 -- Error if being set Exported twice
5841 if Is_Exported
(E
) then
5842 Error_Msg_NE
("entity& was previously exported", N
, E
);
5844 -- OK if Import/Interface case
5846 elsif Import_Interface_Present
(N
) then
5849 -- Error if being set Imported twice
5852 Error_Msg_NE
("entity& was previously imported", N
, E
);
5855 Error_Msg_Name_1
:= Pname
;
5857 ("\(pragma% applies to all previous entities)", N
);
5859 Error_Msg_Sloc
:= Sloc
(E
);
5860 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
5862 -- Here if not previously imported or exported, OK to import
5865 Set_Is_Imported
(E
);
5867 -- If the entity is an object that is not at the library level,
5868 -- then it is statically allocated. We do not worry about objects
5869 -- with address clauses in this context since they are not really
5870 -- imported in the linker sense.
5873 and then not Is_Library_Level_Entity
(E
)
5874 and then No
(Address_Clause
(E
))
5876 Set_Is_Statically_Allocated
(E
);
5883 -------------------------
5884 -- Set_Mechanism_Value --
5885 -------------------------
5887 -- Note: the mechanism name has not been analyzed (and cannot indeed be
5888 -- analyzed, since it is semantic nonsense), so we get it in the exact
5889 -- form created by the parser.
5891 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
5894 Mech_Name_Id
: Name_Id
;
5896 procedure Bad_Class
;
5897 -- Signal bad descriptor class name
5899 procedure Bad_Mechanism
;
5900 -- Signal bad mechanism name
5906 procedure Bad_Class
is
5908 Error_Pragma_Arg
("unrecognized descriptor class name", Class
);
5911 -------------------------
5912 -- Bad_Mechanism_Value --
5913 -------------------------
5915 procedure Bad_Mechanism
is
5917 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
5920 -- Start of processing for Set_Mechanism_Value
5923 if Mechanism
(Ent
) /= Default_Mechanism
then
5925 ("mechanism for & has already been set", Mech_Name
, Ent
);
5928 -- MECHANISM_NAME ::= value | reference | descriptor |
5931 if Nkind
(Mech_Name
) = N_Identifier
then
5932 if Chars
(Mech_Name
) = Name_Value
then
5933 Set_Mechanism
(Ent
, By_Copy
);
5936 elsif Chars
(Mech_Name
) = Name_Reference
then
5937 Set_Mechanism
(Ent
, By_Reference
);
5940 elsif Chars
(Mech_Name
) = Name_Descriptor
then
5941 Check_VMS
(Mech_Name
);
5943 -- Descriptor => Short_Descriptor if pragma was given
5945 if Short_Descriptors
then
5946 Set_Mechanism
(Ent
, By_Short_Descriptor
);
5948 Set_Mechanism
(Ent
, By_Descriptor
);
5953 elsif Chars
(Mech_Name
) = Name_Short_Descriptor
then
5954 Check_VMS
(Mech_Name
);
5955 Set_Mechanism
(Ent
, By_Short_Descriptor
);
5958 elsif Chars
(Mech_Name
) = Name_Copy
then
5960 ("bad mechanism name, Value assumed", Mech_Name
);
5966 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
5967 -- short_descriptor (CLASS_NAME)
5968 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5970 -- Note: this form is parsed as an indexed component
5972 elsif Nkind
(Mech_Name
) = N_Indexed_Component
then
5973 Class
:= First
(Expressions
(Mech_Name
));
5975 if Nkind
(Prefix
(Mech_Name
)) /= N_Identifier
5976 or else not (Chars
(Prefix
(Mech_Name
)) = Name_Descriptor
or else
5977 Chars
(Prefix
(Mech_Name
)) = Name_Short_Descriptor
)
5978 or else Present
(Next
(Class
))
5982 Mech_Name_Id
:= Chars
(Prefix
(Mech_Name
));
5984 -- Change Descriptor => Short_Descriptor if pragma was given
5986 if Mech_Name_Id
= Name_Descriptor
5987 and then Short_Descriptors
5989 Mech_Name_Id
:= Name_Short_Descriptor
;
5993 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
5994 -- short_descriptor (Class => CLASS_NAME)
5995 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5997 -- Note: this form is parsed as a function call
5999 elsif Nkind
(Mech_Name
) = N_Function_Call
then
6000 Param
:= First
(Parameter_Associations
(Mech_Name
));
6002 if Nkind
(Name
(Mech_Name
)) /= N_Identifier
6003 or else not (Chars
(Name
(Mech_Name
)) = Name_Descriptor
or else
6004 Chars
(Name
(Mech_Name
)) = Name_Short_Descriptor
)
6005 or else Present
(Next
(Param
))
6006 or else No
(Selector_Name
(Param
))
6007 or else Chars
(Selector_Name
(Param
)) /= Name_Class
6011 Class
:= Explicit_Actual_Parameter
(Param
);
6012 Mech_Name_Id
:= Chars
(Name
(Mech_Name
));
6019 -- Fall through here with Class set to descriptor class name
6021 Check_VMS
(Mech_Name
);
6023 if Nkind
(Class
) /= N_Identifier
then
6026 elsif Mech_Name_Id
= Name_Descriptor
6027 and then Chars
(Class
) = Name_UBS
6029 Set_Mechanism
(Ent
, By_Descriptor_UBS
);
6031 elsif Mech_Name_Id
= Name_Descriptor
6032 and then Chars
(Class
) = Name_UBSB
6034 Set_Mechanism
(Ent
, By_Descriptor_UBSB
);
6036 elsif Mech_Name_Id
= Name_Descriptor
6037 and then Chars
(Class
) = Name_UBA
6039 Set_Mechanism
(Ent
, By_Descriptor_UBA
);
6041 elsif Mech_Name_Id
= Name_Descriptor
6042 and then Chars
(Class
) = Name_S
6044 Set_Mechanism
(Ent
, By_Descriptor_S
);
6046 elsif Mech_Name_Id
= Name_Descriptor
6047 and then Chars
(Class
) = Name_SB
6049 Set_Mechanism
(Ent
, By_Descriptor_SB
);
6051 elsif Mech_Name_Id
= Name_Descriptor
6052 and then Chars
(Class
) = Name_A
6054 Set_Mechanism
(Ent
, By_Descriptor_A
);
6056 elsif Mech_Name_Id
= Name_Descriptor
6057 and then Chars
(Class
) = Name_NCA
6059 Set_Mechanism
(Ent
, By_Descriptor_NCA
);
6061 elsif Mech_Name_Id
= Name_Short_Descriptor
6062 and then Chars
(Class
) = Name_UBS
6064 Set_Mechanism
(Ent
, By_Short_Descriptor_UBS
);
6066 elsif Mech_Name_Id
= Name_Short_Descriptor
6067 and then Chars
(Class
) = Name_UBSB
6069 Set_Mechanism
(Ent
, By_Short_Descriptor_UBSB
);
6071 elsif Mech_Name_Id
= Name_Short_Descriptor
6072 and then Chars
(Class
) = Name_UBA
6074 Set_Mechanism
(Ent
, By_Short_Descriptor_UBA
);
6076 elsif Mech_Name_Id
= Name_Short_Descriptor
6077 and then Chars
(Class
) = Name_S
6079 Set_Mechanism
(Ent
, By_Short_Descriptor_S
);
6081 elsif Mech_Name_Id
= Name_Short_Descriptor
6082 and then Chars
(Class
) = Name_SB
6084 Set_Mechanism
(Ent
, By_Short_Descriptor_SB
);
6086 elsif Mech_Name_Id
= Name_Short_Descriptor
6087 and then Chars
(Class
) = Name_A
6089 Set_Mechanism
(Ent
, By_Short_Descriptor_A
);
6091 elsif Mech_Name_Id
= Name_Short_Descriptor
6092 and then Chars
(Class
) = Name_NCA
6094 Set_Mechanism
(Ent
, By_Short_Descriptor_NCA
);
6099 end Set_Mechanism_Value
;
6101 ---------------------------
6102 -- Set_Ravenscar_Profile --
6103 ---------------------------
6105 -- The tasks to be done here are
6107 -- Set required policies
6109 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
6110 -- pragma Locking_Policy (Ceiling_Locking)
6112 -- Set Detect_Blocking mode
6114 -- Set required restrictions (see System.Rident for detailed list)
6116 -- Set the No_Dependence rules
6117 -- No_Dependence => Ada.Asynchronous_Task_Control
6118 -- No_Dependence => Ada.Calendar
6119 -- No_Dependence => Ada.Execution_Time.Group_Budget
6120 -- No_Dependence => Ada.Execution_Time.Timers
6121 -- No_Dependence => Ada.Task_Attributes
6122 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
6124 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
6125 Prefix_Entity
: Entity_Id
;
6126 Selector_Entity
: Entity_Id
;
6127 Prefix_Node
: Node_Id
;
6131 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
6133 if Task_Dispatching_Policy
/= ' '
6134 and then Task_Dispatching_Policy
/= 'F'
6136 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
6137 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
6139 -- Set the FIFO_Within_Priorities policy, but always preserve
6140 -- System_Location since we like the error message with the run time
6144 Task_Dispatching_Policy
:= 'F';
6146 if Task_Dispatching_Policy_Sloc
/= System_Location
then
6147 Task_Dispatching_Policy_Sloc
:= Loc
;
6151 -- pragma Locking_Policy (Ceiling_Locking)
6153 if Locking_Policy
/= ' '
6154 and then Locking_Policy
/= 'C'
6156 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
6157 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
6159 -- Set the Ceiling_Locking policy, but preserve System_Location since
6160 -- we like the error message with the run time name.
6163 Locking_Policy
:= 'C';
6165 if Locking_Policy_Sloc
/= System_Location
then
6166 Locking_Policy_Sloc
:= Loc
;
6170 -- pragma Detect_Blocking
6172 Detect_Blocking
:= True;
6174 -- Set the corresponding restrictions
6176 Set_Profile_Restrictions
6177 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
6179 -- Set the No_Dependence restrictions
6181 -- The following No_Dependence restrictions:
6182 -- No_Dependence => Ada.Asynchronous_Task_Control
6183 -- No_Dependence => Ada.Calendar
6184 -- No_Dependence => Ada.Task_Attributes
6185 -- are already set by previous call to Set_Profile_Restrictions.
6187 -- Set the following restrictions which were added to Ada 2005:
6188 -- No_Dependence => Ada.Execution_Time.Group_Budget
6189 -- No_Dependence => Ada.Execution_Time.Timers
6191 if Ada_Version
>= Ada_2005
then
6192 Name_Buffer
(1 .. 3) := "ada";
6195 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
6197 Name_Buffer
(1 .. 14) := "execution_time";
6200 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
6203 Make_Selected_Component
6205 Prefix
=> Prefix_Entity
,
6206 Selector_Name
=> Selector_Entity
);
6208 Name_Buffer
(1 .. 13) := "group_budgets";
6211 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
6214 Make_Selected_Component
6216 Prefix
=> Prefix_Node
,
6217 Selector_Name
=> Selector_Entity
);
6219 Set_Restriction_No_Dependence
6221 Warn
=> Treat_Restrictions_As_Warnings
,
6222 Profile
=> Ravenscar
);
6224 Name_Buffer
(1 .. 6) := "timers";
6227 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
6230 Make_Selected_Component
6232 Prefix
=> Prefix_Node
,
6233 Selector_Name
=> Selector_Entity
);
6235 Set_Restriction_No_Dependence
6237 Warn
=> Treat_Restrictions_As_Warnings
,
6238 Profile
=> Ravenscar
);
6241 -- Set the following restrictions which was added to Ada 2012 (see
6243 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
6245 if Ada_Version
>= Ada_2012
then
6246 Name_Buffer
(1 .. 6) := "system";
6249 Prefix_Entity
:= Make_Identifier
(Loc
, Name_Find
);
6251 Name_Buffer
(1 .. 15) := "multiprocessors";
6254 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
6257 Make_Selected_Component
6259 Prefix
=> Prefix_Entity
,
6260 Selector_Name
=> Selector_Entity
);
6262 Name_Buffer
(1 .. 19) := "dispatching_domains";
6265 Selector_Entity
:= Make_Identifier
(Loc
, Name_Find
);
6268 Make_Selected_Component
6270 Prefix
=> Prefix_Node
,
6271 Selector_Name
=> Selector_Entity
);
6273 Set_Restriction_No_Dependence
6275 Warn
=> Treat_Restrictions_As_Warnings
,
6276 Profile
=> Ravenscar
);
6278 end Set_Ravenscar_Profile
;
6280 -- Start of processing for Analyze_Pragma
6283 -- The following code is a defense against recursion. Not clear that
6284 -- this can happen legitimately, but perhaps some error situations
6285 -- can cause it, and we did see this recursion during testing.
6287 if Analyzed
(N
) then
6290 Set_Analyzed
(N
, True);
6293 -- Deal with unrecognized pragma
6295 Pname
:= Pragma_Name
(N
);
6297 if not Is_Pragma_Name
(Pname
) then
6298 if Warn_On_Unrecognized_Pragma
then
6299 Error_Msg_Name_1
:= Pname
;
6300 Error_Msg_N
("?unrecognized pragma%!", Pragma_Identifier
(N
));
6302 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
6303 if Is_Bad_Spelling_Of
(Pname
, PN
) then
6304 Error_Msg_Name_1
:= PN
;
6305 Error_Msg_N
-- CODEFIX
6306 ("\?possible misspelling of %!", Pragma_Identifier
(N
));
6315 -- Here to start processing for recognized pragma
6317 Prag_Id
:= Get_Pragma_Id
(Pname
);
6319 if Present
(Corresponding_Aspect
(N
)) then
6320 Pname
:= Chars
(Identifier
(Corresponding_Aspect
(N
)));
6331 if Present
(Pragma_Argument_Associations
(N
)) then
6332 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
6333 Arg1
:= First
(Pragma_Argument_Associations
(N
));
6335 if Present
(Arg1
) then
6336 Arg2
:= Next
(Arg1
);
6338 if Present
(Arg2
) then
6339 Arg3
:= Next
(Arg2
);
6341 if Present
(Arg3
) then
6342 Arg4
:= Next
(Arg3
);
6348 -- An enumeration type defines the pragmas that are supported by the
6349 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
6350 -- into the corresponding enumeration value for the following case.
6358 -- pragma Abort_Defer;
6360 when Pragma_Abort_Defer
=>
6362 Check_Arg_Count
(0);
6364 -- The only required semantic processing is to check the
6365 -- placement. This pragma must appear at the start of the
6366 -- statement sequence of a handled sequence of statements.
6368 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
6369 or else N
/= First
(Statements
(Parent
(N
)))
6380 -- Note: this pragma also has some specific processing in Par.Prag
6381 -- because we want to set the Ada version mode during parsing.
6383 when Pragma_Ada_83
=>
6385 Check_Arg_Count
(0);
6387 -- We really should check unconditionally for proper configuration
6388 -- pragma placement, since we really don't want mixed Ada modes
6389 -- within a single unit, and the GNAT reference manual has always
6390 -- said this was a configuration pragma, but we did not check and
6391 -- are hesitant to add the check now.
6393 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
6394 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
6395 -- or Ada 2012 mode.
6397 if Ada_Version
>= Ada_2005
then
6398 Check_Valid_Configuration_Pragma
;
6401 -- Now set Ada 83 mode
6403 Ada_Version
:= Ada_83
;
6404 Ada_Version_Explicit
:= Ada_Version
;
6412 -- Note: this pragma also has some specific processing in Par.Prag
6413 -- because we want to set the Ada 83 version mode during parsing.
6415 when Pragma_Ada_95
=>
6417 Check_Arg_Count
(0);
6419 -- We really should check unconditionally for proper configuration
6420 -- pragma placement, since we really don't want mixed Ada modes
6421 -- within a single unit, and the GNAT reference manual has always
6422 -- said this was a configuration pragma, but we did not check and
6423 -- are hesitant to add the check now.
6425 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
6426 -- or Ada 95, so we must check if we are in Ada 2005 mode.
6428 if Ada_Version
>= Ada_2005
then
6429 Check_Valid_Configuration_Pragma
;
6432 -- Now set Ada 95 mode
6434 Ada_Version
:= Ada_95
;
6435 Ada_Version_Explicit
:= Ada_Version
;
6437 ---------------------
6438 -- Ada_05/Ada_2005 --
6439 ---------------------
6442 -- pragma Ada_05 (LOCAL_NAME);
6445 -- pragma Ada_2005 (LOCAL_NAME):
6447 -- Note: these pragmas also have some specific processing in Par.Prag
6448 -- because we want to set the Ada 2005 version mode during parsing.
6450 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
6456 if Arg_Count
= 1 then
6457 Check_Arg_Is_Local_Name
(Arg1
);
6458 E_Id
:= Get_Pragma_Arg
(Arg1
);
6460 if Etype
(E_Id
) = Any_Type
then
6464 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
6467 Check_Arg_Count
(0);
6469 -- For Ada_2005 we unconditionally enforce the documented
6470 -- configuration pragma placement, since we do not want to
6471 -- tolerate mixed modes in a unit involving Ada 2005. That
6472 -- would cause real difficulties for those cases where there
6473 -- are incompatibilities between Ada 95 and Ada 2005.
6475 Check_Valid_Configuration_Pragma
;
6477 -- Now set appropriate Ada mode
6479 Ada_Version
:= Ada_2005
;
6480 Ada_Version_Explicit
:= Ada_2005
;
6484 ---------------------
6485 -- Ada_12/Ada_2012 --
6486 ---------------------
6489 -- pragma Ada_12 (LOCAL_NAME);
6492 -- pragma Ada_2012 (LOCAL_NAME):
6494 -- Note: these pragmas also have some specific processing in Par.Prag
6495 -- because we want to set the Ada 2012 version mode during parsing.
6497 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
6503 if Arg_Count
= 1 then
6504 Check_Arg_Is_Local_Name
(Arg1
);
6505 E_Id
:= Get_Pragma_Arg
(Arg1
);
6507 if Etype
(E_Id
) = Any_Type
then
6511 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
6514 Check_Arg_Count
(0);
6516 -- For Ada_2012 we unconditionally enforce the documented
6517 -- configuration pragma placement, since we do not want to
6518 -- tolerate mixed modes in a unit involving Ada 2012. That
6519 -- would cause real difficulties for those cases where there
6520 -- are incompatibilities between Ada 95 and Ada 2012. We could
6521 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
6523 Check_Valid_Configuration_Pragma
;
6525 -- Now set appropriate Ada mode
6527 Ada_Version
:= Ada_2012
;
6528 Ada_Version_Explicit
:= Ada_2012
;
6532 ----------------------
6533 -- All_Calls_Remote --
6534 ----------------------
6536 -- pragma All_Calls_Remote [(library_package_NAME)];
6538 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
6539 Lib_Entity
: Entity_Id
;
6542 Check_Ada_83_Warning
;
6543 Check_Valid_Library_Unit_Pragma
;
6545 if Nkind
(N
) = N_Null_Statement
then
6549 Lib_Entity
:= Find_Lib_Unit_Name
;
6551 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
6553 if Present
(Lib_Entity
)
6554 and then not Debug_Flag_U
6556 if not Is_Remote_Call_Interface
(Lib_Entity
) then
6557 Error_Pragma
("pragma% only apply to rci unit");
6559 -- Set flag for entity of the library unit
6562 Set_Has_All_Calls_Remote
(Lib_Entity
);
6566 end All_Calls_Remote
;
6572 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
6573 -- ARG ::= NAME | EXPRESSION
6575 -- The first two arguments are by convention intended to refer to an
6576 -- external tool and a tool-specific function. These arguments are
6579 when Pragma_Annotate
=> Annotate
: declare
6585 Check_At_Least_N_Arguments
(1);
6586 Check_Arg_Is_Identifier
(Arg1
);
6587 Check_No_Identifiers
;
6590 -- Second parameter is optional, it is never analyzed
6595 -- Here if we have a second parameter
6598 -- Second parameter must be identifier
6600 Check_Arg_Is_Identifier
(Arg2
);
6602 -- Process remaining parameters if any
6605 while Present
(Arg
) loop
6606 Exp
:= Get_Pragma_Arg
(Arg
);
6609 if Is_Entity_Name
(Exp
) then
6612 -- For string literals, we assume Standard_String as the
6613 -- type, unless the string contains wide or wide_wide
6616 elsif Nkind
(Exp
) = N_String_Literal
then
6617 if Has_Wide_Wide_Character
(Exp
) then
6618 Resolve
(Exp
, Standard_Wide_Wide_String
);
6619 elsif Has_Wide_Character
(Exp
) then
6620 Resolve
(Exp
, Standard_Wide_String
);
6622 Resolve
(Exp
, Standard_String
);
6625 elsif Is_Overloaded
(Exp
) then
6627 ("ambiguous argument for pragma%", Exp
);
6642 -- pragma Assert ([Check =>] Boolean_EXPRESSION
6643 -- [, [Message =>] Static_String_EXPRESSION]);
6645 when Pragma_Assert
=> Assert
: declare
6651 Check_At_Least_N_Arguments
(1);
6652 Check_At_Most_N_Arguments
(2);
6653 Check_Arg_Order
((Name_Check
, Name_Message
));
6654 Check_Optional_Identifier
(Arg1
, Name_Check
);
6656 -- We treat pragma Assert as equivalent to:
6658 -- pragma Check (Assertion, condition [, msg]);
6660 -- So rewrite pragma in this manner, and analyze the result
6662 Expr
:= Get_Pragma_Arg
(Arg1
);
6664 Make_Pragma_Argument_Association
(Loc
,
6665 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
6667 Make_Pragma_Argument_Association
(Sloc
(Expr
),
6668 Expression
=> Expr
));
6670 if Arg_Count
> 1 then
6671 Check_Optional_Identifier
(Arg2
, Name_Message
);
6672 Analyze_And_Resolve
(Get_Pragma_Arg
(Arg2
), Standard_String
);
6673 Append_To
(Newa
, Relocate_Node
(Arg2
));
6678 Chars
=> Name_Check
,
6679 Pragma_Argument_Associations
=> Newa
));
6683 ----------------------
6684 -- Assertion_Policy --
6685 ----------------------
6687 -- pragma Assertion_Policy (Check | Disable |Ignore)
6689 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
6694 Check_Valid_Configuration_Pragma
;
6695 Check_Arg_Count
(1);
6696 Check_No_Identifiers
;
6697 Check_Arg_Is_One_Of
(Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
6699 -- We treat pragma Assertion_Policy as equivalent to:
6701 -- pragma Check_Policy (Assertion, policy)
6703 -- So rewrite the pragma in that manner and link on to the chain
6704 -- of Check_Policy pragmas, marking the pragma as analyzed.
6706 Policy
:= Get_Pragma_Arg
(Arg1
);
6710 Chars
=> Name_Check_Policy
,
6712 Pragma_Argument_Associations
=> New_List
(
6713 Make_Pragma_Argument_Association
(Loc
,
6714 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
6716 Make_Pragma_Argument_Association
(Loc
,
6718 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
6721 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
6722 Opt
.Check_Policy_List
:= N
;
6723 end Assertion_Policy
;
6725 ------------------------------
6726 -- Assume_No_Invalid_Values --
6727 ------------------------------
6729 -- pragma Assume_No_Invalid_Values (On | Off);
6731 when Pragma_Assume_No_Invalid_Values
=>
6733 Check_Valid_Configuration_Pragma
;
6734 Check_Arg_Count
(1);
6735 Check_No_Identifiers
;
6736 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
6738 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
6739 Assume_No_Invalid_Values
:= True;
6741 Assume_No_Invalid_Values
:= False;
6748 -- pragma AST_Entry (entry_IDENTIFIER);
6750 when Pragma_AST_Entry
=> AST_Entry
: declare
6756 Check_Arg_Count
(1);
6757 Check_No_Identifiers
;
6758 Check_Arg_Is_Local_Name
(Arg1
);
6759 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
6761 -- Note: the implementation of the AST_Entry pragma could handle
6762 -- the entry family case fine, but for now we are consistent with
6763 -- the DEC rules, and do not allow the pragma, which of course
6764 -- has the effect of also forbidding the attribute.
6766 if Ekind
(Ent
) /= E_Entry
then
6768 ("pragma% argument must be simple entry name", Arg1
);
6770 elsif Is_AST_Entry
(Ent
) then
6772 ("duplicate % pragma for entry", Arg1
);
6774 elsif Has_Homonym
(Ent
) then
6776 ("pragma% argument cannot specify overloaded entry", Arg1
);
6780 FF
: constant Entity_Id
:= First_Formal
(Ent
);
6783 if Present
(FF
) then
6784 if Present
(Next_Formal
(FF
)) then
6786 ("entry for pragma% can have only one argument",
6789 elsif Parameter_Mode
(FF
) /= E_In_Parameter
then
6791 ("entry parameter for pragma% must have mode IN",
6797 Set_Is_AST_Entry
(Ent
);
6805 -- pragma Asynchronous (LOCAL_NAME);
6807 when Pragma_Asynchronous
=> Asynchronous
: declare
6815 procedure Process_Async_Pragma
;
6816 -- Common processing for procedure and access-to-procedure case
6818 --------------------------
6819 -- Process_Async_Pragma --
6820 --------------------------
6822 procedure Process_Async_Pragma
is
6825 Set_Is_Asynchronous
(Nm
);
6829 -- The formals should be of mode IN (RM E.4.1(6))
6832 while Present
(S
) loop
6833 Formal
:= Defining_Identifier
(S
);
6835 if Nkind
(Formal
) = N_Defining_Identifier
6836 and then Ekind
(Formal
) /= E_In_Parameter
6839 ("pragma% procedure can only have IN parameter",
6846 Set_Is_Asynchronous
(Nm
);
6847 end Process_Async_Pragma
;
6849 -- Start of processing for pragma Asynchronous
6852 Check_Ada_83_Warning
;
6853 Check_No_Identifiers
;
6854 Check_Arg_Count
(1);
6855 Check_Arg_Is_Local_Name
(Arg1
);
6857 if Debug_Flag_U
then
6861 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
6862 Analyze
(Get_Pragma_Arg
(Arg1
));
6863 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
6865 if not Is_Remote_Call_Interface
(C_Ent
)
6866 and then not Is_Remote_Types
(C_Ent
)
6868 -- This pragma should only appear in an RCI or Remote Types
6869 -- unit (RM E.4.1(4)).
6872 ("pragma% not in Remote_Call_Interface or " &
6873 "Remote_Types unit");
6876 if Ekind
(Nm
) = E_Procedure
6877 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
6879 if not Is_Remote_Call_Interface
(Nm
) then
6881 ("pragma% cannot be applied on non-remote procedure",
6885 L
:= Parameter_Specifications
(Parent
(Nm
));
6886 Process_Async_Pragma
;
6889 elsif Ekind
(Nm
) = E_Function
then
6891 ("pragma% cannot be applied to function", Arg1
);
6893 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
6894 if Is_Record_Type
(Nm
) then
6896 -- A record type that is the Equivalent_Type for a remote
6897 -- access-to-subprogram type.
6899 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
6902 -- A non-expanded RAS type (distribution is not enabled)
6904 N
:= Declaration_Node
(Nm
);
6907 if Nkind
(N
) = N_Full_Type_Declaration
6908 and then Nkind
(Type_Definition
(N
)) =
6909 N_Access_Procedure_Definition
6911 L
:= Parameter_Specifications
(Type_Definition
(N
));
6912 Process_Async_Pragma
;
6914 if Is_Asynchronous
(Nm
)
6915 and then Expander_Active
6916 and then Get_PCS_Name
/= Name_No_DSA
6918 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
6923 ("pragma% cannot reference access-to-function type",
6927 -- Only other possibility is Access-to-class-wide type
6929 elsif Is_Access_Type
(Nm
)
6930 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
6932 Check_First_Subtype
(Arg1
);
6933 Set_Is_Asynchronous
(Nm
);
6934 if Expander_Active
then
6935 RACW_Type_Is_Asynchronous
(Nm
);
6939 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
6947 -- pragma Atomic (LOCAL_NAME);
6949 when Pragma_Atomic
=>
6950 Process_Atomic_Shared_Volatile
;
6952 -----------------------
6953 -- Atomic_Components --
6954 -----------------------
6956 -- pragma Atomic_Components (array_LOCAL_NAME);
6958 -- This processing is shared by Volatile_Components
6960 when Pragma_Atomic_Components |
6961 Pragma_Volatile_Components
=>
6963 Atomic_Components
: declare
6970 Check_Ada_83_Warning
;
6971 Check_No_Identifiers
;
6972 Check_Arg_Count
(1);
6973 Check_Arg_Is_Local_Name
(Arg1
);
6974 E_Id
:= Get_Pragma_Arg
(Arg1
);
6976 if Etype
(E_Id
) = Any_Type
then
6982 Check_Duplicate_Pragma
(E
);
6984 if Rep_Item_Too_Early
(E
, N
)
6986 Rep_Item_Too_Late
(E
, N
)
6991 D
:= Declaration_Node
(E
);
6994 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
6996 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
6997 and then Nkind
(D
) = N_Object_Declaration
6998 and then Nkind
(Object_Definition
(D
)) =
6999 N_Constrained_Array_Definition
)
7001 -- The flag is set on the object, or on the base type
7003 if Nkind
(D
) /= N_Object_Declaration
then
7007 Set_Has_Volatile_Components
(E
);
7009 if Prag_Id
= Pragma_Atomic_Components
then
7010 Set_Has_Atomic_Components
(E
);
7014 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
7016 end Atomic_Components
;
7017 --------------------
7018 -- Attach_Handler --
7019 --------------------
7021 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
7023 when Pragma_Attach_Handler
=>
7024 Check_Ada_83_Warning
;
7025 Check_No_Identifiers
;
7026 Check_Arg_Count
(2);
7028 if No_Run_Time_Mode
then
7029 Error_Msg_CRT
("Attach_Handler pragma", N
);
7031 Check_Interrupt_Or_Attach_Handler
;
7033 -- The expression that designates the attribute may depend on a
7034 -- discriminant, and is therefore a per- object expression, to
7035 -- be expanded in the init proc. If expansion is enabled, then
7036 -- perform semantic checks on a copy only.
7038 if Expander_Active
then
7040 Temp
: constant Node_Id
:=
7041 New_Copy_Tree
(Get_Pragma_Arg
(Arg2
));
7043 Set_Parent
(Temp
, N
);
7044 Preanalyze_And_Resolve
(Temp
, RTE
(RE_Interrupt_ID
));
7048 Analyze
(Get_Pragma_Arg
(Arg2
));
7049 Resolve
(Get_Pragma_Arg
(Arg2
), RTE
(RE_Interrupt_ID
));
7052 Process_Interrupt_Or_Attach_Handler
;
7055 --------------------
7056 -- C_Pass_By_Copy --
7057 --------------------
7059 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
7061 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
7067 Check_Valid_Configuration_Pragma
;
7068 Check_Arg_Count
(1);
7069 Check_Optional_Identifier
(Arg1
, "max_size");
7071 Arg
:= Get_Pragma_Arg
(Arg1
);
7072 Check_Arg_Is_Static_Expression
(Arg
, Any_Integer
);
7074 Val
:= Expr_Value
(Arg
);
7078 ("maximum size for pragma% must be positive", Arg1
);
7080 elsif UI_Is_In_Int_Range
(Val
) then
7081 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
7083 -- If a giant value is given, Int'Last will do well enough.
7084 -- If sometime someone complains that a record larger than
7085 -- two gigabytes is not copied, we will worry about it then!
7088 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
7096 -- pragma Check ([Name =>] IDENTIFIER,
7097 -- [Check =>] Boolean_EXPRESSION
7098 -- [,[Message =>] String_EXPRESSION]);
7100 when Pragma_Check
=> Check
: declare
7105 -- Set True if category of assertions referenced by Name enabled
7109 Check_At_Least_N_Arguments
(2);
7110 Check_At_Most_N_Arguments
(3);
7111 Check_Optional_Identifier
(Arg1
, Name_Name
);
7112 Check_Optional_Identifier
(Arg2
, Name_Check
);
7114 if Arg_Count
= 3 then
7115 Check_Optional_Identifier
(Arg3
, Name_Message
);
7116 Analyze_And_Resolve
(Get_Pragma_Arg
(Arg3
), Standard_String
);
7119 Check_Arg_Is_Identifier
(Arg1
);
7121 -- Completely ignore if disabled
7123 if Check_Disabled
(Chars
(Get_Pragma_Arg
(Arg1
))) then
7124 Rewrite
(N
, Make_Null_Statement
(Loc
));
7129 -- Indicate if pragma is enabled. The Original_Node reference here
7130 -- is to deal with pragma Assert rewritten as a Check pragma.
7132 Check_On
:= Check_Enabled
(Chars
(Get_Pragma_Arg
(Arg1
)));
7135 Set_SCO_Pragma_Enabled
(Loc
);
7138 -- If expansion is active and the check is not enabled then we
7139 -- rewrite the Check as:
7141 -- if False and then condition then
7145 -- The reason we do this rewriting during semantic analysis rather
7146 -- than as part of normal expansion is that we cannot analyze and
7147 -- expand the code for the boolean expression directly, or it may
7148 -- cause insertion of actions that would escape the attempt to
7149 -- suppress the check code.
7151 -- Note that the Sloc for the if statement corresponds to the
7152 -- argument condition, not the pragma itself. The reason for this
7153 -- is that we may generate a warning if the condition is False at
7154 -- compile time, and we do not want to delete this warning when we
7155 -- delete the if statement.
7157 Expr
:= Get_Pragma_Arg
(Arg2
);
7159 if Expander_Active
and then not Check_On
then
7160 Eloc
:= Sloc
(Expr
);
7163 Make_If_Statement
(Eloc
,
7165 Make_And_Then
(Eloc
,
7166 Left_Opnd
=> New_Occurrence_Of
(Standard_False
, Eloc
),
7167 Right_Opnd
=> Expr
),
7168 Then_Statements
=> New_List
(
7169 Make_Null_Statement
(Eloc
))));
7176 Analyze_And_Resolve
(Expr
, Any_Boolean
);
7184 -- pragma Check_Name (check_IDENTIFIER);
7186 when Pragma_Check_Name
=>
7187 Check_No_Identifiers
;
7189 Check_Valid_Configuration_Pragma
;
7190 Check_Arg_Count
(1);
7191 Check_Arg_Is_Identifier
(Arg1
);
7194 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
7197 for J
in Check_Names
.First
.. Check_Names
.Last
loop
7198 if Check_Names
.Table
(J
) = Nam
then
7203 Check_Names
.Append
(Nam
);
7210 -- pragma Check_Policy (
7211 -- [Name =>] IDENTIFIER,
7212 -- [Policy =>] POLICY_IDENTIFIER);
7214 -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | DISABLE | IGNORE
7216 -- Note: this is a configuration pragma, but it is allowed to appear
7219 when Pragma_Check_Policy
=>
7221 Check_Arg_Count
(2);
7222 Check_Optional_Identifier
(Arg1
, Name_Name
);
7223 Check_Optional_Identifier
(Arg2
, Name_Policy
);
7225 (Arg2
, Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
7227 -- A Check_Policy pragma can appear either as a configuration
7228 -- pragma, or in a declarative part or a package spec (see RM
7229 -- 11.5(5) for rules for Suppress/Unsuppress which are also
7230 -- followed for Check_Policy).
7232 if not Is_Configuration_Pragma
then
7233 Check_Is_In_Decl_Part_Or_Package_Spec
;
7236 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
7237 Opt
.Check_Policy_List
:= N
;
7239 ---------------------
7240 -- CIL_Constructor --
7241 ---------------------
7243 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
7245 -- Processing for this pragma is shared with Java_Constructor
7251 -- pragma Comment (static_string_EXPRESSION)
7253 -- Processing for pragma Comment shares the circuitry for pragma
7254 -- Ident. The only differences are that Ident enforces a limit of 31
7255 -- characters on its argument, and also enforces limitations on
7256 -- placement for DEC compatibility. Pragma Comment shares neither of
7257 -- these restrictions.
7263 -- pragma Common_Object (
7264 -- [Internal =>] LOCAL_NAME
7265 -- [, [External =>] EXTERNAL_SYMBOL]
7266 -- [, [Size =>] EXTERNAL_SYMBOL]);
7268 -- Processing for this pragma is shared with Psect_Object
7270 ------------------------
7271 -- Compile_Time_Error --
7272 ------------------------
7274 -- pragma Compile_Time_Error
7275 -- (boolean_EXPRESSION, static_string_EXPRESSION);
7277 when Pragma_Compile_Time_Error
=>
7279 Process_Compile_Time_Warning_Or_Error
;
7281 --------------------------
7282 -- Compile_Time_Warning --
7283 --------------------------
7285 -- pragma Compile_Time_Warning
7286 -- (boolean_EXPRESSION, static_string_EXPRESSION);
7288 when Pragma_Compile_Time_Warning
=>
7290 Process_Compile_Time_Warning_Or_Error
;
7296 when Pragma_Compiler_Unit
=>
7298 Check_Arg_Count
(0);
7299 Set_Is_Compiler_Unit
(Get_Source_Unit
(N
));
7301 -----------------------------
7302 -- Complete_Representation --
7303 -----------------------------
7305 -- pragma Complete_Representation;
7307 when Pragma_Complete_Representation
=>
7309 Check_Arg_Count
(0);
7311 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
7313 ("pragma & must appear within record representation clause");
7316 ----------------------------
7317 -- Complex_Representation --
7318 ----------------------------
7320 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
7322 when Pragma_Complex_Representation
=> Complex_Representation
: declare
7329 Check_Arg_Count
(1);
7330 Check_Optional_Identifier
(Arg1
, Name_Entity
);
7331 Check_Arg_Is_Local_Name
(Arg1
);
7332 E_Id
:= Get_Pragma_Arg
(Arg1
);
7334 if Etype
(E_Id
) = Any_Type
then
7340 if not Is_Record_Type
(E
) then
7342 ("argument for pragma% must be record type", Arg1
);
7345 Ent
:= First_Entity
(E
);
7348 or else No
(Next_Entity
(Ent
))
7349 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
7350 or else not Is_Floating_Point_Type
(Etype
(Ent
))
7351 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
7354 ("record for pragma% must have two fields of the same "
7355 & "floating-point type", Arg1
);
7358 Set_Has_Complex_Representation
(Base_Type
(E
));
7360 -- We need to treat the type has having a non-standard
7361 -- representation, for back-end purposes, even though in
7362 -- general a complex will have the default representation
7363 -- of a record with two real components.
7365 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
7367 end Complex_Representation
;
7369 -------------------------
7370 -- Component_Alignment --
7371 -------------------------
7373 -- pragma Component_Alignment (
7374 -- [Form =>] ALIGNMENT_CHOICE
7375 -- [, [Name =>] type_LOCAL_NAME]);
7377 -- ALIGNMENT_CHOICE ::=
7379 -- | Component_Size_4
7383 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
7384 Args
: Args_List
(1 .. 2);
7385 Names
: constant Name_List
(1 .. 2) := (
7389 Form
: Node_Id
renames Args
(1);
7390 Name
: Node_Id
renames Args
(2);
7392 Atype
: Component_Alignment_Kind
;
7397 Gather_Associations
(Names
, Args
);
7400 Error_Pragma
("missing Form argument for pragma%");
7403 Check_Arg_Is_Identifier
(Form
);
7405 -- Get proper alignment, note that Default = Component_Size on all
7406 -- machines we have so far, and we want to set this value rather
7407 -- than the default value to indicate that it has been explicitly
7408 -- set (and thus will not get overridden by the default component
7409 -- alignment for the current scope)
7411 if Chars
(Form
) = Name_Component_Size
then
7412 Atype
:= Calign_Component_Size
;
7414 elsif Chars
(Form
) = Name_Component_Size_4
then
7415 Atype
:= Calign_Component_Size_4
;
7417 elsif Chars
(Form
) = Name_Default
then
7418 Atype
:= Calign_Component_Size
;
7420 elsif Chars
(Form
) = Name_Storage_Unit
then
7421 Atype
:= Calign_Storage_Unit
;
7425 ("invalid Form parameter for pragma%", Form
);
7428 -- Case with no name, supplied, affects scope table entry
7432 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
7434 -- Case of name supplied
7437 Check_Arg_Is_Local_Name
(Name
);
7439 Typ
:= Entity
(Name
);
7442 or else Rep_Item_Too_Early
(Typ
, N
)
7446 Typ
:= Underlying_Type
(Typ
);
7449 if not Is_Record_Type
(Typ
)
7450 and then not Is_Array_Type
(Typ
)
7453 ("Name parameter of pragma% must identify record or " &
7454 "array type", Name
);
7457 -- An explicit Component_Alignment pragma overrides an
7458 -- implicit pragma Pack, but not an explicit one.
7460 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
7461 Set_Is_Packed
(Base_Type
(Typ
), False);
7462 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
7465 end Component_AlignmentP
;
7471 -- pragma Controlled (first_subtype_LOCAL_NAME);
7473 when Pragma_Controlled
=> Controlled
: declare
7477 Check_No_Identifiers
;
7478 Check_Arg_Count
(1);
7479 Check_Arg_Is_Local_Name
(Arg1
);
7480 Arg
:= Get_Pragma_Arg
(Arg1
);
7482 if not Is_Entity_Name
(Arg
)
7483 or else not Is_Access_Type
(Entity
(Arg
))
7485 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
7487 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
7495 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
7496 -- [Entity =>] LOCAL_NAME);
7498 when Pragma_Convention
=> Convention
: declare
7501 pragma Warnings
(Off
, C
);
7502 pragma Warnings
(Off
, E
);
7504 Check_Arg_Order
((Name_Convention
, Name_Entity
));
7505 Check_Ada_83_Warning
;
7506 Check_Arg_Count
(2);
7507 Process_Convention
(C
, E
);
7510 ---------------------------
7511 -- Convention_Identifier --
7512 ---------------------------
7514 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
7515 -- [Convention =>] convention_IDENTIFIER);
7517 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
7523 Check_Arg_Order
((Name_Name
, Name_Convention
));
7524 Check_Arg_Count
(2);
7525 Check_Optional_Identifier
(Arg1
, Name_Name
);
7526 Check_Optional_Identifier
(Arg2
, Name_Convention
);
7527 Check_Arg_Is_Identifier
(Arg1
);
7528 Check_Arg_Is_Identifier
(Arg2
);
7529 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
7530 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
7532 if Is_Convention_Name
(Cname
) then
7533 Record_Convention_Identifier
7534 (Idnam
, Get_Convention_Id
(Cname
));
7537 ("second arg for % pragma must be convention", Arg2
);
7539 end Convention_Identifier
;
7545 -- pragma CPP_Class ([Entity =>] local_NAME)
7547 when Pragma_CPP_Class
=> CPP_Class
: declare
7552 if Warn_On_Obsolescent_Feature
then
7554 ("'G'N'A'T pragma cpp'_class is now obsolete; replace it" &
7555 " by pragma import?", N
);
7559 Check_Arg_Count
(1);
7560 Check_Optional_Identifier
(Arg1
, Name_Entity
);
7561 Check_Arg_Is_Local_Name
(Arg1
);
7563 Arg
:= Get_Pragma_Arg
(Arg1
);
7566 if Etype
(Arg
) = Any_Type
then
7570 if not Is_Entity_Name
(Arg
)
7571 or else not Is_Type
(Entity
(Arg
))
7573 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
7576 Typ
:= Entity
(Arg
);
7578 if not Is_Tagged_Type
(Typ
) then
7579 Error_Pragma_Arg
("pragma% applicable to tagged types ", Arg1
);
7582 -- Types treated as CPP classes must be declared limited (note:
7583 -- this used to be a warning but there is no real benefit to it
7584 -- since we did effectively intend to treat the type as limited
7587 if not Is_Limited_Type
(Typ
) then
7589 ("imported 'C'P'P type must be limited",
7590 Get_Pragma_Arg
(Arg1
));
7593 Set_Is_CPP_Class
(Typ
);
7594 Set_Convention
(Typ
, Convention_CPP
);
7596 -- Imported CPP types must not have discriminants (because C++
7597 -- classes do not have discriminants).
7599 if Has_Discriminants
(Typ
) then
7601 ("imported 'C'P'P type cannot have discriminants",
7602 First
(Discriminant_Specifications
7603 (Declaration_Node
(Typ
))));
7606 -- Components of imported CPP types must not have default
7607 -- expressions because the constructor (if any) is in the
7610 if Is_Incomplete_Or_Private_Type
(Typ
)
7611 and then No
(Underlying_Type
(Typ
))
7613 -- It should be an error to apply pragma CPP to a private
7614 -- type if the underlying type is not visible (as it is
7615 -- for any representation item). For now, for backward
7616 -- compatibility we do nothing but we cannot check components
7617 -- because they are not available at this stage. All this code
7618 -- will be removed when we cleanup this obsolete GNAT pragma???
7624 Tdef
: constant Node_Id
:=
7625 Type_Definition
(Declaration_Node
(Typ
));
7630 if Nkind
(Tdef
) = N_Record_Definition
then
7631 Clist
:= Component_List
(Tdef
);
7633 pragma Assert
(Nkind
(Tdef
) = N_Derived_Type_Definition
);
7634 Clist
:= Component_List
(Record_Extension_Part
(Tdef
));
7637 if Present
(Clist
) then
7638 Comp
:= First
(Component_Items
(Clist
));
7639 while Present
(Comp
) loop
7640 if Present
(Expression
(Comp
)) then
7642 ("component of imported 'C'P'P type cannot have" &
7643 " default expression", Expression
(Comp
));
7653 ---------------------
7654 -- CPP_Constructor --
7655 ---------------------
7657 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
7658 -- [, [External_Name =>] static_string_EXPRESSION ]
7659 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7661 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
7665 Tag_Typ
: Entity_Id
;
7669 Check_At_Least_N_Arguments
(1);
7670 Check_At_Most_N_Arguments
(3);
7671 Check_Optional_Identifier
(Arg1
, Name_Entity
);
7672 Check_Arg_Is_Local_Name
(Arg1
);
7674 Id
:= Get_Pragma_Arg
(Arg1
);
7675 Find_Program_Unit_Name
(Id
);
7677 -- If we did not find the name, we are done
7679 if Etype
(Id
) = Any_Type
then
7683 Def_Id
:= Entity
(Id
);
7685 -- Check if already defined as constructor
7687 if Is_Constructor
(Def_Id
) then
7689 ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
7693 if Ekind
(Def_Id
) = E_Function
7694 and then (Is_CPP_Class
(Etype
(Def_Id
))
7695 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
7697 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
7699 if Arg_Count
>= 2 then
7700 Set_Imported
(Def_Id
);
7701 Set_Is_Public
(Def_Id
);
7702 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
7705 Set_Has_Completion
(Def_Id
);
7706 Set_Is_Constructor
(Def_Id
);
7708 -- Imported C++ constructors are not dispatching primitives
7709 -- because in C++ they don't have a dispatch table slot.
7710 -- However, in Ada the constructor has the profile of a
7711 -- function that returns a tagged type and therefore it has
7712 -- been treated as a primitive operation during semantic
7713 -- analysis. We now remove it from the list of primitive
7714 -- operations of the type.
7716 if Is_Tagged_Type
(Etype
(Def_Id
))
7717 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
7719 pragma Assert
(Is_Dispatching_Operation
(Def_Id
));
7720 Tag_Typ
:= Etype
(Def_Id
);
7722 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
7723 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
7727 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
7728 Set_Is_Dispatching_Operation
(Def_Id
, False);
7731 -- For backward compatibility, if the constructor returns a
7732 -- class wide type, and we internally change the return type to
7733 -- the corresponding root type.
7735 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
7736 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
7740 ("pragma% requires function returning a 'C'P'P_Class type",
7743 end CPP_Constructor
;
7749 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
7753 if Warn_On_Obsolescent_Feature
then
7755 ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " &
7764 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
7768 if Warn_On_Obsolescent_Feature
then
7770 ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
7779 -- pragma CPU (EXPRESSION);
7781 when Pragma_CPU
=> CPU
: declare
7782 P
: constant Node_Id
:= Parent
(N
);
7787 Check_No_Identifiers
;
7788 Check_Arg_Count
(1);
7792 if Nkind
(P
) = N_Subprogram_Body
then
7793 Check_In_Main_Program
;
7795 Arg
:= Get_Pragma_Arg
(Arg1
);
7796 Analyze_And_Resolve
(Arg
, Any_Integer
);
7800 if not Is_Static_Expression
(Arg
) then
7801 Flag_Non_Static_Expr
7802 ("main subprogram affinity is not static!", Arg
);
7805 -- If constraint error, then we already signalled an error
7807 elsif Raises_Constraint_Error
(Arg
) then
7810 -- Otherwise check in range
7814 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
7815 -- This is the entity System.Multiprocessors.CPU_Range;
7817 Val
: constant Uint
:= Expr_Value
(Arg
);
7820 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
7822 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
7825 ("main subprogram CPU is out of range", Arg1
);
7831 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
7835 elsif Nkind
(P
) = N_Task_Definition
then
7836 Arg
:= Get_Pragma_Arg
(Arg1
);
7838 -- The expression must be analyzed in the special manner
7839 -- described in "Handling of Default and Per-Object
7840 -- Expressions" in sem.ads.
7842 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
7844 -- Anything else is incorrect
7850 if Has_Pragma_CPU
(P
) then
7851 Error_Pragma
("duplicate pragma% not allowed");
7853 Set_Has_Pragma_CPU
(P
, True);
7855 if Nkind
(P
) = N_Task_Definition
then
7856 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
7865 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
7867 when Pragma_Debug
=> Debug
: declare
7874 -- Skip analysis if disabled
7876 if Debug_Pragmas_Disabled
then
7877 Rewrite
(N
, Make_Null_Statement
(Loc
));
7884 (Boolean_Literals
(Debug_Pragmas_Enabled
and Expander_Active
),
7887 if Debug_Pragmas_Enabled
then
7888 Set_SCO_Pragma_Enabled
(Loc
);
7891 if Arg_Count
= 2 then
7894 Left_Opnd
=> Relocate_Node
(Cond
),
7895 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
7896 Call
:= Get_Pragma_Arg
(Arg2
);
7898 Call
:= Get_Pragma_Arg
(Arg1
);
7902 N_Indexed_Component
,
7906 N_Selected_Component
)
7908 -- If this pragma Debug comes from source, its argument was
7909 -- parsed as a name form (which is syntactically identical).
7910 -- In a generic context a parameterless call will be left as
7911 -- an expanded name (if global) or selected_component if local.
7912 -- Change it to a procedure call statement now.
7914 Change_Name_To_Procedure_Call_Statement
(Call
);
7916 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
7918 -- Already in the form of a procedure call statement: nothing
7919 -- to do (could happen in case of an internally generated
7925 -- All other cases: diagnose error
7928 ("argument of pragma ""Debug"" is not procedure call",
7933 -- Rewrite into a conditional with an appropriate condition. We
7934 -- wrap the procedure call in a block so that overhead from e.g.
7935 -- use of the secondary stack does not generate execution overhead
7936 -- for suppressed conditions.
7938 Rewrite
(N
, Make_Implicit_If_Statement
(N
,
7940 Then_Statements
=> New_List
(
7941 Make_Block_Statement
(Loc
,
7942 Handled_Statement_Sequence
=>
7943 Make_Handled_Sequence_Of_Statements
(Loc
,
7944 Statements
=> New_List
(Relocate_Node
(Call
)))))));
7952 -- pragma Debug_Policy (Check | Ignore)
7954 when Pragma_Debug_Policy
=>
7956 Check_Arg_Count
(1);
7957 Check_Arg_Is_One_Of
(Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
7958 Debug_Pragmas_Enabled
:=
7959 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Check
;
7960 Debug_Pragmas_Disabled
:=
7961 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Disable
;
7963 ---------------------
7964 -- Detect_Blocking --
7965 ---------------------
7967 -- pragma Detect_Blocking;
7969 when Pragma_Detect_Blocking
=>
7971 Check_Arg_Count
(0);
7972 Check_Valid_Configuration_Pragma
;
7973 Detect_Blocking
:= True;
7975 --------------------------
7976 -- Default_Storage_Pool --
7977 --------------------------
7979 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
7981 when Pragma_Default_Storage_Pool
=>
7983 Check_Arg_Count
(1);
7985 -- Default_Storage_Pool can appear as a configuration pragma, or
7986 -- in a declarative part or a package spec.
7988 if not Is_Configuration_Pragma
then
7989 Check_Is_In_Decl_Part_Or_Package_Spec
;
7992 -- Case of Default_Storage_Pool (null);
7994 if Nkind
(Expression
(Arg1
)) = N_Null
then
7995 Analyze
(Expression
(Arg1
));
7997 -- This is an odd case, this is not really an expression, so
7998 -- we don't have a type for it. So just set the type to Empty.
8000 Set_Etype
(Expression
(Arg1
), Empty
);
8002 -- Case of Default_Storage_Pool (storage_pool_NAME);
8005 -- If it's a configuration pragma, then the only allowed
8006 -- argument is "null".
8008 if Is_Configuration_Pragma
then
8009 Error_Pragma_Arg
("NULL expected", Arg1
);
8012 -- The expected type for a non-"null" argument is
8013 -- Root_Storage_Pool'Class.
8016 (Get_Pragma_Arg
(Arg1
),
8017 Typ
=> Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
8020 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
8021 -- for an access type will use this information to set the
8022 -- appropriate attributes of the access type.
8024 Default_Pool
:= Expression
(Arg1
);
8030 when Pragma_Dimension
=>
8032 Check_Arg_Count
(4);
8033 Check_No_Identifiers
;
8034 Check_Arg_Is_Local_Name
(Arg1
);
8036 if not Is_Type
(Arg1
) then
8037 Error_Pragma
("first argument for pragma% must be subtype");
8040 Check_Arg_Is_Static_Expression
(Arg2
, Standard_Integer
);
8041 Check_Arg_Is_Static_Expression
(Arg3
, Standard_Integer
);
8042 Check_Arg_Is_Static_Expression
(Arg4
, Standard_Integer
);
8044 ------------------------------------
8045 -- Disable_Atomic_Synchronization --
8046 ------------------------------------
8048 -- pragma Disable_Atomic_Synchronization [(Entity)];
8050 when Pragma_Disable_Atomic_Synchronization
=>
8051 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
8057 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
8059 when Pragma_Discard_Names
=> Discard_Names
: declare
8064 Check_Ada_83_Warning
;
8066 -- Deal with configuration pragma case
8068 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
8069 Global_Discard_Names
:= True;
8072 -- Otherwise, check correct appropriate context
8075 Check_Is_In_Decl_Part_Or_Package_Spec
;
8077 if Arg_Count
= 0 then
8079 -- If there is no parameter, then from now on this pragma
8080 -- applies to any enumeration, exception or tagged type
8081 -- defined in the current declarative part, and recursively
8082 -- to any nested scope.
8084 Set_Discard_Names
(Current_Scope
);
8088 Check_Arg_Count
(1);
8089 Check_Optional_Identifier
(Arg1
, Name_On
);
8090 Check_Arg_Is_Local_Name
(Arg1
);
8092 E_Id
:= Get_Pragma_Arg
(Arg1
);
8094 if Etype
(E_Id
) = Any_Type
then
8100 if (Is_First_Subtype
(E
)
8102 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
8103 or else Ekind
(E
) = E_Exception
8105 Set_Discard_Names
(E
);
8108 ("inappropriate entity for pragma%", Arg1
);
8115 ------------------------
8116 -- Dispatching_Domain --
8117 ------------------------
8119 -- pragma Dispatching_Domain (EXPRESSION);
8121 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
8122 P
: constant Node_Id
:= Parent
(N
);
8127 Check_No_Identifiers
;
8128 Check_Arg_Count
(1);
8130 -- This pragma is born obsolete, but not the aspect
8132 if not From_Aspect_Specification
(N
) then
8134 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
8137 if Nkind
(P
) = N_Task_Definition
then
8138 Arg
:= Get_Pragma_Arg
(Arg1
);
8140 -- The expression must be analyzed in the special manner
8141 -- described in "Handling of Default and Per-Object
8142 -- Expressions" in sem.ads.
8144 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
8146 -- Anything else is incorrect
8152 if Has_Pragma_Dispatching_Domain
(P
) then
8153 Error_Pragma
("duplicate pragma% not allowed");
8155 Set_Has_Pragma_Dispatching_Domain
(P
, True);
8157 if Nkind
(P
) = N_Task_Definition
then
8158 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
8161 end Dispatching_Domain
;
8167 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
8169 when Pragma_Elaborate
=> Elaborate
: declare
8174 -- Pragma must be in context items list of a compilation unit
8176 if not Is_In_Context_Clause
then
8180 -- Must be at least one argument
8182 if Arg_Count
= 0 then
8183 Error_Pragma
("pragma% requires at least one argument");
8186 -- In Ada 83 mode, there can be no items following it in the
8187 -- context list except other pragmas and implicit with clauses
8188 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
8189 -- placement rule does not apply.
8191 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
8193 while Present
(Citem
) loop
8194 if Nkind
(Citem
) = N_Pragma
8195 or else (Nkind
(Citem
) = N_With_Clause
8196 and then Implicit_With
(Citem
))
8201 ("(Ada 83) pragma% must be at end of context clause");
8208 -- Finally, the arguments must all be units mentioned in a with
8209 -- clause in the same context clause. Note we already checked (in
8210 -- Par.Prag) that the arguments are all identifiers or selected
8214 Outer
: while Present
(Arg
) loop
8215 Citem
:= First
(List_Containing
(N
));
8216 Inner
: while Citem
/= N
loop
8217 if Nkind
(Citem
) = N_With_Clause
8218 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
8220 Set_Elaborate_Present
(Citem
, True);
8221 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
8222 Generate_Reference
(Entity
(Name
(Citem
)), Citem
);
8224 -- With the pragma present, elaboration calls on
8225 -- subprograms from the named unit need no further
8226 -- checks, as long as the pragma appears in the current
8227 -- compilation unit. If the pragma appears in some unit
8228 -- in the context, there might still be a need for an
8229 -- Elaborate_All_Desirable from the current compilation
8230 -- to the named unit, so we keep the check enabled.
8232 if In_Extended_Main_Source_Unit
(N
) then
8233 Set_Suppress_Elaboration_Warnings
8234 (Entity
(Name
(Citem
)));
8245 ("argument of pragma% is not with'ed unit", Arg
);
8251 -- Give a warning if operating in static mode with -gnatwl
8252 -- (elaboration warnings enabled) switch set.
8254 if Elab_Warnings
and not Dynamic_Elaboration_Checks
then
8256 ("?use of pragma Elaborate may not be safe", N
);
8258 ("?use pragma Elaborate_All instead if possible", N
);
8266 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
8268 when Pragma_Elaborate_All
=> Elaborate_All
: declare
8273 Check_Ada_83_Warning
;
8275 -- Pragma must be in context items list of a compilation unit
8277 if not Is_In_Context_Clause
then
8281 -- Must be at least one argument
8283 if Arg_Count
= 0 then
8284 Error_Pragma
("pragma% requires at least one argument");
8287 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
8288 -- have to appear at the end of the context clause, but may
8289 -- appear mixed in with other items, even in Ada 83 mode.
8291 -- Final check: the arguments must all be units mentioned in
8292 -- a with clause in the same context clause. Note that we
8293 -- already checked (in Par.Prag) that all the arguments are
8294 -- either identifiers or selected components.
8297 Outr
: while Present
(Arg
) loop
8298 Citem
:= First
(List_Containing
(N
));
8299 Innr
: while Citem
/= N
loop
8300 if Nkind
(Citem
) = N_With_Clause
8301 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
8303 Set_Elaborate_All_Present
(Citem
, True);
8304 Set_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
8306 -- Suppress warnings and elaboration checks on the named
8307 -- unit if the pragma is in the current compilation, as
8308 -- for pragma Elaborate.
8310 if In_Extended_Main_Source_Unit
(N
) then
8311 Set_Suppress_Elaboration_Warnings
8312 (Entity
(Name
(Citem
)));
8321 Set_Error_Posted
(N
);
8323 ("argument of pragma% is not with'ed unit", Arg
);
8330 --------------------
8331 -- Elaborate_Body --
8332 --------------------
8334 -- pragma Elaborate_Body [( library_unit_NAME )];
8336 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
8337 Cunit_Node
: Node_Id
;
8338 Cunit_Ent
: Entity_Id
;
8341 Check_Ada_83_Warning
;
8342 Check_Valid_Library_Unit_Pragma
;
8344 if Nkind
(N
) = N_Null_Statement
then
8348 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
8349 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
8351 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
8354 Error_Pragma
("pragma% must refer to a spec, not a body");
8356 Set_Body_Required
(Cunit_Node
, True);
8357 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
8359 -- If we are in dynamic elaboration mode, then we suppress
8360 -- elaboration warnings for the unit, since it is definitely
8361 -- fine NOT to do dynamic checks at the first level (and such
8362 -- checks will be suppressed because no elaboration boolean
8363 -- is created for Elaborate_Body packages).
8365 -- But in the static model of elaboration, Elaborate_Body is
8366 -- definitely NOT good enough to ensure elaboration safety on
8367 -- its own, since the body may WITH other units that are not
8368 -- safe from an elaboration point of view, so a client must
8369 -- still do an Elaborate_All on such units.
8371 -- Debug flag -gnatdD restores the old behavior of 3.13, where
8372 -- Elaborate_Body always suppressed elab warnings.
8374 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
8375 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
8380 ------------------------
8381 -- Elaboration_Checks --
8382 ------------------------
8384 -- pragma Elaboration_Checks (Static | Dynamic);
8386 when Pragma_Elaboration_Checks
=>
8388 Check_Arg_Count
(1);
8389 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
8390 Dynamic_Elaboration_Checks
:=
8391 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
);
8397 -- pragma Eliminate (
8398 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
8399 -- [,[Entity =>] IDENTIFIER |
8400 -- SELECTED_COMPONENT |
8402 -- [, OVERLOADING_RESOLUTION]);
8404 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
8407 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
8410 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
8412 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
8413 -- Result_Type => result_SUBTYPE_NAME]
8415 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
8416 -- SUBTYPE_NAME ::= STRING_LITERAL
8418 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
8419 -- SOURCE_TRACE ::= STRING_LITERAL
8421 when Pragma_Eliminate
=> Eliminate
: declare
8422 Args
: Args_List
(1 .. 5);
8423 Names
: constant Name_List
(1 .. 5) := (
8426 Name_Parameter_Types
,
8428 Name_Source_Location
);
8430 Unit_Name
: Node_Id
renames Args
(1);
8431 Entity
: Node_Id
renames Args
(2);
8432 Parameter_Types
: Node_Id
renames Args
(3);
8433 Result_Type
: Node_Id
renames Args
(4);
8434 Source_Location
: Node_Id
renames Args
(5);
8438 Check_Valid_Configuration_Pragma
;
8439 Gather_Associations
(Names
, Args
);
8441 if No
(Unit_Name
) then
8442 Error_Pragma
("missing Unit_Name argument for pragma%");
8446 and then (Present
(Parameter_Types
)
8448 Present
(Result_Type
)
8450 Present
(Source_Location
))
8452 Error_Pragma
("missing Entity argument for pragma%");
8455 if (Present
(Parameter_Types
)
8457 Present
(Result_Type
))
8459 Present
(Source_Location
)
8462 ("parameter profile and source location cannot " &
8463 "be used together in pragma%");
8466 Process_Eliminate_Pragma
8475 -----------------------------------
8476 -- Enable_Atomic_Synchronization --
8477 -----------------------------------
8479 -- pragma Enable_Atomic_Synchronization [(Entity)];
8481 when Pragma_Enable_Atomic_Synchronization
=>
8482 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
8489 -- [ Convention =>] convention_IDENTIFIER,
8490 -- [ Entity =>] local_NAME
8491 -- [, [External_Name =>] static_string_EXPRESSION ]
8492 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8494 when Pragma_Export
=> Export
: declare
8498 pragma Warnings
(Off
, C
);
8501 Check_Ada_83_Warning
;
8507 Check_At_Least_N_Arguments
(2);
8508 Check_At_Most_N_Arguments
(4);
8509 Process_Convention
(C
, Def_Id
);
8511 if Ekind
(Def_Id
) /= E_Constant
then
8512 Note_Possible_Modification
8513 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
8516 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8517 Set_Exported
(Def_Id
, Arg2
);
8519 -- If the entity is a deferred constant, propagate the information
8520 -- to the full view, because gigi elaborates the full view only.
8522 if Ekind
(Def_Id
) = E_Constant
8523 and then Present
(Full_View
(Def_Id
))
8526 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
8528 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
8529 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
8530 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
8535 ----------------------
8536 -- Export_Exception --
8537 ----------------------
8539 -- pragma Export_Exception (
8540 -- [Internal =>] LOCAL_NAME
8541 -- [, [External =>] EXTERNAL_SYMBOL]
8542 -- [, [Form =>] Ada | VMS]
8543 -- [, [Code =>] static_integer_EXPRESSION]);
8545 when Pragma_Export_Exception
=> Export_Exception
: declare
8546 Args
: Args_List
(1 .. 4);
8547 Names
: constant Name_List
(1 .. 4) := (
8553 Internal
: Node_Id
renames Args
(1);
8554 External
: Node_Id
renames Args
(2);
8555 Form
: Node_Id
renames Args
(3);
8556 Code
: Node_Id
renames Args
(4);
8561 if Inside_A_Generic
then
8562 Error_Pragma
("pragma% cannot be used for generic entities");
8565 Gather_Associations
(Names
, Args
);
8566 Process_Extended_Import_Export_Exception_Pragma
(
8567 Arg_Internal
=> Internal
,
8568 Arg_External
=> External
,
8572 if not Is_VMS_Exception
(Entity
(Internal
)) then
8573 Set_Exported
(Entity
(Internal
), Internal
);
8575 end Export_Exception
;
8577 ---------------------
8578 -- Export_Function --
8579 ---------------------
8581 -- pragma Export_Function (
8582 -- [Internal =>] LOCAL_NAME
8583 -- [, [External =>] EXTERNAL_SYMBOL]
8584 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8585 -- [, [Result_Type =>] TYPE_DESIGNATOR]
8586 -- [, [Mechanism =>] MECHANISM]
8587 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
8589 -- EXTERNAL_SYMBOL ::=
8591 -- | static_string_EXPRESSION
8593 -- PARAMETER_TYPES ::=
8595 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8597 -- TYPE_DESIGNATOR ::=
8599 -- | subtype_Name ' Access
8603 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8605 -- MECHANISM_ASSOCIATION ::=
8606 -- [formal_parameter_NAME =>] MECHANISM_NAME
8608 -- MECHANISM_NAME ::=
8611 -- | Descriptor [([Class =>] CLASS_NAME)]
8613 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8615 when Pragma_Export_Function
=> Export_Function
: declare
8616 Args
: Args_List
(1 .. 6);
8617 Names
: constant Name_List
(1 .. 6) := (
8620 Name_Parameter_Types
,
8623 Name_Result_Mechanism
);
8625 Internal
: Node_Id
renames Args
(1);
8626 External
: Node_Id
renames Args
(2);
8627 Parameter_Types
: Node_Id
renames Args
(3);
8628 Result_Type
: Node_Id
renames Args
(4);
8629 Mechanism
: Node_Id
renames Args
(5);
8630 Result_Mechanism
: Node_Id
renames Args
(6);
8634 Gather_Associations
(Names
, Args
);
8635 Process_Extended_Import_Export_Subprogram_Pragma
(
8636 Arg_Internal
=> Internal
,
8637 Arg_External
=> External
,
8638 Arg_Parameter_Types
=> Parameter_Types
,
8639 Arg_Result_Type
=> Result_Type
,
8640 Arg_Mechanism
=> Mechanism
,
8641 Arg_Result_Mechanism
=> Result_Mechanism
);
8642 end Export_Function
;
8648 -- pragma Export_Object (
8649 -- [Internal =>] LOCAL_NAME
8650 -- [, [External =>] EXTERNAL_SYMBOL]
8651 -- [, [Size =>] EXTERNAL_SYMBOL]);
8653 -- EXTERNAL_SYMBOL ::=
8655 -- | static_string_EXPRESSION
8657 -- PARAMETER_TYPES ::=
8659 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8661 -- TYPE_DESIGNATOR ::=
8663 -- | subtype_Name ' Access
8667 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8669 -- MECHANISM_ASSOCIATION ::=
8670 -- [formal_parameter_NAME =>] MECHANISM_NAME
8672 -- MECHANISM_NAME ::=
8675 -- | Descriptor [([Class =>] CLASS_NAME)]
8677 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8679 when Pragma_Export_Object
=> Export_Object
: declare
8680 Args
: Args_List
(1 .. 3);
8681 Names
: constant Name_List
(1 .. 3) := (
8686 Internal
: Node_Id
renames Args
(1);
8687 External
: Node_Id
renames Args
(2);
8688 Size
: Node_Id
renames Args
(3);
8692 Gather_Associations
(Names
, Args
);
8693 Process_Extended_Import_Export_Object_Pragma
(
8694 Arg_Internal
=> Internal
,
8695 Arg_External
=> External
,
8699 ----------------------
8700 -- Export_Procedure --
8701 ----------------------
8703 -- pragma Export_Procedure (
8704 -- [Internal =>] LOCAL_NAME
8705 -- [, [External =>] EXTERNAL_SYMBOL]
8706 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8707 -- [, [Mechanism =>] MECHANISM]);
8709 -- EXTERNAL_SYMBOL ::=
8711 -- | static_string_EXPRESSION
8713 -- PARAMETER_TYPES ::=
8715 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8717 -- TYPE_DESIGNATOR ::=
8719 -- | subtype_Name ' Access
8723 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8725 -- MECHANISM_ASSOCIATION ::=
8726 -- [formal_parameter_NAME =>] MECHANISM_NAME
8728 -- MECHANISM_NAME ::=
8731 -- | Descriptor [([Class =>] CLASS_NAME)]
8733 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8735 when Pragma_Export_Procedure
=> Export_Procedure
: declare
8736 Args
: Args_List
(1 .. 4);
8737 Names
: constant Name_List
(1 .. 4) := (
8740 Name_Parameter_Types
,
8743 Internal
: Node_Id
renames Args
(1);
8744 External
: Node_Id
renames Args
(2);
8745 Parameter_Types
: Node_Id
renames Args
(3);
8746 Mechanism
: Node_Id
renames Args
(4);
8750 Gather_Associations
(Names
, Args
);
8751 Process_Extended_Import_Export_Subprogram_Pragma
(
8752 Arg_Internal
=> Internal
,
8753 Arg_External
=> External
,
8754 Arg_Parameter_Types
=> Parameter_Types
,
8755 Arg_Mechanism
=> Mechanism
);
8756 end Export_Procedure
;
8762 -- pragma Export_Value (
8763 -- [Value =>] static_integer_EXPRESSION,
8764 -- [Link_Name =>] static_string_EXPRESSION);
8766 when Pragma_Export_Value
=>
8768 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
8769 Check_Arg_Count
(2);
8771 Check_Optional_Identifier
(Arg1
, Name_Value
);
8772 Check_Arg_Is_Static_Expression
(Arg1
, Any_Integer
);
8774 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
8775 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
8777 -----------------------------
8778 -- Export_Valued_Procedure --
8779 -----------------------------
8781 -- pragma Export_Valued_Procedure (
8782 -- [Internal =>] LOCAL_NAME
8783 -- [, [External =>] EXTERNAL_SYMBOL,]
8784 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8785 -- [, [Mechanism =>] MECHANISM]);
8787 -- EXTERNAL_SYMBOL ::=
8789 -- | static_string_EXPRESSION
8791 -- PARAMETER_TYPES ::=
8793 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8795 -- TYPE_DESIGNATOR ::=
8797 -- | subtype_Name ' Access
8801 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8803 -- MECHANISM_ASSOCIATION ::=
8804 -- [formal_parameter_NAME =>] MECHANISM_NAME
8806 -- MECHANISM_NAME ::=
8809 -- | Descriptor [([Class =>] CLASS_NAME)]
8811 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8813 when Pragma_Export_Valued_Procedure
=>
8814 Export_Valued_Procedure
: declare
8815 Args
: Args_List
(1 .. 4);
8816 Names
: constant Name_List
(1 .. 4) := (
8819 Name_Parameter_Types
,
8822 Internal
: Node_Id
renames Args
(1);
8823 External
: Node_Id
renames Args
(2);
8824 Parameter_Types
: Node_Id
renames Args
(3);
8825 Mechanism
: Node_Id
renames Args
(4);
8829 Gather_Associations
(Names
, Args
);
8830 Process_Extended_Import_Export_Subprogram_Pragma
(
8831 Arg_Internal
=> Internal
,
8832 Arg_External
=> External
,
8833 Arg_Parameter_Types
=> Parameter_Types
,
8834 Arg_Mechanism
=> Mechanism
);
8835 end Export_Valued_Procedure
;
8841 -- pragma Extend_System ([Name =>] Identifier);
8843 when Pragma_Extend_System
=> Extend_System
: declare
8846 Check_Valid_Configuration_Pragma
;
8847 Check_Arg_Count
(1);
8848 Check_Optional_Identifier
(Arg1
, Name_Name
);
8849 Check_Arg_Is_Identifier
(Arg1
);
8851 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
8854 and then Name_Buffer
(1 .. 4) = "aux_"
8856 if Present
(System_Extend_Pragma_Arg
) then
8857 if Chars
(Get_Pragma_Arg
(Arg1
)) =
8858 Chars
(Expression
(System_Extend_Pragma_Arg
))
8862 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
8863 Error_Pragma
("pragma% conflicts with that #");
8867 System_Extend_Pragma_Arg
:= Arg1
;
8869 if not GNAT_Mode
then
8870 System_Extend_Unit
:= Arg1
;
8874 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
8878 ------------------------
8879 -- Extensions_Allowed --
8880 ------------------------
8882 -- pragma Extensions_Allowed (ON | OFF);
8884 when Pragma_Extensions_Allowed
=>
8886 Check_Arg_Count
(1);
8887 Check_No_Identifiers
;
8888 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
8890 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
8891 Extensions_Allowed
:= True;
8892 Ada_Version
:= Ada_Version_Type
'Last;
8895 Extensions_Allowed
:= False;
8896 Ada_Version
:= Ada_Version_Explicit
;
8903 -- pragma External (
8904 -- [ Convention =>] convention_IDENTIFIER,
8905 -- [ Entity =>] local_NAME
8906 -- [, [External_Name =>] static_string_EXPRESSION ]
8907 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8909 when Pragma_External
=> External
: declare
8913 pragma Warnings
(Off
, C
);
8922 Check_At_Least_N_Arguments
(2);
8923 Check_At_Most_N_Arguments
(4);
8924 Process_Convention
(C
, Def_Id
);
8925 Note_Possible_Modification
8926 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
8927 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8928 Set_Exported
(Def_Id
, Arg2
);
8931 --------------------------
8932 -- External_Name_Casing --
8933 --------------------------
8935 -- pragma External_Name_Casing (
8936 -- UPPERCASE | LOWERCASE
8937 -- [, AS_IS | UPPERCASE | LOWERCASE]);
8939 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
8942 Check_No_Identifiers
;
8944 if Arg_Count
= 2 then
8946 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
8948 case Chars
(Get_Pragma_Arg
(Arg2
)) is
8950 Opt
.External_Name_Exp_Casing
:= As_Is
;
8952 when Name_Uppercase
=>
8953 Opt
.External_Name_Exp_Casing
:= Uppercase
;
8955 when Name_Lowercase
=>
8956 Opt
.External_Name_Exp_Casing
:= Lowercase
;
8963 Check_Arg_Count
(1);
8966 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
8968 case Chars
(Get_Pragma_Arg
(Arg1
)) is
8969 when Name_Uppercase
=>
8970 Opt
.External_Name_Imp_Casing
:= Uppercase
;
8972 when Name_Lowercase
=>
8973 Opt
.External_Name_Imp_Casing
:= Lowercase
;
8978 end External_Name_Casing
;
8980 --------------------------
8981 -- Favor_Top_Level --
8982 --------------------------
8984 -- pragma Favor_Top_Level (type_NAME);
8986 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
8987 Named_Entity
: Entity_Id
;
8991 Check_No_Identifiers
;
8992 Check_Arg_Count
(1);
8993 Check_Arg_Is_Local_Name
(Arg1
);
8994 Named_Entity
:= Entity
(Get_Pragma_Arg
(Arg1
));
8996 -- If it's an access-to-subprogram type (in particular, not a
8997 -- subtype), set the flag on that type.
8999 if Is_Access_Subprogram_Type
(Named_Entity
) then
9000 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
9002 -- Otherwise it's an error (name denotes the wrong sort of entity)
9006 ("access-to-subprogram type expected",
9007 Get_Pragma_Arg
(Arg1
));
9009 end Favor_Top_Level
;
9015 -- pragma Fast_Math;
9017 when Pragma_Fast_Math
=>
9019 Check_No_Identifiers
;
9020 Check_Valid_Configuration_Pragma
;
9023 ---------------------------
9024 -- Finalize_Storage_Only --
9025 ---------------------------
9027 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
9029 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
9030 Assoc
: constant Node_Id
:= Arg1
;
9031 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
9036 Check_No_Identifiers
;
9037 Check_Arg_Count
(1);
9038 Check_Arg_Is_Local_Name
(Arg1
);
9040 Find_Type
(Type_Id
);
9041 Typ
:= Entity
(Type_Id
);
9044 or else Rep_Item_Too_Early
(Typ
, N
)
9048 Typ
:= Underlying_Type
(Typ
);
9051 if not Is_Controlled
(Typ
) then
9052 Error_Pragma
("pragma% must specify controlled type");
9055 Check_First_Subtype
(Arg1
);
9057 if Finalize_Storage_Only
(Typ
) then
9058 Error_Pragma
("duplicate pragma%, only one allowed");
9060 elsif not Rep_Item_Too_Late
(Typ
, N
) then
9061 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
9063 end Finalize_Storage
;
9065 --------------------------
9066 -- Float_Representation --
9067 --------------------------
9069 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
9071 -- FLOAT_REP ::= VAX_Float | IEEE_Float
9073 when Pragma_Float_Representation
=> Float_Representation
: declare
9081 if Arg_Count
= 1 then
9082 Check_Valid_Configuration_Pragma
;
9084 Check_Arg_Count
(2);
9085 Check_Optional_Identifier
(Arg2
, Name_Entity
);
9086 Check_Arg_Is_Local_Name
(Arg2
);
9089 Check_No_Identifier
(Arg1
);
9090 Check_Arg_Is_One_Of
(Arg1
, Name_VAX_Float
, Name_IEEE_Float
);
9092 if not OpenVMS_On_Target
then
9093 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_VAX_Float
then
9095 ("?pragma% ignored (applies only to Open'V'M'S)");
9101 -- One argument case
9103 if Arg_Count
= 1 then
9104 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_VAX_Float
then
9105 if Opt
.Float_Format
= 'I' then
9106 Error_Pragma
("'I'E'E'E format previously specified");
9109 Opt
.Float_Format
:= 'V';
9112 if Opt
.Float_Format
= 'V' then
9113 Error_Pragma
("'V'A'X format previously specified");
9116 Opt
.Float_Format
:= 'I';
9119 Set_Standard_Fpt_Formats
;
9121 -- Two argument case
9124 Argx
:= Get_Pragma_Arg
(Arg2
);
9126 if not Is_Entity_Name
(Argx
)
9127 or else not Is_Floating_Point_Type
(Entity
(Argx
))
9130 ("second argument of% pragma must be floating-point type",
9134 Ent
:= Entity
(Argx
);
9135 Digs
:= UI_To_Int
(Digits_Value
(Ent
));
9137 -- Two arguments, VAX_Float case
9139 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_VAX_Float
then
9141 when 6 => Set_F_Float
(Ent
);
9142 when 9 => Set_D_Float
(Ent
);
9143 when 15 => Set_G_Float
(Ent
);
9147 ("wrong digits value, must be 6,9 or 15", Arg2
);
9150 -- Two arguments, IEEE_Float case
9154 when 6 => Set_IEEE_Short
(Ent
);
9155 when 15 => Set_IEEE_Long
(Ent
);
9159 ("wrong digits value, must be 6 or 15", Arg2
);
9163 end Float_Representation
;
9169 -- pragma Ident (static_string_EXPRESSION)
9171 -- Note: pragma Comment shares this processing. Pragma Comment is
9172 -- identical to Ident, except that the restriction of the argument to
9173 -- 31 characters and the placement restrictions are not enforced for
9176 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
9181 Check_Arg_Count
(1);
9182 Check_No_Identifiers
;
9183 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
9186 -- For pragma Ident, preserve DEC compatibility by requiring the
9187 -- pragma to appear in a declarative part or package spec.
9189 if Prag_Id
= Pragma_Ident
then
9190 Check_Is_In_Decl_Part_Or_Package_Spec
;
9193 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
9200 GP
:= Parent
(Parent
(N
));
9202 if Nkind_In
(GP
, N_Package_Declaration
,
9203 N_Generic_Package_Declaration
)
9208 -- If we have a compilation unit, then record the ident value,
9209 -- checking for improper duplication.
9211 if Nkind
(GP
) = N_Compilation_Unit
then
9212 CS
:= Ident_String
(Current_Sem_Unit
);
9214 if Present
(CS
) then
9216 -- For Ident, we do not permit multiple instances
9218 if Prag_Id
= Pragma_Ident
then
9219 Error_Pragma
("duplicate% pragma not permitted");
9221 -- For Comment, we concatenate the string, unless we want
9222 -- to preserve the tree structure for ASIS.
9224 elsif not ASIS_Mode
then
9225 Start_String
(Strval
(CS
));
9226 Store_String_Char
(' ');
9227 Store_String_Chars
(Strval
(Str
));
9228 Set_Strval
(CS
, End_String
);
9232 -- In VMS, the effect of IDENT is achieved by passing
9233 -- --identification=name as a --for-linker switch.
9235 if OpenVMS_On_Target
then
9238 ("--for-linker=--identification=");
9239 String_To_Name_Buffer
(Strval
(Str
));
9240 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
9242 -- Only the last processed IDENT is saved. The main
9243 -- purpose is so an IDENT associated with a main
9244 -- procedure will be used in preference to an IDENT
9245 -- associated with a with'd package.
9247 Replace_Linker_Option_String
9248 (End_String
, "--for-linker=--identification=");
9251 Set_Ident_String
(Current_Sem_Unit
, Str
);
9254 -- For subunits, we just ignore the Ident, since in GNAT these
9255 -- are not separate object files, and hence not separate units
9256 -- in the unit table.
9258 elsif Nkind
(GP
) = N_Subunit
then
9261 -- Otherwise we have a misplaced pragma Ident, but we ignore
9262 -- this if we are in an instantiation, since it comes from
9263 -- a generic, and has no relevance to the instantiation.
9265 elsif Prag_Id
= Pragma_Ident
then
9266 if Instantiation_Location
(Loc
) = No_Location
then
9267 Error_Pragma
("pragma% only allowed at outer level");
9273 ----------------------------
9274 -- Implementation_Defined --
9275 ----------------------------
9277 -- pragma Implementation_Defined (local_NAME);
9279 -- Marks previously declared entity as implementation defined. For
9280 -- an overloaded entity, applies to the most recent homonym.
9282 -- pragma Implementation_Defined;
9284 -- The form with no arguments appears anywhere within a scope, most
9285 -- typically a package spec, and indicates that all entities that are
9286 -- defined within the package spec are Implementation_Defined.
9288 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
9292 Check_No_Identifiers
;
9294 -- Form with no arguments
9296 if Arg_Count
= 0 then
9297 Set_Is_Implementation_Defined
(Current_Scope
);
9299 -- Form with one argument
9302 Check_Arg_Count
(1);
9303 Check_Arg_Is_Local_Name
(Arg1
);
9304 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
9305 Set_Is_Implementation_Defined
(Ent
);
9307 end Implementation_Defined
;
9313 -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
9314 -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
9316 when Pragma_Implemented
=> Implemented
: declare
9317 Proc_Id
: Entity_Id
;
9322 Check_Arg_Count
(2);
9323 Check_No_Identifiers
;
9324 Check_Arg_Is_Identifier
(Arg1
);
9325 Check_Arg_Is_Local_Name
(Arg1
);
9327 (Arg2
, Name_By_Any
, Name_By_Entry
, Name_By_Protected_Procedure
);
9329 -- Extract the name of the local procedure
9331 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
9333 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
9334 -- primitive procedure of a synchronized tagged type.
9336 if Ekind
(Proc_Id
) = E_Procedure
9337 and then Is_Primitive
(Proc_Id
)
9338 and then Present
(First_Formal
(Proc_Id
))
9340 Typ
:= Etype
(First_Formal
(Proc_Id
));
9342 if Is_Tagged_Type
(Typ
)
9345 -- Check for a protected, a synchronized or a task interface
9347 ((Is_Interface
(Typ
)
9348 and then Is_Synchronized_Interface
(Typ
))
9350 -- Check for a protected type or a task type that implements
9354 (Is_Concurrent_Record_Type
(Typ
)
9355 and then Present
(Interfaces
(Typ
)))
9357 -- Check for a private record extension with keyword
9361 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
9362 E_Record_Subtype_With_Private
)
9363 and then Synchronized_Present
(Parent
(Typ
))))
9368 ("controlling formal must be of synchronized " &
9369 "tagged type", Arg1
);
9373 -- Procedures declared inside a protected type must be accepted
9375 elsif Ekind
(Proc_Id
) = E_Procedure
9376 and then Is_Protected_Type
(Scope
(Proc_Id
))
9380 -- The first argument is not a primitive procedure
9384 ("pragma % must be applied to a primitive procedure", Arg1
);
9388 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
9389 -- By_Protected_Procedure to the primitive procedure of a task
9392 if Chars
(Arg2
) = Name_By_Protected_Procedure
9393 and then Is_Interface
(Typ
)
9394 and then Is_Task_Interface
(Typ
)
9397 ("implementation kind By_Protected_Procedure cannot be " &
9398 "applied to a task interface primitive", Arg2
);
9402 Record_Rep_Item
(Proc_Id
, N
);
9405 ----------------------
9406 -- Implicit_Packing --
9407 ----------------------
9409 -- pragma Implicit_Packing;
9411 when Pragma_Implicit_Packing
=>
9413 Check_Arg_Count
(0);
9414 Implicit_Packing
:= True;
9421 -- [Convention =>] convention_IDENTIFIER,
9422 -- [Entity =>] local_NAME
9423 -- [, [External_Name =>] static_string_EXPRESSION ]
9424 -- [, [Link_Name =>] static_string_EXPRESSION ]);
9426 when Pragma_Import
=>
9427 Check_Ada_83_Warning
;
9433 Check_At_Least_N_Arguments
(2);
9434 Check_At_Most_N_Arguments
(4);
9435 Process_Import_Or_Interface
;
9437 ----------------------
9438 -- Import_Exception --
9439 ----------------------
9441 -- pragma Import_Exception (
9442 -- [Internal =>] LOCAL_NAME
9443 -- [, [External =>] EXTERNAL_SYMBOL]
9444 -- [, [Form =>] Ada | VMS]
9445 -- [, [Code =>] static_integer_EXPRESSION]);
9447 when Pragma_Import_Exception
=> Import_Exception
: declare
9448 Args
: Args_List
(1 .. 4);
9449 Names
: constant Name_List
(1 .. 4) := (
9455 Internal
: Node_Id
renames Args
(1);
9456 External
: Node_Id
renames Args
(2);
9457 Form
: Node_Id
renames Args
(3);
9458 Code
: Node_Id
renames Args
(4);
9462 Gather_Associations
(Names
, Args
);
9464 if Present
(External
) and then Present
(Code
) then
9466 ("cannot give both External and Code options for pragma%");
9469 Process_Extended_Import_Export_Exception_Pragma
(
9470 Arg_Internal
=> Internal
,
9471 Arg_External
=> External
,
9475 if not Is_VMS_Exception
(Entity
(Internal
)) then
9476 Set_Imported
(Entity
(Internal
));
9478 end Import_Exception
;
9480 ---------------------
9481 -- Import_Function --
9482 ---------------------
9484 -- pragma Import_Function (
9485 -- [Internal =>] LOCAL_NAME,
9486 -- [, [External =>] EXTERNAL_SYMBOL]
9487 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
9488 -- [, [Result_Type =>] SUBTYPE_MARK]
9489 -- [, [Mechanism =>] MECHANISM]
9490 -- [, [Result_Mechanism =>] MECHANISM_NAME]
9491 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
9493 -- EXTERNAL_SYMBOL ::=
9495 -- | static_string_EXPRESSION
9497 -- PARAMETER_TYPES ::=
9499 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
9501 -- TYPE_DESIGNATOR ::=
9503 -- | subtype_Name ' Access
9507 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
9509 -- MECHANISM_ASSOCIATION ::=
9510 -- [formal_parameter_NAME =>] MECHANISM_NAME
9512 -- MECHANISM_NAME ::=
9515 -- | Descriptor [([Class =>] CLASS_NAME)]
9517 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9519 when Pragma_Import_Function
=> Import_Function
: declare
9520 Args
: Args_List
(1 .. 7);
9521 Names
: constant Name_List
(1 .. 7) := (
9524 Name_Parameter_Types
,
9527 Name_Result_Mechanism
,
9528 Name_First_Optional_Parameter
);
9530 Internal
: Node_Id
renames Args
(1);
9531 External
: Node_Id
renames Args
(2);
9532 Parameter_Types
: Node_Id
renames Args
(3);
9533 Result_Type
: Node_Id
renames Args
(4);
9534 Mechanism
: Node_Id
renames Args
(5);
9535 Result_Mechanism
: Node_Id
renames Args
(6);
9536 First_Optional_Parameter
: Node_Id
renames Args
(7);
9540 Gather_Associations
(Names
, Args
);
9541 Process_Extended_Import_Export_Subprogram_Pragma
(
9542 Arg_Internal
=> Internal
,
9543 Arg_External
=> External
,
9544 Arg_Parameter_Types
=> Parameter_Types
,
9545 Arg_Result_Type
=> Result_Type
,
9546 Arg_Mechanism
=> Mechanism
,
9547 Arg_Result_Mechanism
=> Result_Mechanism
,
9548 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
9549 end Import_Function
;
9555 -- pragma Import_Object (
9556 -- [Internal =>] LOCAL_NAME
9557 -- [, [External =>] EXTERNAL_SYMBOL]
9558 -- [, [Size =>] EXTERNAL_SYMBOL]);
9560 -- EXTERNAL_SYMBOL ::=
9562 -- | static_string_EXPRESSION
9564 when Pragma_Import_Object
=> Import_Object
: declare
9565 Args
: Args_List
(1 .. 3);
9566 Names
: constant Name_List
(1 .. 3) := (
9571 Internal
: Node_Id
renames Args
(1);
9572 External
: Node_Id
renames Args
(2);
9573 Size
: Node_Id
renames Args
(3);
9577 Gather_Associations
(Names
, Args
);
9578 Process_Extended_Import_Export_Object_Pragma
(
9579 Arg_Internal
=> Internal
,
9580 Arg_External
=> External
,
9584 ----------------------
9585 -- Import_Procedure --
9586 ----------------------
9588 -- pragma Import_Procedure (
9589 -- [Internal =>] LOCAL_NAME
9590 -- [, [External =>] EXTERNAL_SYMBOL]
9591 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
9592 -- [, [Mechanism =>] MECHANISM]
9593 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
9595 -- EXTERNAL_SYMBOL ::=
9597 -- | static_string_EXPRESSION
9599 -- PARAMETER_TYPES ::=
9601 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
9603 -- TYPE_DESIGNATOR ::=
9605 -- | subtype_Name ' Access
9609 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
9611 -- MECHANISM_ASSOCIATION ::=
9612 -- [formal_parameter_NAME =>] MECHANISM_NAME
9614 -- MECHANISM_NAME ::=
9617 -- | Descriptor [([Class =>] CLASS_NAME)]
9619 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9621 when Pragma_Import_Procedure
=> Import_Procedure
: declare
9622 Args
: Args_List
(1 .. 5);
9623 Names
: constant Name_List
(1 .. 5) := (
9626 Name_Parameter_Types
,
9628 Name_First_Optional_Parameter
);
9630 Internal
: Node_Id
renames Args
(1);
9631 External
: Node_Id
renames Args
(2);
9632 Parameter_Types
: Node_Id
renames Args
(3);
9633 Mechanism
: Node_Id
renames Args
(4);
9634 First_Optional_Parameter
: Node_Id
renames Args
(5);
9638 Gather_Associations
(Names
, Args
);
9639 Process_Extended_Import_Export_Subprogram_Pragma
(
9640 Arg_Internal
=> Internal
,
9641 Arg_External
=> External
,
9642 Arg_Parameter_Types
=> Parameter_Types
,
9643 Arg_Mechanism
=> Mechanism
,
9644 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
9645 end Import_Procedure
;
9647 -----------------------------
9648 -- Import_Valued_Procedure --
9649 -----------------------------
9651 -- pragma Import_Valued_Procedure (
9652 -- [Internal =>] LOCAL_NAME
9653 -- [, [External =>] EXTERNAL_SYMBOL]
9654 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
9655 -- [, [Mechanism =>] MECHANISM]
9656 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
9658 -- EXTERNAL_SYMBOL ::=
9660 -- | static_string_EXPRESSION
9662 -- PARAMETER_TYPES ::=
9664 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
9666 -- TYPE_DESIGNATOR ::=
9668 -- | subtype_Name ' Access
9672 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
9674 -- MECHANISM_ASSOCIATION ::=
9675 -- [formal_parameter_NAME =>] MECHANISM_NAME
9677 -- MECHANISM_NAME ::=
9680 -- | Descriptor [([Class =>] CLASS_NAME)]
9682 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9684 when Pragma_Import_Valued_Procedure
=>
9685 Import_Valued_Procedure
: declare
9686 Args
: Args_List
(1 .. 5);
9687 Names
: constant Name_List
(1 .. 5) := (
9690 Name_Parameter_Types
,
9692 Name_First_Optional_Parameter
);
9694 Internal
: Node_Id
renames Args
(1);
9695 External
: Node_Id
renames Args
(2);
9696 Parameter_Types
: Node_Id
renames Args
(3);
9697 Mechanism
: Node_Id
renames Args
(4);
9698 First_Optional_Parameter
: Node_Id
renames Args
(5);
9702 Gather_Associations
(Names
, Args
);
9703 Process_Extended_Import_Export_Subprogram_Pragma
(
9704 Arg_Internal
=> Internal
,
9705 Arg_External
=> External
,
9706 Arg_Parameter_Types
=> Parameter_Types
,
9707 Arg_Mechanism
=> Mechanism
,
9708 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
9709 end Import_Valued_Procedure
;
9715 -- pragma Independent (LOCAL_NAME);
9717 when Pragma_Independent
=> Independent
: declare
9724 Check_Ada_83_Warning
;
9726 Check_No_Identifiers
;
9727 Check_Arg_Count
(1);
9728 Check_Arg_Is_Local_Name
(Arg1
);
9729 E_Id
:= Get_Pragma_Arg
(Arg1
);
9731 if Etype
(E_Id
) = Any_Type
then
9736 D
:= Declaration_Node
(E
);
9739 -- Check duplicate before we chain ourselves!
9741 Check_Duplicate_Pragma
(E
);
9743 -- Check appropriate entity
9746 if Rep_Item_Too_Early
(E
, N
)
9748 Rep_Item_Too_Late
(E
, N
)
9752 Check_First_Subtype
(Arg1
);
9755 elsif K
= N_Object_Declaration
9756 or else (K
= N_Component_Declaration
9757 and then Original_Record_Component
(E
) = E
)
9759 if Rep_Item_Too_Late
(E
, N
) then
9765 ("inappropriate entity for pragma%", Arg1
);
9768 Independence_Checks
.Append
((N
, E
));
9771 ----------------------------
9772 -- Independent_Components --
9773 ----------------------------
9775 -- pragma Atomic_Components (array_LOCAL_NAME);
9777 -- This processing is shared by Volatile_Components
9779 when Pragma_Independent_Components
=> Independent_Components
: declare
9786 Check_Ada_83_Warning
;
9788 Check_No_Identifiers
;
9789 Check_Arg_Count
(1);
9790 Check_Arg_Is_Local_Name
(Arg1
);
9791 E_Id
:= Get_Pragma_Arg
(Arg1
);
9793 if Etype
(E_Id
) = Any_Type
then
9799 -- Check duplicate before we chain ourselves!
9801 Check_Duplicate_Pragma
(E
);
9803 -- Check appropriate entity
9805 if Rep_Item_Too_Early
(E
, N
)
9807 Rep_Item_Too_Late
(E
, N
)
9812 D
:= Declaration_Node
(E
);
9815 if (K
= N_Full_Type_Declaration
9816 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
)))
9818 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
9819 and then Nkind
(D
) = N_Object_Declaration
9820 and then Nkind
(Object_Definition
(D
)) =
9821 N_Constrained_Array_Definition
)
9823 Independence_Checks
.Append
((N
, E
));
9826 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
9828 end Independent_Components
;
9830 ------------------------
9831 -- Initialize_Scalars --
9832 ------------------------
9834 -- pragma Initialize_Scalars;
9836 when Pragma_Initialize_Scalars
=>
9838 Check_Arg_Count
(0);
9839 Check_Valid_Configuration_Pragma
;
9840 Check_Restriction
(No_Initialize_Scalars
, N
);
9842 -- Initialize_Scalars creates false positives in CodePeer, and
9843 -- incorrect negative results in Alfa mode, so ignore this pragma
9846 if not Restriction_Active
(No_Initialize_Scalars
)
9847 and then not (CodePeer_Mode
or Alfa_Mode
)
9849 Init_Or_Norm_Scalars
:= True;
9850 Initialize_Scalars
:= True;
9857 -- pragma Inline ( NAME {, NAME} );
9859 when Pragma_Inline
=>
9861 -- Pragma is active if inlining option is active
9863 Process_Inline
(Inline_Active
);
9869 -- pragma Inline_Always ( NAME {, NAME} );
9871 when Pragma_Inline_Always
=>
9874 -- Pragma always active unless in CodePeer or Alfa mode, since
9875 -- this causes walk order issues.
9877 if not (CodePeer_Mode
or Alfa_Mode
) then
9878 Process_Inline
(True);
9881 --------------------
9882 -- Inline_Generic --
9883 --------------------
9885 -- pragma Inline_Generic (NAME {, NAME});
9887 when Pragma_Inline_Generic
=>
9889 Process_Generic_List
;
9891 ----------------------
9892 -- Inspection_Point --
9893 ----------------------
9895 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
9897 when Pragma_Inspection_Point
=> Inspection_Point
: declare
9902 if Arg_Count
> 0 then
9905 Exp
:= Get_Pragma_Arg
(Arg
);
9908 if not Is_Entity_Name
(Exp
)
9909 or else not Is_Object
(Entity
(Exp
))
9911 Error_Pragma_Arg
("object name required", Arg
);
9918 end Inspection_Point
;
9924 -- pragma Interface (
9925 -- [ Convention =>] convention_IDENTIFIER,
9926 -- [ Entity =>] local_NAME
9927 -- [, [External_Name =>] static_string_EXPRESSION ]
9928 -- [, [Link_Name =>] static_string_EXPRESSION ]);
9930 when Pragma_Interface
=>
9937 Check_At_Least_N_Arguments
(2);
9938 Check_At_Most_N_Arguments
(4);
9939 Process_Import_Or_Interface
;
9941 -- In Ada 2005, the permission to use Interface (a reserved word)
9942 -- as a pragma name is considered an obsolescent feature.
9944 if Ada_Version
>= Ada_2005
then
9946 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
9949 --------------------
9950 -- Interface_Name --
9951 --------------------
9953 -- pragma Interface_Name (
9954 -- [ Entity =>] local_NAME
9955 -- [,[External_Name =>] static_string_EXPRESSION ]
9956 -- [,[Link_Name =>] static_string_EXPRESSION ]);
9958 when Pragma_Interface_Name
=> Interface_Name
: declare
9967 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
9968 Check_At_Least_N_Arguments
(2);
9969 Check_At_Most_N_Arguments
(3);
9970 Id
:= Get_Pragma_Arg
(Arg1
);
9973 if not Is_Entity_Name
(Id
) then
9975 ("first argument for pragma% must be entity name", Arg1
);
9976 elsif Etype
(Id
) = Any_Type
then
9979 Def_Id
:= Entity
(Id
);
9982 -- Special DEC-compatible processing for the object case, forces
9983 -- object to be imported.
9985 if Ekind
(Def_Id
) = E_Variable
then
9986 Kill_Size_Check_Code
(Def_Id
);
9987 Note_Possible_Modification
(Id
, Sure
=> False);
9989 -- Initialization is not allowed for imported variable
9991 if Present
(Expression
(Parent
(Def_Id
)))
9992 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
9994 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9996 ("no initialization allowed for declaration of& #",
10000 -- For compatibility, support VADS usage of providing both
10001 -- pragmas Interface and Interface_Name to obtain the effect
10002 -- of a single Import pragma.
10004 if Is_Imported
(Def_Id
)
10005 and then Present
(First_Rep_Item
(Def_Id
))
10006 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
10008 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
10012 Set_Imported
(Def_Id
);
10015 Set_Is_Public
(Def_Id
);
10016 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
10019 -- Otherwise must be subprogram
10021 elsif not Is_Subprogram
(Def_Id
) then
10023 ("argument of pragma% is not subprogram", Arg1
);
10026 Check_At_Most_N_Arguments
(3);
10030 -- Loop through homonyms
10033 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
10035 if Is_Imported
(Def_Id
) then
10036 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
10040 exit when From_Aspect_Specification
(N
);
10041 Hom_Id
:= Homonym
(Hom_Id
);
10043 exit when No
(Hom_Id
)
10044 or else Scope
(Hom_Id
) /= Current_Scope
;
10049 ("argument of pragma% is not imported subprogram",
10053 end Interface_Name
;
10055 -----------------------
10056 -- Interrupt_Handler --
10057 -----------------------
10059 -- pragma Interrupt_Handler (handler_NAME);
10061 when Pragma_Interrupt_Handler
=>
10062 Check_Ada_83_Warning
;
10063 Check_Arg_Count
(1);
10064 Check_No_Identifiers
;
10066 if No_Run_Time_Mode
then
10067 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
10069 Check_Interrupt_Or_Attach_Handler
;
10070 Process_Interrupt_Or_Attach_Handler
;
10073 ------------------------
10074 -- Interrupt_Priority --
10075 ------------------------
10077 -- pragma Interrupt_Priority [(EXPRESSION)];
10079 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
10080 P
: constant Node_Id
:= Parent
(N
);
10084 Check_Ada_83_Warning
;
10086 if Arg_Count
/= 0 then
10087 Arg
:= Get_Pragma_Arg
(Arg1
);
10088 Check_Arg_Count
(1);
10089 Check_No_Identifiers
;
10091 -- The expression must be analyzed in the special manner
10092 -- described in "Handling of Default and Per-Object
10093 -- Expressions" in sem.ads.
10095 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
10098 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
10102 elsif Has_Pragma_Priority
(P
) then
10103 Error_Pragma
("duplicate pragma% not allowed");
10106 Set_Has_Pragma_Priority
(P
, True);
10107 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
10109 end Interrupt_Priority
;
10111 ---------------------
10112 -- Interrupt_State --
10113 ---------------------
10115 -- pragma Interrupt_State (
10116 -- [Name =>] INTERRUPT_ID,
10117 -- [State =>] INTERRUPT_STATE);
10119 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
10120 -- INTERRUPT_STATE => System | Runtime | User
10122 -- Note: if the interrupt id is given as an identifier, then it must
10123 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
10124 -- given as a static integer expression which must be in the range of
10125 -- Ada.Interrupts.Interrupt_ID.
10127 when Pragma_Interrupt_State
=> Interrupt_State
: declare
10129 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
10130 -- This is the entity Ada.Interrupts.Interrupt_ID;
10132 State_Type
: Character;
10133 -- Set to 's'/'r'/'u' for System/Runtime/User
10136 -- Index to entry in Interrupt_States table
10139 -- Value of interrupt
10141 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
10142 -- The first argument to the pragma
10144 Int_Ent
: Entity_Id
;
10145 -- Interrupt entity in Ada.Interrupts.Names
10149 Check_Arg_Order
((Name_Name
, Name_State
));
10150 Check_Arg_Count
(2);
10152 Check_Optional_Identifier
(Arg1
, Name_Name
);
10153 Check_Optional_Identifier
(Arg2
, Name_State
);
10154 Check_Arg_Is_Identifier
(Arg2
);
10156 -- First argument is identifier
10158 if Nkind
(Arg1X
) = N_Identifier
then
10160 -- Search list of names in Ada.Interrupts.Names
10162 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
10164 if No
(Int_Ent
) then
10165 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
10167 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
10168 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
10172 Next_Entity
(Int_Ent
);
10175 -- First argument is not an identifier, so it must be a static
10176 -- expression of type Ada.Interrupts.Interrupt_ID.
10179 Check_Arg_Is_Static_Expression
(Arg1
, Any_Integer
);
10180 Int_Val
:= Expr_Value
(Arg1X
);
10182 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
10184 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
10187 ("value not in range of type " &
10188 """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
10194 case Chars
(Get_Pragma_Arg
(Arg2
)) is
10195 when Name_Runtime
=> State_Type
:= 'r';
10196 when Name_System
=> State_Type
:= 's';
10197 when Name_User
=> State_Type
:= 'u';
10200 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
10203 -- Check if entry is already stored
10205 IST_Num
:= Interrupt_States
.First
;
10207 -- If entry not found, add it
10209 if IST_Num
> Interrupt_States
.Last
then
10210 Interrupt_States
.Append
10211 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
10212 Interrupt_State
=> State_Type
,
10213 Pragma_Loc
=> Loc
));
10216 -- Case of entry for the same entry
10218 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
10221 -- If state matches, done, no need to make redundant entry
10224 State_Type
= Interrupt_States
.Table
(IST_Num
).
10227 -- Otherwise if state does not match, error
10230 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
10232 ("state conflicts with that given #", Arg2
);
10236 IST_Num
:= IST_Num
+ 1;
10238 end Interrupt_State
;
10244 -- pragma Invariant
10245 -- ([Entity =>] type_LOCAL_NAME,
10246 -- [Check =>] EXPRESSION
10247 -- [,[Message =>] String_Expression]);
10249 when Pragma_Invariant
=> Invariant
: declare
10254 pragma Unreferenced
(Discard
);
10258 Check_At_Least_N_Arguments
(2);
10259 Check_At_Most_N_Arguments
(3);
10260 Check_Optional_Identifier
(Arg1
, Name_Entity
);
10261 Check_Optional_Identifier
(Arg2
, Name_Check
);
10263 if Arg_Count
= 3 then
10264 Check_Optional_Identifier
(Arg3
, Name_Message
);
10265 Check_Arg_Is_Static_Expression
(Arg3
, Standard_String
);
10268 Check_Arg_Is_Local_Name
(Arg1
);
10270 Type_Id
:= Get_Pragma_Arg
(Arg1
);
10271 Find_Type
(Type_Id
);
10272 Typ
:= Entity
(Type_Id
);
10274 if Typ
= Any_Type
then
10277 -- An invariant must apply to a private type, or appear in the
10278 -- private part of a package spec and apply to a completion.
10280 elsif Ekind_In
(Typ
, E_Private_Type
,
10281 E_Record_Type_With_Private
,
10282 E_Limited_Private_Type
)
10286 elsif In_Private_Part
(Current_Scope
)
10287 and then Has_Private_Declaration
(Typ
)
10291 elsif In_Private_Part
(Current_Scope
) then
10293 ("pragma% only allowed for private type " &
10294 "declared in visible part", Arg1
);
10298 ("pragma% only allowed for private type", Arg1
);
10301 -- Note that the type has at least one invariant, and also that
10302 -- it has inheritable invariants if we have Invariant'Class.
10304 Set_Has_Invariants
(Typ
);
10306 if Class_Present
(N
) then
10307 Set_Has_Inheritable_Invariants
(Typ
);
10310 -- The remaining processing is simply to link the pragma on to
10311 -- the rep item chain, for processing when the type is frozen.
10312 -- This is accomplished by a call to Rep_Item_Too_Late.
10314 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
10317 ----------------------
10318 -- Java_Constructor --
10319 ----------------------
10321 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
10323 -- Also handles pragma CIL_Constructor
10325 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
10326 Java_Constructor
: declare
10327 Convention
: Convention_Id
;
10328 Def_Id
: Entity_Id
;
10329 Hom_Id
: Entity_Id
;
10331 This_Formal
: Entity_Id
;
10335 Check_Arg_Count
(1);
10336 Check_Optional_Identifier
(Arg1
, Name_Entity
);
10337 Check_Arg_Is_Local_Name
(Arg1
);
10339 Id
:= Get_Pragma_Arg
(Arg1
);
10340 Find_Program_Unit_Name
(Id
);
10342 -- If we did not find the name, we are done
10344 if Etype
(Id
) = Any_Type
then
10348 -- Check wrong use of pragma in wrong VM target
10350 if VM_Target
= No_VM
then
10353 elsif VM_Target
= CLI_Target
10354 and then Prag_Id
= Pragma_Java_Constructor
10356 Error_Pragma
("must use pragma 'C'I'L_'Constructor");
10358 elsif VM_Target
= JVM_Target
10359 and then Prag_Id
= Pragma_CIL_Constructor
10361 Error_Pragma
("must use pragma 'Java_'Constructor");
10365 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
10366 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
10367 when others => null;
10370 Hom_Id
:= Entity
(Id
);
10372 -- Loop through homonyms
10375 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
10377 -- The constructor is required to be a function
10379 if Ekind
(Def_Id
) /= E_Function
then
10380 if VM_Target
= JVM_Target
then
10382 ("pragma% requires function returning a " &
10383 "'Java access type", Def_Id
);
10386 ("pragma% requires function returning a " &
10387 "'C'I'L access type", Def_Id
);
10391 -- Check arguments: For tagged type the first formal must be
10392 -- named "this" and its type must be a named access type
10393 -- designating a class-wide tagged type that has convention
10394 -- CIL/Java. The first formal must also have a null default
10395 -- value. For example:
10397 -- type Typ is tagged ...
10398 -- type Ref is access all Typ;
10399 -- pragma Convention (CIL, Typ);
10401 -- function New_Typ (This : Ref) return Ref;
10402 -- function New_Typ (This : Ref; I : Integer) return Ref;
10403 -- pragma Cil_Constructor (New_Typ);
10405 -- Reason: The first formal must NOT be a primitive of the
10408 -- This rule also applies to constructors of delegates used
10409 -- to interface with standard target libraries. For example:
10411 -- type Delegate is access procedure ...
10412 -- pragma Import (CIL, Delegate, ...);
10414 -- function new_Delegate
10415 -- (This : Delegate := null; ... ) return Delegate;
10417 -- For value-types this rule does not apply.
10419 if not Is_Value_Type
(Etype
(Def_Id
)) then
10420 if No
(First_Formal
(Def_Id
)) then
10421 Error_Msg_Name_1
:= Pname
;
10422 Error_Msg_N
("% function must have parameters", Def_Id
);
10426 -- In the JRE library we have several occurrences in which
10427 -- the "this" parameter is not the first formal.
10429 This_Formal
:= First_Formal
(Def_Id
);
10431 -- In the JRE library we have several occurrences in which
10432 -- the "this" parameter is not the first formal. Search for
10435 if VM_Target
= JVM_Target
then
10436 while Present
(This_Formal
)
10437 and then Get_Name_String
(Chars
(This_Formal
)) /= "this"
10439 Next_Formal
(This_Formal
);
10442 if No
(This_Formal
) then
10443 This_Formal
:= First_Formal
(Def_Id
);
10447 -- Warning: The first parameter should be named "this".
10448 -- We temporarily allow it because we have the following
10449 -- case in the Java runtime (file s-osinte.ads) ???
10451 -- function new_Thread
10452 -- (Self_Id : System.Address) return Thread_Id;
10453 -- pragma Java_Constructor (new_Thread);
10455 if VM_Target
= JVM_Target
10456 and then Get_Name_String
(Chars
(First_Formal
(Def_Id
)))
10458 and then Etype
(First_Formal
(Def_Id
)) = RTE
(RE_Address
)
10462 elsif Get_Name_String
(Chars
(This_Formal
)) /= "this" then
10463 Error_Msg_Name_1
:= Pname
;
10465 ("first formal of % function must be named `this`",
10466 Parent
(This_Formal
));
10468 elsif not Is_Access_Type
(Etype
(This_Formal
)) then
10469 Error_Msg_Name_1
:= Pname
;
10471 ("first formal of % function must be an access type",
10472 Parameter_Type
(Parent
(This_Formal
)));
10474 -- For delegates the type of the first formal must be a
10475 -- named access-to-subprogram type (see previous example)
10477 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
10478 and then Ekind
(Etype
(This_Formal
))
10479 /= E_Access_Subprogram_Type
10481 Error_Msg_Name_1
:= Pname
;
10483 ("first formal of % function must be a named access" &
10484 " to subprogram type",
10485 Parameter_Type
(Parent
(This_Formal
)));
10487 -- Warning: We should reject anonymous access types because
10488 -- the constructor must not be handled as a primitive of the
10489 -- tagged type. We temporarily allow it because this profile
10490 -- is currently generated by cil2ada???
10492 elsif Ekind
(Etype
(Def_Id
)) /= E_Access_Subprogram_Type
10493 and then not Ekind_In
(Etype
(This_Formal
),
10495 E_General_Access_Type
,
10496 E_Anonymous_Access_Type
)
10498 Error_Msg_Name_1
:= Pname
;
10500 ("first formal of % function must be a named access" &
10502 Parameter_Type
(Parent
(This_Formal
)));
10504 elsif Atree
.Convention
10505 (Designated_Type
(Etype
(This_Formal
))) /= Convention
10507 Error_Msg_Name_1
:= Pname
;
10509 if Convention
= Convention_Java
then
10511 ("pragma% requires convention 'Cil in designated" &
10513 Parameter_Type
(Parent
(This_Formal
)));
10516 ("pragma% requires convention 'Java in designated" &
10518 Parameter_Type
(Parent
(This_Formal
)));
10521 elsif No
(Expression
(Parent
(This_Formal
)))
10522 or else Nkind
(Expression
(Parent
(This_Formal
))) /= N_Null
10524 Error_Msg_Name_1
:= Pname
;
10526 ("pragma% requires first formal with default `null`",
10527 Parameter_Type
(Parent
(This_Formal
)));
10531 -- Check result type: the constructor must be a function
10533 -- * a value type (only allowed in the CIL compiler)
10534 -- * an access-to-subprogram type with convention Java/CIL
10535 -- * an access-type designating a type that has convention
10538 if Is_Value_Type
(Etype
(Def_Id
)) then
10541 -- Access-to-subprogram type with convention Java/CIL
10543 elsif Ekind
(Etype
(Def_Id
)) = E_Access_Subprogram_Type
then
10544 if Atree
.Convention
(Etype
(Def_Id
)) /= Convention
then
10545 if Convention
= Convention_Java
then
10547 ("pragma% requires function returning a " &
10548 "'Java access type", Arg1
);
10550 pragma Assert
(Convention
= Convention_CIL
);
10552 ("pragma% requires function returning a " &
10553 "'C'I'L access type", Arg1
);
10557 elsif Ekind
(Etype
(Def_Id
)) in Access_Kind
then
10558 if not Ekind_In
(Etype
(Def_Id
), E_Access_Type
,
10559 E_General_Access_Type
)
10562 (Designated_Type
(Etype
(Def_Id
))) /= Convention
10564 Error_Msg_Name_1
:= Pname
;
10566 if Convention
= Convention_Java
then
10568 ("pragma% requires function returning a named" &
10569 "'Java access type", Arg1
);
10572 ("pragma% requires function returning a named" &
10573 "'C'I'L access type", Arg1
);
10578 Set_Is_Constructor
(Def_Id
);
10579 Set_Convention
(Def_Id
, Convention
);
10580 Set_Is_Imported
(Def_Id
);
10582 exit when From_Aspect_Specification
(N
);
10583 Hom_Id
:= Homonym
(Hom_Id
);
10585 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
10587 end Java_Constructor
;
10589 ----------------------
10590 -- Java_Interface --
10591 ----------------------
10593 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
10595 when Pragma_Java_Interface
=> Java_Interface
: declare
10601 Check_Arg_Count
(1);
10602 Check_Optional_Identifier
(Arg1
, Name_Entity
);
10603 Check_Arg_Is_Local_Name
(Arg1
);
10605 Arg
:= Get_Pragma_Arg
(Arg1
);
10608 if Etype
(Arg
) = Any_Type
then
10612 if not Is_Entity_Name
(Arg
)
10613 or else not Is_Type
(Entity
(Arg
))
10615 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
10618 Typ
:= Underlying_Type
(Entity
(Arg
));
10620 -- For now simply check some of the semantic constraints on the
10621 -- type. This currently leaves out some restrictions on interface
10622 -- types, namely that the parent type must be java.lang.Object.Typ
10623 -- and that all primitives of the type should be declared
10626 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
10627 Error_Pragma_Arg
("pragma% requires an abstract "
10628 & "tagged type", Arg1
);
10630 elsif not Has_Discriminants
(Typ
)
10631 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
10632 /= E_Anonymous_Access_Type
10634 not Is_Class_Wide_Type
10635 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
10638 ("type must have a class-wide access discriminant", Arg1
);
10640 end Java_Interface
;
10646 -- pragma Keep_Names ([On => ] local_NAME);
10648 when Pragma_Keep_Names
=> Keep_Names
: declare
10653 Check_Arg_Count
(1);
10654 Check_Optional_Identifier
(Arg1
, Name_On
);
10655 Check_Arg_Is_Local_Name
(Arg1
);
10657 Arg
:= Get_Pragma_Arg
(Arg1
);
10660 if Etype
(Arg
) = Any_Type
then
10664 if not Is_Entity_Name
(Arg
)
10665 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
10668 ("pragma% requires a local enumeration type", Arg1
);
10671 Set_Discard_Names
(Entity
(Arg
), False);
10678 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
10680 when Pragma_License
=>
10682 Check_Arg_Count
(1);
10683 Check_No_Identifiers
;
10684 Check_Valid_Configuration_Pragma
;
10685 Check_Arg_Is_Identifier
(Arg1
);
10688 Sind
: constant Source_File_Index
:=
10689 Source_Index
(Current_Sem_Unit
);
10692 case Chars
(Get_Pragma_Arg
(Arg1
)) is
10694 Set_License
(Sind
, GPL
);
10696 when Name_Modified_GPL
=>
10697 Set_License
(Sind
, Modified_GPL
);
10699 when Name_Restricted
=>
10700 Set_License
(Sind
, Restricted
);
10702 when Name_Unrestricted
=>
10703 Set_License
(Sind
, Unrestricted
);
10706 Error_Pragma_Arg
("invalid license name", Arg1
);
10714 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
10716 when Pragma_Link_With
=> Link_With
: declare
10722 if Operating_Mode
= Generate_Code
10723 and then In_Extended_Main_Source_Unit
(N
)
10725 Check_At_Least_N_Arguments
(1);
10726 Check_No_Identifiers
;
10727 Check_Is_In_Decl_Part_Or_Package_Spec
;
10728 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
10732 while Present
(Arg
) loop
10733 Check_Arg_Is_Static_Expression
(Arg
, Standard_String
);
10735 -- Store argument, converting sequences of spaces to a
10736 -- single null character (this is one of the differences
10737 -- in processing between Link_With and Linker_Options).
10739 Arg_Store
: declare
10740 C
: constant Char_Code
:= Get_Char_Code
(' ');
10741 S
: constant String_Id
:=
10742 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
10743 L
: constant Nat
:= String_Length
(S
);
10746 procedure Skip_Spaces
;
10747 -- Advance F past any spaces
10753 procedure Skip_Spaces
is
10755 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
10760 -- Start of processing for Arg_Store
10763 Skip_Spaces
; -- skip leading spaces
10765 -- Loop through characters, changing any embedded
10766 -- sequence of spaces to a single null character (this
10767 -- is how Link_With/Linker_Options differ)
10770 if Get_String_Char
(S
, F
) = C
then
10773 Store_String_Char
(ASCII
.NUL
);
10776 Store_String_Char
(Get_String_Char
(S
, F
));
10784 if Present
(Arg
) then
10785 Store_String_Char
(ASCII
.NUL
);
10789 Store_Linker_Option_String
(End_String
);
10797 -- pragma Linker_Alias (
10798 -- [Entity =>] LOCAL_NAME
10799 -- [Target =>] static_string_EXPRESSION);
10801 when Pragma_Linker_Alias
=>
10803 Check_Arg_Order
((Name_Entity
, Name_Target
));
10804 Check_Arg_Count
(2);
10805 Check_Optional_Identifier
(Arg1
, Name_Entity
);
10806 Check_Optional_Identifier
(Arg2
, Name_Target
);
10807 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
10808 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
10810 -- The only processing required is to link this item on to the
10811 -- list of rep items for the given entity. This is accomplished
10812 -- by the call to Rep_Item_Too_Late (when no error is detected
10813 -- and False is returned).
10815 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
10818 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
10821 ------------------------
10822 -- Linker_Constructor --
10823 ------------------------
10825 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
10827 -- Code is shared with Linker_Destructor
10829 -----------------------
10830 -- Linker_Destructor --
10831 -----------------------
10833 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
10835 when Pragma_Linker_Constructor |
10836 Pragma_Linker_Destructor
=>
10837 Linker_Constructor
: declare
10843 Check_Arg_Count
(1);
10844 Check_No_Identifiers
;
10845 Check_Arg_Is_Local_Name
(Arg1
);
10846 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
10848 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
10850 if not Is_Library_Level_Entity
(Proc
) then
10852 ("argument for pragma% must be library level entity", Arg1
);
10855 -- The only processing required is to link this item on to the
10856 -- list of rep items for the given entity. This is accomplished
10857 -- by the call to Rep_Item_Too_Late (when no error is detected
10858 -- and False is returned).
10860 if Rep_Item_Too_Late
(Proc
, N
) then
10863 Set_Has_Gigi_Rep_Item
(Proc
);
10865 end Linker_Constructor
;
10867 --------------------
10868 -- Linker_Options --
10869 --------------------
10871 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
10873 when Pragma_Linker_Options
=> Linker_Options
: declare
10877 Check_Ada_83_Warning
;
10878 Check_No_Identifiers
;
10879 Check_Arg_Count
(1);
10880 Check_Is_In_Decl_Part_Or_Package_Spec
;
10881 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
10882 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
10885 while Present
(Arg
) loop
10886 Check_Arg_Is_Static_Expression
(Arg
, Standard_String
);
10887 Store_String_Char
(ASCII
.NUL
);
10889 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
10893 if Operating_Mode
= Generate_Code
10894 and then In_Extended_Main_Source_Unit
(N
)
10896 Store_Linker_Option_String
(End_String
);
10898 end Linker_Options
;
10900 --------------------
10901 -- Linker_Section --
10902 --------------------
10904 -- pragma Linker_Section (
10905 -- [Entity =>] LOCAL_NAME
10906 -- [Section =>] static_string_EXPRESSION);
10908 when Pragma_Linker_Section
=>
10910 Check_Arg_Order
((Name_Entity
, Name_Section
));
10911 Check_Arg_Count
(2);
10912 Check_Optional_Identifier
(Arg1
, Name_Entity
);
10913 Check_Optional_Identifier
(Arg2
, Name_Section
);
10914 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
10915 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
10917 -- This pragma applies only to objects
10919 if not Is_Object
(Entity
(Get_Pragma_Arg
(Arg1
))) then
10920 Error_Pragma_Arg
("pragma% applies only to objects", Arg1
);
10923 -- The only processing required is to link this item on to the
10924 -- list of rep items for the given entity. This is accomplished
10925 -- by the call to Rep_Item_Too_Late (when no error is detected
10926 -- and False is returned).
10928 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
10931 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
10938 -- pragma List (On | Off)
10940 -- There is nothing to do here, since we did all the processing for
10941 -- this pragma in Par.Prag (so that it works properly even in syntax
10944 when Pragma_List
=>
10947 --------------------
10948 -- Locking_Policy --
10949 --------------------
10951 -- pragma Locking_Policy (policy_IDENTIFIER);
10953 when Pragma_Locking_Policy
=> declare
10954 subtype LP_Range
is Name_Id
10955 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
10959 Check_Ada_83_Warning
;
10960 Check_Arg_Count
(1);
10961 Check_No_Identifiers
;
10962 Check_Arg_Is_Locking_Policy
(Arg1
);
10963 Check_Valid_Configuration_Pragma
;
10964 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
10967 when Name_Ceiling_Locking
=> LP
:= 'C';
10968 when Name_Inheritance_Locking
=> LP
:= 'I';
10969 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
10972 if Locking_Policy
/= ' '
10973 and then Locking_Policy
/= LP
10975 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
10976 Error_Pragma
("locking policy incompatible with policy#");
10978 -- Set new policy, but always preserve System_Location since we
10979 -- like the error message with the run time name.
10982 Locking_Policy
:= LP
;
10984 if Locking_Policy_Sloc
/= System_Location
then
10985 Locking_Policy_Sloc
:= Loc
;
10994 -- pragma Long_Float (D_Float | G_Float);
10996 when Pragma_Long_Float
=> Long_Float : declare
10999 Check_Valid_Configuration_Pragma
;
11000 Check_Arg_Count
(1);
11001 Check_No_Identifier
(Arg1
);
11002 Check_Arg_Is_One_Of
(Arg1
, Name_D_Float
, Name_G_Float
);
11004 if not OpenVMS_On_Target
then
11005 Error_Pragma
("?pragma% ignored (applies only to Open'V'M'S)");
11010 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_D_Float
then
11011 if Opt
.Float_Format_Long
= 'G' then
11013 ("G_Float previously specified", Arg1
);
11015 elsif Current_Sem_Unit
/= Main_Unit
11016 and then Opt
.Float_Format_Long
/= 'D'
11019 ("main unit not compiled with pragma Long_Float (D_Float)",
11020 "\pragma% must be used consistently for whole partition",
11024 Opt
.Float_Format_Long
:= 'D';
11027 -- G_Float case (this is the default, does not need overriding)
11030 if Opt
.Float_Format_Long
= 'D' then
11031 Error_Pragma
("D_Float previously specified");
11033 elsif Current_Sem_Unit
/= Main_Unit
11034 and then Opt
.Float_Format_Long
/= 'G'
11037 ("main unit not compiled with pragma Long_Float (G_Float)",
11038 "\pragma% must be used consistently for whole partition",
11042 Opt
.Float_Format_Long
:= 'G';
11046 Set_Standard_Fpt_Formats
;
11049 -----------------------
11050 -- Machine_Attribute --
11051 -----------------------
11053 -- pragma Machine_Attribute (
11054 -- [Entity =>] LOCAL_NAME,
11055 -- [Attribute_Name =>] static_string_EXPRESSION
11056 -- [, [Info =>] static_EXPRESSION] );
11058 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
11059 Def_Id
: Entity_Id
;
11063 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
11065 if Arg_Count
= 3 then
11066 Check_Optional_Identifier
(Arg3
, Name_Info
);
11067 Check_Arg_Is_Static_Expression
(Arg3
);
11069 Check_Arg_Count
(2);
11072 Check_Optional_Identifier
(Arg1
, Name_Entity
);
11073 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
11074 Check_Arg_Is_Local_Name
(Arg1
);
11075 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
11076 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
11078 if Is_Access_Type
(Def_Id
) then
11079 Def_Id
:= Designated_Type
(Def_Id
);
11082 if Rep_Item_Too_Early
(Def_Id
, N
) then
11086 Def_Id
:= Underlying_Type
(Def_Id
);
11088 -- The only processing required is to link this item on to the
11089 -- list of rep items for the given entity. This is accomplished
11090 -- by the call to Rep_Item_Too_Late (when no error is detected
11091 -- and False is returned).
11093 if Rep_Item_Too_Late
(Def_Id
, N
) then
11096 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
11098 end Machine_Attribute
;
11105 -- (MAIN_OPTION [, MAIN_OPTION]);
11108 -- [STACK_SIZE =>] static_integer_EXPRESSION
11109 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
11110 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
11112 when Pragma_Main
=> Main
: declare
11113 Args
: Args_List
(1 .. 3);
11114 Names
: constant Name_List
(1 .. 3) := (
11116 Name_Task_Stack_Size_Default
,
11117 Name_Time_Slicing_Enabled
);
11123 Gather_Associations
(Names
, Args
);
11125 for J
in 1 .. 2 loop
11126 if Present
(Args
(J
)) then
11127 Check_Arg_Is_Static_Expression
(Args
(J
), Any_Integer
);
11131 if Present
(Args
(3)) then
11132 Check_Arg_Is_Static_Expression
(Args
(3), Standard_Boolean
);
11136 while Present
(Nod
) loop
11137 if Nkind
(Nod
) = N_Pragma
11138 and then Pragma_Name
(Nod
) = Name_Main
11140 Error_Msg_Name_1
:= Pname
;
11141 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
11152 -- pragma Main_Storage
11153 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
11155 -- MAIN_STORAGE_OPTION ::=
11156 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
11157 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
11159 when Pragma_Main_Storage
=> Main_Storage
: declare
11160 Args
: Args_List
(1 .. 2);
11161 Names
: constant Name_List
(1 .. 2) := (
11162 Name_Working_Storage
,
11169 Gather_Associations
(Names
, Args
);
11171 for J
in 1 .. 2 loop
11172 if Present
(Args
(J
)) then
11173 Check_Arg_Is_Static_Expression
(Args
(J
), Any_Integer
);
11177 Check_In_Main_Program
;
11180 while Present
(Nod
) loop
11181 if Nkind
(Nod
) = N_Pragma
11182 and then Pragma_Name
(Nod
) = Name_Main_Storage
11184 Error_Msg_Name_1
:= Pname
;
11185 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
11196 -- pragma Memory_Size (NUMERIC_LITERAL)
11198 when Pragma_Memory_Size
=>
11201 -- Memory size is simply ignored
11203 Check_No_Identifiers
;
11204 Check_Arg_Count
(1);
11205 Check_Arg_Is_Integer_Literal
(Arg1
);
11213 -- The only correct use of this pragma is on its own in a file, in
11214 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
11215 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
11216 -- check for a file containing nothing but a No_Body pragma). If we
11217 -- attempt to process it during normal semantics processing, it means
11218 -- it was misplaced.
11220 when Pragma_No_Body
=>
11228 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
11230 when Pragma_No_Return
=> No_Return
: declare
11238 Check_At_Least_N_Arguments
(1);
11240 -- Loop through arguments of pragma
11243 while Present
(Arg
) loop
11244 Check_Arg_Is_Local_Name
(Arg
);
11245 Id
:= Get_Pragma_Arg
(Arg
);
11248 if not Is_Entity_Name
(Id
) then
11249 Error_Pragma_Arg
("entity name required", Arg
);
11252 if Etype
(Id
) = Any_Type
then
11256 -- Loop to find matching procedures
11261 and then Scope
(E
) = Current_Scope
11263 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
11266 -- Set flag on any alias as well
11268 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
11269 Set_No_Return
(Alias
(E
));
11275 exit when From_Aspect_Specification
(N
);
11280 Error_Pragma_Arg
("no procedure & found for pragma%", Arg
);
11291 -- pragma No_Run_Time;
11293 -- Note: this pragma is retained for backwards compatibility. See
11294 -- body of Rtsfind for full details on its handling.
11296 when Pragma_No_Run_Time
=>
11298 Check_Valid_Configuration_Pragma
;
11299 Check_Arg_Count
(0);
11301 No_Run_Time_Mode
:= True;
11302 Configurable_Run_Time_Mode
:= True;
11304 -- Set Duration to 32 bits if word size is 32
11306 if Ttypes
.System_Word_Size
= 32 then
11307 Duration_32_Bits_On_Target
:= True;
11310 -- Set appropriate restrictions
11312 Set_Restriction
(No_Finalization
, N
);
11313 Set_Restriction
(No_Exception_Handlers
, N
);
11314 Set_Restriction
(Max_Tasks
, N
, 0);
11315 Set_Restriction
(No_Tasking
, N
);
11317 ------------------------
11318 -- No_Strict_Aliasing --
11319 ------------------------
11321 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
11323 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
11328 Check_At_Most_N_Arguments
(1);
11330 if Arg_Count
= 0 then
11331 Check_Valid_Configuration_Pragma
;
11332 Opt
.No_Strict_Aliasing
:= True;
11335 Check_Optional_Identifier
(Arg2
, Name_Entity
);
11336 Check_Arg_Is_Local_Name
(Arg1
);
11337 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
11339 if E_Id
= Any_Type
then
11341 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
11342 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
11345 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
11347 end No_Strict_Aliasing
;
11349 -----------------------
11350 -- Normalize_Scalars --
11351 -----------------------
11353 -- pragma Normalize_Scalars;
11355 when Pragma_Normalize_Scalars
=>
11356 Check_Ada_83_Warning
;
11357 Check_Arg_Count
(0);
11358 Check_Valid_Configuration_Pragma
;
11360 -- Normalize_Scalars creates false positives in CodePeer, and
11361 -- incorrect negative results in Alfa mode, so ignore this pragma
11364 if not (CodePeer_Mode
or Alfa_Mode
) then
11365 Normalize_Scalars
:= True;
11366 Init_Or_Norm_Scalars
:= True;
11373 -- pragma Obsolescent;
11375 -- pragma Obsolescent (
11376 -- [Message =>] static_string_EXPRESSION
11377 -- [,[Version =>] Ada_05]]);
11379 -- pragma Obsolescent (
11380 -- [Entity =>] NAME
11381 -- [,[Message =>] static_string_EXPRESSION
11382 -- [,[Version =>] Ada_05]] );
11384 when Pragma_Obsolescent
=> Obsolescent
: declare
11388 procedure Set_Obsolescent
(E
: Entity_Id
);
11389 -- Given an entity Ent, mark it as obsolescent if appropriate
11391 ---------------------
11392 -- Set_Obsolescent --
11393 ---------------------
11395 procedure Set_Obsolescent
(E
: Entity_Id
) is
11404 -- Entity name was given
11406 if Present
(Ename
) then
11408 -- If entity name matches, we are fine. Save entity in
11409 -- pragma argument, for ASIS use.
11411 if Chars
(Ename
) = Chars
(Ent
) then
11412 Set_Entity
(Ename
, Ent
);
11413 Generate_Reference
(Ent
, Ename
);
11415 -- If entity name does not match, only possibility is an
11416 -- enumeration literal from an enumeration type declaration.
11418 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
11420 ("pragma % entity name does not match declaration");
11423 Ent
:= First_Literal
(E
);
11427 ("pragma % entity name does not match any " &
11428 "enumeration literal");
11430 elsif Chars
(Ent
) = Chars
(Ename
) then
11431 Set_Entity
(Ename
, Ent
);
11432 Generate_Reference
(Ent
, Ename
);
11436 Ent
:= Next_Literal
(Ent
);
11442 -- Ent points to entity to be marked
11444 if Arg_Count
>= 1 then
11446 -- Deal with static string argument
11448 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
11449 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
11451 for J
in 1 .. String_Length
(S
) loop
11452 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
11454 ("pragma% argument does not allow wide characters",
11459 Obsolescent_Warnings
.Append
11460 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
11462 -- Check for Ada_05 parameter
11464 if Arg_Count
/= 1 then
11465 Check_Arg_Count
(2);
11468 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
11471 Check_Arg_Is_Identifier
(Argx
);
11473 if Chars
(Argx
) /= Name_Ada_05
then
11474 Error_Msg_Name_2
:= Name_Ada_05
;
11476 ("only allowed argument for pragma% is %", Argx
);
11479 if Ada_Version_Explicit
< Ada_2005
11480 or else not Warn_On_Ada_2005_Compatibility
11488 -- Set flag if pragma active
11491 Set_Is_Obsolescent
(Ent
);
11495 end Set_Obsolescent
;
11497 -- Start of processing for pragma Obsolescent
11502 Check_At_Most_N_Arguments
(3);
11504 -- See if first argument specifies an entity name
11508 (Chars
(Arg1
) = Name_Entity
11510 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
11512 N_Operator_Symbol
))
11514 Ename
:= Get_Pragma_Arg
(Arg1
);
11516 -- Eliminate first argument, so we can share processing
11520 Arg_Count
:= Arg_Count
- 1;
11522 -- No Entity name argument given
11528 if Arg_Count
>= 1 then
11529 Check_Optional_Identifier
(Arg1
, Name_Message
);
11531 if Arg_Count
= 2 then
11532 Check_Optional_Identifier
(Arg2
, Name_Version
);
11536 -- Get immediately preceding declaration
11539 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
11543 -- Cases where we do not follow anything other than another pragma
11547 -- First case: library level compilation unit declaration with
11548 -- the pragma immediately following the declaration.
11550 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
11552 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
11555 -- Case 2: library unit placement for package
11559 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
11561 if Is_Package_Or_Generic_Package
(Ent
) then
11562 Set_Obsolescent
(Ent
);
11568 -- Cases where we must follow a declaration
11571 if Nkind
(Decl
) not in N_Declaration
11572 and then Nkind
(Decl
) not in N_Later_Decl_Item
11573 and then Nkind
(Decl
) not in N_Generic_Declaration
11574 and then Nkind
(Decl
) not in N_Renaming_Declaration
11577 ("pragma% misplaced, "
11578 & "must immediately follow a declaration");
11581 Set_Obsolescent
(Defining_Entity
(Decl
));
11591 -- pragma Optimize (Time | Space | Off);
11593 -- The actual check for optimize is done in Gigi. Note that this
11594 -- pragma does not actually change the optimization setting, it
11595 -- simply checks that it is consistent with the pragma.
11597 when Pragma_Optimize
=>
11598 Check_No_Identifiers
;
11599 Check_Arg_Count
(1);
11600 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
11602 ------------------------
11603 -- Optimize_Alignment --
11604 ------------------------
11606 -- pragma Optimize_Alignment (Time | Space | Off);
11608 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
11610 Check_No_Identifiers
;
11611 Check_Arg_Count
(1);
11612 Check_Valid_Configuration_Pragma
;
11615 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
11619 Opt
.Optimize_Alignment
:= 'T';
11621 Opt
.Optimize_Alignment
:= 'S';
11623 Opt
.Optimize_Alignment
:= 'O';
11625 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
11629 -- Set indication that mode is set locally. If we are in fact in a
11630 -- configuration pragma file, this setting is harmless since the
11631 -- switch will get reset anyway at the start of each unit.
11633 Optimize_Alignment_Local
:= True;
11634 end Optimize_Alignment
;
11640 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
11642 when Pragma_Ordered
=> Ordered
: declare
11643 Assoc
: constant Node_Id
:= Arg1
;
11649 Check_No_Identifiers
;
11650 Check_Arg_Count
(1);
11651 Check_Arg_Is_Local_Name
(Arg1
);
11653 Type_Id
:= Get_Pragma_Arg
(Assoc
);
11654 Find_Type
(Type_Id
);
11655 Typ
:= Entity
(Type_Id
);
11657 if Typ
= Any_Type
then
11660 Typ
:= Underlying_Type
(Typ
);
11663 if not Is_Enumeration_Type
(Typ
) then
11664 Error_Pragma
("pragma% must specify enumeration type");
11667 Check_First_Subtype
(Arg1
);
11668 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
11675 -- pragma Pack (first_subtype_LOCAL_NAME);
11677 when Pragma_Pack
=> Pack
: declare
11678 Assoc
: constant Node_Id
:= Arg1
;
11682 Ignore
: Boolean := False;
11685 Check_No_Identifiers
;
11686 Check_Arg_Count
(1);
11687 Check_Arg_Is_Local_Name
(Arg1
);
11689 Type_Id
:= Get_Pragma_Arg
(Assoc
);
11690 Find_Type
(Type_Id
);
11691 Typ
:= Entity
(Type_Id
);
11694 or else Rep_Item_Too_Early
(Typ
, N
)
11698 Typ
:= Underlying_Type
(Typ
);
11701 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
11702 Error_Pragma
("pragma% must specify array or record type");
11705 Check_First_Subtype
(Arg1
);
11706 Check_Duplicate_Pragma
(Typ
);
11710 if Is_Array_Type
(Typ
) then
11711 Ctyp
:= Component_Type
(Typ
);
11713 -- Ignore pack that does nothing
11715 if Known_Static_Esize
(Ctyp
)
11716 and then Known_Static_RM_Size
(Ctyp
)
11717 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
11718 and then Addressable
(Esize
(Ctyp
))
11723 -- Process OK pragma Pack. Note that if there is a separate
11724 -- component clause present, the Pack will be cancelled. This
11725 -- processing is in Freeze.
11727 if not Rep_Item_Too_Late
(Typ
, N
) then
11729 -- In the context of static code analysis, we do not need
11730 -- complex front-end expansions related to pragma Pack,
11731 -- so disable handling of pragma Pack in these cases.
11733 if CodePeer_Mode
or Alfa_Mode
then
11736 -- Don't attempt any packing for VM targets. We possibly
11737 -- could deal with some cases of array bit-packing, but we
11738 -- don't bother, since this is not a typical kind of
11739 -- representation in the VM context anyway (and would not
11740 -- for example work nicely with the debugger).
11742 elsif VM_Target
/= No_VM
then
11743 if not GNAT_Mode
then
11745 ("?pragma% ignored in this configuration");
11748 -- Normal case where we do the pack action
11752 Set_Is_Packed
(Base_Type
(Typ
));
11753 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
11756 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
11760 -- For record types, the pack is always effective
11762 else pragma Assert
(Is_Record_Type
(Typ
));
11763 if not Rep_Item_Too_Late
(Typ
, N
) then
11765 -- Ignore pack request with warning in VM mode (skip warning
11766 -- if we are compiling GNAT run time library).
11768 if VM_Target
/= No_VM
then
11769 if not GNAT_Mode
then
11771 ("?pragma% ignored in this configuration");
11774 -- Normal case of pack request active
11777 Set_Is_Packed
(Base_Type
(Typ
));
11778 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
11779 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
11791 -- There is nothing to do here, since we did all the processing for
11792 -- this pragma in Par.Prag (so that it works properly even in syntax
11795 when Pragma_Page
=>
11802 -- pragma Passive [(PASSIVE_FORM)];
11804 -- PASSIVE_FORM ::= Semaphore | No
11806 when Pragma_Passive
=>
11809 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
11810 Error_Pragma
("pragma% must be within task definition");
11813 if Arg_Count
/= 0 then
11814 Check_Arg_Count
(1);
11815 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
11818 ----------------------------------
11819 -- Preelaborable_Initialization --
11820 ----------------------------------
11822 -- pragma Preelaborable_Initialization (DIRECT_NAME);
11824 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
11829 Check_Arg_Count
(1);
11830 Check_No_Identifiers
;
11831 Check_Arg_Is_Identifier
(Arg1
);
11832 Check_Arg_Is_Local_Name
(Arg1
);
11833 Check_First_Subtype
(Arg1
);
11834 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
11836 if not (Is_Private_Type
(Ent
)
11838 Is_Protected_Type
(Ent
)
11840 (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
)))
11843 ("pragma % can only be applied to private, formal derived or "
11844 & "protected type",
11848 -- Give an error if the pragma is applied to a protected type that
11849 -- does not qualify (due to having entries, or due to components
11850 -- that do not qualify).
11852 if Is_Protected_Type
(Ent
)
11853 and then not Has_Preelaborable_Initialization
(Ent
)
11856 ("protected type & does not have preelaborable " &
11857 "initialization", Ent
);
11859 -- Otherwise mark the type as definitely having preelaborable
11863 Set_Known_To_Have_Preelab_Init
(Ent
);
11866 if Has_Pragma_Preelab_Init
(Ent
)
11867 and then Warn_On_Redundant_Constructs
11869 Error_Pragma
("?duplicate pragma%!");
11871 Set_Has_Pragma_Preelab_Init
(Ent
);
11875 --------------------
11876 -- Persistent_BSS --
11877 --------------------
11879 -- pragma Persistent_BSS [(object_NAME)];
11881 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
11888 Check_At_Most_N_Arguments
(1);
11890 -- Case of application to specific object (one argument)
11892 if Arg_Count
= 1 then
11893 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
11895 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
11897 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
11900 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
11903 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
11904 Decl
:= Parent
(Ent
);
11906 if Rep_Item_Too_Late
(Ent
, N
) then
11910 if Present
(Expression
(Decl
)) then
11912 ("object for pragma% cannot have initialization", Arg1
);
11915 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
11917 ("object type for pragma% is not potentially persistent",
11921 Check_Duplicate_Pragma
(Ent
);
11924 Make_Linker_Section_Pragma
11925 (Ent
, Sloc
(N
), ".persistent.bss");
11926 Insert_After
(N
, Prag
);
11929 -- Case of use as configuration pragma with no arguments
11932 Check_Valid_Configuration_Pragma
;
11933 Persistent_BSS_Mode
:= True;
11935 end Persistent_BSS
;
11941 -- pragma Polling (ON | OFF);
11943 when Pragma_Polling
=>
11945 Check_Arg_Count
(1);
11946 Check_No_Identifiers
;
11947 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11948 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
11950 -------------------
11951 -- Postcondition --
11952 -------------------
11954 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
11955 -- [,[Message =>] String_EXPRESSION]);
11957 when Pragma_Postcondition
=> Postcondition
: declare
11959 pragma Warnings
(Off
, In_Body
);
11963 Check_At_Least_N_Arguments
(1);
11964 Check_At_Most_N_Arguments
(2);
11965 Check_Optional_Identifier
(Arg1
, Name_Check
);
11967 -- All we need to do here is call the common check procedure,
11968 -- the remainder of the processing is found in Sem_Ch6/Sem_Ch7.
11970 Check_Precondition_Postcondition
(In_Body
);
11977 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
11978 -- [,[Message =>] String_EXPRESSION]);
11980 when Pragma_Precondition
=> Precondition
: declare
11985 Check_At_Least_N_Arguments
(1);
11986 Check_At_Most_N_Arguments
(2);
11987 Check_Optional_Identifier
(Arg1
, Name_Check
);
11988 Check_Precondition_Postcondition
(In_Body
);
11990 -- If in spec, nothing more to do. If in body, then we convert the
11991 -- pragma to pragma Check (Precondition, cond [, msg]). Note we do
11992 -- this whether or not precondition checks are enabled. That works
11993 -- fine since pragma Check will do this check, and will also
11994 -- analyze the condition itself in the proper context.
11999 Chars
=> Name_Check
,
12000 Pragma_Argument_Associations
=> New_List
(
12001 Make_Pragma_Argument_Association
(Loc
,
12002 Expression
=> Make_Identifier
(Loc
, Name_Precondition
)),
12004 Make_Pragma_Argument_Association
(Sloc
(Arg1
),
12005 Expression
=> Relocate_Node
(Get_Pragma_Arg
(Arg1
))))));
12007 if Arg_Count
= 2 then
12008 Append_To
(Pragma_Argument_Associations
(N
),
12009 Make_Pragma_Argument_Association
(Sloc
(Arg2
),
12010 Expression
=> Relocate_Node
(Get_Pragma_Arg
(Arg2
))));
12021 -- pragma Predicate
12022 -- ([Entity =>] type_LOCAL_NAME,
12023 -- [Check =>] EXPRESSION);
12025 when Pragma_Predicate
=> Predicate
: declare
12030 pragma Unreferenced
(Discard
);
12034 Check_Arg_Count
(2);
12035 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12036 Check_Optional_Identifier
(Arg2
, Name_Check
);
12038 Check_Arg_Is_Local_Name
(Arg1
);
12040 Type_Id
:= Get_Pragma_Arg
(Arg1
);
12041 Find_Type
(Type_Id
);
12042 Typ
:= Entity
(Type_Id
);
12044 if Typ
= Any_Type
then
12048 -- The remaining processing is simply to link the pragma on to
12049 -- the rep item chain, for processing when the type is frozen.
12050 -- This is accomplished by a call to Rep_Item_Too_Late. We also
12051 -- mark the type as having predicates.
12053 Set_Has_Predicates
(Typ
);
12054 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
12061 -- pragma Preelaborate [(library_unit_NAME)];
12063 -- Set the flag Is_Preelaborated of program unit name entity
12065 when Pragma_Preelaborate
=> Preelaborate
: declare
12066 Pa
: constant Node_Id
:= Parent
(N
);
12067 Pk
: constant Node_Kind
:= Nkind
(Pa
);
12071 Check_Ada_83_Warning
;
12072 Check_Valid_Library_Unit_Pragma
;
12074 if Nkind
(N
) = N_Null_Statement
then
12078 Ent
:= Find_Lib_Unit_Name
;
12079 Check_Duplicate_Pragma
(Ent
);
12081 -- This filters out pragmas inside generic parent then
12082 -- show up inside instantiation
12085 and then not (Pk
= N_Package_Specification
12086 and then Present
(Generic_Parent
(Pa
)))
12088 if not Debug_Flag_U
then
12089 Set_Is_Preelaborated
(Ent
);
12090 Set_Suppress_Elaboration_Warnings
(Ent
);
12095 ---------------------
12096 -- Preelaborate_05 --
12097 ---------------------
12099 -- pragma Preelaborate_05 [(library_unit_NAME)];
12101 -- This pragma is useable only in GNAT_Mode, where it is used like
12102 -- pragma Preelaborate but it is only effective in Ada 2005 mode
12103 -- (otherwise it is ignored). This is used to implement AI-362 which
12104 -- recategorizes some run-time packages in Ada 2005 mode.
12106 when Pragma_Preelaborate_05
=> Preelaborate_05
: declare
12111 Check_Valid_Library_Unit_Pragma
;
12113 if not GNAT_Mode
then
12114 Error_Pragma
("pragma% only available in GNAT mode");
12117 if Nkind
(N
) = N_Null_Statement
then
12121 -- This is one of the few cases where we need to test the value of
12122 -- Ada_Version_Explicit rather than Ada_Version (which is always
12123 -- set to Ada_2012 in a predefined unit), we need to know the
12124 -- explicit version set to know if this pragma is active.
12126 if Ada_Version_Explicit
>= Ada_2005
then
12127 Ent
:= Find_Lib_Unit_Name
;
12128 Set_Is_Preelaborated
(Ent
);
12129 Set_Suppress_Elaboration_Warnings
(Ent
);
12131 end Preelaborate_05
;
12137 -- pragma Priority (EXPRESSION);
12139 when Pragma_Priority
=> Priority
: declare
12140 P
: constant Node_Id
:= Parent
(N
);
12144 Check_No_Identifiers
;
12145 Check_Arg_Count
(1);
12149 if Nkind
(P
) = N_Subprogram_Body
then
12150 Check_In_Main_Program
;
12152 Arg
:= Get_Pragma_Arg
(Arg1
);
12153 Analyze_And_Resolve
(Arg
, Standard_Integer
);
12157 if not Is_Static_Expression
(Arg
) then
12158 Flag_Non_Static_Expr
12159 ("main subprogram priority is not static!", Arg
);
12162 -- If constraint error, then we already signalled an error
12164 elsif Raises_Constraint_Error
(Arg
) then
12167 -- Otherwise check in range
12171 Val
: constant Uint
:= Expr_Value
(Arg
);
12175 or else Val
> Expr_Value
(Expression
12176 (Parent
(RTE
(RE_Max_Priority
))))
12179 ("main subprogram priority is out of range", Arg1
);
12185 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
12187 -- Load an arbitrary entity from System.Tasking to make sure
12188 -- this package is implicitly with'ed, since we need to have
12189 -- the tasking run-time active for the pragma Priority to have
12193 Discard
: Entity_Id
;
12194 pragma Warnings
(Off
, Discard
);
12196 Discard
:= RTE
(RE_Task_List
);
12199 -- Task or Protected, must be of type Integer
12201 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
12202 Arg
:= Get_Pragma_Arg
(Arg1
);
12204 -- The expression must be analyzed in the special manner
12205 -- described in "Handling of Default and Per-Object
12206 -- Expressions" in sem.ads.
12208 Preanalyze_Spec_Expression
(Arg
, Standard_Integer
);
12210 if not Is_Static_Expression
(Arg
) then
12211 Check_Restriction
(Static_Priorities
, Arg
);
12214 -- Anything else is incorrect
12220 if Has_Pragma_Priority
(P
) then
12221 Error_Pragma
("duplicate pragma% not allowed");
12223 Set_Has_Pragma_Priority
(P
, True);
12225 if Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
12226 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
12227 -- exp_ch9 should use this ???
12232 -----------------------------------
12233 -- Priority_Specific_Dispatching --
12234 -----------------------------------
12236 -- pragma Priority_Specific_Dispatching (
12237 -- policy_IDENTIFIER,
12238 -- first_priority_EXPRESSION,
12239 -- last_priority_EXPRESSION);
12241 when Pragma_Priority_Specific_Dispatching
=>
12242 Priority_Specific_Dispatching
: declare
12243 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
12244 -- This is the entity System.Any_Priority;
12247 Lower_Bound
: Node_Id
;
12248 Upper_Bound
: Node_Id
;
12254 Check_Arg_Count
(3);
12255 Check_No_Identifiers
;
12256 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
12257 Check_Valid_Configuration_Pragma
;
12258 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12259 DP
:= Fold_Upper
(Name_Buffer
(1));
12261 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
12262 Check_Arg_Is_Static_Expression
(Lower_Bound
, Standard_Integer
);
12263 Lower_Val
:= Expr_Value
(Lower_Bound
);
12265 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
12266 Check_Arg_Is_Static_Expression
(Upper_Bound
, Standard_Integer
);
12267 Upper_Val
:= Expr_Value
(Upper_Bound
);
12269 -- It is not allowed to use Task_Dispatching_Policy and
12270 -- Priority_Specific_Dispatching in the same partition.
12272 if Task_Dispatching_Policy
/= ' ' then
12273 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
12275 ("pragma% incompatible with Task_Dispatching_Policy#");
12277 -- Check lower bound in range
12279 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
12281 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
12284 ("first_priority is out of range", Arg2
);
12286 -- Check upper bound in range
12288 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
12290 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
12293 ("last_priority is out of range", Arg3
);
12295 -- Check that the priority range is valid
12297 elsif Lower_Val
> Upper_Val
then
12299 ("last_priority_expression must be greater than" &
12300 " or equal to first_priority_expression");
12302 -- Store the new policy, but always preserve System_Location since
12303 -- we like the error message with the run-time name.
12306 -- Check overlapping in the priority ranges specified in other
12307 -- Priority_Specific_Dispatching pragmas within the same
12308 -- partition. We can only check those we know about!
12311 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
12313 if Specific_Dispatching
.Table
(J
).First_Priority
in
12314 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
12315 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
12316 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
12319 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
12321 ("priority range overlaps with "
12322 & "Priority_Specific_Dispatching#");
12326 -- The use of Priority_Specific_Dispatching is incompatible
12327 -- with Task_Dispatching_Policy.
12329 if Task_Dispatching_Policy
/= ' ' then
12330 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
12332 ("Priority_Specific_Dispatching incompatible "
12333 & "with Task_Dispatching_Policy#");
12336 -- The use of Priority_Specific_Dispatching forces ceiling
12339 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
12340 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
12342 ("Priority_Specific_Dispatching incompatible "
12343 & "with Locking_Policy#");
12345 -- Set the Ceiling_Locking policy, but preserve System_Location
12346 -- since we like the error message with the run time name.
12349 Locking_Policy
:= 'C';
12351 if Locking_Policy_Sloc
/= System_Location
then
12352 Locking_Policy_Sloc
:= Loc
;
12356 -- Add entry in the table
12358 Specific_Dispatching
.Append
12359 ((Dispatching_Policy
=> DP
,
12360 First_Priority
=> UI_To_Int
(Lower_Val
),
12361 Last_Priority
=> UI_To_Int
(Upper_Val
),
12362 Pragma_Loc
=> Loc
));
12364 end Priority_Specific_Dispatching
;
12370 -- pragma Profile (profile_IDENTIFIER);
12372 -- profile_IDENTIFIER => Restricted | Ravenscar
12374 when Pragma_Profile
=>
12376 Check_Arg_Count
(1);
12377 Check_Valid_Configuration_Pragma
;
12378 Check_No_Identifiers
;
12381 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
12384 if Chars
(Argx
) = Name_Ravenscar
then
12385 Set_Ravenscar_Profile
(N
);
12387 elsif Chars
(Argx
) = Name_Restricted
then
12388 Set_Profile_Restrictions
12390 N
, Warn
=> Treat_Restrictions_As_Warnings
);
12392 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
12393 Set_Profile_Restrictions
12394 (No_Implementation_Extensions
,
12395 N
, Warn
=> Treat_Restrictions_As_Warnings
);
12398 Error_Pragma_Arg
("& is not a valid profile", Argx
);
12402 ----------------------
12403 -- Profile_Warnings --
12404 ----------------------
12406 -- pragma Profile_Warnings (profile_IDENTIFIER);
12408 -- profile_IDENTIFIER => Restricted | Ravenscar
12410 when Pragma_Profile_Warnings
=>
12412 Check_Arg_Count
(1);
12413 Check_Valid_Configuration_Pragma
;
12414 Check_No_Identifiers
;
12417 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
12420 if Chars
(Argx
) = Name_Ravenscar
then
12421 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
12423 elsif Chars
(Argx
) = Name_Restricted
then
12424 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
12426 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
12427 Set_Profile_Restrictions
12428 (No_Implementation_Extensions
, N
, Warn
=> True);
12431 Error_Pragma_Arg
("& is not a valid profile", Argx
);
12435 --------------------------
12436 -- Propagate_Exceptions --
12437 --------------------------
12439 -- pragma Propagate_Exceptions;
12441 -- Note: this pragma is obsolete and has no effect
12443 when Pragma_Propagate_Exceptions
=>
12445 Check_Arg_Count
(0);
12447 if In_Extended_Main_Source_Unit
(N
) then
12448 Propagate_Exceptions
:= True;
12455 -- pragma Psect_Object (
12456 -- [Internal =>] LOCAL_NAME,
12457 -- [, [External =>] EXTERNAL_SYMBOL]
12458 -- [, [Size =>] EXTERNAL_SYMBOL]);
12460 when Pragma_Psect_Object | Pragma_Common_Object
=>
12461 Psect_Object
: declare
12462 Args
: Args_List
(1 .. 3);
12463 Names
: constant Name_List
(1 .. 3) := (
12468 Internal
: Node_Id
renames Args
(1);
12469 External
: Node_Id
renames Args
(2);
12470 Size
: Node_Id
renames Args
(3);
12472 Def_Id
: Entity_Id
;
12474 procedure Check_Too_Long
(Arg
: Node_Id
);
12475 -- Posts message if the argument is an identifier with more
12476 -- than 31 characters, or a string literal with more than
12477 -- 31 characters, and we are operating under VMS
12479 --------------------
12480 -- Check_Too_Long --
12481 --------------------
12483 procedure Check_Too_Long
(Arg
: Node_Id
) is
12484 X
: constant Node_Id
:= Original_Node
(Arg
);
12487 if not Nkind_In
(X
, N_String_Literal
, N_Identifier
) then
12489 ("inappropriate argument for pragma %", Arg
);
12492 if OpenVMS_On_Target
then
12493 if (Nkind
(X
) = N_String_Literal
12494 and then String_Length
(Strval
(X
)) > 31)
12496 (Nkind
(X
) = N_Identifier
12497 and then Length_Of_Name
(Chars
(X
)) > 31)
12500 ("argument for pragma % is longer than 31 characters",
12504 end Check_Too_Long
;
12506 -- Start of processing for Common_Object/Psect_Object
12510 Gather_Associations
(Names
, Args
);
12511 Process_Extended_Import_Export_Internal_Arg
(Internal
);
12513 Def_Id
:= Entity
(Internal
);
12515 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
12517 ("pragma% must designate an object", Internal
);
12520 Check_Too_Long
(Internal
);
12522 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
12524 ("cannot use pragma% for imported/exported object",
12528 if Is_Concurrent_Type
(Etype
(Internal
)) then
12530 ("cannot specify pragma % for task/protected object",
12534 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
12536 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
12538 Error_Msg_N
("?duplicate Common/Psect_Object pragma", N
);
12541 if Ekind
(Def_Id
) = E_Constant
then
12543 ("cannot specify pragma % for a constant", Internal
);
12546 if Is_Record_Type
(Etype
(Internal
)) then
12552 Ent
:= First_Entity
(Etype
(Internal
));
12553 while Present
(Ent
) loop
12554 Decl
:= Declaration_Node
(Ent
);
12556 if Ekind
(Ent
) = E_Component
12557 and then Nkind
(Decl
) = N_Component_Declaration
12558 and then Present
(Expression
(Decl
))
12559 and then Warn_On_Export_Import
12562 ("?object for pragma % has defaults", Internal
);
12572 if Present
(Size
) then
12573 Check_Too_Long
(Size
);
12576 if Present
(External
) then
12577 Check_Arg_Is_External_Name
(External
);
12578 Check_Too_Long
(External
);
12581 -- If all error tests pass, link pragma on to the rep item chain
12583 Record_Rep_Item
(Def_Id
, N
);
12590 -- pragma Pure [(library_unit_NAME)];
12592 when Pragma_Pure
=> Pure
: declare
12596 Check_Ada_83_Warning
;
12597 Check_Valid_Library_Unit_Pragma
;
12599 if Nkind
(N
) = N_Null_Statement
then
12603 Ent
:= Find_Lib_Unit_Name
;
12605 Set_Has_Pragma_Pure
(Ent
);
12606 Set_Suppress_Elaboration_Warnings
(Ent
);
12613 -- pragma Pure_05 [(library_unit_NAME)];
12615 -- This pragma is useable only in GNAT_Mode, where it is used like
12616 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
12617 -- it is ignored). It may be used after a pragma Preelaborate, in
12618 -- which case it overrides the effect of the pragma Preelaborate.
12619 -- This is used to implement AI-362 which recategorizes some run-time
12620 -- packages in Ada 2005 mode.
12622 when Pragma_Pure_05
=> Pure_05
: declare
12627 Check_Valid_Library_Unit_Pragma
;
12629 if not GNAT_Mode
then
12630 Error_Pragma
("pragma% only available in GNAT mode");
12633 if Nkind
(N
) = N_Null_Statement
then
12637 -- This is one of the few cases where we need to test the value of
12638 -- Ada_Version_Explicit rather than Ada_Version (which is always
12639 -- set to Ada_2012 in a predefined unit), we need to know the
12640 -- explicit version set to know if this pragma is active.
12642 if Ada_Version_Explicit
>= Ada_2005
then
12643 Ent
:= Find_Lib_Unit_Name
;
12644 Set_Is_Preelaborated
(Ent
, False);
12646 Set_Suppress_Elaboration_Warnings
(Ent
);
12650 -------------------
12651 -- Pure_Function --
12652 -------------------
12654 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
12656 when Pragma_Pure_Function
=> Pure_Function
: declare
12659 Def_Id
: Entity_Id
;
12660 Effective
: Boolean := False;
12664 Check_Arg_Count
(1);
12665 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12666 Check_Arg_Is_Local_Name
(Arg1
);
12667 E_Id
:= Get_Pragma_Arg
(Arg1
);
12669 if Error_Posted
(E_Id
) then
12673 -- Loop through homonyms (overloadings) of referenced entity
12675 E
:= Entity
(E_Id
);
12677 if Present
(E
) then
12679 Def_Id
:= Get_Base_Subprogram
(E
);
12681 if not Ekind_In
(Def_Id
, E_Function
,
12682 E_Generic_Function
,
12686 ("pragma% requires a function name", Arg1
);
12689 Set_Is_Pure
(Def_Id
);
12691 if not Has_Pragma_Pure_Function
(Def_Id
) then
12692 Set_Has_Pragma_Pure_Function
(Def_Id
);
12696 exit when From_Aspect_Specification
(N
);
12698 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
12702 and then Warn_On_Redundant_Constructs
12705 ("pragma Pure_Function on& is redundant?",
12711 --------------------
12712 -- Queuing_Policy --
12713 --------------------
12715 -- pragma Queuing_Policy (policy_IDENTIFIER);
12717 when Pragma_Queuing_Policy
=> declare
12721 Check_Ada_83_Warning
;
12722 Check_Arg_Count
(1);
12723 Check_No_Identifiers
;
12724 Check_Arg_Is_Queuing_Policy
(Arg1
);
12725 Check_Valid_Configuration_Pragma
;
12726 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
12727 QP
:= Fold_Upper
(Name_Buffer
(1));
12729 if Queuing_Policy
/= ' '
12730 and then Queuing_Policy
/= QP
12732 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
12733 Error_Pragma
("queuing policy incompatible with policy#");
12735 -- Set new policy, but always preserve System_Location since we
12736 -- like the error message with the run time name.
12739 Queuing_Policy
:= QP
;
12741 if Queuing_Policy_Sloc
/= System_Location
then
12742 Queuing_Policy_Sloc
:= Loc
;
12747 -----------------------
12748 -- Relative_Deadline --
12749 -----------------------
12751 -- pragma Relative_Deadline (time_span_EXPRESSION);
12753 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
12754 P
: constant Node_Id
:= Parent
(N
);
12759 Check_No_Identifiers
;
12760 Check_Arg_Count
(1);
12762 Arg
:= Get_Pragma_Arg
(Arg1
);
12764 -- The expression must be analyzed in the special manner described
12765 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
12767 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
12771 if Nkind
(P
) = N_Subprogram_Body
then
12772 Check_In_Main_Program
;
12776 elsif Nkind
(P
) = N_Task_Definition
then
12779 -- Anything else is incorrect
12785 if Has_Relative_Deadline_Pragma
(P
) then
12786 Error_Pragma
("duplicate pragma% not allowed");
12788 Set_Has_Relative_Deadline_Pragma
(P
, True);
12790 if Nkind
(P
) = N_Task_Definition
then
12791 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
12794 end Relative_Deadline
;
12796 ---------------------------
12797 -- Remote_Call_Interface --
12798 ---------------------------
12800 -- pragma Remote_Call_Interface [(library_unit_NAME)];
12802 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
12803 Cunit_Node
: Node_Id
;
12804 Cunit_Ent
: Entity_Id
;
12808 Check_Ada_83_Warning
;
12809 Check_Valid_Library_Unit_Pragma
;
12811 if Nkind
(N
) = N_Null_Statement
then
12815 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
12816 K
:= Nkind
(Unit
(Cunit_Node
));
12817 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
12819 if K
= N_Package_Declaration
12820 or else K
= N_Generic_Package_Declaration
12821 or else K
= N_Subprogram_Declaration
12822 or else K
= N_Generic_Subprogram_Declaration
12823 or else (K
= N_Subprogram_Body
12824 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
12829 "pragma% must apply to package or subprogram declaration");
12832 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
12833 end Remote_Call_Interface
;
12839 -- pragma Remote_Types [(library_unit_NAME)];
12841 when Pragma_Remote_Types
=> Remote_Types
: declare
12842 Cunit_Node
: Node_Id
;
12843 Cunit_Ent
: Entity_Id
;
12846 Check_Ada_83_Warning
;
12847 Check_Valid_Library_Unit_Pragma
;
12849 if Nkind
(N
) = N_Null_Statement
then
12853 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
12854 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
12856 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
12857 N_Generic_Package_Declaration
)
12860 ("pragma% can only apply to a package declaration");
12863 Set_Is_Remote_Types
(Cunit_Ent
);
12870 -- pragma Ravenscar;
12872 when Pragma_Ravenscar
=>
12874 Check_Arg_Count
(0);
12875 Check_Valid_Configuration_Pragma
;
12876 Set_Ravenscar_Profile
(N
);
12878 if Warn_On_Obsolescent_Feature
then
12879 Error_Msg_N
("pragma Ravenscar is an obsolescent feature?", N
);
12880 Error_Msg_N
("|use pragma Profile (Ravenscar) instead", N
);
12883 -------------------------
12884 -- Restricted_Run_Time --
12885 -------------------------
12887 -- pragma Restricted_Run_Time;
12889 when Pragma_Restricted_Run_Time
=>
12891 Check_Arg_Count
(0);
12892 Check_Valid_Configuration_Pragma
;
12893 Set_Profile_Restrictions
12894 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
12896 if Warn_On_Obsolescent_Feature
then
12898 ("pragma Restricted_Run_Time is an obsolescent feature?", N
);
12899 Error_Msg_N
("|use pragma Profile (Restricted) instead", N
);
12906 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
12909 -- restriction_IDENTIFIER
12910 -- | restriction_parameter_IDENTIFIER => EXPRESSION
12912 when Pragma_Restrictions
=>
12913 Process_Restrictions_Or_Restriction_Warnings
12914 (Warn
=> Treat_Restrictions_As_Warnings
);
12916 --------------------------
12917 -- Restriction_Warnings --
12918 --------------------------
12920 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
12923 -- restriction_IDENTIFIER
12924 -- | restriction_parameter_IDENTIFIER => EXPRESSION
12926 when Pragma_Restriction_Warnings
=>
12928 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
12934 -- pragma Reviewable;
12936 when Pragma_Reviewable
=>
12937 Check_Ada_83_Warning
;
12938 Check_Arg_Count
(0);
12940 -- Call dummy debugging function rv. This is done to assist front
12941 -- end debugging. By placing a Reviewable pragma in the source
12942 -- program, a breakpoint on rv catches this place in the source,
12943 -- allowing convenient stepping to the point of interest.
12947 --------------------------
12948 -- Short_Circuit_And_Or --
12949 --------------------------
12951 when Pragma_Short_Circuit_And_Or
=>
12953 Check_Arg_Count
(0);
12954 Check_Valid_Configuration_Pragma
;
12955 Short_Circuit_And_Or
:= True;
12957 -------------------
12958 -- Share_Generic --
12959 -------------------
12961 -- pragma Share_Generic (NAME {, NAME});
12963 when Pragma_Share_Generic
=>
12965 Process_Generic_List
;
12971 -- pragma Shared (LOCAL_NAME);
12973 when Pragma_Shared
=>
12975 Process_Atomic_Shared_Volatile
;
12977 --------------------
12978 -- Shared_Passive --
12979 --------------------
12981 -- pragma Shared_Passive [(library_unit_NAME)];
12983 -- Set the flag Is_Shared_Passive of program unit name entity
12985 when Pragma_Shared_Passive
=> Shared_Passive
: declare
12986 Cunit_Node
: Node_Id
;
12987 Cunit_Ent
: Entity_Id
;
12990 Check_Ada_83_Warning
;
12991 Check_Valid_Library_Unit_Pragma
;
12993 if Nkind
(N
) = N_Null_Statement
then
12997 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
12998 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13000 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
13001 N_Generic_Package_Declaration
)
13004 ("pragma% can only apply to a package declaration");
13007 Set_Is_Shared_Passive
(Cunit_Ent
);
13008 end Shared_Passive
;
13010 -----------------------
13011 -- Short_Descriptors --
13012 -----------------------
13014 -- pragma Short_Descriptors;
13016 when Pragma_Short_Descriptors
=>
13018 Check_Arg_Count
(0);
13019 Check_Valid_Configuration_Pragma
;
13020 Short_Descriptors
:= True;
13022 ----------------------
13023 -- Source_File_Name --
13024 ----------------------
13026 -- There are five forms for this pragma:
13028 -- pragma Source_File_Name (
13029 -- [UNIT_NAME =>] unit_NAME,
13030 -- BODY_FILE_NAME => STRING_LITERAL
13031 -- [, [INDEX =>] INTEGER_LITERAL]);
13033 -- pragma Source_File_Name (
13034 -- [UNIT_NAME =>] unit_NAME,
13035 -- SPEC_FILE_NAME => STRING_LITERAL
13036 -- [, [INDEX =>] INTEGER_LITERAL]);
13038 -- pragma Source_File_Name (
13039 -- BODY_FILE_NAME => STRING_LITERAL
13040 -- [, DOT_REPLACEMENT => STRING_LITERAL]
13041 -- [, CASING => CASING_SPEC]);
13043 -- pragma Source_File_Name (
13044 -- SPEC_FILE_NAME => STRING_LITERAL
13045 -- [, DOT_REPLACEMENT => STRING_LITERAL]
13046 -- [, CASING => CASING_SPEC]);
13048 -- pragma Source_File_Name (
13049 -- SUBUNIT_FILE_NAME => STRING_LITERAL
13050 -- [, DOT_REPLACEMENT => STRING_LITERAL]
13051 -- [, CASING => CASING_SPEC]);
13053 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
13055 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
13056 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
13057 -- only be used when no project file is used, while SFNP can only be
13058 -- used when a project file is used.
13060 -- No processing here. Processing was completed during parsing, since
13061 -- we need to have file names set as early as possible. Units are
13062 -- loaded well before semantic processing starts.
13064 -- The only processing we defer to this point is the check for
13065 -- correct placement.
13067 when Pragma_Source_File_Name
=>
13069 Check_Valid_Configuration_Pragma
;
13071 ------------------------------
13072 -- Source_File_Name_Project --
13073 ------------------------------
13075 -- See Source_File_Name for syntax
13077 -- No processing here. Processing was completed during parsing, since
13078 -- we need to have file names set as early as possible. Units are
13079 -- loaded well before semantic processing starts.
13081 -- The only processing we defer to this point is the check for
13082 -- correct placement.
13084 when Pragma_Source_File_Name_Project
=>
13086 Check_Valid_Configuration_Pragma
;
13088 -- Check that a pragma Source_File_Name_Project is used only in a
13089 -- configuration pragmas file.
13091 -- Pragmas Source_File_Name_Project should only be generated by
13092 -- the Project Manager in configuration pragmas files.
13094 -- This is really an ugly test. It seems to depend on some
13095 -- accidental and undocumented property. At the very least it
13096 -- needs to be documented, but it would be better to have a
13097 -- clean way of testing if we are in a configuration file???
13099 if Present
(Parent
(N
)) then
13101 ("pragma% can only appear in a configuration pragmas file");
13104 ----------------------
13105 -- Source_Reference --
13106 ----------------------
13108 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
13110 -- Nothing to do, all processing completed in Par.Prag, since we need
13111 -- the information for possible parser messages that are output.
13113 when Pragma_Source_Reference
=>
13116 --------------------------------
13117 -- Static_Elaboration_Desired --
13118 --------------------------------
13120 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
13122 when Pragma_Static_Elaboration_Desired
=>
13124 Check_At_Most_N_Arguments
(1);
13126 if Is_Compilation_Unit
(Current_Scope
)
13127 and then Ekind
(Current_Scope
) = E_Package
13129 Set_Static_Elaboration_Desired
(Current_Scope
, True);
13131 Error_Pragma
("pragma% must apply to a library-level package");
13138 -- pragma Storage_Size (EXPRESSION);
13140 when Pragma_Storage_Size
=> Storage_Size
: declare
13141 P
: constant Node_Id
:= Parent
(N
);
13145 Check_No_Identifiers
;
13146 Check_Arg_Count
(1);
13148 -- The expression must be analyzed in the special manner described
13149 -- in "Handling of Default Expressions" in sem.ads.
13151 Arg
:= Get_Pragma_Arg
(Arg1
);
13152 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
13154 if not Is_Static_Expression
(Arg
) then
13155 Check_Restriction
(Static_Storage_Size
, Arg
);
13158 if Nkind
(P
) /= N_Task_Definition
then
13163 if Has_Storage_Size_Pragma
(P
) then
13164 Error_Pragma
("duplicate pragma% not allowed");
13166 Set_Has_Storage_Size_Pragma
(P
, True);
13169 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
13170 -- ??? exp_ch9 should use this!
13178 -- pragma Storage_Unit (NUMERIC_LITERAL);
13180 -- Only permitted argument is System'Storage_Unit value
13182 when Pragma_Storage_Unit
=>
13183 Check_No_Identifiers
;
13184 Check_Arg_Count
(1);
13185 Check_Arg_Is_Integer_Literal
(Arg1
);
13187 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
13188 UI_From_Int
(Ttypes
.System_Storage_Unit
)
13190 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
13192 ("the only allowed argument for pragma% is ^", Arg1
);
13195 --------------------
13196 -- Stream_Convert --
13197 --------------------
13199 -- pragma Stream_Convert (
13200 -- [Entity =>] type_LOCAL_NAME,
13201 -- [Read =>] function_NAME,
13202 -- [Write =>] function NAME);
13204 when Pragma_Stream_Convert
=> Stream_Convert
: declare
13206 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
13207 -- Check that the given argument is the name of a local function
13208 -- of one argument that is not overloaded earlier in the current
13209 -- local scope. A check is also made that the argument is a
13210 -- function with one parameter.
13212 --------------------------------------
13213 -- Check_OK_Stream_Convert_Function --
13214 --------------------------------------
13216 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
13220 Check_Arg_Is_Local_Name
(Arg
);
13221 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
13223 if Has_Homonym
(Ent
) then
13225 ("argument for pragma% may not be overloaded", Arg
);
13228 if Ekind
(Ent
) /= E_Function
13229 or else No
(First_Formal
(Ent
))
13230 or else Present
(Next_Formal
(First_Formal
(Ent
)))
13233 ("argument for pragma% must be" &
13234 " function of one argument", Arg
);
13236 end Check_OK_Stream_Convert_Function
;
13238 -- Start of processing for Stream_Convert
13242 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
13243 Check_Arg_Count
(3);
13244 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13245 Check_Optional_Identifier
(Arg2
, Name_Read
);
13246 Check_Optional_Identifier
(Arg3
, Name_Write
);
13247 Check_Arg_Is_Local_Name
(Arg1
);
13248 Check_OK_Stream_Convert_Function
(Arg2
);
13249 Check_OK_Stream_Convert_Function
(Arg3
);
13252 Typ
: constant Entity_Id
:=
13253 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
13254 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
13255 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
13258 Check_First_Subtype
(Arg1
);
13260 -- Check for too early or too late. Note that we don't enforce
13261 -- the rule about primitive operations in this case, since, as
13262 -- is the case for explicit stream attributes themselves, these
13263 -- restrictions are not appropriate. Note that the chaining of
13264 -- the pragma by Rep_Item_Too_Late is actually the critical
13265 -- processing done for this pragma.
13267 if Rep_Item_Too_Early
(Typ
, N
)
13269 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
13274 -- Return if previous error
13276 if Etype
(Typ
) = Any_Type
13278 Etype
(Read
) = Any_Type
13280 Etype
(Write
) = Any_Type
13287 if Underlying_Type
(Etype
(Read
)) /= Typ
then
13289 ("incorrect return type for function&", Arg2
);
13292 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
13294 ("incorrect parameter type for function&", Arg3
);
13297 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
13298 Underlying_Type
(Etype
(Write
))
13301 ("result type of & does not match Read parameter type",
13305 end Stream_Convert
;
13307 -------------------------
13308 -- Style_Checks (GNAT) --
13309 -------------------------
13311 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
13313 -- This is processed by the parser since some of the style checks
13314 -- take place during source scanning and parsing. This means that
13315 -- we don't need to issue error messages here.
13317 when Pragma_Style_Checks
=> Style_Checks
: declare
13318 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
13324 Check_No_Identifiers
;
13326 -- Two argument form
13328 if Arg_Count
= 2 then
13329 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13336 E_Id
:= Get_Pragma_Arg
(Arg2
);
13339 if not Is_Entity_Name
(E_Id
) then
13341 ("second argument of pragma% must be entity name",
13345 E
:= Entity
(E_Id
);
13351 Set_Suppress_Style_Checks
(E
,
13352 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
));
13353 exit when No
(Homonym
(E
));
13359 -- One argument form
13362 Check_Arg_Count
(1);
13364 if Nkind
(A
) = N_String_Literal
then
13368 Slen
: constant Natural := Natural (String_Length
(S
));
13369 Options
: String (1 .. Slen
);
13375 C
:= Get_String_Char
(S
, Int
(J
));
13376 exit when not In_Character_Range
(C
);
13377 Options
(J
) := Get_Character
(C
);
13379 -- If at end of string, set options. As per discussion
13380 -- above, no need to check for errors, since we issued
13381 -- them in the parser.
13384 Set_Style_Check_Options
(Options
);
13392 elsif Nkind
(A
) = N_Identifier
then
13393 if Chars
(A
) = Name_All_Checks
then
13395 Set_GNAT_Style_Check_Options
;
13397 Set_Default_Style_Check_Options
;
13400 elsif Chars
(A
) = Name_On
then
13401 Style_Check
:= True;
13403 elsif Chars
(A
) = Name_Off
then
13404 Style_Check
:= False;
13414 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
13416 when Pragma_Subtitle
=>
13418 Check_Arg_Count
(1);
13419 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
13420 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
13427 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
13429 when Pragma_Suppress
=>
13430 Process_Suppress_Unsuppress
(True);
13436 -- pragma Suppress_All;
13438 -- The only check made here is that the pragma has no arguments.
13439 -- There are no placement rules, and the processing required (setting
13440 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
13441 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
13442 -- then creates and inserts a pragma Suppress (All_Checks).
13444 when Pragma_Suppress_All
=>
13446 Check_Arg_Count
(0);
13448 -------------------------
13449 -- Suppress_Debug_Info --
13450 -------------------------
13452 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
13454 when Pragma_Suppress_Debug_Info
=>
13456 Check_Arg_Count
(1);
13457 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13458 Check_Arg_Is_Local_Name
(Arg1
);
13459 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
13461 ----------------------------------
13462 -- Suppress_Exception_Locations --
13463 ----------------------------------
13465 -- pragma Suppress_Exception_Locations;
13467 when Pragma_Suppress_Exception_Locations
=>
13469 Check_Arg_Count
(0);
13470 Check_Valid_Configuration_Pragma
;
13471 Exception_Locations_Suppressed
:= True;
13473 -----------------------------
13474 -- Suppress_Initialization --
13475 -----------------------------
13477 -- pragma Suppress_Initialization ([Entity =>] type_Name);
13479 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
13485 Check_Arg_Count
(1);
13486 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13487 Check_Arg_Is_Local_Name
(Arg1
);
13489 E_Id
:= Get_Pragma_Arg
(Arg1
);
13491 if Etype
(E_Id
) = Any_Type
then
13495 E
:= Entity
(E_Id
);
13497 if not Is_Type
(E
) then
13498 Error_Pragma_Arg
("pragma% requires type or subtype", Arg1
);
13501 if Rep_Item_Too_Early
(E
, N
)
13503 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
13508 -- For incomplete/private type, set flag on full view
13510 if Is_Incomplete_Or_Private_Type
(E
) then
13511 if No
(Full_View
(Base_Type
(E
))) then
13513 ("argument of pragma% cannot be an incomplete type", Arg1
);
13515 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
13518 -- For first subtype, set flag on base type
13520 elsif Is_First_Subtype
(E
) then
13521 Set_Suppress_Initialization
(Base_Type
(E
));
13523 -- For other than first subtype, set flag on subtype itself
13526 Set_Suppress_Initialization
(E
);
13534 -- pragma System_Name (DIRECT_NAME);
13536 -- Syntax check: one argument, which must be the identifier GNAT or
13537 -- the identifier GCC, no other identifiers are acceptable.
13539 when Pragma_System_Name
=>
13541 Check_No_Identifiers
;
13542 Check_Arg_Count
(1);
13543 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
13545 -----------------------------
13546 -- Task_Dispatching_Policy --
13547 -----------------------------
13549 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
13551 when Pragma_Task_Dispatching_Policy
=> declare
13555 Check_Ada_83_Warning
;
13556 Check_Arg_Count
(1);
13557 Check_No_Identifiers
;
13558 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
13559 Check_Valid_Configuration_Pragma
;
13560 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13561 DP
:= Fold_Upper
(Name_Buffer
(1));
13563 if Task_Dispatching_Policy
/= ' '
13564 and then Task_Dispatching_Policy
/= DP
13566 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
13568 ("task dispatching policy incompatible with policy#");
13570 -- Set new policy, but always preserve System_Location since we
13571 -- like the error message with the run time name.
13574 Task_Dispatching_Policy
:= DP
;
13576 if Task_Dispatching_Policy_Sloc
/= System_Location
then
13577 Task_Dispatching_Policy_Sloc
:= Loc
;
13586 -- pragma Task_Info (EXPRESSION);
13588 when Pragma_Task_Info
=> Task_Info
: declare
13589 P
: constant Node_Id
:= Parent
(N
);
13594 if Nkind
(P
) /= N_Task_Definition
then
13595 Error_Pragma
("pragma% must appear in task definition");
13598 Check_No_Identifiers
;
13599 Check_Arg_Count
(1);
13601 Analyze_And_Resolve
13602 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
13604 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
13608 if Has_Task_Info_Pragma
(P
) then
13609 Error_Pragma
("duplicate pragma% not allowed");
13611 Set_Has_Task_Info_Pragma
(P
, True);
13619 -- pragma Task_Name (string_EXPRESSION);
13621 when Pragma_Task_Name
=> Task_Name
: declare
13622 P
: constant Node_Id
:= Parent
(N
);
13626 Check_No_Identifiers
;
13627 Check_Arg_Count
(1);
13629 Arg
:= Get_Pragma_Arg
(Arg1
);
13631 -- The expression is used in the call to Create_Task, and must be
13632 -- expanded there, not in the context of the current spec. It must
13633 -- however be analyzed to capture global references, in case it
13634 -- appears in a generic context.
13636 Preanalyze_And_Resolve
(Arg
, Standard_String
);
13638 if Nkind
(P
) /= N_Task_Definition
then
13642 if Has_Task_Name_Pragma
(P
) then
13643 Error_Pragma
("duplicate pragma% not allowed");
13645 Set_Has_Task_Name_Pragma
(P
, True);
13646 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
13654 -- pragma Task_Storage (
13655 -- [Task_Type =>] LOCAL_NAME,
13656 -- [Top_Guard =>] static_integer_EXPRESSION);
13658 when Pragma_Task_Storage
=> Task_Storage
: declare
13659 Args
: Args_List
(1 .. 2);
13660 Names
: constant Name_List
(1 .. 2) := (
13664 Task_Type
: Node_Id
renames Args
(1);
13665 Top_Guard
: Node_Id
renames Args
(2);
13671 Gather_Associations
(Names
, Args
);
13673 if No
(Task_Type
) then
13675 ("missing task_type argument for pragma%");
13678 Check_Arg_Is_Local_Name
(Task_Type
);
13680 Ent
:= Entity
(Task_Type
);
13682 if not Is_Task_Type
(Ent
) then
13684 ("argument for pragma% must be task type", Task_Type
);
13687 if No
(Top_Guard
) then
13689 ("pragma% takes two arguments", Task_Type
);
13691 Check_Arg_Is_Static_Expression
(Top_Guard
, Any_Integer
);
13694 Check_First_Subtype
(Task_Type
);
13696 if Rep_Item_Too_Late
(Ent
, N
) then
13705 -- pragma Test_Case ([Name =>] Static_String_EXPRESSION
13706 -- ,[Mode =>] MODE_TYPE
13707 -- [, Requires => Boolean_EXPRESSION]
13708 -- [, Ensures => Boolean_EXPRESSION]);
13710 -- MODE_TYPE ::= Nominal | Robustness
13712 when Pragma_Test_Case
=> Test_Case
: declare
13715 Check_At_Least_N_Arguments
(2);
13716 Check_At_Most_N_Arguments
(4);
13718 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
13720 Check_Optional_Identifier
(Arg1
, Name_Name
);
13721 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
13723 -- In ASIS mode, for a pragma generated from a source aspect, also
13724 -- analyze the original aspect expression.
13727 and then Present
(Corresponding_Aspect
(N
))
13729 Check_Expr_Is_Static_Expression
13730 (Original_Node
(Get_Pragma_Arg
(Arg1
)), Standard_String
);
13733 Check_Optional_Identifier
(Arg2
, Name_Mode
);
13734 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
13736 if Arg_Count
= 4 then
13737 Check_Identifier
(Arg3
, Name_Requires
);
13738 Check_Identifier
(Arg4
, Name_Ensures
);
13740 elsif Arg_Count
= 3 then
13741 Check_Identifier_Is_One_Of
(Arg3
, Name_Requires
, Name_Ensures
);
13747 --------------------------
13748 -- Thread_Local_Storage --
13749 --------------------------
13751 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
13753 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
13759 Check_Arg_Count
(1);
13760 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13761 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
13763 Id
:= Get_Pragma_Arg
(Arg1
);
13766 if not Is_Entity_Name
(Id
)
13767 or else Ekind
(Entity
(Id
)) /= E_Variable
13769 Error_Pragma_Arg
("local variable name required", Arg1
);
13774 if Rep_Item_Too_Early
(E
, N
)
13775 or else Rep_Item_Too_Late
(E
, N
)
13780 Set_Has_Pragma_Thread_Local_Storage
(E
);
13781 Set_Has_Gigi_Rep_Item
(E
);
13782 end Thread_Local_Storage
;
13788 -- pragma Time_Slice (static_duration_EXPRESSION);
13790 when Pragma_Time_Slice
=> Time_Slice
: declare
13796 Check_Arg_Count
(1);
13797 Check_No_Identifiers
;
13798 Check_In_Main_Program
;
13799 Check_Arg_Is_Static_Expression
(Arg1
, Standard_Duration
);
13801 if not Error_Posted
(Arg1
) then
13803 while Present
(Nod
) loop
13804 if Nkind
(Nod
) = N_Pragma
13805 and then Pragma_Name
(Nod
) = Name_Time_Slice
13807 Error_Msg_Name_1
:= Pname
;
13808 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
13815 -- Process only if in main unit
13817 if Get_Source_Unit
(Loc
) = Main_Unit
then
13818 Opt
.Time_Slice_Set
:= True;
13819 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
13821 if Val
<= Ureal_0
then
13822 Opt
.Time_Slice_Value
:= 0;
13824 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
13825 Opt
.Time_Slice_Value
:= 1_000_000_000
;
13828 Opt
.Time_Slice_Value
:=
13829 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
13838 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
13840 -- TITLING_OPTION ::=
13841 -- [Title =>] STRING_LITERAL
13842 -- | [Subtitle =>] STRING_LITERAL
13844 when Pragma_Title
=> Title
: declare
13845 Args
: Args_List
(1 .. 2);
13846 Names
: constant Name_List
(1 .. 2) := (
13852 Gather_Associations
(Names
, Args
);
13855 for J
in 1 .. 2 loop
13856 if Present
(Args
(J
)) then
13857 Check_Arg_Is_Static_Expression
(Args
(J
), Standard_String
);
13862 ---------------------
13863 -- Unchecked_Union --
13864 ---------------------
13866 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
13868 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
13869 Assoc
: constant Node_Id
:= Arg1
;
13870 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
13881 Check_No_Identifiers
;
13882 Check_Arg_Count
(1);
13883 Check_Arg_Is_Local_Name
(Arg1
);
13885 Find_Type
(Type_Id
);
13886 Typ
:= Entity
(Type_Id
);
13889 or else Rep_Item_Too_Early
(Typ
, N
)
13893 Typ
:= Underlying_Type
(Typ
);
13896 if Rep_Item_Too_Late
(Typ
, N
) then
13900 Check_First_Subtype
(Arg1
);
13902 -- Note remaining cases are references to a type in the current
13903 -- declarative part. If we find an error, we post the error on
13904 -- the relevant type declaration at an appropriate point.
13906 if not Is_Record_Type
(Typ
) then
13907 Error_Msg_N
("Unchecked_Union must be record type", Typ
);
13910 elsif Is_Tagged_Type
(Typ
) then
13911 Error_Msg_N
("Unchecked_Union must not be tagged", Typ
);
13914 elsif not Has_Discriminants
(Typ
) then
13916 ("Unchecked_Union must have one discriminant", Typ
);
13919 -- Note: in previous versions of GNAT we used to check for limited
13920 -- types and give an error, but in fact the standard does allow
13921 -- Unchecked_Union on limited types, so this check was removed.
13923 -- Proceed with basic error checks completed
13926 Discr
:= First_Discriminant
(Typ
);
13927 while Present
(Discr
) loop
13928 if No
(Discriminant_Default_Value
(Discr
)) then
13930 ("Unchecked_Union discriminant must have default value",
13934 Next_Discriminant
(Discr
);
13937 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
13938 Clist
:= Component_List
(Tdef
);
13940 Comp
:= First
(Component_Items
(Clist
));
13941 while Present
(Comp
) loop
13942 Check_Component
(Comp
, Typ
);
13946 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
13948 ("Unchecked_Union must have variant part",
13953 Vpart
:= Variant_Part
(Clist
);
13955 Variant
:= First
(Variants
(Vpart
));
13956 while Present
(Variant
) loop
13957 Check_Variant
(Variant
, Typ
);
13962 Set_Is_Unchecked_Union
(Typ
);
13963 Set_Convention
(Typ
, Convention_C
);
13964 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
13965 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
13966 end Unchecked_Union
;
13968 ------------------------
13969 -- Unimplemented_Unit --
13970 ------------------------
13972 -- pragma Unimplemented_Unit;
13974 -- Note: this only gives an error if we are generating code, or if
13975 -- we are in a generic library unit (where the pragma appears in the
13976 -- body, not in the spec).
13978 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
13979 Cunitent
: constant Entity_Id
:=
13980 Cunit_Entity
(Get_Source_Unit
(Loc
));
13981 Ent_Kind
: constant Entity_Kind
:=
13986 Check_Arg_Count
(0);
13988 if Operating_Mode
= Generate_Code
13989 or else Ent_Kind
= E_Generic_Function
13990 or else Ent_Kind
= E_Generic_Procedure
13991 or else Ent_Kind
= E_Generic_Package
13993 Get_Name_String
(Chars
(Cunitent
));
13994 Set_Casing
(Mixed_Case
);
13995 Write_Str
(Name_Buffer
(1 .. Name_Len
));
13996 Write_Str
(" is not supported in this configuration");
13998 raise Unrecoverable_Error
;
14000 end Unimplemented_Unit
;
14002 ------------------------
14003 -- Universal_Aliasing --
14004 ------------------------
14006 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
14008 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
14013 Check_Arg_Count
(1);
14014 Check_Optional_Identifier
(Arg2
, Name_Entity
);
14015 Check_Arg_Is_Local_Name
(Arg1
);
14016 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
14018 if E_Id
= Any_Type
then
14020 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
14021 Error_Pragma_Arg
("pragma% requires type", Arg1
);
14024 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
14025 end Universal_Alias
;
14027 --------------------
14028 -- Universal_Data --
14029 --------------------
14031 -- pragma Universal_Data [(library_unit_NAME)];
14033 when Pragma_Universal_Data
=>
14036 -- If this is a configuration pragma, then set the universal
14037 -- addressing option, otherwise confirm that the pragma satisfies
14038 -- the requirements of library unit pragma placement and leave it
14039 -- to the GNAAMP back end to detect the pragma (avoids transitive
14040 -- setting of the option due to withed units).
14042 if Is_Configuration_Pragma
then
14043 Universal_Addressing_On_AAMP
:= True;
14045 Check_Valid_Library_Unit_Pragma
;
14048 if not AAMP_On_Target
then
14049 Error_Pragma
("?pragma% ignored (applies only to AAMP)");
14056 -- pragma Unmodified (local_Name {, local_Name});
14058 when Pragma_Unmodified
=> Unmodified
: declare
14059 Arg_Node
: Node_Id
;
14060 Arg_Expr
: Node_Id
;
14061 Arg_Ent
: Entity_Id
;
14065 Check_At_Least_N_Arguments
(1);
14067 -- Loop through arguments
14070 while Present
(Arg_Node
) loop
14071 Check_No_Identifier
(Arg_Node
);
14073 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
14074 -- in fact generate reference, so that the entity will have a
14075 -- reference, which will inhibit any warnings about it not
14076 -- being referenced, and also properly show up in the ali file
14077 -- as a reference. But this reference is recorded before the
14078 -- Has_Pragma_Unreferenced flag is set, so that no warning is
14079 -- generated for this reference.
14081 Check_Arg_Is_Local_Name
(Arg_Node
);
14082 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
14084 if Is_Entity_Name
(Arg_Expr
) then
14085 Arg_Ent
:= Entity
(Arg_Expr
);
14087 if not Is_Assignable
(Arg_Ent
) then
14089 ("pragma% can only be applied to a variable",
14092 Set_Has_Pragma_Unmodified
(Arg_Ent
);
14104 -- pragma Unreferenced (local_Name {, local_Name});
14106 -- or when used in a context clause:
14108 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
14110 when Pragma_Unreferenced
=> Unreferenced
: declare
14111 Arg_Node
: Node_Id
;
14112 Arg_Expr
: Node_Id
;
14113 Arg_Ent
: Entity_Id
;
14118 Check_At_Least_N_Arguments
(1);
14120 -- Check case of appearing within context clause
14122 if Is_In_Context_Clause
then
14124 -- The arguments must all be units mentioned in a with clause
14125 -- in the same context clause. Note we already checked (in
14126 -- Par.Prag) that the arguments are either identifiers or
14127 -- selected components.
14130 while Present
(Arg_Node
) loop
14131 Citem
:= First
(List_Containing
(N
));
14132 while Citem
/= N
loop
14133 if Nkind
(Citem
) = N_With_Clause
14135 Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg_Node
))
14137 Set_Has_Pragma_Unreferenced
14140 (Library_Unit
(Citem
))));
14142 (Get_Pragma_Arg
(Arg_Node
), Name
(Citem
));
14151 ("argument of pragma% is not with'ed unit", Arg_Node
);
14157 -- Case of not in list of context items
14161 while Present
(Arg_Node
) loop
14162 Check_No_Identifier
(Arg_Node
);
14164 -- Note: the analyze call done by Check_Arg_Is_Local_Name
14165 -- will in fact generate reference, so that the entity will
14166 -- have a reference, which will inhibit any warnings about
14167 -- it not being referenced, and also properly show up in the
14168 -- ali file as a reference. But this reference is recorded
14169 -- before the Has_Pragma_Unreferenced flag is set, so that
14170 -- no warning is generated for this reference.
14172 Check_Arg_Is_Local_Name
(Arg_Node
);
14173 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
14175 if Is_Entity_Name
(Arg_Expr
) then
14176 Arg_Ent
:= Entity
(Arg_Expr
);
14178 -- If the entity is overloaded, the pragma applies to the
14179 -- most recent overloading, as documented. In this case,
14180 -- name resolution does not generate a reference, so it
14181 -- must be done here explicitly.
14183 if Is_Overloaded
(Arg_Expr
) then
14184 Generate_Reference
(Arg_Ent
, N
);
14187 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
14195 --------------------------
14196 -- Unreferenced_Objects --
14197 --------------------------
14199 -- pragma Unreferenced_Objects (local_Name {, local_Name});
14201 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
14202 Arg_Node
: Node_Id
;
14203 Arg_Expr
: Node_Id
;
14207 Check_At_Least_N_Arguments
(1);
14210 while Present
(Arg_Node
) loop
14211 Check_No_Identifier
(Arg_Node
);
14212 Check_Arg_Is_Local_Name
(Arg_Node
);
14213 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
14215 if not Is_Entity_Name
(Arg_Expr
)
14216 or else not Is_Type
(Entity
(Arg_Expr
))
14219 ("argument for pragma% must be type or subtype", Arg_Node
);
14222 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
14225 end Unreferenced_Objects
;
14227 ------------------------------
14228 -- Unreserve_All_Interrupts --
14229 ------------------------------
14231 -- pragma Unreserve_All_Interrupts;
14233 when Pragma_Unreserve_All_Interrupts
=>
14235 Check_Arg_Count
(0);
14237 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
14238 Unreserve_All_Interrupts
:= True;
14245 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
14247 when Pragma_Unsuppress
=>
14249 Process_Suppress_Unsuppress
(False);
14251 -------------------
14252 -- Use_VADS_Size --
14253 -------------------
14255 -- pragma Use_VADS_Size;
14257 when Pragma_Use_VADS_Size
=>
14259 Check_Arg_Count
(0);
14260 Check_Valid_Configuration_Pragma
;
14261 Use_VADS_Size
:= True;
14263 ---------------------
14264 -- Validity_Checks --
14265 ---------------------
14267 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
14269 when Pragma_Validity_Checks
=> Validity_Checks
: declare
14270 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
14276 Check_Arg_Count
(1);
14277 Check_No_Identifiers
;
14279 if Nkind
(A
) = N_String_Literal
then
14283 Slen
: constant Natural := Natural (String_Length
(S
));
14284 Options
: String (1 .. Slen
);
14290 C
:= Get_String_Char
(S
, Int
(J
));
14291 exit when not In_Character_Range
(C
);
14292 Options
(J
) := Get_Character
(C
);
14295 Set_Validity_Check_Options
(Options
);
14303 elsif Nkind
(A
) = N_Identifier
then
14304 if Chars
(A
) = Name_All_Checks
then
14305 Set_Validity_Check_Options
("a");
14306 elsif Chars
(A
) = Name_On
then
14307 Validity_Checks_On
:= True;
14308 elsif Chars
(A
) = Name_Off
then
14309 Validity_Checks_On
:= False;
14312 end Validity_Checks
;
14318 -- pragma Volatile (LOCAL_NAME);
14320 when Pragma_Volatile
=>
14321 Process_Atomic_Shared_Volatile
;
14323 -------------------------
14324 -- Volatile_Components --
14325 -------------------------
14327 -- pragma Volatile_Components (array_LOCAL_NAME);
14329 -- Volatile is handled by the same circuit as Atomic_Components
14335 -- pragma Warnings (On | Off);
14336 -- pragma Warnings (On | Off, LOCAL_NAME);
14337 -- pragma Warnings (static_string_EXPRESSION);
14338 -- pragma Warnings (On | Off, STRING_LITERAL);
14340 when Pragma_Warnings
=> Warnings
: begin
14342 Check_At_Least_N_Arguments
(1);
14343 Check_No_Identifiers
;
14345 -- If debug flag -gnatd.i is set, pragma is ignored
14347 if Debug_Flag_Dot_I
then
14351 -- Process various forms of the pragma
14354 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
14357 -- One argument case
14359 if Arg_Count
= 1 then
14361 -- On/Off one argument case was processed by parser
14363 if Nkind
(Argx
) = N_Identifier
14365 (Chars
(Argx
) = Name_On
14367 Chars
(Argx
) = Name_Off
)
14371 -- One argument case must be ON/OFF or static string expr
14373 elsif not Is_Static_String_Expression
(Arg1
) then
14375 ("argument of pragma% must be On/Off or " &
14376 "static string expression", Arg1
);
14378 -- One argument string expression case
14382 Lit
: constant Node_Id
:= Expr_Value_S
(Argx
);
14383 Str
: constant String_Id
:= Strval
(Lit
);
14384 Len
: constant Nat
:= String_Length
(Str
);
14392 while J
<= Len
loop
14393 C
:= Get_String_Char
(Str
, J
);
14394 OK
:= In_Character_Range
(C
);
14397 Chr
:= Get_Character
(C
);
14401 if J
< Len
and then Chr
= '.' then
14403 C
:= Get_String_Char
(Str
, J
);
14404 Chr
:= Get_Character
(C
);
14406 if not Set_Dot_Warning_Switch
(Chr
) then
14408 ("invalid warning switch character " &
14415 OK
:= Set_Warning_Switch
(Chr
);
14421 ("invalid warning switch character " & Chr
,
14430 -- Two or more arguments (must be two)
14433 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
14434 Check_At_Most_N_Arguments
(2);
14442 E_Id
:= Get_Pragma_Arg
(Arg2
);
14445 -- In the expansion of an inlined body, a reference to
14446 -- the formal may be wrapped in a conversion if the
14447 -- actual is a conversion. Retrieve the real entity name.
14449 if (In_Instance_Body
14450 or else In_Inlined_Body
)
14451 and then Nkind
(E_Id
) = N_Unchecked_Type_Conversion
14453 E_Id
:= Expression
(E_Id
);
14456 -- Entity name case
14458 if Is_Entity_Name
(E_Id
) then
14459 E
:= Entity
(E_Id
);
14466 (E
, (Chars
(Get_Pragma_Arg
(Arg1
)) =
14469 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
14470 and then Warn_On_Warnings_Off
14472 Warnings_Off_Pragmas
.Append
((N
, E
));
14475 if Is_Enumeration_Type
(E
) then
14479 Lit
:= First_Literal
(E
);
14480 while Present
(Lit
) loop
14481 Set_Warnings_Off
(Lit
);
14482 Next_Literal
(Lit
);
14487 exit when No
(Homonym
(E
));
14492 -- Error if not entity or static string literal case
14494 elsif not Is_Static_String_Expression
(Arg2
) then
14496 ("second argument of pragma% must be entity " &
14497 "name or static string expression", Arg2
);
14499 -- String literal case
14502 String_To_Name_Buffer
14503 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg2
))));
14505 -- Note on configuration pragma case: If this is a
14506 -- configuration pragma, then for an OFF pragma, we
14507 -- just set Config True in the call, which is all
14508 -- that needs to be done. For the case of ON, this
14509 -- is normally an error, unless it is canceling the
14510 -- effect of a previous OFF pragma in the same file.
14511 -- In any other case, an error will be signalled (ON
14512 -- with no matching OFF).
14514 if Chars
(Argx
) = Name_Off
then
14515 Set_Specific_Warning_Off
14516 (Loc
, Name_Buffer
(1 .. Name_Len
),
14517 Config
=> Is_Configuration_Pragma
);
14519 elsif Chars
(Argx
) = Name_On
then
14520 Set_Specific_Warning_On
14521 (Loc
, Name_Buffer
(1 .. Name_Len
), Err
);
14525 ("?pragma Warnings On with no " &
14526 "matching Warnings Off",
14536 -------------------
14537 -- Weak_External --
14538 -------------------
14540 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
14542 when Pragma_Weak_External
=> Weak_External
: declare
14547 Check_Arg_Count
(1);
14548 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14549 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
14550 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
14552 if Rep_Item_Too_Early
(Ent
, N
) then
14555 Ent
:= Underlying_Type
(Ent
);
14558 -- The only processing required is to link this item on to the
14559 -- list of rep items for the given entity. This is accomplished
14560 -- by the call to Rep_Item_Too_Late (when no error is detected
14561 -- and False is returned).
14563 if Rep_Item_Too_Late
(Ent
, N
) then
14566 Set_Has_Gigi_Rep_Item
(Ent
);
14570 -----------------------------
14571 -- Wide_Character_Encoding --
14572 -----------------------------
14574 -- pragma Wide_Character_Encoding (IDENTIFIER);
14576 when Pragma_Wide_Character_Encoding
=>
14579 -- Nothing to do, handled in parser. Note that we do not enforce
14580 -- configuration pragma placement, this pragma can appear at any
14581 -- place in the source, allowing mixed encodings within a single
14586 --------------------
14587 -- Unknown_Pragma --
14588 --------------------
14590 -- Should be impossible, since the case of an unknown pragma is
14591 -- separately processed before the case statement is entered.
14593 when Unknown_Pragma
=>
14594 raise Program_Error
;
14597 -- AI05-0144: detect dangerous order dependence. Disabled for now,
14598 -- until AI is formally approved.
14600 -- Check_Order_Dependence;
14603 when Pragma_Exit
=> null;
14604 end Analyze_Pragma
;
14606 -----------------------------
14607 -- Analyze_TC_In_Decl_Part --
14608 -----------------------------
14610 procedure Analyze_TC_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
14612 -- Install formals and push subprogram spec onto scope stack so that we
14613 -- can see the formals from the pragma.
14615 Install_Formals
(S
);
14618 -- Preanalyze the boolean expressions, we treat these as spec
14619 -- expressions (i.e. similar to a default expression).
14621 Preanalyze_TC_Args
(N
,
14622 Get_Requires_From_Test_Case_Pragma
(N
),
14623 Get_Ensures_From_Test_Case_Pragma
(N
));
14625 -- Remove the subprogram from the scope stack now that the pre-analysis
14626 -- of the expressions in the test-case is done.
14629 end Analyze_TC_In_Decl_Part
;
14631 --------------------
14632 -- Check_Disabled --
14633 --------------------
14635 function Check_Disabled
(Nam
: Name_Id
) return Boolean is
14639 -- Loop through entries in check policy list
14641 PP
:= Opt
.Check_Policy_List
;
14643 -- If there are no specific entries that matched, then nothing is
14644 -- disabled, so return False.
14649 -- Here we have an entry see if it matches
14653 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
14655 if Nam
= Chars
(Get_Pragma_Arg
(First
(PPA
))) then
14656 return Chars
(Get_Pragma_Arg
(Last
(PPA
))) = Name_Disable
;
14658 PP
:= Next_Pragma
(PP
);
14663 end Check_Disabled
;
14665 -------------------
14666 -- Check_Enabled --
14667 -------------------
14669 function Check_Enabled
(Nam
: Name_Id
) return Boolean is
14673 -- Loop through entries in check policy list
14675 PP
:= Opt
.Check_Policy_List
;
14677 -- If there are no specific entries that matched, then we let the
14678 -- setting of assertions govern. Note that this provides the needed
14679 -- compatibility with the RM for the cases of assertion, invariant,
14680 -- precondition, predicate, and postcondition.
14683 return Assertions_Enabled
;
14685 -- Here we have an entry see if it matches
14689 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
14692 if Nam
= Chars
(Get_Pragma_Arg
(First
(PPA
))) then
14693 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
14694 when Name_On | Name_Check
=>
14696 when Name_Off | Name_Ignore
=>
14699 raise Program_Error
;
14703 PP
:= Next_Pragma
(PP
);
14710 ---------------------------------
14711 -- Delay_Config_Pragma_Analyze --
14712 ---------------------------------
14714 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
14716 return Pragma_Name
(N
) = Name_Interrupt_State
14718 Pragma_Name
(N
) = Name_Priority_Specific_Dispatching
;
14719 end Delay_Config_Pragma_Analyze
;
14721 -------------------------
14722 -- Get_Base_Subprogram --
14723 -------------------------
14725 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
14726 Result
: Entity_Id
;
14729 -- Follow subprogram renaming chain
14732 while Is_Subprogram
(Result
)
14734 Nkind
(Parent
(Declaration_Node
(Result
))) =
14735 N_Subprogram_Renaming_Declaration
14736 and then Present
(Alias
(Result
))
14738 Result
:= Alias
(Result
);
14742 end Get_Base_Subprogram
;
14748 procedure Initialize
is
14753 -----------------------------
14754 -- Is_Config_Static_String --
14755 -----------------------------
14757 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
14759 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
14760 -- This is an internal recursive function that is just like the outer
14761 -- function except that it adds the string to the name buffer rather
14762 -- than placing the string in the name buffer.
14764 ------------------------------
14765 -- Add_Config_Static_String --
14766 ------------------------------
14768 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
14775 if Nkind
(N
) = N_Op_Concat
then
14776 if Add_Config_Static_String
(Left_Opnd
(N
)) then
14777 N
:= Right_Opnd
(N
);
14783 if Nkind
(N
) /= N_String_Literal
then
14784 Error_Msg_N
("string literal expected for pragma argument", N
);
14788 for J
in 1 .. String_Length
(Strval
(N
)) loop
14789 C
:= Get_String_Char
(Strval
(N
), J
);
14791 if not In_Character_Range
(C
) then
14793 ("string literal contains invalid wide character",
14794 Sloc
(N
) + 1 + Source_Ptr
(J
));
14798 Add_Char_To_Name_Buffer
(Get_Character
(C
));
14803 end Add_Config_Static_String
;
14805 -- Start of processing for Is_Config_Static_String
14810 return Add_Config_Static_String
(Arg
);
14811 end Is_Config_Static_String
;
14813 -----------------------------------------
14814 -- Is_Non_Significant_Pragma_Reference --
14815 -----------------------------------------
14817 -- This function makes use of the following static table which indicates
14818 -- whether a given pragma is significant.
14820 -- -1 indicates that references in any argument position are significant
14821 -- 0 indicates that appearance in any argument is not significant
14822 -- +n indicates that appearance as argument n is significant, but all
14823 -- other arguments are not significant
14824 -- 99 special processing required (e.g. for pragma Check)
14826 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
14827 (Pragma_AST_Entry
=> -1,
14828 Pragma_Abort_Defer
=> -1,
14829 Pragma_Ada_83
=> -1,
14830 Pragma_Ada_95
=> -1,
14831 Pragma_Ada_05
=> -1,
14832 Pragma_Ada_2005
=> -1,
14833 Pragma_Ada_12
=> -1,
14834 Pragma_Ada_2012
=> -1,
14835 Pragma_All_Calls_Remote
=> -1,
14836 Pragma_Annotate
=> -1,
14837 Pragma_Assert
=> -1,
14838 Pragma_Assertion_Policy
=> 0,
14839 Pragma_Assume_No_Invalid_Values
=> 0,
14840 Pragma_Asynchronous
=> -1,
14841 Pragma_Atomic
=> 0,
14842 Pragma_Atomic_Components
=> 0,
14843 Pragma_Attach_Handler
=> -1,
14844 Pragma_Check
=> 99,
14845 Pragma_Check_Name
=> 0,
14846 Pragma_Check_Policy
=> 0,
14847 Pragma_CIL_Constructor
=> -1,
14848 Pragma_CPP_Class
=> 0,
14849 Pragma_CPP_Constructor
=> 0,
14850 Pragma_CPP_Virtual
=> 0,
14851 Pragma_CPP_Vtable
=> 0,
14853 Pragma_C_Pass_By_Copy
=> 0,
14854 Pragma_Comment
=> 0,
14855 Pragma_Common_Object
=> -1,
14856 Pragma_Compile_Time_Error
=> -1,
14857 Pragma_Compile_Time_Warning
=> -1,
14858 Pragma_Compiler_Unit
=> 0,
14859 Pragma_Complete_Representation
=> 0,
14860 Pragma_Complex_Representation
=> 0,
14861 Pragma_Component_Alignment
=> -1,
14862 Pragma_Controlled
=> 0,
14863 Pragma_Convention
=> 0,
14864 Pragma_Convention_Identifier
=> 0,
14865 Pragma_Debug
=> -1,
14866 Pragma_Debug_Policy
=> 0,
14867 Pragma_Detect_Blocking
=> -1,
14868 Pragma_Default_Storage_Pool
=> -1,
14869 Pragma_Dimension
=> -1,
14870 Pragma_Disable_Atomic_Synchronization
=> -1,
14871 Pragma_Discard_Names
=> 0,
14872 Pragma_Dispatching_Domain
=> -1,
14873 Pragma_Elaborate
=> -1,
14874 Pragma_Elaborate_All
=> -1,
14875 Pragma_Elaborate_Body
=> -1,
14876 Pragma_Elaboration_Checks
=> -1,
14877 Pragma_Eliminate
=> -1,
14878 Pragma_Enable_Atomic_Synchronization
=> -1,
14879 Pragma_Export
=> -1,
14880 Pragma_Export_Exception
=> -1,
14881 Pragma_Export_Function
=> -1,
14882 Pragma_Export_Object
=> -1,
14883 Pragma_Export_Procedure
=> -1,
14884 Pragma_Export_Value
=> -1,
14885 Pragma_Export_Valued_Procedure
=> -1,
14886 Pragma_Extend_System
=> -1,
14887 Pragma_Extensions_Allowed
=> -1,
14888 Pragma_External
=> -1,
14889 Pragma_Favor_Top_Level
=> -1,
14890 Pragma_External_Name_Casing
=> -1,
14891 Pragma_Fast_Math
=> -1,
14892 Pragma_Finalize_Storage_Only
=> 0,
14893 Pragma_Float_Representation
=> 0,
14894 Pragma_Ident
=> -1,
14895 Pragma_Implementation_Defined
=> -1,
14896 Pragma_Implemented
=> -1,
14897 Pragma_Implicit_Packing
=> 0,
14898 Pragma_Import
=> +2,
14899 Pragma_Import_Exception
=> 0,
14900 Pragma_Import_Function
=> 0,
14901 Pragma_Import_Object
=> 0,
14902 Pragma_Import_Procedure
=> 0,
14903 Pragma_Import_Valued_Procedure
=> 0,
14904 Pragma_Independent
=> 0,
14905 Pragma_Independent_Components
=> 0,
14906 Pragma_Initialize_Scalars
=> -1,
14907 Pragma_Inline
=> 0,
14908 Pragma_Inline_Always
=> 0,
14909 Pragma_Inline_Generic
=> 0,
14910 Pragma_Inspection_Point
=> -1,
14911 Pragma_Interface
=> +2,
14912 Pragma_Interface_Name
=> +2,
14913 Pragma_Interrupt_Handler
=> -1,
14914 Pragma_Interrupt_Priority
=> -1,
14915 Pragma_Interrupt_State
=> -1,
14916 Pragma_Invariant
=> -1,
14917 Pragma_Java_Constructor
=> -1,
14918 Pragma_Java_Interface
=> -1,
14919 Pragma_Keep_Names
=> 0,
14920 Pragma_License
=> -1,
14921 Pragma_Link_With
=> -1,
14922 Pragma_Linker_Alias
=> -1,
14923 Pragma_Linker_Constructor
=> -1,
14924 Pragma_Linker_Destructor
=> -1,
14925 Pragma_Linker_Options
=> -1,
14926 Pragma_Linker_Section
=> -1,
14928 Pragma_Locking_Policy
=> -1,
14929 Pragma_Long_Float
=> -1,
14930 Pragma_Machine_Attribute
=> -1,
14932 Pragma_Main_Storage
=> -1,
14933 Pragma_Memory_Size
=> -1,
14934 Pragma_No_Return
=> 0,
14935 Pragma_No_Body
=> 0,
14936 Pragma_No_Run_Time
=> -1,
14937 Pragma_No_Strict_Aliasing
=> -1,
14938 Pragma_Normalize_Scalars
=> -1,
14939 Pragma_Obsolescent
=> 0,
14940 Pragma_Optimize
=> -1,
14941 Pragma_Optimize_Alignment
=> -1,
14942 Pragma_Ordered
=> 0,
14945 Pragma_Passive
=> -1,
14946 Pragma_Preelaborable_Initialization
=> -1,
14947 Pragma_Polling
=> -1,
14948 Pragma_Persistent_BSS
=> 0,
14949 Pragma_Postcondition
=> -1,
14950 Pragma_Precondition
=> -1,
14951 Pragma_Predicate
=> -1,
14952 Pragma_Preelaborate
=> -1,
14953 Pragma_Preelaborate_05
=> -1,
14954 Pragma_Priority
=> -1,
14955 Pragma_Priority_Specific_Dispatching
=> -1,
14956 Pragma_Profile
=> 0,
14957 Pragma_Profile_Warnings
=> 0,
14958 Pragma_Propagate_Exceptions
=> -1,
14959 Pragma_Psect_Object
=> -1,
14961 Pragma_Pure_05
=> -1,
14962 Pragma_Pure_Function
=> -1,
14963 Pragma_Queuing_Policy
=> -1,
14964 Pragma_Ravenscar
=> -1,
14965 Pragma_Relative_Deadline
=> -1,
14966 Pragma_Remote_Call_Interface
=> -1,
14967 Pragma_Remote_Types
=> -1,
14968 Pragma_Restricted_Run_Time
=> -1,
14969 Pragma_Restriction_Warnings
=> -1,
14970 Pragma_Restrictions
=> -1,
14971 Pragma_Reviewable
=> -1,
14972 Pragma_Short_Circuit_And_Or
=> -1,
14973 Pragma_Share_Generic
=> -1,
14974 Pragma_Shared
=> -1,
14975 Pragma_Shared_Passive
=> -1,
14976 Pragma_Short_Descriptors
=> 0,
14977 Pragma_Source_File_Name
=> -1,
14978 Pragma_Source_File_Name_Project
=> -1,
14979 Pragma_Source_Reference
=> -1,
14980 Pragma_Storage_Size
=> -1,
14981 Pragma_Storage_Unit
=> -1,
14982 Pragma_Static_Elaboration_Desired
=> -1,
14983 Pragma_Stream_Convert
=> -1,
14984 Pragma_Style_Checks
=> -1,
14985 Pragma_Subtitle
=> -1,
14986 Pragma_Suppress
=> 0,
14987 Pragma_Suppress_Exception_Locations
=> 0,
14988 Pragma_Suppress_All
=> -1,
14989 Pragma_Suppress_Debug_Info
=> 0,
14990 Pragma_Suppress_Initialization
=> 0,
14991 Pragma_System_Name
=> -1,
14992 Pragma_Task_Dispatching_Policy
=> -1,
14993 Pragma_Task_Info
=> -1,
14994 Pragma_Task_Name
=> -1,
14995 Pragma_Task_Storage
=> 0,
14996 Pragma_Test_Case
=> -1,
14997 Pragma_Thread_Local_Storage
=> 0,
14998 Pragma_Time_Slice
=> -1,
14999 Pragma_Title
=> -1,
15000 Pragma_Unchecked_Union
=> 0,
15001 Pragma_Unimplemented_Unit
=> -1,
15002 Pragma_Universal_Aliasing
=> -1,
15003 Pragma_Universal_Data
=> -1,
15004 Pragma_Unmodified
=> -1,
15005 Pragma_Unreferenced
=> -1,
15006 Pragma_Unreferenced_Objects
=> -1,
15007 Pragma_Unreserve_All_Interrupts
=> -1,
15008 Pragma_Unsuppress
=> 0,
15009 Pragma_Use_VADS_Size
=> -1,
15010 Pragma_Validity_Checks
=> -1,
15011 Pragma_Volatile
=> 0,
15012 Pragma_Volatile_Components
=> 0,
15013 Pragma_Warnings
=> -1,
15014 Pragma_Weak_External
=> -1,
15015 Pragma_Wide_Character_Encoding
=> 0,
15016 Unknown_Pragma
=> 0);
15018 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
15027 if Nkind
(P
) /= N_Pragma_Argument_Association
then
15031 Id
:= Get_Pragma_Id
(Parent
(P
));
15032 C
:= Sig_Flags
(Id
);
15044 -- For pragma Check, the first argument is not significant,
15045 -- the second and the third (if present) arguments are
15048 when Pragma_Check
=>
15050 P
= First
(Pragma_Argument_Associations
(Parent
(P
)));
15053 raise Program_Error
;
15057 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
15058 for J
in 1 .. C
- 1 loop
15066 return A
= P
; -- is this wrong way round ???
15069 end Is_Non_Significant_Pragma_Reference
;
15071 ------------------------------
15072 -- Is_Pragma_String_Literal --
15073 ------------------------------
15075 -- This function returns true if the corresponding pragma argument is a
15076 -- static string expression. These are the only cases in which string
15077 -- literals can appear as pragma arguments. We also allow a string literal
15078 -- as the first argument to pragma Assert (although it will of course
15079 -- always generate a type error).
15081 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
15082 Pragn
: constant Node_Id
:= Parent
(Par
);
15083 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
15084 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
15090 N
:= First
(Assoc
);
15097 if Pname
= Name_Assert
then
15100 elsif Pname
= Name_Export
then
15103 elsif Pname
= Name_Ident
then
15106 elsif Pname
= Name_Import
then
15109 elsif Pname
= Name_Interface_Name
then
15112 elsif Pname
= Name_Linker_Alias
then
15115 elsif Pname
= Name_Linker_Section
then
15118 elsif Pname
= Name_Machine_Attribute
then
15121 elsif Pname
= Name_Source_File_Name
then
15124 elsif Pname
= Name_Source_Reference
then
15127 elsif Pname
= Name_Title
then
15130 elsif Pname
= Name_Subtitle
then
15136 end Is_Pragma_String_Literal
;
15138 ------------------------
15139 -- Preanalyze_TC_Args --
15140 ------------------------
15142 procedure Preanalyze_TC_Args
(N
, Arg_Req
, Arg_Ens
: Node_Id
) is
15144 -- Preanalyze the boolean expressions, we treat these as spec
15145 -- expressions (i.e. similar to a default expression).
15147 if Present
(Arg_Req
) then
15148 Preanalyze_Spec_Expression
15149 (Get_Pragma_Arg
(Arg_Req
), Standard_Boolean
);
15151 -- In ASIS mode, for a pragma generated from a source aspect, also
15152 -- analyze the original aspect expression.
15155 and then Present
(Corresponding_Aspect
(N
))
15157 Preanalyze_Spec_Expression
15158 (Original_Node
(Get_Pragma_Arg
(Arg_Req
)), Standard_Boolean
);
15162 if Present
(Arg_Ens
) then
15163 Preanalyze_Spec_Expression
15164 (Get_Pragma_Arg
(Arg_Ens
), Standard_Boolean
);
15166 -- In ASIS mode, for a pragma generated from a source aspect, also
15167 -- analyze the original aspect expression.
15170 and then Present
(Corresponding_Aspect
(N
))
15172 Preanalyze_Spec_Expression
15173 (Original_Node
(Get_Pragma_Arg
(Arg_Ens
)), Standard_Boolean
);
15176 end Preanalyze_TC_Args
;
15178 --------------------------------------
15179 -- Process_Compilation_Unit_Pragmas --
15180 --------------------------------------
15182 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
15184 -- A special check for pragma Suppress_All, a very strange DEC pragma,
15185 -- strange because it comes at the end of the unit. Rational has the
15186 -- same name for a pragma, but treats it as a program unit pragma, In
15187 -- GNAT we just decide to allow it anywhere at all. If it appeared then
15188 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
15189 -- node, and we insert a pragma Suppress (All_Checks) at the start of
15190 -- the context clause to ensure the correct processing.
15192 if Has_Pragma_Suppress_All
(N
) then
15193 Prepend_To
(Context_Items
(N
),
15194 Make_Pragma
(Sloc
(N
),
15195 Chars
=> Name_Suppress
,
15196 Pragma_Argument_Associations
=> New_List
(
15197 Make_Pragma_Argument_Association
(Sloc
(N
),
15198 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
15201 -- Nothing else to do at the current time!
15203 end Process_Compilation_Unit_Pragmas
;
15214 --------------------------------
15215 -- Set_Encoded_Interface_Name --
15216 --------------------------------
15218 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
15219 Str
: constant String_Id
:= Strval
(S
);
15220 Len
: constant Int
:= String_Length
(Str
);
15225 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
15228 -- Stores encoded value of character code CC. The encoding we use an
15229 -- underscore followed by four lower case hex digits.
15235 procedure Encode
is
15237 Store_String_Char
(Get_Char_Code
('_'));
15239 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
15241 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
15243 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
15245 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
15248 -- Start of processing for Set_Encoded_Interface_Name
15251 -- If first character is asterisk, this is a link name, and we leave it
15252 -- completely unmodified. We also ignore null strings (the latter case
15253 -- happens only in error cases) and no encoding should occur for Java or
15254 -- AAMP interface names.
15257 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
15258 or else VM_Target
/= No_VM
15259 or else AAMP_On_Target
15261 Set_Interface_Name
(E
, S
);
15266 CC
:= Get_String_Char
(Str
, J
);
15268 exit when not In_Character_Range
(CC
);
15270 C
:= Get_Character
(CC
);
15272 exit when C
/= '_' and then C
/= '$'
15273 and then C
not in '0' .. '9'
15274 and then C
not in 'a' .. 'z'
15275 and then C
not in 'A' .. 'Z';
15278 Set_Interface_Name
(E
, S
);
15286 -- Here we need to encode. The encoding we use as follows:
15287 -- three underscores + four hex digits (lower case)
15291 for J
in 1 .. String_Length
(Str
) loop
15292 CC
:= Get_String_Char
(Str
, J
);
15294 if not In_Character_Range
(CC
) then
15297 C
:= Get_Character
(CC
);
15299 if C
= '_' or else C
= '$'
15300 or else C
in '0' .. '9'
15301 or else C
in 'a' .. 'z'
15302 or else C
in 'A' .. 'Z'
15304 Store_String_Char
(CC
);
15311 Set_Interface_Name
(E
,
15312 Make_String_Literal
(Sloc
(S
),
15313 Strval
=> End_String
));
15315 end Set_Encoded_Interface_Name
;
15317 -------------------
15318 -- Set_Unit_Name --
15319 -------------------
15321 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
15326 if Nkind
(N
) = N_Identifier
15327 and then Nkind
(With_Item
) = N_Identifier
15329 Set_Entity
(N
, Entity
(With_Item
));
15331 elsif Nkind
(N
) = N_Selected_Component
then
15332 Change_Selected_Component_To_Expanded_Name
(N
);
15333 Set_Entity
(N
, Entity
(With_Item
));
15334 Set_Entity
(Selector_Name
(N
), Entity
(N
));
15336 Pref
:= Prefix
(N
);
15337 Scop
:= Scope
(Entity
(N
));
15338 while Nkind
(Pref
) = N_Selected_Component
loop
15339 Change_Selected_Component_To_Expanded_Name
(Pref
);
15340 Set_Entity
(Selector_Name
(Pref
), Scop
);
15341 Set_Entity
(Pref
, Scop
);
15342 Pref
:= Prefix
(Pref
);
15343 Scop
:= Scope
(Scop
);
15346 Set_Entity
(Pref
, Scop
);