1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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 Atree
; use Atree
;
33 with Casing
; use Casing
;
34 with Checks
; use Checks
;
35 with Csets
; use Csets
;
36 with Debug
; use Debug
;
37 with Einfo
; use Einfo
;
38 with Errout
; use Errout
;
39 with Exp_Dist
; use Exp_Dist
;
41 with Lib
.Writ
; use Lib
.Writ
;
42 with Lib
.Xref
; use Lib
.Xref
;
43 with Namet
.Sp
; use Namet
.Sp
;
44 with Nlists
; use Nlists
;
45 with Nmake
; use Nmake
;
47 with Output
; use Output
;
48 with Restrict
; use Restrict
;
49 with Rident
; use Rident
;
50 with Rtsfind
; use Rtsfind
;
52 with Sem_Aux
; use Sem_Aux
;
53 with Sem_Ch3
; use Sem_Ch3
;
54 with Sem_Ch6
; use Sem_Ch6
;
55 with Sem_Ch8
; use Sem_Ch8
;
56 with Sem_Ch12
; use Sem_Ch12
;
57 with Sem_Ch13
; use Sem_Ch13
;
58 with Sem_Dist
; use Sem_Dist
;
59 with Sem_Elim
; use Sem_Elim
;
60 with Sem_Eval
; use Sem_Eval
;
61 with Sem_Intr
; use Sem_Intr
;
62 with Sem_Mech
; use Sem_Mech
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Type
; use Sem_Type
;
65 with Sem_Util
; use Sem_Util
;
66 with Sem_VFpt
; use Sem_VFpt
;
67 with Sem_Warn
; use Sem_Warn
;
68 with Stand
; use Stand
;
69 with Sinfo
; use Sinfo
;
70 with Sinfo
.CN
; use Sinfo
.CN
;
71 with Sinput
; use Sinput
;
72 with Snames
; use Snames
;
73 with Stringt
; use Stringt
;
74 with Stylesw
; use Stylesw
;
76 with Targparm
; use Targparm
;
77 with Tbuild
; use Tbuild
;
79 with Uintp
; use Uintp
;
80 with Uname
; use Uname
;
81 with Urealp
; use Urealp
;
82 with Validsw
; use Validsw
;
84 package body Sem_Prag
is
86 ----------------------------------------------
87 -- Common Handling of Import-Export Pragmas --
88 ----------------------------------------------
90 -- In the following section, a number of Import_xxx and Export_xxx
91 -- pragmas are defined by GNAT. These are compatible with the DEC
92 -- pragmas of the same name, and all have the following common
93 -- form and processing:
96 -- [Internal =>] LOCAL_NAME
97 -- [, [External =>] EXTERNAL_SYMBOL]
98 -- [, other optional parameters ]);
101 -- [Internal =>] LOCAL_NAME
102 -- [, [External =>] EXTERNAL_SYMBOL]
103 -- [, other optional parameters ]);
105 -- EXTERNAL_SYMBOL ::=
107 -- | static_string_EXPRESSION
109 -- The internal LOCAL_NAME designates the entity that is imported or
110 -- exported, and must refer to an entity in the current declarative
111 -- part (as required by the rules for LOCAL_NAME).
113 -- The external linker name is designated by the External parameter
114 -- if given, or the Internal parameter if not (if there is no External
115 -- parameter, the External parameter is a copy of the Internal name).
117 -- If the External parameter is given as a string, then this string
118 -- is treated as an external name (exactly as though it had been given
119 -- as an External_Name parameter for a normal Import pragma).
121 -- If the External parameter is given as an identifier (or there is no
122 -- External parameter, so that the Internal identifier is used), then
123 -- the external name is the characters of the identifier, translated
124 -- to all upper case letters for OpenVMS versions of GNAT, and to all
125 -- lower case letters for all other versions
127 -- Note: the external name specified or implied by any of these special
128 -- Import_xxx or Export_xxx pragmas override an external or link name
129 -- specified in a previous Import or Export pragma.
131 -- Note: these and all other DEC-compatible GNAT pragmas allow full
132 -- use of named notation, following the standard rules for subprogram
133 -- calls, i.e. parameters can be given in any order if named notation
134 -- is used, and positional and named notation can be mixed, subject to
135 -- the rule that all positional parameters must appear first.
137 -- Note: All these pragmas are implemented exactly following the DEC
138 -- design and implementation and are intended to be fully compatible
139 -- with the use of these pragmas in the DEC Ada compiler.
141 --------------------------------------------
142 -- Checking for Duplicated External Names --
143 --------------------------------------------
145 -- It is suspicious if two separate Export pragmas use the same external
146 -- name. The following table is used to diagnose this situation so that
147 -- an appropriate warning can be issued.
149 -- The Node_Id stored is for the N_String_Literal node created to
150 -- hold the value of the external name. The Sloc of this node is
151 -- used to cross-reference the location of the duplication.
153 package Externals
is new Table
.Table
(
154 Table_Component_Type
=> Node_Id
,
155 Table_Index_Type
=> Int
,
156 Table_Low_Bound
=> 0,
157 Table_Initial
=> 100,
158 Table_Increment
=> 100,
159 Table_Name
=> "Name_Externals");
161 -------------------------------------
162 -- Local Subprograms and Variables --
163 -------------------------------------
165 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
166 -- This routine is used for possible casing adjustment of an explicit
167 -- external name supplied as a string literal (the node N), according
168 -- to the casing requirement of Opt.External_Name_Casing. If this is
169 -- set to As_Is, then the string literal is returned unchanged, but if
170 -- it is set to Uppercase or Lowercase, then a new string literal with
171 -- appropriate casing is constructed.
173 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
174 -- If Def_Id refers to a renamed subprogram, then the base subprogram
175 -- (the original one, following the renaming chain) is returned.
176 -- Otherwise the entity is returned unchanged. Should be in Einfo???
178 function Get_Pragma_Arg
(Arg
: Node_Id
) return Node_Id
;
179 -- All the routines that check pragma arguments take either a pragma
180 -- argument association (in which case the expression of the argument
181 -- association is checked), or the expression directly. The function
182 -- Get_Pragma_Arg is a utility used to deal with these two cases. If Arg
183 -- is a pragma argument association node, then its expression is returned,
184 -- otherwise Arg is returned unchanged.
187 -- This is a dummy function called by the processing for pragma Reviewable.
188 -- It is there for assisting front end debugging. By placing a Reviewable
189 -- pragma in the source program, a breakpoint on rv catches this place in
190 -- the source, allowing convenient stepping to the point of interest.
192 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
193 -- Place semantic information on the argument of an Elaborate or
194 -- Elaborate_All pragma. Entity name for unit and its parents is
195 -- taken from item in previous with_clause that mentions the unit.
197 -------------------------------
198 -- Adjust_External_Name_Case --
199 -------------------------------
201 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
205 -- Adjust case of literal if required
207 if Opt
.External_Name_Exp_Casing
= As_Is
then
211 -- Copy existing string
217 for J
in 1 .. String_Length
(Strval
(N
)) loop
218 CC
:= Get_String_Char
(Strval
(N
), J
);
220 if Opt
.External_Name_Exp_Casing
= Uppercase
221 and then CC
>= Get_Char_Code
('a')
222 and then CC
<= Get_Char_Code
('z')
224 Store_String_Char
(CC
- 32);
226 elsif Opt
.External_Name_Exp_Casing
= Lowercase
227 and then CC
>= Get_Char_Code
('A')
228 and then CC
<= Get_Char_Code
('Z')
230 Store_String_Char
(CC
+ 32);
233 Store_String_Char
(CC
);
238 Make_String_Literal
(Sloc
(N
),
239 Strval
=> End_String
);
241 end Adjust_External_Name_Case
;
243 ------------------------------
244 -- Analyze_PPC_In_Decl_Part --
245 ------------------------------
247 procedure Analyze_PPC_In_Decl_Part
(N
: Node_Id
; S
: Entity_Id
) is
248 Arg1
: constant Node_Id
:=
249 First
(Pragma_Argument_Associations
(N
));
250 Arg2
: constant Node_Id
:= Next
(Arg1
);
253 -- Install formals and push subprogram spec onto scope stack
254 -- so that we can see the formals from the pragma.
259 -- Preanalyze the boolean expression, we treat this as a
260 -- spec expression (i.e. similar to a default expression).
262 Preanalyze_Spec_Expression
263 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
265 -- If there is a message argument, analyze it the same way
267 if Present
(Arg2
) then
268 Preanalyze_Spec_Expression
269 (Get_Pragma_Arg
(Arg2
), Standard_String
);
272 -- Remove the subprogram from the scope stack now that the
273 -- pre-analysis of the precondition/postcondition is done.
276 end Analyze_PPC_In_Decl_Part
;
282 procedure Analyze_Pragma
(N
: Node_Id
) is
283 Loc
: constant Source_Ptr
:= Sloc
(N
);
284 Pname
: constant Name_Id
:= Pragma_Name
(N
);
287 Pragma_Exit
: exception;
288 -- This exception is used to exit pragma processing completely. It
289 -- is used when an error is detected, and no further processing is
290 -- required. It is also used if an earlier error has left the tree
291 -- in a state where the pragma should not be processed.
294 -- Number of pragma argument associations
300 -- First four pragma arguments (pragma argument association nodes,
301 -- or Empty if the corresponding argument does not exist).
303 type Name_List
is array (Natural range <>) of Name_Id
;
304 type Args_List
is array (Natural range <>) of Node_Id
;
305 -- Types used for arguments to Check_Arg_Order and Gather_Associations
307 procedure Ada_2005_Pragma
;
308 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
309 -- Ada 95 mode, these are implementation defined pragmas, so should be
310 -- caught by the No_Implementation_Pragmas restriction
312 procedure Check_Ada_83_Warning
;
313 -- Issues a warning message for the current pragma if operating in Ada
314 -- 83 mode (used for language pragmas that are not a standard part of
315 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
318 procedure Check_Arg_Count
(Required
: Nat
);
319 -- Check argument count for pragma is equal to given parameter.
320 -- If not, then issue an error message and raise Pragma_Exit.
322 -- Note: all routines whose name is Check_Arg_Is_xxx take an
323 -- argument Arg which can either be a pragma argument association,
324 -- in which case the check is applied to the expression of the
325 -- association or an expression directly.
327 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
328 -- Check that an argument has the right form for an EXTERNAL_NAME
329 -- parameter of an extended import/export pragma. The rule is that
330 -- the name must be an identifier or string literal (in Ada 83 mode)
331 -- or a static string expression (in Ada 95 mode).
333 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
334 -- Check the specified argument Arg to make sure that it is an
335 -- identifier. If not give error and raise Pragma_Exit.
337 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
338 -- Check the specified argument Arg to make sure that it is an
339 -- integer literal. If not give error and raise Pragma_Exit.
341 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
342 -- Check the specified argument Arg to make sure that it has the
343 -- proper syntactic form for a local name and meets the semantic
344 -- requirements for a local name. The local name is analyzed as
345 -- part of the processing for this call. In addition, the local
346 -- name is required to represent an entity at the library level.
348 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
349 -- Check the specified argument Arg to make sure that it has the
350 -- proper syntactic form for a local name and meets the semantic
351 -- requirements for a local name. The local name is analyzed as
352 -- part of the processing for this call.
354 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
355 -- Check the specified argument Arg to make sure that it is a valid
356 -- locking policy name. If not give error and raise Pragma_Exit.
358 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
359 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
, N3
: Name_Id
);
360 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
, N3
, N4
: Name_Id
);
361 -- Check the specified argument Arg to make sure that it is an
362 -- identifier whose name matches either N1 or N2 (or N3 if present).
363 -- If not then give error and raise Pragma_Exit.
365 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
366 -- Check the specified argument Arg to make sure that it is a valid
367 -- queuing policy name. If not give error and raise Pragma_Exit.
369 procedure Check_Arg_Is_Static_Expression
372 -- Check the specified argument Arg to make sure that it is a static
373 -- expression of the given type (i.e. it will be analyzed and resolved
374 -- using this type, which can be any valid argument to Resolve, e.g.
375 -- Any_Integer is OK). If not, given error and raise Pragma_Exit.
377 procedure Check_Arg_Is_String_Literal
(Arg
: Node_Id
);
378 -- Check the specified argument Arg to make sure that it is a
379 -- string literal. If not give error and raise Pragma_Exit
381 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
382 -- Check the specified argument Arg to make sure that it is a valid
383 -- valid task dispatching policy name. If not give error and raise
386 procedure Check_Arg_Order
(Names
: Name_List
);
387 -- Checks for an instance of two arguments with identifiers for the
388 -- current pragma which are not in the sequence indicated by Names,
389 -- and if so, generates a fatal message about bad order of arguments.
391 procedure Check_At_Least_N_Arguments
(N
: Nat
);
392 -- Check there are at least N arguments present
394 procedure Check_At_Most_N_Arguments
(N
: Nat
);
395 -- Check there are no more than N arguments present
397 procedure Check_Component
(Comp
: Node_Id
);
398 -- Examine Unchecked_Union component for correct use of per-object
399 -- constrained subtypes, and for restrictions on finalizable components.
401 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
402 -- Nam is an N_String_Literal node containing the external name set
403 -- by an Import or Export pragma (or extended Import or Export pragma).
404 -- This procedure checks for possible duplications if this is the
405 -- export case, and if found, issues an appropriate error message.
407 procedure Check_First_Subtype
(Arg
: Node_Id
);
408 -- Checks that Arg, whose expression is an entity name referencing
409 -- a subtype, does not reference a type that is not a first subtype.
411 procedure Check_In_Main_Program
;
412 -- Common checks for pragmas that appear within a main program
413 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline).
415 procedure Check_Interrupt_Or_Attach_Handler
;
416 -- Common processing for first argument of pragma Interrupt_Handler
417 -- or pragma Attach_Handler.
419 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
420 -- Check that pragma appears in a declarative part, or in a package
421 -- specification, i.e. that it does not occur in a statement sequence
424 procedure Check_No_Identifier
(Arg
: Node_Id
);
425 -- Checks that the given argument does not have an identifier. If
426 -- an identifier is present, then an error message is issued, and
427 -- Pragma_Exit is raised.
429 procedure Check_No_Identifiers
;
430 -- Checks that none of the arguments to the pragma has an identifier.
431 -- If any argument has an identifier, then an error message is issued,
432 -- and Pragma_Exit is raised.
434 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
435 -- Checks if the given argument has an identifier, and if so, requires
436 -- it to match the given identifier name. If there is a non-matching
437 -- identifier, then an error message is given and Error_Pragmas raised.
439 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
440 -- Checks if the given argument has an identifier, and if so, requires
441 -- it to match the given identifier name. If there is a non-matching
442 -- identifier, then an error message is given and Error_Pragmas raised.
443 -- In this version of the procedure, the identifier name is given as
444 -- a string with lower case letters.
446 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean);
447 -- Called to process a precondition or postcondition pragma. There are
450 -- The pragma appears after a subprogram spec
452 -- If the corresponding check is not enabled, the pragma is analyzed
453 -- but otherwise ignored and control returns with In_Body set False.
455 -- If the check is enabled, then the first step is to analyze the
456 -- pragma, but this is skipped if the subprogram spec appears within
457 -- a package specification (because this is the case where we delay
458 -- analysis till the end of the spec). Then (whether or not it was
459 -- analyzed), the pragma is chained to the subprogram in question
460 -- (using Spec_PPC_List and Next_Pragma) and control returns to the
461 -- caller with In_Body set False.
463 -- The pragma appears at the start of subprogram body declarations
465 -- In this case an immediate return to the caller is made with
466 -- In_Body set True, and the pragma is NOT analyzed.
468 -- In all other cases, an error message for bad placement is given
470 procedure Check_Static_Constraint
(Constr
: Node_Id
);
471 -- Constr is a constraint from an N_Subtype_Indication node from a
472 -- component constraint in an Unchecked_Union type. This routine checks
473 -- that the constraint is static as required by the restrictions for
476 procedure Check_Valid_Configuration_Pragma
;
477 -- Legality checks for placement of a configuration pragma
479 procedure Check_Valid_Library_Unit_Pragma
;
480 -- Legality checks for library unit pragmas. A special case arises for
481 -- pragmas in generic instances that come from copies of the original
482 -- library unit pragmas in the generic templates. In the case of other
483 -- than library level instantiations these can appear in contexts which
484 -- would normally be invalid (they only apply to the original template
485 -- and to library level instantiations), and they are simply ignored,
486 -- which is implemented by rewriting them as null statements.
488 procedure Check_Variant
(Variant
: Node_Id
);
489 -- Check Unchecked_Union variant for lack of nested variants and
490 -- presence of at least one component.
492 procedure Error_Pragma
(Msg
: String);
493 pragma No_Return
(Error_Pragma
);
494 -- Outputs error message for current pragma. The message contains a %
495 -- that will be replaced with the pragma name, and the flag is placed
496 -- on the pragma itself. Pragma_Exit is then raised.
498 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
499 pragma No_Return
(Error_Pragma_Arg
);
500 -- Outputs error message for current pragma. The message may contain
501 -- a % that will be replaced with the pragma name. The parameter Arg
502 -- may either be a pragma argument association, in which case the flag
503 -- is placed on the expression of this association, or an expression,
504 -- in which case the flag is placed directly on the expression. The
505 -- message is placed using Error_Msg_N, so the message may also contain
506 -- an & insertion character which will reference the given Arg value.
507 -- After placing the message, Pragma_Exit is raised.
509 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
510 pragma No_Return
(Error_Pragma_Arg
);
511 -- Similar to above form of Error_Pragma_Arg except that two messages
512 -- are provided, the second is a continuation comment starting with \.
514 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
515 pragma No_Return
(Error_Pragma_Arg_Ident
);
516 -- Outputs error message for current pragma. The message may contain
517 -- a % that will be replaced with the pragma name. The parameter Arg
518 -- must be a pragma argument association with a non-empty identifier
519 -- (i.e. its Chars field must be set), and the error message is placed
520 -- on the identifier. The message is placed using Error_Msg_N so
521 -- the message may also contain an & insertion character which will
522 -- reference the identifier. After placing the message, Pragma_Exit
525 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
526 pragma No_Return
(Error_Pragma_Ref
);
527 -- Outputs error message for current pragma. The message may contain
528 -- a % that will be replaced with the pragma name. The parameter Ref
529 -- must be an entity whose name can be referenced by & and sloc by #.
530 -- After placing the message, Pragma_Exit is raised.
532 function Find_Lib_Unit_Name
return Entity_Id
;
533 -- Used for a library unit pragma to find the entity to which the
534 -- library unit pragma applies, returns the entity found.
536 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
537 -- If the pragma is a compilation unit pragma, the id must denote the
538 -- compilation unit in the same compilation, and the pragma must appear
539 -- in the list of preceding or trailing pragmas. If it is a program
540 -- unit pragma that is not a compilation unit pragma, then the
541 -- identifier must be visible.
543 function Find_Unique_Parameterless_Procedure
545 Arg
: Node_Id
) return Entity_Id
;
546 -- Used for a procedure pragma to find the unique parameterless
547 -- procedure identified by Name, returns it if it exists, otherwise
548 -- errors out and uses Arg as the pragma argument for the message.
550 procedure Gather_Associations
552 Args
: out Args_List
);
553 -- This procedure is used to gather the arguments for a pragma that
554 -- permits arbitrary ordering of parameters using the normal rules
555 -- for named and positional parameters. The Names argument is a list
556 -- of Name_Id values that corresponds to the allowed pragma argument
557 -- association identifiers in order. The result returned in Args is
558 -- a list of corresponding expressions that are the pragma arguments.
559 -- Note that this is a list of expressions, not of pragma argument
560 -- associations (Gather_Associations has completely checked all the
561 -- optional identifiers when it returns). An entry in Args is Empty
562 -- on return if the corresponding argument is not present.
564 procedure GNAT_Pragma
;
565 -- Called for all GNAT defined pragmas to check the relevant restriction
566 -- (No_Implementation_Pragmas).
568 function Is_Before_First_Decl
569 (Pragma_Node
: Node_Id
;
570 Decls
: List_Id
) return Boolean;
571 -- Return True if Pragma_Node is before the first declarative item in
572 -- Decls where Decls is the list of declarative items.
574 function Is_Configuration_Pragma
return Boolean;
575 -- Determines if the placement of the current pragma is appropriate
576 -- for a configuration pragma.
578 function Is_In_Context_Clause
return Boolean;
579 -- Returns True if pragma appears within the context clause of a unit,
580 -- and False for any other placement (does not generate any messages).
582 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
583 -- Analyzes the argument, and determines if it is a static string
584 -- expression, returns True if so, False if non-static or not String.
586 procedure Pragma_Misplaced
;
587 pragma No_Return
(Pragma_Misplaced
);
588 -- Issue fatal error message for misplaced pragma
590 procedure Process_Atomic_Shared_Volatile
;
591 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
592 -- Shared is an obsolete Ada 83 pragma, treated as being identical
593 -- in effect to pragma Atomic.
595 procedure Process_Compile_Time_Warning_Or_Error
;
596 -- Common processing for Compile_Time_Error and Compile_Time_Warning
598 procedure Process_Convention
(C
: out Convention_Id
; E
: out Entity_Id
);
599 -- Common processing for Convention, Interface, Import and Export.
600 -- Checks first two arguments of pragma, and sets the appropriate
601 -- convention value in the specified entity or entities. On return
602 -- C is the convention, E is the referenced entity.
604 procedure Process_Extended_Import_Export_Exception_Pragma
605 (Arg_Internal
: Node_Id
;
606 Arg_External
: Node_Id
;
609 -- Common processing for the pragmas Import/Export_Exception.
610 -- The three arguments correspond to the three named parameters of
611 -- the pragma. An argument is empty if the corresponding parameter
612 -- is not present in the pragma.
614 procedure Process_Extended_Import_Export_Object_Pragma
615 (Arg_Internal
: Node_Id
;
616 Arg_External
: Node_Id
;
618 -- Common processing for the pragmas Import/Export_Object.
619 -- The three arguments correspond to the three named parameters
620 -- of the pragmas. An argument is empty if the corresponding
621 -- parameter is not present in the pragma.
623 procedure Process_Extended_Import_Export_Internal_Arg
624 (Arg_Internal
: Node_Id
:= Empty
);
625 -- Common processing for all extended Import and Export pragmas. The
626 -- argument is the pragma parameter for the Internal argument. If
627 -- Arg_Internal is empty or inappropriate, an error message is posted.
628 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
629 -- set to identify the referenced entity.
631 procedure Process_Extended_Import_Export_Subprogram_Pragma
632 (Arg_Internal
: Node_Id
;
633 Arg_External
: Node_Id
;
634 Arg_Parameter_Types
: Node_Id
;
635 Arg_Result_Type
: Node_Id
:= Empty
;
636 Arg_Mechanism
: Node_Id
;
637 Arg_Result_Mechanism
: Node_Id
:= Empty
;
638 Arg_First_Optional_Parameter
: Node_Id
:= Empty
);
639 -- Common processing for all extended Import and Export pragmas
640 -- applying to subprograms. The caller omits any arguments that do
641 -- not apply to the pragma in question (for example, Arg_Result_Type
642 -- can be non-Empty only in the Import_Function and Export_Function
643 -- cases). The argument names correspond to the allowed pragma
644 -- association identifiers.
646 procedure Process_Generic_List
;
647 -- Common processing for Share_Generic and Inline_Generic
649 procedure Process_Import_Or_Interface
;
650 -- Common processing for Import of Interface
652 procedure Process_Inline
(Active
: Boolean);
653 -- Common processing for Inline and Inline_Always. The parameter
654 -- indicates if the inline pragma is active, i.e. if it should
655 -- actually cause inlining to occur.
657 procedure Process_Interface_Name
658 (Subprogram_Def
: Entity_Id
;
661 -- Given the last two arguments of pragma Import, pragma Export, or
662 -- pragma Interface_Name, performs validity checks and sets the
663 -- Interface_Name field of the given subprogram entity to the
664 -- appropriate external or link name, depending on the arguments
665 -- given. Ext_Arg is always present, but Link_Arg may be missing.
666 -- Note that Ext_Arg may represent the Link_Name if Link_Arg is
667 -- missing, and appropriate named notation is used for Ext_Arg.
668 -- If neither Ext_Arg nor Link_Arg is present, the interface name
669 -- is set to the default from the subprogram name.
671 procedure Process_Interrupt_Or_Attach_Handler
;
672 -- Common processing for Interrupt and Attach_Handler pragmas
674 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
675 -- Common processing for Restrictions and Restriction_Warnings pragmas.
676 -- Warn is True for Restriction_Warnings, or for Restrictions if the
677 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
678 -- is not set in the Restrictions case.
680 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
681 -- Common processing for Suppress and Unsuppress. The boolean parameter
682 -- Suppress_Case is True for the Suppress case, and False for the
685 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
686 -- This procedure sets the Is_Exported flag for the given entity,
687 -- checking that the entity was not previously imported. Arg is
688 -- the argument that specified the entity. A check is also made
689 -- for exporting inappropriate entities.
691 procedure Set_Extended_Import_Export_External_Name
692 (Internal_Ent
: Entity_Id
;
693 Arg_External
: Node_Id
);
694 -- Common processing for all extended import export pragmas. The first
695 -- argument, Internal_Ent, is the internal entity, which has already
696 -- been checked for validity by the caller. Arg_External is from the
697 -- Import or Export pragma, and may be null if no External parameter
698 -- was present. If Arg_External is present and is a non-null string
699 -- (a null string is treated as the default), then the Interface_Name
700 -- field of Internal_Ent is set appropriately.
702 procedure Set_Imported
(E
: Entity_Id
);
703 -- This procedure sets the Is_Imported flag for the given entity,
704 -- checking that it is not previously exported or imported.
706 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
707 -- Mech is a parameter passing mechanism (see Import_Function syntax
708 -- for MECHANISM_NAME). This routine checks that the mechanism argument
709 -- has the right form, and if not issues an error message. If the
710 -- argument has the right form then the Mechanism field of Ent is
711 -- set appropriately.
713 procedure Set_Ravenscar_Profile
(N
: Node_Id
);
714 -- Activate the set of configuration pragmas and restrictions that
715 -- make up the Ravenscar Profile. N is the corresponding pragma
716 -- node, which is used for error messages on any constructs
717 -- that violate the profile.
719 ---------------------
720 -- Ada_2005_Pragma --
721 ---------------------
723 procedure Ada_2005_Pragma
is
725 if Ada_Version
<= Ada_95
then
726 Check_Restriction
(No_Implementation_Pragmas
, N
);
730 --------------------------
731 -- Check_Ada_83_Warning --
732 --------------------------
734 procedure Check_Ada_83_Warning
is
736 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
737 Error_Msg_N
("(Ada 83) pragma& is non-standard?", N
);
739 end Check_Ada_83_Warning
;
741 ---------------------
742 -- Check_Arg_Count --
743 ---------------------
745 procedure Check_Arg_Count
(Required
: Nat
) is
747 if Arg_Count
/= Required
then
748 Error_Pragma
("wrong number of arguments for pragma%");
752 --------------------------------
753 -- Check_Arg_Is_External_Name --
754 --------------------------------
756 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
757 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
760 if Nkind
(Argx
) = N_Identifier
then
764 Analyze_And_Resolve
(Argx
, Standard_String
);
766 if Is_OK_Static_Expression
(Argx
) then
769 elsif Etype
(Argx
) = Any_Type
then
772 -- An interesting special case, if we have a string literal and
773 -- we are in Ada 83 mode, then we allow it even though it will
774 -- not be flagged as static. This allows expected Ada 83 mode
775 -- use of external names which are string literals, even though
776 -- technically these are not static in Ada 83.
778 elsif Ada_Version
= Ada_83
779 and then Nkind
(Argx
) = N_String_Literal
783 -- Static expression that raises Constraint_Error. This has
784 -- already been flagged, so just exit from pragma processing.
786 elsif Is_Static_Expression
(Argx
) then
789 -- Here we have a real error (non-static expression)
792 Error_Msg_Name_1
:= Pname
;
794 ("argument for pragma% must be a identifier or " &
795 "static string expression!", Argx
);
799 end Check_Arg_Is_External_Name
;
801 -----------------------------
802 -- Check_Arg_Is_Identifier --
803 -----------------------------
805 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
806 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
808 if Nkind
(Argx
) /= N_Identifier
then
810 ("argument for pragma% must be identifier", Argx
);
812 end Check_Arg_Is_Identifier
;
814 ----------------------------------
815 -- Check_Arg_Is_Integer_Literal --
816 ----------------------------------
818 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
819 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
821 if Nkind
(Argx
) /= N_Integer_Literal
then
823 ("argument for pragma% must be integer literal", Argx
);
825 end Check_Arg_Is_Integer_Literal
;
827 -------------------------------------------
828 -- Check_Arg_Is_Library_Level_Local_Name --
829 -------------------------------------------
833 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
834 -- | library_unit_NAME
836 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
838 Check_Arg_Is_Local_Name
(Arg
);
840 if not Is_Library_Level_Entity
(Entity
(Expression
(Arg
)))
841 and then Comes_From_Source
(N
)
844 ("argument for pragma% must be library level entity", Arg
);
846 end Check_Arg_Is_Library_Level_Local_Name
;
848 -----------------------------
849 -- Check_Arg_Is_Local_Name --
850 -----------------------------
854 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
855 -- | library_unit_NAME
857 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
858 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
863 if Nkind
(Argx
) not in N_Direct_Name
864 and then (Nkind
(Argx
) /= N_Attribute_Reference
865 or else Present
(Expressions
(Argx
))
866 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
867 and then (not Is_Entity_Name
(Argx
)
868 or else not Is_Compilation_Unit
(Entity
(Argx
)))
870 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
873 if Is_Entity_Name
(Argx
)
874 and then Scope
(Entity
(Argx
)) /= Current_Scope
877 ("pragma% argument must be in same declarative part", Arg
);
879 end Check_Arg_Is_Local_Name
;
881 ---------------------------------
882 -- Check_Arg_Is_Locking_Policy --
883 ---------------------------------
885 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
886 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
889 Check_Arg_Is_Identifier
(Argx
);
891 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
893 ("& is not a valid locking policy name", Argx
);
895 end Check_Arg_Is_Locking_Policy
;
897 -------------------------
898 -- Check_Arg_Is_One_Of --
899 -------------------------
901 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
902 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
905 Check_Arg_Is_Identifier
(Argx
);
907 if Chars
(Argx
) /= N1
and then Chars
(Argx
) /= N2
then
908 Error_Msg_Name_2
:= N1
;
909 Error_Msg_Name_3
:= N2
;
910 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
912 end Check_Arg_Is_One_Of
;
914 procedure Check_Arg_Is_One_Of
916 N1
, N2
, N3
: Name_Id
)
918 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
921 Check_Arg_Is_Identifier
(Argx
);
923 if Chars
(Argx
) /= N1
924 and then Chars
(Argx
) /= N2
925 and then Chars
(Argx
) /= N3
927 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
929 end Check_Arg_Is_One_Of
;
931 procedure Check_Arg_Is_One_Of
933 N1
, N2
, N3
, N4
: Name_Id
)
935 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
938 Check_Arg_Is_Identifier
(Argx
);
940 if Chars
(Argx
) /= N1
941 and then Chars
(Argx
) /= N2
942 and then Chars
(Argx
) /= N3
943 and then Chars
(Argx
) /= N4
945 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
947 end Check_Arg_Is_One_Of
;
949 ---------------------------------
950 -- Check_Arg_Is_Queuing_Policy --
951 ---------------------------------
953 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
954 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
957 Check_Arg_Is_Identifier
(Argx
);
959 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
961 ("& is not a valid queuing policy name", Argx
);
963 end Check_Arg_Is_Queuing_Policy
;
965 ------------------------------------
966 -- Check_Arg_Is_Static_Expression --
967 ------------------------------------
969 procedure Check_Arg_Is_Static_Expression
973 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
976 Analyze_And_Resolve
(Argx
, Typ
);
978 if Is_OK_Static_Expression
(Argx
) then
981 elsif Etype
(Argx
) = Any_Type
then
984 -- An interesting special case, if we have a string literal and
985 -- we are in Ada 83 mode, then we allow it even though it will
986 -- not be flagged as static. This allows the use of Ada 95
987 -- pragmas like Import in Ada 83 mode. They will of course be
988 -- flagged with warnings as usual, but will not cause errors.
990 elsif Ada_Version
= Ada_83
991 and then Nkind
(Argx
) = N_String_Literal
995 -- Static expression that raises Constraint_Error. This has
996 -- already been flagged, so just exit from pragma processing.
998 elsif Is_Static_Expression
(Argx
) then
1001 -- Finally, we have a real error
1004 Error_Msg_Name_1
:= Pname
;
1005 Flag_Non_Static_Expr
1006 ("argument for pragma% must be a static expression!", Argx
);
1009 end Check_Arg_Is_Static_Expression
;
1011 ---------------------------------
1012 -- Check_Arg_Is_String_Literal --
1013 ---------------------------------
1015 procedure Check_Arg_Is_String_Literal
(Arg
: Node_Id
) is
1016 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1018 if Nkind
(Argx
) /= N_String_Literal
then
1020 ("argument for pragma% must be string literal", Argx
);
1022 end Check_Arg_Is_String_Literal
;
1024 ------------------------------------------
1025 -- Check_Arg_Is_Task_Dispatching_Policy --
1026 ------------------------------------------
1028 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
1029 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1032 Check_Arg_Is_Identifier
(Argx
);
1034 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
1036 ("& is not a valid task dispatching policy name", Argx
);
1038 end Check_Arg_Is_Task_Dispatching_Policy
;
1040 ---------------------
1041 -- Check_Arg_Order --
1042 ---------------------
1044 procedure Check_Arg_Order
(Names
: Name_List
) is
1047 Highest_So_Far
: Natural := 0;
1048 -- Highest index in Names seen do far
1052 for J
in 1 .. Arg_Count
loop
1053 if Chars
(Arg
) /= No_Name
then
1054 for K
in Names
'Range loop
1055 if Chars
(Arg
) = Names
(K
) then
1056 if K
< Highest_So_Far
then
1057 Error_Msg_Name_1
:= Pname
;
1059 ("parameters out of order for pragma%", Arg
);
1060 Error_Msg_Name_1
:= Names
(K
);
1061 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
1062 Error_Msg_N
("\% must appear before %", Arg
);
1066 Highest_So_Far
:= K
;
1074 end Check_Arg_Order
;
1076 --------------------------------
1077 -- Check_At_Least_N_Arguments --
1078 --------------------------------
1080 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
1082 if Arg_Count
< N
then
1083 Error_Pragma
("too few arguments for pragma%");
1085 end Check_At_Least_N_Arguments
;
1087 -------------------------------
1088 -- Check_At_Most_N_Arguments --
1089 -------------------------------
1091 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
1094 if Arg_Count
> N
then
1096 for J
in 1 .. N
loop
1098 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
1101 end Check_At_Most_N_Arguments
;
1103 ---------------------
1104 -- Check_Component --
1105 ---------------------
1107 procedure Check_Component
(Comp
: Node_Id
) is
1109 if Nkind
(Comp
) = N_Component_Declaration
then
1111 Sindic
: constant Node_Id
:=
1112 Subtype_Indication
(Component_Definition
(Comp
));
1113 Typ
: constant Entity_Id
:=
1114 Etype
(Defining_Identifier
(Comp
));
1116 if Nkind
(Sindic
) = N_Subtype_Indication
then
1118 -- Ada 2005 (AI-216): If a component subtype is subject to
1119 -- a per-object constraint, then the component type shall
1120 -- be an Unchecked_Union.
1122 if Has_Per_Object_Constraint
(Defining_Identifier
(Comp
))
1124 not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
1126 Error_Msg_N
("component subtype subject to per-object" &
1127 " constraint must be an Unchecked_Union", Comp
);
1131 if Is_Controlled
(Typ
) then
1133 ("component of unchecked union cannot be controlled", Comp
);
1135 elsif Has_Task
(Typ
) then
1137 ("component of unchecked union cannot have tasks", Comp
);
1141 end Check_Component
;
1143 ----------------------------------
1144 -- Check_Duplicated_Export_Name --
1145 ----------------------------------
1147 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
1148 String_Val
: constant String_Id
:= Strval
(Nam
);
1151 -- We are only interested in the export case, and in the case of
1152 -- generics, it is the instance, not the template, that is the
1153 -- problem (the template will generate a warning in any case).
1155 if not Inside_A_Generic
1156 and then (Prag_Id
= Pragma_Export
1158 Prag_Id
= Pragma_Export_Procedure
1160 Prag_Id
= Pragma_Export_Valued_Procedure
1162 Prag_Id
= Pragma_Export_Function
)
1164 for J
in Externals
.First
.. Externals
.Last
loop
1165 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
1166 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
1167 Error_Msg_N
("external name duplicates name given#", Nam
);
1172 Externals
.Append
(Nam
);
1174 end Check_Duplicated_Export_Name
;
1176 -------------------------
1177 -- Check_First_Subtype --
1178 -------------------------
1180 procedure Check_First_Subtype
(Arg
: Node_Id
) is
1181 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
1183 if not Is_First_Subtype
(Entity
(Argx
)) then
1185 ("pragma% cannot apply to subtype", Argx
);
1187 end Check_First_Subtype
;
1189 ---------------------------
1190 -- Check_In_Main_Program --
1191 ---------------------------
1193 procedure Check_In_Main_Program
is
1194 P
: constant Node_Id
:= Parent
(N
);
1197 -- Must be at in subprogram body
1199 if Nkind
(P
) /= N_Subprogram_Body
then
1200 Error_Pragma
("% pragma allowed only in subprogram");
1202 -- Otherwise warn if obviously not main program
1204 elsif Present
(Parameter_Specifications
(Specification
(P
)))
1205 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
1207 Error_Msg_Name_1
:= Pname
;
1209 ("?pragma% is only effective in main program", N
);
1211 end Check_In_Main_Program
;
1213 ---------------------------------------
1214 -- Check_Interrupt_Or_Attach_Handler --
1215 ---------------------------------------
1217 procedure Check_Interrupt_Or_Attach_Handler
is
1218 Arg1_X
: constant Node_Id
:= Expression
(Arg1
);
1219 Handler_Proc
, Proc_Scope
: Entity_Id
;
1224 if Prag_Id
= Pragma_Interrupt_Handler
then
1225 Check_Restriction
(No_Dynamic_Attachment
, N
);
1228 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
1229 Proc_Scope
:= Scope
(Handler_Proc
);
1231 -- On AAMP only, a pragma Interrupt_Handler is supported for
1232 -- nonprotected parameterless procedures.
1234 if not AAMP_On_Target
1235 or else Prag_Id
= Pragma_Attach_Handler
1237 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
1239 ("argument of pragma% must be protected procedure", Arg1
);
1242 if Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
)) then
1243 Error_Pragma
("pragma% must be in protected definition");
1247 if not Is_Library_Level_Entity
(Proc_Scope
)
1248 or else (AAMP_On_Target
1249 and then not Is_Library_Level_Entity
(Handler_Proc
))
1252 ("argument for pragma% must be library level entity", Arg1
);
1254 end Check_Interrupt_Or_Attach_Handler
;
1256 -------------------------------------------
1257 -- Check_Is_In_Decl_Part_Or_Package_Spec --
1258 -------------------------------------------
1260 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
1269 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
1272 elsif Nkind
(P
) = N_Package_Specification
then
1275 elsif Nkind
(P
) = N_Block_Statement
then
1278 -- Note: the following tests seem a little peculiar, because
1279 -- they test for bodies, but if we were in the statement part
1280 -- of the body, we would already have hit the handled statement
1281 -- sequence, so the only way we get here is by being in the
1282 -- declarative part of the body.
1284 elsif Nkind_In
(P
, N_Subprogram_Body
,
1295 Error_Pragma
("pragma% is not in declarative part or package spec");
1296 end Check_Is_In_Decl_Part_Or_Package_Spec
;
1298 -------------------------
1299 -- Check_No_Identifier --
1300 -------------------------
1302 procedure Check_No_Identifier
(Arg
: Node_Id
) is
1304 if Chars
(Arg
) /= No_Name
then
1305 Error_Pragma_Arg_Ident
1306 ("pragma% does not permit identifier& here", Arg
);
1308 end Check_No_Identifier
;
1310 --------------------------
1311 -- Check_No_Identifiers --
1312 --------------------------
1314 procedure Check_No_Identifiers
is
1317 if Arg_Count
> 0 then
1319 while Present
(Arg_Node
) loop
1320 Check_No_Identifier
(Arg_Node
);
1324 end Check_No_Identifiers
;
1326 -------------------------------
1327 -- Check_Optional_Identifier --
1328 -------------------------------
1330 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
1332 if Present
(Arg
) and then Chars
(Arg
) /= No_Name
then
1333 if Chars
(Arg
) /= Id
then
1334 Error_Msg_Name_1
:= Pname
;
1335 Error_Msg_Name_2
:= Id
;
1336 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
1340 end Check_Optional_Identifier
;
1342 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
1344 Name_Buffer
(1 .. Id
'Length) := Id
;
1345 Name_Len
:= Id
'Length;
1346 Check_Optional_Identifier
(Arg
, Name_Find
);
1347 end Check_Optional_Identifier
;
1349 --------------------------------------
1350 -- Check_Precondition_Postcondition --
1351 --------------------------------------
1353 procedure Check_Precondition_Postcondition
(In_Body
: out Boolean) is
1357 procedure Chain_PPC
(PO
: Node_Id
);
1358 -- If PO is a subprogram declaration node (or a generic subprogram
1359 -- declaration node), then the precondition/postcondition applies
1360 -- to this subprogram and the processing for the pragma is completed.
1361 -- Otherwise the pragma is misplaced.
1367 procedure Chain_PPC
(PO
: Node_Id
) is
1371 if not Nkind_In
(PO
, N_Subprogram_Declaration
,
1372 N_Generic_Subprogram_Declaration
)
1377 -- Here if we have subprogram or generic subprogram declaration
1379 S
:= Defining_Unit_Name
(Specification
(PO
));
1381 -- Analyze the pragma unless it appears within a package spec,
1382 -- which is the case where we delay the analysis of the PPC until
1383 -- the end of the package declarations (for details, see
1384 -- Analyze_Package_Specification.Analyze_PPCs).
1386 if not Is_Package_Or_Generic_Package
(Scope
(S
)) then
1387 Analyze_PPC_In_Decl_Part
(N
, S
);
1390 -- Chain spec PPC pragma to list for subprogram
1392 Set_Next_Pragma
(N
, Spec_PPC_List
(S
));
1393 Set_Spec_PPC_List
(S
, N
);
1395 -- Return indicating spec case
1401 -- Start of processing for Check_Precondition_Postcondition
1404 if not Is_List_Member
(N
) then
1408 -- Record whether pragma is enabled
1410 Set_PPC_Enabled
(N
, Check_Enabled
(Pname
));
1412 -- If we are within an inlined body, the legality of the pragma
1413 -- has been checked already.
1415 if In_Inlined_Body
then
1420 -- Search prior declarations
1423 while Present
(Prev
(P
)) loop
1426 -- If the previous node is a generic subprogram, do not go to
1427 -- to the original node, which is the unanalyzed tree: we need
1428 -- to attach the pre/postconditions to the analyzed version
1429 -- at this point. They get propagated to the original tree when
1430 -- analyzing the corresponding body.
1432 if Nkind
(P
) not in N_Generic_Declaration
then
1433 PO
:= Original_Node
(P
);
1438 -- Skip past prior pragma
1440 if Nkind
(PO
) = N_Pragma
then
1443 -- Skip stuff not coming from source
1445 elsif not Comes_From_Source
(PO
) then
1448 -- Only remaining possibility is subprogram declaration
1456 -- If we fall through loop, pragma is at start of list, so see if
1457 -- it is at the start of declarations of a subprogram body.
1459 if Nkind
(Parent
(N
)) = N_Subprogram_Body
1460 and then List_Containing
(N
) = Declarations
(Parent
(N
))
1462 if Operating_Mode
/= Generate_Code
then
1464 -- Analyze expression in pragma, for correctness
1465 -- and for ASIS use.
1467 Preanalyze_Spec_Expression
1468 (Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
1474 -- See if it is in the pragmas after a library level subprogram
1476 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
1477 Chain_PPC
(Unit
(Parent
(Parent
(N
))));
1481 -- If we fall through, pragma was misplaced
1484 end Check_Precondition_Postcondition
;
1486 -----------------------------
1487 -- Check_Static_Constraint --
1488 -----------------------------
1490 -- Note: for convenience in writing this procedure, in addition to
1491 -- the officially (i.e. by spec) allowed argument which is always
1492 -- a constraint, it also allows ranges and discriminant associations.
1493 -- Above is not clear ???
1495 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
1497 procedure Require_Static
(E
: Node_Id
);
1498 -- Require given expression to be static expression
1500 --------------------
1501 -- Require_Static --
1502 --------------------
1504 procedure Require_Static
(E
: Node_Id
) is
1506 if not Is_OK_Static_Expression
(E
) then
1507 Flag_Non_Static_Expr
1508 ("non-static constraint not allowed in Unchecked_Union!", E
);
1513 -- Start of processing for Check_Static_Constraint
1516 case Nkind
(Constr
) is
1517 when N_Discriminant_Association
=>
1518 Require_Static
(Expression
(Constr
));
1521 Require_Static
(Low_Bound
(Constr
));
1522 Require_Static
(High_Bound
(Constr
));
1524 when N_Attribute_Reference
=>
1525 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
1526 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
1528 when N_Range_Constraint
=>
1529 Check_Static_Constraint
(Range_Expression
(Constr
));
1531 when N_Index_Or_Discriminant_Constraint
=>
1535 IDC
:= First
(Constraints
(Constr
));
1536 while Present
(IDC
) loop
1537 Check_Static_Constraint
(IDC
);
1545 end Check_Static_Constraint
;
1547 --------------------------------------
1548 -- Check_Valid_Configuration_Pragma --
1549 --------------------------------------
1551 -- A configuration pragma must appear in the context clause of a
1552 -- compilation unit, and only other pragmas may precede it. Note that
1553 -- the test also allows use in a configuration pragma file.
1555 procedure Check_Valid_Configuration_Pragma
is
1557 if not Is_Configuration_Pragma
then
1558 Error_Pragma
("incorrect placement for configuration pragma%");
1560 end Check_Valid_Configuration_Pragma
;
1562 -------------------------------------
1563 -- Check_Valid_Library_Unit_Pragma --
1564 -------------------------------------
1566 procedure Check_Valid_Library_Unit_Pragma
is
1568 Parent_Node
: Node_Id
;
1569 Unit_Name
: Entity_Id
;
1570 Unit_Kind
: Node_Kind
;
1571 Unit_Node
: Node_Id
;
1572 Sindex
: Source_File_Index
;
1575 if not Is_List_Member
(N
) then
1579 Plist
:= List_Containing
(N
);
1580 Parent_Node
:= Parent
(Plist
);
1582 if Parent_Node
= Empty
then
1585 -- Case of pragma appearing after a compilation unit. In this
1586 -- case it must have an argument with the corresponding name
1587 -- and must be part of the following pragmas of its parent.
1589 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
1590 if Plist
/= Pragmas_After
(Parent_Node
) then
1593 elsif Arg_Count
= 0 then
1595 ("argument required if outside compilation unit");
1598 Check_No_Identifiers
;
1599 Check_Arg_Count
(1);
1600 Unit_Node
:= Unit
(Parent
(Parent_Node
));
1601 Unit_Kind
:= Nkind
(Unit_Node
);
1603 Analyze
(Expression
(Arg1
));
1605 if Unit_Kind
= N_Generic_Subprogram_Declaration
1606 or else Unit_Kind
= N_Subprogram_Declaration
1608 Unit_Name
:= Defining_Entity
(Unit_Node
);
1610 elsif Unit_Kind
in N_Generic_Instantiation
then
1611 Unit_Name
:= Defining_Entity
(Unit_Node
);
1614 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
1617 if Chars
(Unit_Name
) /=
1618 Chars
(Entity
(Expression
(Arg1
)))
1621 ("pragma% argument is not current unit name", Arg1
);
1624 if Ekind
(Unit_Name
) = E_Package
1625 and then Present
(Renamed_Entity
(Unit_Name
))
1627 Error_Pragma
("pragma% not allowed for renamed package");
1631 -- Pragma appears other than after a compilation unit
1634 -- Here we check for the generic instantiation case and also
1635 -- for the case of processing a generic formal package. We
1636 -- detect these cases by noting that the Sloc on the node
1637 -- does not belong to the current compilation unit.
1639 Sindex
:= Source_Index
(Current_Sem_Unit
);
1641 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
1642 Rewrite
(N
, Make_Null_Statement
(Loc
));
1645 -- If before first declaration, the pragma applies to the
1646 -- enclosing unit, and the name if present must be this name.
1648 elsif Is_Before_First_Decl
(N
, Plist
) then
1649 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
1650 Unit_Kind
:= Nkind
(Unit_Node
);
1652 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
1655 elsif Unit_Kind
= N_Subprogram_Body
1656 and then not Acts_As_Spec
(Unit_Node
)
1660 elsif Nkind
(Parent_Node
) = N_Package_Body
then
1663 elsif Nkind
(Parent_Node
) = N_Package_Specification
1664 and then Plist
= Private_Declarations
(Parent_Node
)
1668 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
1669 or else Nkind
(Parent_Node
) =
1670 N_Generic_Subprogram_Declaration
)
1671 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
1675 elsif Arg_Count
> 0 then
1676 Analyze
(Expression
(Arg1
));
1678 if Entity
(Expression
(Arg1
)) /= Current_Scope
then
1680 ("name in pragma% must be enclosing unit", Arg1
);
1683 -- It is legal to have no argument in this context
1689 -- Error if not before first declaration. This is because a
1690 -- library unit pragma argument must be the name of a library
1691 -- unit (RM 10.1.5(7)), but the only names permitted in this
1692 -- context are (RM 10.1.5(6)) names of subprogram declarations,
1693 -- generic subprogram declarations or generic instantiations.
1697 ("pragma% misplaced, must be before first declaration");
1701 end Check_Valid_Library_Unit_Pragma
;
1707 procedure Check_Variant
(Variant
: Node_Id
) is
1708 Clist
: constant Node_Id
:= Component_List
(Variant
);
1712 if not Is_Non_Empty_List
(Component_Items
(Clist
)) then
1714 ("Unchecked_Union may not have empty component list",
1719 Comp
:= First
(Component_Items
(Clist
));
1720 while Present
(Comp
) loop
1721 Check_Component
(Comp
);
1730 procedure Error_Pragma
(Msg
: String) is
1732 Error_Msg_Name_1
:= Pname
;
1733 Error_Msg_N
(Msg
, N
);
1737 ----------------------
1738 -- Error_Pragma_Arg --
1739 ----------------------
1741 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
1743 Error_Msg_Name_1
:= Pname
;
1744 Error_Msg_N
(Msg
, Get_Pragma_Arg
(Arg
));
1746 end Error_Pragma_Arg
;
1748 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
1750 Error_Msg_Name_1
:= Pname
;
1751 Error_Msg_N
(Msg1
, Get_Pragma_Arg
(Arg
));
1752 Error_Pragma_Arg
(Msg2
, Arg
);
1753 end Error_Pragma_Arg
;
1755 ----------------------------
1756 -- Error_Pragma_Arg_Ident --
1757 ----------------------------
1759 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
1761 Error_Msg_Name_1
:= Pname
;
1762 Error_Msg_N
(Msg
, Arg
);
1764 end Error_Pragma_Arg_Ident
;
1766 ----------------------
1767 -- Error_Pragma_Ref --
1768 ----------------------
1770 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
1772 Error_Msg_Name_1
:= Pname
;
1773 Error_Msg_Sloc
:= Sloc
(Ref
);
1774 Error_Msg_NE
(Msg
, N
, Ref
);
1776 end Error_Pragma_Ref
;
1778 ------------------------
1779 -- Find_Lib_Unit_Name --
1780 ------------------------
1782 function Find_Lib_Unit_Name
return Entity_Id
is
1784 -- Return inner compilation unit entity, for case of nested
1785 -- categorization pragmas. This happens in generic unit.
1787 if Nkind
(Parent
(N
)) = N_Package_Specification
1788 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
1790 return Defining_Entity
(Parent
(N
));
1792 return Current_Scope
;
1794 end Find_Lib_Unit_Name
;
1796 ----------------------------
1797 -- Find_Program_Unit_Name --
1798 ----------------------------
1800 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
1801 Unit_Name
: Entity_Id
;
1802 Unit_Kind
: Node_Kind
;
1803 P
: constant Node_Id
:= Parent
(N
);
1806 if Nkind
(P
) = N_Compilation_Unit
then
1807 Unit_Kind
:= Nkind
(Unit
(P
));
1809 if Unit_Kind
= N_Subprogram_Declaration
1810 or else Unit_Kind
= N_Package_Declaration
1811 or else Unit_Kind
in N_Generic_Declaration
1813 Unit_Name
:= Defining_Entity
(Unit
(P
));
1815 if Chars
(Id
) = Chars
(Unit_Name
) then
1816 Set_Entity
(Id
, Unit_Name
);
1817 Set_Etype
(Id
, Etype
(Unit_Name
));
1819 Set_Etype
(Id
, Any_Type
);
1821 ("cannot find program unit referenced by pragma%");
1825 Set_Etype
(Id
, Any_Type
);
1826 Error_Pragma
("pragma% inapplicable to this unit");
1832 end Find_Program_Unit_Name
;
1834 -----------------------------------------
1835 -- Find_Unique_Parameterless_Procedure --
1836 -----------------------------------------
1838 function Find_Unique_Parameterless_Procedure
1840 Arg
: Node_Id
) return Entity_Id
1842 Proc
: Entity_Id
:= Empty
;
1845 -- The body of this procedure needs some comments ???
1847 if not Is_Entity_Name
(Name
) then
1849 ("argument of pragma% must be entity name", Arg
);
1851 elsif not Is_Overloaded
(Name
) then
1852 Proc
:= Entity
(Name
);
1854 if Ekind
(Proc
) /= E_Procedure
1855 or else Present
(First_Formal
(Proc
)) then
1857 ("argument of pragma% must be parameterless procedure", Arg
);
1862 Found
: Boolean := False;
1864 Index
: Interp_Index
;
1867 Get_First_Interp
(Name
, Index
, It
);
1868 while Present
(It
.Nam
) loop
1871 if Ekind
(Proc
) = E_Procedure
1872 and then No
(First_Formal
(Proc
))
1876 Set_Entity
(Name
, Proc
);
1877 Set_Is_Overloaded
(Name
, False);
1880 ("ambiguous handler name for pragma% ", Arg
);
1884 Get_Next_Interp
(Index
, It
);
1889 ("argument of pragma% must be parameterless procedure",
1892 Proc
:= Entity
(Name
);
1898 end Find_Unique_Parameterless_Procedure
;
1900 -------------------------
1901 -- Gather_Associations --
1902 -------------------------
1904 procedure Gather_Associations
1906 Args
: out Args_List
)
1911 -- Initialize all parameters to Empty
1913 for J
in Args
'Range loop
1917 -- That's all we have to do if there are no argument associations
1919 if No
(Pragma_Argument_Associations
(N
)) then
1923 -- Otherwise first deal with any positional parameters present
1925 Arg
:= First
(Pragma_Argument_Associations
(N
));
1926 for Index
in Args
'Range loop
1927 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
1928 Args
(Index
) := Expression
(Arg
);
1932 -- Positional parameters all processed, if any left, then we
1933 -- have too many positional parameters.
1935 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
1937 ("too many positional associations for pragma%", Arg
);
1940 -- Process named parameters if any are present
1942 while Present
(Arg
) loop
1943 if Chars
(Arg
) = No_Name
then
1945 ("positional association cannot follow named association",
1949 for Index
in Names
'Range loop
1950 if Names
(Index
) = Chars
(Arg
) then
1951 if Present
(Args
(Index
)) then
1953 ("duplicate argument association for pragma%", Arg
);
1955 Args
(Index
) := Expression
(Arg
);
1960 if Index
= Names
'Last then
1961 Error_Msg_Name_1
:= Pname
;
1962 Error_Msg_N
("pragma% does not allow & argument", Arg
);
1964 -- Check for possible misspelling
1966 for Index1
in Names
'Range loop
1967 if Is_Bad_Spelling_Of
1968 (Chars
(Arg
), Names
(Index1
))
1970 Error_Msg_Name_1
:= Names
(Index1
);
1971 Error_Msg_N
("\possible misspelling of%", Arg
);
1983 end Gather_Associations
;
1989 procedure GNAT_Pragma
is
1991 Check_Restriction
(No_Implementation_Pragmas
, N
);
1994 --------------------------
1995 -- Is_Before_First_Decl --
1996 --------------------------
1998 function Is_Before_First_Decl
1999 (Pragma_Node
: Node_Id
;
2000 Decls
: List_Id
) return Boolean
2002 Item
: Node_Id
:= First
(Decls
);
2005 -- Only other pragmas can come before this pragma
2008 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
2011 elsif Item
= Pragma_Node
then
2017 end Is_Before_First_Decl
;
2019 -----------------------------
2020 -- Is_Configuration_Pragma --
2021 -----------------------------
2023 -- A configuration pragma must appear in the context clause of a
2024 -- compilation unit, and only other pragmas may precede it. Note that
2025 -- the test below also permits use in a configuration pragma file.
2027 function Is_Configuration_Pragma
return Boolean is
2028 Lis
: constant List_Id
:= List_Containing
(N
);
2029 Par
: constant Node_Id
:= Parent
(N
);
2033 -- If no parent, then we are in the configuration pragma file,
2034 -- so the placement is definitely appropriate.
2039 -- Otherwise we must be in the context clause of a compilation unit
2040 -- and the only thing allowed before us in the context list is more
2041 -- configuration pragmas.
2043 elsif Nkind
(Par
) = N_Compilation_Unit
2044 and then Context_Items
(Par
) = Lis
2051 elsif Nkind
(Prg
) /= N_Pragma
then
2061 end Is_Configuration_Pragma
;
2063 --------------------------
2064 -- Is_In_Context_Clause --
2065 --------------------------
2067 function Is_In_Context_Clause
return Boolean is
2069 Parent_Node
: Node_Id
;
2072 if not Is_List_Member
(N
) then
2076 Plist
:= List_Containing
(N
);
2077 Parent_Node
:= Parent
(Plist
);
2079 if Parent_Node
= Empty
2080 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
2081 or else Context_Items
(Parent_Node
) /= Plist
2088 end Is_In_Context_Clause
;
2090 ---------------------------------
2091 -- Is_Static_String_Expression --
2092 ---------------------------------
2094 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
2095 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
2098 Analyze_And_Resolve
(Argx
);
2099 return Is_OK_Static_Expression
(Argx
)
2100 and then Nkind
(Argx
) = N_String_Literal
;
2101 end Is_Static_String_Expression
;
2103 ----------------------
2104 -- Pragma_Misplaced --
2105 ----------------------
2107 procedure Pragma_Misplaced
is
2109 Error_Pragma
("incorrect placement of pragma%");
2110 end Pragma_Misplaced
;
2112 ------------------------------------
2113 -- Process Atomic_Shared_Volatile --
2114 ------------------------------------
2116 procedure Process_Atomic_Shared_Volatile
is
2123 procedure Set_Atomic
(E
: Entity_Id
);
2124 -- Set given type as atomic, and if no explicit alignment was given,
2125 -- set alignment to unknown, since back end knows what the alignment
2126 -- requirements are for atomic arrays. Note: this step is necessary
2127 -- for derived types.
2133 procedure Set_Atomic
(E
: Entity_Id
) is
2137 if not Has_Alignment_Clause
(E
) then
2138 Set_Alignment
(E
, Uint_0
);
2142 -- Start of processing for Process_Atomic_Shared_Volatile
2145 Check_Ada_83_Warning
;
2146 Check_No_Identifiers
;
2147 Check_Arg_Count
(1);
2148 Check_Arg_Is_Local_Name
(Arg1
);
2149 E_Id
:= Expression
(Arg1
);
2151 if Etype
(E_Id
) = Any_Type
then
2156 D
:= Declaration_Node
(E
);
2160 if Rep_Item_Too_Early
(E
, N
)
2162 Rep_Item_Too_Late
(E
, N
)
2166 Check_First_Subtype
(Arg1
);
2169 if Prag_Id
/= Pragma_Volatile
then
2171 Set_Atomic
(Underlying_Type
(E
));
2172 Set_Atomic
(Base_Type
(E
));
2175 -- Attribute belongs on the base type. If the view of the type is
2176 -- currently private, it also belongs on the underlying type.
2178 Set_Is_Volatile
(Base_Type
(E
));
2179 Set_Is_Volatile
(Underlying_Type
(E
));
2181 Set_Treat_As_Volatile
(E
);
2182 Set_Treat_As_Volatile
(Underlying_Type
(E
));
2184 elsif K
= N_Object_Declaration
2185 or else (K
= N_Component_Declaration
2186 and then Original_Record_Component
(E
) = E
)
2188 if Rep_Item_Too_Late
(E
, N
) then
2192 if Prag_Id
/= Pragma_Volatile
then
2195 -- If the object declaration has an explicit initialization, a
2196 -- temporary may have to be created to hold the expression, to
2197 -- ensure that access to the object remain atomic.
2199 if Nkind
(Parent
(E
)) = N_Object_Declaration
2200 and then Present
(Expression
(Parent
(E
)))
2202 Set_Has_Delayed_Freeze
(E
);
2205 -- An interesting improvement here. If an object of type X
2206 -- is declared atomic, and the type X is not atomic, that's
2207 -- a pity, since it may not have appropriate alignment etc.
2208 -- We can rescue this in the special case where the object
2209 -- and type are in the same unit by just setting the type
2210 -- as atomic, so that the back end will process it as atomic.
2212 Utyp
:= Underlying_Type
(Etype
(E
));
2215 and then Sloc
(E
) > No_Location
2216 and then Sloc
(Utyp
) > No_Location
2218 Get_Source_File_Index
(Sloc
(E
)) =
2219 Get_Source_File_Index
(Sloc
(Underlying_Type
(Etype
(E
))))
2221 Set_Is_Atomic
(Underlying_Type
(Etype
(E
)));
2225 Set_Is_Volatile
(E
);
2226 Set_Treat_As_Volatile
(E
);
2230 ("inappropriate entity for pragma%", Arg1
);
2232 end Process_Atomic_Shared_Volatile
;
2234 -------------------------------------------
2235 -- Process_Compile_Time_Warning_Or_Error --
2236 -------------------------------------------
2238 procedure Process_Compile_Time_Warning_Or_Error
is
2239 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
2242 Check_Arg_Count
(2);
2243 Check_No_Identifiers
;
2244 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
2245 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
2247 if Compile_Time_Known_Value
(Arg1x
) then
2248 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
2250 Str
: constant String_Id
:=
2251 Strval
(Get_Pragma_Arg
(Arg2
));
2252 Len
: constant Int
:= String_Length
(Str
);
2257 Cent
: constant Entity_Id
:=
2258 Cunit_Entity
(Current_Sem_Unit
);
2260 Force
: constant Boolean :=
2261 Prag_Id
= Pragma_Compile_Time_Warning
2263 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
2264 and then (Ekind
(Cent
) /= E_Package
2265 or else not In_Private_Part
(Cent
));
2266 -- Set True if this is the warning case, and we are in the
2267 -- visible part of a package spec, or in a subprogram spec,
2268 -- in which case we want to force the client to see the
2269 -- warning, even though it is not in the main unit.
2272 -- Loop through segments of message separated by line
2273 -- feeds. We output these segments as separate messages
2274 -- with continuation marks for all but the first.
2279 Error_Msg_Strlen
:= 0;
2281 -- Loop to copy characters from argument to error
2282 -- message string buffer.
2285 exit when Ptr
> Len
;
2286 CC
:= Get_String_Char
(Str
, Ptr
);
2289 -- Ignore wide chars ??? else store character
2291 if In_Character_Range
(CC
) then
2292 C
:= Get_Character
(CC
);
2293 exit when C
= ASCII
.LF
;
2294 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
2295 Error_Msg_String
(Error_Msg_Strlen
) := C
;
2299 -- Here with one line ready to go
2301 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
2303 -- If this is a warning in a spec, then we want clients
2304 -- to see the warning, so mark the message with the
2305 -- special sequence !! to force the warning. In the case
2306 -- of a package spec, we do not force this if we are in
2307 -- the private part of the spec.
2310 if Cont
= False then
2311 Error_Msg_N
("<~!!", Arg1
);
2314 Error_Msg_N
("\<~!!", Arg1
);
2317 -- Error, rather than warning, or in a body, so we do not
2318 -- need to force visibility for client (error will be
2319 -- output in any case, and this is the situation in which
2320 -- we do not want a client to get a warning, since the
2321 -- warning is in the body or the spec private part.
2324 if Cont
= False then
2325 Error_Msg_N
("<~", Arg1
);
2328 Error_Msg_N
("\<~", Arg1
);
2332 exit when Ptr
> Len
;
2337 end Process_Compile_Time_Warning_Or_Error
;
2339 ------------------------
2340 -- Process_Convention --
2341 ------------------------
2343 procedure Process_Convention
2344 (C
: out Convention_Id
;
2350 Comp_Unit
: Unit_Number_Type
;
2352 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
2353 -- Set convention in entity E, and also flag that the entity has a
2354 -- convention pragma. If entity is for a private or incomplete type,
2355 -- also set convention and flag on underlying type. This procedure
2356 -- also deals with the special case of C_Pass_By_Copy convention.
2358 --------------------------------
2359 -- Set_Convention_From_Pragma --
2360 --------------------------------
2362 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
2364 -- Ada 2005 (AI-430): Check invalid attempt to change convention
2365 -- for an overridden dispatching operation. Technically this is
2366 -- an amendment and should only be done in Ada 2005 mode. However,
2367 -- this is clearly a mistake, since the problem that is addressed
2368 -- by this AI is that there is a clear gap in the RM!
2370 if Is_Dispatching_Operation
(E
)
2371 and then Present
(Overridden_Operation
(E
))
2372 and then C
/= Convention
(Overridden_Operation
(E
))
2375 ("cannot change convention for " &
2376 "overridden dispatching operation",
2380 -- Set the convention
2382 Set_Convention
(E
, C
);
2383 Set_Has_Convention_Pragma
(E
);
2385 if Is_Incomplete_Or_Private_Type
(E
) then
2386 Set_Convention
(Underlying_Type
(E
), C
);
2387 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
2390 -- A class-wide type should inherit the convention of
2391 -- the specific root type (although this isn't specified
2392 -- clearly by the RM).
2394 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
2395 Set_Convention
(Class_Wide_Type
(E
), C
);
2398 -- If the entity is a record type, then check for special case of
2399 -- C_Pass_By_Copy, which is treated the same as C except that the
2400 -- special record flag is set. This convention is only permitted
2401 -- on record types (see AI95-00131).
2403 if Cname
= Name_C_Pass_By_Copy
then
2404 if Is_Record_Type
(E
) then
2405 Set_C_Pass_By_Copy
(Base_Type
(E
));
2406 elsif Is_Incomplete_Or_Private_Type
(E
)
2407 and then Is_Record_Type
(Underlying_Type
(E
))
2409 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
2412 ("C_Pass_By_Copy convention allowed only for record type",
2417 -- If the entity is a derived boolean type, check for the
2418 -- special case of convention C, C++, or Fortran, where we
2419 -- consider any nonzero value to represent true.
2421 if Is_Discrete_Type
(E
)
2422 and then Root_Type
(Etype
(E
)) = Standard_Boolean
2428 C
= Convention_Fortran
)
2430 Set_Nonzero_Is_True
(Base_Type
(E
));
2432 end Set_Convention_From_Pragma
;
2434 -- Start of processing for Process_Convention
2437 Check_At_Least_N_Arguments
(2);
2438 Check_Optional_Identifier
(Arg1
, Name_Convention
);
2439 Check_Arg_Is_Identifier
(Arg1
);
2440 Cname
:= Chars
(Expression
(Arg1
));
2442 -- C_Pass_By_Copy is treated as a synonym for convention C
2443 -- (this is tested again below to set the critical flag)
2445 if Cname
= Name_C_Pass_By_Copy
then
2448 -- Otherwise we must have something in the standard convention list
2450 elsif Is_Convention_Name
(Cname
) then
2451 C
:= Get_Convention_Id
(Chars
(Expression
(Arg1
)));
2453 -- In DEC VMS, it seems that there is an undocumented feature that
2454 -- any unrecognized convention is treated as the default, which for
2455 -- us is convention C. It does not seem so terrible to do this
2456 -- unconditionally, silently in the VMS case, and with a warning
2457 -- in the non-VMS case.
2460 if Warn_On_Export_Import
and not OpenVMS_On_Target
then
2462 ("?unrecognized convention name, C assumed",
2469 Check_Optional_Identifier
(Arg2
, Name_Entity
);
2470 Check_Arg_Is_Local_Name
(Arg2
);
2472 Id
:= Expression
(Arg2
);
2475 if not Is_Entity_Name
(Id
) then
2476 Error_Pragma_Arg
("entity name required", Arg2
);
2481 -- Go to renamed subprogram if present, since convention applies to
2482 -- the actual renamed entity, not to the renaming entity. If the
2483 -- subprogram is inherited, go to parent subprogram.
2485 if Is_Subprogram
(E
)
2486 and then Present
(Alias
(E
))
2488 if Nkind
(Parent
(Declaration_Node
(E
))) =
2489 N_Subprogram_Renaming_Declaration
2491 if Scope
(E
) /= Scope
(Alias
(E
)) then
2493 ("cannot apply pragma% to non-local renaming&#", E
);
2497 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
2498 N_Private_Extension_Declaration
)
2499 and then Scope
(E
) = Scope
(Alias
(E
))
2505 -- Check that we are not applying this to a specless body
2507 if Is_Subprogram
(E
)
2508 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
2511 ("pragma% requires separate spec and must come before body");
2514 -- Check that we are not applying this to a named constant
2516 if Ekind
(E
) = E_Named_Integer
2518 Ekind
(E
) = E_Named_Real
2520 Error_Msg_Name_1
:= Pname
;
2522 ("cannot apply pragma% to named constant!",
2523 Get_Pragma_Arg
(Arg2
));
2525 ("\supply appropriate type for&!", Arg2
);
2528 if Ekind
(E
) = E_Enumeration_Literal
then
2529 Error_Pragma
("enumeration literal not allowed for pragma%");
2532 -- Check for rep item appearing too early or too late
2534 if Etype
(E
) = Any_Type
2535 or else Rep_Item_Too_Early
(E
, N
)
2539 E
:= Underlying_Type
(E
);
2542 if Rep_Item_Too_Late
(E
, N
) then
2546 if Has_Convention_Pragma
(E
) then
2548 ("at most one Convention/Export/Import pragma is allowed", Arg2
);
2550 elsif Convention
(E
) = Convention_Protected
2551 or else Ekind
(Scope
(E
)) = E_Protected_Type
2554 ("a protected operation cannot be given a different convention",
2558 -- For Intrinsic, a subprogram is required
2560 if C
= Convention_Intrinsic
2561 and then not Is_Subprogram
(E
)
2562 and then not Is_Generic_Subprogram
(E
)
2565 ("second argument of pragma% must be a subprogram", Arg2
);
2568 -- For Stdcall, a subprogram, variable or subprogram type is required
2570 if C
= Convention_Stdcall
2571 and then not Is_Subprogram
(E
)
2572 and then not Is_Generic_Subprogram
(E
)
2573 and then Ekind
(E
) /= E_Variable
2576 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
2579 ("second argument of pragma% must be subprogram (type)",
2583 if not Is_Subprogram
(E
)
2584 and then not Is_Generic_Subprogram
(E
)
2586 Set_Convention_From_Pragma
(E
);
2590 Check_First_Subtype
(Arg2
);
2591 Set_Convention_From_Pragma
(Base_Type
(E
));
2593 -- For subprograms, we must set the convention on the
2594 -- internally generated directly designated type as well.
2596 if Ekind
(E
) = E_Access_Subprogram_Type
then
2597 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
2601 -- For the subprogram case, set proper convention for all homonyms
2602 -- in same scope and the same declarative part, i.e. the same
2603 -- compilation unit.
2606 Comp_Unit
:= Get_Source_Unit
(E
);
2607 Set_Convention_From_Pragma
(E
);
2609 -- Treat a pragma Import as an implicit body, for GPS use
2611 if Prag_Id
= Pragma_Import
then
2612 Generate_Reference
(E
, Id
, 'b');
2618 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
2620 -- Do not set the pragma on inherited operations or on
2621 -- formal subprograms.
2623 if Comes_From_Source
(E1
)
2624 and then Comp_Unit
= Get_Source_Unit
(E1
)
2625 and then not Is_Formal_Subprogram
(E1
)
2626 and then Nkind
(Original_Node
(Parent
(E1
))) /=
2627 N_Full_Type_Declaration
2629 if Present
(Alias
(E1
))
2630 and then Scope
(E1
) /= Scope
(Alias
(E1
))
2633 ("cannot apply pragma% to non-local renaming&#", E1
);
2635 Set_Convention_From_Pragma
(E1
);
2637 if Prag_Id
= Pragma_Import
then
2638 Generate_Reference
(E
, Id
, 'b');
2643 end Process_Convention
;
2645 -----------------------------------------------------
2646 -- Process_Extended_Import_Export_Exception_Pragma --
2647 -----------------------------------------------------
2649 procedure Process_Extended_Import_Export_Exception_Pragma
2650 (Arg_Internal
: Node_Id
;
2651 Arg_External
: Node_Id
;
2659 if not OpenVMS_On_Target
then
2661 ("?pragma% ignored (applies only to Open'V'M'S)");
2664 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
2665 Def_Id
:= Entity
(Arg_Internal
);
2667 if Ekind
(Def_Id
) /= E_Exception
then
2669 ("pragma% must refer to declared exception", Arg_Internal
);
2672 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
2674 if Present
(Arg_Form
) then
2675 Check_Arg_Is_One_Of
(Arg_Form
, Name_Ada
, Name_VMS
);
2678 if Present
(Arg_Form
)
2679 and then Chars
(Arg_Form
) = Name_Ada
2683 Set_Is_VMS_Exception
(Def_Id
);
2684 Set_Exception_Code
(Def_Id
, No_Uint
);
2687 if Present
(Arg_Code
) then
2688 if not Is_VMS_Exception
(Def_Id
) then
2690 ("Code option for pragma% not allowed for Ada case",
2694 Check_Arg_Is_Static_Expression
(Arg_Code
, Any_Integer
);
2695 Code_Val
:= Expr_Value
(Arg_Code
);
2697 if not UI_Is_In_Int_Range
(Code_Val
) then
2699 ("Code option for pragma% must be in 32-bit range",
2703 Set_Exception_Code
(Def_Id
, Code_Val
);
2706 end Process_Extended_Import_Export_Exception_Pragma
;
2708 -------------------------------------------------
2709 -- Process_Extended_Import_Export_Internal_Arg --
2710 -------------------------------------------------
2712 procedure Process_Extended_Import_Export_Internal_Arg
2713 (Arg_Internal
: Node_Id
:= Empty
)
2716 if No
(Arg_Internal
) then
2717 Error_Pragma
("Internal parameter required for pragma%");
2720 if Nkind
(Arg_Internal
) = N_Identifier
then
2723 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
2724 and then (Prag_Id
= Pragma_Import_Function
2726 Prag_Id
= Pragma_Export_Function
)
2732 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
2735 Check_Arg_Is_Local_Name
(Arg_Internal
);
2736 end Process_Extended_Import_Export_Internal_Arg
;
2738 --------------------------------------------------
2739 -- Process_Extended_Import_Export_Object_Pragma --
2740 --------------------------------------------------
2742 procedure Process_Extended_Import_Export_Object_Pragma
2743 (Arg_Internal
: Node_Id
;
2744 Arg_External
: Node_Id
;
2750 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
2751 Def_Id
:= Entity
(Arg_Internal
);
2753 if Ekind
(Def_Id
) /= E_Constant
2754 and then Ekind
(Def_Id
) /= E_Variable
2757 ("pragma% must designate an object", Arg_Internal
);
2760 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
2762 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
2765 ("previous Common/Psect_Object applies, pragma % not permitted",
2769 if Rep_Item_Too_Late
(Def_Id
, N
) then
2773 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
2775 if Present
(Arg_Size
) then
2776 Check_Arg_Is_External_Name
(Arg_Size
);
2779 -- Export_Object case
2781 if Prag_Id
= Pragma_Export_Object
then
2782 if not Is_Library_Level_Entity
(Def_Id
) then
2784 ("argument for pragma% must be library level entity",
2788 if Ekind
(Current_Scope
) = E_Generic_Package
then
2789 Error_Pragma
("pragma& cannot appear in a generic unit");
2792 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
2794 ("exported object must have compile time known size",
2798 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
2800 ("?duplicate Export_Object pragma", N
);
2802 Set_Exported
(Def_Id
, Arg_Internal
);
2805 -- Import_Object case
2808 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
2810 ("cannot use pragma% for task/protected object",
2814 if Ekind
(Def_Id
) = E_Constant
then
2816 ("cannot import a constant", Arg_Internal
);
2819 if Warn_On_Export_Import
2820 and then Has_Discriminants
(Etype
(Def_Id
))
2823 ("imported value must be initialized?", Arg_Internal
);
2826 if Warn_On_Export_Import
2827 and then Is_Access_Type
(Etype
(Def_Id
))
2830 ("cannot import object of an access type?", Arg_Internal
);
2833 if Warn_On_Export_Import
2834 and then Is_Imported
(Def_Id
)
2837 ("?duplicate Import_Object pragma", N
);
2839 -- Check for explicit initialization present. Note that an
2840 -- initialization that generated by the code generator, e.g.
2841 -- for an access type, does not count here.
2843 elsif Present
(Expression
(Parent
(Def_Id
)))
2846 (Original_Node
(Expression
(Parent
(Def_Id
))))
2848 Error_Msg_Sloc
:= Sloc
(Def_Id
);
2850 ("imported entities cannot be initialized (RM B.1(24))",
2851 "\no initialization allowed for & declared#", Arg1
);
2853 Set_Imported
(Def_Id
);
2854 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
2857 end Process_Extended_Import_Export_Object_Pragma
;
2859 ------------------------------------------------------
2860 -- Process_Extended_Import_Export_Subprogram_Pragma --
2861 ------------------------------------------------------
2863 procedure Process_Extended_Import_Export_Subprogram_Pragma
2864 (Arg_Internal
: Node_Id
;
2865 Arg_External
: Node_Id
;
2866 Arg_Parameter_Types
: Node_Id
;
2867 Arg_Result_Type
: Node_Id
:= Empty
;
2868 Arg_Mechanism
: Node_Id
;
2869 Arg_Result_Mechanism
: Node_Id
:= Empty
;
2870 Arg_First_Optional_Parameter
: Node_Id
:= Empty
)
2876 Ambiguous
: Boolean;
2880 function Same_Base_Type
2882 Formal
: Entity_Id
) return Boolean;
2883 -- Determines if Ptype references the type of Formal. Note that
2884 -- only the base types need to match according to the spec. Ptype
2885 -- here is the argument from the pragma, which is either a type
2886 -- name, or an access attribute.
2888 --------------------
2889 -- Same_Base_Type --
2890 --------------------
2892 function Same_Base_Type
2894 Formal
: Entity_Id
) return Boolean
2896 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
2900 -- Case where pragma argument is typ'Access
2902 if Nkind
(Ptype
) = N_Attribute_Reference
2903 and then Attribute_Name
(Ptype
) = Name_Access
2905 Pref
:= Prefix
(Ptype
);
2908 if not Is_Entity_Name
(Pref
)
2909 or else Entity
(Pref
) = Any_Type
2914 -- We have a match if the corresponding argument is of an
2915 -- anonymous access type, and its designated type matches
2916 -- the type of the prefix of the access attribute
2918 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
2919 and then Base_Type
(Entity
(Pref
)) =
2920 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
2922 -- Case where pragma argument is a type name
2927 if not Is_Entity_Name
(Ptype
)
2928 or else Entity
(Ptype
) = Any_Type
2933 -- We have a match if the corresponding argument is of
2934 -- the type given in the pragma (comparing base types)
2936 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
2940 -- Start of processing for
2941 -- Process_Extended_Import_Export_Subprogram_Pragma
2944 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
2948 -- Loop through homonyms (overloadings) of the entity
2950 Hom_Id
:= Entity
(Arg_Internal
);
2951 while Present
(Hom_Id
) loop
2952 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
2954 -- We need a subprogram in the current scope
2956 if not Is_Subprogram
(Def_Id
)
2957 or else Scope
(Def_Id
) /= Current_Scope
2964 -- Pragma cannot apply to subprogram body
2966 if Is_Subprogram
(Def_Id
)
2967 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
2971 ("pragma% requires separate spec"
2972 & " and must come before body");
2975 -- Test result type if given, note that the result type
2976 -- parameter can only be present for the function cases.
2978 if Present
(Arg_Result_Type
)
2979 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
2983 elsif Etype
(Def_Id
) /= Standard_Void_Type
2985 (Pname
= Name_Export_Procedure
2987 Pname
= Name_Import_Procedure
)
2991 -- Test parameter types if given. Note that this parameter
2992 -- has not been analyzed (and must not be, since it is
2993 -- semantic nonsense), so we get it as the parser left it.
2995 elsif Present
(Arg_Parameter_Types
) then
2996 Check_Matching_Types
: declare
3001 Formal
:= First_Formal
(Def_Id
);
3003 if Nkind
(Arg_Parameter_Types
) = N_Null
then
3004 if Present
(Formal
) then
3008 -- A list of one type, e.g. (List) is parsed as
3009 -- a parenthesized expression.
3011 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
3012 and then Paren_Count
(Arg_Parameter_Types
) = 1
3015 or else Present
(Next_Formal
(Formal
))
3020 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
3023 -- A list of more than one type is parsed as a aggregate
3025 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
3026 and then Paren_Count
(Arg_Parameter_Types
) = 0
3028 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
3029 while Present
(Ptype
) or else Present
(Formal
) loop
3032 or else not Same_Base_Type
(Ptype
, Formal
)
3037 Next_Formal
(Formal
);
3042 -- Anything else is of the wrong form
3046 ("wrong form for Parameter_Types parameter",
3047 Arg_Parameter_Types
);
3049 end Check_Matching_Types
;
3052 -- Match is now False if the entry we found did not match
3053 -- either a supplied Parameter_Types or Result_Types argument
3059 -- Ambiguous case, the flag Ambiguous shows if we already
3060 -- detected this and output the initial messages.
3063 if not Ambiguous
then
3065 Error_Msg_Name_1
:= Pname
;
3067 ("pragma% does not uniquely identify subprogram!",
3069 Error_Msg_Sloc
:= Sloc
(Ent
);
3070 Error_Msg_N
("matching subprogram #!", N
);
3074 Error_Msg_Sloc
:= Sloc
(Def_Id
);
3075 Error_Msg_N
("matching subprogram #!", N
);
3080 Hom_Id
:= Homonym
(Hom_Id
);
3083 -- See if we found an entry
3086 if not Ambiguous
then
3087 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
3089 ("pragma% cannot be given for generic subprogram");
3092 ("pragma% does not identify local subprogram");
3099 -- Import pragmas must be be for imported entities
3101 if Prag_Id
= Pragma_Import_Function
3103 Prag_Id
= Pragma_Import_Procedure
3105 Prag_Id
= Pragma_Import_Valued_Procedure
3107 if not Is_Imported
(Ent
) then
3109 ("pragma Import or Interface must precede pragma%");
3112 -- Here we have the Export case which can set the entity as exported
3114 -- But does not do so if the specified external name is null, since
3115 -- that is taken as a signal in DEC Ada 83 (with which we want to be
3116 -- compatible) to request no external name.
3118 elsif Nkind
(Arg_External
) = N_String_Literal
3119 and then String_Length
(Strval
(Arg_External
)) = 0
3123 -- In all other cases, set entity as exported
3126 Set_Exported
(Ent
, Arg_Internal
);
3129 -- Special processing for Valued_Procedure cases
3131 if Prag_Id
= Pragma_Import_Valued_Procedure
3133 Prag_Id
= Pragma_Export_Valued_Procedure
3135 Formal
:= First_Formal
(Ent
);
3139 ("at least one parameter required for pragma%");
3141 elsif Ekind
(Formal
) /= E_Out_Parameter
then
3143 ("first parameter must have mode out for pragma%");
3146 Set_Is_Valued_Procedure
(Ent
);
3150 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
3152 -- Process Result_Mechanism argument if present. We have already
3153 -- checked that this is only allowed for the function case.
3155 if Present
(Arg_Result_Mechanism
) then
3156 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
3159 -- Process Mechanism parameter if present. Note that this parameter
3160 -- is not analyzed, and must not be analyzed since it is semantic
3161 -- nonsense, so we get it in exactly as the parser left it.
3163 if Present
(Arg_Mechanism
) then
3171 -- A single mechanism association without a formal parameter
3172 -- name is parsed as a parenthesized expression. All other
3173 -- cases are parsed as aggregates, so we rewrite the single
3174 -- parameter case as an aggregate for consistency.
3176 if Nkind
(Arg_Mechanism
) /= N_Aggregate
3177 and then Paren_Count
(Arg_Mechanism
) = 1
3179 Rewrite
(Arg_Mechanism
,
3180 Make_Aggregate
(Sloc
(Arg_Mechanism
),
3181 Expressions
=> New_List
(
3182 Relocate_Node
(Arg_Mechanism
))));
3185 -- Case of only mechanism name given, applies to all formals
3187 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
3188 Formal
:= First_Formal
(Ent
);
3189 while Present
(Formal
) loop
3190 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
3191 Next_Formal
(Formal
);
3194 -- Case of list of mechanism associations given
3197 if Null_Record_Present
(Arg_Mechanism
) then
3199 ("inappropriate form for Mechanism parameter",
3203 -- Deal with positional ones first
3205 Formal
:= First_Formal
(Ent
);
3207 if Present
(Expressions
(Arg_Mechanism
)) then
3208 Mname
:= First
(Expressions
(Arg_Mechanism
));
3209 while Present
(Mname
) loop
3212 ("too many mechanism associations", Mname
);
3215 Set_Mechanism_Value
(Formal
, Mname
);
3216 Next_Formal
(Formal
);
3221 -- Deal with named entries
3223 if Present
(Component_Associations
(Arg_Mechanism
)) then
3224 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
3225 while Present
(Massoc
) loop
3226 Choice
:= First
(Choices
(Massoc
));
3228 if Nkind
(Choice
) /= N_Identifier
3229 or else Present
(Next
(Choice
))
3232 ("incorrect form for mechanism association",
3236 Formal
:= First_Formal
(Ent
);
3240 ("parameter name & not present", Choice
);
3243 if Chars
(Choice
) = Chars
(Formal
) then
3245 (Formal
, Expression
(Massoc
));
3247 -- Set entity on identifier for ASIS
3249 Set_Entity
(Choice
, Formal
);
3254 Next_Formal
(Formal
);
3264 -- Process First_Optional_Parameter argument if present. We have
3265 -- already checked that this is only allowed for the Import case.
3267 if Present
(Arg_First_Optional_Parameter
) then
3268 if Nkind
(Arg_First_Optional_Parameter
) /= N_Identifier
then
3270 ("first optional parameter must be formal parameter name",
3271 Arg_First_Optional_Parameter
);
3274 Formal
:= First_Formal
(Ent
);
3278 ("specified formal parameter& not found",
3279 Arg_First_Optional_Parameter
);
3282 exit when Chars
(Formal
) =
3283 Chars
(Arg_First_Optional_Parameter
);
3285 Next_Formal
(Formal
);
3288 Set_First_Optional_Parameter
(Ent
, Formal
);
3290 -- Check specified and all remaining formals have right form
3292 while Present
(Formal
) loop
3293 if Ekind
(Formal
) /= E_In_Parameter
then
3295 ("optional formal& is not of mode in!",
3296 Arg_First_Optional_Parameter
, Formal
);
3299 Dval
:= Default_Value
(Formal
);
3303 ("optional formal& does not have default value!",
3304 Arg_First_Optional_Parameter
, Formal
);
3306 elsif Compile_Time_Known_Value_Or_Aggr
(Dval
) then
3311 ("default value for optional formal& is non-static!",
3312 Arg_First_Optional_Parameter
, Formal
);
3316 Set_Is_Optional_Parameter
(Formal
);
3317 Next_Formal
(Formal
);
3320 end Process_Extended_Import_Export_Subprogram_Pragma
;
3322 --------------------------
3323 -- Process_Generic_List --
3324 --------------------------
3326 procedure Process_Generic_List
is
3331 Check_No_Identifiers
;
3332 Check_At_Least_N_Arguments
(1);
3335 while Present
(Arg
) loop
3336 Exp
:= Expression
(Arg
);
3339 if not Is_Entity_Name
(Exp
)
3341 (not Is_Generic_Instance
(Entity
(Exp
))
3343 not Is_Generic_Unit
(Entity
(Exp
)))
3346 ("pragma% argument must be name of generic unit/instance",
3352 end Process_Generic_List
;
3354 ---------------------------------
3355 -- Process_Import_Or_Interface --
3356 ---------------------------------
3358 procedure Process_Import_Or_Interface
is
3364 Process_Convention
(C
, Def_Id
);
3365 Kill_Size_Check_Code
(Def_Id
);
3366 Note_Possible_Modification
(Expression
(Arg2
), Sure
=> False);
3368 if Ekind
(Def_Id
) = E_Variable
3370 Ekind
(Def_Id
) = E_Constant
3372 -- We do not permit Import to apply to a renaming declaration
3374 if Present
(Renamed_Object
(Def_Id
)) then
3376 ("pragma% not allowed for object renaming", Arg2
);
3378 -- User initialization is not allowed for imported object, but
3379 -- the object declaration may contain a default initialization,
3380 -- that will be discarded. Note that an explicit initialization
3381 -- only counts if it comes from source, otherwise it is simply
3382 -- the code generator making an implicit initialization explicit.
3384 elsif Present
(Expression
(Parent
(Def_Id
)))
3385 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
3387 Error_Msg_Sloc
:= Sloc
(Def_Id
);
3389 ("no initialization allowed for declaration of& #",
3390 "\imported entities cannot be initialized (RM B.1(24))",
3394 Set_Imported
(Def_Id
);
3395 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
3397 -- Note that we do not set Is_Public here. That's because we
3398 -- only want to set if if there is no address clause, and we
3399 -- don't know that yet, so we delay that processing till
3402 -- pragma Import completes deferred constants
3404 if Ekind
(Def_Id
) = E_Constant
then
3405 Set_Has_Completion
(Def_Id
);
3408 -- It is not possible to import a constant of an unconstrained
3409 -- array type (e.g. string) because there is no simple way to
3410 -- write a meaningful subtype for it.
3412 if Is_Array_Type
(Etype
(Def_Id
))
3413 and then not Is_Constrained
(Etype
(Def_Id
))
3416 ("imported constant& must have a constrained subtype",
3421 elsif Is_Subprogram
(Def_Id
)
3422 or else Is_Generic_Subprogram
(Def_Id
)
3424 -- If the name is overloaded, pragma applies to all of the
3425 -- denoted entities in the same declarative part.
3428 while Present
(Hom_Id
) loop
3429 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
3431 -- Ignore inherited subprograms because the pragma will
3432 -- apply to the parent operation, which is the one called.
3434 if Is_Overloadable
(Def_Id
)
3435 and then Present
(Alias
(Def_Id
))
3439 -- If it is not a subprogram, it must be in an outer
3440 -- scope and pragma does not apply.
3442 elsif not Is_Subprogram
(Def_Id
)
3443 and then not Is_Generic_Subprogram
(Def_Id
)
3447 -- Verify that the homonym is in the same declarative
3448 -- part (not just the same scope).
3450 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
3451 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
3456 Set_Imported
(Def_Id
);
3458 -- Special processing for Convention_Intrinsic
3460 if C
= Convention_Intrinsic
then
3462 -- Link_Name argument not allowed for intrinsic
3465 and then Chars
(Arg3
) = Name_Link_Name
3470 if Present
(Arg4
) then
3472 ("Link_Name argument not allowed for " &
3477 Set_Is_Intrinsic_Subprogram
(Def_Id
);
3479 -- If no external name is present, then check that
3480 -- this is a valid intrinsic subprogram. If an external
3481 -- name is present, then this is handled by the back end.
3484 Check_Intrinsic_Subprogram
(Def_Id
, Expression
(Arg2
));
3488 -- All interfaced procedures need an external symbol
3489 -- created for them since they are always referenced
3490 -- from another object file.
3492 Set_Is_Public
(Def_Id
);
3494 -- Verify that the subprogram does not have a completion
3495 -- through a renaming declaration. For other completions
3496 -- the pragma appears as a too late representation.
3499 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
3503 and then Nkind
(Decl
) = N_Subprogram_Declaration
3504 and then Present
(Corresponding_Body
(Decl
))
3505 and then Nkind
(Unit_Declaration_Node
3506 (Corresponding_Body
(Decl
))) =
3507 N_Subprogram_Renaming_Declaration
3509 Error_Msg_Sloc
:= Sloc
(Def_Id
);
3511 ("cannot import&, renaming already provided for " &
3512 "declaration #", N
, Def_Id
);
3516 Set_Has_Completion
(Def_Id
);
3517 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
3520 if Is_Compilation_Unit
(Hom_Id
) then
3522 -- Its possible homonyms are not affected by the pragma.
3523 -- Such homonyms might be present in the context of other
3524 -- units being compiled.
3529 Hom_Id
:= Homonym
(Hom_Id
);
3533 -- When the convention is Java or CIL, we also allow Import to be
3534 -- given for packages, generic packages, exceptions, and record
3537 elsif (C
= Convention_Java
or else C
= Convention_CIL
)
3539 (Is_Package_Or_Generic_Package
(Def_Id
)
3540 or else Ekind
(Def_Id
) = E_Exception
3541 or else Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
)
3543 Set_Imported
(Def_Id
);
3544 Set_Is_Public
(Def_Id
);
3545 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
3547 -- Import a CPP class
3549 elsif Is_Record_Type
(Def_Id
)
3550 and then C
= Convention_CPP
3552 if not Is_Tagged_Type
(Def_Id
) then
3553 Error_Msg_Sloc
:= Sloc
(Def_Id
);
3554 Error_Pragma_Arg
("imported 'C'P'P type must be tagged", Arg2
);
3557 -- Types treated as CPP classes are treated as limited, but we
3558 -- don't require them to be declared this way. A warning is
3559 -- issued to encourage the user to declare them as limited.
3560 -- This is not an error, for compatibility reasons, because
3561 -- these types have been supported this way for some time.
3563 if not Is_Limited_Type
(Def_Id
) then
3565 ("imported 'C'P'P type should be " &
3566 "explicitly declared limited?",
3567 Get_Pragma_Arg
(Arg2
));
3569 ("\type will be considered limited",
3570 Get_Pragma_Arg
(Arg2
));
3573 Set_Is_CPP_Class
(Def_Id
);
3574 Set_Is_Limited_Record
(Def_Id
);
3579 ("second argument of pragma% must be object or subprogram",
3583 -- If this pragma applies to a compilation unit, then the unit,
3584 -- which is a subprogram, does not require (or allow) a body.
3585 -- We also do not need to elaborate imported procedures.
3587 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
3589 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
3591 Set_Body_Required
(Cunit
, False);
3594 end Process_Import_Or_Interface
;
3596 --------------------
3597 -- Process_Inline --
3598 --------------------
3600 procedure Process_Inline
(Active
: Boolean) is
3606 Effective
: Boolean := False;
3608 procedure Make_Inline
(Subp
: Entity_Id
);
3609 -- Subp is the defining unit name of the subprogram
3610 -- declaration. Set the flag, as well as the flag in the
3611 -- corresponding body, if there is one present.
3613 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
3614 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
3615 -- Has_Pragma_Inline_Always for the Inline_Always case.
3617 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
3618 -- Returns True if it can be determined at this stage that inlining
3619 -- is not possible, for example if the body is available and contains
3620 -- exception handlers, we prevent inlining, since otherwise we can
3621 -- get undefined symbols at link time. This function also emits a
3622 -- warning if front-end inlining is enabled and the pragma appears
3625 -- ??? is business with link symbols still valid, or does it relate
3626 -- to front end ZCX which is being phased out ???
3628 ---------------------------
3629 -- Inlining_Not_Possible --
3630 ---------------------------
3632 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
3633 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
3637 if Nkind
(Decl
) = N_Subprogram_Body
then
3638 Stats
:= Handled_Statement_Sequence
(Decl
);
3639 return Present
(Exception_Handlers
(Stats
))
3640 or else Present
(At_End_Proc
(Stats
));
3642 elsif Nkind
(Decl
) = N_Subprogram_Declaration
3643 and then Present
(Corresponding_Body
(Decl
))
3645 if Front_End_Inlining
3646 and then Analyzed
(Corresponding_Body
(Decl
))
3648 Error_Msg_N
("pragma appears too late, ignored?", N
);
3651 -- If the subprogram is a renaming as body, the body is
3652 -- just a call to the renamed subprogram, and inlining is
3653 -- trivially possible.
3656 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
3657 N_Subprogram_Renaming_Declaration
3663 Handled_Statement_Sequence
3664 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
3667 Present
(Exception_Handlers
(Stats
))
3668 or else Present
(At_End_Proc
(Stats
));
3672 -- If body is not available, assume the best, the check is
3673 -- performed again when compiling enclosing package bodies.
3677 end Inlining_Not_Possible
;
3683 procedure Make_Inline
(Subp
: Entity_Id
) is
3684 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
3685 Inner_Subp
: Entity_Id
:= Subp
;
3688 -- Ignore if bad type, avoid cascaded error
3690 if Etype
(Subp
) = Any_Type
then
3694 -- Ignore if all inlining is suppressed
3696 elsif Suppress_All_Inlining
then
3700 -- If inlining is not possible, for now do not treat as an error
3702 elsif Inlining_Not_Possible
(Subp
) then
3706 -- Here we have a candidate for inlining, but we must exclude
3707 -- derived operations. Otherwise we would end up trying to inline
3708 -- a phantom declaration, and the result would be to drag in a
3709 -- body which has no direct inlining associated with it. That
3710 -- would not only be inefficient but would also result in the
3711 -- backend doing cross-unit inlining in cases where it was
3712 -- definitely inappropriate to do so.
3714 -- However, a simple Comes_From_Source test is insufficient, since
3715 -- we do want to allow inlining of generic instances which also do
3716 -- not come from source. We also need to recognize specs
3717 -- generated by the front-end for bodies that carry the pragma.
3718 -- Finally, predefined operators do not come from source but are
3719 -- not inlineable either.
3721 elsif Is_Generic_Instance
(Subp
)
3722 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
3726 elsif not Comes_From_Source
(Subp
)
3727 and then Scope
(Subp
) /= Standard_Standard
3733 -- The referenced entity must either be the enclosing entity,
3734 -- or an entity declared within the current open scope.
3736 if Present
(Scope
(Subp
))
3737 and then Scope
(Subp
) /= Current_Scope
3738 and then Subp
/= Current_Scope
3741 ("argument of% must be entity in current scope", Assoc
);
3745 -- Processing for procedure, operator or function.
3746 -- If subprogram is aliased (as for an instance) indicate
3747 -- that the renamed entity (if declared in the same unit)
3750 if Is_Subprogram
(Subp
) then
3751 while Present
(Alias
(Inner_Subp
)) loop
3752 Inner_Subp
:= Alias
(Inner_Subp
);
3755 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
3756 Set_Inline_Flags
(Inner_Subp
);
3758 Decl
:= Parent
(Parent
(Inner_Subp
));
3760 if Nkind
(Decl
) = N_Subprogram_Declaration
3761 and then Present
(Corresponding_Body
(Decl
))
3763 Set_Inline_Flags
(Corresponding_Body
(Decl
));
3765 elsif Is_Generic_Instance
(Subp
) then
3767 -- Indicate that the body needs to be created for
3768 -- inlining subsequent calls. The instantiation
3769 -- node follows the declaration of the wrapper
3770 -- package created for it.
3772 if Scope
(Subp
) /= Standard_Standard
3774 Need_Subprogram_Instance_Body
3775 (Next
(Unit_Declaration_Node
(Scope
(Alias
(Subp
)))),
3785 -- For a generic subprogram set flag as well, for use at
3786 -- the point of instantiation, to determine whether the
3787 -- body should be generated.
3789 elsif Is_Generic_Subprogram
(Subp
) then
3790 Set_Inline_Flags
(Subp
);
3793 -- Literals are by definition inlined
3795 elsif Kind
= E_Enumeration_Literal
then
3798 -- Anything else is an error
3802 ("expect subprogram name for pragma%", Assoc
);
3806 ----------------------
3807 -- Set_Inline_Flags --
3808 ----------------------
3810 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
3813 Set_Is_Inlined
(Subp
, True);
3816 if not Has_Pragma_Inline
(Subp
) then
3817 Set_Has_Pragma_Inline
(Subp
);
3821 if Prag_Id
= Pragma_Inline_Always
then
3822 Set_Has_Pragma_Inline_Always
(Subp
);
3824 end Set_Inline_Flags
;
3826 -- Start of processing for Process_Inline
3829 Check_No_Identifiers
;
3830 Check_At_Least_N_Arguments
(1);
3833 Inline_Processing_Required
:= True;
3837 while Present
(Assoc
) loop
3838 Subp_Id
:= Expression
(Assoc
);
3842 if Is_Entity_Name
(Subp_Id
) then
3843 Subp
:= Entity
(Subp_Id
);
3845 if Subp
= Any_Id
then
3847 -- If previous error, avoid cascaded errors
3855 while Present
(Homonym
(Subp
))
3856 and then Scope
(Homonym
(Subp
)) = Current_Scope
3858 Make_Inline
(Homonym
(Subp
));
3859 Subp
:= Homonym
(Subp
);
3866 ("inappropriate argument for pragma%", Assoc
);
3869 and then Warn_On_Redundant_Constructs
3870 and then not Suppress_All_Inlining
3872 if Inlining_Not_Possible
(Subp
) then
3874 ("pragma Inline for& is ignored?", N
, Entity
(Subp_Id
));
3877 ("pragma Inline for& is redundant?", N
, Entity
(Subp_Id
));
3885 ----------------------------
3886 -- Process_Interface_Name --
3887 ----------------------------
3889 procedure Process_Interface_Name
3890 (Subprogram_Def
: Entity_Id
;
3896 String_Val
: String_Id
;
3898 procedure Check_Form_Of_Interface_Name
3900 Ext_Name_Case
: Boolean);
3901 -- SN is a string literal node for an interface name. This routine
3902 -- performs some minimal checks that the name is reasonable. In
3903 -- particular that no spaces or other obviously incorrect characters
3904 -- appear. This is only a warning, since any characters are allowed.
3905 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
3907 ----------------------------------
3908 -- Check_Form_Of_Interface_Name --
3909 ----------------------------------
3911 procedure Check_Form_Of_Interface_Name
3913 Ext_Name_Case
: Boolean)
3915 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
3916 SL
: constant Nat
:= String_Length
(S
);
3921 Error_Msg_N
("interface name cannot be null string", SN
);
3924 for J
in 1 .. SL
loop
3925 C
:= Get_String_Char
(S
, J
);
3927 -- Look for dubious character and issue unconditional warning.
3928 -- Definitely dubious if not in character range.
3930 if not In_Character_Range
(C
)
3932 -- For all cases except external names on CLI target,
3933 -- commas, spaces and slashes are dubious (in CLI, we use
3934 -- spaces and commas in external names to specify assembly
3935 -- version and public key).
3937 or else ((not Ext_Name_Case
or else VM_Target
/= CLI_Target
)
3938 and then (Get_Character
(C
) = ' '
3940 Get_Character
(C
) = ','
3942 Get_Character
(C
) = '/'
3944 Get_Character
(C
) = '\'))
3947 ("?interface name contains illegal character",
3948 Sloc
(SN
) + Source_Ptr
(J
));
3951 end Check_Form_Of_Interface_Name
;
3953 -- Start of processing for Process_Interface_Name
3956 if No
(Link_Arg
) then
3957 if No
(Ext_Arg
) then
3958 if VM_Target
= CLI_Target
3959 and then Ekind
(Subprogram_Def
) = E_Package
3960 and then Nkind
(Parent
(Subprogram_Def
)) =
3961 N_Package_Specification
3962 and then Present
(Generic_Parent
(Parent
(Subprogram_Def
)))
3967 (Generic_Parent
(Parent
(Subprogram_Def
))));
3972 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
3974 Link_Nam
:= Expression
(Ext_Arg
);
3977 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
3978 Ext_Nam
:= Expression
(Ext_Arg
);
3983 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
3984 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
3985 Ext_Nam
:= Expression
(Ext_Arg
);
3986 Link_Nam
:= Expression
(Link_Arg
);
3989 -- Check expressions for external name and link name are static
3991 if Present
(Ext_Nam
) then
3992 Check_Arg_Is_Static_Expression
(Ext_Nam
, Standard_String
);
3993 Check_Form_Of_Interface_Name
(Ext_Nam
, Ext_Name_Case
=> True);
3995 -- Verify that external name is not the name of a local entity,
3996 -- which would hide the imported one and could lead to run-time
3997 -- surprises. The problem can only arise for entities declared in
3998 -- a package body (otherwise the external name is fully qualified
3999 -- and will not conflict).
4007 if Prag_Id
= Pragma_Import
then
4008 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
4010 E
:= Entity_Id
(Get_Name_Table_Info
(Nam
));
4012 if Nam
/= Chars
(Subprogram_Def
)
4013 and then Present
(E
)
4014 and then not Is_Overloadable
(E
)
4015 and then Is_Immediately_Visible
(E
)
4016 and then not Is_Imported
(E
)
4017 and then Ekind
(Scope
(E
)) = E_Package
4020 while Present
(Par
) loop
4021 if Nkind
(Par
) = N_Package_Body
then
4022 Error_Msg_Sloc
:= Sloc
(E
);
4024 ("imported entity is hidden by & declared#",
4029 Par
:= Parent
(Par
);
4036 if Present
(Link_Nam
) then
4037 Check_Arg_Is_Static_Expression
(Link_Nam
, Standard_String
);
4038 Check_Form_Of_Interface_Name
(Link_Nam
, Ext_Name_Case
=> False);
4041 -- If there is no link name, just set the external name
4043 if No
(Link_Nam
) then
4044 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
4046 -- For the Link_Name case, the given literal is preceded by an
4047 -- asterisk, which indicates to GCC that the given name should
4048 -- be taken literally, and in particular that no prepending of
4049 -- underlines should occur, even in systems where this is the
4055 if VM_Target
= No_VM
then
4056 Store_String_Char
(Get_Char_Code
('*'));
4059 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
4060 Store_String_Chars
(String_Val
);
4062 Make_String_Literal
(Sloc
(Link_Nam
),
4063 Strval
=> End_String
);
4066 Set_Encoded_Interface_Name
4067 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
4068 Check_Duplicated_Export_Name
(Link_Nam
);
4069 end Process_Interface_Name
;
4071 -----------------------------------------
4072 -- Process_Interrupt_Or_Attach_Handler --
4073 -----------------------------------------
4075 procedure Process_Interrupt_Or_Attach_Handler
is
4076 Arg1_X
: constant Node_Id
:= Expression
(Arg1
);
4077 Handler_Proc
: constant Entity_Id
:= Entity
(Arg1_X
);
4078 Proc_Scope
: constant Entity_Id
:= Scope
(Handler_Proc
);
4081 Set_Is_Interrupt_Handler
(Handler_Proc
);
4083 -- If the pragma is not associated with a handler procedure
4084 -- within a protected type, then it must be for a nonprotected
4085 -- procedure for the AAMP target, in which case we don't
4086 -- associate a representation item with the procedure's scope.
4088 if Ekind
(Proc_Scope
) = E_Protected_Type
then
4089 if Prag_Id
= Pragma_Interrupt_Handler
4091 Prag_Id
= Pragma_Attach_Handler
4093 Record_Rep_Item
(Proc_Scope
, N
);
4096 end Process_Interrupt_Or_Attach_Handler
;
4098 --------------------------------------------------
4099 -- Process_Restrictions_Or_Restriction_Warnings --
4100 --------------------------------------------------
4102 -- Note: some of the simple identifier cases were handled in par-prag,
4103 -- but it is harmless (and more straightforward) to simply handle all
4104 -- cases here, even if it means we repeat a bit of work in some cases.
4106 procedure Process_Restrictions_Or_Restriction_Warnings
4110 R_Id
: Restriction_Id
;
4115 procedure Check_Unit_Name
(N
: Node_Id
);
4116 -- Checks unit name parameter for No_Dependence. Returns if it has
4117 -- an appropriate form, otherwise raises pragma argument error.
4119 ---------------------
4120 -- Check_Unit_Name --
4121 ---------------------
4123 procedure Check_Unit_Name
(N
: Node_Id
) is
4125 if Nkind
(N
) = N_Selected_Component
then
4126 Check_Unit_Name
(Prefix
(N
));
4127 Check_Unit_Name
(Selector_Name
(N
));
4129 elsif Nkind
(N
) = N_Identifier
then
4134 ("wrong form for unit name for No_Dependence", N
);
4136 end Check_Unit_Name
;
4138 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
4141 Check_Ada_83_Warning
;
4142 Check_At_Least_N_Arguments
(1);
4143 Check_Valid_Configuration_Pragma
;
4146 while Present
(Arg
) loop
4148 Expr
:= Expression
(Arg
);
4150 -- Case of no restriction identifier present
4152 if Id
= No_Name
then
4153 if Nkind
(Expr
) /= N_Identifier
then
4155 ("invalid form for restriction", Arg
);
4160 (Process_Restriction_Synonyms
(Expr
));
4162 if R_Id
not in All_Boolean_Restrictions
then
4163 Error_Msg_Name_1
:= Pname
;
4165 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
4167 -- Check for possible misspelling
4169 for J
in Restriction_Id
loop
4171 Rnm
: constant String := Restriction_Id
'Image (J
);
4174 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
4175 Name_Len
:= Rnm
'Length;
4176 Set_Casing
(All_Lower_Case
);
4178 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
4180 (Identifier_Casing
(Current_Source_File
));
4181 Error_Msg_String
(1 .. Rnm
'Length) :=
4182 Name_Buffer
(1 .. Name_Len
);
4183 Error_Msg_Strlen
:= Rnm
'Length;
4185 ("\possible misspelling of ""~""",
4186 Get_Pragma_Arg
(Arg
));
4195 if Implementation_Restriction
(R_Id
) then
4196 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
4199 -- If this is a warning, then set the warning unless we already
4200 -- have a real restriction active (we never want a warning to
4201 -- override a real restriction).
4204 if not Restriction_Active
(R_Id
) then
4205 Set_Restriction
(R_Id
, N
);
4206 Restriction_Warnings
(R_Id
) := True;
4209 -- If real restriction case, then set it and make sure that the
4210 -- restriction warning flag is off, since a real restriction
4211 -- always overrides a warning.
4214 Set_Restriction
(R_Id
, N
);
4215 Restriction_Warnings
(R_Id
) := False;
4218 -- A very special case that must be processed here: pragma
4219 -- Restrictions (No_Exceptions) turns off all run-time
4220 -- checking. This is a bit dubious in terms of the formal
4221 -- language definition, but it is what is intended by RM
4222 -- H.4(12). Restriction_Warnings never affects generated code
4223 -- so this is done only in the real restriction case.
4225 if R_Id
= No_Exceptions
and then not Warn
then
4226 Scope_Suppress
:= (others => True);
4229 -- Case of No_Dependence => unit-name. Note that the parser
4230 -- already made the necessary entry in the No_Dependence table.
4232 elsif Id
= Name_No_Dependence
then
4233 Check_Unit_Name
(Expr
);
4235 -- All other cases of restriction identifier present
4238 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
4239 Analyze_And_Resolve
(Expr
, Any_Integer
);
4241 if R_Id
not in All_Parameter_Restrictions
then
4243 ("invalid restriction parameter identifier", Arg
);
4245 elsif not Is_OK_Static_Expression
(Expr
) then
4246 Flag_Non_Static_Expr
4247 ("value must be static expression!", Expr
);
4250 elsif not Is_Integer_Type
(Etype
(Expr
))
4251 or else Expr_Value
(Expr
) < 0
4254 ("value must be non-negative integer", Arg
);
4257 -- Restriction pragma is active
4259 Val
:= Expr_Value
(Expr
);
4261 if not UI_Is_In_Int_Range
(Val
) then
4263 ("pragma ignored, value too large?", Arg
);
4266 -- Warning case. If the real restriction is active, then we
4267 -- ignore the request, since warning never overrides a real
4268 -- restriction. Otherwise we set the proper warning. Note that
4269 -- this circuit sets the warning again if it is already set,
4270 -- which is what we want, since the constant may have changed.
4273 if not Restriction_Active
(R_Id
) then
4275 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
4276 Restriction_Warnings
(R_Id
) := True;
4279 -- Real restriction case, set restriction and make sure warning
4280 -- flag is off since real restriction always overrides warning.
4283 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
4284 Restriction_Warnings
(R_Id
) := False;
4290 end Process_Restrictions_Or_Restriction_Warnings
;
4292 ---------------------------------
4293 -- Process_Suppress_Unsuppress --
4294 ---------------------------------
4296 -- Note: this procedure makes entries in the check suppress data
4297 -- structures managed by Sem. See spec of package Sem for full
4298 -- details on how we handle recording of check suppression.
4300 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
4305 In_Package_Spec
: constant Boolean :=
4306 Is_Package_Or_Generic_Package
(Current_Scope
)
4307 and then not In_Package_Body
(Current_Scope
);
4309 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
4310 -- Used to suppress a single check on the given entity
4312 --------------------------------
4313 -- Suppress_Unsuppress_Echeck --
4314 --------------------------------
4316 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
4318 Set_Checks_May_Be_Suppressed
(E
);
4320 if In_Package_Spec
then
4321 Push_Global_Suppress_Stack_Entry
4324 Suppress
=> Suppress_Case
);
4327 Push_Local_Suppress_Stack_Entry
4330 Suppress
=> Suppress_Case
);
4333 -- If this is a first subtype, and the base type is distinct,
4334 -- then also set the suppress flags on the base type.
4336 if Is_First_Subtype
(E
)
4337 and then Etype
(E
) /= E
4339 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
4341 end Suppress_Unsuppress_Echeck
;
4343 -- Start of processing for Process_Suppress_Unsuppress
4346 -- Suppress/Unsuppress can appear as a configuration pragma,
4347 -- or in a declarative part or a package spec (RM 11.5(5))
4349 if not Is_Configuration_Pragma
then
4350 Check_Is_In_Decl_Part_Or_Package_Spec
;
4353 Check_At_Least_N_Arguments
(1);
4354 Check_At_Most_N_Arguments
(2);
4355 Check_No_Identifier
(Arg1
);
4356 Check_Arg_Is_Identifier
(Arg1
);
4358 C
:= Get_Check_Id
(Chars
(Expression
(Arg1
)));
4360 if C
= No_Check_Id
then
4362 ("argument of pragma% is not valid check name", Arg1
);
4365 if not Suppress_Case
4366 and then (C
= All_Checks
or else C
= Overflow_Check
)
4368 Opt
.Overflow_Checks_Unsuppressed
:= True;
4371 if Arg_Count
= 1 then
4373 -- Make an entry in the local scope suppress table. This is the
4374 -- table that directly shows the current value of the scope
4375 -- suppress check for any check id value.
4377 if C
= All_Checks
then
4379 -- For All_Checks, we set all specific predefined checks with
4380 -- the exception of Elaboration_Check, which is handled
4381 -- specially because of not wanting All_Checks to have the
4382 -- effect of deactivating static elaboration order processing.
4384 for J
in Scope_Suppress
'Range loop
4385 if J
/= Elaboration_Check
then
4386 Scope_Suppress
(J
) := Suppress_Case
;
4390 -- If not All_Checks, and predefined check, then set appropriate
4391 -- scope entry. Note that we will set Elaboration_Check if this
4392 -- is explicitly specified.
4394 elsif C
in Predefined_Check_Id
then
4395 Scope_Suppress
(C
) := Suppress_Case
;
4398 -- Also make an entry in the Local_Entity_Suppress table
4400 Push_Local_Suppress_Stack_Entry
4403 Suppress
=> Suppress_Case
);
4405 -- Case of two arguments present, where the check is suppressed for
4406 -- a specified entity (given as the second argument of the pragma)
4409 Check_Optional_Identifier
(Arg2
, Name_On
);
4410 E_Id
:= Expression
(Arg2
);
4413 if not Is_Entity_Name
(E_Id
) then
4415 ("second argument of pragma% must be entity name", Arg2
);
4424 -- Enforce RM 11.5(7) which requires that for a pragma that
4425 -- appears within a package spec, the named entity must be
4426 -- within the package spec. We allow the package name itself
4427 -- to be mentioned since that makes sense, although it is not
4428 -- strictly allowed by 11.5(7).
4431 and then E
/= Current_Scope
4432 and then Scope
(E
) /= Current_Scope
4435 ("entity in pragma% is not in package spec (RM 11.5(7))",
4439 -- Loop through homonyms. As noted below, in the case of a package
4440 -- spec, only homonyms within the package spec are considered.
4443 Suppress_Unsuppress_Echeck
(E
, C
);
4445 if Is_Generic_Instance
(E
)
4446 and then Is_Subprogram
(E
)
4447 and then Present
(Alias
(E
))
4449 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
4452 -- Move to next homonym
4457 -- If we are within a package specification, the
4458 -- pragma only applies to homonyms in the same scope.
4460 exit when In_Package_Spec
4461 and then Scope
(E
) /= Current_Scope
;
4464 end Process_Suppress_Unsuppress
;
4470 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
4472 if Is_Imported
(E
) then
4474 ("cannot export entity& that was previously imported", Arg
);
4476 elsif Present
(Address_Clause
(E
)) then
4478 ("cannot export entity& that has an address clause", Arg
);
4481 Set_Is_Exported
(E
);
4483 -- Generate a reference for entity explicitly, because the
4484 -- identifier may be overloaded and name resolution will not
4487 Generate_Reference
(E
, Arg
);
4489 -- Deal with exporting non-library level entity
4491 if not Is_Library_Level_Entity
(E
) then
4493 -- Not allowed at all for subprograms
4495 if Is_Subprogram
(E
) then
4496 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
4498 -- Otherwise set public and statically allocated
4502 Set_Is_Statically_Allocated
(E
);
4504 -- Warn if the corresponding W flag is set and the pragma
4505 -- comes from source. The latter may not be true e.g. on
4506 -- VMS where we expand export pragmas for exception codes
4507 -- associated with imported or exported exceptions. We do
4508 -- not want to generate a warning for something that the
4509 -- user did not write.
4511 if Warn_On_Export_Import
4512 and then Comes_From_Source
(Arg
)
4515 ("?& has been made static as a result of Export", Arg
, E
);
4517 ("\this usage is non-standard and non-portable", Arg
);
4522 if Warn_On_Export_Import
and then Is_Type
(E
) then
4524 ("exporting a type has no effect?", Arg
, E
);
4527 if Warn_On_Export_Import
and Inside_A_Generic
then
4529 ("all instances of& will have the same external name?", Arg
, E
);
4533 ----------------------------------------------
4534 -- Set_Extended_Import_Export_External_Name --
4535 ----------------------------------------------
4537 procedure Set_Extended_Import_Export_External_Name
4538 (Internal_Ent
: Entity_Id
;
4539 Arg_External
: Node_Id
)
4541 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
4545 if No
(Arg_External
) then
4549 Check_Arg_Is_External_Name
(Arg_External
);
4551 if Nkind
(Arg_External
) = N_String_Literal
then
4552 if String_Length
(Strval
(Arg_External
)) = 0 then
4555 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
4558 elsif Nkind
(Arg_External
) = N_Identifier
then
4559 New_Name
:= Get_Default_External_Name
(Arg_External
);
4561 -- Check_Arg_Is_External_Name should let through only
4562 -- identifiers and string literals or static string
4563 -- expressions (which are folded to string literals).
4566 raise Program_Error
;
4569 -- If we already have an external name set (by a prior normal
4570 -- Import or Export pragma), then the external names must match
4572 if Present
(Interface_Name
(Internal_Ent
)) then
4573 Check_Matching_Internal_Names
: declare
4574 S1
: constant String_Id
:= Strval
(Old_Name
);
4575 S2
: constant String_Id
:= Strval
(New_Name
);
4578 -- Called if names do not match
4584 procedure Mismatch
is
4586 Error_Msg_Sloc
:= Sloc
(Old_Name
);
4588 ("external name does not match that given #",
4592 -- Start of processing for Check_Matching_Internal_Names
4595 if String_Length
(S1
) /= String_Length
(S2
) then
4599 for J
in 1 .. String_Length
(S1
) loop
4600 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
4605 end Check_Matching_Internal_Names
;
4607 -- Otherwise set the given name
4610 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
4611 Check_Duplicated_Export_Name
(New_Name
);
4613 end Set_Extended_Import_Export_External_Name
;
4619 procedure Set_Imported
(E
: Entity_Id
) is
4621 -- Error message if already imported or exported
4623 if Is_Exported
(E
) or else Is_Imported
(E
) then
4624 if Is_Exported
(E
) then
4625 Error_Msg_NE
("entity& was previously exported", N
, E
);
4627 Error_Msg_NE
("entity& was previously imported", N
, E
);
4630 Error_Msg_Name_1
:= Pname
;
4632 ("\(pragma% applies to all previous entities)", N
);
4634 Error_Msg_Sloc
:= Sloc
(E
);
4635 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
4637 -- Here if not previously imported or exported, OK to import
4640 Set_Is_Imported
(E
);
4642 -- If the entity is an object that is not at the library
4643 -- level, then it is statically allocated. We do not worry
4644 -- about objects with address clauses in this context since
4645 -- they are not really imported in the linker sense.
4648 and then not Is_Library_Level_Entity
(E
)
4649 and then No
(Address_Clause
(E
))
4651 Set_Is_Statically_Allocated
(E
);
4656 -------------------------
4657 -- Set_Mechanism_Value --
4658 -------------------------
4660 -- Note: the mechanism name has not been analyzed (and cannot indeed
4661 -- be analyzed, since it is semantic nonsense), so we get it in the
4662 -- exact form created by the parser.
4664 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
4667 Mech_Name_Id
: Name_Id
;
4669 procedure Bad_Class
;
4670 -- Signal bad descriptor class name
4672 procedure Bad_Mechanism
;
4673 -- Signal bad mechanism name
4679 procedure Bad_Class
is
4681 Error_Pragma_Arg
("unrecognized descriptor class name", Class
);
4684 -------------------------
4685 -- Bad_Mechanism_Value --
4686 -------------------------
4688 procedure Bad_Mechanism
is
4690 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
4693 -- Start of processing for Set_Mechanism_Value
4696 if Mechanism
(Ent
) /= Default_Mechanism
then
4698 ("mechanism for & has already been set", Mech_Name
, Ent
);
4701 -- MECHANISM_NAME ::= value | reference | descriptor |
4704 if Nkind
(Mech_Name
) = N_Identifier
then
4705 if Chars
(Mech_Name
) = Name_Value
then
4706 Set_Mechanism
(Ent
, By_Copy
);
4709 elsif Chars
(Mech_Name
) = Name_Reference
then
4710 Set_Mechanism
(Ent
, By_Reference
);
4713 elsif Chars
(Mech_Name
) = Name_Descriptor
then
4714 Check_VMS
(Mech_Name
);
4715 Set_Mechanism
(Ent
, By_Descriptor
);
4718 elsif Chars
(Mech_Name
) = Name_Short_Descriptor
then
4719 Check_VMS
(Mech_Name
);
4720 Set_Mechanism
(Ent
, By_Short_Descriptor
);
4723 elsif Chars
(Mech_Name
) = Name_Copy
then
4725 ("bad mechanism name, Value assumed", Mech_Name
);
4731 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
4732 -- short_descriptor (CLASS_NAME)
4733 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
4735 -- Note: this form is parsed as an indexed component
4737 elsif Nkind
(Mech_Name
) = N_Indexed_Component
then
4739 Class
:= First
(Expressions
(Mech_Name
));
4741 if Nkind
(Prefix
(Mech_Name
)) /= N_Identifier
4742 or else not (Chars
(Prefix
(Mech_Name
)) = Name_Descriptor
or else
4743 Chars
(Prefix
(Mech_Name
)) = Name_Short_Descriptor
)
4744 or else Present
(Next
(Class
))
4748 Mech_Name_Id
:= Chars
(Prefix
(Mech_Name
));
4751 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
4752 -- short_descriptor (Class => CLASS_NAME)
4753 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
4755 -- Note: this form is parsed as a function call
4757 elsif Nkind
(Mech_Name
) = N_Function_Call
then
4759 Param
:= First
(Parameter_Associations
(Mech_Name
));
4761 if Nkind
(Name
(Mech_Name
)) /= N_Identifier
4762 or else not (Chars
(Name
(Mech_Name
)) = Name_Descriptor
or else
4763 Chars
(Name
(Mech_Name
)) = Name_Short_Descriptor
)
4764 or else Present
(Next
(Param
))
4765 or else No
(Selector_Name
(Param
))
4766 or else Chars
(Selector_Name
(Param
)) /= Name_Class
4770 Class
:= Explicit_Actual_Parameter
(Param
);
4771 Mech_Name_Id
:= Chars
(Name
(Mech_Name
));
4778 -- Fall through here with Class set to descriptor class name
4780 Check_VMS
(Mech_Name
);
4782 if Nkind
(Class
) /= N_Identifier
then
4785 elsif Mech_Name_Id
= Name_Descriptor
4786 and then Chars
(Class
) = Name_UBS
4788 Set_Mechanism
(Ent
, By_Descriptor_UBS
);
4790 elsif Mech_Name_Id
= Name_Descriptor
4791 and then Chars
(Class
) = Name_UBSB
4793 Set_Mechanism
(Ent
, By_Descriptor_UBSB
);
4795 elsif Mech_Name_Id
= Name_Descriptor
4796 and then Chars
(Class
) = Name_UBA
4798 Set_Mechanism
(Ent
, By_Descriptor_UBA
);
4800 elsif Mech_Name_Id
= Name_Descriptor
4801 and then Chars
(Class
) = Name_S
4803 Set_Mechanism
(Ent
, By_Descriptor_S
);
4805 elsif Mech_Name_Id
= Name_Descriptor
4806 and then Chars
(Class
) = Name_SB
4808 Set_Mechanism
(Ent
, By_Descriptor_SB
);
4810 elsif Mech_Name_Id
= Name_Descriptor
4811 and then Chars
(Class
) = Name_A
4813 Set_Mechanism
(Ent
, By_Descriptor_A
);
4815 elsif Mech_Name_Id
= Name_Descriptor
4816 and then Chars
(Class
) = Name_NCA
4818 Set_Mechanism
(Ent
, By_Descriptor_NCA
);
4820 elsif Mech_Name_Id
= Name_Short_Descriptor
4821 and then Chars
(Class
) = Name_UBS
4823 Set_Mechanism
(Ent
, By_Short_Descriptor_UBS
);
4825 elsif Mech_Name_Id
= Name_Short_Descriptor
4826 and then Chars
(Class
) = Name_UBSB
4828 Set_Mechanism
(Ent
, By_Short_Descriptor_UBSB
);
4830 elsif Mech_Name_Id
= Name_Short_Descriptor
4831 and then Chars
(Class
) = Name_UBA
4833 Set_Mechanism
(Ent
, By_Short_Descriptor_UBA
);
4835 elsif Mech_Name_Id
= Name_Short_Descriptor
4836 and then Chars
(Class
) = Name_S
4838 Set_Mechanism
(Ent
, By_Short_Descriptor_S
);
4840 elsif Mech_Name_Id
= Name_Short_Descriptor
4841 and then Chars
(Class
) = Name_SB
4843 Set_Mechanism
(Ent
, By_Short_Descriptor_SB
);
4845 elsif Mech_Name_Id
= Name_Short_Descriptor
4846 and then Chars
(Class
) = Name_A
4848 Set_Mechanism
(Ent
, By_Short_Descriptor_A
);
4850 elsif Mech_Name_Id
= Name_Short_Descriptor
4851 and then Chars
(Class
) = Name_NCA
4853 Set_Mechanism
(Ent
, By_Short_Descriptor_NCA
);
4858 end Set_Mechanism_Value
;
4860 ---------------------------
4861 -- Set_Ravenscar_Profile --
4862 ---------------------------
4864 -- The tasks to be done here are
4866 -- Set required policies
4868 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
4869 -- pragma Locking_Policy (Ceiling_Locking)
4871 -- Set Detect_Blocking mode
4873 -- Set required restrictions (see System.Rident for detailed list)
4875 procedure Set_Ravenscar_Profile
(N
: Node_Id
) is
4877 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
4879 if Task_Dispatching_Policy
/= ' '
4880 and then Task_Dispatching_Policy
/= 'F'
4882 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
4883 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
4885 -- Set the FIFO_Within_Priorities policy, but always preserve
4886 -- System_Location since we like the error message with the run time
4890 Task_Dispatching_Policy
:= 'F';
4892 if Task_Dispatching_Policy_Sloc
/= System_Location
then
4893 Task_Dispatching_Policy_Sloc
:= Loc
;
4897 -- pragma Locking_Policy (Ceiling_Locking)
4899 if Locking_Policy
/= ' '
4900 and then Locking_Policy
/= 'C'
4902 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
4903 Error_Pragma
("Profile (Ravenscar) incompatible with policy#");
4905 -- Set the Ceiling_Locking policy, but preserve System_Location since
4906 -- we like the error message with the run time name.
4909 Locking_Policy
:= 'C';
4911 if Locking_Policy_Sloc
/= System_Location
then
4912 Locking_Policy_Sloc
:= Loc
;
4916 -- pragma Detect_Blocking
4918 Detect_Blocking
:= True;
4920 -- Set the corresponding restrictions
4922 Set_Profile_Restrictions
4923 (Ravenscar
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
4924 end Set_Ravenscar_Profile
;
4926 -- Start of processing for Analyze_Pragma
4929 -- Deal with unrecognized pragma
4931 if not Is_Pragma_Name
(Pname
) then
4932 if Warn_On_Unrecognized_Pragma
then
4933 Error_Msg_Name_1
:= Pname
;
4934 Error_Msg_N
("?unrecognized pragma%!", Pragma_Identifier
(N
));
4936 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
4937 if Is_Bad_Spelling_Of
(Pname
, PN
) then
4938 Error_Msg_Name_1
:= PN
;
4940 ("\?possible misspelling of %!", Pragma_Identifier
(N
));
4949 -- Here to start processing for recognized pragma
4951 Prag_Id
:= Get_Pragma_Id
(Pname
);
4960 if Present
(Pragma_Argument_Associations
(N
)) then
4961 Arg1
:= First
(Pragma_Argument_Associations
(N
));
4963 if Present
(Arg1
) then
4964 Arg2
:= Next
(Arg1
);
4966 if Present
(Arg2
) then
4967 Arg3
:= Next
(Arg2
);
4969 if Present
(Arg3
) then
4970 Arg4
:= Next
(Arg3
);
4976 -- Count number of arguments
4983 while Present
(Arg_Node
) loop
4984 Arg_Count
:= Arg_Count
+ 1;
4989 -- An enumeration type defines the pragmas that are supported by the
4990 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
4991 -- into the corresponding enumeration value for the following case.
4999 -- pragma Abort_Defer;
5001 when Pragma_Abort_Defer
=>
5003 Check_Arg_Count
(0);
5005 -- The only required semantic processing is to check the
5006 -- placement. This pragma must appear at the start of the
5007 -- statement sequence of a handled sequence of statements.
5009 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
5010 or else N
/= First
(Statements
(Parent
(N
)))
5021 -- Note: this pragma also has some specific processing in Par.Prag
5022 -- because we want to set the Ada version mode during parsing.
5024 when Pragma_Ada_83
=>
5026 Check_Arg_Count
(0);
5028 -- We really should check unconditionally for proper configuration
5029 -- pragma placement, since we really don't want mixed Ada modes
5030 -- within a single unit, and the GNAT reference manual has always
5031 -- said this was a configuration pragma, but we did not check and
5032 -- are hesitant to add the check now.
5034 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
5035 -- or Ada 95, so we must check if we are in Ada 2005 mode.
5037 if Ada_Version
>= Ada_05
then
5038 Check_Valid_Configuration_Pragma
;
5041 -- Now set Ada 83 mode
5043 Ada_Version
:= Ada_83
;
5044 Ada_Version_Explicit
:= Ada_Version
;
5052 -- Note: this pragma also has some specific processing in Par.Prag
5053 -- because we want to set the Ada 83 version mode during parsing.
5055 when Pragma_Ada_95
=>
5057 Check_Arg_Count
(0);
5059 -- We really should check unconditionally for proper configuration
5060 -- pragma placement, since we really don't want mixed Ada modes
5061 -- within a single unit, and the GNAT reference manual has always
5062 -- said this was a configuration pragma, but we did not check and
5063 -- are hesitant to add the check now.
5065 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
5066 -- or Ada 95, so we must check if we are in Ada 2005 mode.
5068 if Ada_Version
>= Ada_05
then
5069 Check_Valid_Configuration_Pragma
;
5072 -- Now set Ada 95 mode
5074 Ada_Version
:= Ada_95
;
5075 Ada_Version_Explicit
:= Ada_Version
;
5077 ---------------------
5078 -- Ada_05/Ada_2005 --
5079 ---------------------
5082 -- pragma Ada_05 (LOCAL_NAME);
5085 -- pragma Ada_2005 (LOCAL_NAME):
5087 -- Note: these pragma also have some specific processing in Par.Prag
5088 -- because we want to set the Ada 2005 version mode during parsing.
5090 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
5096 if Arg_Count
= 1 then
5097 Check_Arg_Is_Local_Name
(Arg1
);
5098 E_Id
:= Expression
(Arg1
);
5100 if Etype
(E_Id
) = Any_Type
then
5104 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
5107 Check_Arg_Count
(0);
5109 -- For Ada_2005 we unconditionally enforce the documented
5110 -- configuration pragma placement, since we do not want to
5111 -- tolerate mixed modes in a unit involving Ada 2005. That
5112 -- would cause real difficulties for those cases where there
5113 -- are incompatibilities between Ada 95 and Ada 2005.
5115 Check_Valid_Configuration_Pragma
;
5117 -- Now set Ada 2005 mode
5119 Ada_Version
:= Ada_05
;
5120 Ada_Version_Explicit
:= Ada_05
;
5124 ----------------------
5125 -- All_Calls_Remote --
5126 ----------------------
5128 -- pragma All_Calls_Remote [(library_package_NAME)];
5130 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
5131 Lib_Entity
: Entity_Id
;
5134 Check_Ada_83_Warning
;
5135 Check_Valid_Library_Unit_Pragma
;
5137 if Nkind
(N
) = N_Null_Statement
then
5141 Lib_Entity
:= Find_Lib_Unit_Name
;
5143 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
5145 if Present
(Lib_Entity
)
5146 and then not Debug_Flag_U
5148 if not Is_Remote_Call_Interface
(Lib_Entity
) then
5149 Error_Pragma
("pragma% only apply to rci unit");
5151 -- Set flag for entity of the library unit
5154 Set_Has_All_Calls_Remote
(Lib_Entity
);
5158 end All_Calls_Remote
;
5164 -- pragma Annotate (IDENTIFIER {, ARG});
5165 -- ARG ::= NAME | EXPRESSION
5167 when Pragma_Annotate
=> Annotate
: begin
5169 Check_At_Least_N_Arguments
(1);
5170 Check_Arg_Is_Identifier
(Arg1
);
5178 while Present
(Arg
) loop
5179 Exp
:= Expression
(Arg
);
5182 if Is_Entity_Name
(Exp
) then
5185 elsif Nkind
(Exp
) = N_String_Literal
then
5186 Resolve
(Exp
, Standard_String
);
5188 elsif Is_Overloaded
(Exp
) then
5189 Error_Pragma_Arg
("ambiguous argument for pragma%", Exp
);
5204 -- pragma Assert ([Check =>] Boolean_EXPRESSION
5205 -- [, [Message =>] Static_String_EXPRESSION]);
5207 when Pragma_Assert
=> Assert
: declare
5213 Check_At_Least_N_Arguments
(1);
5214 Check_At_Most_N_Arguments
(2);
5215 Check_Arg_Order
((Name_Check
, Name_Message
));
5216 Check_Optional_Identifier
(Arg1
, Name_Check
);
5218 -- We treat pragma Assert as equivalent to:
5220 -- pragma Check (Assertion, condition [, msg]);
5222 -- So rewrite pragma in this manner, and analyze the result
5224 Expr
:= Get_Pragma_Arg
(Arg1
);
5226 Make_Pragma_Argument_Association
(Loc
,
5228 Make_Identifier
(Loc
,
5229 Chars
=> Name_Assertion
)),
5231 Make_Pragma_Argument_Association
(Sloc
(Expr
),
5232 Expression
=> Expr
));
5234 if Arg_Count
> 1 then
5235 Check_Optional_Identifier
(Arg2
, Name_Message
);
5236 Analyze_And_Resolve
(Get_Pragma_Arg
(Arg2
), Standard_String
);
5237 Append_To
(Newa
, Relocate_Node
(Arg2
));
5242 Chars
=> Name_Check
,
5243 Pragma_Argument_Associations
=> Newa
));
5247 ----------------------
5248 -- Assertion_Policy --
5249 ----------------------
5251 -- pragma Assertion_Policy (Check | Ignore)
5253 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
5258 Check_Valid_Configuration_Pragma
;
5259 Check_Arg_Count
(1);
5260 Check_No_Identifiers
;
5261 Check_Arg_Is_One_Of
(Arg1
, Name_Check
, Name_Ignore
);
5263 -- We treat pragma Assertion_Policy as equivalent to:
5265 -- pragma Check_Policy (Assertion, policy)
5267 -- So rewrite the pragma in that manner and link on to the chain
5268 -- of Check_Policy pragmas, marking the pragma as analyzed.
5270 Policy
:= Get_Pragma_Arg
(Arg1
);
5274 Chars
=> Name_Check_Policy
,
5276 Pragma_Argument_Associations
=> New_List
(
5277 Make_Pragma_Argument_Association
(Loc
,
5279 Make_Identifier
(Loc
,
5280 Chars
=> Name_Assertion
)),
5282 Make_Pragma_Argument_Association
(Loc
,
5284 Make_Identifier
(Sloc
(Policy
),
5285 Chars
=> Chars
(Policy
))))));
5288 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
5289 Opt
.Check_Policy_List
:= N
;
5290 end Assertion_Policy
;
5292 ------------------------------
5293 -- Assume_No_Invalid_Values --
5294 ------------------------------
5296 -- pragma Assume_No_Invalid_Values (On | Off);
5298 when Pragma_Assume_No_Invalid_Values
=>
5300 Check_Valid_Configuration_Pragma
;
5301 Check_Arg_Count
(1);
5302 Check_No_Identifiers
;
5303 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
5305 if Chars
(Expression
(Arg1
)) = Name_On
then
5306 Assume_No_Invalid_Values
:= True;
5308 Assume_No_Invalid_Values
:= False;
5315 -- pragma AST_Entry (entry_IDENTIFIER);
5317 when Pragma_AST_Entry
=> AST_Entry
: declare
5323 Check_Arg_Count
(1);
5324 Check_No_Identifiers
;
5325 Check_Arg_Is_Local_Name
(Arg1
);
5326 Ent
:= Entity
(Expression
(Arg1
));
5328 -- Note: the implementation of the AST_Entry pragma could handle
5329 -- the entry family case fine, but for now we are consistent with
5330 -- the DEC rules, and do not allow the pragma, which of course
5331 -- has the effect of also forbidding the attribute.
5333 if Ekind
(Ent
) /= E_Entry
then
5335 ("pragma% argument must be simple entry name", Arg1
);
5337 elsif Is_AST_Entry
(Ent
) then
5339 ("duplicate % pragma for entry", Arg1
);
5341 elsif Has_Homonym
(Ent
) then
5343 ("pragma% argument cannot specify overloaded entry", Arg1
);
5347 FF
: constant Entity_Id
:= First_Formal
(Ent
);
5350 if Present
(FF
) then
5351 if Present
(Next_Formal
(FF
)) then
5353 ("entry for pragma% can have only one argument",
5356 elsif Parameter_Mode
(FF
) /= E_In_Parameter
then
5358 ("entry parameter for pragma% must have mode IN",
5364 Set_Is_AST_Entry
(Ent
);
5372 -- pragma Asynchronous (LOCAL_NAME);
5374 when Pragma_Asynchronous
=> Asynchronous
: declare
5382 procedure Process_Async_Pragma
;
5383 -- Common processing for procedure and access-to-procedure case
5385 --------------------------
5386 -- Process_Async_Pragma --
5387 --------------------------
5389 procedure Process_Async_Pragma
is
5392 Set_Is_Asynchronous
(Nm
);
5396 -- The formals should be of mode IN (RM E.4.1(6))
5399 while Present
(S
) loop
5400 Formal
:= Defining_Identifier
(S
);
5402 if Nkind
(Formal
) = N_Defining_Identifier
5403 and then Ekind
(Formal
) /= E_In_Parameter
5406 ("pragma% procedure can only have IN parameter",
5413 Set_Is_Asynchronous
(Nm
);
5414 end Process_Async_Pragma
;
5416 -- Start of processing for pragma Asynchronous
5419 Check_Ada_83_Warning
;
5420 Check_No_Identifiers
;
5421 Check_Arg_Count
(1);
5422 Check_Arg_Is_Local_Name
(Arg1
);
5424 if Debug_Flag_U
then
5428 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
5429 Analyze
(Expression
(Arg1
));
5430 Nm
:= Entity
(Expression
(Arg1
));
5432 if not Is_Remote_Call_Interface
(C_Ent
)
5433 and then not Is_Remote_Types
(C_Ent
)
5435 -- This pragma should only appear in an RCI or Remote Types
5436 -- unit (RM E.4.1(4))
5439 ("pragma% not in Remote_Call_Interface or " &
5440 "Remote_Types unit");
5443 if Ekind
(Nm
) = E_Procedure
5444 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
5446 if not Is_Remote_Call_Interface
(Nm
) then
5448 ("pragma% cannot be applied on non-remote procedure",
5452 L
:= Parameter_Specifications
(Parent
(Nm
));
5453 Process_Async_Pragma
;
5456 elsif Ekind
(Nm
) = E_Function
then
5458 ("pragma% cannot be applied to function", Arg1
);
5460 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
5462 if Is_Record_Type
(Nm
) then
5463 -- A record type that is the Equivalent_Type for
5464 -- a remote access-to-subprogram type.
5466 N
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
5469 -- A non-expanded RAS type (case where distribution is
5472 N
:= Declaration_Node
(Nm
);
5475 if Nkind
(N
) = N_Full_Type_Declaration
5476 and then Nkind
(Type_Definition
(N
)) =
5477 N_Access_Procedure_Definition
5479 L
:= Parameter_Specifications
(Type_Definition
(N
));
5480 Process_Async_Pragma
;
5482 if Is_Asynchronous
(Nm
)
5483 and then Expander_Active
5484 and then Get_PCS_Name
/= Name_No_DSA
5486 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
5491 ("pragma% cannot reference access-to-function type",
5495 -- Only other possibility is Access-to-class-wide type
5497 elsif Is_Access_Type
(Nm
)
5498 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
5500 Check_First_Subtype
(Arg1
);
5501 Set_Is_Asynchronous
(Nm
);
5502 if Expander_Active
then
5503 RACW_Type_Is_Asynchronous
(Nm
);
5507 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
5515 -- pragma Atomic (LOCAL_NAME);
5517 when Pragma_Atomic
=>
5518 Process_Atomic_Shared_Volatile
;
5520 -----------------------
5521 -- Atomic_Components --
5522 -----------------------
5524 -- pragma Atomic_Components (array_LOCAL_NAME);
5526 -- This processing is shared by Volatile_Components
5528 when Pragma_Atomic_Components |
5529 Pragma_Volatile_Components
=>
5531 Atomic_Components
: declare
5538 Check_Ada_83_Warning
;
5539 Check_No_Identifiers
;
5540 Check_Arg_Count
(1);
5541 Check_Arg_Is_Local_Name
(Arg1
);
5542 E_Id
:= Expression
(Arg1
);
5544 if Etype
(E_Id
) = Any_Type
then
5550 if Rep_Item_Too_Early
(E
, N
)
5552 Rep_Item_Too_Late
(E
, N
)
5557 D
:= Declaration_Node
(E
);
5560 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
5562 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
5563 and then Nkind
(D
) = N_Object_Declaration
5564 and then Nkind
(Object_Definition
(D
)) =
5565 N_Constrained_Array_Definition
)
5567 -- The flag is set on the object, or on the base type
5569 if Nkind
(D
) /= N_Object_Declaration
then
5573 Set_Has_Volatile_Components
(E
);
5575 if Prag_Id
= Pragma_Atomic_Components
then
5576 Set_Has_Atomic_Components
(E
);
5578 if Is_Packed
(E
) then
5579 Set_Is_Packed
(E
, False);
5582 ("?Pack canceled, cannot pack atomic components",
5588 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
5590 end Atomic_Components
;
5592 --------------------
5593 -- Attach_Handler --
5594 --------------------
5596 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
5598 when Pragma_Attach_Handler
=>
5599 Check_Ada_83_Warning
;
5600 Check_No_Identifiers
;
5601 Check_Arg_Count
(2);
5603 if No_Run_Time_Mode
then
5604 Error_Msg_CRT
("Attach_Handler pragma", N
);
5606 Check_Interrupt_Or_Attach_Handler
;
5608 -- The expression that designates the attribute may
5609 -- depend on a discriminant, and is therefore a per-
5610 -- object expression, to be expanded in the init proc.
5611 -- If expansion is enabled, perform semantic checks
5614 if Expander_Active
then
5616 Temp
: constant Node_Id
:=
5617 New_Copy_Tree
(Expression
(Arg2
));
5619 Set_Parent
(Temp
, N
);
5620 Preanalyze_And_Resolve
(Temp
, RTE
(RE_Interrupt_ID
));
5624 Analyze
(Expression
(Arg2
));
5625 Resolve
(Expression
(Arg2
), RTE
(RE_Interrupt_ID
));
5628 Process_Interrupt_Or_Attach_Handler
;
5631 --------------------
5632 -- C_Pass_By_Copy --
5633 --------------------
5635 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
5637 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
5643 Check_Valid_Configuration_Pragma
;
5644 Check_Arg_Count
(1);
5645 Check_Optional_Identifier
(Arg1
, "max_size");
5647 Arg
:= Expression
(Arg1
);
5648 Check_Arg_Is_Static_Expression
(Arg
, Any_Integer
);
5650 Val
:= Expr_Value
(Arg
);
5654 ("maximum size for pragma% must be positive", Arg1
);
5656 elsif UI_Is_In_Int_Range
(Val
) then
5657 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
5659 -- If a giant value is given, Int'Last will do well enough.
5660 -- If sometime someone complains that a record larger than
5661 -- two gigabytes is not copied, we will worry about it then!
5664 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
5672 -- pragma Check ([Name =>] Identifier,
5673 -- [Check =>] Boolean_Expression
5674 -- [,[Message =>] String_Expression]);
5676 when Pragma_Check
=> Check
: declare
5681 -- Set True if category of assertions referenced by Name enabled
5685 Check_At_Least_N_Arguments
(2);
5686 Check_At_Most_N_Arguments
(3);
5687 Check_Optional_Identifier
(Arg1
, Name_Name
);
5688 Check_Optional_Identifier
(Arg2
, Name_Check
);
5690 if Arg_Count
= 3 then
5691 Check_Optional_Identifier
(Arg3
, Name_Message
);
5692 Analyze_And_Resolve
(Get_Pragma_Arg
(Arg3
), Standard_String
);
5695 Check_Arg_Is_Identifier
(Arg1
);
5696 Check_On
:= Check_Enabled
(Chars
(Get_Pragma_Arg
(Arg1
)));
5698 -- If expansion is active and the check is not enabled then we
5699 -- rewrite the Check as:
5701 -- if False and then condition then
5705 -- The reason we do this rewriting during semantic analysis rather
5706 -- than as part of normal expansion is that we cannot analyze and
5707 -- expand the code for the boolean expression directly, or it may
5708 -- cause insertion of actions that would escape the attempt to
5709 -- suppress the check code.
5711 -- Note that the Sloc for the if statement corresponds to the
5712 -- argument condition, not the pragma itself. The reason for this
5713 -- is that we may generate a warning if the condition is False at
5714 -- compile time, and we do not want to delete this warning when we
5715 -- delete the if statement.
5717 Expr
:= Expression
(Arg2
);
5719 if Expander_Active
and then not Check_On
then
5720 Eloc
:= Sloc
(Expr
);
5723 Make_If_Statement
(Eloc
,
5725 Make_And_Then
(Eloc
,
5726 Left_Opnd
=> New_Occurrence_Of
(Standard_False
, Eloc
),
5727 Right_Opnd
=> Expr
),
5728 Then_Statements
=> New_List
(
5729 Make_Null_Statement
(Eloc
))));
5736 Analyze_And_Resolve
(Expr
, Any_Boolean
);
5739 -- If assertion is of the form (X'First = literal), where X is
5740 -- a formal, then set Low_Bound_Known flag on this formal.
5742 if Nkind
(Expr
) = N_Op_Eq
then
5744 Right
: constant Node_Id
:= Right_Opnd
(Expr
);
5745 Left
: constant Node_Id
:= Left_Opnd
(Expr
);
5747 if Nkind
(Left
) = N_Attribute_Reference
5748 and then Attribute_Name
(Left
) = Name_First
5749 and then Is_Entity_Name
(Prefix
(Left
))
5750 and then Is_Formal
(Entity
(Prefix
(Left
)))
5751 and then Nkind
(Right
) = N_Integer_Literal
5753 Set_Low_Bound_Known
(Entity
(Prefix
(Left
)));
5763 -- pragma Check_Name (check_IDENTIFIER);
5765 when Pragma_Check_Name
=>
5766 Check_No_Identifiers
;
5768 Check_Valid_Configuration_Pragma
;
5769 Check_Arg_Count
(1);
5770 Check_Arg_Is_Identifier
(Arg1
);
5773 Nam
: constant Name_Id
:= Chars
(Expression
(Arg1
));
5776 for J
in Check_Names
.First
.. Check_Names
.Last
loop
5777 if Check_Names
.Table
(J
) = Nam
then
5782 Check_Names
.Append
(Nam
);
5789 -- pragma Check_Policy ([Name =>] IDENTIFIER,
5790 -- POLICY_IDENTIFIER;
5792 -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE
5794 -- Note: this is a configuration pragma, but it is allowed to
5795 -- appear anywhere else.
5797 when Pragma_Check_Policy
=>
5799 Check_Arg_Count
(2);
5800 Check_No_Identifier
(Arg2
);
5801 Check_Optional_Identifier
(Arg1
, Name_Name
);
5803 (Arg2
, Name_On
, Name_Off
, Name_Check
, Name_Ignore
);
5805 -- A Check_Policy pragma can appear either as a configuration
5806 -- pragma, or in a declarative part or a package spec (see RM
5807 -- 11.5(5) for rules for Suppress/Unsuppress which are also
5808 -- followed for Check_Policy).
5810 if not Is_Configuration_Pragma
then
5811 Check_Is_In_Decl_Part_Or_Package_Spec
;
5814 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
5815 Opt
.Check_Policy_List
:= N
;
5817 ---------------------
5818 -- CIL_Constructor --
5819 ---------------------
5821 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
5823 -- Processing for this pragma is shared with Java_Constructor
5829 -- pragma Comment (static_string_EXPRESSION)
5831 -- Processing for pragma Comment shares the circuitry for pragma
5832 -- Ident. The only differences are that Ident enforces a limit of 31
5833 -- characters on its argument, and also enforces limitations on
5834 -- placement for DEC compatibility. Pragma Comment shares neither of
5835 -- these restrictions.
5841 -- pragma Common_Object (
5842 -- [Internal =>] LOCAL_NAME
5843 -- [, [External =>] EXTERNAL_SYMBOL]
5844 -- [, [Size =>] EXTERNAL_SYMBOL]);
5846 -- Processing for this pragma is shared with Psect_Object
5848 ------------------------
5849 -- Compile_Time_Error --
5850 ------------------------
5852 -- pragma Compile_Time_Error
5853 -- (boolean_EXPRESSION, static_string_EXPRESSION);
5855 when Pragma_Compile_Time_Error
=>
5857 Process_Compile_Time_Warning_Or_Error
;
5859 --------------------------
5860 -- Compile_Time_Warning --
5861 --------------------------
5863 -- pragma Compile_Time_Warning
5864 -- (boolean_EXPRESSION, static_string_EXPRESSION);
5866 when Pragma_Compile_Time_Warning
=>
5868 Process_Compile_Time_Warning_Or_Error
;
5874 when Pragma_Compiler_Unit
=>
5876 Check_Arg_Count
(0);
5877 Set_Is_Compiler_Unit
(Get_Source_Unit
(N
));
5879 -----------------------------
5880 -- Complete_Representation --
5881 -----------------------------
5883 -- pragma Complete_Representation;
5885 when Pragma_Complete_Representation
=>
5887 Check_Arg_Count
(0);
5889 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
5891 ("pragma & must appear within record representation clause");
5894 ----------------------------
5895 -- Complex_Representation --
5896 ----------------------------
5898 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
5900 when Pragma_Complex_Representation
=> Complex_Representation
: declare
5907 Check_Arg_Count
(1);
5908 Check_Optional_Identifier
(Arg1
, Name_Entity
);
5909 Check_Arg_Is_Local_Name
(Arg1
);
5910 E_Id
:= Expression
(Arg1
);
5912 if Etype
(E_Id
) = Any_Type
then
5918 if not Is_Record_Type
(E
) then
5920 ("argument for pragma% must be record type", Arg1
);
5923 Ent
:= First_Entity
(E
);
5926 or else No
(Next_Entity
(Ent
))
5927 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
5928 or else not Is_Floating_Point_Type
(Etype
(Ent
))
5929 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
5932 ("record for pragma% must have two fields of the same "
5933 & "floating-point type", Arg1
);
5936 Set_Has_Complex_Representation
(Base_Type
(E
));
5938 -- We need to treat the type has having a non-standard
5939 -- representation, for back-end purposes, even though in
5940 -- general a complex will have the default representation
5941 -- of a record with two real components.
5943 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
5945 end Complex_Representation
;
5947 -------------------------
5948 -- Component_Alignment --
5949 -------------------------
5951 -- pragma Component_Alignment (
5952 -- [Form =>] ALIGNMENT_CHOICE
5953 -- [, [Name =>] type_LOCAL_NAME]);
5955 -- ALIGNMENT_CHOICE ::=
5957 -- | Component_Size_4
5961 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
5962 Args
: Args_List
(1 .. 2);
5963 Names
: constant Name_List
(1 .. 2) := (
5967 Form
: Node_Id
renames Args
(1);
5968 Name
: Node_Id
renames Args
(2);
5970 Atype
: Component_Alignment_Kind
;
5975 Gather_Associations
(Names
, Args
);
5978 Error_Pragma
("missing Form argument for pragma%");
5981 Check_Arg_Is_Identifier
(Form
);
5983 -- Get proper alignment, note that Default = Component_Size
5984 -- on all machines we have so far, and we want to set this
5985 -- value rather than the default value to indicate that it
5986 -- has been explicitly set (and thus will not get overridden
5987 -- by the default component alignment for the current scope)
5989 if Chars
(Form
) = Name_Component_Size
then
5990 Atype
:= Calign_Component_Size
;
5992 elsif Chars
(Form
) = Name_Component_Size_4
then
5993 Atype
:= Calign_Component_Size_4
;
5995 elsif Chars
(Form
) = Name_Default
then
5996 Atype
:= Calign_Component_Size
;
5998 elsif Chars
(Form
) = Name_Storage_Unit
then
5999 Atype
:= Calign_Storage_Unit
;
6003 ("invalid Form parameter for pragma%", Form
);
6006 -- Case with no name, supplied, affects scope table entry
6010 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
6012 -- Case of name supplied
6015 Check_Arg_Is_Local_Name
(Name
);
6017 Typ
:= Entity
(Name
);
6020 or else Rep_Item_Too_Early
(Typ
, N
)
6024 Typ
:= Underlying_Type
(Typ
);
6027 if not Is_Record_Type
(Typ
)
6028 and then not Is_Array_Type
(Typ
)
6031 ("Name parameter of pragma% must identify record or " &
6032 "array type", Name
);
6035 -- An explicit Component_Alignment pragma overrides an
6036 -- implicit pragma Pack, but not an explicit one.
6038 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
6039 Set_Is_Packed
(Base_Type
(Typ
), False);
6040 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
6043 end Component_AlignmentP
;
6049 -- pragma Controlled (first_subtype_LOCAL_NAME);
6051 when Pragma_Controlled
=> Controlled
: declare
6055 Check_No_Identifiers
;
6056 Check_Arg_Count
(1);
6057 Check_Arg_Is_Local_Name
(Arg1
);
6058 Arg
:= Expression
(Arg1
);
6060 if not Is_Entity_Name
(Arg
)
6061 or else not Is_Access_Type
(Entity
(Arg
))
6063 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
6065 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
6073 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
6074 -- [Entity =>] LOCAL_NAME);
6076 when Pragma_Convention
=> Convention
: declare
6079 pragma Warnings
(Off
, C
);
6080 pragma Warnings
(Off
, E
);
6082 Check_Arg_Order
((Name_Convention
, Name_Entity
));
6083 Check_Ada_83_Warning
;
6084 Check_Arg_Count
(2);
6085 Process_Convention
(C
, E
);
6088 ---------------------------
6089 -- Convention_Identifier --
6090 ---------------------------
6092 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
6093 -- [Convention =>] convention_IDENTIFIER);
6095 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
6101 Check_Arg_Order
((Name_Name
, Name_Convention
));
6102 Check_Arg_Count
(2);
6103 Check_Optional_Identifier
(Arg1
, Name_Name
);
6104 Check_Optional_Identifier
(Arg2
, Name_Convention
);
6105 Check_Arg_Is_Identifier
(Arg1
);
6106 Check_Arg_Is_Identifier
(Arg2
);
6107 Idnam
:= Chars
(Expression
(Arg1
));
6108 Cname
:= Chars
(Expression
(Arg2
));
6110 if Is_Convention_Name
(Cname
) then
6111 Record_Convention_Identifier
6112 (Idnam
, Get_Convention_Id
(Cname
));
6115 ("second arg for % pragma must be convention", Arg2
);
6117 end Convention_Identifier
;
6123 -- pragma CPP_Class ([Entity =>] local_NAME)
6125 when Pragma_CPP_Class
=> CPP_Class
: declare
6130 if Warn_On_Obsolescent_Feature
then
6132 ("'G'N'A'T pragma cpp'_class is now obsolete; replace it" &
6133 " by pragma import?", N
);
6137 Check_Arg_Count
(1);
6138 Check_Optional_Identifier
(Arg1
, Name_Entity
);
6139 Check_Arg_Is_Local_Name
(Arg1
);
6141 Arg
:= Expression
(Arg1
);
6144 if Etype
(Arg
) = Any_Type
then
6148 if not Is_Entity_Name
(Arg
)
6149 or else not Is_Type
(Entity
(Arg
))
6151 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
6154 Typ
:= Entity
(Arg
);
6156 if not Is_Tagged_Type
(Typ
) then
6157 Error_Pragma_Arg
("pragma% applicable to tagged types ", Arg1
);
6160 -- Types treated as CPP classes are treated as limited, but we
6161 -- don't require them to be declared this way. A warning is issued
6162 -- to encourage the user to declare them as limited. This is not
6163 -- an error, for compatibility reasons, because these types have
6164 -- been supported this way for some time.
6166 if not Is_Limited_Type
(Typ
) then
6168 ("imported 'C'P'P type should be " &
6169 "explicitly declared limited?",
6170 Get_Pragma_Arg
(Arg1
));
6172 ("\type will be considered limited",
6173 Get_Pragma_Arg
(Arg1
));
6176 Set_Is_CPP_Class
(Typ
);
6177 Set_Is_Limited_Record
(Typ
);
6178 Set_Convention
(Typ
, Convention_CPP
);
6181 ---------------------
6182 -- CPP_Constructor --
6183 ---------------------
6185 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
6186 -- [, [External_Name =>] static_string_EXPRESSION ]
6187 -- [, [Link_Name =>] static_string_EXPRESSION ]);
6189 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
6195 Check_At_Least_N_Arguments
(1);
6196 Check_At_Most_N_Arguments
(3);
6197 Check_Optional_Identifier
(Arg1
, Name_Entity
);
6198 Check_Arg_Is_Local_Name
(Arg1
);
6200 Id
:= Expression
(Arg1
);
6201 Find_Program_Unit_Name
(Id
);
6203 -- If we did not find the name, we are done
6205 if Etype
(Id
) = Any_Type
then
6209 Def_Id
:= Entity
(Id
);
6211 if Ekind
(Def_Id
) = E_Function
6212 and then Is_Class_Wide_Type
(Etype
(Def_Id
))
6213 and then Is_CPP_Class
(Etype
(Etype
(Def_Id
)))
6215 if Arg_Count
>= 2 then
6216 Set_Imported
(Def_Id
);
6217 Set_Is_Public
(Def_Id
);
6218 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
6221 if No
(Parameter_Specifications
(Parent
(Def_Id
))) then
6222 Set_Has_Completion
(Def_Id
);
6223 Set_Is_Constructor
(Def_Id
);
6226 ("non-default constructors not implemented", Arg1
);
6231 ("pragma% requires function returning a 'C'P'P_Class type",
6234 end CPP_Constructor
;
6240 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
6244 if Warn_On_Obsolescent_Feature
then
6246 ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " &
6255 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
6259 if Warn_On_Obsolescent_Feature
then
6261 ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
6270 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
6272 when Pragma_Debug
=> Debug
: declare
6280 (Boolean_Literals
(Debug_Pragmas_Enabled
and Expander_Active
),
6283 if Arg_Count
= 2 then
6286 Left_Opnd
=> Relocate_Node
(Cond
),
6287 Right_Opnd
=> Expression
(Arg1
));
6290 -- Rewrite into a conditional with an appropriate condition. We
6291 -- wrap the procedure call in a block so that overhead from e.g.
6292 -- use of the secondary stack does not generate execution overhead
6293 -- for suppressed conditions.
6295 Rewrite
(N
, Make_Implicit_If_Statement
(N
,
6297 Then_Statements
=> New_List
(
6298 Make_Block_Statement
(Loc
,
6299 Handled_Statement_Sequence
=>
6300 Make_Handled_Sequence_Of_Statements
(Loc
,
6301 Statements
=> New_List
(
6302 Relocate_Node
(Debug_Statement
(N
))))))));
6310 -- pragma Debug_Policy (Check | Ignore)
6312 when Pragma_Debug_Policy
=>
6314 Check_Arg_Count
(1);
6315 Check_Arg_Is_One_Of
(Arg1
, Name_Check
, Name_Ignore
);
6316 Debug_Pragmas_Enabled
:= Chars
(Expression
(Arg1
)) = Name_Check
;
6318 ---------------------
6319 -- Detect_Blocking --
6320 ---------------------
6322 -- pragma Detect_Blocking;
6324 when Pragma_Detect_Blocking
=>
6326 Check_Arg_Count
(0);
6327 Check_Valid_Configuration_Pragma
;
6328 Detect_Blocking
:= True;
6334 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
6336 when Pragma_Discard_Names
=> Discard_Names
: declare
6341 Check_Ada_83_Warning
;
6343 -- Deal with configuration pragma case
6345 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
6346 Global_Discard_Names
:= True;
6349 -- Otherwise, check correct appropriate context
6352 Check_Is_In_Decl_Part_Or_Package_Spec
;
6354 if Arg_Count
= 0 then
6356 -- If there is no parameter, then from now on this pragma
6357 -- applies to any enumeration, exception or tagged type
6358 -- defined in the current declarative part, and recursively
6359 -- to any nested scope.
6361 Set_Discard_Names
(Current_Scope
);
6365 Check_Arg_Count
(1);
6366 Check_Optional_Identifier
(Arg1
, Name_On
);
6367 Check_Arg_Is_Local_Name
(Arg1
);
6369 E_Id
:= Expression
(Arg1
);
6371 if Etype
(E_Id
) = Any_Type
then
6377 if (Is_First_Subtype
(E
)
6379 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
6380 or else Ekind
(E
) = E_Exception
6382 Set_Discard_Names
(E
);
6385 ("inappropriate entity for pragma%", Arg1
);
6396 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
6398 when Pragma_Elaborate
=> Elaborate
: declare
6403 -- Pragma must be in context items list of a compilation unit
6405 if not Is_In_Context_Clause
then
6409 -- Must be at least one argument
6411 if Arg_Count
= 0 then
6412 Error_Pragma
("pragma% requires at least one argument");
6415 -- In Ada 83 mode, there can be no items following it in the
6416 -- context list except other pragmas and implicit with clauses
6417 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
6418 -- placement rule does not apply.
6420 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
6422 while Present
(Citem
) loop
6423 if Nkind
(Citem
) = N_Pragma
6424 or else (Nkind
(Citem
) = N_With_Clause
6425 and then Implicit_With
(Citem
))
6430 ("(Ada 83) pragma% must be at end of context clause");
6437 -- Finally, the arguments must all be units mentioned in a with
6438 -- clause in the same context clause. Note we already checked (in
6439 -- Par.Prag) that the arguments are all identifiers or selected
6443 Outer
: while Present
(Arg
) loop
6444 Citem
:= First
(List_Containing
(N
));
6445 Inner
: while Citem
/= N
loop
6446 if Nkind
(Citem
) = N_With_Clause
6447 and then Same_Name
(Name
(Citem
), Expression
(Arg
))
6449 Set_Elaborate_Present
(Citem
, True);
6450 Set_Unit_Name
(Expression
(Arg
), Name
(Citem
));
6452 -- With the pragma present, elaboration calls on
6453 -- subprograms from the named unit need no further
6454 -- checks, as long as the pragma appears in the current
6455 -- compilation unit. If the pragma appears in some unit
6456 -- in the context, there might still be a need for an
6457 -- Elaborate_All_Desirable from the current compilation
6458 -- to the named unit, so we keep the check enabled.
6460 if In_Extended_Main_Source_Unit
(N
) then
6461 Set_Suppress_Elaboration_Warnings
6462 (Entity
(Name
(Citem
)));
6473 ("argument of pragma% is not with'ed unit", Arg
);
6479 -- Give a warning if operating in static mode with -gnatwl
6480 -- (elaboration warnings enabled) switch set.
6482 if Elab_Warnings
and not Dynamic_Elaboration_Checks
then
6484 ("?use of pragma Elaborate may not be safe", N
);
6486 ("?use pragma Elaborate_All instead if possible", N
);
6494 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
6496 when Pragma_Elaborate_All
=> Elaborate_All
: declare
6501 Check_Ada_83_Warning
;
6503 -- Pragma must be in context items list of a compilation unit
6505 if not Is_In_Context_Clause
then
6509 -- Must be at least one argument
6511 if Arg_Count
= 0 then
6512 Error_Pragma
("pragma% requires at least one argument");
6515 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
6516 -- have to appear at the end of the context clause, but may
6517 -- appear mixed in with other items, even in Ada 83 mode.
6519 -- Final check: the arguments must all be units mentioned in
6520 -- a with clause in the same context clause. Note that we
6521 -- already checked (in Par.Prag) that all the arguments are
6522 -- either identifiers or selected components.
6525 Outr
: while Present
(Arg
) loop
6526 Citem
:= First
(List_Containing
(N
));
6527 Innr
: while Citem
/= N
loop
6528 if Nkind
(Citem
) = N_With_Clause
6529 and then Same_Name
(Name
(Citem
), Expression
(Arg
))
6531 Set_Elaborate_All_Present
(Citem
, True);
6532 Set_Unit_Name
(Expression
(Arg
), Name
(Citem
));
6534 -- Suppress warnings and elaboration checks on the named
6535 -- unit if the pragma is in the current compilation, as
6536 -- for pragma Elaborate.
6538 if In_Extended_Main_Source_Unit
(N
) then
6539 Set_Suppress_Elaboration_Warnings
6540 (Entity
(Name
(Citem
)));
6549 Set_Error_Posted
(N
);
6551 ("argument of pragma% is not with'ed unit", Arg
);
6558 --------------------
6559 -- Elaborate_Body --
6560 --------------------
6562 -- pragma Elaborate_Body [( library_unit_NAME )];
6564 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
6565 Cunit_Node
: Node_Id
;
6566 Cunit_Ent
: Entity_Id
;
6569 Check_Ada_83_Warning
;
6570 Check_Valid_Library_Unit_Pragma
;
6572 if Nkind
(N
) = N_Null_Statement
then
6576 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
6577 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
6579 if Nkind
(Unit
(Cunit_Node
)) = N_Package_Body
6581 Nkind
(Unit
(Cunit_Node
)) = N_Subprogram_Body
6583 Error_Pragma
("pragma% must refer to a spec, not a body");
6585 Set_Body_Required
(Cunit_Node
, True);
6586 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
6588 -- If we are in dynamic elaboration mode, then we suppress
6589 -- elaboration warnings for the unit, since it is definitely
6590 -- fine NOT to do dynamic checks at the first level (and such
6591 -- checks will be suppressed because no elaboration boolean
6592 -- is created for Elaborate_Body packages).
6594 -- But in the static model of elaboration, Elaborate_Body is
6595 -- definitely NOT good enough to ensure elaboration safety on
6596 -- its own, since the body may WITH other units that are not
6597 -- safe from an elaboration point of view, so a client must
6598 -- still do an Elaborate_All on such units.
6600 -- Debug flag -gnatdD restores the old behavior of 3.13,
6601 -- where Elaborate_Body always suppressed elab warnings.
6603 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
6604 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
6609 ------------------------
6610 -- Elaboration_Checks --
6611 ------------------------
6613 -- pragma Elaboration_Checks (Static | Dynamic);
6615 when Pragma_Elaboration_Checks
=>
6617 Check_Arg_Count
(1);
6618 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
6619 Dynamic_Elaboration_Checks
:=
6620 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
);
6626 -- pragma Eliminate (
6627 -- [Unit_Name =>] IDENTIFIER |
6628 -- SELECTED_COMPONENT
6629 -- [,[Entity =>] IDENTIFIER |
6630 -- SELECTED_COMPONENT |
6632 -- [,]OVERLOADING_RESOLUTION);
6634 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
6637 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
6640 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
6642 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
6643 -- Result_Type => result_SUBTYPE_NAME]
6645 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
6646 -- SUBTYPE_NAME ::= STRING_LITERAL
6648 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
6649 -- SOURCE_TRACE ::= STRING_LITERAL
6651 when Pragma_Eliminate
=> Eliminate
: declare
6652 Args
: Args_List
(1 .. 5);
6653 Names
: constant Name_List
(1 .. 5) := (
6656 Name_Parameter_Types
,
6658 Name_Source_Location
);
6660 Unit_Name
: Node_Id
renames Args
(1);
6661 Entity
: Node_Id
renames Args
(2);
6662 Parameter_Types
: Node_Id
renames Args
(3);
6663 Result_Type
: Node_Id
renames Args
(4);
6664 Source_Location
: Node_Id
renames Args
(5);
6668 Check_Valid_Configuration_Pragma
;
6669 Gather_Associations
(Names
, Args
);
6671 if No
(Unit_Name
) then
6672 Error_Pragma
("missing Unit_Name argument for pragma%");
6676 and then (Present
(Parameter_Types
)
6678 Present
(Result_Type
)
6680 Present
(Source_Location
))
6682 Error_Pragma
("missing Entity argument for pragma%");
6685 if (Present
(Parameter_Types
)
6687 Present
(Result_Type
))
6689 Present
(Source_Location
)
6692 ("parameter profile and source location cannot " &
6693 "be used together in pragma%");
6696 Process_Eliminate_Pragma
6710 -- [ Convention =>] convention_IDENTIFIER,
6711 -- [ Entity =>] local_NAME
6712 -- [, [External_Name =>] static_string_EXPRESSION ]
6713 -- [, [Link_Name =>] static_string_EXPRESSION ]);
6715 when Pragma_Export
=> Export
: declare
6719 pragma Warnings
(Off
, C
);
6722 Check_Ada_83_Warning
;
6728 Check_At_Least_N_Arguments
(2);
6729 Check_At_Most_N_Arguments
(4);
6730 Process_Convention
(C
, Def_Id
);
6732 if Ekind
(Def_Id
) /= E_Constant
then
6733 Note_Possible_Modification
(Expression
(Arg2
), Sure
=> False);
6736 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
6737 Set_Exported
(Def_Id
, Arg2
);
6739 -- If the entity is a deferred constant, propagate the
6740 -- information to the full view, because gigi elaborates
6741 -- the full view only.
6743 if Ekind
(Def_Id
) = E_Constant
6744 and then Present
(Full_View
(Def_Id
))
6747 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
6749 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
6750 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
6751 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
6756 ----------------------
6757 -- Export_Exception --
6758 ----------------------
6760 -- pragma Export_Exception (
6761 -- [Internal =>] LOCAL_NAME
6762 -- [, [External =>] EXTERNAL_SYMBOL]
6763 -- [, [Form =>] Ada | VMS]
6764 -- [, [Code =>] static_integer_EXPRESSION]);
6766 when Pragma_Export_Exception
=> Export_Exception
: declare
6767 Args
: Args_List
(1 .. 4);
6768 Names
: constant Name_List
(1 .. 4) := (
6774 Internal
: Node_Id
renames Args
(1);
6775 External
: Node_Id
renames Args
(2);
6776 Form
: Node_Id
renames Args
(3);
6777 Code
: Node_Id
renames Args
(4);
6782 if Inside_A_Generic
then
6783 Error_Pragma
("pragma% cannot be used for generic entities");
6786 Gather_Associations
(Names
, Args
);
6787 Process_Extended_Import_Export_Exception_Pragma
(
6788 Arg_Internal
=> Internal
,
6789 Arg_External
=> External
,
6793 if not Is_VMS_Exception
(Entity
(Internal
)) then
6794 Set_Exported
(Entity
(Internal
), Internal
);
6796 end Export_Exception
;
6798 ---------------------
6799 -- Export_Function --
6800 ---------------------
6802 -- pragma Export_Function (
6803 -- [Internal =>] LOCAL_NAME
6804 -- [, [External =>] EXTERNAL_SYMBOL]
6805 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
6806 -- [, [Result_Type =>] TYPE_DESIGNATOR]
6807 -- [, [Mechanism =>] MECHANISM]
6808 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
6810 -- EXTERNAL_SYMBOL ::=
6812 -- | static_string_EXPRESSION
6814 -- PARAMETER_TYPES ::=
6816 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6818 -- TYPE_DESIGNATOR ::=
6820 -- | subtype_Name ' Access
6824 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6826 -- MECHANISM_ASSOCIATION ::=
6827 -- [formal_parameter_NAME =>] MECHANISM_NAME
6829 -- MECHANISM_NAME ::=
6832 -- | Descriptor [([Class =>] CLASS_NAME)]
6834 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6836 when Pragma_Export_Function
=> Export_Function
: declare
6837 Args
: Args_List
(1 .. 6);
6838 Names
: constant Name_List
(1 .. 6) := (
6841 Name_Parameter_Types
,
6844 Name_Result_Mechanism
);
6846 Internal
: Node_Id
renames Args
(1);
6847 External
: Node_Id
renames Args
(2);
6848 Parameter_Types
: Node_Id
renames Args
(3);
6849 Result_Type
: Node_Id
renames Args
(4);
6850 Mechanism
: Node_Id
renames Args
(5);
6851 Result_Mechanism
: Node_Id
renames Args
(6);
6855 Gather_Associations
(Names
, Args
);
6856 Process_Extended_Import_Export_Subprogram_Pragma
(
6857 Arg_Internal
=> Internal
,
6858 Arg_External
=> External
,
6859 Arg_Parameter_Types
=> Parameter_Types
,
6860 Arg_Result_Type
=> Result_Type
,
6861 Arg_Mechanism
=> Mechanism
,
6862 Arg_Result_Mechanism
=> Result_Mechanism
);
6863 end Export_Function
;
6869 -- pragma Export_Object (
6870 -- [Internal =>] LOCAL_NAME
6871 -- [, [External =>] EXTERNAL_SYMBOL]
6872 -- [, [Size =>] EXTERNAL_SYMBOL]);
6874 -- EXTERNAL_SYMBOL ::=
6876 -- | static_string_EXPRESSION
6878 -- PARAMETER_TYPES ::=
6880 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6882 -- TYPE_DESIGNATOR ::=
6884 -- | subtype_Name ' Access
6888 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6890 -- MECHANISM_ASSOCIATION ::=
6891 -- [formal_parameter_NAME =>] MECHANISM_NAME
6893 -- MECHANISM_NAME ::=
6896 -- | Descriptor [([Class =>] CLASS_NAME)]
6898 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6900 when Pragma_Export_Object
=> Export_Object
: declare
6901 Args
: Args_List
(1 .. 3);
6902 Names
: constant Name_List
(1 .. 3) := (
6907 Internal
: Node_Id
renames Args
(1);
6908 External
: Node_Id
renames Args
(2);
6909 Size
: Node_Id
renames Args
(3);
6913 Gather_Associations
(Names
, Args
);
6914 Process_Extended_Import_Export_Object_Pragma
(
6915 Arg_Internal
=> Internal
,
6916 Arg_External
=> External
,
6920 ----------------------
6921 -- Export_Procedure --
6922 ----------------------
6924 -- pragma Export_Procedure (
6925 -- [Internal =>] LOCAL_NAME
6926 -- [, [External =>] EXTERNAL_SYMBOL]
6927 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
6928 -- [, [Mechanism =>] MECHANISM]);
6930 -- EXTERNAL_SYMBOL ::=
6932 -- | static_string_EXPRESSION
6934 -- PARAMETER_TYPES ::=
6936 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6938 -- TYPE_DESIGNATOR ::=
6940 -- | subtype_Name ' Access
6944 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6946 -- MECHANISM_ASSOCIATION ::=
6947 -- [formal_parameter_NAME =>] MECHANISM_NAME
6949 -- MECHANISM_NAME ::=
6952 -- | Descriptor [([Class =>] CLASS_NAME)]
6954 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6956 when Pragma_Export_Procedure
=> Export_Procedure
: declare
6957 Args
: Args_List
(1 .. 4);
6958 Names
: constant Name_List
(1 .. 4) := (
6961 Name_Parameter_Types
,
6964 Internal
: Node_Id
renames Args
(1);
6965 External
: Node_Id
renames Args
(2);
6966 Parameter_Types
: Node_Id
renames Args
(3);
6967 Mechanism
: Node_Id
renames Args
(4);
6971 Gather_Associations
(Names
, Args
);
6972 Process_Extended_Import_Export_Subprogram_Pragma
(
6973 Arg_Internal
=> Internal
,
6974 Arg_External
=> External
,
6975 Arg_Parameter_Types
=> Parameter_Types
,
6976 Arg_Mechanism
=> Mechanism
);
6977 end Export_Procedure
;
6983 -- pragma Export_Value (
6984 -- [Value =>] static_integer_EXPRESSION,
6985 -- [Link_Name =>] static_string_EXPRESSION);
6987 when Pragma_Export_Value
=>
6989 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
6990 Check_Arg_Count
(2);
6992 Check_Optional_Identifier
(Arg1
, Name_Value
);
6993 Check_Arg_Is_Static_Expression
(Arg1
, Any_Integer
);
6995 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
6996 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
6998 -----------------------------
6999 -- Export_Valued_Procedure --
7000 -----------------------------
7002 -- pragma Export_Valued_Procedure (
7003 -- [Internal =>] LOCAL_NAME
7004 -- [, [External =>] EXTERNAL_SYMBOL,]
7005 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7006 -- [, [Mechanism =>] MECHANISM]);
7008 -- EXTERNAL_SYMBOL ::=
7010 -- | static_string_EXPRESSION
7012 -- PARAMETER_TYPES ::=
7014 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7016 -- TYPE_DESIGNATOR ::=
7018 -- | subtype_Name ' Access
7022 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7024 -- MECHANISM_ASSOCIATION ::=
7025 -- [formal_parameter_NAME =>] MECHANISM_NAME
7027 -- MECHANISM_NAME ::=
7030 -- | Descriptor [([Class =>] CLASS_NAME)]
7032 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7034 when Pragma_Export_Valued_Procedure
=>
7035 Export_Valued_Procedure
: declare
7036 Args
: Args_List
(1 .. 4);
7037 Names
: constant Name_List
(1 .. 4) := (
7040 Name_Parameter_Types
,
7043 Internal
: Node_Id
renames Args
(1);
7044 External
: Node_Id
renames Args
(2);
7045 Parameter_Types
: Node_Id
renames Args
(3);
7046 Mechanism
: Node_Id
renames Args
(4);
7050 Gather_Associations
(Names
, Args
);
7051 Process_Extended_Import_Export_Subprogram_Pragma
(
7052 Arg_Internal
=> Internal
,
7053 Arg_External
=> External
,
7054 Arg_Parameter_Types
=> Parameter_Types
,
7055 Arg_Mechanism
=> Mechanism
);
7056 end Export_Valued_Procedure
;
7062 -- pragma Extend_System ([Name =>] Identifier);
7064 when Pragma_Extend_System
=> Extend_System
: declare
7067 Check_Valid_Configuration_Pragma
;
7068 Check_Arg_Count
(1);
7069 Check_Optional_Identifier
(Arg1
, Name_Name
);
7070 Check_Arg_Is_Identifier
(Arg1
);
7072 Get_Name_String
(Chars
(Expression
(Arg1
)));
7075 and then Name_Buffer
(1 .. 4) = "aux_"
7077 if Present
(System_Extend_Pragma_Arg
) then
7078 if Chars
(Expression
(Arg1
)) =
7079 Chars
(Expression
(System_Extend_Pragma_Arg
))
7083 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
7084 Error_Pragma
("pragma% conflicts with that #");
7088 System_Extend_Pragma_Arg
:= Arg1
;
7090 if not GNAT_Mode
then
7091 System_Extend_Unit
:= Arg1
;
7095 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
7099 ------------------------
7100 -- Extensions_Allowed --
7101 ------------------------
7103 -- pragma Extensions_Allowed (ON | OFF);
7105 when Pragma_Extensions_Allowed
=>
7107 Check_Arg_Count
(1);
7108 Check_No_Identifiers
;
7109 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
7111 if Chars
(Expression
(Arg1
)) = Name_On
then
7112 Extensions_Allowed
:= True;
7114 Extensions_Allowed
:= False;
7121 -- pragma External (
7122 -- [ Convention =>] convention_IDENTIFIER,
7123 -- [ Entity =>] local_NAME
7124 -- [, [External_Name =>] static_string_EXPRESSION ]
7125 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7127 when Pragma_External
=> External
: declare
7131 pragma Warnings
(Off
, C
);
7140 Check_At_Least_N_Arguments
(2);
7141 Check_At_Most_N_Arguments
(4);
7142 Process_Convention
(C
, Def_Id
);
7143 Note_Possible_Modification
(Expression
(Arg2
), Sure
=> False);
7144 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
7145 Set_Exported
(Def_Id
, Arg2
);
7148 --------------------------
7149 -- External_Name_Casing --
7150 --------------------------
7152 -- pragma External_Name_Casing (
7153 -- UPPERCASE | LOWERCASE
7154 -- [, AS_IS | UPPERCASE | LOWERCASE]);
7156 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
7159 Check_No_Identifiers
;
7161 if Arg_Count
= 2 then
7163 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
7165 case Chars
(Get_Pragma_Arg
(Arg2
)) is
7167 Opt
.External_Name_Exp_Casing
:= As_Is
;
7169 when Name_Uppercase
=>
7170 Opt
.External_Name_Exp_Casing
:= Uppercase
;
7172 when Name_Lowercase
=>
7173 Opt
.External_Name_Exp_Casing
:= Lowercase
;
7180 Check_Arg_Count
(1);
7183 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
7185 case Chars
(Get_Pragma_Arg
(Arg1
)) is
7186 when Name_Uppercase
=>
7187 Opt
.External_Name_Imp_Casing
:= Uppercase
;
7189 when Name_Lowercase
=>
7190 Opt
.External_Name_Imp_Casing
:= Lowercase
;
7195 end External_Name_Casing
;
7197 --------------------------
7198 -- Favor_Top_Level --
7199 --------------------------
7201 -- pragma Favor_Top_Level (type_NAME);
7203 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
7204 Named_Entity
: Entity_Id
;
7208 Check_No_Identifiers
;
7209 Check_Arg_Count
(1);
7210 Check_Arg_Is_Local_Name
(Arg1
);
7211 Named_Entity
:= Entity
(Expression
(Arg1
));
7213 -- If it's an access-to-subprogram type (in particular, not a
7214 -- subtype), set the flag on that type.
7216 if Is_Access_Subprogram_Type
(Named_Entity
) then
7217 Set_Can_Use_Internal_Rep
(Named_Entity
, False);
7219 -- Otherwise it's an error (name denotes the wrong sort of entity)
7223 ("access-to-subprogram type expected", Expression
(Arg1
));
7225 end Favor_Top_Level
;
7231 -- pragma Fast_Math;
7233 when Pragma_Fast_Math
=>
7235 Check_No_Identifiers
;
7236 Check_Valid_Configuration_Pragma
;
7239 ---------------------------
7240 -- Finalize_Storage_Only --
7241 ---------------------------
7243 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
7245 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
7246 Assoc
: constant Node_Id
:= Arg1
;
7247 Type_Id
: constant Node_Id
:= Expression
(Assoc
);
7252 Check_No_Identifiers
;
7253 Check_Arg_Count
(1);
7254 Check_Arg_Is_Local_Name
(Arg1
);
7256 Find_Type
(Type_Id
);
7257 Typ
:= Entity
(Type_Id
);
7260 or else Rep_Item_Too_Early
(Typ
, N
)
7264 Typ
:= Underlying_Type
(Typ
);
7267 if not Is_Controlled
(Typ
) then
7268 Error_Pragma
("pragma% must specify controlled type");
7271 Check_First_Subtype
(Arg1
);
7273 if Finalize_Storage_Only
(Typ
) then
7274 Error_Pragma
("duplicate pragma%, only one allowed");
7276 elsif not Rep_Item_Too_Late
(Typ
, N
) then
7277 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
7279 end Finalize_Storage
;
7281 --------------------------
7282 -- Float_Representation --
7283 --------------------------
7285 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
7287 -- FLOAT_REP ::= VAX_Float | IEEE_Float
7289 when Pragma_Float_Representation
=> Float_Representation
: declare
7297 if Arg_Count
= 1 then
7298 Check_Valid_Configuration_Pragma
;
7300 Check_Arg_Count
(2);
7301 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7302 Check_Arg_Is_Local_Name
(Arg2
);
7305 Check_No_Identifier
(Arg1
);
7306 Check_Arg_Is_One_Of
(Arg1
, Name_VAX_Float
, Name_IEEE_Float
);
7308 if not OpenVMS_On_Target
then
7309 if Chars
(Expression
(Arg1
)) = Name_VAX_Float
then
7311 ("?pragma% ignored (applies only to Open'V'M'S)");
7317 -- One argument case
7319 if Arg_Count
= 1 then
7320 if Chars
(Expression
(Arg1
)) = Name_VAX_Float
then
7321 if Opt
.Float_Format
= 'I' then
7322 Error_Pragma
("'I'E'E'E format previously specified");
7325 Opt
.Float_Format
:= 'V';
7328 if Opt
.Float_Format
= 'V' then
7329 Error_Pragma
("'V'A'X format previously specified");
7332 Opt
.Float_Format
:= 'I';
7335 Set_Standard_Fpt_Formats
;
7337 -- Two argument case
7340 Argx
:= Get_Pragma_Arg
(Arg2
);
7342 if not Is_Entity_Name
(Argx
)
7343 or else not Is_Floating_Point_Type
(Entity
(Argx
))
7346 ("second argument of% pragma must be floating-point type",
7350 Ent
:= Entity
(Argx
);
7351 Digs
:= UI_To_Int
(Digits_Value
(Ent
));
7353 -- Two arguments, VAX_Float case
7355 if Chars
(Expression
(Arg1
)) = Name_VAX_Float
then
7357 when 6 => Set_F_Float
(Ent
);
7358 when 9 => Set_D_Float
(Ent
);
7359 when 15 => Set_G_Float
(Ent
);
7363 ("wrong digits value, must be 6,9 or 15", Arg2
);
7366 -- Two arguments, IEEE_Float case
7370 when 6 => Set_IEEE_Short
(Ent
);
7371 when 15 => Set_IEEE_Long
(Ent
);
7375 ("wrong digits value, must be 6 or 15", Arg2
);
7379 end Float_Representation
;
7385 -- pragma Ident (static_string_EXPRESSION)
7387 -- Note: pragma Comment shares this processing. Pragma Comment
7388 -- is identical to Ident, except that the restriction of the
7389 -- argument to 31 characters and the placement restrictions
7390 -- are not enforced for pragma Comment.
7392 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
7397 Check_Arg_Count
(1);
7398 Check_No_Identifiers
;
7399 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
7401 -- For pragma Ident, preserve DEC compatibility by requiring
7402 -- the pragma to appear in a declarative part or package spec.
7404 if Prag_Id
= Pragma_Ident
then
7405 Check_Is_In_Decl_Part_Or_Package_Spec
;
7408 Str
:= Expr_Value_S
(Expression
(Arg1
));
7415 GP
:= Parent
(Parent
(N
));
7417 if Nkind
(GP
) = N_Package_Declaration
7419 Nkind
(GP
) = N_Generic_Package_Declaration
7424 -- If we have a compilation unit, then record the ident
7425 -- value, checking for improper duplication.
7427 if Nkind
(GP
) = N_Compilation_Unit
then
7428 CS
:= Ident_String
(Current_Sem_Unit
);
7430 if Present
(CS
) then
7432 -- For Ident, we do not permit multiple instances
7434 if Prag_Id
= Pragma_Ident
then
7435 Error_Pragma
("duplicate% pragma not permitted");
7437 -- For Comment, we concatenate the string, unless we
7438 -- want to preserve the tree structure for ASIS.
7440 elsif not ASIS_Mode
then
7441 Start_String
(Strval
(CS
));
7442 Store_String_Char
(' ');
7443 Store_String_Chars
(Strval
(Str
));
7444 Set_Strval
(CS
, End_String
);
7448 -- In VMS, the effect of IDENT is achieved by passing
7449 -- IDENTIFICATION=name as a --for-linker switch.
7451 if OpenVMS_On_Target
then
7454 ("--for-linker=IDENTIFICATION=");
7455 String_To_Name_Buffer
(Strval
(Str
));
7456 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
7458 -- Only the last processed IDENT is saved. The main
7459 -- purpose is so an IDENT associated with a main
7460 -- procedure will be used in preference to an IDENT
7461 -- associated with a with'd package.
7463 Replace_Linker_Option_String
7464 (End_String
, "--for-linker=IDENTIFICATION=");
7467 Set_Ident_String
(Current_Sem_Unit
, Str
);
7470 -- For subunits, we just ignore the Ident, since in GNAT
7471 -- these are not separate object files, and hence not
7472 -- separate units in the unit table.
7474 elsif Nkind
(GP
) = N_Subunit
then
7477 -- Otherwise we have a misplaced pragma Ident, but we ignore
7478 -- this if we are in an instantiation, since it comes from
7479 -- a generic, and has no relevance to the instantiation.
7481 elsif Prag_Id
= Pragma_Ident
then
7482 if Instantiation_Location
(Loc
) = No_Location
then
7483 Error_Pragma
("pragma% only allowed at outer level");
7489 --------------------------
7490 -- Implemented_By_Entry --
7491 --------------------------
7493 -- pragma Implemented_By_Entry (DIRECT_NAME);
7495 when Pragma_Implemented_By_Entry
=> Implemented_By_Entry
: declare
7500 Check_Arg_Count
(1);
7501 Check_No_Identifiers
;
7502 Check_Arg_Is_Identifier
(Arg1
);
7503 Check_Arg_Is_Local_Name
(Arg1
);
7504 Ent
:= Entity
(Expression
(Arg1
));
7506 -- Pragma Implemented_By_Entry must be applied only to protected
7507 -- synchronized or task interface primitives.
7509 if (Ekind
(Ent
) /= E_Function
7510 and then Ekind
(Ent
) /= E_Procedure
)
7511 or else not Present
(First_Formal
(Ent
))
7512 or else not Is_Concurrent_Interface
(Etype
(First_Formal
(Ent
)))
7515 ("pragma % must be applied to a concurrent interface " &
7519 if Einfo
.Implemented_By_Entry
(Ent
)
7520 and then Warn_On_Redundant_Constructs
7522 Error_Pragma
("?duplicate pragma%!");
7524 Set_Implemented_By_Entry
(Ent
);
7527 end Implemented_By_Entry
;
7529 -----------------------
7530 -- Implicit_Packing --
7531 -----------------------
7533 -- pragma Implicit_Packing;
7535 when Pragma_Implicit_Packing
=>
7537 Check_Arg_Count
(0);
7538 Implicit_Packing
:= True;
7545 -- [Convention =>] convention_IDENTIFIER,
7546 -- [Entity =>] local_NAME
7547 -- [, [External_Name =>] static_string_EXPRESSION ]
7548 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7550 when Pragma_Import
=>
7551 Check_Ada_83_Warning
;
7557 Check_At_Least_N_Arguments
(2);
7558 Check_At_Most_N_Arguments
(4);
7559 Process_Import_Or_Interface
;
7561 ----------------------
7562 -- Import_Exception --
7563 ----------------------
7565 -- pragma Import_Exception (
7566 -- [Internal =>] LOCAL_NAME
7567 -- [, [External =>] EXTERNAL_SYMBOL]
7568 -- [, [Form =>] Ada | VMS]
7569 -- [, [Code =>] static_integer_EXPRESSION]);
7571 when Pragma_Import_Exception
=> Import_Exception
: declare
7572 Args
: Args_List
(1 .. 4);
7573 Names
: constant Name_List
(1 .. 4) := (
7579 Internal
: Node_Id
renames Args
(1);
7580 External
: Node_Id
renames Args
(2);
7581 Form
: Node_Id
renames Args
(3);
7582 Code
: Node_Id
renames Args
(4);
7586 Gather_Associations
(Names
, Args
);
7588 if Present
(External
) and then Present
(Code
) then
7590 ("cannot give both External and Code options for pragma%");
7593 Process_Extended_Import_Export_Exception_Pragma
(
7594 Arg_Internal
=> Internal
,
7595 Arg_External
=> External
,
7599 if not Is_VMS_Exception
(Entity
(Internal
)) then
7600 Set_Imported
(Entity
(Internal
));
7602 end Import_Exception
;
7604 ---------------------
7605 -- Import_Function --
7606 ---------------------
7608 -- pragma Import_Function (
7609 -- [Internal =>] LOCAL_NAME,
7610 -- [, [External =>] EXTERNAL_SYMBOL]
7611 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7612 -- [, [Result_Type =>] SUBTYPE_MARK]
7613 -- [, [Mechanism =>] MECHANISM]
7614 -- [, [Result_Mechanism =>] MECHANISM_NAME]
7615 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
7617 -- EXTERNAL_SYMBOL ::=
7619 -- | static_string_EXPRESSION
7621 -- PARAMETER_TYPES ::=
7623 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7625 -- TYPE_DESIGNATOR ::=
7627 -- | subtype_Name ' Access
7631 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7633 -- MECHANISM_ASSOCIATION ::=
7634 -- [formal_parameter_NAME =>] MECHANISM_NAME
7636 -- MECHANISM_NAME ::=
7639 -- | Descriptor [([Class =>] CLASS_NAME)]
7641 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7643 when Pragma_Import_Function
=> Import_Function
: declare
7644 Args
: Args_List
(1 .. 7);
7645 Names
: constant Name_List
(1 .. 7) := (
7648 Name_Parameter_Types
,
7651 Name_Result_Mechanism
,
7652 Name_First_Optional_Parameter
);
7654 Internal
: Node_Id
renames Args
(1);
7655 External
: Node_Id
renames Args
(2);
7656 Parameter_Types
: Node_Id
renames Args
(3);
7657 Result_Type
: Node_Id
renames Args
(4);
7658 Mechanism
: Node_Id
renames Args
(5);
7659 Result_Mechanism
: Node_Id
renames Args
(6);
7660 First_Optional_Parameter
: Node_Id
renames Args
(7);
7664 Gather_Associations
(Names
, Args
);
7665 Process_Extended_Import_Export_Subprogram_Pragma
(
7666 Arg_Internal
=> Internal
,
7667 Arg_External
=> External
,
7668 Arg_Parameter_Types
=> Parameter_Types
,
7669 Arg_Result_Type
=> Result_Type
,
7670 Arg_Mechanism
=> Mechanism
,
7671 Arg_Result_Mechanism
=> Result_Mechanism
,
7672 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
7673 end Import_Function
;
7679 -- pragma Import_Object (
7680 -- [Internal =>] LOCAL_NAME
7681 -- [, [External =>] EXTERNAL_SYMBOL]
7682 -- [, [Size =>] EXTERNAL_SYMBOL]);
7684 -- EXTERNAL_SYMBOL ::=
7686 -- | static_string_EXPRESSION
7688 when Pragma_Import_Object
=> Import_Object
: declare
7689 Args
: Args_List
(1 .. 3);
7690 Names
: constant Name_List
(1 .. 3) := (
7695 Internal
: Node_Id
renames Args
(1);
7696 External
: Node_Id
renames Args
(2);
7697 Size
: Node_Id
renames Args
(3);
7701 Gather_Associations
(Names
, Args
);
7702 Process_Extended_Import_Export_Object_Pragma
(
7703 Arg_Internal
=> Internal
,
7704 Arg_External
=> External
,
7708 ----------------------
7709 -- Import_Procedure --
7710 ----------------------
7712 -- pragma Import_Procedure (
7713 -- [Internal =>] LOCAL_NAME
7714 -- [, [External =>] EXTERNAL_SYMBOL]
7715 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7716 -- [, [Mechanism =>] MECHANISM]
7717 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
7719 -- EXTERNAL_SYMBOL ::=
7721 -- | static_string_EXPRESSION
7723 -- PARAMETER_TYPES ::=
7725 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7727 -- TYPE_DESIGNATOR ::=
7729 -- | subtype_Name ' Access
7733 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7735 -- MECHANISM_ASSOCIATION ::=
7736 -- [formal_parameter_NAME =>] MECHANISM_NAME
7738 -- MECHANISM_NAME ::=
7741 -- | Descriptor [([Class =>] CLASS_NAME)]
7743 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7745 when Pragma_Import_Procedure
=> Import_Procedure
: declare
7746 Args
: Args_List
(1 .. 5);
7747 Names
: constant Name_List
(1 .. 5) := (
7750 Name_Parameter_Types
,
7752 Name_First_Optional_Parameter
);
7754 Internal
: Node_Id
renames Args
(1);
7755 External
: Node_Id
renames Args
(2);
7756 Parameter_Types
: Node_Id
renames Args
(3);
7757 Mechanism
: Node_Id
renames Args
(4);
7758 First_Optional_Parameter
: Node_Id
renames Args
(5);
7762 Gather_Associations
(Names
, Args
);
7763 Process_Extended_Import_Export_Subprogram_Pragma
(
7764 Arg_Internal
=> Internal
,
7765 Arg_External
=> External
,
7766 Arg_Parameter_Types
=> Parameter_Types
,
7767 Arg_Mechanism
=> Mechanism
,
7768 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
7769 end Import_Procedure
;
7771 -----------------------------
7772 -- Import_Valued_Procedure --
7773 -----------------------------
7775 -- pragma Import_Valued_Procedure (
7776 -- [Internal =>] LOCAL_NAME
7777 -- [, [External =>] EXTERNAL_SYMBOL]
7778 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7779 -- [, [Mechanism =>] MECHANISM]
7780 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
7782 -- EXTERNAL_SYMBOL ::=
7784 -- | static_string_EXPRESSION
7786 -- PARAMETER_TYPES ::=
7788 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7790 -- TYPE_DESIGNATOR ::=
7792 -- | subtype_Name ' Access
7796 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7798 -- MECHANISM_ASSOCIATION ::=
7799 -- [formal_parameter_NAME =>] MECHANISM_NAME
7801 -- MECHANISM_NAME ::=
7804 -- | Descriptor [([Class =>] CLASS_NAME)]
7806 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7808 when Pragma_Import_Valued_Procedure
=>
7809 Import_Valued_Procedure
: declare
7810 Args
: Args_List
(1 .. 5);
7811 Names
: constant Name_List
(1 .. 5) := (
7814 Name_Parameter_Types
,
7816 Name_First_Optional_Parameter
);
7818 Internal
: Node_Id
renames Args
(1);
7819 External
: Node_Id
renames Args
(2);
7820 Parameter_Types
: Node_Id
renames Args
(3);
7821 Mechanism
: Node_Id
renames Args
(4);
7822 First_Optional_Parameter
: Node_Id
renames Args
(5);
7826 Gather_Associations
(Names
, Args
);
7827 Process_Extended_Import_Export_Subprogram_Pragma
(
7828 Arg_Internal
=> Internal
,
7829 Arg_External
=> External
,
7830 Arg_Parameter_Types
=> Parameter_Types
,
7831 Arg_Mechanism
=> Mechanism
,
7832 Arg_First_Optional_Parameter
=> First_Optional_Parameter
);
7833 end Import_Valued_Procedure
;
7835 ------------------------
7836 -- Initialize_Scalars --
7837 ------------------------
7839 -- pragma Initialize_Scalars;
7841 when Pragma_Initialize_Scalars
=>
7843 Check_Arg_Count
(0);
7844 Check_Valid_Configuration_Pragma
;
7845 Check_Restriction
(No_Initialize_Scalars
, N
);
7847 if not Restriction_Active
(No_Initialize_Scalars
) then
7848 Init_Or_Norm_Scalars
:= True;
7849 Initialize_Scalars
:= True;
7856 -- pragma Inline ( NAME {, NAME} );
7858 when Pragma_Inline
=>
7860 -- Pragma is active if inlining option is active
7862 Process_Inline
(Inline_Active
);
7868 -- pragma Inline_Always ( NAME {, NAME} );
7870 when Pragma_Inline_Always
=>
7872 Process_Inline
(True);
7874 --------------------
7875 -- Inline_Generic --
7876 --------------------
7878 -- pragma Inline_Generic (NAME {, NAME});
7880 when Pragma_Inline_Generic
=>
7882 Process_Generic_List
;
7884 ----------------------
7885 -- Inspection_Point --
7886 ----------------------
7888 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
7890 when Pragma_Inspection_Point
=> Inspection_Point
: declare
7895 if Arg_Count
> 0 then
7898 Exp
:= Expression
(Arg
);
7901 if not Is_Entity_Name
(Exp
)
7902 or else not Is_Object
(Entity
(Exp
))
7904 Error_Pragma_Arg
("object name required", Arg
);
7911 end Inspection_Point
;
7917 -- pragma Interface (
7918 -- [ Convention =>] convention_IDENTIFIER,
7919 -- [ Entity =>] local_NAME
7920 -- [, [External_Name =>] static_string_EXPRESSION ]
7921 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7923 when Pragma_Interface
=>
7930 Check_At_Least_N_Arguments
(2);
7931 Check_At_Most_N_Arguments
(4);
7932 Process_Import_Or_Interface
;
7934 --------------------
7935 -- Interface_Name --
7936 --------------------
7938 -- pragma Interface_Name (
7939 -- [ Entity =>] local_NAME
7940 -- [,[External_Name =>] static_string_EXPRESSION ]
7941 -- [,[Link_Name =>] static_string_EXPRESSION ]);
7943 when Pragma_Interface_Name
=> Interface_Name
: declare
7952 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
7953 Check_At_Least_N_Arguments
(2);
7954 Check_At_Most_N_Arguments
(3);
7955 Id
:= Expression
(Arg1
);
7958 if not Is_Entity_Name
(Id
) then
7960 ("first argument for pragma% must be entity name", Arg1
);
7961 elsif Etype
(Id
) = Any_Type
then
7964 Def_Id
:= Entity
(Id
);
7967 -- Special DEC-compatible processing for the object case, forces
7968 -- object to be imported.
7970 if Ekind
(Def_Id
) = E_Variable
then
7971 Kill_Size_Check_Code
(Def_Id
);
7972 Note_Possible_Modification
(Id
, Sure
=> False);
7974 -- Initialization is not allowed for imported variable
7976 if Present
(Expression
(Parent
(Def_Id
)))
7977 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
7979 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7981 ("no initialization allowed for declaration of& #",
7985 -- For compatibility, support VADS usage of providing both
7986 -- pragmas Interface and Interface_Name to obtain the effect
7987 -- of a single Import pragma.
7989 if Is_Imported
(Def_Id
)
7990 and then Present
(First_Rep_Item
(Def_Id
))
7991 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
7993 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
7997 Set_Imported
(Def_Id
);
8000 Set_Is_Public
(Def_Id
);
8001 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
8004 -- Otherwise must be subprogram
8006 elsif not Is_Subprogram
(Def_Id
) then
8008 ("argument of pragma% is not subprogram", Arg1
);
8011 Check_At_Most_N_Arguments
(3);
8015 -- Loop through homonyms
8018 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8020 if Is_Imported
(Def_Id
) then
8021 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
8025 Hom_Id
:= Homonym
(Hom_Id
);
8027 exit when No
(Hom_Id
)
8028 or else Scope
(Hom_Id
) /= Current_Scope
;
8033 ("argument of pragma% is not imported subprogram",
8039 -----------------------
8040 -- Interrupt_Handler --
8041 -----------------------
8043 -- pragma Interrupt_Handler (handler_NAME);
8045 when Pragma_Interrupt_Handler
=>
8046 Check_Ada_83_Warning
;
8047 Check_Arg_Count
(1);
8048 Check_No_Identifiers
;
8050 if No_Run_Time_Mode
then
8051 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
8053 Check_Interrupt_Or_Attach_Handler
;
8054 Process_Interrupt_Or_Attach_Handler
;
8057 ------------------------
8058 -- Interrupt_Priority --
8059 ------------------------
8061 -- pragma Interrupt_Priority [(EXPRESSION)];
8063 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
8064 P
: constant Node_Id
:= Parent
(N
);
8068 Check_Ada_83_Warning
;
8070 if Arg_Count
/= 0 then
8071 Arg
:= Expression
(Arg1
);
8072 Check_Arg_Count
(1);
8073 Check_No_Identifiers
;
8075 -- The expression must be analyzed in the special manner
8076 -- described in "Handling of Default and Per-Object
8077 -- Expressions" in sem.ads.
8079 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
8082 if Nkind
(P
) /= N_Task_Definition
8083 and then Nkind
(P
) /= N_Protected_Definition
8088 elsif Has_Priority_Pragma
(P
) then
8089 Error_Pragma
("duplicate pragma% not allowed");
8092 Set_Has_Priority_Pragma
(P
, True);
8093 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
8095 end Interrupt_Priority
;
8097 ---------------------
8098 -- Interrupt_State --
8099 ---------------------
8101 -- pragma Interrupt_State (
8102 -- [Name =>] INTERRUPT_ID,
8103 -- [State =>] INTERRUPT_STATE);
8105 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
8106 -- INTERRUPT_STATE => System | Runtime | User
8108 -- Note: if the interrupt id is given as an identifier, then
8109 -- it must be one of the identifiers in Ada.Interrupts.Names.
8110 -- Otherwise it is given as a static integer expression which
8111 -- must be in the range of Ada.Interrupts.Interrupt_ID.
8113 when Pragma_Interrupt_State
=> Interrupt_State
: declare
8115 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
8116 -- This is the entity Ada.Interrupts.Interrupt_ID;
8118 State_Type
: Character;
8119 -- Set to 's'/'r'/'u' for System/Runtime/User
8122 -- Index to entry in Interrupt_States table
8125 -- Value of interrupt
8127 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8128 -- The first argument to the pragma
8130 Int_Ent
: Entity_Id
;
8131 -- Interrupt entity in Ada.Interrupts.Names
8135 Check_Arg_Order
((Name_Name
, Name_State
));
8136 Check_Arg_Count
(2);
8138 Check_Optional_Identifier
(Arg1
, Name_Name
);
8139 Check_Optional_Identifier
(Arg2
, Name_State
);
8140 Check_Arg_Is_Identifier
(Arg2
);
8142 -- First argument is identifier
8144 if Nkind
(Arg1X
) = N_Identifier
then
8146 -- Search list of names in Ada.Interrupts.Names
8148 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
8150 if No
(Int_Ent
) then
8151 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
8153 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
8154 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
8158 Next_Entity
(Int_Ent
);
8161 -- First argument is not an identifier, so it must be a
8162 -- static expression of type Ada.Interrupts.Interrupt_ID.
8165 Check_Arg_Is_Static_Expression
(Arg1
, Any_Integer
);
8166 Int_Val
:= Expr_Value
(Arg1X
);
8168 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
8170 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
8173 ("value not in range of type " &
8174 """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
8180 case Chars
(Get_Pragma_Arg
(Arg2
)) is
8181 when Name_Runtime
=> State_Type
:= 'r';
8182 when Name_System
=> State_Type
:= 's';
8183 when Name_User
=> State_Type
:= 'u';
8186 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
8189 -- Check if entry is already stored
8191 IST_Num
:= Interrupt_States
.First
;
8193 -- If entry not found, add it
8195 if IST_Num
> Interrupt_States
.Last
then
8196 Interrupt_States
.Append
8197 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
8198 Interrupt_State
=> State_Type
,
8199 Pragma_Loc
=> Loc
));
8202 -- Case of entry for the same entry
8204 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
8207 -- If state matches, done, no need to make redundant entry
8210 State_Type
= Interrupt_States
.Table
(IST_Num
).
8213 -- Otherwise if state does not match, error
8216 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
8218 ("state conflicts with that given #", Arg2
);
8222 IST_Num
:= IST_Num
+ 1;
8224 end Interrupt_State
;
8226 ----------------------
8227 -- Java_Constructor --
8228 ----------------------
8230 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
8232 -- Also handles pragma CIL_Constructor
8234 when Pragma_CIL_Constructor | Pragma_Java_Constructor
=>
8235 Java_Constructor
: declare
8239 Convention
: Convention_Id
;
8243 Check_Arg_Count
(1);
8244 Check_Optional_Identifier
(Arg1
, Name_Entity
);
8245 Check_Arg_Is_Local_Name
(Arg1
);
8247 Id
:= Expression
(Arg1
);
8248 Find_Program_Unit_Name
(Id
);
8250 -- If we did not find the name, we are done
8252 if Etype
(Id
) = Any_Type
then
8257 when Pragma_CIL_Constructor
=> Convention
:= Convention_CIL
;
8258 when Pragma_Java_Constructor
=> Convention
:= Convention_Java
;
8259 when others => null;
8262 Hom_Id
:= Entity
(Id
);
8264 -- Loop through homonyms
8267 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8269 -- The constructor is required to be a function returning an
8270 -- access type whose designated type has convention Java/CIL.
8272 if Ekind
(Def_Id
) = E_Function
8274 (Is_Value_Type
(Etype
(Def_Id
))
8276 (Ekind
(Etype
(Def_Id
)) in Access_Kind
8279 (Designated_Type
(Etype
(Def_Id
))) = Convention
8282 (Root_Type
(Designated_Type
(Etype
(Def_Id
)))) =
8285 Set_Is_Constructor
(Def_Id
);
8286 Set_Convention
(Def_Id
, Convention
);
8287 Set_Is_Imported
(Def_Id
);
8290 if Convention
= Convention_Java
then
8292 ("pragma% requires function returning a " &
8293 "'Java access type", Arg1
);
8295 pragma Assert
(Convention
= Convention_CIL
);
8297 ("pragma% requires function returning a " &
8298 "'CIL access type", Arg1
);
8302 Hom_Id
:= Homonym
(Hom_Id
);
8304 exit when No
(Hom_Id
) or else Scope
(Hom_Id
) /= Current_Scope
;
8306 end Java_Constructor
;
8308 ----------------------
8309 -- Java_Interface --
8310 ----------------------
8312 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
8314 when Pragma_Java_Interface
=> Java_Interface
: declare
8320 Check_Arg_Count
(1);
8321 Check_Optional_Identifier
(Arg1
, Name_Entity
);
8322 Check_Arg_Is_Local_Name
(Arg1
);
8324 Arg
:= Expression
(Arg1
);
8327 if Etype
(Arg
) = Any_Type
then
8331 if not Is_Entity_Name
(Arg
)
8332 or else not Is_Type
(Entity
(Arg
))
8334 Error_Pragma_Arg
("pragma% requires a type mark", Arg1
);
8337 Typ
:= Underlying_Type
(Entity
(Arg
));
8339 -- For now we simply check some of the semantic constraints
8340 -- on the type. This currently leaves out some restrictions
8341 -- on interface types, namely that the parent type must be
8342 -- java.lang.Object.Typ and that all primitives of the type
8343 -- should be declared abstract. ???
8345 if not Is_Tagged_Type
(Typ
) or else not Is_Abstract_Type
(Typ
) then
8346 Error_Pragma_Arg
("pragma% requires an abstract "
8347 & "tagged type", Arg1
);
8349 elsif not Has_Discriminants
(Typ
)
8350 or else Ekind
(Etype
(First_Discriminant
(Typ
)))
8351 /= E_Anonymous_Access_Type
8353 not Is_Class_Wide_Type
8354 (Designated_Type
(Etype
(First_Discriminant
(Typ
))))
8357 ("type must have a class-wide access discriminant", Arg1
);
8365 -- pragma Keep_Names ([On => ] local_NAME);
8367 when Pragma_Keep_Names
=> Keep_Names
: declare
8372 Check_Arg_Count
(1);
8373 Check_Optional_Identifier
(Arg1
, Name_On
);
8374 Check_Arg_Is_Local_Name
(Arg1
);
8376 Arg
:= Expression
(Arg1
);
8379 if Etype
(Arg
) = Any_Type
then
8383 if not Is_Entity_Name
(Arg
)
8384 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
8387 ("pragma% requires a local enumeration type", Arg1
);
8390 Set_Discard_Names
(Entity
(Arg
), False);
8397 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
8399 when Pragma_License
=>
8401 Check_Arg_Count
(1);
8402 Check_No_Identifiers
;
8403 Check_Valid_Configuration_Pragma
;
8404 Check_Arg_Is_Identifier
(Arg1
);
8407 Sind
: constant Source_File_Index
:=
8408 Source_Index
(Current_Sem_Unit
);
8411 case Chars
(Get_Pragma_Arg
(Arg1
)) is
8413 Set_License
(Sind
, GPL
);
8415 when Name_Modified_GPL
=>
8416 Set_License
(Sind
, Modified_GPL
);
8418 when Name_Restricted
=>
8419 Set_License
(Sind
, Restricted
);
8421 when Name_Unrestricted
=>
8422 Set_License
(Sind
, Unrestricted
);
8425 Error_Pragma_Arg
("invalid license name", Arg1
);
8433 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
8435 when Pragma_Link_With
=> Link_With
: declare
8441 if Operating_Mode
= Generate_Code
8442 and then In_Extended_Main_Source_Unit
(N
)
8444 Check_At_Least_N_Arguments
(1);
8445 Check_No_Identifiers
;
8446 Check_Is_In_Decl_Part_Or_Package_Spec
;
8447 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
8451 while Present
(Arg
) loop
8452 Check_Arg_Is_Static_Expression
(Arg
, Standard_String
);
8454 -- Store argument, converting sequences of spaces
8455 -- to a single null character (this is one of the
8456 -- differences in processing between Link_With
8457 -- and Linker_Options).
8460 C
: constant Char_Code
:= Get_Char_Code
(' ');
8461 S
: constant String_Id
:=
8462 Strval
(Expr_Value_S
(Expression
(Arg
)));
8463 L
: constant Nat
:= String_Length
(S
);
8466 procedure Skip_Spaces
;
8467 -- Advance F past any spaces
8473 procedure Skip_Spaces
is
8475 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
8480 -- Start of processing for Arg_Store
8483 Skip_Spaces
; -- skip leading spaces
8485 -- Loop through characters, changing any embedded
8486 -- sequence of spaces to a single null character
8487 -- (this is how Link_With/Linker_Options differ)
8490 if Get_String_Char
(S
, F
) = C
then
8493 Store_String_Char
(ASCII
.NUL
);
8496 Store_String_Char
(Get_String_Char
(S
, F
));
8504 if Present
(Arg
) then
8505 Store_String_Char
(ASCII
.NUL
);
8509 Store_Linker_Option_String
(End_String
);
8517 -- pragma Linker_Alias (
8518 -- [Entity =>] LOCAL_NAME
8519 -- [Target =>] static_string_EXPRESSION);
8521 when Pragma_Linker_Alias
=>
8523 Check_Arg_Order
((Name_Entity
, Name_Target
));
8524 Check_Arg_Count
(2);
8525 Check_Optional_Identifier
(Arg1
, Name_Entity
);
8526 Check_Optional_Identifier
(Arg2
, Name_Target
);
8527 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
8528 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
8530 -- The only processing required is to link this item on to the
8531 -- list of rep items for the given entity. This is accomplished
8532 -- by the call to Rep_Item_Too_Late (when no error is detected
8533 -- and False is returned).
8535 if Rep_Item_Too_Late
(Entity
(Expression
(Arg1
)), N
) then
8538 Set_Has_Gigi_Rep_Item
(Entity
(Expression
(Arg1
)));
8541 ------------------------
8542 -- Linker_Constructor --
8543 ------------------------
8545 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
8547 -- Code is shared with Linker_Destructor
8549 -----------------------
8550 -- Linker_Destructor --
8551 -----------------------
8553 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
8555 when Pragma_Linker_Constructor |
8556 Pragma_Linker_Destructor
=>
8557 Linker_Constructor
: declare
8563 Check_Arg_Count
(1);
8564 Check_No_Identifiers
;
8565 Check_Arg_Is_Local_Name
(Arg1
);
8566 Arg1_X
:= Expression
(Arg1
);
8568 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
8570 if not Is_Library_Level_Entity
(Proc
) then
8572 ("argument for pragma% must be library level entity", Arg1
);
8575 -- The only processing required is to link this item on to the
8576 -- list of rep items for the given entity. This is accomplished
8577 -- by the call to Rep_Item_Too_Late (when no error is detected
8578 -- and False is returned).
8580 if Rep_Item_Too_Late
(Proc
, N
) then
8583 Set_Has_Gigi_Rep_Item
(Proc
);
8585 end Linker_Constructor
;
8587 --------------------
8588 -- Linker_Options --
8589 --------------------
8591 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
8593 when Pragma_Linker_Options
=> Linker_Options
: declare
8597 Check_Ada_83_Warning
;
8598 Check_No_Identifiers
;
8599 Check_Arg_Count
(1);
8600 Check_Is_In_Decl_Part_Or_Package_Spec
;
8601 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
8602 Start_String
(Strval
(Expr_Value_S
(Expression
(Arg1
))));
8605 while Present
(Arg
) loop
8606 Check_Arg_Is_Static_Expression
(Arg
, Standard_String
);
8607 Store_String_Char
(ASCII
.NUL
);
8608 Store_String_Chars
(Strval
(Expr_Value_S
(Expression
(Arg
))));
8612 if Operating_Mode
= Generate_Code
8613 and then In_Extended_Main_Source_Unit
(N
)
8615 Store_Linker_Option_String
(End_String
);
8619 --------------------
8620 -- Linker_Section --
8621 --------------------
8623 -- pragma Linker_Section (
8624 -- [Entity =>] LOCAL_NAME
8625 -- [Section =>] static_string_EXPRESSION);
8627 when Pragma_Linker_Section
=>
8629 Check_Arg_Order
((Name_Entity
, Name_Section
));
8630 Check_Arg_Count
(2);
8631 Check_Optional_Identifier
(Arg1
, Name_Entity
);
8632 Check_Optional_Identifier
(Arg2
, Name_Section
);
8633 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
8634 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
8636 -- This pragma applies only to objects
8638 if not Is_Object
(Entity
(Expression
(Arg1
))) then
8639 Error_Pragma_Arg
("pragma% applies only to objects", Arg1
);
8642 -- The only processing required is to link this item on to the
8643 -- list of rep items for the given entity. This is accomplished
8644 -- by the call to Rep_Item_Too_Late (when no error is detected
8645 -- and False is returned).
8647 if Rep_Item_Too_Late
(Entity
(Expression
(Arg1
)), N
) then
8650 Set_Has_Gigi_Rep_Item
(Entity
(Expression
(Arg1
)));
8657 -- pragma List (On | Off)
8659 -- There is nothing to do here, since we did all the processing
8660 -- for this pragma in Par.Prag (so that it works properly even in
8661 -- syntax only mode)
8666 --------------------
8667 -- Locking_Policy --
8668 --------------------
8670 -- pragma Locking_Policy (policy_IDENTIFIER);
8672 when Pragma_Locking_Policy
=> declare
8676 Check_Ada_83_Warning
;
8677 Check_Arg_Count
(1);
8678 Check_No_Identifiers
;
8679 Check_Arg_Is_Locking_Policy
(Arg1
);
8680 Check_Valid_Configuration_Pragma
;
8681 Get_Name_String
(Chars
(Expression
(Arg1
)));
8682 LP
:= Fold_Upper
(Name_Buffer
(1));
8684 if Locking_Policy
/= ' '
8685 and then Locking_Policy
/= LP
8687 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
8688 Error_Pragma
("locking policy incompatible with policy#");
8690 -- Set new policy, but always preserve System_Location since
8691 -- we like the error message with the run time name.
8694 Locking_Policy
:= LP
;
8696 if Locking_Policy_Sloc
/= System_Location
then
8697 Locking_Policy_Sloc
:= Loc
;
8706 -- pragma Long_Float (D_Float | G_Float);
8708 when Pragma_Long_Float
=>
8710 Check_Valid_Configuration_Pragma
;
8711 Check_Arg_Count
(1);
8712 Check_No_Identifier
(Arg1
);
8713 Check_Arg_Is_One_Of
(Arg1
, Name_D_Float
, Name_G_Float
);
8715 if not OpenVMS_On_Target
then
8716 Error_Pragma
("?pragma% ignored (applies only to Open'V'M'S)");
8721 if Chars
(Expression
(Arg1
)) = Name_D_Float
then
8722 if Opt
.Float_Format_Long
= 'G' then
8723 Error_Pragma
("G_Float previously specified");
8726 Opt
.Float_Format_Long
:= 'D';
8728 -- G_Float case (this is the default, does not need overriding)
8731 if Opt
.Float_Format_Long
= 'D' then
8732 Error_Pragma
("D_Float previously specified");
8735 Opt
.Float_Format_Long
:= 'G';
8738 Set_Standard_Fpt_Formats
;
8740 -----------------------
8741 -- Machine_Attribute --
8742 -----------------------
8744 -- pragma Machine_Attribute (
8745 -- [Entity =>] LOCAL_NAME,
8746 -- [Attribute_Name =>] static_string_EXPRESSION
8747 -- [, [Info =>] static_string_EXPRESSION] );
8749 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
8754 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
8756 if Arg_Count
= 3 then
8757 Check_Optional_Identifier
(Arg3
, Name_Info
);
8758 Check_Arg_Is_Static_Expression
(Arg3
, Standard_String
);
8760 Check_Arg_Count
(2);
8763 Check_Optional_Identifier
(Arg1
, Name_Entity
);
8764 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
8765 Check_Arg_Is_Local_Name
(Arg1
);
8766 Check_Arg_Is_Static_Expression
(Arg2
, Standard_String
);
8767 Def_Id
:= Entity
(Expression
(Arg1
));
8769 if Is_Access_Type
(Def_Id
) then
8770 Def_Id
:= Designated_Type
(Def_Id
);
8773 if Rep_Item_Too_Early
(Def_Id
, N
) then
8777 Def_Id
:= Underlying_Type
(Def_Id
);
8779 -- The only processing required is to link this item on to the
8780 -- list of rep items for the given entity. This is accomplished
8781 -- by the call to Rep_Item_Too_Late (when no error is detected
8782 -- and False is returned).
8784 if Rep_Item_Too_Late
(Def_Id
, N
) then
8787 Set_Has_Gigi_Rep_Item
(Entity
(Expression
(Arg1
)));
8789 end Machine_Attribute
;
8796 -- (MAIN_OPTION [, MAIN_OPTION]);
8799 -- [STACK_SIZE =>] static_integer_EXPRESSION
8800 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
8801 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
8803 when Pragma_Main
=> Main
: declare
8804 Args
: Args_List
(1 .. 3);
8805 Names
: constant Name_List
(1 .. 3) := (
8807 Name_Task_Stack_Size_Default
,
8808 Name_Time_Slicing_Enabled
);
8814 Gather_Associations
(Names
, Args
);
8816 for J
in 1 .. 2 loop
8817 if Present
(Args
(J
)) then
8818 Check_Arg_Is_Static_Expression
(Args
(J
), Any_Integer
);
8822 if Present
(Args
(3)) then
8823 Check_Arg_Is_Static_Expression
(Args
(3), Standard_Boolean
);
8827 while Present
(Nod
) loop
8828 if Nkind
(Nod
) = N_Pragma
8829 and then Pragma_Name
(Nod
) = Name_Main
8831 Error_Msg_Name_1
:= Pname
;
8832 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
8843 -- pragma Main_Storage
8844 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
8846 -- MAIN_STORAGE_OPTION ::=
8847 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
8848 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
8850 when Pragma_Main_Storage
=> Main_Storage
: declare
8851 Args
: Args_List
(1 .. 2);
8852 Names
: constant Name_List
(1 .. 2) := (
8853 Name_Working_Storage
,
8860 Gather_Associations
(Names
, Args
);
8862 for J
in 1 .. 2 loop
8863 if Present
(Args
(J
)) then
8864 Check_Arg_Is_Static_Expression
(Args
(J
), Any_Integer
);
8868 Check_In_Main_Program
;
8871 while Present
(Nod
) loop
8872 if Nkind
(Nod
) = N_Pragma
8873 and then Pragma_Name
(Nod
) = Name_Main_Storage
8875 Error_Msg_Name_1
:= Pname
;
8876 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
8887 -- pragma Memory_Size (NUMERIC_LITERAL)
8889 when Pragma_Memory_Size
=>
8892 -- Memory size is simply ignored
8894 Check_No_Identifiers
;
8895 Check_Arg_Count
(1);
8896 Check_Arg_Is_Integer_Literal
(Arg1
);
8904 -- The only correct use of this pragma is on its own in a file, in
8905 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
8906 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
8907 -- check for a file containing nothing but a No_Body pragma). If we
8908 -- attempt to process it during normal semantics processing, it means
8909 -- it was misplaced.
8911 when Pragma_No_Body
=>
8919 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
8921 when Pragma_No_Return
=> No_Return
: declare
8929 Check_At_Least_N_Arguments
(1);
8931 -- Loop through arguments of pragma
8934 while Present
(Arg
) loop
8935 Check_Arg_Is_Local_Name
(Arg
);
8936 Id
:= Expression
(Arg
);
8939 if not Is_Entity_Name
(Id
) then
8940 Error_Pragma_Arg
("entity name required", Arg
);
8943 if Etype
(Id
) = Any_Type
then
8947 -- Loop to find matching procedures
8952 and then Scope
(E
) = Current_Scope
8954 if Ekind
(E
) = E_Procedure
8955 or else Ekind
(E
) = E_Generic_Procedure
8959 -- Set flag on any alias as well
8961 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
8962 Set_No_Return
(Alias
(E
));
8972 Error_Pragma_Arg
("no procedure & found for pragma%", Arg
);
8983 -- pragma No_Run_Time;
8985 -- Note: this pragma is retained for backwards compatibility.
8986 -- See body of Rtsfind for full details on its handling.
8988 when Pragma_No_Run_Time
=>
8990 Check_Valid_Configuration_Pragma
;
8991 Check_Arg_Count
(0);
8993 No_Run_Time_Mode
:= True;
8994 Configurable_Run_Time_Mode
:= True;
8996 -- Set Duration to 32 bits if word size is 32
8998 if Ttypes
.System_Word_Size
= 32 then
8999 Duration_32_Bits_On_Target
:= True;
9002 -- Set appropriate restrictions
9004 Set_Restriction
(No_Finalization
, N
);
9005 Set_Restriction
(No_Exception_Handlers
, N
);
9006 Set_Restriction
(Max_Tasks
, N
, 0);
9007 Set_Restriction
(No_Tasking
, N
);
9009 ------------------------
9010 -- No_Strict_Aliasing --
9011 ------------------------
9013 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
9015 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
9020 Check_At_Most_N_Arguments
(1);
9022 if Arg_Count
= 0 then
9023 Check_Valid_Configuration_Pragma
;
9024 Opt
.No_Strict_Aliasing
:= True;
9027 Check_Optional_Identifier
(Arg2
, Name_Entity
);
9028 Check_Arg_Is_Local_Name
(Arg1
);
9029 E_Id
:= Entity
(Expression
(Arg1
));
9031 if E_Id
= Any_Type
then
9033 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
9034 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
9037 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
9039 end No_Strict_Aliasing
;
9041 -----------------------
9042 -- Normalize_Scalars --
9043 -----------------------
9045 -- pragma Normalize_Scalars;
9047 when Pragma_Normalize_Scalars
=>
9048 Check_Ada_83_Warning
;
9049 Check_Arg_Count
(0);
9050 Check_Valid_Configuration_Pragma
;
9051 Normalize_Scalars
:= True;
9052 Init_Or_Norm_Scalars
:= True;
9058 -- pragma Obsolescent [(
9059 -- [Entity => NAME,]
9060 -- [(static_string_EXPRESSION [, Ada_05])];
9062 when Pragma_Obsolescent
=> Obsolescent
: declare
9066 procedure Set_Obsolescent
(E
: Entity_Id
);
9067 -- Given an entity Ent, mark it as obsolescent if appropriate
9069 ---------------------
9070 -- Set_Obsolescent --
9071 ---------------------
9073 procedure Set_Obsolescent
(E
: Entity_Id
) is
9082 -- Entity name was given
9084 if Present
(Ename
) then
9086 -- If entity name matches, we are fine
9087 -- Save entity in pragma argument, for ASIS use.
9089 if Chars
(Ename
) = Chars
(Ent
) then
9090 Set_Entity
(Ename
, Ent
);
9091 Generate_Reference
(Ent
, Ename
);
9093 -- If entity name does not match, only possibility is an
9094 -- enumeration literal from an enumeration type declaration.
9096 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
9098 ("pragma % entity name does not match declaration");
9101 Ent
:= First_Literal
(E
);
9105 ("pragma % entity name does not match any " &
9106 "enumeration literal");
9108 elsif Chars
(Ent
) = Chars
(Ename
) then
9109 Set_Entity
(Ename
, Ent
);
9110 Generate_Reference
(Ent
, Ename
);
9114 Ent
:= Next_Literal
(Ent
);
9120 -- Ent points to entity to be marked
9122 if Arg_Count
>= 1 then
9124 -- Deal with static string argument
9126 Check_Arg_Is_Static_Expression
(Arg1
, Standard_String
);
9127 S
:= Strval
(Expression
(Arg1
));
9129 for J
in 1 .. String_Length
(S
) loop
9130 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
9132 ("pragma% argument does not allow wide characters",
9137 Obsolescent_Warnings
.Append
9138 ((Ent
=> Ent
, Msg
=> Strval
(Expression
(Arg1
))));
9140 -- Check for Ada_05 parameter
9142 if Arg_Count
/= 1 then
9143 Check_Arg_Count
(2);
9146 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
9149 Check_Arg_Is_Identifier
(Argx
);
9151 if Chars
(Argx
) /= Name_Ada_05
then
9152 Error_Msg_Name_2
:= Name_Ada_05
;
9154 ("only allowed argument for pragma% is %", Argx
);
9157 if Ada_Version_Explicit
< Ada_05
9158 or else not Warn_On_Ada_2005_Compatibility
9166 -- Set flag if pragma active
9169 Set_Is_Obsolescent
(Ent
);
9173 end Set_Obsolescent
;
9175 -- Start of processing for pragma Obsolescent
9180 Check_At_Most_N_Arguments
(3);
9182 -- See if first argument specifies an entity name
9185 and then Chars
(Arg1
) = Name_Entity
9187 Ename
:= Get_Pragma_Arg
(Arg1
);
9189 if Nkind
(Ename
) /= N_Character_Literal
9191 Nkind
(Ename
) /= N_Identifier
9193 Nkind
(Ename
) /= N_Operator_Symbol
9195 Error_Pragma_Arg
("entity name expected for pragma%", Arg1
);
9198 -- Eliminate first argument, so we can share processing
9202 Arg_Count
:= Arg_Count
- 1;
9204 -- No Entity name argument given
9210 Check_No_Identifiers
;
9212 -- Get immediately preceding declaration
9215 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
9219 -- Cases where we do not follow anything other than another pragma
9223 -- First case: library level compilation unit declaration with
9224 -- the pragma immediately following the declaration.
9226 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
9228 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
9231 -- Case 2: library unit placement for package
9235 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
9237 if Is_Package_Or_Generic_Package
(Ent
) then
9238 Set_Obsolescent
(Ent
);
9244 -- Cases where we must follow a declaration
9247 if Nkind
(Decl
) not in N_Declaration
9248 and then Nkind
(Decl
) not in N_Later_Decl_Item
9249 and then Nkind
(Decl
) not in N_Generic_Declaration
9252 ("pragma% misplaced, " &
9253 "must immediately follow a declaration");
9256 Set_Obsolescent
(Defining_Entity
(Decl
));
9266 -- pragma Optimize (Time | Space | Off);
9268 -- The actual check for optimize is done in Gigi. Note that this
9269 -- pragma does not actually change the optimization setting, it
9270 -- simply checks that it is consistent with the pragma.
9272 when Pragma_Optimize
=>
9273 Check_No_Identifiers
;
9274 Check_Arg_Count
(1);
9275 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
9277 ------------------------
9278 -- Optimize_Alignment --
9279 ------------------------
9281 -- pragma Optimize_Alignment (Time | Space | Off);
9283 when Pragma_Optimize_Alignment
=>
9285 Check_No_Identifiers
;
9286 Check_Arg_Count
(1);
9287 Check_Valid_Configuration_Pragma
;
9290 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
9294 Opt
.Optimize_Alignment
:= 'T';
9296 Opt
.Optimize_Alignment
:= 'S';
9298 Opt
.Optimize_Alignment
:= 'O';
9300 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
9304 -- Set indication that mode is set locally. If we are in fact in a
9305 -- configuration pragma file, this setting is harmless since the
9306 -- switch will get reset anyway at the start of each unit.
9308 Optimize_Alignment_Local
:= True;
9314 -- pragma Pack (first_subtype_LOCAL_NAME);
9316 when Pragma_Pack
=> Pack
: declare
9317 Assoc
: constant Node_Id
:= Arg1
;
9322 Check_No_Identifiers
;
9323 Check_Arg_Count
(1);
9324 Check_Arg_Is_Local_Name
(Arg1
);
9326 Type_Id
:= Expression
(Assoc
);
9327 Find_Type
(Type_Id
);
9328 Typ
:= Entity
(Type_Id
);
9331 or else Rep_Item_Too_Early
(Typ
, N
)
9335 Typ
:= Underlying_Type
(Typ
);
9338 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
9339 Error_Pragma
("pragma% must specify array or record type");
9342 Check_First_Subtype
(Arg1
);
9344 if Has_Pragma_Pack
(Typ
) then
9345 Error_Pragma
("duplicate pragma%, only one allowed");
9349 elsif Is_Array_Type
(Typ
) then
9351 -- Pack not allowed for aliased or atomic components
9353 if Has_Aliased_Components
(Base_Type
(Typ
)) then
9355 ("pragma% ignored, cannot pack aliased components?");
9357 elsif Has_Atomic_Components
(Typ
)
9358 or else Is_Atomic
(Component_Type
(Typ
))
9361 ("?pragma% ignored, cannot pack atomic components");
9364 -- If we had an explicit component size given, then we do not
9365 -- let Pack override this given size. We also give a warning
9366 -- that Pack is being ignored unless we can tell for sure that
9367 -- the Pack would not have had any effect anyway.
9369 if Has_Component_Size_Clause
(Typ
) then
9370 if Known_Static_RM_Size
(Component_Type
(Typ
))
9372 RM_Size
(Component_Type
(Typ
)) = Component_Size
(Typ
)
9377 ("?pragma% ignored, explicit component size given");
9380 -- If no prior array component size given, Pack is effective
9383 if not Rep_Item_Too_Late
(Typ
, N
) then
9384 if VM_Target
= No_VM
then
9385 Set_Is_Packed
(Base_Type
(Typ
));
9386 elsif not GNAT_Mode
then
9388 ("?pragma% ignored in this configuration");
9391 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
9392 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
9396 -- For record types, the pack is always effective
9398 else pragma Assert
(Is_Record_Type
(Typ
));
9399 if not Rep_Item_Too_Late
(Typ
, N
) then
9400 if VM_Target
= No_VM
then
9401 Set_Is_Packed
(Base_Type
(Typ
));
9402 elsif not GNAT_Mode
then
9403 Error_Pragma
("?pragma% ignored in this configuration");
9406 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
9407 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
9418 -- There is nothing to do here, since we did all the processing
9419 -- for this pragma in Par.Prag (so that it works properly even in
9420 -- syntax only mode)
9429 -- pragma Passive [(PASSIVE_FORM)];
9431 -- PASSIVE_FORM ::= Semaphore | No
9433 when Pragma_Passive
=>
9436 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
9437 Error_Pragma
("pragma% must be within task definition");
9440 if Arg_Count
/= 0 then
9441 Check_Arg_Count
(1);
9442 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
9445 ----------------------------------
9446 -- Preelaborable_Initialization --
9447 ----------------------------------
9449 -- pragma Preelaborable_Initialization (DIRECT_NAME);
9451 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
9456 Check_Arg_Count
(1);
9457 Check_No_Identifiers
;
9458 Check_Arg_Is_Identifier
(Arg1
);
9459 Check_Arg_Is_Local_Name
(Arg1
);
9460 Check_First_Subtype
(Arg1
);
9461 Ent
:= Entity
(Expression
(Arg1
));
9463 if not Is_Private_Type
(Ent
)
9464 and then not Is_Protected_Type
(Ent
)
9467 ("pragma % can only be applied to private or protected type",
9471 -- Give an error if the pragma is applied to a protected type that
9472 -- does not qualify (due to having entries, or due to components
9473 -- that do not qualify).
9475 if Is_Protected_Type
(Ent
)
9476 and then not Has_Preelaborable_Initialization
(Ent
)
9479 ("protected type & does not have preelaborable " &
9480 "initialization", Ent
);
9482 -- Otherwise mark the type as definitely having preelaborable
9486 Set_Known_To_Have_Preelab_Init
(Ent
);
9489 if Has_Pragma_Preelab_Init
(Ent
)
9490 and then Warn_On_Redundant_Constructs
9492 Error_Pragma
("?duplicate pragma%!");
9494 Set_Has_Pragma_Preelab_Init
(Ent
);
9498 --------------------
9499 -- Persistent_BSS --
9500 --------------------
9502 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
9509 Check_At_Most_N_Arguments
(1);
9511 -- Case of application to specific object (one argument)
9513 if Arg_Count
= 1 then
9514 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
9516 if not Is_Entity_Name
(Expression
(Arg1
))
9518 (Ekind
(Entity
(Expression
(Arg1
))) /= E_Variable
9519 and then Ekind
(Entity
(Expression
(Arg1
))) /= E_Constant
)
9521 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
9524 Ent
:= Entity
(Expression
(Arg1
));
9525 Decl
:= Parent
(Ent
);
9527 if Rep_Item_Too_Late
(Ent
, N
) then
9531 if Present
(Expression
(Decl
)) then
9533 ("object for pragma% cannot have initialization", Arg1
);
9536 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
9538 ("object type for pragma% is not potentially persistent",
9543 Make_Linker_Section_Pragma
9544 (Ent
, Sloc
(N
), ".persistent.bss");
9545 Insert_After
(N
, Prag
);
9548 -- Case of use as configuration pragma with no arguments
9551 Check_Valid_Configuration_Pragma
;
9552 Persistent_BSS_Mode
:= True;
9560 -- pragma Polling (ON | OFF);
9562 when Pragma_Polling
=>
9564 Check_Arg_Count
(1);
9565 Check_No_Identifiers
;
9566 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
9567 Polling_Required
:= (Chars
(Expression
(Arg1
)) = Name_On
);
9573 -- pragma Postcondition ([Check =>] Boolean_Expression
9574 -- [,[Message =>] String_Expression]);
9576 when Pragma_Postcondition
=> Postcondition
: declare
9578 pragma Warnings
(Off
, In_Body
);
9582 Check_At_Least_N_Arguments
(1);
9583 Check_At_Most_N_Arguments
(2);
9584 Check_Optional_Identifier
(Arg1
, Name_Check
);
9586 -- All we need to do here is call the common check procedure,
9587 -- the remainder of the processing is found in Sem_Ch6/Sem_Ch7.
9589 Check_Precondition_Postcondition
(In_Body
);
9596 -- pragma Precondition ([Check =>] Boolean_Expression
9597 -- [,[Message =>] String_Expression]);
9599 when Pragma_Precondition
=> Precondition
: declare
9604 Check_At_Least_N_Arguments
(1);
9605 Check_At_Most_N_Arguments
(2);
9606 Check_Optional_Identifier
(Arg1
, Name_Check
);
9608 Check_Precondition_Postcondition
(In_Body
);
9610 -- If in spec, nothing to do. If in body, then we convert the
9611 -- pragma to pragma Check (Precondition, cond [, msg]). Note we
9612 -- do this whether or not precondition checks are enabled. That
9613 -- works fine since pragma Check will do this check.
9616 if Arg_Count
= 2 then
9617 Check_Optional_Identifier
(Arg3
, Name_Message
);
9618 Analyze_And_Resolve
(Get_Pragma_Arg
(Arg2
), Standard_String
);
9621 Analyze_And_Resolve
(Get_Pragma_Arg
(Arg1
), Standard_Boolean
);
9625 Chars
=> Name_Check
,
9626 Pragma_Argument_Associations
=> New_List
(
9627 Make_Pragma_Argument_Association
(Loc
,
9629 Make_Identifier
(Loc
,
9630 Chars
=> Name_Precondition
)),
9632 Make_Pragma_Argument_Association
(Sloc
(Arg1
),
9633 Expression
=> Relocate_Node
(Get_Pragma_Arg
(Arg1
))))));
9635 if Arg_Count
= 2 then
9636 Append_To
(Pragma_Argument_Associations
(N
),
9637 Make_Pragma_Argument_Association
(Sloc
(Arg2
),
9638 Expression
=> Relocate_Node
(Get_Pragma_Arg
(Arg2
))));
9649 -- pragma Preelaborate [(library_unit_NAME)];
9651 -- Set the flag Is_Preelaborated of program unit name entity
9653 when Pragma_Preelaborate
=> Preelaborate
: declare
9654 Pa
: constant Node_Id
:= Parent
(N
);
9655 Pk
: constant Node_Kind
:= Nkind
(Pa
);
9659 Check_Ada_83_Warning
;
9660 Check_Valid_Library_Unit_Pragma
;
9662 if Nkind
(N
) = N_Null_Statement
then
9666 Ent
:= Find_Lib_Unit_Name
;
9668 -- This filters out pragmas inside generic parent then
9669 -- show up inside instantiation
9672 and then not (Pk
= N_Package_Specification
9673 and then Present
(Generic_Parent
(Pa
)))
9675 if not Debug_Flag_U
then
9676 Set_Is_Preelaborated
(Ent
);
9677 Set_Suppress_Elaboration_Warnings
(Ent
);
9682 ---------------------
9683 -- Preelaborate_05 --
9684 ---------------------
9686 -- pragma Preelaborate_05 [(library_unit_NAME)];
9688 -- This pragma is useable only in GNAT_Mode, where it is used like
9689 -- pragma Preelaborate but it is only effective in Ada 2005 mode
9690 -- (otherwise it is ignored). This is used to implement AI-362 which
9691 -- recategorizes some run-time packages in Ada 2005 mode.
9693 when Pragma_Preelaborate_05
=> Preelaborate_05
: declare
9698 Check_Valid_Library_Unit_Pragma
;
9700 if not GNAT_Mode
then
9701 Error_Pragma
("pragma% only available in GNAT mode");
9704 if Nkind
(N
) = N_Null_Statement
then
9708 -- This is one of the few cases where we need to test the value of
9709 -- Ada_Version_Explicit rather than Ada_Version (which is always
9710 -- set to Ada_05 in a predefined unit), we need to know the
9711 -- explicit version set to know if this pragma is active.
9713 if Ada_Version_Explicit
>= Ada_05
then
9714 Ent
:= Find_Lib_Unit_Name
;
9715 Set_Is_Preelaborated
(Ent
);
9716 Set_Suppress_Elaboration_Warnings
(Ent
);
9718 end Preelaborate_05
;
9724 -- pragma Priority (EXPRESSION);
9726 when Pragma_Priority
=> Priority
: declare
9727 P
: constant Node_Id
:= Parent
(N
);
9731 Check_No_Identifiers
;
9732 Check_Arg_Count
(1);
9736 if Nkind
(P
) = N_Subprogram_Body
then
9737 Check_In_Main_Program
;
9739 Arg
:= Expression
(Arg1
);
9740 Analyze_And_Resolve
(Arg
, Standard_Integer
);
9744 if not Is_Static_Expression
(Arg
) then
9745 Flag_Non_Static_Expr
9746 ("main subprogram priority is not static!", Arg
);
9749 -- If constraint error, then we already signalled an error
9751 elsif Raises_Constraint_Error
(Arg
) then
9754 -- Otherwise check in range
9758 Val
: constant Uint
:= Expr_Value
(Arg
);
9762 or else Val
> Expr_Value
(Expression
9763 (Parent
(RTE
(RE_Max_Priority
))))
9766 ("main subprogram priority is out of range", Arg1
);
9772 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
9774 -- Load an arbitrary entity from System.Tasking to make sure
9775 -- this package is implicitly with'ed, since we need to have
9776 -- the tasking run-time active for the pragma Priority to have
9780 Discard
: Entity_Id
;
9781 pragma Warnings
(Off
, Discard
);
9783 Discard
:= RTE
(RE_Task_List
);
9786 -- Task or Protected, must be of type Integer
9788 elsif Nkind
(P
) = N_Protected_Definition
9790 Nkind
(P
) = N_Task_Definition
9792 Arg
:= Expression
(Arg1
);
9794 -- The expression must be analyzed in the special manner
9795 -- described in "Handling of Default and Per-Object
9796 -- Expressions" in sem.ads.
9798 Preanalyze_Spec_Expression
(Arg
, Standard_Integer
);
9800 if not Is_Static_Expression
(Arg
) then
9801 Check_Restriction
(Static_Priorities
, Arg
);
9804 -- Anything else is incorrect
9810 if Has_Priority_Pragma
(P
) then
9811 Error_Pragma
("duplicate pragma% not allowed");
9813 Set_Has_Priority_Pragma
(P
, True);
9815 if Nkind
(P
) = N_Protected_Definition
9817 Nkind
(P
) = N_Task_Definition
9819 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
9820 -- exp_ch9 should use this ???
9825 -----------------------------------
9826 -- Priority_Specific_Dispatching --
9827 -----------------------------------
9829 -- pragma Priority_Specific_Dispatching (
9830 -- policy_IDENTIFIER,
9831 -- first_priority_EXPRESSION,
9832 -- last_priority_EXPRESSION);
9834 when Pragma_Priority_Specific_Dispatching
=>
9835 Priority_Specific_Dispatching
: declare
9836 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
9837 -- This is the entity System.Any_Priority;
9840 Lower_Bound
: Node_Id
;
9841 Upper_Bound
: Node_Id
;
9847 Check_Arg_Count
(3);
9848 Check_No_Identifiers
;
9849 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
9850 Check_Valid_Configuration_Pragma
;
9851 Get_Name_String
(Chars
(Expression
(Arg1
)));
9852 DP
:= Fold_Upper
(Name_Buffer
(1));
9854 Lower_Bound
:= Expression
(Arg2
);
9855 Check_Arg_Is_Static_Expression
(Lower_Bound
, Standard_Integer
);
9856 Lower_Val
:= Expr_Value
(Lower_Bound
);
9858 Upper_Bound
:= Expression
(Arg3
);
9859 Check_Arg_Is_Static_Expression
(Upper_Bound
, Standard_Integer
);
9860 Upper_Val
:= Expr_Value
(Upper_Bound
);
9862 -- It is not allowed to use Task_Dispatching_Policy and
9863 -- Priority_Specific_Dispatching in the same partition.
9865 if Task_Dispatching_Policy
/= ' ' then
9866 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9868 ("pragma% incompatible with Task_Dispatching_Policy#");
9870 -- Check lower bound in range
9872 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
9874 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
9877 ("first_priority is out of range", Arg2
);
9879 -- Check upper bound in range
9881 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
9883 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
9886 ("last_priority is out of range", Arg3
);
9888 -- Check that the priority range is valid
9890 elsif Lower_Val
> Upper_Val
then
9892 ("last_priority_expression must be greater than" &
9893 " or equal to first_priority_expression");
9895 -- Store the new policy, but always preserve System_Location since
9896 -- we like the error message with the run-time name.
9899 -- Check overlapping in the priority ranges specified in other
9900 -- Priority_Specific_Dispatching pragmas within the same
9901 -- partition. We can only check those we know about!
9904 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
9906 if Specific_Dispatching
.Table
(J
).First_Priority
in
9907 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
9908 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
9909 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
9912 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
9914 ("priority range overlaps with "
9915 & "Priority_Specific_Dispatching#");
9919 -- The use of Priority_Specific_Dispatching is incompatible
9920 -- with Task_Dispatching_Policy.
9922 if Task_Dispatching_Policy
/= ' ' then
9923 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9925 ("Priority_Specific_Dispatching incompatible "
9926 & "with Task_Dispatching_Policy#");
9929 -- The use of Priority_Specific_Dispatching forces ceiling
9932 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
9933 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9935 ("Priority_Specific_Dispatching incompatible "
9936 & "with Locking_Policy#");
9938 -- Set the Ceiling_Locking policy, but preserve System_Location
9939 -- since we like the error message with the run time name.
9942 Locking_Policy
:= 'C';
9944 if Locking_Policy_Sloc
/= System_Location
then
9945 Locking_Policy_Sloc
:= Loc
;
9949 -- Add entry in the table
9951 Specific_Dispatching
.Append
9952 ((Dispatching_Policy
=> DP
,
9953 First_Priority
=> UI_To_Int
(Lower_Val
),
9954 Last_Priority
=> UI_To_Int
(Upper_Val
),
9955 Pragma_Loc
=> Loc
));
9957 end Priority_Specific_Dispatching
;
9963 -- pragma Profile (profile_IDENTIFIER);
9965 -- profile_IDENTIFIER => Restricted | Ravenscar
9967 when Pragma_Profile
=>
9969 Check_Arg_Count
(1);
9970 Check_Valid_Configuration_Pragma
;
9971 Check_No_Identifiers
;
9974 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
9976 if Chars
(Argx
) = Name_Ravenscar
then
9977 Set_Ravenscar_Profile
(N
);
9978 elsif Chars
(Argx
) = Name_Restricted
then
9979 Set_Profile_Restrictions
9980 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9982 Error_Pragma_Arg
("& is not a valid profile", Argx
);
9986 ----------------------
9987 -- Profile_Warnings --
9988 ----------------------
9990 -- pragma Profile_Warnings (profile_IDENTIFIER);
9992 -- profile_IDENTIFIER => Restricted | Ravenscar
9994 when Pragma_Profile_Warnings
=>
9996 Check_Arg_Count
(1);
9997 Check_Valid_Configuration_Pragma
;
9998 Check_No_Identifiers
;
10001 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
10003 if Chars
(Argx
) = Name_Ravenscar
then
10004 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
10005 elsif Chars
(Argx
) = Name_Restricted
then
10006 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
10008 Error_Pragma_Arg
("& is not a valid profile", Argx
);
10012 --------------------------
10013 -- Propagate_Exceptions --
10014 --------------------------
10016 -- pragma Propagate_Exceptions;
10018 -- Note: this pragma is obsolete and has no effect
10020 when Pragma_Propagate_Exceptions
=>
10022 Check_Arg_Count
(0);
10024 if In_Extended_Main_Source_Unit
(N
) then
10025 Propagate_Exceptions
:= True;
10032 -- pragma Psect_Object (
10033 -- [Internal =>] LOCAL_NAME,
10034 -- [, [External =>] EXTERNAL_SYMBOL]
10035 -- [, [Size =>] EXTERNAL_SYMBOL]);
10037 when Pragma_Psect_Object | Pragma_Common_Object
=>
10038 Psect_Object
: declare
10039 Args
: Args_List
(1 .. 3);
10040 Names
: constant Name_List
(1 .. 3) := (
10045 Internal
: Node_Id
renames Args
(1);
10046 External
: Node_Id
renames Args
(2);
10047 Size
: Node_Id
renames Args
(3);
10049 Def_Id
: Entity_Id
;
10051 procedure Check_Too_Long
(Arg
: Node_Id
);
10052 -- Posts message if the argument is an identifier with more
10053 -- than 31 characters, or a string literal with more than
10054 -- 31 characters, and we are operating under VMS
10056 --------------------
10057 -- Check_Too_Long --
10058 --------------------
10060 procedure Check_Too_Long
(Arg
: Node_Id
) is
10061 X
: constant Node_Id
:= Original_Node
(Arg
);
10064 if Nkind
(X
) /= N_String_Literal
10066 Nkind
(X
) /= N_Identifier
10069 ("inappropriate argument for pragma %", Arg
);
10072 if OpenVMS_On_Target
then
10073 if (Nkind
(X
) = N_String_Literal
10074 and then String_Length
(Strval
(X
)) > 31)
10076 (Nkind
(X
) = N_Identifier
10077 and then Length_Of_Name
(Chars
(X
)) > 31)
10080 ("argument for pragma % is longer than 31 characters",
10084 end Check_Too_Long
;
10086 -- Start of processing for Common_Object/Psect_Object
10090 Gather_Associations
(Names
, Args
);
10091 Process_Extended_Import_Export_Internal_Arg
(Internal
);
10093 Def_Id
:= Entity
(Internal
);
10095 if Ekind
(Def_Id
) /= E_Constant
10096 and then Ekind
(Def_Id
) /= E_Variable
10099 ("pragma% must designate an object", Internal
);
10102 Check_Too_Long
(Internal
);
10104 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
10106 ("cannot use pragma% for imported/exported object",
10110 if Is_Concurrent_Type
(Etype
(Internal
)) then
10112 ("cannot specify pragma % for task/protected object",
10116 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
10118 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
10120 Error_Msg_N
("?duplicate Common/Psect_Object pragma", N
);
10123 if Ekind
(Def_Id
) = E_Constant
then
10125 ("cannot specify pragma % for a constant", Internal
);
10128 if Is_Record_Type
(Etype
(Internal
)) then
10134 Ent
:= First_Entity
(Etype
(Internal
));
10135 while Present
(Ent
) loop
10136 Decl
:= Declaration_Node
(Ent
);
10138 if Ekind
(Ent
) = E_Component
10139 and then Nkind
(Decl
) = N_Component_Declaration
10140 and then Present
(Expression
(Decl
))
10141 and then Warn_On_Export_Import
10144 ("?object for pragma % has defaults", Internal
);
10154 if Present
(Size
) then
10155 Check_Too_Long
(Size
);
10158 if Present
(External
) then
10159 Check_Arg_Is_External_Name
(External
);
10160 Check_Too_Long
(External
);
10163 -- If all error tests pass, link pragma on to the rep item chain
10165 Record_Rep_Item
(Def_Id
, N
);
10172 -- pragma Pure [(library_unit_NAME)];
10174 when Pragma_Pure
=> Pure
: declare
10178 Check_Ada_83_Warning
;
10179 Check_Valid_Library_Unit_Pragma
;
10181 if Nkind
(N
) = N_Null_Statement
then
10185 Ent
:= Find_Lib_Unit_Name
;
10187 Set_Has_Pragma_Pure
(Ent
);
10188 Set_Suppress_Elaboration_Warnings
(Ent
);
10195 -- pragma Pure_05 [(library_unit_NAME)];
10197 -- This pragma is useable only in GNAT_Mode, where it is used like
10198 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
10199 -- it is ignored). It may be used after a pragma Preelaborate, in
10200 -- which case it overrides the effect of the pragma Preelaborate.
10201 -- This is used to implement AI-362 which recategorizes some run-time
10202 -- packages in Ada 2005 mode.
10204 when Pragma_Pure_05
=> Pure_05
: declare
10209 Check_Valid_Library_Unit_Pragma
;
10211 if not GNAT_Mode
then
10212 Error_Pragma
("pragma% only available in GNAT mode");
10214 if Nkind
(N
) = N_Null_Statement
then
10218 -- This is one of the few cases where we need to test the value of
10219 -- Ada_Version_Explicit rather than Ada_Version (which is always
10220 -- set to Ada_05 in a predefined unit), we need to know the
10221 -- explicit version set to know if this pragma is active.
10223 if Ada_Version_Explicit
>= Ada_05
then
10224 Ent
:= Find_Lib_Unit_Name
;
10225 Set_Is_Preelaborated
(Ent
, False);
10227 Set_Suppress_Elaboration_Warnings
(Ent
);
10231 -------------------
10232 -- Pure_Function --
10233 -------------------
10235 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
10237 when Pragma_Pure_Function
=> Pure_Function
: declare
10240 Def_Id
: Entity_Id
;
10241 Effective
: Boolean := False;
10245 Check_Arg_Count
(1);
10246 Check_Optional_Identifier
(Arg1
, Name_Entity
);
10247 Check_Arg_Is_Local_Name
(Arg1
);
10248 E_Id
:= Expression
(Arg1
);
10250 if Error_Posted
(E_Id
) then
10254 -- Loop through homonyms (overloadings) of referenced entity
10256 E
:= Entity
(E_Id
);
10258 if Present
(E
) then
10260 Def_Id
:= Get_Base_Subprogram
(E
);
10262 if Ekind
(Def_Id
) /= E_Function
10263 and then Ekind
(Def_Id
) /= E_Generic_Function
10264 and then Ekind
(Def_Id
) /= E_Operator
10267 ("pragma% requires a function name", Arg1
);
10270 Set_Is_Pure
(Def_Id
);
10272 if not Has_Pragma_Pure_Function
(Def_Id
) then
10273 Set_Has_Pragma_Pure_Function
(Def_Id
);
10278 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
10282 and then Warn_On_Redundant_Constructs
10284 Error_Msg_NE
("pragma Pure_Function on& is redundant?",
10290 --------------------
10291 -- Queuing_Policy --
10292 --------------------
10294 -- pragma Queuing_Policy (policy_IDENTIFIER);
10296 when Pragma_Queuing_Policy
=> declare
10300 Check_Ada_83_Warning
;
10301 Check_Arg_Count
(1);
10302 Check_No_Identifiers
;
10303 Check_Arg_Is_Queuing_Policy
(Arg1
);
10304 Check_Valid_Configuration_Pragma
;
10305 Get_Name_String
(Chars
(Expression
(Arg1
)));
10306 QP
:= Fold_Upper
(Name_Buffer
(1));
10308 if Queuing_Policy
/= ' '
10309 and then Queuing_Policy
/= QP
10311 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
10312 Error_Pragma
("queuing policy incompatible with policy#");
10314 -- Set new policy, but always preserve System_Location since
10315 -- we like the error message with the run time name.
10318 Queuing_Policy
:= QP
;
10320 if Queuing_Policy_Sloc
/= System_Location
then
10321 Queuing_Policy_Sloc
:= Loc
;
10326 -----------------------
10327 -- Relative_Deadline --
10328 -----------------------
10330 -- pragma Relative_Deadline (time_span_EXPRESSION);
10332 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
10333 P
: constant Node_Id
:= Parent
(N
);
10338 Check_No_Identifiers
;
10339 Check_Arg_Count
(1);
10341 Arg
:= Expression
(Arg1
);
10343 -- The expression must be analyzed in the special manner described
10344 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
10346 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
10350 if Nkind
(P
) = N_Subprogram_Body
then
10351 Check_In_Main_Program
;
10355 elsif Nkind
(P
) = N_Task_Definition
then
10358 -- Anything else is incorrect
10364 if Has_Relative_Deadline_Pragma
(P
) then
10365 Error_Pragma
("duplicate pragma% not allowed");
10367 Set_Has_Relative_Deadline_Pragma
(P
, True);
10369 if Nkind
(P
) = N_Task_Definition
then
10370 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
10373 end Relative_Deadline
;
10375 ---------------------------
10376 -- Remote_Call_Interface --
10377 ---------------------------
10379 -- pragma Remote_Call_Interface [(library_unit_NAME)];
10381 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
10382 Cunit_Node
: Node_Id
;
10383 Cunit_Ent
: Entity_Id
;
10387 Check_Ada_83_Warning
;
10388 Check_Valid_Library_Unit_Pragma
;
10390 if Nkind
(N
) = N_Null_Statement
then
10394 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
10395 K
:= Nkind
(Unit
(Cunit_Node
));
10396 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
10398 if K
= N_Package_Declaration
10399 or else K
= N_Generic_Package_Declaration
10400 or else K
= N_Subprogram_Declaration
10401 or else K
= N_Generic_Subprogram_Declaration
10402 or else (K
= N_Subprogram_Body
10403 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
10408 "pragma% must apply to package or subprogram declaration");
10411 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
10412 end Remote_Call_Interface
;
10418 -- pragma Remote_Types [(library_unit_NAME)];
10420 when Pragma_Remote_Types
=> Remote_Types
: declare
10421 Cunit_Node
: Node_Id
;
10422 Cunit_Ent
: Entity_Id
;
10425 Check_Ada_83_Warning
;
10426 Check_Valid_Library_Unit_Pragma
;
10428 if Nkind
(N
) = N_Null_Statement
then
10432 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
10433 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
10435 if Nkind
(Unit
(Cunit_Node
)) /= N_Package_Declaration
10437 Nkind
(Unit
(Cunit_Node
)) /= N_Generic_Package_Declaration
10440 "pragma% can only apply to a package declaration");
10443 Set_Is_Remote_Types
(Cunit_Ent
);
10450 -- pragma Ravenscar;
10452 when Pragma_Ravenscar
=>
10454 Check_Arg_Count
(0);
10455 Check_Valid_Configuration_Pragma
;
10456 Set_Ravenscar_Profile
(N
);
10458 if Warn_On_Obsolescent_Feature
then
10460 ("pragma Ravenscar is an obsolescent feature?", N
);
10462 ("|use pragma Profile (Ravenscar) instead", N
);
10465 -------------------------
10466 -- Restricted_Run_Time --
10467 -------------------------
10469 -- pragma Restricted_Run_Time;
10471 when Pragma_Restricted_Run_Time
=>
10473 Check_Arg_Count
(0);
10474 Check_Valid_Configuration_Pragma
;
10475 Set_Profile_Restrictions
10476 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
10478 if Warn_On_Obsolescent_Feature
then
10480 ("pragma Restricted_Run_Time is an obsolescent feature?", N
);
10482 ("|use pragma Profile (Restricted) instead", N
);
10489 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
10492 -- restriction_IDENTIFIER
10493 -- | restriction_parameter_IDENTIFIER => EXPRESSION
10495 when Pragma_Restrictions
=>
10496 Process_Restrictions_Or_Restriction_Warnings
10497 (Warn
=> Treat_Restrictions_As_Warnings
);
10499 --------------------------
10500 -- Restriction_Warnings --
10501 --------------------------
10503 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
10506 -- restriction_IDENTIFIER
10507 -- | restriction_parameter_IDENTIFIER => EXPRESSION
10509 when Pragma_Restriction_Warnings
=>
10511 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
10517 -- pragma Reviewable;
10519 when Pragma_Reviewable
=>
10520 Check_Ada_83_Warning
;
10521 Check_Arg_Count
(0);
10524 -------------------
10525 -- Share_Generic --
10526 -------------------
10528 -- pragma Share_Generic (NAME {, NAME});
10530 when Pragma_Share_Generic
=>
10532 Process_Generic_List
;
10538 -- pragma Shared (LOCAL_NAME);
10540 when Pragma_Shared
=>
10542 Process_Atomic_Shared_Volatile
;
10544 --------------------
10545 -- Shared_Passive --
10546 --------------------
10548 -- pragma Shared_Passive [(library_unit_NAME)];
10550 -- Set the flag Is_Shared_Passive of program unit name entity
10552 when Pragma_Shared_Passive
=> Shared_Passive
: declare
10553 Cunit_Node
: Node_Id
;
10554 Cunit_Ent
: Entity_Id
;
10557 Check_Ada_83_Warning
;
10558 Check_Valid_Library_Unit_Pragma
;
10560 if Nkind
(N
) = N_Null_Statement
then
10564 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
10565 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
10567 if Nkind
(Unit
(Cunit_Node
)) /= N_Package_Declaration
10569 Nkind
(Unit
(Cunit_Node
)) /= N_Generic_Package_Declaration
10572 "pragma% can only apply to a package declaration");
10575 Set_Is_Shared_Passive
(Cunit_Ent
);
10576 end Shared_Passive
;
10578 ----------------------
10579 -- Source_File_Name --
10580 ----------------------
10582 -- There are five forms for this pragma:
10584 -- pragma Source_File_Name (
10585 -- [UNIT_NAME =>] unit_NAME,
10586 -- BODY_FILE_NAME => STRING_LITERAL
10587 -- [, [INDEX =>] INTEGER_LITERAL]);
10589 -- pragma Source_File_Name (
10590 -- [UNIT_NAME =>] unit_NAME,
10591 -- SPEC_FILE_NAME => STRING_LITERAL
10592 -- [, [INDEX =>] INTEGER_LITERAL]);
10594 -- pragma Source_File_Name (
10595 -- BODY_FILE_NAME => STRING_LITERAL
10596 -- [, DOT_REPLACEMENT => STRING_LITERAL]
10597 -- [, CASING => CASING_SPEC]);
10599 -- pragma Source_File_Name (
10600 -- SPEC_FILE_NAME => STRING_LITERAL
10601 -- [, DOT_REPLACEMENT => STRING_LITERAL]
10602 -- [, CASING => CASING_SPEC]);
10604 -- pragma Source_File_Name (
10605 -- SUBUNIT_FILE_NAME => STRING_LITERAL
10606 -- [, DOT_REPLACEMENT => STRING_LITERAL]
10607 -- [, CASING => CASING_SPEC]);
10609 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
10611 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
10612 -- Source_File_Name (SFN), however their usage is exclusive:
10613 -- SFN can only be used when no project file is used, while
10614 -- SFNP can only be used when a project file is used.
10616 -- No processing here. Processing was completed during parsing,
10617 -- since we need to have file names set as early as possible.
10618 -- Units are loaded well before semantic processing starts.
10620 -- The only processing we defer to this point is the check
10621 -- for correct placement.
10623 when Pragma_Source_File_Name
=>
10625 Check_Valid_Configuration_Pragma
;
10627 ------------------------------
10628 -- Source_File_Name_Project --
10629 ------------------------------
10631 -- See Source_File_Name for syntax
10633 -- No processing here. Processing was completed during parsing,
10634 -- since we need to have file names set as early as possible.
10635 -- Units are loaded well before semantic processing starts.
10637 -- The only processing we defer to this point is the check
10638 -- for correct placement.
10640 when Pragma_Source_File_Name_Project
=>
10642 Check_Valid_Configuration_Pragma
;
10644 -- Check that a pragma Source_File_Name_Project is used only
10645 -- in a configuration pragmas file.
10647 -- Pragmas Source_File_Name_Project should only be generated
10648 -- by the Project Manager in configuration pragmas files.
10650 -- This is really an ugly test. It seems to depend on some
10651 -- accidental and undocumented property. At the very least
10652 -- it needs to be documented, but it would be better to have
10653 -- a clean way of testing if we are in a configuration file???
10655 if Present
(Parent
(N
)) then
10657 ("pragma% can only appear in a configuration pragmas file");
10660 ----------------------
10661 -- Source_Reference --
10662 ----------------------
10664 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
10666 -- Nothing to do, all processing completed in Par.Prag, since we
10667 -- need the information for possible parser messages that are output
10669 when Pragma_Source_Reference
=>
10672 --------------------------------
10673 -- Static_Elaboration_Desired --
10674 --------------------------------
10676 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
10678 when Pragma_Static_Elaboration_Desired
=>
10680 Check_At_Most_N_Arguments
(1);
10682 if Is_Compilation_Unit
(Current_Scope
)
10683 and then Ekind
(Current_Scope
) = E_Package
10685 Set_Static_Elaboration_Desired
(Current_Scope
, True);
10687 Error_Pragma
("pragma% must apply to a library-level package");
10694 -- pragma Storage_Size (EXPRESSION);
10696 when Pragma_Storage_Size
=> Storage_Size
: declare
10697 P
: constant Node_Id
:= Parent
(N
);
10701 Check_No_Identifiers
;
10702 Check_Arg_Count
(1);
10704 -- The expression must be analyzed in the special manner described
10705 -- in "Handling of Default Expressions" in sem.ads.
10707 Arg
:= Expression
(Arg1
);
10708 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
10710 if not Is_Static_Expression
(Arg
) then
10711 Check_Restriction
(Static_Storage_Size
, Arg
);
10714 if Nkind
(P
) /= N_Task_Definition
then
10719 if Has_Storage_Size_Pragma
(P
) then
10720 Error_Pragma
("duplicate pragma% not allowed");
10722 Set_Has_Storage_Size_Pragma
(P
, True);
10725 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
10726 -- ??? exp_ch9 should use this!
10734 -- pragma Storage_Unit (NUMERIC_LITERAL);
10736 -- Only permitted argument is System'Storage_Unit value
10738 when Pragma_Storage_Unit
=>
10739 Check_No_Identifiers
;
10740 Check_Arg_Count
(1);
10741 Check_Arg_Is_Integer_Literal
(Arg1
);
10743 if Intval
(Expression
(Arg1
)) /=
10744 UI_From_Int
(Ttypes
.System_Storage_Unit
)
10746 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
10748 ("the only allowed argument for pragma% is ^", Arg1
);
10751 --------------------
10752 -- Stream_Convert --
10753 --------------------
10755 -- pragma Stream_Convert (
10756 -- [Entity =>] type_LOCAL_NAME,
10757 -- [Read =>] function_NAME,
10758 -- [Write =>] function NAME);
10760 when Pragma_Stream_Convert
=> Stream_Convert
: declare
10762 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
10763 -- Check that the given argument is the name of a local
10764 -- function of one argument that is not overloaded earlier
10765 -- in the current local scope. A check is also made that the
10766 -- argument is a function with one parameter.
10768 --------------------------------------
10769 -- Check_OK_Stream_Convert_Function --
10770 --------------------------------------
10772 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
10776 Check_Arg_Is_Local_Name
(Arg
);
10777 Ent
:= Entity
(Expression
(Arg
));
10779 if Has_Homonym
(Ent
) then
10781 ("argument for pragma% may not be overloaded", Arg
);
10784 if Ekind
(Ent
) /= E_Function
10785 or else No
(First_Formal
(Ent
))
10786 or else Present
(Next_Formal
(First_Formal
(Ent
)))
10789 ("argument for pragma% must be" &
10790 " function of one argument", Arg
);
10792 end Check_OK_Stream_Convert_Function
;
10794 -- Start of processing for Stream_Convert
10798 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
10799 Check_Arg_Count
(3);
10800 Check_Optional_Identifier
(Arg1
, Name_Entity
);
10801 Check_Optional_Identifier
(Arg2
, Name_Read
);
10802 Check_Optional_Identifier
(Arg3
, Name_Write
);
10803 Check_Arg_Is_Local_Name
(Arg1
);
10804 Check_OK_Stream_Convert_Function
(Arg2
);
10805 Check_OK_Stream_Convert_Function
(Arg3
);
10808 Typ
: constant Entity_Id
:=
10809 Underlying_Type
(Entity
(Expression
(Arg1
)));
10810 Read
: constant Entity_Id
:= Entity
(Expression
(Arg2
));
10811 Write
: constant Entity_Id
:= Entity
(Expression
(Arg3
));
10814 Check_First_Subtype
(Arg1
);
10816 -- Check for too early or too late. Note that we don't enforce
10817 -- the rule about primitive operations in this case, since, as
10818 -- is the case for explicit stream attributes themselves, these
10819 -- restrictions are not appropriate. Note that the chaining of
10820 -- the pragma by Rep_Item_Too_Late is actually the critical
10821 -- processing done for this pragma.
10823 if Rep_Item_Too_Early
(Typ
, N
)
10825 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
10830 -- Return if previous error
10832 if Etype
(Typ
) = Any_Type
10834 Etype
(Read
) = Any_Type
10836 Etype
(Write
) = Any_Type
10843 if Underlying_Type
(Etype
(Read
)) /= Typ
then
10845 ("incorrect return type for function&", Arg2
);
10848 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
10850 ("incorrect parameter type for function&", Arg3
);
10853 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
10854 Underlying_Type
(Etype
(Write
))
10857 ("result type of & does not match Read parameter type",
10861 end Stream_Convert
;
10863 -------------------------
10864 -- Style_Checks (GNAT) --
10865 -------------------------
10867 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
10869 -- This is processed by the parser since some of the style
10870 -- checks take place during source scanning and parsing. This
10871 -- means that we don't need to issue error messages here.
10873 when Pragma_Style_Checks
=> Style_Checks
: declare
10874 A
: constant Node_Id
:= Expression
(Arg1
);
10880 Check_No_Identifiers
;
10882 -- Two argument form
10884 if Arg_Count
= 2 then
10885 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
10892 E_Id
:= Expression
(Arg2
);
10895 if not Is_Entity_Name
(E_Id
) then
10897 ("second argument of pragma% must be entity name",
10901 E
:= Entity
(E_Id
);
10907 Set_Suppress_Style_Checks
(E
,
10908 (Chars
(Expression
(Arg1
)) = Name_Off
));
10909 exit when No
(Homonym
(E
));
10915 -- One argument form
10918 Check_Arg_Count
(1);
10920 if Nkind
(A
) = N_String_Literal
then
10924 Slen
: constant Natural := Natural (String_Length
(S
));
10925 Options
: String (1 .. Slen
);
10931 C
:= Get_String_Char
(S
, Int
(J
));
10932 exit when not In_Character_Range
(C
);
10933 Options
(J
) := Get_Character
(C
);
10935 -- If at end of string, set options. As per discussion
10936 -- above, no need to check for errors, since we issued
10937 -- them in the parser.
10940 Set_Style_Check_Options
(Options
);
10948 elsif Nkind
(A
) = N_Identifier
then
10949 if Chars
(A
) = Name_All_Checks
then
10950 Set_Default_Style_Check_Options
;
10952 elsif Chars
(A
) = Name_On
then
10953 Style_Check
:= True;
10955 elsif Chars
(A
) = Name_Off
then
10956 Style_Check
:= False;
10966 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
10968 when Pragma_Subtitle
=>
10970 Check_Arg_Count
(1);
10971 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
10972 Check_Arg_Is_String_Literal
(Arg1
);
10978 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
10980 when Pragma_Suppress
=>
10981 Process_Suppress_Unsuppress
(True);
10987 -- pragma Suppress_All;
10989 -- The only check made here is that the pragma appears in the
10990 -- proper place, i.e. following a compilation unit. If indeed
10991 -- it appears in this context, then the parser has already
10992 -- inserted an equivalent pragma Suppress (All_Checks) to get
10993 -- the required effect.
10995 when Pragma_Suppress_All
=>
10997 Check_Arg_Count
(0);
10999 if Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
11000 or else not Is_List_Member
(N
)
11001 or else List_Containing
(N
) /= Pragmas_After
(Parent
(N
))
11004 ("misplaced pragma%, must follow compilation unit");
11007 -------------------------
11008 -- Suppress_Debug_Info --
11009 -------------------------
11011 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
11013 when Pragma_Suppress_Debug_Info
=>
11015 Check_Arg_Count
(1);
11016 Check_Optional_Identifier
(Arg1
, Name_Entity
);
11017 Check_Arg_Is_Local_Name
(Arg1
);
11018 Set_Debug_Info_Off
(Entity
(Get_Pragma_Arg
(Arg1
)));
11020 ----------------------------------
11021 -- Suppress_Exception_Locations --
11022 ----------------------------------
11024 -- pragma Suppress_Exception_Locations;
11026 when Pragma_Suppress_Exception_Locations
=>
11028 Check_Arg_Count
(0);
11029 Check_Valid_Configuration_Pragma
;
11030 Exception_Locations_Suppressed
:= True;
11032 -----------------------------
11033 -- Suppress_Initialization --
11034 -----------------------------
11036 -- pragma Suppress_Initialization ([Entity =>] type_Name);
11038 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
11044 Check_Arg_Count
(1);
11045 Check_Optional_Identifier
(Arg1
, Name_Entity
);
11046 Check_Arg_Is_Local_Name
(Arg1
);
11048 E_Id
:= Expression
(Arg1
);
11050 if Etype
(E_Id
) = Any_Type
then
11054 E
:= Entity
(E_Id
);
11056 if Is_Type
(E
) then
11057 if Is_Incomplete_Or_Private_Type
(E
) then
11058 if No
(Full_View
(Base_Type
(E
))) then
11060 ("argument of pragma% cannot be an incomplete type",
11063 Set_Suppress_Init_Proc
(Full_View
(Base_Type
(E
)));
11066 Set_Suppress_Init_Proc
(Base_Type
(E
));
11071 ("pragma% requires argument that is a type name", Arg1
);
11079 -- pragma System_Name (DIRECT_NAME);
11081 -- Syntax check: one argument, which must be the identifier GNAT
11082 -- or the identifier GCC, no other identifiers are acceptable.
11084 when Pragma_System_Name
=>
11086 Check_No_Identifiers
;
11087 Check_Arg_Count
(1);
11088 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
11090 -----------------------------
11091 -- Task_Dispatching_Policy --
11092 -----------------------------
11094 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
11096 when Pragma_Task_Dispatching_Policy
=> declare
11100 Check_Ada_83_Warning
;
11101 Check_Arg_Count
(1);
11102 Check_No_Identifiers
;
11103 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
11104 Check_Valid_Configuration_Pragma
;
11105 Get_Name_String
(Chars
(Expression
(Arg1
)));
11106 DP
:= Fold_Upper
(Name_Buffer
(1));
11108 if Task_Dispatching_Policy
/= ' '
11109 and then Task_Dispatching_Policy
/= DP
11111 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
11113 ("task dispatching policy incompatible with policy#");
11115 -- Set new policy, but always preserve System_Location since
11116 -- we like the error message with the run time name.
11119 Task_Dispatching_Policy
:= DP
;
11121 if Task_Dispatching_Policy_Sloc
/= System_Location
then
11122 Task_Dispatching_Policy_Sloc
:= Loc
;
11131 -- pragma Task_Info (EXPRESSION);
11133 when Pragma_Task_Info
=> Task_Info
: declare
11134 P
: constant Node_Id
:= Parent
(N
);
11139 if Nkind
(P
) /= N_Task_Definition
then
11140 Error_Pragma
("pragma% must appear in task definition");
11143 Check_No_Identifiers
;
11144 Check_Arg_Count
(1);
11146 Analyze_And_Resolve
(Expression
(Arg1
), RTE
(RE_Task_Info_Type
));
11148 if Etype
(Expression
(Arg1
)) = Any_Type
then
11152 if Has_Task_Info_Pragma
(P
) then
11153 Error_Pragma
("duplicate pragma% not allowed");
11155 Set_Has_Task_Info_Pragma
(P
, True);
11163 -- pragma Task_Name (string_EXPRESSION);
11165 when Pragma_Task_Name
=> Task_Name
: declare
11166 P
: constant Node_Id
:= Parent
(N
);
11170 Check_No_Identifiers
;
11171 Check_Arg_Count
(1);
11173 Arg
:= Expression
(Arg1
);
11174 Analyze_And_Resolve
(Arg
, Standard_String
);
11176 if Nkind
(P
) /= N_Task_Definition
then
11180 if Has_Task_Name_Pragma
(P
) then
11181 Error_Pragma
("duplicate pragma% not allowed");
11183 Set_Has_Task_Name_Pragma
(P
, True);
11184 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
11192 -- pragma Task_Storage (
11193 -- [Task_Type =>] LOCAL_NAME,
11194 -- [Top_Guard =>] static_integer_EXPRESSION);
11196 when Pragma_Task_Storage
=> Task_Storage
: declare
11197 Args
: Args_List
(1 .. 2);
11198 Names
: constant Name_List
(1 .. 2) := (
11202 Task_Type
: Node_Id
renames Args
(1);
11203 Top_Guard
: Node_Id
renames Args
(2);
11209 Gather_Associations
(Names
, Args
);
11211 if No
(Task_Type
) then
11213 ("missing task_type argument for pragma%");
11216 Check_Arg_Is_Local_Name
(Task_Type
);
11218 Ent
:= Entity
(Task_Type
);
11220 if not Is_Task_Type
(Ent
) then
11222 ("argument for pragma% must be task type", Task_Type
);
11225 if No
(Top_Guard
) then
11227 ("pragma% takes two arguments", Task_Type
);
11229 Check_Arg_Is_Static_Expression
(Top_Guard
, Any_Integer
);
11232 Check_First_Subtype
(Task_Type
);
11234 if Rep_Item_Too_Late
(Ent
, N
) then
11243 -- pragma Time_Slice (static_duration_EXPRESSION);
11245 when Pragma_Time_Slice
=> Time_Slice
: declare
11251 Check_Arg_Count
(1);
11252 Check_No_Identifiers
;
11253 Check_In_Main_Program
;
11254 Check_Arg_Is_Static_Expression
(Arg1
, Standard_Duration
);
11256 if not Error_Posted
(Arg1
) then
11258 while Present
(Nod
) loop
11259 if Nkind
(Nod
) = N_Pragma
11260 and then Pragma_Name
(Nod
) = Name_Time_Slice
11262 Error_Msg_Name_1
:= Pname
;
11263 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
11270 -- Process only if in main unit
11272 if Get_Source_Unit
(Loc
) = Main_Unit
then
11273 Opt
.Time_Slice_Set
:= True;
11274 Val
:= Expr_Value_R
(Expression
(Arg1
));
11276 if Val
<= Ureal_0
then
11277 Opt
.Time_Slice_Value
:= 0;
11279 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
11280 Opt
.Time_Slice_Value
:= 1_000_000_000
;
11283 Opt
.Time_Slice_Value
:=
11284 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
11293 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
11295 -- TITLING_OPTION ::=
11296 -- [Title =>] STRING_LITERAL
11297 -- | [Subtitle =>] STRING_LITERAL
11299 when Pragma_Title
=> Title
: declare
11300 Args
: Args_List
(1 .. 2);
11301 Names
: constant Name_List
(1 .. 2) := (
11307 Gather_Associations
(Names
, Args
);
11309 for J
in 1 .. 2 loop
11310 if Present
(Args
(J
)) then
11311 Check_Arg_Is_String_Literal
(Args
(J
));
11316 ---------------------
11317 -- Unchecked_Union --
11318 ---------------------
11320 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
11322 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
11323 Assoc
: constant Node_Id
:= Arg1
;
11324 Type_Id
: constant Node_Id
:= Expression
(Assoc
);
11335 Check_No_Identifiers
;
11336 Check_Arg_Count
(1);
11337 Check_Arg_Is_Local_Name
(Arg1
);
11339 Find_Type
(Type_Id
);
11340 Typ
:= Entity
(Type_Id
);
11343 or else Rep_Item_Too_Early
(Typ
, N
)
11347 Typ
:= Underlying_Type
(Typ
);
11350 if Rep_Item_Too_Late
(Typ
, N
) then
11354 Check_First_Subtype
(Arg1
);
11356 -- Note remaining cases are references to a type in the current
11357 -- declarative part. If we find an error, we post the error on
11358 -- the relevant type declaration at an appropriate point.
11360 if not Is_Record_Type
(Typ
) then
11361 Error_Msg_N
("Unchecked_Union must be record type", Typ
);
11364 elsif Is_Tagged_Type
(Typ
) then
11365 Error_Msg_N
("Unchecked_Union must not be tagged", Typ
);
11368 elsif Is_Limited_Type
(Typ
) then
11370 ("Unchecked_Union must not be limited record type", Typ
);
11371 Explain_Limited_Type
(Typ
, Typ
);
11375 if not Has_Discriminants
(Typ
) then
11377 ("Unchecked_Union must have one discriminant", Typ
);
11381 Discr
:= First_Discriminant
(Typ
);
11382 while Present
(Discr
) loop
11383 if No
(Discriminant_Default_Value
(Discr
)) then
11385 ("Unchecked_Union discriminant must have default value",
11388 Next_Discriminant
(Discr
);
11391 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
11392 Clist
:= Component_List
(Tdef
);
11394 Comp
:= First
(Component_Items
(Clist
));
11395 while Present
(Comp
) loop
11396 Check_Component
(Comp
);
11400 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
11402 ("Unchecked_Union must have variant part",
11407 Vpart
:= Variant_Part
(Clist
);
11409 Variant
:= First
(Variants
(Vpart
));
11410 while Present
(Variant
) loop
11411 Check_Variant
(Variant
);
11416 Set_Is_Unchecked_Union
(Typ
, True);
11417 Set_Convention
(Typ
, Convention_C
);
11419 Set_Has_Unchecked_Union
(Base_Type
(Typ
), True);
11420 Set_Is_Unchecked_Union
(Base_Type
(Typ
), True);
11421 end Unchecked_Union
;
11423 ------------------------
11424 -- Unimplemented_Unit --
11425 ------------------------
11427 -- pragma Unimplemented_Unit;
11429 -- Note: this only gives an error if we are generating code,
11430 -- or if we are in a generic library unit (where the pragma
11431 -- appears in the body, not in the spec).
11433 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
11434 Cunitent
: constant Entity_Id
:=
11435 Cunit_Entity
(Get_Source_Unit
(Loc
));
11436 Ent_Kind
: constant Entity_Kind
:=
11441 Check_Arg_Count
(0);
11443 if Operating_Mode
= Generate_Code
11444 or else Ent_Kind
= E_Generic_Function
11445 or else Ent_Kind
= E_Generic_Procedure
11446 or else Ent_Kind
= E_Generic_Package
11448 Get_Name_String
(Chars
(Cunitent
));
11449 Set_Casing
(Mixed_Case
);
11450 Write_Str
(Name_Buffer
(1 .. Name_Len
));
11451 Write_Str
(" is not supported in this configuration");
11453 raise Unrecoverable_Error
;
11455 end Unimplemented_Unit
;
11457 ------------------------
11458 -- Universal_Aliasing --
11459 ------------------------
11461 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
11463 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
11468 Check_Arg_Count
(1);
11469 Check_Optional_Identifier
(Arg2
, Name_Entity
);
11470 Check_Arg_Is_Local_Name
(Arg1
);
11471 E_Id
:= Entity
(Expression
(Arg1
));
11473 if E_Id
= Any_Type
then
11475 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
11476 Error_Pragma_Arg
("pragma% requires type", Arg1
);
11479 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
11480 end Universal_Alias
;
11482 --------------------
11483 -- Universal_Data --
11484 --------------------
11486 -- pragma Universal_Data [(library_unit_NAME)];
11488 when Pragma_Universal_Data
=>
11491 -- If this is a configuration pragma, then set the universal
11492 -- addressing option, otherwise confirm that the pragma
11493 -- satisfies the requirements of library unit pragma placement
11494 -- and leave it to the GNAAMP back end to detect the pragma
11495 -- (avoids transitive setting of the option due to withed units).
11497 if Is_Configuration_Pragma
then
11498 Universal_Addressing_On_AAMP
:= True;
11500 Check_Valid_Library_Unit_Pragma
;
11503 if not AAMP_On_Target
then
11504 Error_Pragma
("?pragma% ignored (applies only to AAMP)");
11511 -- pragma Unmodified (local_Name {, local_Name});
11513 when Pragma_Unmodified
=> Unmodified
: declare
11514 Arg_Node
: Node_Id
;
11515 Arg_Expr
: Node_Id
;
11516 Arg_Ent
: Entity_Id
;
11520 Check_At_Least_N_Arguments
(1);
11522 -- Loop through arguments
11525 while Present
(Arg_Node
) loop
11526 Check_No_Identifier
(Arg_Node
);
11528 -- Note: the analyze call done by Check_Arg_Is_Local_Name
11529 -- will in fact generate reference, so that the entity will
11530 -- have a reference, which will inhibit any warnings about
11531 -- it not being referenced, and also properly show up in the
11532 -- ali file as a reference. But this reference is recorded
11533 -- before the Has_Pragma_Unreferenced flag is set, so that
11534 -- no warning is generated for this reference.
11536 Check_Arg_Is_Local_Name
(Arg_Node
);
11537 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
11539 if Is_Entity_Name
(Arg_Expr
) then
11540 Arg_Ent
:= Entity
(Arg_Expr
);
11542 if not Is_Assignable
(Arg_Ent
) then
11544 ("pragma% can only be applied to a variable",
11547 Set_Has_Pragma_Unmodified
(Arg_Ent
);
11559 -- pragma Unreferenced (local_Name {, local_Name});
11561 -- or when used in a context clause:
11563 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
11565 when Pragma_Unreferenced
=> Unreferenced
: declare
11566 Arg_Node
: Node_Id
;
11567 Arg_Expr
: Node_Id
;
11568 Arg_Ent
: Entity_Id
;
11573 Check_At_Least_N_Arguments
(1);
11575 -- Check case of appearing within context clause
11577 if Is_In_Context_Clause
then
11579 -- The arguments must all be units mentioned in a with clause
11580 -- in the same context clause. Note we already checked (in
11581 -- Par.Prag) that the arguments are either identifiers or
11582 -- selected components.
11585 while Present
(Arg_Node
) loop
11586 Citem
:= First
(List_Containing
(N
));
11587 while Citem
/= N
loop
11588 if Nkind
(Citem
) = N_With_Clause
11589 and then Same_Name
(Name
(Citem
), Expression
(Arg_Node
))
11591 Set_Has_Pragma_Unreferenced
11594 (Library_Unit
(Citem
))));
11595 Set_Unit_Name
(Expression
(Arg_Node
), Name
(Citem
));
11604 ("argument of pragma% is not with'ed unit", Arg_Node
);
11610 -- Case of not in list of context items
11614 while Present
(Arg_Node
) loop
11615 Check_No_Identifier
(Arg_Node
);
11617 -- Note: the analyze call done by Check_Arg_Is_Local_Name
11618 -- will in fact generate reference, so that the entity will
11619 -- have a reference, which will inhibit any warnings about
11620 -- it not being referenced, and also properly show up in the
11621 -- ali file as a reference. But this reference is recorded
11622 -- before the Has_Pragma_Unreferenced flag is set, so that
11623 -- no warning is generated for this reference.
11625 Check_Arg_Is_Local_Name
(Arg_Node
);
11626 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
11628 if Is_Entity_Name
(Arg_Expr
) then
11629 Arg_Ent
:= Entity
(Arg_Expr
);
11631 -- If the entity is overloaded, the pragma applies to the
11632 -- most recent overloading, as documented. In this case,
11633 -- name resolution does not generate a reference, so it
11634 -- must be done here explicitly.
11636 if Is_Overloaded
(Arg_Expr
) then
11637 Generate_Reference
(Arg_Ent
, N
);
11640 Set_Has_Pragma_Unreferenced
(Arg_Ent
);
11648 --------------------------
11649 -- Unreferenced_Objects --
11650 --------------------------
11652 -- pragma Unreferenced_Objects (local_Name {, local_Name});
11654 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
11655 Arg_Node
: Node_Id
;
11656 Arg_Expr
: Node_Id
;
11660 Check_At_Least_N_Arguments
(1);
11663 while Present
(Arg_Node
) loop
11664 Check_No_Identifier
(Arg_Node
);
11665 Check_Arg_Is_Local_Name
(Arg_Node
);
11666 Arg_Expr
:= Get_Pragma_Arg
(Arg_Node
);
11668 if not Is_Entity_Name
(Arg_Expr
)
11669 or else not Is_Type
(Entity
(Arg_Expr
))
11672 ("argument for pragma% must be type or subtype", Arg_Node
);
11675 Set_Has_Pragma_Unreferenced_Objects
(Entity
(Arg_Expr
));
11678 end Unreferenced_Objects
;
11680 ------------------------------
11681 -- Unreserve_All_Interrupts --
11682 ------------------------------
11684 -- pragma Unreserve_All_Interrupts;
11686 when Pragma_Unreserve_All_Interrupts
=>
11688 Check_Arg_Count
(0);
11690 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
11691 Unreserve_All_Interrupts
:= True;
11698 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
11700 when Pragma_Unsuppress
=>
11702 Process_Suppress_Unsuppress
(False);
11704 -------------------
11705 -- Use_VADS_Size --
11706 -------------------
11708 -- pragma Use_VADS_Size;
11710 when Pragma_Use_VADS_Size
=>
11712 Check_Arg_Count
(0);
11713 Check_Valid_Configuration_Pragma
;
11714 Use_VADS_Size
:= True;
11716 ---------------------
11717 -- Validity_Checks --
11718 ---------------------
11720 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
11722 when Pragma_Validity_Checks
=> Validity_Checks
: declare
11723 A
: constant Node_Id
:= Expression
(Arg1
);
11729 Check_Arg_Count
(1);
11730 Check_No_Identifiers
;
11732 if Nkind
(A
) = N_String_Literal
then
11736 Slen
: constant Natural := Natural (String_Length
(S
));
11737 Options
: String (1 .. Slen
);
11743 C
:= Get_String_Char
(S
, Int
(J
));
11744 exit when not In_Character_Range
(C
);
11745 Options
(J
) := Get_Character
(C
);
11748 Set_Validity_Check_Options
(Options
);
11756 elsif Nkind
(A
) = N_Identifier
then
11758 if Chars
(A
) = Name_All_Checks
then
11759 Set_Validity_Check_Options
("a");
11761 elsif Chars
(A
) = Name_On
then
11762 Validity_Checks_On
:= True;
11764 elsif Chars
(A
) = Name_Off
then
11765 Validity_Checks_On
:= False;
11769 end Validity_Checks
;
11775 -- pragma Volatile (LOCAL_NAME);
11777 when Pragma_Volatile
=>
11778 Process_Atomic_Shared_Volatile
;
11780 -------------------------
11781 -- Volatile_Components --
11782 -------------------------
11784 -- pragma Volatile_Components (array_LOCAL_NAME);
11786 -- Volatile is handled by the same circuit as Atomic_Components
11792 -- pragma Warnings (On | Off);
11793 -- pragma Warnings (On | Off, LOCAL_NAME);
11794 -- pragma Warnings (static_string_EXPRESSION);
11795 -- pragma Warnings (On | Off, STRING_LITERAL);
11797 when Pragma_Warnings
=> Warnings
: begin
11799 Check_At_Least_N_Arguments
(1);
11800 Check_No_Identifiers
;
11803 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11806 -- One argument case
11808 if Arg_Count
= 1 then
11810 -- On/Off one argument case was processed by parser
11812 if Nkind
(Argx
) = N_Identifier
11814 (Chars
(Argx
) = Name_On
11816 Chars
(Argx
) = Name_Off
)
11820 -- One argument case must be ON/OFF or static string expr
11822 elsif not Is_Static_String_Expression
(Arg1
) then
11824 ("argument of pragma% must be On/Off or " &
11825 "static string expression", Arg2
);
11827 -- One argument string expression case
11831 Lit
: constant Node_Id
:= Expr_Value_S
(Argx
);
11832 Str
: constant String_Id
:= Strval
(Lit
);
11833 Len
: constant Nat
:= String_Length
(Str
);
11841 while J
<= Len
loop
11842 C
:= Get_String_Char
(Str
, J
);
11843 OK
:= In_Character_Range
(C
);
11846 Chr
:= Get_Character
(C
);
11850 if J
< Len
and then Chr
= '.' then
11852 C
:= Get_String_Char
(Str
, J
);
11853 Chr
:= Get_Character
(C
);
11855 if not Set_Dot_Warning_Switch
(Chr
) then
11857 ("invalid warning switch character " &
11864 OK
:= Set_Warning_Switch
(Chr
);
11870 ("invalid warning switch character " & Chr
,
11879 -- Two or more arguments (must be two)
11882 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11883 Check_At_Most_N_Arguments
(2);
11891 E_Id
:= Expression
(Arg2
);
11894 -- In the expansion of an inlined body, a reference to
11895 -- the formal may be wrapped in a conversion if the
11896 -- actual is a conversion. Retrieve the real entity name.
11898 if (In_Instance_Body
11899 or else In_Inlined_Body
)
11900 and then Nkind
(E_Id
) = N_Unchecked_Type_Conversion
11902 E_Id
:= Expression
(E_Id
);
11905 -- Entity name case
11907 if Is_Entity_Name
(E_Id
) then
11908 E
:= Entity
(E_Id
);
11915 (E
, (Chars
(Expression
(Arg1
)) = Name_Off
));
11917 if Chars
(Expression
(Arg1
)) = Name_Off
11918 and then Warn_On_Warnings_Off
11920 Warnings_Off_Pragmas
.Append
((N
, E
));
11923 if Is_Enumeration_Type
(E
) then
11927 Lit
:= First_Literal
(E
);
11928 while Present
(Lit
) loop
11929 Set_Warnings_Off
(Lit
);
11930 Next_Literal
(Lit
);
11935 exit when No
(Homonym
(E
));
11940 -- Error if not entity or static string literal case
11942 elsif not Is_Static_String_Expression
(Arg2
) then
11944 ("second argument of pragma% must be entity " &
11945 "name or static string expression", Arg2
);
11947 -- String literal case
11950 String_To_Name_Buffer
11951 (Strval
(Expr_Value_S
(Expression
(Arg2
))));
11953 -- Note on configuration pragma case: If this is a
11954 -- configuration pragma, then for an OFF pragma, we
11955 -- just set Config True in the call, which is all
11956 -- that needs to be done. For the case of ON, this
11957 -- is normally an error, unless it is canceling the
11958 -- effect of a previous OFF pragma in the same file.
11959 -- In any other case, an error will be signalled (ON
11960 -- with no matching OFF).
11962 if Chars
(Argx
) = Name_Off
then
11963 Set_Specific_Warning_Off
11964 (Loc
, Name_Buffer
(1 .. Name_Len
),
11965 Config
=> Is_Configuration_Pragma
);
11967 elsif Chars
(Argx
) = Name_On
then
11968 Set_Specific_Warning_On
11969 (Loc
, Name_Buffer
(1 .. Name_Len
), Err
);
11973 ("?pragma Warnings On with no " &
11974 "matching Warnings Off",
11984 -------------------
11985 -- Weak_External --
11986 -------------------
11988 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
11990 when Pragma_Weak_External
=> Weak_External
: declare
11995 Check_Arg_Count
(1);
11996 Check_Optional_Identifier
(Arg1
, Name_Entity
);
11997 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
11998 Ent
:= Entity
(Expression
(Arg1
));
12000 if Rep_Item_Too_Early
(Ent
, N
) then
12003 Ent
:= Underlying_Type
(Ent
);
12006 -- The only processing required is to link this item on to the
12007 -- list of rep items for the given entity. This is accomplished
12008 -- by the call to Rep_Item_Too_Late (when no error is detected
12009 -- and False is returned).
12011 if Rep_Item_Too_Late
(Ent
, N
) then
12014 Set_Has_Gigi_Rep_Item
(Ent
);
12018 -----------------------------
12019 -- Wide_Character_Encoding --
12020 -----------------------------
12022 -- pragma Wide_Character_Encoding (IDENTIFIER);
12024 when Pragma_Wide_Character_Encoding
=>
12027 -- Nothing to do, handled in parser. Note that we do not enforce
12028 -- configuration pragma placement, this pragma can appear at any
12029 -- place in the source, allowing mixed encodings within a single
12034 --------------------
12035 -- Unknown_Pragma --
12036 --------------------
12038 -- Should be impossible, since the case of an unknown pragma is
12039 -- separately processed before the case statement is entered.
12041 when Unknown_Pragma
=>
12042 raise Program_Error
;
12046 when Pragma_Exit
=> null;
12047 end Analyze_Pragma
;
12049 -------------------
12050 -- Check_Enabled --
12051 -------------------
12053 function Check_Enabled
(Nam
: Name_Id
) return Boolean is
12057 PP
:= Opt
.Check_Policy_List
;
12060 return Assertions_Enabled
;
12063 Nam
= Chars
(Expression
(First
(Pragma_Argument_Associations
(PP
))))
12066 Chars
(Expression
(Last
(Pragma_Argument_Associations
(PP
))))
12068 when Name_On | Name_Check
=>
12070 when Name_Off | Name_Ignore
=>
12073 raise Program_Error
;
12077 PP
:= Next_Pragma
(PP
);
12082 ---------------------------------
12083 -- Delay_Config_Pragma_Analyze --
12084 ---------------------------------
12086 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
12088 return Pragma_Name
(N
) = Name_Interrupt_State
12090 Pragma_Name
(N
) = Name_Priority_Specific_Dispatching
;
12091 end Delay_Config_Pragma_Analyze
;
12093 -------------------------
12094 -- Get_Base_Subprogram --
12095 -------------------------
12097 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
12098 Result
: Entity_Id
;
12101 -- Follow subprogram renaming chain
12104 while Is_Subprogram
(Result
)
12106 (Is_Generic_Instance
(Result
)
12107 or else Nkind
(Parent
(Declaration_Node
(Result
))) =
12108 N_Subprogram_Renaming_Declaration
)
12109 and then Present
(Alias
(Result
))
12111 Result
:= Alias
(Result
);
12115 end Get_Base_Subprogram
;
12117 --------------------
12118 -- Get_Pragma_Arg --
12119 --------------------
12121 function Get_Pragma_Arg
(Arg
: Node_Id
) return Node_Id
is
12123 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
12124 return Expression
(Arg
);
12128 end Get_Pragma_Arg
;
12134 procedure Initialize
is
12139 -----------------------------
12140 -- Is_Config_Static_String --
12141 -----------------------------
12143 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
12145 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
12146 -- This is an internal recursive function that is just like the
12147 -- outer function except that it adds the string to the name buffer
12148 -- rather than placing the string in the name buffer.
12150 ------------------------------
12151 -- Add_Config_Static_String --
12152 ------------------------------
12154 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
12161 if Nkind
(N
) = N_Op_Concat
then
12162 if Add_Config_Static_String
(Left_Opnd
(N
)) then
12163 N
:= Right_Opnd
(N
);
12169 if Nkind
(N
) /= N_String_Literal
then
12170 Error_Msg_N
("string literal expected for pragma argument", N
);
12174 for J
in 1 .. String_Length
(Strval
(N
)) loop
12175 C
:= Get_String_Char
(Strval
(N
), J
);
12177 if not In_Character_Range
(C
) then
12179 ("string literal contains invalid wide character",
12180 Sloc
(N
) + 1 + Source_Ptr
(J
));
12184 Add_Char_To_Name_Buffer
(Get_Character
(C
));
12189 end Add_Config_Static_String
;
12191 -- Start of processing for Is_Config_Static_String
12196 return Add_Config_Static_String
(Arg
);
12197 end Is_Config_Static_String
;
12199 -----------------------------------------
12200 -- Is_Non_Significant_Pragma_Reference --
12201 -----------------------------------------
12203 -- This function makes use of the following static table which indicates
12204 -- whether a given pragma is significant. A value of -1 in this table
12205 -- indicates that the reference is significant. A value of zero indicates
12206 -- than appearance as any argument is insignificant, a positive value
12207 -- indicates that appearance in that parameter position is significant.
12209 -- A value of 99 flags a special case requiring a special check (this is
12210 -- used for cases not covered by this standard encoding, e.g. pragma Check
12211 -- where the first argument is not significant, but the others are).
12213 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
12214 (Pragma_AST_Entry
=> -1,
12215 Pragma_Abort_Defer
=> -1,
12216 Pragma_Ada_83
=> -1,
12217 Pragma_Ada_95
=> -1,
12218 Pragma_Ada_05
=> -1,
12219 Pragma_Ada_2005
=> -1,
12220 Pragma_All_Calls_Remote
=> -1,
12221 Pragma_Annotate
=> -1,
12222 Pragma_Assert
=> -1,
12223 Pragma_Assertion_Policy
=> 0,
12224 Pragma_Assume_No_Invalid_Values
=> 0,
12225 Pragma_Asynchronous
=> -1,
12226 Pragma_Atomic
=> 0,
12227 Pragma_Atomic_Components
=> 0,
12228 Pragma_Attach_Handler
=> -1,
12229 Pragma_Check
=> 99,
12230 Pragma_Check_Name
=> 0,
12231 Pragma_Check_Policy
=> 0,
12232 Pragma_CIL_Constructor
=> -1,
12233 Pragma_CPP_Class
=> 0,
12234 Pragma_CPP_Constructor
=> 0,
12235 Pragma_CPP_Virtual
=> 0,
12236 Pragma_CPP_Vtable
=> 0,
12237 Pragma_C_Pass_By_Copy
=> 0,
12238 Pragma_Comment
=> 0,
12239 Pragma_Common_Object
=> -1,
12240 Pragma_Compile_Time_Error
=> -1,
12241 Pragma_Compile_Time_Warning
=> -1,
12242 Pragma_Compiler_Unit
=> 0,
12243 Pragma_Complete_Representation
=> 0,
12244 Pragma_Complex_Representation
=> 0,
12245 Pragma_Component_Alignment
=> -1,
12246 Pragma_Controlled
=> 0,
12247 Pragma_Convention
=> 0,
12248 Pragma_Convention_Identifier
=> 0,
12249 Pragma_Debug
=> -1,
12250 Pragma_Debug_Policy
=> 0,
12251 Pragma_Detect_Blocking
=> -1,
12252 Pragma_Discard_Names
=> 0,
12253 Pragma_Elaborate
=> -1,
12254 Pragma_Elaborate_All
=> -1,
12255 Pragma_Elaborate_Body
=> -1,
12256 Pragma_Elaboration_Checks
=> -1,
12257 Pragma_Eliminate
=> -1,
12258 Pragma_Export
=> -1,
12259 Pragma_Export_Exception
=> -1,
12260 Pragma_Export_Function
=> -1,
12261 Pragma_Export_Object
=> -1,
12262 Pragma_Export_Procedure
=> -1,
12263 Pragma_Export_Value
=> -1,
12264 Pragma_Export_Valued_Procedure
=> -1,
12265 Pragma_Extend_System
=> -1,
12266 Pragma_Extensions_Allowed
=> -1,
12267 Pragma_External
=> -1,
12268 Pragma_Favor_Top_Level
=> -1,
12269 Pragma_External_Name_Casing
=> -1,
12270 Pragma_Fast_Math
=> -1,
12271 Pragma_Finalize_Storage_Only
=> 0,
12272 Pragma_Float_Representation
=> 0,
12273 Pragma_Ident
=> -1,
12274 Pragma_Implemented_By_Entry
=> -1,
12275 Pragma_Implicit_Packing
=> 0,
12276 Pragma_Import
=> +2,
12277 Pragma_Import_Exception
=> 0,
12278 Pragma_Import_Function
=> 0,
12279 Pragma_Import_Object
=> 0,
12280 Pragma_Import_Procedure
=> 0,
12281 Pragma_Import_Valued_Procedure
=> 0,
12282 Pragma_Initialize_Scalars
=> -1,
12283 Pragma_Inline
=> 0,
12284 Pragma_Inline_Always
=> 0,
12285 Pragma_Inline_Generic
=> 0,
12286 Pragma_Inspection_Point
=> -1,
12287 Pragma_Interface
=> +2,
12288 Pragma_Interface_Name
=> +2,
12289 Pragma_Interrupt_Handler
=> -1,
12290 Pragma_Interrupt_Priority
=> -1,
12291 Pragma_Interrupt_State
=> -1,
12292 Pragma_Java_Constructor
=> -1,
12293 Pragma_Java_Interface
=> -1,
12294 Pragma_Keep_Names
=> 0,
12295 Pragma_License
=> -1,
12296 Pragma_Link_With
=> -1,
12297 Pragma_Linker_Alias
=> -1,
12298 Pragma_Linker_Constructor
=> -1,
12299 Pragma_Linker_Destructor
=> -1,
12300 Pragma_Linker_Options
=> -1,
12301 Pragma_Linker_Section
=> -1,
12303 Pragma_Locking_Policy
=> -1,
12304 Pragma_Long_Float
=> -1,
12305 Pragma_Machine_Attribute
=> -1,
12307 Pragma_Main_Storage
=> -1,
12308 Pragma_Memory_Size
=> -1,
12309 Pragma_No_Return
=> 0,
12310 Pragma_No_Body
=> 0,
12311 Pragma_No_Run_Time
=> -1,
12312 Pragma_No_Strict_Aliasing
=> -1,
12313 Pragma_Normalize_Scalars
=> -1,
12314 Pragma_Obsolescent
=> 0,
12315 Pragma_Optimize
=> -1,
12316 Pragma_Optimize_Alignment
=> -1,
12319 Pragma_Passive
=> -1,
12320 Pragma_Preelaborable_Initialization
=> -1,
12321 Pragma_Polling
=> -1,
12322 Pragma_Persistent_BSS
=> 0,
12323 Pragma_Postcondition
=> -1,
12324 Pragma_Precondition
=> -1,
12325 Pragma_Preelaborate
=> -1,
12326 Pragma_Preelaborate_05
=> -1,
12327 Pragma_Priority
=> -1,
12328 Pragma_Priority_Specific_Dispatching
=> -1,
12329 Pragma_Profile
=> 0,
12330 Pragma_Profile_Warnings
=> 0,
12331 Pragma_Propagate_Exceptions
=> -1,
12332 Pragma_Psect_Object
=> -1,
12334 Pragma_Pure_05
=> -1,
12335 Pragma_Pure_Function
=> -1,
12336 Pragma_Queuing_Policy
=> -1,
12337 Pragma_Ravenscar
=> -1,
12338 Pragma_Relative_Deadline
=> -1,
12339 Pragma_Remote_Call_Interface
=> -1,
12340 Pragma_Remote_Types
=> -1,
12341 Pragma_Restricted_Run_Time
=> -1,
12342 Pragma_Restriction_Warnings
=> -1,
12343 Pragma_Restrictions
=> -1,
12344 Pragma_Reviewable
=> -1,
12345 Pragma_Share_Generic
=> -1,
12346 Pragma_Shared
=> -1,
12347 Pragma_Shared_Passive
=> -1,
12348 Pragma_Source_File_Name
=> -1,
12349 Pragma_Source_File_Name_Project
=> -1,
12350 Pragma_Source_Reference
=> -1,
12351 Pragma_Storage_Size
=> -1,
12352 Pragma_Storage_Unit
=> -1,
12353 Pragma_Static_Elaboration_Desired
=> -1,
12354 Pragma_Stream_Convert
=> -1,
12355 Pragma_Style_Checks
=> -1,
12356 Pragma_Subtitle
=> -1,
12357 Pragma_Suppress
=> 0,
12358 Pragma_Suppress_Exception_Locations
=> 0,
12359 Pragma_Suppress_All
=> -1,
12360 Pragma_Suppress_Debug_Info
=> 0,
12361 Pragma_Suppress_Initialization
=> 0,
12362 Pragma_System_Name
=> -1,
12363 Pragma_Task_Dispatching_Policy
=> -1,
12364 Pragma_Task_Info
=> -1,
12365 Pragma_Task_Name
=> -1,
12366 Pragma_Task_Storage
=> 0,
12367 Pragma_Time_Slice
=> -1,
12368 Pragma_Title
=> -1,
12369 Pragma_Unchecked_Union
=> 0,
12370 Pragma_Unimplemented_Unit
=> -1,
12371 Pragma_Universal_Aliasing
=> -1,
12372 Pragma_Universal_Data
=> -1,
12373 Pragma_Unmodified
=> -1,
12374 Pragma_Unreferenced
=> -1,
12375 Pragma_Unreferenced_Objects
=> -1,
12376 Pragma_Unreserve_All_Interrupts
=> -1,
12377 Pragma_Unsuppress
=> 0,
12378 Pragma_Use_VADS_Size
=> -1,
12379 Pragma_Validity_Checks
=> -1,
12380 Pragma_Volatile
=> 0,
12381 Pragma_Volatile_Components
=> 0,
12382 Pragma_Warnings
=> -1,
12383 Pragma_Weak_External
=> -1,
12384 Pragma_Wide_Character_Encoding
=> 0,
12385 Unknown_Pragma
=> 0);
12387 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
12396 if Nkind
(P
) /= N_Pragma_Argument_Association
then
12400 Id
:= Get_Pragma_Id
(Parent
(P
));
12401 C
:= Sig_Flags
(Id
);
12413 -- For pragma Check, the first argument is not significant,
12414 -- the second and the third (if present) arguments are
12417 when Pragma_Check
=>
12419 P
= First
(Pragma_Argument_Associations
(Parent
(P
)));
12422 raise Program_Error
;
12426 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
12427 for J
in 1 .. C
- 1 loop
12435 return A
= P
; -- is this wrong way round ???
12438 end Is_Non_Significant_Pragma_Reference
;
12440 ------------------------------
12441 -- Is_Pragma_String_Literal --
12442 ------------------------------
12444 -- This function returns true if the corresponding pragma argument is
12445 -- a static string expression. These are the only cases in which string
12446 -- literals can appear as pragma arguments. We also allow a string
12447 -- literal as the first argument to pragma Assert (although it will
12448 -- of course always generate a type error).
12450 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
12451 Pragn
: constant Node_Id
:= Parent
(Par
);
12452 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
12453 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
12459 N
:= First
(Assoc
);
12466 if Pname
= Name_Assert
then
12469 elsif Pname
= Name_Export
then
12472 elsif Pname
= Name_Ident
then
12475 elsif Pname
= Name_Import
then
12478 elsif Pname
= Name_Interface_Name
then
12481 elsif Pname
= Name_Linker_Alias
then
12484 elsif Pname
= Name_Linker_Section
then
12487 elsif Pname
= Name_Machine_Attribute
then
12490 elsif Pname
= Name_Source_File_Name
then
12493 elsif Pname
= Name_Source_Reference
then
12496 elsif Pname
= Name_Title
then
12499 elsif Pname
= Name_Subtitle
then
12505 end Is_Pragma_String_Literal
;
12507 --------------------------------------
12508 -- Process_Compilation_Unit_Pragmas --
12509 --------------------------------------
12511 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
12513 -- A special check for pragma Suppress_All. This is a strange DEC
12514 -- pragma, strange because it comes at the end of the unit. If we
12515 -- have a pragma Suppress_All in the Pragmas_After of the current
12516 -- unit, then we insert a pragma Suppress (All_Checks) at the start
12517 -- of the context clause to ensure the correct processing.
12520 PA
: constant List_Id
:= Pragmas_After
(Aux_Decls_Node
(N
));
12524 if Present
(PA
) then
12526 while Present
(P
) loop
12527 if Pragma_Name
(P
) = Name_Suppress_All
then
12528 Prepend_To
(Context_Items
(N
),
12529 Make_Pragma
(Sloc
(P
),
12530 Chars
=> Name_Suppress
,
12531 Pragma_Argument_Associations
=> New_List
(
12532 Make_Pragma_Argument_Association
(Sloc
(P
),
12534 Make_Identifier
(Sloc
(P
),
12535 Chars
=> Name_All_Checks
)))));
12543 end Process_Compilation_Unit_Pragmas
;
12554 --------------------------------
12555 -- Set_Encoded_Interface_Name --
12556 --------------------------------
12558 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
12559 Str
: constant String_Id
:= Strval
(S
);
12560 Len
: constant Int
:= String_Length
(Str
);
12565 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
12568 -- Stores encoded value of character code CC. The encoding we
12569 -- use an underscore followed by four lower case hex digits.
12575 procedure Encode
is
12577 Store_String_Char
(Get_Char_Code
('_'));
12579 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
12581 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
12583 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
12585 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
12588 -- Start of processing for Set_Encoded_Interface_Name
12591 -- If first character is asterisk, this is a link name, and we
12592 -- leave it completely unmodified. We also ignore null strings
12593 -- (the latter case happens only in error cases) and no encoding
12594 -- should occur for Java or AAMP interface names.
12597 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
12598 or else VM_Target
/= No_VM
12599 or else AAMP_On_Target
12601 Set_Interface_Name
(E
, S
);
12606 CC
:= Get_String_Char
(Str
, J
);
12608 exit when not In_Character_Range
(CC
);
12610 C
:= Get_Character
(CC
);
12612 exit when C
/= '_' and then C
/= '$'
12613 and then C
not in '0' .. '9'
12614 and then C
not in 'a' .. 'z'
12615 and then C
not in 'A' .. 'Z';
12618 Set_Interface_Name
(E
, S
);
12626 -- Here we need to encode. The encoding we use as follows:
12627 -- three underscores + four hex digits (lower case)
12631 for J
in 1 .. String_Length
(Str
) loop
12632 CC
:= Get_String_Char
(Str
, J
);
12634 if not In_Character_Range
(CC
) then
12637 C
:= Get_Character
(CC
);
12639 if C
= '_' or else C
= '$'
12640 or else C
in '0' .. '9'
12641 or else C
in 'a' .. 'z'
12642 or else C
in 'A' .. 'Z'
12644 Store_String_Char
(CC
);
12651 Set_Interface_Name
(E
,
12652 Make_String_Literal
(Sloc
(S
),
12653 Strval
=> End_String
));
12655 end Set_Encoded_Interface_Name
;
12657 -------------------
12658 -- Set_Unit_Name --
12659 -------------------
12661 procedure Set_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
12666 if Nkind
(N
) = N_Identifier
12667 and then Nkind
(With_Item
) = N_Identifier
12669 Set_Entity
(N
, Entity
(With_Item
));
12671 elsif Nkind
(N
) = N_Selected_Component
then
12672 Change_Selected_Component_To_Expanded_Name
(N
);
12673 Set_Entity
(N
, Entity
(With_Item
));
12674 Set_Entity
(Selector_Name
(N
), Entity
(N
));
12676 Pref
:= Prefix
(N
);
12677 Scop
:= Scope
(Entity
(N
));
12678 while Nkind
(Pref
) = N_Selected_Component
loop
12679 Change_Selected_Component_To_Expanded_Name
(Pref
);
12680 Set_Entity
(Selector_Name
(Pref
), Scop
);
12681 Set_Entity
(Pref
, Scop
);
12682 Pref
:= Prefix
(Pref
);
12683 Scop
:= Scope
(Scop
);
12686 Set_Entity
(Pref
, Scop
);