1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 Elists; use Elists;
39 with Errout; use Errout;
40 with Exp_Ch7; use Exp_Ch7;
41 with Exp_Dist; use Exp_Dist;
43 with Lib.Writ; use Lib.Writ;
44 with Lib.Xref; use Lib.Xref;
45 with Namet.Sp; use Namet.Sp;
46 with Nlists; use Nlists;
47 with Nmake; use Nmake;
49 with Output; use Output;
50 with Par_SCO; use Par_SCO;
51 with Restrict; use Restrict;
52 with Rident; use Rident;
53 with Rtsfind; use Rtsfind;
55 with Sem_Aux; use Sem_Aux;
56 with Sem_Ch3; use Sem_Ch3;
57 with Sem_Ch6; use Sem_Ch6;
58 with Sem_Ch8; use Sem_Ch8;
59 with Sem_Ch12; use Sem_Ch12;
60 with Sem_Ch13; use Sem_Ch13;
61 with Sem_Disp; use Sem_Disp;
62 with Sem_Dist; use Sem_Dist;
63 with Sem_Elim; use Sem_Elim;
64 with Sem_Eval; use Sem_Eval;
65 with Sem_Intr; use Sem_Intr;
66 with Sem_Mech; use Sem_Mech;
67 with Sem_Res; use Sem_Res;
68 with Sem_Type; use Sem_Type;
69 with Sem_Util; use Sem_Util;
70 with Sem_VFpt; use Sem_VFpt;
71 with Sem_Warn; use Sem_Warn;
72 with Stand; use Stand;
73 with Sinfo; use Sinfo;
74 with Sinfo.CN; use Sinfo.CN;
75 with Sinput; use Sinput;
76 with Snames; use Snames;
77 with Stringt; use Stringt;
78 with Stylesw; use Stylesw;
80 with Targparm; use Targparm;
81 with Tbuild; use Tbuild;
83 with Uintp; use Uintp;
84 with Uname; use Uname;
85 with Urealp; use Urealp;
86 with Validsw; use Validsw;
88 package body Sem_Prag is
90 ----------------------------------------------
91 -- Common Handling of Import-Export Pragmas --
92 ----------------------------------------------
94 -- In the following section, a number of Import_xxx and Export_xxx pragmas
95 -- are defined by GNAT. These are compatible with the DEC pragmas of the
96 -- same name, and all have the following common form and processing:
99 -- [Internal =>] LOCAL_NAME
100 -- [, [External =>] EXTERNAL_SYMBOL]
101 -- [, other optional parameters ]);
104 -- [Internal =>] LOCAL_NAME
105 -- [, [External =>] EXTERNAL_SYMBOL]
106 -- [, other optional parameters ]);
108 -- EXTERNAL_SYMBOL ::=
110 -- | static_string_EXPRESSION
112 -- The internal LOCAL_NAME designates the entity that is imported or
113 -- exported, and must refer to an entity in the current declarative
114 -- part (as required by the rules for LOCAL_NAME).
116 -- The external linker name is designated by the External parameter if
117 -- given, or the Internal parameter if not (if there is no External
118 -- parameter, the External parameter is a copy of the Internal name).
120 -- If the External parameter is given as a string, then this string is
121 -- treated as an external name (exactly as though it had been given as an
122 -- External_Name parameter for a normal Import pragma).
124 -- If the External parameter is given as an identifier (or there is no
125 -- External parameter, so that the Internal identifier is used), then
126 -- the external name is the characters of the identifier, translated
127 -- to all upper case letters for OpenVMS versions of GNAT, and to all
128 -- lower case letters for all other versions
130 -- Note: the external name specified or implied by any of these special
131 -- Import_xxx or Export_xxx pragmas override an external or link name
132 -- specified in a previous Import or Export pragma.
134 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
135 -- named notation, following the standard rules for subprogram calls, i.e.
136 -- parameters can be given in any order if named notation is used, and
137 -- positional and named notation can be mixed, subject to the rule that all
138 -- positional parameters must appear first.
140 -- Note: All these pragmas are implemented exactly following the DEC design
141 -- and implementation and are intended to be fully compatible with the use
142 -- of these pragmas in the DEC Ada compiler.
144 --------------------------------------------
145 -- Checking for Duplicated External Names --
146 --------------------------------------------
148 -- It is suspicious if two separate Export pragmas use the same external
149 -- name. The following table is used to diagnose this situation so that
150 -- an appropriate warning can be issued.
152 -- The Node_Id stored is for the N_String_Literal node created to hold
153 -- the value of the external name. The Sloc of this node is used to
154 -- cross-reference the location of the duplication.
156 package Externals is new Table.Table (
157 Table_Component_Type => Node_Id,
158 Table_Index_Type => Int,
159 Table_Low_Bound => 0,
160 Table_Initial => 100,
161 Table_Increment => 100,
162 Table_Name => "Name_Externals");
164 -------------------------------------
165 -- Local Subprograms and Variables --
166 -------------------------------------
168 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
169 -- This routine is used for possible casing adjustment of an explicit
170 -- external name supplied as a string literal (the node N), according to
171 -- the casing requirement of Opt.External_Name_Casing. If this is set to
172 -- As_Is, then the string literal is returned unchanged, but if it is set
173 -- to Uppercase or Lowercase, then a new string literal with appropriate
174 -- casing is constructed.
176 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
177 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
178 -- original one, following the renaming chain) is returned. Otherwise the
179 -- entity is returned unchanged. Should be in Einfo???
182 -- This is a dummy function called by the processing for pragma Reviewable.
183 -- It is there for assisting front end debugging. By placing a Reviewable
184 -- pragma in the source program, a breakpoint on rv catches this place in
185 -- the source, allowing convenient stepping to the point of interest.
187 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
188 -- Place semantic information on the argument of an Elaborate/Elaborate_All
189 -- pragma. Entity name for unit and its parents is taken from item in
190 -- previous with_clause that mentions the unit.
192 -------------------------------
193 -- Adjust_External_Name_Case --
194 -------------------------------
196 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
200 -- Adjust case of literal if required
202 if Opt.External_Name_Exp_Casing = As_Is then
206 -- Copy existing string
212 for J in 1 .. String_Length (Strval (N)) loop
213 CC := Get_String_Char (Strval (N), J);
215 if Opt.External_Name_Exp_Casing = Uppercase
216 and then CC >= Get_Char_Code ('a')
217 and then CC <= Get_Char_Code ('z')
219 Store_String_Char (CC - 32);
221 elsif Opt.External_Name_Exp_Casing = Lowercase
222 and then CC >= Get_Char_Code ('A')
223 and then CC <= Get_Char_Code ('Z')
225 Store_String_Char (CC + 32);
228 Store_String_Char (CC);
233 Make_String_Literal (Sloc (N),
234 Strval => End_String);
236 end Adjust_External_Name_Case;
238 ------------------------------
239 -- Analyze_PPC_In_Decl_Part --
240 ------------------------------
242 procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
243 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
246 -- Install formals and push subprogram spec onto scope stack so that we
247 -- can see the formals from the pragma.
252 -- Preanalyze the boolean expression, we treat this as a spec expression
253 -- (i.e. similar to a default expression).
255 Preanalyze_Spec_Expression
256 (Get_Pragma_Arg (Arg1), Standard_Boolean);
258 -- Remove the subprogram from the scope stack now that the pre-analysis
259 -- of the precondition/postcondition is done.
262 end Analyze_PPC_In_Decl_Part;
268 procedure Analyze_Pragma (N : Node_Id) is
269 Loc : constant Source_Ptr := Sloc (N);
270 Pname : constant Name_Id := Pragma_Name (N);
273 Sense : constant Boolean := not Aspect_Cancel (N);
274 -- Sense is True if we have the normal case of a pragma that is active
275 -- and turns the corresponding aspect on. It is false only for the case
276 -- of a pragma coming from an aspect which is explicitly turned off by
277 -- using aspect => False. If Sense is False, the effect of the pragma
278 -- is to turn the corresponding aspect off.
280 Pragma_Exit : exception;
281 -- This exception is used to exit pragma processing completely. It is
282 -- used when an error is detected, and no further processing is
283 -- required. It is also used if an earlier error has left the tree in
284 -- a state where the pragma should not be processed.
287 -- Number of pragma argument associations
293 -- First four pragma arguments (pragma argument association nodes, or
294 -- Empty if the corresponding argument does not exist).
296 type Name_List is array (Natural range <>) of Name_Id;
297 type Args_List is array (Natural range <>) of Node_Id;
298 -- Types used for arguments to Check_Arg_Order and Gather_Associations
300 procedure Ada_2005_Pragma;
301 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
302 -- Ada 95 mode, these are implementation defined pragmas, so should be
303 -- caught by the No_Implementation_Pragmas restriction.
305 procedure Ada_2012_Pragma;
306 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
307 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
308 -- should be caught by the No_Implementation_Pragmas restriction.
310 procedure Check_Ada_83_Warning;
311 -- Issues a warning message for the current pragma if operating in Ada
312 -- 83 mode (used for language pragmas that are not a standard part of
313 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
316 procedure Check_Arg_Count (Required : Nat);
317 -- Check argument count for pragma is equal to given parameter. If not,
318 -- then issue an error message and raise Pragma_Exit.
320 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
321 -- Arg which can either be a pragma argument association, in which case
322 -- the check is applied to the expression of the association or an
323 -- expression directly.
325 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
326 -- Check that an argument has the right form for an EXTERNAL_NAME
327 -- parameter of an extended import/export pragma. The rule is that the
328 -- name must be an identifier or string literal (in Ada 83 mode) or a
329 -- static string expression (in Ada 95 mode).
331 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
332 -- Check the specified argument Arg to make sure that it is an
333 -- identifier. If not give error and raise Pragma_Exit.
335 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
336 -- Check the specified argument Arg to make sure that it is an integer
337 -- literal. If not give error and raise Pragma_Exit.
339 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
340 -- Check the specified argument Arg to make sure that it has the proper
341 -- syntactic form for a local name and meets the semantic requirements
342 -- for a local name. The local name is analyzed as part of the
343 -- processing for this call. In addition, the local name is required
344 -- to represent an entity at the library level.
346 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
347 -- Check the specified argument Arg to make sure that it has the proper
348 -- syntactic form for a local name and meets the semantic requirements
349 -- for a local name. The local name is analyzed as part of the
350 -- processing for this call.
352 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
353 -- Check the specified argument Arg to make sure that it is a valid
354 -- locking policy name. If not give error and raise Pragma_Exit.
356 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
357 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id);
358 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3, N4 : Name_Id);
359 -- Check the specified argument Arg to make sure that it is an
360 -- identifier whose name matches either N1 or N2 (or N3 if present).
361 -- If not then give error and raise Pragma_Exit.
363 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
364 -- Check the specified argument Arg to make sure that it is a valid
365 -- queuing policy name. If not give error and raise Pragma_Exit.
367 procedure Check_Arg_Is_Static_Expression
369 Typ : Entity_Id := Empty);
370 -- Check the specified argument Arg to make sure that it is a static
371 -- expression of the given type (i.e. it will be analyzed and resolved
372 -- using this type, which can be any valid argument to Resolve, e.g.
373 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
374 -- Typ is left Empty, then any static expression is allowed.
376 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
377 -- Check the specified argument Arg to make sure that it is a valid task
378 -- dispatching policy name. If not give error and raise Pragma_Exit.
380 procedure Check_Arg_Order (Names : Name_List);
381 -- Checks for an instance of two arguments with identifiers for the
382 -- current pragma which are not in the sequence indicated by Names,
383 -- and if so, generates a fatal message about bad order of arguments.
385 procedure Check_At_Least_N_Arguments (N : Nat);
386 -- Check there are at least N arguments present
388 procedure Check_At_Most_N_Arguments (N : Nat);
389 -- Check there are no more than N arguments present
391 procedure Check_Component
394 In_Variant_Part : Boolean := False);
395 -- Examine an Unchecked_Union component for correct use of per-object
396 -- constrained subtypes, and for restrictions on finalizable components.
397 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
398 -- should be set when Comp comes from a record variant.
400 procedure Check_Duplicate_Pragma (E : Entity_Id);
401 -- Check if a pragma of the same name as the current pragma is already
402 -- chained as a rep pragma to the given entity. If so give a message
403 -- about the duplicate, and then raise Pragma_Exit so does not return.
404 -- Also checks for delayed aspect specification node in the chain.
406 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
407 -- Nam is an N_String_Literal node containing the external name set by
408 -- an Import or Export pragma (or extended Import or Export pragma).
409 -- This procedure checks for possible duplications if this is the export
410 -- case, and if found, issues an appropriate error message.
412 procedure Check_First_Subtype (Arg : Node_Id);
413 -- Checks that Arg, whose expression is an entity name referencing a
414 -- subtype, does not reference a type that is not a first subtype.
416 procedure Check_In_Main_Program;
417 -- Common checks for pragmas that appear within a main program
418 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline).
420 procedure Check_Interrupt_Or_Attach_Handler;
421 -- Common processing for first argument of pragma Interrupt_Handler or
422 -- pragma Attach_Handler.
424 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
425 -- Check that pragma appears in a declarative part, or in a package
426 -- specification, i.e. that it does not occur in a statement sequence
429 procedure Check_No_Identifier (Arg : Node_Id);
430 -- Checks that the given argument does not have an identifier. If
431 -- an identifier is present, then an error message is issued, and
432 -- Pragma_Exit is raised.
434 procedure Check_No_Identifiers;
435 -- Checks that none of the arguments to the pragma has an identifier.
436 -- If any argument has an identifier, then an error message is issued,
437 -- and Pragma_Exit is raised.
439 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
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.
444 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
445 -- Checks if the given argument has an identifier, and if so, requires
446 -- it to match the given identifier name. If there is a non-matching
447 -- identifier, then an error message is given and Error_Pragmas raised.
448 -- In this version of the procedure, the identifier name is given as
449 -- a string with lower case letters.
451 procedure Check_Precondition_Postcondition (In_Body : out Boolean);
452 -- Called to process a precondition or postcondition pragma. There are
455 -- The pragma appears after a subprogram spec
457 -- If the corresponding check is not enabled, the pragma is analyzed
458 -- but otherwise ignored and control returns with In_Body set False.
460 -- If the check is enabled, then the first step is to analyze the
461 -- pragma, but this is skipped if the subprogram spec appears within
462 -- a package specification (because this is the case where we delay
463 -- analysis till the end of the spec). Then (whether or not it was
464 -- analyzed), the pragma is chained to the subprogram in question
465 -- (using Spec_PPC_List and Next_Pragma) and control returns to the
466 -- caller with In_Body set False.
468 -- The pragma appears at the start of subprogram body declarations
470 -- In this case an immediate return to the caller is made with
471 -- In_Body set True, and the pragma is NOT analyzed.
473 -- In all other cases, an error message for bad placement is given
475 procedure Check_Static_Constraint (Constr : Node_Id);
476 -- Constr is a constraint from an N_Subtype_Indication node from a
477 -- component constraint in an Unchecked_Union type. This routine checks
478 -- that the constraint is static as required by the restrictions for
481 procedure Check_Valid_Configuration_Pragma;
482 -- Legality checks for placement of a configuration pragma
484 procedure Check_Valid_Library_Unit_Pragma;
485 -- Legality checks for library unit pragmas. A special case arises for
486 -- pragmas in generic instances that come from copies of the original
487 -- library unit pragmas in the generic templates. In the case of other
488 -- than library level instantiations these can appear in contexts which
489 -- would normally be invalid (they only apply to the original template
490 -- and to library level instantiations), and they are simply ignored,
491 -- which is implemented by rewriting them as null statements.
493 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
494 -- Check an Unchecked_Union variant for lack of nested variants and
495 -- presence of at least one component. UU_Typ is the related Unchecked_
498 procedure Error_Pragma (Msg : String);
499 pragma No_Return (Error_Pragma);
500 -- Outputs error message for current pragma. The message contains a %
501 -- that will be replaced with the pragma name, and the flag is placed
502 -- on the pragma itself. Pragma_Exit is then raised.
504 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
505 pragma No_Return (Error_Pragma_Arg);
506 -- Outputs error message for current pragma. The message may contain
507 -- a % that will be replaced with the pragma name. The parameter Arg
508 -- may either be a pragma argument association, in which case the flag
509 -- is placed on the expression of this association, or an expression,
510 -- in which case the flag is placed directly on the expression. The
511 -- message is placed using Error_Msg_N, so the message may also contain
512 -- an & insertion character which will reference the given Arg value.
513 -- After placing the message, Pragma_Exit is raised.
515 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
516 pragma No_Return (Error_Pragma_Arg);
517 -- Similar to above form of Error_Pragma_Arg except that two messages
518 -- are provided, the second is a continuation comment starting with \.
520 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
521 pragma No_Return (Error_Pragma_Arg_Ident);
522 -- Outputs error message for current pragma. The message may contain
523 -- a % that will be replaced with the pragma name. The parameter Arg
524 -- must be a pragma argument association with a non-empty identifier
525 -- (i.e. its Chars field must be set), and the error message is placed
526 -- on the identifier. The message is placed using Error_Msg_N so
527 -- the message may also contain an & insertion character which will
528 -- reference the identifier. After placing the message, Pragma_Exit
531 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
532 pragma No_Return (Error_Pragma_Ref);
533 -- Outputs error message for current pragma. The message may contain
534 -- a % that will be replaced with the pragma name. The parameter Ref
535 -- must be an entity whose name can be referenced by & and sloc by #.
536 -- After placing the message, Pragma_Exit is raised.
538 function Find_Lib_Unit_Name return Entity_Id;
539 -- Used for a library unit pragma to find the entity to which the
540 -- library unit pragma applies, returns the entity found.
542 procedure Find_Program_Unit_Name (Id : Node_Id);
543 -- If the pragma is a compilation unit pragma, the id must denote the
544 -- compilation unit in the same compilation, and the pragma must appear
545 -- in the list of preceding or trailing pragmas. If it is a program
546 -- unit pragma that is not a compilation unit pragma, then the
547 -- identifier must be visible.
549 function Find_Unique_Parameterless_Procedure
551 Arg : Node_Id) return Entity_Id;
552 -- Used for a procedure pragma to find the unique parameterless
553 -- procedure identified by Name, returns it if it exists, otherwise
554 -- errors out and uses Arg as the pragma argument for the message.
556 procedure Fix_Error (Msg : in out String);
557 -- This is called prior to issuing an error message. Msg is a string
558 -- which typically contains the substring pragma. If the current pragma
559 -- comes from an aspect, each such "pragma" substring is replaced with
560 -- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
561 -- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).
563 procedure Gather_Associations
565 Args : out Args_List);
566 -- This procedure is used to gather the arguments for a pragma that
567 -- permits arbitrary ordering of parameters using the normal rules
568 -- for named and positional parameters. The Names argument is a list
569 -- of Name_Id values that corresponds to the allowed pragma argument
570 -- association identifiers in order. The result returned in Args is
571 -- a list of corresponding expressions that are the pragma arguments.
572 -- Note that this is a list of expressions, not of pragma argument
573 -- associations (Gather_Associations has completely checked all the
574 -- optional identifiers when it returns). An entry in Args is Empty
575 -- on return if the corresponding argument is not present.
577 procedure GNAT_Pragma;
578 -- Called for all GNAT defined pragmas to check the relevant restriction
579 -- (No_Implementation_Pragmas).
581 function Is_Before_First_Decl
582 (Pragma_Node : Node_Id;
583 Decls : List_Id) return Boolean;
584 -- Return True if Pragma_Node is before the first declarative item in
585 -- Decls where Decls is the list of declarative items.
587 function Is_Configuration_Pragma return Boolean;
588 -- Determines if the placement of the current pragma is appropriate
589 -- for a configuration pragma.
591 function Is_In_Context_Clause return Boolean;
592 -- Returns True if pragma appears within the context clause of a unit,
593 -- and False for any other placement (does not generate any messages).
595 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
596 -- Analyzes the argument, and determines if it is a static string
597 -- expression, returns True if so, False if non-static or not String.
599 procedure Pragma_Misplaced;
600 pragma No_Return (Pragma_Misplaced);
601 -- Issue fatal error message for misplaced pragma
603 procedure Process_Atomic_Shared_Volatile;
604 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
605 -- Shared is an obsolete Ada 83 pragma, treated as being identical
606 -- in effect to pragma Atomic.
608 procedure Process_Compile_Time_Warning_Or_Error;
609 -- Common processing for Compile_Time_Error and Compile_Time_Warning
611 procedure Process_Convention
612 (C : out Convention_Id;
613 Ent : out Entity_Id);
614 -- Common processing for Convention, Interface, Import and Export.
615 -- Checks first two arguments of pragma, and sets the appropriate
616 -- convention value in the specified entity or entities. On return
617 -- C is the convention, Ent is the referenced entity.
619 procedure Process_Extended_Import_Export_Exception_Pragma
620 (Arg_Internal : Node_Id;
621 Arg_External : Node_Id;
624 -- Common processing for the pragmas Import/Export_Exception. The three
625 -- arguments correspond to the three named parameters of the pragma. An
626 -- argument is empty if the corresponding parameter is not present in
629 procedure Process_Extended_Import_Export_Object_Pragma
630 (Arg_Internal : Node_Id;
631 Arg_External : Node_Id;
633 -- Common processing for the pragmas Import/Export_Object. The three
634 -- arguments correspond to the three named parameters of the pragmas. An
635 -- argument is empty if the corresponding parameter is not present in
638 procedure Process_Extended_Import_Export_Internal_Arg
639 (Arg_Internal : Node_Id := Empty);
640 -- Common processing for all extended Import and Export pragmas. The
641 -- argument is the pragma parameter for the Internal argument. If
642 -- Arg_Internal is empty or inappropriate, an error message is posted.
643 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
644 -- set to identify the referenced entity.
646 procedure Process_Extended_Import_Export_Subprogram_Pragma
647 (Arg_Internal : Node_Id;
648 Arg_External : Node_Id;
649 Arg_Parameter_Types : Node_Id;
650 Arg_Result_Type : Node_Id := Empty;
651 Arg_Mechanism : Node_Id;
652 Arg_Result_Mechanism : Node_Id := Empty;
653 Arg_First_Optional_Parameter : Node_Id := Empty);
654 -- Common processing for all extended Import and Export pragmas applying
655 -- to subprograms. The caller omits any arguments that do not apply to
656 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
657 -- only in the Import_Function and Export_Function cases). The argument
658 -- names correspond to the allowed pragma association identifiers.
660 procedure Process_Generic_List;
661 -- Common processing for Share_Generic and Inline_Generic
663 procedure Process_Import_Or_Interface;
664 -- Common processing for Import of Interface
666 procedure Process_Inline (Active : Boolean);
667 -- Common processing for Inline and Inline_Always. The parameter
668 -- indicates if the inline pragma is active, i.e. if it should actually
669 -- cause inlining to occur.
671 procedure Process_Interface_Name
672 (Subprogram_Def : Entity_Id;
675 -- Given the last two arguments of pragma Import, pragma Export, or
676 -- pragma Interface_Name, performs validity checks and sets the
677 -- Interface_Name field of the given subprogram entity to the
678 -- appropriate external or link name, depending on the arguments given.
679 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
680 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
681 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
682 -- nor Link_Arg is present, the interface name is set to the default
683 -- from the subprogram name.
685 procedure Process_Interrupt_Or_Attach_Handler;
686 -- Common processing for Interrupt and Attach_Handler pragmas
688 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
689 -- Common processing for Restrictions and Restriction_Warnings pragmas.
690 -- Warn is True for Restriction_Warnings, or for Restrictions if the
691 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
692 -- is not set in the Restrictions case.
694 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
695 -- Common processing for Suppress and Unsuppress. The boolean parameter
696 -- Suppress_Case is True for the Suppress case, and False for the
699 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
700 -- This procedure sets the Is_Exported flag for the given entity,
701 -- checking that the entity was not previously imported. Arg is
702 -- the argument that specified the entity. A check is also made
703 -- for exporting inappropriate entities.
705 procedure Set_Extended_Import_Export_External_Name
706 (Internal_Ent : Entity_Id;
707 Arg_External : Node_Id);
708 -- Common processing for all extended import export pragmas. The first
709 -- argument, Internal_Ent, is the internal entity, which has already
710 -- been checked for validity by the caller. Arg_External is from the
711 -- Import or Export pragma, and may be null if no External parameter
712 -- was present. If Arg_External is present and is a non-null string
713 -- (a null string is treated as the default), then the Interface_Name
714 -- field of Internal_Ent is set appropriately.
716 procedure Set_Imported (E : Entity_Id);
717 -- This procedure sets the Is_Imported flag for the given entity,
718 -- checking that it is not previously exported or imported.
720 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
721 -- Mech is a parameter passing mechanism (see Import_Function syntax
722 -- for MECHANISM_NAME). This routine checks that the mechanism argument
723 -- has the right form, and if not issues an error message. If the
724 -- argument has the right form then the Mechanism field of Ent is
725 -- set appropriately.
727 procedure Set_Ravenscar_Profile (N : Node_Id);
728 -- Activate the set of configuration pragmas and restrictions that make
729 -- up the Ravenscar Profile. N is the corresponding pragma node, which
730 -- is used for error messages on any constructs that violate the
733 ---------------------
734 -- Ada_2005_Pragma --
735 ---------------------
737 procedure Ada_2005_Pragma is
739 if Ada_Version <= Ada_95 then
740 Check_Restriction (No_Implementation_Pragmas, N);
744 ---------------------
745 -- Ada_2012_Pragma --
746 ---------------------
748 procedure Ada_2012_Pragma is
750 if Ada_Version <= Ada_2005 then
751 Check_Restriction (No_Implementation_Pragmas, N);
755 --------------------------
756 -- Check_Ada_83_Warning --
757 --------------------------
759 procedure Check_Ada_83_Warning is
761 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
762 Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
764 end Check_Ada_83_Warning;
766 ---------------------
767 -- Check_Arg_Count --
768 ---------------------
770 procedure Check_Arg_Count (Required : Nat) is
772 if Arg_Count /= Required then
773 Error_Pragma ("wrong number of arguments for pragma%");
777 --------------------------------
778 -- Check_Arg_Is_External_Name --
779 --------------------------------
781 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
782 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
785 if Nkind (Argx) = N_Identifier then
789 Analyze_And_Resolve (Argx, Standard_String);
791 if Is_OK_Static_Expression (Argx) then
794 elsif Etype (Argx) = Any_Type then
797 -- An interesting special case, if we have a string literal and
798 -- we are in Ada 83 mode, then we allow it even though it will
799 -- not be flagged as static. This allows expected Ada 83 mode
800 -- use of external names which are string literals, even though
801 -- technically these are not static in Ada 83.
803 elsif Ada_Version = Ada_83
804 and then Nkind (Argx) = N_String_Literal
808 -- Static expression that raises Constraint_Error. This has
809 -- already been flagged, so just exit from pragma processing.
811 elsif Is_Static_Expression (Argx) then
814 -- Here we have a real error (non-static expression)
817 Error_Msg_Name_1 := Pname;
821 "argument for pragma% must be a identifier or "
822 & "static string expression!";
825 Flag_Non_Static_Expr (Msg, Argx);
830 end Check_Arg_Is_External_Name;
832 -----------------------------
833 -- Check_Arg_Is_Identifier --
834 -----------------------------
836 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
837 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
839 if Nkind (Argx) /= N_Identifier then
841 ("argument for pragma% must be identifier", Argx);
843 end Check_Arg_Is_Identifier;
845 ----------------------------------
846 -- Check_Arg_Is_Integer_Literal --
847 ----------------------------------
849 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
850 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
852 if Nkind (Argx) /= N_Integer_Literal then
854 ("argument for pragma% must be integer literal", Argx);
856 end Check_Arg_Is_Integer_Literal;
858 -------------------------------------------
859 -- Check_Arg_Is_Library_Level_Local_Name --
860 -------------------------------------------
864 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
865 -- | library_unit_NAME
867 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
869 Check_Arg_Is_Local_Name (Arg);
871 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
872 and then Comes_From_Source (N)
875 ("argument for pragma% must be library level entity", Arg);
877 end Check_Arg_Is_Library_Level_Local_Name;
879 -----------------------------
880 -- Check_Arg_Is_Local_Name --
881 -----------------------------
885 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
886 -- | library_unit_NAME
888 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
889 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
894 if Nkind (Argx) not in N_Direct_Name
895 and then (Nkind (Argx) /= N_Attribute_Reference
896 or else Present (Expressions (Argx))
897 or else Nkind (Prefix (Argx)) /= N_Identifier)
898 and then (not Is_Entity_Name (Argx)
899 or else not Is_Compilation_Unit (Entity (Argx)))
901 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
904 if Is_Entity_Name (Argx)
905 and then Scope (Entity (Argx)) /= Current_Scope
908 ("pragma% argument must be in same declarative part", Arg);
910 end Check_Arg_Is_Local_Name;
912 ---------------------------------
913 -- Check_Arg_Is_Locking_Policy --
914 ---------------------------------
916 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
917 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
920 Check_Arg_Is_Identifier (Argx);
922 if not Is_Locking_Policy_Name (Chars (Argx)) then
924 ("& is not a valid locking policy name", Argx);
926 end Check_Arg_Is_Locking_Policy;
928 -------------------------
929 -- Check_Arg_Is_One_Of --
930 -------------------------
932 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
933 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
936 Check_Arg_Is_Identifier (Argx);
938 if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
939 Error_Msg_Name_2 := N1;
940 Error_Msg_Name_3 := N2;
941 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
943 end Check_Arg_Is_One_Of;
945 procedure Check_Arg_Is_One_Of
947 N1, N2, N3 : Name_Id)
949 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
952 Check_Arg_Is_Identifier (Argx);
954 if Chars (Argx) /= N1
955 and then Chars (Argx) /= N2
956 and then Chars (Argx) /= N3
958 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
960 end Check_Arg_Is_One_Of;
962 procedure Check_Arg_Is_One_Of
964 N1, N2, N3, N4 : Name_Id)
966 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
969 Check_Arg_Is_Identifier (Argx);
971 if Chars (Argx) /= N1
972 and then Chars (Argx) /= N2
973 and then Chars (Argx) /= N3
974 and then Chars (Argx) /= N4
976 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
978 end Check_Arg_Is_One_Of;
980 ---------------------------------
981 -- Check_Arg_Is_Queuing_Policy --
982 ---------------------------------
984 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
985 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
988 Check_Arg_Is_Identifier (Argx);
990 if not Is_Queuing_Policy_Name (Chars (Argx)) then
992 ("& is not a valid queuing policy name", Argx);
994 end Check_Arg_Is_Queuing_Policy;
996 ------------------------------------
997 -- Check_Arg_Is_Static_Expression --
998 ------------------------------------
1000 procedure Check_Arg_Is_Static_Expression
1002 Typ : Entity_Id := Empty)
1004 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1007 if Present (Typ) then
1008 Analyze_And_Resolve (Argx, Typ);
1010 Analyze_And_Resolve (Argx);
1013 if Is_OK_Static_Expression (Argx) then
1016 elsif Etype (Argx) = Any_Type then
1019 -- An interesting special case, if we have a string literal and we
1020 -- are in Ada 83 mode, then we allow it even though it will not be
1021 -- flagged as static. This allows the use of Ada 95 pragmas like
1022 -- Import in Ada 83 mode. They will of course be flagged with
1023 -- warnings as usual, but will not cause errors.
1025 elsif Ada_Version = Ada_83
1026 and then Nkind (Argx) = N_String_Literal
1030 -- Static expression that raises Constraint_Error. This has already
1031 -- been flagged, so just exit from pragma processing.
1033 elsif Is_Static_Expression (Argx) then
1036 -- Finally, we have a real error
1039 Error_Msg_Name_1 := Pname;
1043 "argument for pragma% must be a static expression!";
1046 Flag_Non_Static_Expr (Msg, Argx);
1051 end Check_Arg_Is_Static_Expression;
1053 ------------------------------------------
1054 -- Check_Arg_Is_Task_Dispatching_Policy --
1055 ------------------------------------------
1057 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
1058 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1061 Check_Arg_Is_Identifier (Argx);
1063 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
1065 ("& is not a valid task dispatching policy name", Argx);
1067 end Check_Arg_Is_Task_Dispatching_Policy;
1069 ---------------------
1070 -- Check_Arg_Order --
1071 ---------------------
1073 procedure Check_Arg_Order (Names : Name_List) is
1076 Highest_So_Far : Natural := 0;
1077 -- Highest index in Names seen do far
1081 for J in 1 .. Arg_Count loop
1082 if Chars (Arg) /= No_Name then
1083 for K in Names'Range loop
1084 if Chars (Arg) = Names (K) then
1085 if K < Highest_So_Far then
1086 Error_Msg_Name_1 := Pname;
1088 ("parameters out of order for pragma%", Arg);
1089 Error_Msg_Name_1 := Names (K);
1090 Error_Msg_Name_2 := Names (Highest_So_Far);
1091 Error_Msg_N ("\% must appear before %", Arg);
1095 Highest_So_Far := K;
1103 end Check_Arg_Order;
1105 --------------------------------
1106 -- Check_At_Least_N_Arguments --
1107 --------------------------------
1109 procedure Check_At_Least_N_Arguments (N : Nat) is
1111 if Arg_Count < N then
1112 Error_Pragma ("too few arguments for pragma%");
1114 end Check_At_Least_N_Arguments;
1116 -------------------------------
1117 -- Check_At_Most_N_Arguments --
1118 -------------------------------
1120 procedure Check_At_Most_N_Arguments (N : Nat) is
1123 if Arg_Count > N then
1125 for J in 1 .. N loop
1127 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
1130 end Check_At_Most_N_Arguments;
1132 ---------------------
1133 -- Check_Component --
1134 ---------------------
1136 procedure Check_Component
1139 In_Variant_Part : Boolean := False)
1141 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
1142 Sindic : constant Node_Id :=
1143 Subtype_Indication (Component_Definition (Comp));
1144 Typ : constant Entity_Id := Etype (Comp_Id);
1146 function Inside_Generic_Body (Id : Entity_Id) return Boolean;
1147 -- Determine whether entity Id appears inside a generic body
1149 -------------------------
1150 -- Inside_Generic_Body --
1151 -------------------------
1153 function Inside_Generic_Body (Id : Entity_Id) return Boolean is
1154 S : Entity_Id := Id;
1158 and then S /= Standard_Standard
1160 if Ekind (S) = E_Generic_Package
1161 and then In_Package_Body (S)
1170 end Inside_Generic_Body;
1172 -- Start of processing for Check_Component
1175 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
1176 -- object constraint, then the component type shall be an Unchecked_
1179 if Nkind (Sindic) = N_Subtype_Indication
1180 and then Has_Per_Object_Constraint (Comp_Id)
1181 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
1184 ("component subtype subject to per-object constraint " &
1185 "must be an Unchecked_Union", Comp);
1187 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
1188 -- the body of a generic unit, or within the body of any of its
1189 -- descendant library units, no part of the type of a component
1190 -- declared in a variant_part of the unchecked union type shall be of
1191 -- a formal private type or formal private extension declared within
1192 -- the formal part of the generic unit.
1194 elsif Ada_Version >= Ada_2012
1195 and then Inside_Generic_Body (UU_Typ)
1196 and then In_Variant_Part
1197 and then Is_Private_Type (Typ)
1198 and then Is_Generic_Type (Typ)
1201 ("component of Unchecked_Union cannot be of generic type", Comp);
1203 elsif Needs_Finalization (Typ) then
1205 ("component of Unchecked_Union cannot be controlled", Comp);
1207 elsif Has_Task (Typ) then
1209 ("component of Unchecked_Union cannot have tasks", Comp);
1211 end Check_Component;
1213 ----------------------------
1214 -- Check_Duplicate_Pragma --
1215 ----------------------------
1217 procedure Check_Duplicate_Pragma (E : Entity_Id) is
1221 -- Nothing to do if this pragma comes from an aspect specification,
1222 -- since we could not be duplicating a pragma, and we dealt with the
1223 -- case of duplicated aspects in Analyze_Aspect_Specifications.
1225 if From_Aspect_Specification (N) then
1229 -- Otherwise current pragma may duplicate previous pragma or a
1230 -- previously given aspect specification for the same pragma.
1232 P := Get_Rep_Item_For_Entity (E, Pragma_Name (N));
1235 Error_Msg_Name_1 := Pragma_Name (N);
1236 Error_Msg_Sloc := Sloc (P);
1238 if Nkind (P) = N_Aspect_Specification
1239 or else From_Aspect_Specification (P)
1241 Error_Msg_NE ("aspect% for & previously given#", N, E);
1243 Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
1248 end Check_Duplicate_Pragma;
1250 ----------------------------------
1251 -- Check_Duplicated_Export_Name --
1252 ----------------------------------
1254 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
1255 String_Val : constant String_Id := Strval (Nam);
1258 -- We are only interested in the export case, and in the case of
1259 -- generics, it is the instance, not the template, that is the
1260 -- problem (the template will generate a warning in any case).
1262 if not Inside_A_Generic
1263 and then (Prag_Id = Pragma_Export
1265 Prag_Id = Pragma_Export_Procedure
1267 Prag_Id = Pragma_Export_Valued_Procedure
1269 Prag_Id = Pragma_Export_Function)
1271 for J in Externals.First .. Externals.Last loop
1272 if String_Equal (String_Val, Strval (Externals.Table (J))) then
1273 Error_Msg_Sloc := Sloc (Externals.Table (J));
1274 Error_Msg_N ("external name duplicates name given#", Nam);
1279 Externals.Append (Nam);
1281 end Check_Duplicated_Export_Name;
1283 -------------------------
1284 -- Check_First_Subtype --
1285 -------------------------
1287 procedure Check_First_Subtype (Arg : Node_Id) is
1288 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1290 if not Is_First_Subtype (Entity (Argx)) then
1292 ("pragma% cannot apply to subtype", Argx);
1294 end Check_First_Subtype;
1296 ---------------------------
1297 -- Check_In_Main_Program --
1298 ---------------------------
1300 procedure Check_In_Main_Program is
1301 P : constant Node_Id := Parent (N);
1304 -- Must be at in subprogram body
1306 if Nkind (P) /= N_Subprogram_Body then
1307 Error_Pragma ("% pragma allowed only in subprogram");
1309 -- Otherwise warn if obviously not main program
1311 elsif Present (Parameter_Specifications (Specification (P)))
1312 or else not Is_Compilation_Unit (Defining_Entity (P))
1314 Error_Msg_Name_1 := Pname;
1316 ("?pragma% is only effective in main program", N);
1318 end Check_In_Main_Program;
1320 ---------------------------------------
1321 -- Check_Interrupt_Or_Attach_Handler --
1322 ---------------------------------------
1324 procedure Check_Interrupt_Or_Attach_Handler is
1325 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
1326 Handler_Proc, Proc_Scope : Entity_Id;
1331 if Prag_Id = Pragma_Interrupt_Handler then
1332 Check_Restriction (No_Dynamic_Attachment, N);
1335 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
1336 Proc_Scope := Scope (Handler_Proc);
1338 -- On AAMP only, a pragma Interrupt_Handler is supported for
1339 -- nonprotected parameterless procedures.
1341 if not AAMP_On_Target
1342 or else Prag_Id = Pragma_Attach_Handler
1344 if Ekind (Proc_Scope) /= E_Protected_Type then
1346 ("argument of pragma% must be protected procedure", Arg1);
1349 if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
1350 Error_Pragma ("pragma% must be in protected definition");
1354 if not Is_Library_Level_Entity (Proc_Scope)
1355 or else (AAMP_On_Target
1356 and then not Is_Library_Level_Entity (Handler_Proc))
1359 ("argument for pragma% must be library level entity", Arg1);
1362 -- AI05-0033: A pragma cannot appear within a generic body, because
1363 -- instance can be in a nested scope. The check that protected type
1364 -- is itself a library-level declaration is done elsewhere.
1366 -- Note: we omit this check in Codepeer mode to properly handle code
1367 -- prior to AI-0033 (pragmas don't matter to codepeer in any case).
1369 if Inside_A_Generic then
1370 if Ekind (Scope (Current_Scope)) = E_Generic_Package
1371 and then In_Package_Body (Scope (Current_Scope))
1372 and then not CodePeer_Mode
1374 Error_Pragma ("pragma% cannot be used inside a generic");
1377 end Check_Interrupt_Or_Attach_Handler;
1379 -------------------------------------------
1380 -- Check_Is_In_Decl_Part_Or_Package_Spec --
1381 -------------------------------------------
1383 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
1392 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
1395 elsif Nkind_In (P, N_Package_Specification,
1400 -- Note: the following tests seem a little peculiar, because
1401 -- they test for bodies, but if we were in the statement part
1402 -- of the body, we would already have hit the handled statement
1403 -- sequence, so the only way we get here is by being in the
1404 -- declarative part of the body.
1406 elsif Nkind_In (P, N_Subprogram_Body,
1417 Error_Pragma ("pragma% is not in declarative part or package spec");
1418 end Check_Is_In_Decl_Part_Or_Package_Spec;
1420 -------------------------
1421 -- Check_No_Identifier --
1422 -------------------------
1424 procedure Check_No_Identifier (Arg : Node_Id) is
1426 if Nkind (Arg) = N_Pragma_Argument_Association
1427 and then Chars (Arg) /= No_Name
1429 Error_Pragma_Arg_Ident
1430 ("pragma% does not permit identifier& here", Arg);
1432 end Check_No_Identifier;
1434 --------------------------
1435 -- Check_No_Identifiers --
1436 --------------------------
1438 procedure Check_No_Identifiers is
1441 if Arg_Count > 0 then
1443 while Present (Arg_Node) loop
1444 Check_No_Identifier (Arg_Node);
1448 end Check_No_Identifiers;
1450 -------------------------------
1451 -- Check_Optional_Identifier --
1452 -------------------------------
1454 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
1457 and then Nkind (Arg) = N_Pragma_Argument_Association
1458 and then Chars (Arg) /= No_Name
1460 if Chars (Arg) /= Id then
1461 Error_Msg_Name_1 := Pname;
1462 Error_Msg_Name_2 := Id;
1463 Error_Msg_N ("pragma% argument expects identifier%", Arg);
1467 end Check_Optional_Identifier;
1469 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
1471 Name_Buffer (1 .. Id'Length) := Id;
1472 Name_Len := Id'Length;
1473 Check_Optional_Identifier (Arg, Name_Find);
1474 end Check_Optional_Identifier;
1476 --------------------------------------
1477 -- Check_Precondition_Postcondition --
1478 --------------------------------------
1480 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
1484 procedure Chain_PPC (PO : Node_Id);
1485 -- If PO is a subprogram declaration node (or a generic subprogram
1486 -- declaration node), then the precondition/postcondition applies
1487 -- to this subprogram and the processing for the pragma is completed.
1488 -- Otherwise the pragma is misplaced.
1494 procedure Chain_PPC (PO : Node_Id) is
1499 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
1500 if not From_Aspect_Specification (N) then
1502 ("pragma% cannot be applied to abstract subprogram");
1504 elsif Class_Present (N) then
1509 ("aspect % requires ''Class for abstract subprogram");
1512 elsif not Nkind_In (PO, N_Subprogram_Declaration,
1513 N_Generic_Subprogram_Declaration,
1514 N_Entry_Declaration)
1519 -- Here if we have [generic] subprogram or entry declaration
1521 if Nkind (PO) = N_Entry_Declaration then
1522 S := Defining_Entity (PO);
1524 S := Defining_Unit_Name (Specification (PO));
1527 -- Make sure we do not have the case of a precondition pragma when
1528 -- the Pre'Class aspect is present.
1530 -- We do this by looking at pragmas already chained to the entity
1531 -- since the aspect derived pragma will be put on this list first.
1533 if Pragma_Name (N) = Name_Precondition then
1534 if not From_Aspect_Specification (N) then
1535 P := Spec_PPC_List (S);
1536 while Present (P) loop
1537 if Pragma_Name (P) = Name_Precondition
1538 and then From_Aspect_Specification (P)
1539 and then Class_Present (P)
1541 Error_Msg_Sloc := Sloc (P);
1543 ("pragma% not allowed, `Pre''Class` aspect given#");
1546 P := Next_Pragma (P);
1551 -- Similarly check for Pre with inherited Pre'Class. Note that
1552 -- we cover the aspect case as well here.
1554 if Pragma_Name (N) = Name_Precondition
1555 and then not Class_Present (N)
1558 Inherited : constant Subprogram_List :=
1559 Inherited_Subprograms (S);
1563 for J in Inherited'Range loop
1564 P := Spec_PPC_List (Inherited (J));
1565 while Present (P) loop
1566 if Pragma_Name (P) = Name_Precondition
1567 and then Class_Present (P)
1569 Error_Msg_Sloc := Sloc (P);
1571 ("pragma% not allowed, `Pre''Class` "
1572 & "aspect inherited from#");
1575 P := Next_Pragma (P);
1581 -- Note: we do not analye the pragma at this point. Instead we
1582 -- delay this analysis until the end of the declarative part in
1583 -- which the pragma appears. This implements the required delay
1584 -- in this analysis, allowing forward references. The analysis
1585 -- happens at the end of Analyze_Declarations.
1587 -- Chain spec PPC pragma to list for subprogram
1589 Set_Next_Pragma (N, Spec_PPC_List (S));
1590 Set_Spec_PPC_List (S, N);
1592 -- Return indicating spec case
1598 -- Start of processing for Check_Precondition_Postcondition
1601 if not Is_List_Member (N) then
1605 -- Preanalyze message argument if present. Visibility in this
1606 -- argument is established at the point of pragma occurrence.
1608 if Arg_Count = 2 then
1609 Check_Optional_Identifier (Arg2, Name_Message);
1610 Preanalyze_Spec_Expression
1611 (Get_Pragma_Arg (Arg2), Standard_String);
1614 -- Record if pragma is enabled
1616 if Check_Enabled (Pname) then
1617 Set_Pragma_Enabled (N);
1618 Set_SCO_Pragma_Enabled (Loc);
1621 -- If we are within an inlined body, the legality of the pragma
1622 -- has been checked already.
1624 if In_Inlined_Body then
1629 -- Search prior declarations
1632 while Present (Prev (P)) loop
1635 -- If the previous node is a generic subprogram, do not go to to
1636 -- the original node, which is the unanalyzed tree: we need to
1637 -- attach the pre/postconditions to the analyzed version at this
1638 -- point. They get propagated to the original tree when analyzing
1639 -- the corresponding body.
1641 if Nkind (P) not in N_Generic_Declaration then
1642 PO := Original_Node (P);
1647 -- Skip past prior pragma
1649 if Nkind (PO) = N_Pragma then
1652 -- Skip stuff not coming from source
1654 elsif not Comes_From_Source (PO) then
1657 -- Only remaining possibility is subprogram declaration
1665 -- If we fall through loop, pragma is at start of list, so see if it
1666 -- is at the start of declarations of a subprogram body.
1668 if Nkind (Parent (N)) = N_Subprogram_Body
1669 and then List_Containing (N) = Declarations (Parent (N))
1671 if Operating_Mode /= Generate_Code
1672 or else Inside_A_Generic
1674 -- Analyze pragma expression for correctness and for ASIS use
1676 Preanalyze_Spec_Expression
1677 (Get_Pragma_Arg (Arg1), Standard_Boolean);
1683 -- See if it is in the pragmas after a library level subprogram
1685 elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
1686 Chain_PPC (Unit (Parent (Parent (N))));
1690 -- If we fall through, pragma was misplaced
1693 end Check_Precondition_Postcondition;
1695 -----------------------------
1696 -- Check_Static_Constraint --
1697 -----------------------------
1699 -- Note: for convenience in writing this procedure, in addition to
1700 -- the officially (i.e. by spec) allowed argument which is always a
1701 -- constraint, it also allows ranges and discriminant associations.
1702 -- Above is not clear ???
1704 procedure Check_Static_Constraint (Constr : Node_Id) is
1706 procedure Require_Static (E : Node_Id);
1707 -- Require given expression to be static expression
1709 --------------------
1710 -- Require_Static --
1711 --------------------
1713 procedure Require_Static (E : Node_Id) is
1715 if not Is_OK_Static_Expression (E) then
1716 Flag_Non_Static_Expr
1717 ("non-static constraint not allowed in Unchecked_Union!", E);
1722 -- Start of processing for Check_Static_Constraint
1725 case Nkind (Constr) is
1726 when N_Discriminant_Association =>
1727 Require_Static (Expression (Constr));
1730 Require_Static (Low_Bound (Constr));
1731 Require_Static (High_Bound (Constr));
1733 when N_Attribute_Reference =>
1734 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
1735 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
1737 when N_Range_Constraint =>
1738 Check_Static_Constraint (Range_Expression (Constr));
1740 when N_Index_Or_Discriminant_Constraint =>
1744 IDC := First (Constraints (Constr));
1745 while Present (IDC) loop
1746 Check_Static_Constraint (IDC);
1754 end Check_Static_Constraint;
1756 --------------------------------------
1757 -- Check_Valid_Configuration_Pragma --
1758 --------------------------------------
1760 -- A configuration pragma must appear in the context clause of a
1761 -- compilation unit, and only other pragmas may precede it. Note that
1762 -- the test also allows use in a configuration pragma file.
1764 procedure Check_Valid_Configuration_Pragma is
1766 if not Is_Configuration_Pragma then
1767 Error_Pragma ("incorrect placement for configuration pragma%");
1769 end Check_Valid_Configuration_Pragma;
1771 -------------------------------------
1772 -- Check_Valid_Library_Unit_Pragma --
1773 -------------------------------------
1775 procedure Check_Valid_Library_Unit_Pragma is
1777 Parent_Node : Node_Id;
1778 Unit_Name : Entity_Id;
1779 Unit_Kind : Node_Kind;
1780 Unit_Node : Node_Id;
1781 Sindex : Source_File_Index;
1784 if not Is_List_Member (N) then
1788 Plist := List_Containing (N);
1789 Parent_Node := Parent (Plist);
1791 if Parent_Node = Empty then
1794 -- Case of pragma appearing after a compilation unit. In this case
1795 -- it must have an argument with the corresponding name and must
1796 -- be part of the following pragmas of its parent.
1798 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
1799 if Plist /= Pragmas_After (Parent_Node) then
1802 elsif Arg_Count = 0 then
1804 ("argument required if outside compilation unit");
1807 Check_No_Identifiers;
1808 Check_Arg_Count (1);
1809 Unit_Node := Unit (Parent (Parent_Node));
1810 Unit_Kind := Nkind (Unit_Node);
1812 Analyze (Get_Pragma_Arg (Arg1));
1814 if Unit_Kind = N_Generic_Subprogram_Declaration
1815 or else Unit_Kind = N_Subprogram_Declaration
1817 Unit_Name := Defining_Entity (Unit_Node);
1819 elsif Unit_Kind in N_Generic_Instantiation then
1820 Unit_Name := Defining_Entity (Unit_Node);
1823 Unit_Name := Cunit_Entity (Current_Sem_Unit);
1826 if Chars (Unit_Name) /=
1827 Chars (Entity (Get_Pragma_Arg (Arg1)))
1830 ("pragma% argument is not current unit name", Arg1);
1833 if Ekind (Unit_Name) = E_Package
1834 and then Present (Renamed_Entity (Unit_Name))
1836 Error_Pragma ("pragma% not allowed for renamed package");
1840 -- Pragma appears other than after a compilation unit
1843 -- Here we check for the generic instantiation case and also
1844 -- for the case of processing a generic formal package. We
1845 -- detect these cases by noting that the Sloc on the node
1846 -- does not belong to the current compilation unit.
1848 Sindex := Source_Index (Current_Sem_Unit);
1850 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
1851 Rewrite (N, Make_Null_Statement (Loc));
1854 -- If before first declaration, the pragma applies to the
1855 -- enclosing unit, and the name if present must be this name.
1857 elsif Is_Before_First_Decl (N, Plist) then
1858 Unit_Node := Unit_Declaration_Node (Current_Scope);
1859 Unit_Kind := Nkind (Unit_Node);
1861 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
1864 elsif Unit_Kind = N_Subprogram_Body
1865 and then not Acts_As_Spec (Unit_Node)
1869 elsif Nkind (Parent_Node) = N_Package_Body then
1872 elsif Nkind (Parent_Node) = N_Package_Specification
1873 and then Plist = Private_Declarations (Parent_Node)
1877 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
1878 or else Nkind (Parent_Node) =
1879 N_Generic_Subprogram_Declaration)
1880 and then Plist = Generic_Formal_Declarations (Parent_Node)
1884 elsif Arg_Count > 0 then
1885 Analyze (Get_Pragma_Arg (Arg1));
1887 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
1889 ("name in pragma% must be enclosing unit", Arg1);
1892 -- It is legal to have no argument in this context
1898 -- Error if not before first declaration. This is because a
1899 -- library unit pragma argument must be the name of a library
1900 -- unit (RM 10.1.5(7)), but the only names permitted in this
1901 -- context are (RM 10.1.5(6)) names of subprogram declarations,
1902 -- generic subprogram declarations or generic instantiations.
1906 ("pragma% misplaced, must be before first declaration");
1910 end Check_Valid_Library_Unit_Pragma;
1916 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
1917 Clist : constant Node_Id := Component_List (Variant);
1921 if not Is_Non_Empty_List (Component_Items (Clist)) then
1923 ("Unchecked_Union may not have empty component list",
1928 Comp := First (Component_Items (Clist));
1929 while Present (Comp) loop
1930 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
1939 procedure Error_Pragma (Msg : String) is
1940 MsgF : String := Msg;
1942 Error_Msg_Name_1 := Pname;
1944 Error_Msg_N (MsgF, N);
1948 ----------------------
1949 -- Error_Pragma_Arg --
1950 ----------------------
1952 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
1953 MsgF : String := Msg;
1955 Error_Msg_Name_1 := Pname;
1957 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
1959 end Error_Pragma_Arg;
1961 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
1962 MsgF : String := Msg1;
1964 Error_Msg_Name_1 := Pname;
1966 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
1967 Error_Pragma_Arg (Msg2, Arg);
1968 end Error_Pragma_Arg;
1970 ----------------------------
1971 -- Error_Pragma_Arg_Ident --
1972 ----------------------------
1974 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
1975 MsgF : String := Msg;
1977 Error_Msg_Name_1 := Pname;
1979 Error_Msg_N (MsgF, Arg);
1981 end Error_Pragma_Arg_Ident;
1983 ----------------------
1984 -- Error_Pragma_Ref --
1985 ----------------------
1987 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
1988 MsgF : String := Msg;
1990 Error_Msg_Name_1 := Pname;
1992 Error_Msg_Sloc := Sloc (Ref);
1993 Error_Msg_NE (MsgF, N, Ref);
1995 end Error_Pragma_Ref;
1997 ------------------------
1998 -- Find_Lib_Unit_Name --
1999 ------------------------
2001 function Find_Lib_Unit_Name return Entity_Id is
2003 -- Return inner compilation unit entity, for case of nested
2004 -- categorization pragmas. This happens in generic unit.
2006 if Nkind (Parent (N)) = N_Package_Specification
2007 and then Defining_Entity (Parent (N)) /= Current_Scope
2009 return Defining_Entity (Parent (N));
2011 return Current_Scope;
2013 end Find_Lib_Unit_Name;
2015 ----------------------------
2016 -- Find_Program_Unit_Name --
2017 ----------------------------
2019 procedure Find_Program_Unit_Name (Id : Node_Id) is
2020 Unit_Name : Entity_Id;
2021 Unit_Kind : Node_Kind;
2022 P : constant Node_Id := Parent (N);
2025 if Nkind (P) = N_Compilation_Unit then
2026 Unit_Kind := Nkind (Unit (P));
2028 if Unit_Kind = N_Subprogram_Declaration
2029 or else Unit_Kind = N_Package_Declaration
2030 or else Unit_Kind in N_Generic_Declaration
2032 Unit_Name := Defining_Entity (Unit (P));
2034 if Chars (Id) = Chars (Unit_Name) then
2035 Set_Entity (Id, Unit_Name);
2036 Set_Etype (Id, Etype (Unit_Name));
2038 Set_Etype (Id, Any_Type);
2040 ("cannot find program unit referenced by pragma%");
2044 Set_Etype (Id, Any_Type);
2045 Error_Pragma ("pragma% inapplicable to this unit");
2051 end Find_Program_Unit_Name;
2053 -----------------------------------------
2054 -- Find_Unique_Parameterless_Procedure --
2055 -----------------------------------------
2057 function Find_Unique_Parameterless_Procedure
2059 Arg : Node_Id) return Entity_Id
2061 Proc : Entity_Id := Empty;
2064 -- The body of this procedure needs some comments ???
2066 if not Is_Entity_Name (Name) then
2068 ("argument of pragma% must be entity name", Arg);
2070 elsif not Is_Overloaded (Name) then
2071 Proc := Entity (Name);
2073 if Ekind (Proc) /= E_Procedure
2074 or else Present (First_Formal (Proc))
2077 ("argument of pragma% must be parameterless procedure", Arg);
2082 Found : Boolean := False;
2084 Index : Interp_Index;
2087 Get_First_Interp (Name, Index, It);
2088 while Present (It.Nam) loop
2091 if Ekind (Proc) = E_Procedure
2092 and then No (First_Formal (Proc))
2096 Set_Entity (Name, Proc);
2097 Set_Is_Overloaded (Name, False);
2100 ("ambiguous handler name for pragma% ", Arg);
2104 Get_Next_Interp (Index, It);
2109 ("argument of pragma% must be parameterless procedure",
2112 Proc := Entity (Name);
2118 end Find_Unique_Parameterless_Procedure;
2124 procedure Fix_Error (Msg : in out String) is
2126 if From_Aspect_Specification (N) then
2127 for J in Msg'First .. Msg'Last - 5 loop
2128 if Msg (J .. J + 5) = "pragma" then
2129 Msg (J .. J + 5) := "aspect";
2133 if Error_Msg_Name_1 = Name_Precondition then
2134 Error_Msg_Name_1 := Name_Pre;
2135 elsif Error_Msg_Name_1 = Name_Postcondition then
2136 Error_Msg_Name_1 := Name_Post;
2141 -------------------------
2142 -- Gather_Associations --
2143 -------------------------
2145 procedure Gather_Associations
2147 Args : out Args_List)
2152 -- Initialize all parameters to Empty
2154 for J in Args'Range loop
2158 -- That's all we have to do if there are no argument associations
2160 if No (Pragma_Argument_Associations (N)) then
2164 -- Otherwise first deal with any positional parameters present
2166 Arg := First (Pragma_Argument_Associations (N));
2167 for Index in Args'Range loop
2168 exit when No (Arg) or else Chars (Arg) /= No_Name;
2169 Args (Index) := Get_Pragma_Arg (Arg);
2173 -- Positional parameters all processed, if any left, then we
2174 -- have too many positional parameters.
2176 if Present (Arg) and then Chars (Arg) = No_Name then
2178 ("too many positional associations for pragma%", Arg);
2181 -- Process named parameters if any are present
2183 while Present (Arg) loop
2184 if Chars (Arg) = No_Name then
2186 ("positional association cannot follow named association",
2190 for Index in Names'Range loop
2191 if Names (Index) = Chars (Arg) then
2192 if Present (Args (Index)) then
2194 ("duplicate argument association for pragma%", Arg);
2196 Args (Index) := Get_Pragma_Arg (Arg);
2201 if Index = Names'Last then
2202 Error_Msg_Name_1 := Pname;
2203 Error_Msg_N ("pragma% does not allow & argument", Arg);
2205 -- Check for possible misspelling
2207 for Index1 in Names'Range loop
2208 if Is_Bad_Spelling_Of
2209 (Chars (Arg), Names (Index1))
2211 Error_Msg_Name_1 := Names (Index1);
2212 Error_Msg_N -- CODEFIX
2213 ("\possible misspelling of%", Arg);
2225 end Gather_Associations;
2231 procedure GNAT_Pragma is
2233 Check_Restriction (No_Implementation_Pragmas, N);
2236 --------------------------
2237 -- Is_Before_First_Decl --
2238 --------------------------
2240 function Is_Before_First_Decl
2241 (Pragma_Node : Node_Id;
2242 Decls : List_Id) return Boolean
2244 Item : Node_Id := First (Decls);
2247 -- Only other pragmas can come before this pragma
2250 if No (Item) or else Nkind (Item) /= N_Pragma then
2253 elsif Item = Pragma_Node then
2259 end Is_Before_First_Decl;
2261 -----------------------------
2262 -- Is_Configuration_Pragma --
2263 -----------------------------
2265 -- A configuration pragma must appear in the context clause of a
2266 -- compilation unit, and only other pragmas may precede it. Note that
2267 -- the test below also permits use in a configuration pragma file.
2269 function Is_Configuration_Pragma return Boolean is
2270 Lis : constant List_Id := List_Containing (N);
2271 Par : constant Node_Id := Parent (N);
2275 -- If no parent, then we are in the configuration pragma file,
2276 -- so the placement is definitely appropriate.
2281 -- Otherwise we must be in the context clause of a compilation unit
2282 -- and the only thing allowed before us in the context list is more
2283 -- configuration pragmas.
2285 elsif Nkind (Par) = N_Compilation_Unit
2286 and then Context_Items (Par) = Lis
2293 elsif Nkind (Prg) /= N_Pragma then
2303 end Is_Configuration_Pragma;
2305 --------------------------
2306 -- Is_In_Context_Clause --
2307 --------------------------
2309 function Is_In_Context_Clause return Boolean is
2311 Parent_Node : Node_Id;
2314 if not Is_List_Member (N) then
2318 Plist := List_Containing (N);
2319 Parent_Node := Parent (Plist);
2321 if Parent_Node = Empty
2322 or else Nkind (Parent_Node) /= N_Compilation_Unit
2323 or else Context_Items (Parent_Node) /= Plist
2330 end Is_In_Context_Clause;
2332 ---------------------------------
2333 -- Is_Static_String_Expression --
2334 ---------------------------------
2336 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
2337 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2340 Analyze_And_Resolve (Argx);
2341 return Is_OK_Static_Expression (Argx)
2342 and then Nkind (Argx) = N_String_Literal;
2343 end Is_Static_String_Expression;
2345 ----------------------
2346 -- Pragma_Misplaced --
2347 ----------------------
2349 procedure Pragma_Misplaced is
2351 Error_Pragma ("incorrect placement of pragma%");
2352 end Pragma_Misplaced;
2354 ------------------------------------
2355 -- Process Atomic_Shared_Volatile --
2356 ------------------------------------
2358 procedure Process_Atomic_Shared_Volatile is
2365 procedure Set_Atomic (E : Entity_Id);
2366 -- Set given type as atomic, and if no explicit alignment was given,
2367 -- set alignment to unknown, since back end knows what the alignment
2368 -- requirements are for atomic arrays. Note: this step is necessary
2369 -- for derived types.
2375 procedure Set_Atomic (E : Entity_Id) is
2377 Set_Is_Atomic (E, Sense);
2379 if Sense and then not Has_Alignment_Clause (E) then
2380 Set_Alignment (E, Uint_0);
2384 -- Start of processing for Process_Atomic_Shared_Volatile
2387 Check_Ada_83_Warning;
2388 Check_No_Identifiers;
2389 Check_Arg_Count (1);
2390 Check_Arg_Is_Local_Name (Arg1);
2391 E_Id := Get_Pragma_Arg (Arg1);
2393 if Etype (E_Id) = Any_Type then
2398 D := Declaration_Node (E);
2401 -- Check duplicate before we chain ourselves!
2403 Check_Duplicate_Pragma (E);
2405 -- Now check appropriateness of the entity
2408 if Rep_Item_Too_Early (E, N)
2410 Rep_Item_Too_Late (E, N)
2414 Check_First_Subtype (Arg1);
2417 if Prag_Id /= Pragma_Volatile then
2419 Set_Atomic (Underlying_Type (E));
2420 Set_Atomic (Base_Type (E));
2423 -- Attribute belongs on the base type. If the view of the type is
2424 -- currently private, it also belongs on the underlying type.
2426 Set_Is_Volatile (Base_Type (E), Sense);
2427 Set_Is_Volatile (Underlying_Type (E), Sense);
2429 Set_Treat_As_Volatile (E, Sense);
2430 Set_Treat_As_Volatile (Underlying_Type (E), Sense);
2432 elsif K = N_Object_Declaration
2433 or else (K = N_Component_Declaration
2434 and then Original_Record_Component (E) = E)
2436 if Rep_Item_Too_Late (E, N) then
2440 if Prag_Id /= Pragma_Volatile then
2441 Set_Is_Atomic (E, Sense);
2443 -- If the object declaration has an explicit initialization, a
2444 -- temporary may have to be created to hold the expression, to
2445 -- ensure that access to the object remain atomic.
2447 if Nkind (Parent (E)) = N_Object_Declaration
2448 and then Present (Expression (Parent (E)))
2451 Set_Has_Delayed_Freeze (E);
2454 -- An interesting improvement here. If an object of type X is
2455 -- declared atomic, and the type X is not atomic, that's a
2456 -- pity, since it may not have appropriate alignment etc. We
2457 -- can rescue this in the special case where the object and
2458 -- type are in the same unit by just setting the type as
2459 -- atomic, so that the back end will process it as atomic.
2461 Utyp := Underlying_Type (Etype (E));
2464 and then Sloc (E) > No_Location
2465 and then Sloc (Utyp) > No_Location
2467 Get_Source_File_Index (Sloc (E)) =
2468 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
2470 Set_Is_Atomic (Underlying_Type (Etype (E)), Sense);
2474 Set_Is_Volatile (E);
2475 Set_Treat_As_Volatile (E);
2479 ("inappropriate entity for pragma%", Arg1);
2481 end Process_Atomic_Shared_Volatile;
2483 -------------------------------------------
2484 -- Process_Compile_Time_Warning_Or_Error --
2485 -------------------------------------------
2487 procedure Process_Compile_Time_Warning_Or_Error is
2488 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
2491 Check_Arg_Count (2);
2492 Check_No_Identifiers;
2493 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
2494 Analyze_And_Resolve (Arg1x, Standard_Boolean);
2496 if Compile_Time_Known_Value (Arg1x) then
2497 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
2499 Str : constant String_Id :=
2500 Strval (Get_Pragma_Arg (Arg2));
2501 Len : constant Int := String_Length (Str);
2506 Cent : constant Entity_Id :=
2507 Cunit_Entity (Current_Sem_Unit);
2509 Force : constant Boolean :=
2510 Prag_Id = Pragma_Compile_Time_Warning
2512 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
2513 and then (Ekind (Cent) /= E_Package
2514 or else not In_Private_Part (Cent));
2515 -- Set True if this is the warning case, and we are in the
2516 -- visible part of a package spec, or in a subprogram spec,
2517 -- in which case we want to force the client to see the
2518 -- warning, even though it is not in the main unit.
2521 -- Loop through segments of message separated by line feeds.
2522 -- We output these segments as separate messages with
2523 -- continuation marks for all but the first.
2528 Error_Msg_Strlen := 0;
2530 -- Loop to copy characters from argument to error message
2534 exit when Ptr > Len;
2535 CC := Get_String_Char (Str, Ptr);
2538 -- Ignore wide chars ??? else store character
2540 if In_Character_Range (CC) then
2541 C := Get_Character (CC);
2542 exit when C = ASCII.LF;
2543 Error_Msg_Strlen := Error_Msg_Strlen + 1;
2544 Error_Msg_String (Error_Msg_Strlen) := C;
2548 -- Here with one line ready to go
2550 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
2552 -- If this is a warning in a spec, then we want clients
2553 -- to see the warning, so mark the message with the
2554 -- special sequence !! to force the warning. In the case
2555 -- of a package spec, we do not force this if we are in
2556 -- the private part of the spec.
2559 if Cont = False then
2560 Error_Msg_N ("<~!!", Arg1);
2563 Error_Msg_N ("\<~!!", Arg1);
2566 -- Error, rather than warning, or in a body, so we do not
2567 -- need to force visibility for client (error will be
2568 -- output in any case, and this is the situation in which
2569 -- we do not want a client to get a warning, since the
2570 -- warning is in the body or the spec private part).
2573 if Cont = False then
2574 Error_Msg_N ("<~", Arg1);
2577 Error_Msg_N ("\<~", Arg1);
2581 exit when Ptr > Len;
2586 end Process_Compile_Time_Warning_Or_Error;
2588 ------------------------
2589 -- Process_Convention --
2590 ------------------------
2592 procedure Process_Convention
2593 (C : out Convention_Id;
2594 Ent : out Entity_Id)
2600 Comp_Unit : Unit_Number_Type;
2602 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
2603 -- Called if we have more than one Export/Import/Convention pragma.
2604 -- This is generally illegal, but we have a special case of allowing
2605 -- Import and Interface to coexist if they specify the convention in
2606 -- a consistent manner. We are allowed to do this, since Interface is
2607 -- an implementation defined pragma, and we choose to do it since we
2608 -- know Rational allows this combination. S is the entity id of the
2609 -- subprogram in question. This procedure also sets the special flag
2610 -- Import_Interface_Present in both pragmas in the case where we do
2611 -- have matching Import and Interface pragmas.
2613 procedure Set_Convention_From_Pragma (E : Entity_Id);
2614 -- Set convention in entity E, and also flag that the entity has a
2615 -- convention pragma. If entity is for a private or incomplete type,
2616 -- also set convention and flag on underlying type. This procedure
2617 -- also deals with the special case of C_Pass_By_Copy convention.
2619 -------------------------------
2620 -- Diagnose_Multiple_Pragmas --
2621 -------------------------------
2623 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
2624 Pdec : constant Node_Id := Declaration_Node (S);
2628 function Same_Convention (Decl : Node_Id) return Boolean;
2629 -- Decl is a pragma node. This function returns True if this
2630 -- pragma has a first argument that is an identifier with a
2631 -- Chars field corresponding to the Convention_Id C.
2633 function Same_Name (Decl : Node_Id) return Boolean;
2634 -- Decl is a pragma node. This function returns True if this
2635 -- pragma has a second argument that is an identifier with a
2636 -- Chars field that matches the Chars of the current subprogram.
2638 ---------------------
2639 -- Same_Convention --
2640 ---------------------
2642 function Same_Convention (Decl : Node_Id) return Boolean is
2643 Arg1 : constant Node_Id :=
2644 First (Pragma_Argument_Associations (Decl));
2647 if Present (Arg1) then
2649 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
2651 if Nkind (Arg) = N_Identifier
2652 and then Is_Convention_Name (Chars (Arg))
2653 and then Get_Convention_Id (Chars (Arg)) = C
2661 end Same_Convention;
2667 function Same_Name (Decl : Node_Id) return Boolean is
2668 Arg1 : constant Node_Id :=
2669 First (Pragma_Argument_Associations (Decl));
2677 Arg2 := Next (Arg1);
2684 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
2686 if Nkind (Arg) = N_Identifier
2687 and then Chars (Arg) = Chars (S)
2696 -- Start of processing for Diagnose_Multiple_Pragmas
2701 -- Definitely give message if we have Convention/Export here
2703 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
2706 -- If we have an Import or Export, scan back from pragma to
2707 -- find any previous pragma applying to the same procedure.
2708 -- The scan will be terminated by the start of the list, or
2709 -- hitting the subprogram declaration. This won't allow one
2710 -- pragma to appear in the public part and one in the private
2711 -- part, but that seems very unlikely in practice.
2715 while Present (Decl) and then Decl /= Pdec loop
2717 -- Look for pragma with same name as us
2719 if Nkind (Decl) = N_Pragma
2720 and then Same_Name (Decl)
2722 -- Give error if same as our pragma or Export/Convention
2724 if Pragma_Name (Decl) = Name_Export
2726 Pragma_Name (Decl) = Name_Convention
2728 Pragma_Name (Decl) = Pragma_Name (N)
2732 -- Case of Import/Interface or the other way round
2734 elsif Pragma_Name (Decl) = Name_Interface
2736 Pragma_Name (Decl) = Name_Import
2738 -- Here we know that we have Import and Interface. It
2739 -- doesn't matter which way round they are. See if
2740 -- they specify the same convention. If so, all OK,
2741 -- and set special flags to stop other messages
2743 if Same_Convention (Decl) then
2744 Set_Import_Interface_Present (N);
2745 Set_Import_Interface_Present (Decl);
2748 -- If different conventions, special message
2751 Error_Msg_Sloc := Sloc (Decl);
2753 ("convention differs from that given#", Arg1);
2763 -- Give message if needed if we fall through those tests
2767 ("at most one Convention/Export/Import pragma is allowed",
2770 end Diagnose_Multiple_Pragmas;
2772 --------------------------------
2773 -- Set_Convention_From_Pragma --
2774 --------------------------------
2776 procedure Set_Convention_From_Pragma (E : Entity_Id) is
2778 -- Ada 2005 (AI-430): Check invalid attempt to change convention
2779 -- for an overridden dispatching operation. Technically this is
2780 -- an amendment and should only be done in Ada 2005 mode. However,
2781 -- this is clearly a mistake, since the problem that is addressed
2782 -- by this AI is that there is a clear gap in the RM!
2784 if Is_Dispatching_Operation (E)
2785 and then Present (Overridden_Operation (E))
2786 and then C /= Convention (Overridden_Operation (E))
2789 ("cannot change convention for " &
2790 "overridden dispatching operation",
2794 -- Set the convention
2796 Set_Convention (E, C);
2797 Set_Has_Convention_Pragma (E);
2799 if Is_Incomplete_Or_Private_Type (E) then
2800 Set_Convention (Underlying_Type (E), C);
2801 Set_Has_Convention_Pragma (Underlying_Type (E), True);
2804 -- A class-wide type should inherit the convention of the specific
2805 -- root type (although this isn't specified clearly by the RM).
2807 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
2808 Set_Convention (Class_Wide_Type (E), C);
2811 -- If the entity is a record type, then check for special case of
2812 -- C_Pass_By_Copy, which is treated the same as C except that the
2813 -- special record flag is set. This convention is only permitted
2814 -- on record types (see AI95-00131).
2816 if Cname = Name_C_Pass_By_Copy then
2817 if Is_Record_Type (E) then
2818 Set_C_Pass_By_Copy (Base_Type (E));
2819 elsif Is_Incomplete_Or_Private_Type (E)
2820 and then Is_Record_Type (Underlying_Type (E))
2822 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
2825 ("C_Pass_By_Copy convention allowed only for record type",
2830 -- If the entity is a derived boolean type, check for the special
2831 -- case of convention C, C++, or Fortran, where we consider any
2832 -- nonzero value to represent true.
2834 if Is_Discrete_Type (E)
2835 and then Root_Type (Etype (E)) = Standard_Boolean
2841 C = Convention_Fortran)
2843 Set_Nonzero_Is_True (Base_Type (E));
2845 end Set_Convention_From_Pragma;
2847 -- Start of processing for Process_Convention
2850 Check_At_Least_N_Arguments (2);
2851 Check_Optional_Identifier (Arg1, Name_Convention);
2852 Check_Arg_Is_Identifier (Arg1);
2853 Cname := Chars (Get_Pragma_Arg (Arg1));
2855 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
2856 -- tested again below to set the critical flag).
2857 if Cname = Name_C_Pass_By_Copy then
2860 -- Otherwise we must have something in the standard convention list
2862 elsif Is_Convention_Name (Cname) then
2863 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
2865 -- In DEC VMS, it seems that there is an undocumented feature that
2866 -- any unrecognized convention is treated as the default, which for
2867 -- us is convention C. It does not seem so terrible to do this
2868 -- unconditionally, silently in the VMS case, and with a warning
2869 -- in the non-VMS case.
2872 if Warn_On_Export_Import and not OpenVMS_On_Target then
2874 ("?unrecognized convention name, C assumed",
2875 Get_Pragma_Arg (Arg1));
2881 Check_Optional_Identifier (Arg2, Name_Entity);
2882 Check_Arg_Is_Local_Name (Arg2);
2884 Id := Get_Pragma_Arg (Arg2);
2887 if not Is_Entity_Name (Id) then
2888 Error_Pragma_Arg ("entity name required", Arg2);
2893 -- Set entity to return
2897 -- Go to renamed subprogram if present, since convention applies to
2898 -- the actual renamed entity, not to the renaming entity. If the
2899 -- subprogram is inherited, go to parent subprogram.
2901 if Is_Subprogram (E)
2902 and then Present (Alias (E))
2904 if Nkind (Parent (Declaration_Node (E))) =
2905 N_Subprogram_Renaming_Declaration
2907 if Scope (E) /= Scope (Alias (E)) then
2909 ("cannot apply pragma% to non-local entity&#", E);
2914 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
2915 N_Private_Extension_Declaration)
2916 and then Scope (E) = Scope (Alias (E))
2920 -- Return the parent subprogram the entity was inherited from
2926 -- Check that we are not applying this to a specless body
2928 if Is_Subprogram (E)
2929 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
2932 ("pragma% requires separate spec and must come before body");
2935 -- Check that we are not applying this to a named constant
2937 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
2938 Error_Msg_Name_1 := Pname;
2940 ("cannot apply pragma% to named constant!",
2941 Get_Pragma_Arg (Arg2));
2943 ("\supply appropriate type for&!", Arg2);
2946 if Ekind (E) = E_Enumeration_Literal then
2947 Error_Pragma ("enumeration literal not allowed for pragma%");
2950 -- Check for rep item appearing too early or too late
2952 if Etype (E) = Any_Type
2953 or else Rep_Item_Too_Early (E, N)
2957 E := Underlying_Type (E);
2960 if Rep_Item_Too_Late (E, N) then
2964 if Has_Convention_Pragma (E) then
2965 Diagnose_Multiple_Pragmas (E);
2967 elsif Convention (E) = Convention_Protected
2968 or else Ekind (Scope (E)) = E_Protected_Type
2971 ("a protected operation cannot be given a different convention",
2975 -- For Intrinsic, a subprogram is required
2977 if C = Convention_Intrinsic
2978 and then not Is_Subprogram (E)
2979 and then not Is_Generic_Subprogram (E)
2982 ("second argument of pragma% must be a subprogram", Arg2);
2985 -- For Stdcall, a subprogram, variable or subprogram type is required
2987 if C = Convention_Stdcall
2988 and then not Is_Subprogram (E)
2989 and then not Is_Generic_Subprogram (E)
2990 and then Ekind (E) /= E_Variable
2993 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
2996 ("second argument of pragma% must be subprogram (type)",
3000 if not Is_Subprogram (E)
3001 and then not Is_Generic_Subprogram (E)
3003 Set_Convention_From_Pragma (E);
3006 Check_First_Subtype (Arg2);
3007 Set_Convention_From_Pragma (Base_Type (E));
3009 -- For subprograms, we must set the convention on the
3010 -- internally generated directly designated type as well.
3012 if Ekind (E) = E_Access_Subprogram_Type then
3013 Set_Convention_From_Pragma (Directly_Designated_Type (E));
3017 -- For the subprogram case, set proper convention for all homonyms
3018 -- in same scope and the same declarative part, i.e. the same
3019 -- compilation unit.
3022 Comp_Unit := Get_Source_Unit (E);
3023 Set_Convention_From_Pragma (E);
3025 -- Treat a pragma Import as an implicit body, for GPS use
3027 if Prag_Id = Pragma_Import then
3028 Generate_Reference (E, Id, 'b');
3031 -- Loop through the homonyms of the pragma argument's entity
3036 exit when No (E1) or else Scope (E1) /= Current_Scope;
3038 -- Do not set the pragma on inherited operations or on formal
3041 if Comes_From_Source (E1)
3042 and then Comp_Unit = Get_Source_Unit (E1)
3043 and then not Is_Formal_Subprogram (E1)
3044 and then Nkind (Original_Node (Parent (E1))) /=
3045 N_Full_Type_Declaration
3047 if Present (Alias (E1))
3048 and then Scope (E1) /= Scope (Alias (E1))
3051 ("cannot apply pragma% to non-local entity& declared#",
3055 Set_Convention_From_Pragma (E1);
3057 if Prag_Id = Pragma_Import then
3058 Generate_Reference (E1, Id, 'b');
3062 -- For aspect case, do NOT apply to homonyms
3064 exit when From_Aspect_Specification (N);
3067 end Process_Convention;
3069 -----------------------------------------------------
3070 -- Process_Extended_Import_Export_Exception_Pragma --
3071 -----------------------------------------------------
3073 procedure Process_Extended_Import_Export_Exception_Pragma
3074 (Arg_Internal : Node_Id;
3075 Arg_External : Node_Id;
3083 if not OpenVMS_On_Target then
3085 ("?pragma% ignored (applies only to Open'V'M'S)");
3088 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3089 Def_Id := Entity (Arg_Internal);
3091 if Ekind (Def_Id) /= E_Exception then
3093 ("pragma% must refer to declared exception", Arg_Internal);
3096 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
3098 if Present (Arg_Form) then
3099 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
3102 if Present (Arg_Form)
3103 and then Chars (Arg_Form) = Name_Ada
3107 Set_Is_VMS_Exception (Def_Id);
3108 Set_Exception_Code (Def_Id, No_Uint);
3111 if Present (Arg_Code) then
3112 if not Is_VMS_Exception (Def_Id) then
3114 ("Code option for pragma% not allowed for Ada case",
3118 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
3119 Code_Val := Expr_Value (Arg_Code);
3121 if not UI_Is_In_Int_Range (Code_Val) then
3123 ("Code option for pragma% must be in 32-bit range",
3127 Set_Exception_Code (Def_Id, Code_Val);
3130 end Process_Extended_Import_Export_Exception_Pragma;
3132 -------------------------------------------------
3133 -- Process_Extended_Import_Export_Internal_Arg --
3134 -------------------------------------------------
3136 procedure Process_Extended_Import_Export_Internal_Arg
3137 (Arg_Internal : Node_Id := Empty)
3140 if No (Arg_Internal) then
3141 Error_Pragma ("Internal parameter required for pragma%");
3144 if Nkind (Arg_Internal) = N_Identifier then
3147 elsif Nkind (Arg_Internal) = N_Operator_Symbol
3148 and then (Prag_Id = Pragma_Import_Function
3150 Prag_Id = Pragma_Export_Function)
3156 ("wrong form for Internal parameter for pragma%", Arg_Internal);
3159 Check_Arg_Is_Local_Name (Arg_Internal);
3160 end Process_Extended_Import_Export_Internal_Arg;
3162 --------------------------------------------------
3163 -- Process_Extended_Import_Export_Object_Pragma --
3164 --------------------------------------------------
3166 procedure Process_Extended_Import_Export_Object_Pragma
3167 (Arg_Internal : Node_Id;
3168 Arg_External : Node_Id;
3174 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3175 Def_Id := Entity (Arg_Internal);
3177 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
3179 ("pragma% must designate an object", Arg_Internal);
3182 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
3184 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
3187 ("previous Common/Psect_Object applies, pragma % not permitted",
3191 if Rep_Item_Too_Late (Def_Id, N) then
3195 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
3197 if Present (Arg_Size) then
3198 Check_Arg_Is_External_Name (Arg_Size);
3201 -- Export_Object case
3203 if Prag_Id = Pragma_Export_Object then
3204 if not Is_Library_Level_Entity (Def_Id) then
3206 ("argument for pragma% must be library level entity",
3210 if Ekind (Current_Scope) = E_Generic_Package then
3211 Error_Pragma ("pragma& cannot appear in a generic unit");
3214 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
3216 ("exported object must have compile time known size",
3220 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
3221 Error_Msg_N ("?duplicate Export_Object pragma", N);
3223 Set_Exported (Def_Id, Arg_Internal);
3226 -- Import_Object case
3229 if Is_Concurrent_Type (Etype (Def_Id)) then
3231 ("cannot use pragma% for task/protected object",
3235 if Ekind (Def_Id) = E_Constant then
3237 ("cannot import a constant", Arg_Internal);
3240 if Warn_On_Export_Import
3241 and then Has_Discriminants (Etype (Def_Id))
3244 ("imported value must be initialized?", Arg_Internal);
3247 if Warn_On_Export_Import
3248 and then Is_Access_Type (Etype (Def_Id))
3251 ("cannot import object of an access type?", Arg_Internal);
3254 if Warn_On_Export_Import
3255 and then Is_Imported (Def_Id)
3258 ("?duplicate Import_Object pragma", N);
3260 -- Check for explicit initialization present. Note that an
3261 -- initialization generated by the code generator, e.g. for an
3262 -- access type, does not count here.
3264 elsif Present (Expression (Parent (Def_Id)))
3267 (Original_Node (Expression (Parent (Def_Id))))
3269 Error_Msg_Sloc := Sloc (Def_Id);
3271 ("imported entities cannot be initialized (RM B.1(24))",
3272 "\no initialization allowed for & declared#", Arg1);
3274 Set_Imported (Def_Id);
3275 Note_Possible_Modification (Arg_Internal, Sure => False);
3278 end Process_Extended_Import_Export_Object_Pragma;
3280 ------------------------------------------------------
3281 -- Process_Extended_Import_Export_Subprogram_Pragma --
3282 ------------------------------------------------------
3284 procedure Process_Extended_Import_Export_Subprogram_Pragma
3285 (Arg_Internal : Node_Id;
3286 Arg_External : Node_Id;
3287 Arg_Parameter_Types : Node_Id;
3288 Arg_Result_Type : Node_Id := Empty;
3289 Arg_Mechanism : Node_Id;
3290 Arg_Result_Mechanism : Node_Id := Empty;
3291 Arg_First_Optional_Parameter : Node_Id := Empty)
3297 Ambiguous : Boolean;
3301 function Same_Base_Type
3303 Formal : Entity_Id) return Boolean;
3304 -- Determines if Ptype references the type of Formal. Note that only
3305 -- the base types need to match according to the spec. Ptype here is
3306 -- the argument from the pragma, which is either a type name, or an
3307 -- access attribute.
3309 --------------------
3310 -- Same_Base_Type --
3311 --------------------
3313 function Same_Base_Type
3315 Formal : Entity_Id) return Boolean
3317 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
3321 -- Case where pragma argument is typ'Access
3323 if Nkind (Ptype) = N_Attribute_Reference
3324 and then Attribute_Name (Ptype) = Name_Access
3326 Pref := Prefix (Ptype);
3329 if not Is_Entity_Name (Pref)
3330 or else Entity (Pref) = Any_Type
3335 -- We have a match if the corresponding argument is of an
3336 -- anonymous access type, and its designated type matches the
3337 -- type of the prefix of the access attribute
3339 return Ekind (Ftyp) = E_Anonymous_Access_Type
3340 and then Base_Type (Entity (Pref)) =
3341 Base_Type (Etype (Designated_Type (Ftyp)));
3343 -- Case where pragma argument is a type name
3348 if not Is_Entity_Name (Ptype)
3349 or else Entity (Ptype) = Any_Type
3354 -- We have a match if the corresponding argument is of the type
3355 -- given in the pragma (comparing base types)
3357 return Base_Type (Entity (Ptype)) = Ftyp;
3361 -- Start of processing for
3362 -- Process_Extended_Import_Export_Subprogram_Pragma
3365 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3369 -- Loop through homonyms (overloadings) of the entity
3371 Hom_Id := Entity (Arg_Internal);
3372 while Present (Hom_Id) loop
3373 Def_Id := Get_Base_Subprogram (Hom_Id);
3375 -- We need a subprogram in the current scope
3377 if not Is_Subprogram (Def_Id)
3378 or else Scope (Def_Id) /= Current_Scope
3385 -- Pragma cannot apply to subprogram body
3387 if Is_Subprogram (Def_Id)
3388 and then Nkind (Parent (Declaration_Node (Def_Id))) =
3392 ("pragma% requires separate spec"
3393 & " and must come before body");
3396 -- Test result type if given, note that the result type
3397 -- parameter can only be present for the function cases.
3399 if Present (Arg_Result_Type)
3400 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
3404 elsif Etype (Def_Id) /= Standard_Void_Type
3406 (Pname = Name_Export_Procedure
3408 Pname = Name_Import_Procedure)
3412 -- Test parameter types if given. Note that this parameter
3413 -- has not been analyzed (and must not be, since it is
3414 -- semantic nonsense), so we get it as the parser left it.
3416 elsif Present (Arg_Parameter_Types) then
3417 Check_Matching_Types : declare
3422 Formal := First_Formal (Def_Id);
3424 if Nkind (Arg_Parameter_Types) = N_Null then
3425 if Present (Formal) then
3429 -- A list of one type, e.g. (List) is parsed as
3430 -- a parenthesized expression.
3432 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
3433 and then Paren_Count (Arg_Parameter_Types) = 1
3436 or else Present (Next_Formal (Formal))
3441 Same_Base_Type (Arg_Parameter_Types, Formal);
3444 -- A list of more than one type is parsed as a aggregate
3446 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
3447 and then Paren_Count (Arg_Parameter_Types) = 0
3449 Ptype := First (Expressions (Arg_Parameter_Types));
3450 while Present (Ptype) or else Present (Formal) loop
3453 or else not Same_Base_Type (Ptype, Formal)
3458 Next_Formal (Formal);
3463 -- Anything else is of the wrong form
3467 ("wrong form for Parameter_Types parameter",
3468 Arg_Parameter_Types);
3470 end Check_Matching_Types;
3473 -- Match is now False if the entry we found did not match
3474 -- either a supplied Parameter_Types or Result_Types argument
3480 -- Ambiguous case, the flag Ambiguous shows if we already
3481 -- detected this and output the initial messages.
3484 if not Ambiguous then
3486 Error_Msg_Name_1 := Pname;
3488 ("pragma% does not uniquely identify subprogram!",
3490 Error_Msg_Sloc := Sloc (Ent);
3491 Error_Msg_N ("matching subprogram #!", N);
3495 Error_Msg_Sloc := Sloc (Def_Id);
3496 Error_Msg_N ("matching subprogram #!", N);
3501 Hom_Id := Homonym (Hom_Id);
3504 -- See if we found an entry
3507 if not Ambiguous then
3508 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
3510 ("pragma% cannot be given for generic subprogram");
3513 ("pragma% does not identify local subprogram");
3520 -- Import pragmas must be for imported entities
3522 if Prag_Id = Pragma_Import_Function
3524 Prag_Id = Pragma_Import_Procedure
3526 Prag_Id = Pragma_Import_Valued_Procedure
3528 if not Is_Imported (Ent) then
3530 ("pragma Import or Interface must precede pragma%");
3533 -- Here we have the Export case which can set the entity as exported
3535 -- But does not do so if the specified external name is null, since
3536 -- that is taken as a signal in DEC Ada 83 (with which we want to be
3537 -- compatible) to request no external name.
3539 elsif Nkind (Arg_External) = N_String_Literal
3540 and then String_Length (Strval (Arg_External)) = 0
3544 -- In all other cases, set entity as exported
3547 Set_Exported (Ent, Arg_Internal);
3550 -- Special processing for Valued_Procedure cases
3552 if Prag_Id = Pragma_Import_Valued_Procedure
3554 Prag_Id = Pragma_Export_Valued_Procedure
3556 Formal := First_Formal (Ent);
3559 Error_Pragma ("at least one parameter required for pragma%");
3561 elsif Ekind (Formal) /= E_Out_Parameter then
3562 Error_Pragma ("first parameter must have mode out for pragma%");
3565 Set_Is_Valued_Procedure (Ent);
3569 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
3571 -- Process Result_Mechanism argument if present. We have already
3572 -- checked that this is only allowed for the function case.
3574 if Present (Arg_Result_Mechanism) then
3575 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
3578 -- Process Mechanism parameter if present. Note that this parameter
3579 -- is not analyzed, and must not be analyzed since it is semantic
3580 -- nonsense, so we get it in exactly as the parser left it.
3582 if Present (Arg_Mechanism) then
3590 -- A single mechanism association without a formal parameter
3591 -- name is parsed as a parenthesized expression. All other
3592 -- cases are parsed as aggregates, so we rewrite the single
3593 -- parameter case as an aggregate for consistency.
3595 if Nkind (Arg_Mechanism) /= N_Aggregate
3596 and then Paren_Count (Arg_Mechanism) = 1
3598 Rewrite (Arg_Mechanism,
3599 Make_Aggregate (Sloc (Arg_Mechanism),
3600 Expressions => New_List (
3601 Relocate_Node (Arg_Mechanism))));
3604 -- Case of only mechanism name given, applies to all formals
3606 if Nkind (Arg_Mechanism) /= N_Aggregate then
3607 Formal := First_Formal (Ent);
3608 while Present (Formal) loop
3609 Set_Mechanism_Value (Formal, Arg_Mechanism);
3610 Next_Formal (Formal);
3613 -- Case of list of mechanism associations given
3616 if Null_Record_Present (Arg_Mechanism) then
3618 ("inappropriate form for Mechanism parameter",
3622 -- Deal with positional ones first
3624 Formal := First_Formal (Ent);
3626 if Present (Expressions (Arg_Mechanism)) then
3627 Mname := First (Expressions (Arg_Mechanism));
3628 while Present (Mname) loop
3631 ("too many mechanism associations", Mname);
3634 Set_Mechanism_Value (Formal, Mname);
3635 Next_Formal (Formal);
3640 -- Deal with named entries
3642 if Present (Component_Associations (Arg_Mechanism)) then
3643 Massoc := First (Component_Associations (Arg_Mechanism));
3644 while Present (Massoc) loop
3645 Choice := First (Choices (Massoc));
3647 if Nkind (Choice) /= N_Identifier
3648 or else Present (Next (Choice))
3651 ("incorrect form for mechanism association",
3655 Formal := First_Formal (Ent);
3659 ("parameter name & not present", Choice);
3662 if Chars (Choice) = Chars (Formal) then
3664 (Formal, Expression (Massoc));
3666 -- Set entity on identifier (needed by ASIS)
3668 Set_Entity (Choice, Formal);
3673 Next_Formal (Formal);
3683 -- Process First_Optional_Parameter argument if present. We have
3684 -- already checked that this is only allowed for the Import case.
3686 if Present (Arg_First_Optional_Parameter) then
3687 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
3689 ("first optional parameter must be formal parameter name",
3690 Arg_First_Optional_Parameter);
3693 Formal := First_Formal (Ent);
3697 ("specified formal parameter& not found",
3698 Arg_First_Optional_Parameter);
3701 exit when Chars (Formal) =
3702 Chars (Arg_First_Optional_Parameter);
3704 Next_Formal (Formal);
3707 Set_First_Optional_Parameter (Ent, Formal);
3709 -- Check specified and all remaining formals have right form
3711 while Present (Formal) loop
3712 if Ekind (Formal) /= E_In_Parameter then
3714 ("optional formal& is not of mode in!",
3715 Arg_First_Optional_Parameter, Formal);
3718 Dval := Default_Value (Formal);
3722 ("optional formal& does not have default value!",
3723 Arg_First_Optional_Parameter, Formal);
3725 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
3730 ("default value for optional formal& is non-static!",
3731 Arg_First_Optional_Parameter, Formal);
3735 Set_Is_Optional_Parameter (Formal);
3736 Next_Formal (Formal);
3739 end Process_Extended_Import_Export_Subprogram_Pragma;
3741 --------------------------
3742 -- Process_Generic_List --
3743 --------------------------
3745 procedure Process_Generic_List is
3750 Check_No_Identifiers;
3751 Check_At_Least_N_Arguments (1);
3754 while Present (Arg) loop
3755 Exp := Get_Pragma_Arg (Arg);
3758 if not Is_Entity_Name (Exp)
3760 (not Is_Generic_Instance (Entity (Exp))
3762 not Is_Generic_Unit (Entity (Exp)))
3765 ("pragma% argument must be name of generic unit/instance",
3771 end Process_Generic_List;
3773 ---------------------------------
3774 -- Process_Import_Or_Interface --
3775 ---------------------------------
3777 procedure Process_Import_Or_Interface is
3783 Process_Convention (C, Def_Id);
3784 Kill_Size_Check_Code (Def_Id);
3785 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
3787 if Ekind_In (Def_Id, E_Variable, E_Constant) then
3789 -- We do not permit Import to apply to a renaming declaration
3791 if Present (Renamed_Object (Def_Id)) then
3793 ("pragma% not allowed for object renaming", Arg2);
3795 -- User initialization is not allowed for imported object, but
3796 -- the object declaration may contain a default initialization,
3797 -- that will be discarded. Note that an explicit initialization
3798 -- only counts if it comes from source, otherwise it is simply
3799 -- the code generator making an implicit initialization explicit.
3801 elsif Present (Expression (Parent (Def_Id)))
3802 and then Comes_From_Source (Expression (Parent (Def_Id)))
3804 Error_Msg_Sloc := Sloc (Def_Id);
3806 ("no initialization allowed for declaration of& #",
3807 "\imported entities cannot be initialized (RM B.1(24))",
3811 Set_Imported (Def_Id);
3812 Process_Interface_Name (Def_Id, Arg3, Arg4);
3814 -- Note that we do not set Is_Public here. That's because we
3815 -- only want to set it if there is no address clause, and we
3816 -- don't know that yet, so we delay that processing till
3819 -- pragma Import completes deferred constants
3821 if Ekind (Def_Id) = E_Constant then
3822 Set_Has_Completion (Def_Id);
3825 -- It is not possible to import a constant of an unconstrained
3826 -- array type (e.g. string) because there is no simple way to
3827 -- write a meaningful subtype for it.
3829 if Is_Array_Type (Etype (Def_Id))
3830 and then not Is_Constrained (Etype (Def_Id))
3833 ("imported constant& must have a constrained subtype",
3838 elsif Is_Subprogram (Def_Id)
3839 or else Is_Generic_Subprogram (Def_Id)
3841 -- If the name is overloaded, pragma applies to all of the denoted
3842 -- entities in the same declarative part.
3845 while Present (Hom_Id) loop
3846 Def_Id := Get_Base_Subprogram (Hom_Id);
3848 -- Ignore inherited subprograms because the pragma will apply
3849 -- to the parent operation, which is the one called.
3851 if Is_Overloadable (Def_Id)
3852 and then Present (Alias (Def_Id))
3856 -- If it is not a subprogram, it must be in an outer scope and
3857 -- pragma does not apply.
3859 elsif not Is_Subprogram (Def_Id)
3860 and then not Is_Generic_Subprogram (Def_Id)
3864 -- Verify that the homonym is in the same declarative part (not
3865 -- just the same scope).
3867 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
3868 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
3873 Set_Imported (Def_Id);
3875 -- Reject an Import applied to an abstract subprogram
3877 if Is_Subprogram (Def_Id)
3878 and then Is_Abstract_Subprogram (Def_Id)
3880 Error_Msg_Sloc := Sloc (Def_Id);
3882 ("cannot import abstract subprogram& declared#",
3886 -- Special processing for Convention_Intrinsic
3888 if C = Convention_Intrinsic then
3890 -- Link_Name argument not allowed for intrinsic
3893 and then Chars (Arg3) = Name_Link_Name
3898 if Present (Arg4) then
3900 ("Link_Name argument not allowed for " &
3905 Set_Is_Intrinsic_Subprogram (Def_Id);
3907 -- If no external name is present, then check that this
3908 -- is a valid intrinsic subprogram. If an external name
3909 -- is present, then this is handled by the back end.
3912 Check_Intrinsic_Subprogram
3913 (Def_Id, Get_Pragma_Arg (Arg2));
3917 -- All interfaced procedures need an external symbol created
3918 -- for them since they are always referenced from another
3921 Set_Is_Public (Def_Id);
3923 -- Verify that the subprogram does not have a completion
3924 -- through a renaming declaration. For other completions the
3925 -- pragma appears as a too late representation.
3928 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
3932 and then Nkind (Decl) = N_Subprogram_Declaration
3933 and then Present (Corresponding_Body (Decl))
3934 and then Nkind (Unit_Declaration_Node
3935 (Corresponding_Body (Decl))) =
3936 N_Subprogram_Renaming_Declaration
3938 Error_Msg_Sloc := Sloc (Def_Id);
3940 ("cannot import&, renaming already provided for " &
3941 "declaration #", N, Def_Id);
3945 Set_Has_Completion (Def_Id);
3946 Process_Interface_Name (Def_Id, Arg3, Arg4);
3949 if Is_Compilation_Unit (Hom_Id) then
3951 -- Its possible homonyms are not affected by the pragma.
3952 -- Such homonyms might be present in the context of other
3953 -- units being compiled.
3958 Hom_Id := Homonym (Hom_Id);
3962 -- When the convention is Java or CIL, we also allow Import to be
3963 -- given for packages, generic packages, exceptions, record
3964 -- components, and access to subprograms.
3966 elsif (C = Convention_Java or else C = Convention_CIL)
3968 (Is_Package_Or_Generic_Package (Def_Id)
3969 or else Ekind (Def_Id) = E_Exception
3970 or else Ekind (Def_Id) = E_Access_Subprogram_Type
3971 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
3973 Set_Imported (Def_Id);
3974 Set_Is_Public (Def_Id);
3975 Process_Interface_Name (Def_Id, Arg3, Arg4);
3977 -- Import a CPP class
3979 elsif Is_Record_Type (Def_Id)
3980 and then C = Convention_CPP
3982 -- Types treated as CPP classes are treated as limited, but we
3983 -- don't require them to be declared this way. A warning is
3984 -- issued to encourage the user to declare them as limited.
3985 -- This is not an error, for compatibility reasons, because
3986 -- these types have been supported this way for some time.
3988 if not Is_Limited_Type (Def_Id) then
3990 ("imported 'C'P'P type should be " &
3991 "explicitly declared limited?",
3992 Get_Pragma_Arg (Arg2));
3994 ("\type will be considered limited",
3995 Get_Pragma_Arg (Arg2));
3998 Set_Is_CPP_Class (Def_Id);
3999 Set_Is_Limited_Record (Def_Id);
4001 -- Imported CPP types must not have discriminants (because C++
4002 -- classes do not have discriminants).
4004 if Has_Discriminants (Def_Id) then
4006 ("imported 'C'P'P type cannot have discriminants",
4007 First (Discriminant_Specifications
4008 (Declaration_Node (Def_Id))));
4011 -- Components of imported CPP types must not have default
4012 -- expressions because the constructor (if any) is on the
4016 Tdef : constant Node_Id :=
4017 Type_Definition (Declaration_Node (Def_Id));
4022 if Nkind (Tdef) = N_Record_Definition then
4023 Clist := Component_List (Tdef);
4026 pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
4027 Clist := Component_List (Record_Extension_Part (Tdef));
4030 if Present (Clist) then
4031 Comp := First (Component_Items (Clist));
4032 while Present (Comp) loop
4033 if Present (Expression (Comp)) then
4035 ("component of imported 'C'P'P type cannot have" &
4036 " default expression", Expression (Comp));
4046 ("second argument of pragma% must be object or subprogram",
4050 -- If this pragma applies to a compilation unit, then the unit, which
4051 -- is a subprogram, does not require (or allow) a body. We also do
4052 -- not need to elaborate imported procedures.
4054 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
4056 Cunit : constant Node_Id := Parent (Parent (N));
4058 Set_Body_Required (Cunit, False);
4061 end Process_Import_Or_Interface;
4063 --------------------
4064 -- Process_Inline --
4065 --------------------
4067 procedure Process_Inline (Active : Boolean) is
4073 Effective : Boolean := False;
4075 procedure Make_Inline (Subp : Entity_Id);
4076 -- Subp is the defining unit name of the subprogram declaration. Set
4077 -- the flag, as well as the flag in the corresponding body, if there
4080 procedure Set_Inline_Flags (Subp : Entity_Id);
4081 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
4082 -- Has_Pragma_Inline_Always for the Inline_Always case.
4084 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
4085 -- Returns True if it can be determined at this stage that inlining
4086 -- is not possible, for example if the body is available and contains
4087 -- exception handlers, we prevent inlining, since otherwise we can
4088 -- get undefined symbols at link time. This function also emits a
4089 -- warning if front-end inlining is enabled and the pragma appears
4092 -- ??? is business with link symbols still valid, or does it relate
4093 -- to front end ZCX which is being phased out ???
4095 ---------------------------
4096 -- Inlining_Not_Possible --
4097 ---------------------------
4099 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
4100 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
4104 if Nkind (Decl) = N_Subprogram_Body then
4105 Stats := Handled_Statement_Sequence (Decl);
4106 return Present (Exception_Handlers (Stats))
4107 or else Present (At_End_Proc (Stats));
4109 elsif Nkind (Decl) = N_Subprogram_Declaration
4110 and then Present (Corresponding_Body (Decl))
4112 if Front_End_Inlining
4113 and then Analyzed (Corresponding_Body (Decl))
4115 Error_Msg_N ("pragma appears too late, ignored?", N);
4118 -- If the subprogram is a renaming as body, the body is just a
4119 -- call to the renamed subprogram, and inlining is trivially
4123 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
4124 N_Subprogram_Renaming_Declaration
4130 Handled_Statement_Sequence
4131 (Unit_Declaration_Node (Corresponding_Body (Decl)));
4134 Present (Exception_Handlers (Stats))
4135 or else Present (At_End_Proc (Stats));
4139 -- If body is not available, assume the best, the check is
4140 -- performed again when compiling enclosing package bodies.
4144 end Inlining_Not_Possible;
4150 procedure Make_Inline (Subp : Entity_Id) is
4151 Kind : constant Entity_Kind := Ekind (Subp);
4152 Inner_Subp : Entity_Id := Subp;
4155 -- Ignore if bad type, avoid cascaded error
4157 if Etype (Subp) = Any_Type then
4161 -- Ignore if all inlining is suppressed
4163 elsif Suppress_All_Inlining then
4167 -- If inlining is not possible, for now do not treat as an error
4169 elsif Inlining_Not_Possible (Subp) then
4173 -- Here we have a candidate for inlining, but we must exclude
4174 -- derived operations. Otherwise we would end up trying to inline
4175 -- a phantom declaration, and the result would be to drag in a
4176 -- body which has no direct inlining associated with it. That
4177 -- would not only be inefficient but would also result in the
4178 -- backend doing cross-unit inlining in cases where it was
4179 -- definitely inappropriate to do so.
4181 -- However, a simple Comes_From_Source test is insufficient, since
4182 -- we do want to allow inlining of generic instances which also do
4183 -- not come from source. We also need to recognize specs generated
4184 -- by the front-end for bodies that carry the pragma. Finally,
4185 -- predefined operators do not come from source but are not
4186 -- inlineable either.
4188 elsif Is_Generic_Instance (Subp)
4189 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
4193 elsif not Comes_From_Source (Subp)
4194 and then Scope (Subp) /= Standard_Standard
4200 -- The referenced entity must either be the enclosing entity, or
4201 -- an entity declared within the current open scope.
4203 if Present (Scope (Subp))
4204 and then Scope (Subp) /= Current_Scope
4205 and then Subp /= Current_Scope
4208 ("argument of% must be entity in current scope", Assoc);
4212 -- Processing for procedure, operator or function. If subprogram
4213 -- is aliased (as for an instance) indicate that the renamed
4214 -- entity (if declared in the same unit) is inlined.
4216 if Is_Subprogram (Subp) then
4222 Inner_Subp := Ultimate_Alias (Inner_Subp);
4224 if In_Same_Source_Unit (Subp, Inner_Subp) then
4225 Set_Inline_Flags (Inner_Subp);
4227 Decl := Parent (Parent (Inner_Subp));
4229 if Nkind (Decl) = N_Subprogram_Declaration
4230 and then Present (Corresponding_Body (Decl))
4232 Set_Inline_Flags (Corresponding_Body (Decl));
4234 elsif Is_Generic_Instance (Subp) then
4236 -- Indicate that the body needs to be created for
4237 -- inlining subsequent calls. The instantiation node
4238 -- follows the declaration of the wrapper package
4241 if Scope (Subp) /= Standard_Standard
4243 Need_Subprogram_Instance_Body
4244 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
4254 -- For a generic subprogram set flag as well, for use at the point
4255 -- of instantiation, to determine whether the body should be
4258 elsif Is_Generic_Subprogram (Subp) then
4259 Set_Inline_Flags (Subp);
4262 -- Literals are by definition inlined
4264 elsif Kind = E_Enumeration_Literal then
4267 -- Anything else is an error
4271 ("expect subprogram name for pragma%", Assoc);
4275 ----------------------
4276 -- Set_Inline_Flags --
4277 ----------------------
4279 procedure Set_Inline_Flags (Subp : Entity_Id) is
4282 Set_Is_Inlined (Subp, Sense);
4285 if not Has_Pragma_Inline (Subp) then
4286 Set_Has_Pragma_Inline (Subp, Sense);
4290 if Prag_Id = Pragma_Inline_Always then
4291 Set_Has_Pragma_Inline_Always (Subp, Sense);
4293 end Set_Inline_Flags;
4295 -- Start of processing for Process_Inline
4298 Check_No_Identifiers;
4299 Check_At_Least_N_Arguments (1);
4302 Inline_Processing_Required := True;
4306 while Present (Assoc) loop
4307 Subp_Id := Get_Pragma_Arg (Assoc);
4311 if Is_Entity_Name (Subp_Id) then
4312 Subp := Entity (Subp_Id);
4314 if Subp = Any_Id then
4316 -- If previous error, avoid cascaded errors
4324 if not From_Aspect_Specification (N) then
4325 while Present (Homonym (Subp))
4326 and then Scope (Homonym (Subp)) = Current_Scope
4328 Make_Inline (Homonym (Subp));
4329 Subp := Homonym (Subp);
4337 ("inappropriate argument for pragma%", Assoc);
4340 and then Warn_On_Redundant_Constructs
4341 and then not Suppress_All_Inlining
4343 if Inlining_Not_Possible (Subp) then
4345 ("pragma Inline for& is ignored?", N, Entity (Subp_Id));
4348 ("pragma Inline for& is redundant?", N, Entity (Subp_Id));
4356 ----------------------------
4357 -- Process_Interface_Name --
4358 ----------------------------
4360 procedure Process_Interface_Name
4361 (Subprogram_Def : Entity_Id;
4367 String_Val : String_Id;
4369 procedure Check_Form_Of_Interface_Name
4371 Ext_Name_Case : Boolean);
4372 -- SN is a string literal node for an interface name. This routine
4373 -- performs some minimal checks that the name is reasonable. In
4374 -- particular that no spaces or other obviously incorrect characters
4375 -- appear. This is only a warning, since any characters are allowed.
4376 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
4378 ----------------------------------
4379 -- Check_Form_Of_Interface_Name --
4380 ----------------------------------
4382 procedure Check_Form_Of_Interface_Name
4384 Ext_Name_Case : Boolean)
4386 S : constant String_Id := Strval (Expr_Value_S (SN));
4387 SL : constant Nat := String_Length (S);
4392 Error_Msg_N ("interface name cannot be null string", SN);
4395 for J in 1 .. SL loop
4396 C := Get_String_Char (S, J);
4398 -- Look for dubious character and issue unconditional warning.
4399 -- Definitely dubious if not in character range.
4401 if not In_Character_Range (C)
4403 -- For all cases except CLI target,
4404 -- commas, spaces and slashes are dubious (in CLI, we use
4405 -- commas and backslashes in external names to specify
4406 -- assembly version and public key, while slashes and spaces
4407 -- can be used in names to mark nested classes and
4410 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
4411 and then (Get_Character (C) = ','
4413 Get_Character (C) = '\'))
4414 or else (VM_Target /= CLI_Target
4415 and then (Get_Character (C) = ' '
4417 Get_Character (C) = '/'))
4420 ("?interface name contains illegal character",
4421 Sloc (SN) + Source_Ptr (J));
4424 end Check_Form_Of_Interface_Name;
4426 -- Start of processing for Process_Interface_Name
4429 if No (Link_Arg) then
4430 if No (Ext_Arg) then
4431 if VM_Target = CLI_Target
4432 and then Ekind (Subprogram_Def) = E_Package
4433 and then Nkind (Parent (Subprogram_Def)) =
4434 N_Package_Specification
4435 and then Present (Generic_Parent (Parent (Subprogram_Def)))
4440 (Generic_Parent (Parent (Subprogram_Def))));
4445 elsif Chars (Ext_Arg) = Name_Link_Name then
4447 Link_Nam := Expression (Ext_Arg);
4450 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
4451 Ext_Nam := Expression (Ext_Arg);
4456 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
4457 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
4458 Ext_Nam := Expression (Ext_Arg);
4459 Link_Nam := Expression (Link_Arg);
4462 -- Check expressions for external name and link name are static
4464 if Present (Ext_Nam) then
4465 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
4466 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
4468 -- Verify that external name is not the name of a local entity,
4469 -- which would hide the imported one and could lead to run-time
4470 -- surprises. The problem can only arise for entities declared in
4471 -- a package body (otherwise the external name is fully qualified
4472 -- and will not conflict).
4480 if Prag_Id = Pragma_Import then
4481 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
4483 E := Entity_Id (Get_Name_Table_Info (Nam));
4485 if Nam /= Chars (Subprogram_Def)
4486 and then Present (E)
4487 and then not Is_Overloadable (E)
4488 and then Is_Immediately_Visible (E)
4489 and then not Is_Imported (E)
4490 and then Ekind (Scope (E)) = E_Package
4493 while Present (Par) loop
4494 if Nkind (Par) = N_Package_Body then
4495 Error_Msg_Sloc := Sloc (E);
4497 ("imported entity is hidden by & declared#",
4502 Par := Parent (Par);
4509 if Present (Link_Nam) then
4510 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
4511 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
4514 -- If there is no link name, just set the external name
4516 if No (Link_Nam) then
4517 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
4519 -- For the Link_Name case, the given literal is preceded by an
4520 -- asterisk, which indicates to GCC that the given name should be
4521 -- taken literally, and in particular that no prepending of
4522 -- underlines should occur, even in systems where this is the
4528 if VM_Target = No_VM then
4529 Store_String_Char (Get_Char_Code ('*'));
4532 String_Val := Strval (Expr_Value_S (Link_Nam));
4533 Store_String_Chars (String_Val);
4535 Make_String_Literal (Sloc (Link_Nam),
4536 Strval => End_String);
4539 Set_Encoded_Interface_Name
4540 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
4542 -- We allow duplicated export names in CIL, as they are always
4543 -- enclosed in a namespace that differentiates them, and overloaded
4544 -- entities are supported by the VM.
4546 if Convention (Subprogram_Def) /= Convention_CIL then
4547 Check_Duplicated_Export_Name (Link_Nam);
4549 end Process_Interface_Name;
4551 -----------------------------------------
4552 -- Process_Interrupt_Or_Attach_Handler --
4553 -----------------------------------------
4555 procedure Process_Interrupt_Or_Attach_Handler is
4556 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
4557 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
4558 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
4561 Set_Is_Interrupt_Handler (Handler_Proc);
4563 -- If the pragma is not associated with a handler procedure within a
4564 -- protected type, then it must be for a nonprotected procedure for
4565 -- the AAMP target, in which case we don't associate a representation
4566 -- item with the procedure's scope.
4568 if Ekind (Proc_Scope) = E_Protected_Type then
4569 if Prag_Id = Pragma_Interrupt_Handler
4571 Prag_Id = Pragma_Attach_Handler
4573 Record_Rep_Item (Proc_Scope, N);
4576 end Process_Interrupt_Or_Attach_Handler;
4578 --------------------------------------------------
4579 -- Process_Restrictions_Or_Restriction_Warnings --
4580 --------------------------------------------------
4582 -- Note: some of the simple identifier cases were handled in par-prag,
4583 -- but it is harmless (and more straightforward) to simply handle all
4584 -- cases here, even if it means we repeat a bit of work in some cases.
4586 procedure Process_Restrictions_Or_Restriction_Warnings
4590 R_Id : Restriction_Id;
4595 procedure Check_Unit_Name (N : Node_Id);
4596 -- Checks unit name parameter for No_Dependence. Returns if it has
4597 -- an appropriate form, otherwise raises pragma argument error.
4599 ---------------------
4600 -- Check_Unit_Name --
4601 ---------------------
4603 procedure Check_Unit_Name (N : Node_Id) is
4605 if Nkind (N) = N_Selected_Component then
4606 Check_Unit_Name (Prefix (N));
4607 Check_Unit_Name (Selector_Name (N));
4609 elsif Nkind (N) = N_Identifier then
4614 ("wrong form for unit name for No_Dependence", N);
4616 end Check_Unit_Name;
4618 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
4621 -- Ignore all Restrictions pragma in CodePeer mode
4623 if CodePeer_Mode then
4627 Check_Ada_83_Warning;
4628 Check_At_Least_N_Arguments (1);
4629 Check_Valid_Configuration_Pragma;
4632 while Present (Arg) loop
4634 Expr := Get_Pragma_Arg (Arg);
4636 -- Case of no restriction identifier present
4638 if Id = No_Name then
4639 if Nkind (Expr) /= N_Identifier then
4641 ("invalid form for restriction", Arg);
4646 (Process_Restriction_Synonyms (Expr));
4648 if R_Id not in All_Boolean_Restrictions then
4649 Error_Msg_Name_1 := Pname;
4651 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
4653 -- Check for possible misspelling
4655 for J in Restriction_Id loop
4657 Rnm : constant String := Restriction_Id'Image (J);
4660 Name_Buffer (1 .. Rnm'Length) := Rnm;
4661 Name_Len := Rnm'Length;
4662 Set_Casing (All_Lower_Case);
4664 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
4666 (Identifier_Casing (Current_Source_File));
4667 Error_Msg_String (1 .. Rnm'Length) :=
4668 Name_Buffer (1 .. Name_Len);
4669 Error_Msg_Strlen := Rnm'Length;
4670 Error_Msg_N -- CODEFIX
4671 ("\possible misspelling of ""~""",
4672 Get_Pragma_Arg (Arg));
4681 if Implementation_Restriction (R_Id) then
4682 Check_Restriction (No_Implementation_Restrictions, Arg);
4685 -- If this is a warning, then set the warning unless we already
4686 -- have a real restriction active (we never want a warning to
4687 -- override a real restriction).
4690 if not Restriction_Active (R_Id) then
4691 Set_Restriction (R_Id, N);
4692 Restriction_Warnings (R_Id) := True;
4695 -- If real restriction case, then set it and make sure that the
4696 -- restriction warning flag is off, since a real restriction
4697 -- always overrides a warning.
4700 Set_Restriction (R_Id, N);
4701 Restriction_Warnings (R_Id) := False;
4704 -- Check for obsolescent restrictions in Ada 2005 mode
4707 and then Ada_Version >= Ada_2005
4708 and then (R_Id = No_Asynchronous_Control
4710 R_Id = No_Unchecked_Deallocation
4712 R_Id = No_Unchecked_Conversion)
4714 Check_Restriction (No_Obsolescent_Features, N);
4717 -- A very special case that must be processed here: pragma
4718 -- Restrictions (No_Exceptions) turns off all run-time
4719 -- checking. This is a bit dubious in terms of the formal
4720 -- language definition, but it is what is intended by RM
4721 -- H.4(12). Restriction_Warnings never affects generated code
4722 -- so this is done only in the real restriction case.
4724 if R_Id = No_Exceptions and then not Warn then
4725 Scope_Suppress := (others => True);
4728 -- Case of No_Dependence => unit-name. Note that the parser
4729 -- already made the necessary entry in the No_Dependence table.
4731 elsif Id = Name_No_Dependence then
4732 Check_Unit_Name (Expr);
4734 -- All other cases of restriction identifier present
4737 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
4738 Analyze_And_Resolve (Expr, Any_Integer);
4740 if R_Id not in All_Parameter_Restrictions then
4742 ("invalid restriction parameter identifier", Arg);
4744 elsif not Is_OK_Static_Expression (Expr) then
4745 Flag_Non_Static_Expr
4746 ("value must be static expression!", Expr);
4749 elsif not Is_Integer_Type (Etype (Expr))
4750 or else Expr_Value (Expr) < 0
4753 ("value must be non-negative integer", Arg);
4756 -- Restriction pragma is active
4758 Val := Expr_Value (Expr);
4760 if not UI_Is_In_Int_Range (Val) then
4762 ("pragma ignored, value too large?", Arg);
4765 -- Warning case. If the real restriction is active, then we
4766 -- ignore the request, since warning never overrides a real
4767 -- restriction. Otherwise we set the proper warning. Note that
4768 -- this circuit sets the warning again if it is already set,
4769 -- which is what we want, since the constant may have changed.
4772 if not Restriction_Active (R_Id) then
4774 (R_Id, N, Integer (UI_To_Int (Val)));
4775 Restriction_Warnings (R_Id) := True;
4778 -- Real restriction case, set restriction and make sure warning
4779 -- flag is off since real restriction always overrides warning.
4782 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
4783 Restriction_Warnings (R_Id) := False;
4789 end Process_Restrictions_Or_Restriction_Warnings;
4791 ---------------------------------
4792 -- Process_Suppress_Unsuppress --
4793 ---------------------------------
4795 -- Note: this procedure makes entries in the check suppress data
4796 -- structures managed by Sem. See spec of package Sem for full
4797 -- details on how we handle recording of check suppression.
4799 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
4804 In_Package_Spec : constant Boolean :=
4805 Is_Package_Or_Generic_Package (Current_Scope)
4806 and then not In_Package_Body (Current_Scope);
4808 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
4809 -- Used to suppress a single check on the given entity
4811 --------------------------------
4812 -- Suppress_Unsuppress_Echeck --
4813 --------------------------------
4815 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
4817 Set_Checks_May_Be_Suppressed (E);
4819 if In_Package_Spec then
4820 Push_Global_Suppress_Stack_Entry
4823 Suppress => Suppress_Case);
4826 Push_Local_Suppress_Stack_Entry
4829 Suppress => Suppress_Case);
4832 -- If this is a first subtype, and the base type is distinct,
4833 -- then also set the suppress flags on the base type.
4835 if Is_First_Subtype (E)
4836 and then Etype (E) /= E
4838 Suppress_Unsuppress_Echeck (Etype (E), C);
4840 end Suppress_Unsuppress_Echeck;
4842 -- Start of processing for Process_Suppress_Unsuppress
4845 -- Ignore pragma Suppress/Unsuppress in codepeer mode on user code:
4846 -- we want to generate checks for analysis purposes, as set by -gnatC
4848 if CodePeer_Mode and then Comes_From_Source (N) then
4852 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
4853 -- declarative part or a package spec (RM 11.5(5)).
4855 if not Is_Configuration_Pragma then
4856 Check_Is_In_Decl_Part_Or_Package_Spec;
4859 Check_At_Least_N_Arguments (1);
4860 Check_At_Most_N_Arguments (2);
4861 Check_No_Identifier (Arg1);
4862 Check_Arg_Is_Identifier (Arg1);
4864 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
4866 if C = No_Check_Id then
4868 ("argument of pragma% is not valid check name", Arg1);
4871 if not Suppress_Case
4872 and then (C = All_Checks or else C = Overflow_Check)
4874 Opt.Overflow_Checks_Unsuppressed := True;
4877 if Arg_Count = 1 then
4879 -- Make an entry in the local scope suppress table. This is the
4880 -- table that directly shows the current value of the scope
4881 -- suppress check for any check id value.
4883 if C = All_Checks then
4885 -- For All_Checks, we set all specific predefined checks with
4886 -- the exception of Elaboration_Check, which is handled
4887 -- specially because of not wanting All_Checks to have the
4888 -- effect of deactivating static elaboration order processing.
4890 for J in Scope_Suppress'Range loop
4891 if J /= Elaboration_Check then
4892 Scope_Suppress (J) := Suppress_Case;
4896 -- If not All_Checks, and predefined check, then set appropriate
4897 -- scope entry. Note that we will set Elaboration_Check if this
4898 -- is explicitly specified.
4900 elsif C in Predefined_Check_Id then
4901 Scope_Suppress (C) := Suppress_Case;
4904 -- Also make an entry in the Local_Entity_Suppress table
4906 Push_Local_Suppress_Stack_Entry
4909 Suppress => Suppress_Case);
4911 -- Case of two arguments present, where the check is suppressed for
4912 -- a specified entity (given as the second argument of the pragma)
4915 -- This is obsolescent in Ada 2005 mode
4917 if Ada_Version >= Ada_2005 then
4918 Check_Restriction (No_Obsolescent_Features, Arg2);
4921 Check_Optional_Identifier (Arg2, Name_On);
4922 E_Id := Get_Pragma_Arg (Arg2);
4925 if not Is_Entity_Name (E_Id) then
4927 ("second argument of pragma% must be entity name", Arg2);
4936 -- Enforce RM 11.5(7) which requires that for a pragma that
4937 -- appears within a package spec, the named entity must be
4938 -- within the package spec. We allow the package name itself
4939 -- to be mentioned since that makes sense, although it is not
4940 -- strictly allowed by 11.5(7).
4943 and then E /= Current_Scope
4944 and then Scope (E) /= Current_Scope
4947 ("entity in pragma% is not in package spec (RM 11.5(7))",
4951 -- Loop through homonyms. As noted below, in the case of a package
4952 -- spec, only homonyms within the package spec are considered.
4955 Suppress_Unsuppress_Echeck (E, C);
4957 if Is_Generic_Instance (E)
4958 and then Is_Subprogram (E)
4959 and then Present (Alias (E))
4961 Suppress_Unsuppress_Echeck (Alias (E), C);
4964 -- Move to next homonym if not aspect spec case
4966 exit when From_Aspect_Specification (N);
4970 -- If we are within a package specification, the pragma only
4971 -- applies to homonyms in the same scope.
4973 exit when In_Package_Spec
4974 and then Scope (E) /= Current_Scope;
4977 end Process_Suppress_Unsuppress;
4983 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
4985 if Is_Imported (E) then
4987 ("cannot export entity& that was previously imported", Arg);
4989 elsif Present (Address_Clause (E)) and then not CodePeer_Mode then
4991 ("cannot export entity& that has an address clause", Arg);
4994 Set_Is_Exported (E);
4996 -- Generate a reference for entity explicitly, because the
4997 -- identifier may be overloaded and name resolution will not
5000 Generate_Reference (E, Arg);
5002 -- Deal with exporting non-library level entity
5004 if not Is_Library_Level_Entity (E) then
5006 -- Not allowed at all for subprograms
5008 if Is_Subprogram (E) then
5009 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
5011 -- Otherwise set public and statically allocated
5015 Set_Is_Statically_Allocated (E);
5017 -- Warn if the corresponding W flag is set and the pragma comes
5018 -- from source. The latter may not be true e.g. on VMS where we
5019 -- expand export pragmas for exception codes associated with
5020 -- imported or exported exceptions. We do not want to generate
5021 -- a warning for something that the user did not write.
5023 if Warn_On_Export_Import
5024 and then Comes_From_Source (Arg)
5027 ("?& has been made static as a result of Export", Arg, E);
5029 ("\this usage is non-standard and non-portable", Arg);
5034 if Warn_On_Export_Import and then Is_Type (E) then
5035 Error_Msg_NE ("exporting a type has no effect?", Arg, E);
5038 if Warn_On_Export_Import and Inside_A_Generic then
5040 ("all instances of& will have the same external name?", Arg, E);
5044 ----------------------------------------------
5045 -- Set_Extended_Import_Export_External_Name --
5046 ----------------------------------------------
5048 procedure Set_Extended_Import_Export_External_Name
5049 (Internal_Ent : Entity_Id;
5050 Arg_External : Node_Id)
5052 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
5056 if No (Arg_External) then
5060 Check_Arg_Is_External_Name (Arg_External);
5062 if Nkind (Arg_External) = N_String_Literal then
5063 if String_Length (Strval (Arg_External)) = 0 then
5066 New_Name := Adjust_External_Name_Case (Arg_External);
5069 elsif Nkind (Arg_External) = N_Identifier then
5070 New_Name := Get_Default_External_Name (Arg_External);
5072 -- Check_Arg_Is_External_Name should let through only identifiers and
5073 -- string literals or static string expressions (which are folded to
5074 -- string literals).
5077 raise Program_Error;
5080 -- If we already have an external name set (by a prior normal Import
5081 -- or Export pragma), then the external names must match
5083 if Present (Interface_Name (Internal_Ent)) then
5084 Check_Matching_Internal_Names : declare
5085 S1 : constant String_Id := Strval (Old_Name);
5086 S2 : constant String_Id := Strval (New_Name);
5089 -- Called if names do not match
5095 procedure Mismatch is
5097 Error_Msg_Sloc := Sloc (Old_Name);
5099 ("external name does not match that given #",
5103 -- Start of processing for Check_Matching_Internal_Names
5106 if String_Length (S1) /= String_Length (S2) then
5110 for J in 1 .. String_Length (S1) loop
5111 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
5116 end Check_Matching_Internal_Names;
5118 -- Otherwise set the given name
5121 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
5122 Check_Duplicated_Export_Name (New_Name);
5124 end Set_Extended_Import_Export_External_Name;
5130 procedure Set_Imported (E : Entity_Id) is
5132 -- Error message if already imported or exported
5134 if Is_Exported (E) or else Is_Imported (E) then
5136 -- Error if being set Exported twice
5138 if Is_Exported (E) then
5139 Error_Msg_NE ("entity& was previously exported", N, E);
5141 -- OK if Import/Interface case
5143 elsif Import_Interface_Present (N) then
5146 -- Error if being set Imported twice
5149 Error_Msg_NE ("entity& was previously imported", N, E);
5152 Error_Msg_Name_1 := Pname;
5154 ("\(pragma% applies to all previous entities)", N);
5156 Error_Msg_Sloc := Sloc (E);
5157 Error_Msg_NE ("\import not allowed for& declared#", N, E);
5159 -- Here if not previously imported or exported, OK to import
5162 Set_Is_Imported (E);
5164 -- If the entity is an object that is not at the library level,
5165 -- then it is statically allocated. We do not worry about objects
5166 -- with address clauses in this context since they are not really
5167 -- imported in the linker sense.
5170 and then not Is_Library_Level_Entity (E)
5171 and then No (Address_Clause (E))
5173 Set_Is_Statically_Allocated (E);
5180 -------------------------
5181 -- Set_Mechanism_Value --
5182 -------------------------
5184 -- Note: the mechanism name has not been analyzed (and cannot indeed be
5185 -- analyzed, since it is semantic nonsense), so we get it in the exact
5186 -- form created by the parser.
5188 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
5191 Mech_Name_Id : Name_Id;
5193 procedure Bad_Class;
5194 -- Signal bad descriptor class name
5196 procedure Bad_Mechanism;
5197 -- Signal bad mechanism name
5203 procedure Bad_Class is
5205 Error_Pragma_Arg ("unrecognized descriptor class name", Class);
5208 -------------------------
5209 -- Bad_Mechanism_Value --
5210 -------------------------
5212 procedure Bad_Mechanism is
5214 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
5217 -- Start of processing for Set_Mechanism_Value
5220 if Mechanism (Ent) /= Default_Mechanism then
5222 ("mechanism for & has already been set", Mech_Name, Ent);
5225 -- MECHANISM_NAME ::= value | reference | descriptor |
5228 if Nkind (Mech_Name) = N_Identifier then
5229 if Chars (Mech_Name) = Name_Value then
5230 Set_Mechanism (Ent, By_Copy);
5233 elsif Chars (Mech_Name) = Name_Reference then
5234 Set_Mechanism (Ent, By_Reference);
5237 elsif Chars (Mech_Name) = Name_Descriptor then
5238 Check_VMS (Mech_Name);
5240 -- Descriptor => Short_Descriptor if pragma was given
5242 if Short_Descriptors then
5243 Set_Mechanism (Ent, By_Short_Descriptor);
5245 Set_Mechanism (Ent, By_Descriptor);
5250 elsif Chars (Mech_Name) = Name_Short_Descriptor then
5251 Check_VMS (Mech_Name);
5252 Set_Mechanism (Ent, By_Short_Descriptor);
5255 elsif Chars (Mech_Name) = Name_Copy then
5257 ("bad mechanism name, Value assumed", Mech_Name);
5263 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
5264 -- short_descriptor (CLASS_NAME)
5265 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5267 -- Note: this form is parsed as an indexed component
5269 elsif Nkind (Mech_Name) = N_Indexed_Component then
5270 Class := First (Expressions (Mech_Name));
5272 if Nkind (Prefix (Mech_Name)) /= N_Identifier
5273 or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else
5274 Chars (Prefix (Mech_Name)) = Name_Short_Descriptor)
5275 or else Present (Next (Class))
5279 Mech_Name_Id := Chars (Prefix (Mech_Name));
5281 -- Change Descriptor => Short_Descriptor if pragma was given
5283 if Mech_Name_Id = Name_Descriptor
5284 and then Short_Descriptors
5286 Mech_Name_Id := Name_Short_Descriptor;
5290 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
5291 -- short_descriptor (Class => CLASS_NAME)
5292 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5294 -- Note: this form is parsed as a function call
5296 elsif Nkind (Mech_Name) = N_Function_Call then
5297 Param := First (Parameter_Associations (Mech_Name));
5299 if Nkind (Name (Mech_Name)) /= N_Identifier
5300 or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else
5301 Chars (Name (Mech_Name)) = Name_Short_Descriptor)
5302 or else Present (Next (Param))
5303 or else No (Selector_Name (Param))
5304 or else Chars (Selector_Name (Param)) /= Name_Class
5308 Class := Explicit_Actual_Parameter (Param);
5309 Mech_Name_Id := Chars (Name (Mech_Name));
5316 -- Fall through here with Class set to descriptor class name
5318 Check_VMS (Mech_Name);
5320 if Nkind (Class) /= N_Identifier then
5323 elsif Mech_Name_Id = Name_Descriptor
5324 and then Chars (Class) = Name_UBS
5326 Set_Mechanism (Ent, By_Descriptor_UBS);
5328 elsif Mech_Name_Id = Name_Descriptor
5329 and then Chars (Class) = Name_UBSB
5331 Set_Mechanism (Ent, By_Descriptor_UBSB);
5333 elsif Mech_Name_Id = Name_Descriptor
5334 and then Chars (Class) = Name_UBA
5336 Set_Mechanism (Ent, By_Descriptor_UBA);
5338 elsif Mech_Name_Id = Name_Descriptor
5339 and then Chars (Class) = Name_S
5341 Set_Mechanism (Ent, By_Descriptor_S);
5343 elsif Mech_Name_Id = Name_Descriptor
5344 and then Chars (Class) = Name_SB
5346 Set_Mechanism (Ent, By_Descriptor_SB);
5348 elsif Mech_Name_Id = Name_Descriptor
5349 and then Chars (Class) = Name_A
5351 Set_Mechanism (Ent, By_Descriptor_A);
5353 elsif Mech_Name_Id = Name_Descriptor
5354 and then Chars (Class) = Name_NCA
5356 Set_Mechanism (Ent, By_Descriptor_NCA);
5358 elsif Mech_Name_Id = Name_Short_Descriptor
5359 and then Chars (Class) = Name_UBS
5361 Set_Mechanism (Ent, By_Short_Descriptor_UBS);
5363 elsif Mech_Name_Id = Name_Short_Descriptor
5364 and then Chars (Class) = Name_UBSB
5366 Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
5368 elsif Mech_Name_Id = Name_Short_Descriptor
5369 and then Chars (Class) = Name_UBA
5371 Set_Mechanism (Ent, By_Short_Descriptor_UBA);
5373 elsif Mech_Name_Id = Name_Short_Descriptor
5374 and then Chars (Class) = Name_S
5376 Set_Mechanism (Ent, By_Short_Descriptor_S);
5378 elsif Mech_Name_Id = Name_Short_Descriptor
5379 and then Chars (Class) = Name_SB
5381 Set_Mechanism (Ent, By_Short_Descriptor_SB);
5383 elsif Mech_Name_Id = Name_Short_Descriptor
5384 and then Chars (Class) = Name_A
5386 Set_Mechanism (Ent, By_Short_Descriptor_A);
5388 elsif Mech_Name_Id = Name_Short_Descriptor
5389 and then Chars (Class) = Name_NCA
5391 Set_Mechanism (Ent, By_Short_Descriptor_NCA);
5396 end Set_Mechanism_Value;
5398 ---------------------------
5399 -- Set_Ravenscar_Profile --
5400 ---------------------------
5402 -- The tasks to be done here are
5404 -- Set required policies
5406 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
5407 -- pragma Locking_Policy (Ceiling_Locking)
5409 -- Set Detect_Blocking mode
5411 -- Set required restrictions (see System.Rident for detailed list)
5413 procedure Set_Ravenscar_Profile (N : Node_Id) is
5415 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
5417 if Task_Dispatching_Policy /= ' '
5418 and then Task_Dispatching_Policy /= 'F'
5420 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
5421 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
5423 -- Set the FIFO_Within_Priorities policy, but always preserve
5424 -- System_Location since we like the error message with the run time
5428 Task_Dispatching_Policy := 'F';
5430 if Task_Dispatching_Policy_Sloc /= System_Location then
5431 Task_Dispatching_Policy_Sloc := Loc;
5435 -- pragma Locking_Policy (Ceiling_Locking)
5437 if Locking_Policy /= ' '
5438 and then Locking_Policy /= 'C'
5440 Error_Msg_Sloc := Locking_Policy_Sloc;
5441 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
5443 -- Set the Ceiling_Locking policy, but preserve System_Location since
5444 -- we like the error message with the run time name.
5447 Locking_Policy := 'C';
5449 if Locking_Policy_Sloc /= System_Location then
5450 Locking_Policy_Sloc := Loc;
5454 -- pragma Detect_Blocking
5456 Detect_Blocking := True;
5458 -- Set the corresponding restrictions
5460 Set_Profile_Restrictions
5461 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
5462 end Set_Ravenscar_Profile;
5464 -- Start of processing for Analyze_Pragma
5467 -- Deal with unrecognized pragma
5469 if not Is_Pragma_Name (Pname) then
5470 if Warn_On_Unrecognized_Pragma then
5471 Error_Msg_Name_1 := Pname;
5472 Error_Msg_N ("?unrecognized pragma%!", Pragma_Identifier (N));
5474 for PN in First_Pragma_Name .. Last_Pragma_Name loop
5475 if Is_Bad_Spelling_Of (Pname, PN) then
5476 Error_Msg_Name_1 := PN;
5477 Error_Msg_N -- CODEFIX
5478 ("\?possible misspelling of %!", Pragma_Identifier (N));
5487 -- Here to start processing for recognized pragma
5489 Prag_Id := Get_Pragma_Id (Pname);
5498 if Present (Pragma_Argument_Associations (N)) then
5499 Arg1 := First (Pragma_Argument_Associations (N));
5501 if Present (Arg1) then
5502 Arg2 := Next (Arg1);
5504 if Present (Arg2) then
5505 Arg3 := Next (Arg2);
5507 if Present (Arg3) then
5508 Arg4 := Next (Arg3);
5514 -- Count number of arguments
5521 while Present (Arg_Node) loop
5522 Arg_Count := Arg_Count + 1;
5527 -- An enumeration type defines the pragmas that are supported by the
5528 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
5529 -- into the corresponding enumeration value for the following case.
5537 -- pragma Abort_Defer;
5539 when Pragma_Abort_Defer =>
5541 Check_Arg_Count (0);
5543 -- The only required semantic processing is to check the
5544 -- placement. This pragma must appear at the start of the
5545 -- statement sequence of a handled sequence of statements.
5547 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
5548 or else N /= First (Statements (Parent (N)))
5559 -- Note: this pragma also has some specific processing in Par.Prag
5560 -- because we want to set the Ada version mode during parsing.
5562 when Pragma_Ada_83 =>
5564 Check_Arg_Count (0);
5566 -- We really should check unconditionally for proper configuration
5567 -- pragma placement, since we really don't want mixed Ada modes
5568 -- within a single unit, and the GNAT reference manual has always
5569 -- said this was a configuration pragma, but we did not check and
5570 -- are hesitant to add the check now.
5572 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
5573 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
5574 -- or Ada 2012 mode.
5576 if Ada_Version >= Ada_2005 then
5577 Check_Valid_Configuration_Pragma;
5580 -- Now set Ada 83 mode
5582 Ada_Version := Ada_83;
5583 Ada_Version_Explicit := Ada_Version;
5591 -- Note: this pragma also has some specific processing in Par.Prag
5592 -- because we want to set the Ada 83 version mode during parsing.
5594 when Pragma_Ada_95 =>
5596 Check_Arg_Count (0);
5598 -- We really should check unconditionally for proper configuration
5599 -- pragma placement, since we really don't want mixed Ada modes
5600 -- within a single unit, and the GNAT reference manual has always
5601 -- said this was a configuration pragma, but we did not check and
5602 -- are hesitant to add the check now.
5604 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
5605 -- or Ada 95, so we must check if we are in Ada 2005 mode.
5607 if Ada_Version >= Ada_2005 then
5608 Check_Valid_Configuration_Pragma;
5611 -- Now set Ada 95 mode
5613 Ada_Version := Ada_95;
5614 Ada_Version_Explicit := Ada_Version;
5616 ---------------------
5617 -- Ada_05/Ada_2005 --
5618 ---------------------
5621 -- pragma Ada_05 (LOCAL_NAME);
5624 -- pragma Ada_2005 (LOCAL_NAME):
5626 -- Note: these pragmas also have some specific processing in Par.Prag
5627 -- because we want to set the Ada 2005 version mode during parsing.
5629 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
5635 if Arg_Count = 1 then
5636 Check_Arg_Is_Local_Name (Arg1);
5637 E_Id := Get_Pragma_Arg (Arg1);
5639 if Etype (E_Id) = Any_Type then
5643 Set_Is_Ada_2005_Only (Entity (E_Id));
5646 Check_Arg_Count (0);
5648 -- For Ada_2005 we unconditionally enforce the documented
5649 -- configuration pragma placement, since we do not want to
5650 -- tolerate mixed modes in a unit involving Ada 2005. That
5651 -- would cause real difficulties for those cases where there
5652 -- are incompatibilities between Ada 95 and Ada 2005.
5654 Check_Valid_Configuration_Pragma;
5656 -- Now set appropriate Ada mode
5659 Ada_Version := Ada_2005;
5661 Ada_Version := Ada_Version_Default;
5664 Ada_Version_Explicit := Ada_2005;
5668 ---------------------
5669 -- Ada_12/Ada_2012 --
5670 ---------------------
5673 -- pragma Ada_12 (LOCAL_NAME);
5676 -- pragma Ada_2012 (LOCAL_NAME):
5678 -- Note: these pragmas also have some specific processing in Par.Prag
5679 -- because we want to set the Ada 2012 version mode during parsing.
5681 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
5687 if Arg_Count = 1 then
5688 Check_Arg_Is_Local_Name (Arg1);
5689 E_Id := Get_Pragma_Arg (Arg1);
5691 if Etype (E_Id) = Any_Type then
5695 Set_Is_Ada_2012_Only (Entity (E_Id));
5698 Check_Arg_Count (0);
5700 -- For Ada_2012 we unconditionally enforce the documented
5701 -- configuration pragma placement, since we do not want to
5702 -- tolerate mixed modes in a unit involving Ada 2012. That
5703 -- would cause real difficulties for those cases where there
5704 -- are incompatibilities between Ada 95 and Ada 2012. We could
5705 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
5707 Check_Valid_Configuration_Pragma;
5709 -- Now set appropriate Ada mode
5712 Ada_Version := Ada_2012;
5714 Ada_Version := Ada_Version_Default;
5717 Ada_Version_Explicit := Ada_2012;
5721 ----------------------
5722 -- All_Calls_Remote --
5723 ----------------------
5725 -- pragma All_Calls_Remote [(library_package_NAME)];
5727 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
5728 Lib_Entity : Entity_Id;
5731 Check_Ada_83_Warning;
5732 Check_Valid_Library_Unit_Pragma;
5734 if Nkind (N) = N_Null_Statement then
5738 Lib_Entity := Find_Lib_Unit_Name;
5740 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
5742 if Present (Lib_Entity)
5743 and then not Debug_Flag_U
5745 if not Is_Remote_Call_Interface (Lib_Entity) then
5746 Error_Pragma ("pragma% only apply to rci unit");
5748 -- Set flag for entity of the library unit
5751 Set_Has_All_Calls_Remote (Lib_Entity);
5755 end All_Calls_Remote;
5761 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
5762 -- ARG ::= NAME | EXPRESSION
5764 -- The first two arguments are by convention intended to refer to an
5765 -- external tool and a tool-specific function. These arguments are
5768 when Pragma_Annotate => Annotate : begin
5770 Check_At_Least_N_Arguments (1);
5771 Check_Arg_Is_Identifier (Arg1);
5772 Check_No_Identifiers;
5780 -- Second unanalyzed parameter is optional
5786 while Present (Arg) loop
5787 Exp := Get_Pragma_Arg (Arg);
5790 if Is_Entity_Name (Exp) then
5793 -- For string literals, we assume Standard_String as the
5794 -- type, unless the string contains wide or wide_wide
5797 elsif Nkind (Exp) = N_String_Literal then
5798 if Has_Wide_Wide_Character (Exp) then
5799 Resolve (Exp, Standard_Wide_Wide_String);
5800 elsif Has_Wide_Character (Exp) then
5801 Resolve (Exp, Standard_Wide_String);
5803 Resolve (Exp, Standard_String);
5806 elsif Is_Overloaded (Exp) then
5808 ("ambiguous argument for pragma%", Exp);
5824 -- pragma Assert ([Check =>] Boolean_EXPRESSION
5825 -- [, [Message =>] Static_String_EXPRESSION]);
5827 when Pragma_Assert => Assert : declare
5833 Check_At_Least_N_Arguments (1);
5834 Check_At_Most_N_Arguments (2);
5835 Check_Arg_Order ((Name_Check, Name_Message));
5836 Check_Optional_Identifier (Arg1, Name_Check);
5838 -- We treat pragma Assert as equivalent to:
5840 -- pragma Check (Assertion, condition [, msg]);
5842 -- So rewrite pragma in this manner, and analyze the result
5844 Expr := Get_Pragma_Arg (Arg1);
5846 Make_Pragma_Argument_Association (Loc,
5848 Make_Identifier (Loc,
5849 Chars => Name_Assertion)),
5851 Make_Pragma_Argument_Association (Sloc (Expr),
5852 Expression => Expr));
5854 if Arg_Count > 1 then
5855 Check_Optional_Identifier (Arg2, Name_Message);
5856 Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
5857 Append_To (Newa, Relocate_Node (Arg2));
5862 Chars => Name_Check,
5863 Pragma_Argument_Associations => Newa));
5867 ----------------------
5868 -- Assertion_Policy --
5869 ----------------------
5871 -- pragma Assertion_Policy (Check | Ignore)
5873 when Pragma_Assertion_Policy => Assertion_Policy : declare
5878 Check_Valid_Configuration_Pragma;
5879 Check_Arg_Count (1);
5880 Check_No_Identifiers;
5881 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
5883 -- We treat pragma Assertion_Policy as equivalent to:
5885 -- pragma Check_Policy (Assertion, policy)
5887 -- So rewrite the pragma in that manner and link on to the chain
5888 -- of Check_Policy pragmas, marking the pragma as analyzed.
5890 Policy := Get_Pragma_Arg (Arg1);
5894 Chars => Name_Check_Policy,
5896 Pragma_Argument_Associations => New_List (
5897 Make_Pragma_Argument_Association (Loc,
5899 Make_Identifier (Loc,
5900 Chars => Name_Assertion)),
5902 Make_Pragma_Argument_Association (Loc,
5904 Make_Identifier (Sloc (Policy),
5905 Chars => Chars (Policy))))));
5908 Set_Next_Pragma (N, Opt.Check_Policy_List);
5909 Opt.Check_Policy_List := N;
5910 end Assertion_Policy;
5912 ------------------------------
5913 -- Assume_No_Invalid_Values --
5914 ------------------------------
5916 -- pragma Assume_No_Invalid_Values (On | Off);
5918 when Pragma_Assume_No_Invalid_Values =>
5920 Check_Valid_Configuration_Pragma;
5921 Check_Arg_Count (1);
5922 Check_No_Identifiers;
5923 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
5925 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
5926 Assume_No_Invalid_Values := True;
5928 Assume_No_Invalid_Values := False;
5935 -- pragma AST_Entry (entry_IDENTIFIER);
5937 when Pragma_AST_Entry => AST_Entry : declare
5943 Check_Arg_Count (1);
5944 Check_No_Identifiers;
5945 Check_Arg_Is_Local_Name (Arg1);
5946 Ent := Entity (Get_Pragma_Arg (Arg1));
5948 -- Note: the implementation of the AST_Entry pragma could handle
5949 -- the entry family case fine, but for now we are consistent with
5950 -- the DEC rules, and do not allow the pragma, which of course
5951 -- has the effect of also forbidding the attribute.
5953 if Ekind (Ent) /= E_Entry then
5955 ("pragma% argument must be simple entry name", Arg1);
5957 elsif Is_AST_Entry (Ent) then
5959 ("duplicate % pragma for entry", Arg1);
5961 elsif Has_Homonym (Ent) then
5963 ("pragma% argument cannot specify overloaded entry", Arg1);
5967 FF : constant Entity_Id := First_Formal (Ent);
5970 if Present (FF) then
5971 if Present (Next_Formal (FF)) then
5973 ("entry for pragma% can have only one argument",
5976 elsif Parameter_Mode (FF) /= E_In_Parameter then
5978 ("entry parameter for pragma% must have mode IN",
5984 Set_Is_AST_Entry (Ent);
5992 -- pragma Asynchronous (LOCAL_NAME);
5994 when Pragma_Asynchronous => Asynchronous : declare
6002 procedure Process_Async_Pragma;
6003 -- Common processing for procedure and access-to-procedure case
6005 --------------------------
6006 -- Process_Async_Pragma --
6007 --------------------------
6009 procedure Process_Async_Pragma is
6012 Set_Is_Asynchronous (Nm);
6016 -- The formals should be of mode IN (RM E.4.1(6))
6019 while Present (S) loop
6020 Formal := Defining_Identifier (S);
6022 if Nkind (Formal) = N_Defining_Identifier
6023 and then Ekind (Formal) /= E_In_Parameter
6026 ("pragma% procedure can only have IN parameter",
6033 Set_Is_Asynchronous (Nm);
6034 end Process_Async_Pragma;
6036 -- Start of processing for pragma Asynchronous
6039 Check_Ada_83_Warning;
6040 Check_No_Identifiers;
6041 Check_Arg_Count (1);
6042 Check_Arg_Is_Local_Name (Arg1);
6044 if Debug_Flag_U then
6048 C_Ent := Cunit_Entity (Current_Sem_Unit);
6049 Analyze (Get_Pragma_Arg (Arg1));
6050 Nm := Entity (Get_Pragma_Arg (Arg1));
6052 if not Is_Remote_Call_Interface (C_Ent)
6053 and then not Is_Remote_Types (C_Ent)
6055 -- This pragma should only appear in an RCI or Remote Types
6056 -- unit (RM E.4.1(4)).
6059 ("pragma% not in Remote_Call_Interface or " &
6060 "Remote_Types unit");
6063 if Ekind (Nm) = E_Procedure
6064 and then Nkind (Parent (Nm)) = N_Procedure_Specification
6066 if not Is_Remote_Call_Interface (Nm) then
6068 ("pragma% cannot be applied on non-remote procedure",
6072 L := Parameter_Specifications (Parent (Nm));
6073 Process_Async_Pragma;
6076 elsif Ekind (Nm) = E_Function then
6078 ("pragma% cannot be applied to function", Arg1);
6080 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
6082 if Is_Record_Type (Nm) then
6084 -- A record type that is the Equivalent_Type for a remote
6085 -- access-to-subprogram type.
6087 N := Declaration_Node (Corresponding_Remote_Type (Nm));
6090 -- A non-expanded RAS type (distribution is not enabled)
6092 N := Declaration_Node (Nm);
6095 if Nkind (N) = N_Full_Type_Declaration
6096 and then Nkind (Type_Definition (N)) =
6097 N_Access_Procedure_Definition
6099 L := Parameter_Specifications (Type_Definition (N));
6100 Process_Async_Pragma;
6102 if Is_Asynchronous (Nm)
6103 and then Expander_Active
6104 and then Get_PCS_Name /= Name_No_DSA
6106 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
6111 ("pragma% cannot reference access-to-function type",
6115 -- Only other possibility is Access-to-class-wide type
6117 elsif Is_Access_Type (Nm)
6118 and then Is_Class_Wide_Type (Designated_Type (Nm))
6120 Check_First_Subtype (Arg1);
6121 Set_Is_Asynchronous (Nm);
6122 if Expander_Active then
6123 RACW_Type_Is_Asynchronous (Nm);
6127 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
6135 -- pragma Atomic (LOCAL_NAME);
6137 when Pragma_Atomic =>
6138 Process_Atomic_Shared_Volatile;
6140 -----------------------
6141 -- Atomic_Components --
6142 -----------------------
6144 -- pragma Atomic_Components (array_LOCAL_NAME);
6146 -- This processing is shared by Volatile_Components
6148 when Pragma_Atomic_Components |
6149 Pragma_Volatile_Components =>
6151 Atomic_Components : declare
6158 Check_Ada_83_Warning;
6159 Check_No_Identifiers;
6160 Check_Arg_Count (1);
6161 Check_Arg_Is_Local_Name (Arg1);
6162 E_Id := Get_Pragma_Arg (Arg1);
6164 if Etype (E_Id) = Any_Type then
6170 Check_Duplicate_Pragma (E);
6172 if Rep_Item_Too_Early (E, N)
6174 Rep_Item_Too_Late (E, N)
6179 D := Declaration_Node (E);
6182 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
6184 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
6185 and then Nkind (D) = N_Object_Declaration
6186 and then Nkind (Object_Definition (D)) =
6187 N_Constrained_Array_Definition)
6189 -- The flag is set on the object, or on the base type
6191 if Nkind (D) /= N_Object_Declaration then
6195 Set_Has_Volatile_Components (E, Sense);
6197 if Prag_Id = Pragma_Atomic_Components then
6198 Set_Has_Atomic_Components (E, Sense);
6202 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6204 end Atomic_Components;
6206 --------------------
6207 -- Attach_Handler --
6208 --------------------
6210 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
6212 when Pragma_Attach_Handler =>
6213 Check_Ada_83_Warning;
6214 Check_No_Identifiers;
6215 Check_Arg_Count (2);
6217 if No_Run_Time_Mode then
6218 Error_Msg_CRT ("Attach_Handler pragma", N);
6220 Check_Interrupt_Or_Attach_Handler;
6222 -- The expression that designates the attribute may depend on a
6223 -- discriminant, and is therefore a per- object expression, to
6224 -- be expanded in the init proc. If expansion is enabled, then
6225 -- perform semantic checks on a copy only.
6227 if Expander_Active then
6229 Temp : constant Node_Id :=
6230 New_Copy_Tree (Get_Pragma_Arg (Arg2));
6232 Set_Parent (Temp, N);
6233 Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
6237 Analyze (Get_Pragma_Arg (Arg2));
6238 Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
6241 Process_Interrupt_Or_Attach_Handler;
6244 --------------------
6245 -- C_Pass_By_Copy --
6246 --------------------
6248 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
6250 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
6256 Check_Valid_Configuration_Pragma;
6257 Check_Arg_Count (1);
6258 Check_Optional_Identifier (Arg1, "max_size");
6260 Arg := Get_Pragma_Arg (Arg1);
6261 Check_Arg_Is_Static_Expression (Arg, Any_Integer);
6263 Val := Expr_Value (Arg);
6267 ("maximum size for pragma% must be positive", Arg1);
6269 elsif UI_Is_In_Int_Range (Val) then
6270 Default_C_Record_Mechanism := UI_To_Int (Val);
6272 -- If a giant value is given, Int'Last will do well enough.
6273 -- If sometime someone complains that a record larger than
6274 -- two gigabytes is not copied, we will worry about it then!
6277 Default_C_Record_Mechanism := Mechanism_Type'Last;
6285 -- pragma Check ([Name =>] Identifier,
6286 -- [Check =>] Boolean_Expression
6287 -- [,[Message =>] String_Expression]);
6289 when Pragma_Check => Check : declare
6294 -- Set True if category of assertions referenced by Name enabled
6298 Check_At_Least_N_Arguments (2);
6299 Check_At_Most_N_Arguments (3);
6300 Check_Optional_Identifier (Arg1, Name_Name);
6301 Check_Optional_Identifier (Arg2, Name_Check);
6303 if Arg_Count = 3 then
6304 Check_Optional_Identifier (Arg3, Name_Message);
6305 Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String);
6308 Check_Arg_Is_Identifier (Arg1);
6310 -- Indicate if pragma is enabled. The Original_Node reference here
6311 -- is to deal with pragma Assert rewritten as a Check pragma.
6313 Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
6316 Set_Pragma_Enabled (N);
6317 Set_Pragma_Enabled (Original_Node (N));
6318 Set_SCO_Pragma_Enabled (Loc);
6321 -- If expansion is active and the check is not enabled then we
6322 -- rewrite the Check as:
6324 -- if False and then condition then
6328 -- The reason we do this rewriting during semantic analysis rather
6329 -- than as part of normal expansion is that we cannot analyze and
6330 -- expand the code for the boolean expression directly, or it may
6331 -- cause insertion of actions that would escape the attempt to
6332 -- suppress the check code.
6334 -- Note that the Sloc for the if statement corresponds to the
6335 -- argument condition, not the pragma itself. The reason for this
6336 -- is that we may generate a warning if the condition is False at
6337 -- compile time, and we do not want to delete this warning when we
6338 -- delete the if statement.
6340 Expr := Get_Pragma_Arg (Arg2);
6342 if Expander_Active and then not Check_On then
6343 Eloc := Sloc (Expr);
6346 Make_If_Statement (Eloc,
6348 Make_And_Then (Eloc,
6349 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
6350 Right_Opnd => Expr),
6351 Then_Statements => New_List (
6352 Make_Null_Statement (Eloc))));
6359 Analyze_And_Resolve (Expr, Any_Boolean);
6367 -- pragma Check_Name (check_IDENTIFIER);
6369 when Pragma_Check_Name =>
6370 Check_No_Identifiers;
6372 Check_Valid_Configuration_Pragma;
6373 Check_Arg_Count (1);
6374 Check_Arg_Is_Identifier (Arg1);
6377 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
6380 for J in Check_Names.First .. Check_Names.Last loop
6381 if Check_Names.Table (J) = Nam then
6386 Check_Names.Append (Nam);
6393 -- pragma Check_Policy (
6394 -- [Name =>] IDENTIFIER,
6395 -- [Policy =>] POLICY_IDENTIFIER);
6397 -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE
6399 -- Note: this is a configuration pragma, but it is allowed to appear
6402 when Pragma_Check_Policy =>
6404 Check_Arg_Count (2);
6405 Check_Optional_Identifier (Arg1, Name_Name);
6406 Check_Optional_Identifier (Arg2, Name_Policy);
6408 (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore);
6410 -- A Check_Policy pragma can appear either as a configuration
6411 -- pragma, or in a declarative part or a package spec (see RM
6412 -- 11.5(5) for rules for Suppress/Unsuppress which are also
6413 -- followed for Check_Policy).
6415 if not Is_Configuration_Pragma then
6416 Check_Is_In_Decl_Part_Or_Package_Spec;
6419 Set_Next_Pragma (N, Opt.Check_Policy_List);
6420 Opt.Check_Policy_List := N;
6422 ---------------------
6423 -- CIL_Constructor --
6424 ---------------------
6426 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
6428 -- Processing for this pragma is shared with Java_Constructor
6434 -- pragma Comment (static_string_EXPRESSION)
6436 -- Processing for pragma Comment shares the circuitry for pragma
6437 -- Ident. The only differences are that Ident enforces a limit of 31
6438 -- characters on its argument, and also enforces limitations on
6439 -- placement for DEC compatibility. Pragma Comment shares neither of
6440 -- these restrictions.
6446 -- pragma Common_Object (
6447 -- [Internal =>] LOCAL_NAME
6448 -- [, [External =>] EXTERNAL_SYMBOL]
6449 -- [, [Size =>] EXTERNAL_SYMBOL]);
6451 -- Processing for this pragma is shared with Psect_Object
6453 ------------------------
6454 -- Compile_Time_Error --
6455 ------------------------
6457 -- pragma Compile_Time_Error
6458 -- (boolean_EXPRESSION, static_string_EXPRESSION);
6460 when Pragma_Compile_Time_Error =>
6462 Process_Compile_Time_Warning_Or_Error;
6464 --------------------------
6465 -- Compile_Time_Warning --
6466 --------------------------
6468 -- pragma Compile_Time_Warning
6469 -- (boolean_EXPRESSION, static_string_EXPRESSION);
6471 when Pragma_Compile_Time_Warning =>
6473 Process_Compile_Time_Warning_Or_Error;
6479 when Pragma_Compiler_Unit =>
6481 Check_Arg_Count (0);
6482 Set_Is_Compiler_Unit (Get_Source_Unit (N));
6484 -----------------------------
6485 -- Complete_Representation --
6486 -----------------------------
6488 -- pragma Complete_Representation;
6490 when Pragma_Complete_Representation =>
6492 Check_Arg_Count (0);
6494 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
6496 ("pragma & must appear within record representation clause");
6499 ----------------------------
6500 -- Complex_Representation --
6501 ----------------------------
6503 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
6505 when Pragma_Complex_Representation => Complex_Representation : declare
6512 Check_Arg_Count (1);
6513 Check_Optional_Identifier (Arg1, Name_Entity);
6514 Check_Arg_Is_Local_Name (Arg1);
6515 E_Id := Get_Pragma_Arg (Arg1);
6517 if Etype (E_Id) = Any_Type then
6523 if not Is_Record_Type (E) then
6525 ("argument for pragma% must be record type", Arg1);
6528 Ent := First_Entity (E);
6531 or else No (Next_Entity (Ent))
6532 or else Present (Next_Entity (Next_Entity (Ent)))
6533 or else not Is_Floating_Point_Type (Etype (Ent))
6534 or else Etype (Ent) /= Etype (Next_Entity (Ent))
6537 ("record for pragma% must have two fields of the same "
6538 & "floating-point type", Arg1);
6541 Set_Has_Complex_Representation (Base_Type (E));
6543 -- We need to treat the type has having a non-standard
6544 -- representation, for back-end purposes, even though in
6545 -- general a complex will have the default representation
6546 -- of a record with two real components.
6548 Set_Has_Non_Standard_Rep (Base_Type (E));
6550 end Complex_Representation;
6552 -------------------------
6553 -- Component_Alignment --
6554 -------------------------
6556 -- pragma Component_Alignment (
6557 -- [Form =>] ALIGNMENT_CHOICE
6558 -- [, [Name =>] type_LOCAL_NAME]);
6560 -- ALIGNMENT_CHOICE ::=
6562 -- | Component_Size_4
6566 when Pragma_Component_Alignment => Component_AlignmentP : declare
6567 Args : Args_List (1 .. 2);
6568 Names : constant Name_List (1 .. 2) := (
6572 Form : Node_Id renames Args (1);
6573 Name : Node_Id renames Args (2);
6575 Atype : Component_Alignment_Kind;
6580 Gather_Associations (Names, Args);
6583 Error_Pragma ("missing Form argument for pragma%");
6586 Check_Arg_Is_Identifier (Form);
6588 -- Get proper alignment, note that Default = Component_Size on all
6589 -- machines we have so far, and we want to set this value rather
6590 -- than the default value to indicate that it has been explicitly
6591 -- set (and thus will not get overridden by the default component
6592 -- alignment for the current scope)
6594 if Chars (Form) = Name_Component_Size then
6595 Atype := Calign_Component_Size;
6597 elsif Chars (Form) = Name_Component_Size_4 then
6598 Atype := Calign_Component_Size_4;
6600 elsif Chars (Form) = Name_Default then
6601 Atype := Calign_Component_Size;
6603 elsif Chars (Form) = Name_Storage_Unit then
6604 Atype := Calign_Storage_Unit;
6608 ("invalid Form parameter for pragma%", Form);
6611 -- Case with no name, supplied, affects scope table entry
6615 (Scope_Stack.Last).Component_Alignment_Default := Atype;
6617 -- Case of name supplied
6620 Check_Arg_Is_Local_Name (Name);
6622 Typ := Entity (Name);
6625 or else Rep_Item_Too_Early (Typ, N)
6629 Typ := Underlying_Type (Typ);
6632 if not Is_Record_Type (Typ)
6633 and then not Is_Array_Type (Typ)
6636 ("Name parameter of pragma% must identify record or " &
6637 "array type", Name);
6640 -- An explicit Component_Alignment pragma overrides an
6641 -- implicit pragma Pack, but not an explicit one.
6643 if not Has_Pragma_Pack (Base_Type (Typ)) then
6644 Set_Is_Packed (Base_Type (Typ), False);
6645 Set_Component_Alignment (Base_Type (Typ), Atype);
6648 end Component_AlignmentP;
6654 -- pragma Controlled (first_subtype_LOCAL_NAME);
6656 when Pragma_Controlled => Controlled : declare
6660 Check_No_Identifiers;
6661 Check_Arg_Count (1);
6662 Check_Arg_Is_Local_Name (Arg1);
6663 Arg := Get_Pragma_Arg (Arg1);
6665 if not Is_Entity_Name (Arg)
6666 or else not Is_Access_Type (Entity (Arg))
6668 Error_Pragma_Arg ("pragma% requires access type", Arg1);
6670 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
6678 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
6679 -- [Entity =>] LOCAL_NAME);
6681 when Pragma_Convention => Convention : declare
6684 pragma Warnings (Off, C);
6685 pragma Warnings (Off, E);
6687 Check_Arg_Order ((Name_Convention, Name_Entity));
6688 Check_Ada_83_Warning;
6689 Check_Arg_Count (2);
6690 Process_Convention (C, E);
6693 ---------------------------
6694 -- Convention_Identifier --
6695 ---------------------------
6697 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
6698 -- [Convention =>] convention_IDENTIFIER);
6700 when Pragma_Convention_Identifier => Convention_Identifier : declare
6706 Check_Arg_Order ((Name_Name, Name_Convention));
6707 Check_Arg_Count (2);
6708 Check_Optional_Identifier (Arg1, Name_Name);
6709 Check_Optional_Identifier (Arg2, Name_Convention);
6710 Check_Arg_Is_Identifier (Arg1);
6711 Check_Arg_Is_Identifier (Arg2);
6712 Idnam := Chars (Get_Pragma_Arg (Arg1));
6713 Cname := Chars (Get_Pragma_Arg (Arg2));
6715 if Is_Convention_Name (Cname) then
6716 Record_Convention_Identifier
6717 (Idnam, Get_Convention_Id (Cname));
6720 ("second arg for % pragma must be convention", Arg2);
6722 end Convention_Identifier;
6728 -- pragma CPP_Class ([Entity =>] local_NAME)
6730 when Pragma_CPP_Class => CPP_Class : declare
6735 if Warn_On_Obsolescent_Feature then
6737 ("'G'N'A'T pragma cpp'_class is now obsolete; replace it" &
6738 " by pragma import?", N);
6742 Check_Arg_Count (1);
6743 Check_Optional_Identifier (Arg1, Name_Entity);
6744 Check_Arg_Is_Local_Name (Arg1);
6746 Arg := Get_Pragma_Arg (Arg1);
6749 if Etype (Arg) = Any_Type then
6753 if not Is_Entity_Name (Arg)
6754 or else not Is_Type (Entity (Arg))
6756 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
6759 Typ := Entity (Arg);
6761 if not Is_Tagged_Type (Typ) then
6762 Error_Pragma_Arg ("pragma% applicable to tagged types ", Arg1);
6765 -- Types treated as CPP classes are treated as limited, but we
6766 -- don't require them to be declared this way. A warning is issued
6767 -- to encourage the user to declare them as limited. This is not
6768 -- an error, for compatibility reasons, because these types have
6769 -- been supported this way for some time.
6771 if not Is_Limited_Type (Typ) then
6773 ("imported 'C'P'P type should be " &
6774 "explicitly declared limited?",
6775 Get_Pragma_Arg (Arg1));
6777 ("\type will be considered limited",
6778 Get_Pragma_Arg (Arg1));
6781 Set_Is_CPP_Class (Typ);
6782 Set_Is_Limited_Record (Typ);
6783 Set_Convention (Typ, Convention_CPP);
6785 -- Imported CPP types must not have discriminants (because C++
6786 -- classes do not have discriminants).
6788 if Has_Discriminants (Typ) then
6790 ("imported 'C'P'P type cannot have discriminants",
6791 First (Discriminant_Specifications
6792 (Declaration_Node (Typ))));
6795 -- Components of imported CPP types must not have default
6796 -- expressions because the constructor (if any) is in the
6799 if Is_Incomplete_Or_Private_Type (Typ)
6800 and then No (Underlying_Type (Typ))
6802 -- It should be an error to apply pragma CPP to a private
6803 -- type if the underlying type is not visible (as it is
6804 -- for any representation item). For now, for backward
6805 -- compatibility we do nothing but we cannot check components
6806 -- because they are not available at this stage. All this code
6807 -- will be removed when we cleanup this obsolete GNAT pragma???
6813 Tdef : constant Node_Id :=
6814 Type_Definition (Declaration_Node (Typ));
6819 if Nkind (Tdef) = N_Record_Definition then
6820 Clist := Component_List (Tdef);
6822 pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
6823 Clist := Component_List (Record_Extension_Part (Tdef));
6826 if Present (Clist) then
6827 Comp := First (Component_Items (Clist));
6828 while Present (Comp) loop
6829 if Present (Expression (Comp)) then
6831 ("component of imported 'C'P'P type cannot have" &
6832 " default expression", Expression (Comp));
6842 ---------------------
6843 -- CPP_Constructor --
6844 ---------------------
6846 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
6847 -- [, [External_Name =>] static_string_EXPRESSION ]
6848 -- [, [Link_Name =>] static_string_EXPRESSION ]);
6850 when Pragma_CPP_Constructor => CPP_Constructor : declare
6854 Tag_Typ : Entity_Id;
6858 Check_At_Least_N_Arguments (1);
6859 Check_At_Most_N_Arguments (3);
6860 Check_Optional_Identifier (Arg1, Name_Entity);
6861 Check_Arg_Is_Local_Name (Arg1);
6863 Id := Get_Pragma_Arg (Arg1);
6864 Find_Program_Unit_Name (Id);
6866 -- If we did not find the name, we are done
6868 if Etype (Id) = Any_Type then
6872 Def_Id := Entity (Id);
6874 -- Check if already defined as constructor
6876 if Is_Constructor (Def_Id) then
6878 ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1);
6882 if Ekind (Def_Id) = E_Function
6883 and then (Is_CPP_Class (Etype (Def_Id))
6884 or else (Is_Class_Wide_Type (Etype (Def_Id))
6886 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
6888 if Arg_Count >= 2 then
6889 Set_Imported (Def_Id);
6890 Set_Is_Public (Def_Id);
6891 Process_Interface_Name (Def_Id, Arg2, Arg3);
6894 Set_Has_Completion (Def_Id);
6895 Set_Is_Constructor (Def_Id);
6897 -- Imported C++ constructors are not dispatching primitives
6898 -- because in C++ they don't have a dispatch table slot.
6899 -- However, in Ada the constructor has the profile of a
6900 -- function that returns a tagged type and therefore it has
6901 -- been treated as a primitive operation during semantic
6902 -- analysis. We now remove it from the list of primitive
6903 -- operations of the type.
6905 if Is_Tagged_Type (Etype (Def_Id))
6906 and then not Is_Class_Wide_Type (Etype (Def_Id))
6908 pragma Assert (Is_Dispatching_Operation (Def_Id));
6909 Tag_Typ := Etype (Def_Id);
6911 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
6912 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
6916 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
6917 Set_Is_Dispatching_Operation (Def_Id, False);
6920 -- For backward compatibility, if the constructor returns a
6921 -- class wide type, and we internally change the return type to
6922 -- the corresponding root type.
6924 if Is_Class_Wide_Type (Etype (Def_Id)) then
6925 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
6929 ("pragma% requires function returning a 'C'P'P_Class type",
6932 end CPP_Constructor;
6938 when Pragma_CPP_Virtual => CPP_Virtual : declare
6942 if Warn_On_Obsolescent_Feature then
6944 ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " &
6953 when Pragma_CPP_Vtable => CPP_Vtable : declare
6957 if Warn_On_Obsolescent_Feature then
6959 ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
6968 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
6970 when Pragma_Debug => Debug : declare
6978 (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active),
6981 if Arg_Count = 2 then
6984 Left_Opnd => Relocate_Node (Cond),
6985 Right_Opnd => Get_Pragma_Arg (Arg1));
6988 -- Rewrite into a conditional with an appropriate condition. We
6989 -- wrap the procedure call in a block so that overhead from e.g.
6990 -- use of the secondary stack does not generate execution overhead
6991 -- for suppressed conditions.
6993 Rewrite (N, Make_Implicit_If_Statement (N,
6995 Then_Statements => New_List (
6996 Make_Block_Statement (Loc,
6997 Handled_Statement_Sequence =>
6998 Make_Handled_Sequence_Of_Statements (Loc,
6999 Statements => New_List (
7000 Relocate_Node (Debug_Statement (N))))))));
7008 -- pragma Debug_Policy (Check | Ignore)
7010 when Pragma_Debug_Policy =>
7012 Check_Arg_Count (1);
7013 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
7014 Debug_Pragmas_Enabled :=
7015 Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
7017 ---------------------
7018 -- Detect_Blocking --
7019 ---------------------
7021 -- pragma Detect_Blocking;
7023 when Pragma_Detect_Blocking =>
7025 Check_Arg_Count (0);
7026 Check_Valid_Configuration_Pragma;
7027 Detect_Blocking := True;
7033 when Pragma_Dimension =>
7035 Check_Arg_Count (4);
7036 Check_No_Identifiers;
7037 Check_Arg_Is_Local_Name (Arg1);
7039 if not Is_Type (Arg1) then
7040 Error_Pragma ("first argument for pragma% must be subtype");
7043 Check_Arg_Is_Static_Expression (Arg2, Standard_Integer);
7044 Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
7045 Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
7051 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
7053 when Pragma_Discard_Names => Discard_Names : declare
7058 Check_Ada_83_Warning;
7060 -- Deal with configuration pragma case
7062 if Arg_Count = 0 and then Is_Configuration_Pragma then
7063 Global_Discard_Names := True;
7066 -- Otherwise, check correct appropriate context
7069 Check_Is_In_Decl_Part_Or_Package_Spec;
7071 if Arg_Count = 0 then
7073 -- If there is no parameter, then from now on this pragma
7074 -- applies to any enumeration, exception or tagged type
7075 -- defined in the current declarative part, and recursively
7076 -- to any nested scope.
7078 Set_Discard_Names (Current_Scope, Sense);
7082 Check_Arg_Count (1);
7083 Check_Optional_Identifier (Arg1, Name_On);
7084 Check_Arg_Is_Local_Name (Arg1);
7086 E_Id := Get_Pragma_Arg (Arg1);
7088 if Etype (E_Id) = Any_Type then
7094 if (Is_First_Subtype (E)
7096 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
7097 or else Ekind (E) = E_Exception
7099 Set_Discard_Names (E, Sense);
7102 ("inappropriate entity for pragma%", Arg1);
7113 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
7115 when Pragma_Elaborate => Elaborate : declare
7120 -- Pragma must be in context items list of a compilation unit
7122 if not Is_In_Context_Clause then
7126 -- Must be at least one argument
7128 if Arg_Count = 0 then
7129 Error_Pragma ("pragma% requires at least one argument");
7132 -- In Ada 83 mode, there can be no items following it in the
7133 -- context list except other pragmas and implicit with clauses
7134 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
7135 -- placement rule does not apply.
7137 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
7139 while Present (Citem) loop
7140 if Nkind (Citem) = N_Pragma
7141 or else (Nkind (Citem) = N_With_Clause
7142 and then Implicit_With (Citem))
7147 ("(Ada 83) pragma% must be at end of context clause");
7154 -- Finally, the arguments must all be units mentioned in a with
7155 -- clause in the same context clause. Note we already checked (in
7156 -- Par.Prag) that the arguments are all identifiers or selected
7160 Outer : while Present (Arg) loop
7161 Citem := First (List_Containing (N));
7162 Inner : while Citem /= N loop
7163 if Nkind (Citem) = N_With_Clause
7164 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
7166 Set_Elaborate_Present (Citem, True);
7167 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
7169 -- With the pragma present, elaboration calls on
7170 -- subprograms from the named unit need no further
7171 -- checks, as long as the pragma appears in the current
7172 -- compilation unit. If the pragma appears in some unit
7173 -- in the context, there might still be a need for an
7174 -- Elaborate_All_Desirable from the current compilation
7175 -- to the named unit, so we keep the check enabled.
7177 if In_Extended_Main_Source_Unit (N) then
7178 Set_Suppress_Elaboration_Warnings
7179 (Entity (Name (Citem)));
7190 ("argument of pragma% is not with'ed unit", Arg);
7196 -- Give a warning if operating in static mode with -gnatwl
7197 -- (elaboration warnings enabled) switch set.
7199 if Elab_Warnings and not Dynamic_Elaboration_Checks then
7201 ("?use of pragma Elaborate may not be safe", N);
7203 ("?use pragma Elaborate_All instead if possible", N);
7211 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
7213 when Pragma_Elaborate_All => Elaborate_All : declare
7218 Check_Ada_83_Warning;
7220 -- Pragma must be in context items list of a compilation unit
7222 if not Is_In_Context_Clause then
7226 -- Must be at least one argument
7228 if Arg_Count = 0 then
7229 Error_Pragma ("pragma% requires at least one argument");
7232 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
7233 -- have to appear at the end of the context clause, but may
7234 -- appear mixed in with other items, even in Ada 83 mode.
7236 -- Final check: the arguments must all be units mentioned in
7237 -- a with clause in the same context clause. Note that we
7238 -- already checked (in Par.Prag) that all the arguments are
7239 -- either identifiers or selected components.
7242 Outr : while Present (Arg) loop
7243 Citem := First (List_Containing (N));
7244 Innr : while Citem /= N loop
7245 if Nkind (Citem) = N_With_Clause
7246 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
7248 Set_Elaborate_All_Present (Citem, True);
7249 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
7251 -- Suppress warnings and elaboration checks on the named
7252 -- unit if the pragma is in the current compilation, as
7253 -- for pragma Elaborate.
7255 if In_Extended_Main_Source_Unit (N) then
7256 Set_Suppress_Elaboration_Warnings
7257 (Entity (Name (Citem)));
7266 Set_Error_Posted (N);
7268 ("argument of pragma% is not with'ed unit", Arg);
7275 --------------------
7276 -- Elaborate_Body --
7277 --------------------
7279 -- pragma Elaborate_Body [( library_unit_NAME )];
7281 when Pragma_Elaborate_Body => Elaborate_Body : declare
7282 Cunit_Node : Node_Id;
7283 Cunit_Ent : Entity_Id;
7286 Check_Ada_83_Warning;
7287 Check_Valid_Library_Unit_Pragma;
7289 if Nkind (N) = N_Null_Statement then
7293 Cunit_Node := Cunit (Current_Sem_Unit);
7294 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
7296 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
7299 Error_Pragma ("pragma% must refer to a spec, not a body");
7301 Set_Body_Required (Cunit_Node, True);
7302 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
7304 -- If we are in dynamic elaboration mode, then we suppress
7305 -- elaboration warnings for the unit, since it is definitely
7306 -- fine NOT to do dynamic checks at the first level (and such
7307 -- checks will be suppressed because no elaboration boolean
7308 -- is created for Elaborate_Body packages).
7310 -- But in the static model of elaboration, Elaborate_Body is
7311 -- definitely NOT good enough to ensure elaboration safety on
7312 -- its own, since the body may WITH other units that are not
7313 -- safe from an elaboration point of view, so a client must
7314 -- still do an Elaborate_All on such units.
7316 -- Debug flag -gnatdD restores the old behavior of 3.13, where
7317 -- Elaborate_Body always suppressed elab warnings.
7319 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
7320 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
7325 ------------------------
7326 -- Elaboration_Checks --
7327 ------------------------
7329 -- pragma Elaboration_Checks (Static | Dynamic);
7331 when Pragma_Elaboration_Checks =>
7333 Check_Arg_Count (1);
7334 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
7335 Dynamic_Elaboration_Checks :=
7336 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
7342 -- pragma Eliminate (
7343 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
7344 -- [,[Entity =>] IDENTIFIER |
7345 -- SELECTED_COMPONENT |
7347 -- [, OVERLOADING_RESOLUTION]);
7349 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
7352 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
7355 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
7357 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
7358 -- Result_Type => result_SUBTYPE_NAME]
7360 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
7361 -- SUBTYPE_NAME ::= STRING_LITERAL
7363 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
7364 -- SOURCE_TRACE ::= STRING_LITERAL
7366 when Pragma_Eliminate => Eliminate : declare
7367 Args : Args_List (1 .. 5);
7368 Names : constant Name_List (1 .. 5) := (
7371 Name_Parameter_Types,
7373 Name_Source_Location);
7375 Unit_Name : Node_Id renames Args (1);
7376 Entity : Node_Id renames Args (2);
7377 Parameter_Types : Node_Id renames Args (3);
7378 Result_Type : Node_Id renames Args (4);
7379 Source_Location : Node_Id renames Args (5);
7383 Check_Valid_Configuration_Pragma;
7384 Gather_Associations (Names, Args);
7386 if No (Unit_Name) then
7387 Error_Pragma ("missing Unit_Name argument for pragma%");
7391 and then (Present (Parameter_Types)
7393 Present (Result_Type)
7395 Present (Source_Location))
7397 Error_Pragma ("missing Entity argument for pragma%");
7400 if (Present (Parameter_Types)
7402 Present (Result_Type))
7404 Present (Source_Location)
7407 ("parameter profile and source location cannot " &
7408 "be used together in pragma%");
7411 Process_Eliminate_Pragma
7425 -- [ Convention =>] convention_IDENTIFIER,
7426 -- [ Entity =>] local_NAME
7427 -- [, [External_Name =>] static_string_EXPRESSION ]
7428 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7430 when Pragma_Export => Export : declare
7434 pragma Warnings (Off, C);
7437 Check_Ada_83_Warning;
7443 Check_At_Least_N_Arguments (2);
7444 Check_At_Most_N_Arguments (4);
7445 Process_Convention (C, Def_Id);
7447 if Ekind (Def_Id) /= E_Constant then
7448 Note_Possible_Modification
7449 (Get_Pragma_Arg (Arg2), Sure => False);
7452 Process_Interface_Name (Def_Id, Arg3, Arg4);
7453 Set_Exported (Def_Id, Arg2);
7455 -- If the entity is a deferred constant, propagate the information
7456 -- to the full view, because gigi elaborates the full view only.
7458 if Ekind (Def_Id) = E_Constant
7459 and then Present (Full_View (Def_Id))
7462 Id2 : constant Entity_Id := Full_View (Def_Id);
7464 Set_Is_Exported (Id2, Is_Exported (Def_Id));
7465 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
7466 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
7471 ----------------------
7472 -- Export_Exception --
7473 ----------------------
7475 -- pragma Export_Exception (
7476 -- [Internal =>] LOCAL_NAME
7477 -- [, [External =>] EXTERNAL_SYMBOL]
7478 -- [, [Form =>] Ada | VMS]
7479 -- [, [Code =>] static_integer_EXPRESSION]);
7481 when Pragma_Export_Exception => Export_Exception : declare
7482 Args : Args_List (1 .. 4);
7483 Names : constant Name_List (1 .. 4) := (
7489 Internal : Node_Id renames Args (1);
7490 External : Node_Id renames Args (2);
7491 Form : Node_Id renames Args (3);
7492 Code : Node_Id renames Args (4);
7497 if Inside_A_Generic then
7498 Error_Pragma ("pragma% cannot be used for generic entities");
7501 Gather_Associations (Names, Args);
7502 Process_Extended_Import_Export_Exception_Pragma (
7503 Arg_Internal => Internal,
7504 Arg_External => External,
7508 if not Is_VMS_Exception (Entity (Internal)) then
7509 Set_Exported (Entity (Internal), Internal);
7511 end Export_Exception;
7513 ---------------------
7514 -- Export_Function --
7515 ---------------------
7517 -- pragma Export_Function (
7518 -- [Internal =>] LOCAL_NAME
7519 -- [, [External =>] EXTERNAL_SYMBOL]
7520 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7521 -- [, [Result_Type =>] TYPE_DESIGNATOR]
7522 -- [, [Mechanism =>] MECHANISM]
7523 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
7525 -- EXTERNAL_SYMBOL ::=
7527 -- | static_string_EXPRESSION
7529 -- PARAMETER_TYPES ::=
7531 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7533 -- TYPE_DESIGNATOR ::=
7535 -- | subtype_Name ' Access
7539 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7541 -- MECHANISM_ASSOCIATION ::=
7542 -- [formal_parameter_NAME =>] MECHANISM_NAME
7544 -- MECHANISM_NAME ::=
7547 -- | Descriptor [([Class =>] CLASS_NAME)]
7549 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7551 when Pragma_Export_Function => Export_Function : declare
7552 Args : Args_List (1 .. 6);
7553 Names : constant Name_List (1 .. 6) := (
7556 Name_Parameter_Types,
7559 Name_Result_Mechanism);
7561 Internal : Node_Id renames Args (1);
7562 External : Node_Id renames Args (2);
7563 Parameter_Types : Node_Id renames Args (3);
7564 Result_Type : Node_Id renames Args (4);
7565 Mechanism : Node_Id renames Args (5);
7566 Result_Mechanism : Node_Id renames Args (6);
7570 Gather_Associations (Names, Args);
7571 Process_Extended_Import_Export_Subprogram_Pragma (
7572 Arg_Internal => Internal,
7573 Arg_External => External,
7574 Arg_Parameter_Types => Parameter_Types,
7575 Arg_Result_Type => Result_Type,
7576 Arg_Mechanism => Mechanism,
7577 Arg_Result_Mechanism => Result_Mechanism);
7578 end Export_Function;
7584 -- pragma Export_Object (
7585 -- [Internal =>] LOCAL_NAME
7586 -- [, [External =>] EXTERNAL_SYMBOL]
7587 -- [, [Size =>] EXTERNAL_SYMBOL]);
7589 -- EXTERNAL_SYMBOL ::=
7591 -- | static_string_EXPRESSION
7593 -- PARAMETER_TYPES ::=
7595 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7597 -- TYPE_DESIGNATOR ::=
7599 -- | subtype_Name ' Access
7603 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7605 -- MECHANISM_ASSOCIATION ::=
7606 -- [formal_parameter_NAME =>] MECHANISM_NAME
7608 -- MECHANISM_NAME ::=
7611 -- | Descriptor [([Class =>] CLASS_NAME)]
7613 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7615 when Pragma_Export_Object => Export_Object : declare
7616 Args : Args_List (1 .. 3);
7617 Names : constant Name_List (1 .. 3) := (
7622 Internal : Node_Id renames Args (1);
7623 External : Node_Id renames Args (2);
7624 Size : Node_Id renames Args (3);
7628 Gather_Associations (Names, Args);
7629 Process_Extended_Import_Export_Object_Pragma (
7630 Arg_Internal => Internal,
7631 Arg_External => External,
7635 ----------------------
7636 -- Export_Procedure --
7637 ----------------------
7639 -- pragma Export_Procedure (
7640 -- [Internal =>] LOCAL_NAME
7641 -- [, [External =>] EXTERNAL_SYMBOL]
7642 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7643 -- [, [Mechanism =>] MECHANISM]);
7645 -- EXTERNAL_SYMBOL ::=
7647 -- | static_string_EXPRESSION
7649 -- PARAMETER_TYPES ::=
7651 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7653 -- TYPE_DESIGNATOR ::=
7655 -- | subtype_Name ' Access
7659 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7661 -- MECHANISM_ASSOCIATION ::=
7662 -- [formal_parameter_NAME =>] MECHANISM_NAME
7664 -- MECHANISM_NAME ::=
7667 -- | Descriptor [([Class =>] CLASS_NAME)]
7669 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7671 when Pragma_Export_Procedure => Export_Procedure : declare
7672 Args : Args_List (1 .. 4);
7673 Names : constant Name_List (1 .. 4) := (
7676 Name_Parameter_Types,
7679 Internal : Node_Id renames Args (1);
7680 External : Node_Id renames Args (2);
7681 Parameter_Types : Node_Id renames Args (3);
7682 Mechanism : Node_Id renames Args (4);
7686 Gather_Associations (Names, Args);
7687 Process_Extended_Import_Export_Subprogram_Pragma (
7688 Arg_Internal => Internal,
7689 Arg_External => External,
7690 Arg_Parameter_Types => Parameter_Types,
7691 Arg_Mechanism => Mechanism);
7692 end Export_Procedure;
7698 -- pragma Export_Value (
7699 -- [Value =>] static_integer_EXPRESSION,
7700 -- [Link_Name =>] static_string_EXPRESSION);
7702 when Pragma_Export_Value =>
7704 Check_Arg_Order ((Name_Value, Name_Link_Name));
7705 Check_Arg_Count (2);
7707 Check_Optional_Identifier (Arg1, Name_Value);
7708 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
7710 Check_Optional_Identifier (Arg2, Name_Link_Name);
7711 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
7713 -----------------------------
7714 -- Export_Valued_Procedure --
7715 -----------------------------
7717 -- pragma Export_Valued_Procedure (
7718 -- [Internal =>] LOCAL_NAME
7719 -- [, [External =>] EXTERNAL_SYMBOL,]
7720 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7721 -- [, [Mechanism =>] MECHANISM]);
7723 -- EXTERNAL_SYMBOL ::=
7725 -- | static_string_EXPRESSION
7727 -- PARAMETER_TYPES ::=
7729 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7731 -- TYPE_DESIGNATOR ::=
7733 -- | subtype_Name ' Access
7737 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7739 -- MECHANISM_ASSOCIATION ::=
7740 -- [formal_parameter_NAME =>] MECHANISM_NAME
7742 -- MECHANISM_NAME ::=
7745 -- | Descriptor [([Class =>] CLASS_NAME)]
7747 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7749 when Pragma_Export_Valued_Procedure =>
7750 Export_Valued_Procedure : declare
7751 Args : Args_List (1 .. 4);
7752 Names : constant Name_List (1 .. 4) := (
7755 Name_Parameter_Types,
7758 Internal : Node_Id renames Args (1);
7759 External : Node_Id renames Args (2);
7760 Parameter_Types : Node_Id renames Args (3);
7761 Mechanism : Node_Id renames Args (4);
7765 Gather_Associations (Names, Args);
7766 Process_Extended_Import_Export_Subprogram_Pragma (
7767 Arg_Internal => Internal,
7768 Arg_External => External,
7769 Arg_Parameter_Types => Parameter_Types,
7770 Arg_Mechanism => Mechanism);
7771 end Export_Valued_Procedure;
7777 -- pragma Extend_System ([Name =>] Identifier);
7779 when Pragma_Extend_System => Extend_System : declare
7782 Check_Valid_Configuration_Pragma;
7783 Check_Arg_Count (1);
7784 Check_Optional_Identifier (Arg1, Name_Name);
7785 Check_Arg_Is_Identifier (Arg1);
7787 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
7790 and then Name_Buffer (1 .. 4) = "aux_"
7792 if Present (System_Extend_Pragma_Arg) then
7793 if Chars (Get_Pragma_Arg (Arg1)) =
7794 Chars (Expression (System_Extend_Pragma_Arg))
7798 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
7799 Error_Pragma ("pragma% conflicts with that #");
7803 System_Extend_Pragma_Arg := Arg1;
7805 if not GNAT_Mode then
7806 System_Extend_Unit := Arg1;
7810 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
7814 ------------------------
7815 -- Extensions_Allowed --
7816 ------------------------
7818 -- pragma Extensions_Allowed (ON | OFF);
7820 when Pragma_Extensions_Allowed =>
7822 Check_Arg_Count (1);
7823 Check_No_Identifiers;
7824 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
7826 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
7827 Extensions_Allowed := True;
7828 Ada_Version := Ada_Version_Type'Last;
7831 Extensions_Allowed := False;
7832 Ada_Version := Ada_Version_Explicit;
7839 -- pragma External (
7840 -- [ Convention =>] convention_IDENTIFIER,
7841 -- [ Entity =>] local_NAME
7842 -- [, [External_Name =>] static_string_EXPRESSION ]
7843 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7845 when Pragma_External => External : declare
7849 pragma Warnings (Off, C);
7858 Check_At_Least_N_Arguments (2);
7859 Check_At_Most_N_Arguments (4);
7860 Process_Convention (C, Def_Id);
7861 Note_Possible_Modification
7862 (Get_Pragma_Arg (Arg2), Sure => False);
7863 Process_Interface_Name (Def_Id, Arg3, Arg4);
7864 Set_Exported (Def_Id, Arg2);
7867 --------------------------
7868 -- External_Name_Casing --
7869 --------------------------
7871 -- pragma External_Name_Casing (
7872 -- UPPERCASE | LOWERCASE
7873 -- [, AS_IS | UPPERCASE | LOWERCASE]);
7875 when Pragma_External_Name_Casing => External_Name_Casing : declare
7878 Check_No_Identifiers;
7880 if Arg_Count = 2 then
7882 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
7884 case Chars (Get_Pragma_Arg (Arg2)) is
7886 Opt.External_Name_Exp_Casing := As_Is;
7888 when Name_Uppercase =>
7889 Opt.External_Name_Exp_Casing := Uppercase;
7891 when Name_Lowercase =>
7892 Opt.External_Name_Exp_Casing := Lowercase;
7899 Check_Arg_Count (1);
7902 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
7904 case Chars (Get_Pragma_Arg (Arg1)) is
7905 when Name_Uppercase =>
7906 Opt.External_Name_Imp_Casing := Uppercase;
7908 when Name_Lowercase =>
7909 Opt.External_Name_Imp_Casing := Lowercase;
7914 end External_Name_Casing;
7916 --------------------------
7917 -- Favor_Top_Level --
7918 --------------------------
7920 -- pragma Favor_Top_Level (type_NAME);
7922 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
7923 Named_Entity : Entity_Id;
7927 Check_No_Identifiers;
7928 Check_Arg_Count (1);
7929 Check_Arg_Is_Local_Name (Arg1);
7930 Named_Entity := Entity (Get_Pragma_Arg (Arg1));
7932 -- If it's an access-to-subprogram type (in particular, not a
7933 -- subtype), set the flag on that type.
7935 if Is_Access_Subprogram_Type (Named_Entity) then
7937 Set_Can_Use_Internal_Rep (Named_Entity, False);
7940 -- Otherwise it's an error (name denotes the wrong sort of entity)
7944 ("access-to-subprogram type expected",
7945 Get_Pragma_Arg (Arg1));
7947 end Favor_Top_Level;
7953 -- pragma Fast_Math;
7955 when Pragma_Fast_Math =>
7957 Check_No_Identifiers;
7958 Check_Valid_Configuration_Pragma;
7961 ---------------------------
7962 -- Finalize_Storage_Only --
7963 ---------------------------
7965 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
7967 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
7968 Assoc : constant Node_Id := Arg1;
7969 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
7974 Check_No_Identifiers;
7975 Check_Arg_Count (1);
7976 Check_Arg_Is_Local_Name (Arg1);
7978 Find_Type (Type_Id);
7979 Typ := Entity (Type_Id);
7982 or else Rep_Item_Too_Early (Typ, N)
7986 Typ := Underlying_Type (Typ);
7989 if not Is_Controlled (Typ) then
7990 Error_Pragma ("pragma% must specify controlled type");
7993 Check_First_Subtype (Arg1);
7995 if Finalize_Storage_Only (Typ) then
7996 Error_Pragma ("duplicate pragma%, only one allowed");
7998 elsif not Rep_Item_Too_Late (Typ, N) then
7999 Set_Finalize_Storage_Only (Base_Type (Typ), True);
8001 end Finalize_Storage;
8003 --------------------------
8004 -- Float_Representation --
8005 --------------------------
8007 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
8009 -- FLOAT_REP ::= VAX_Float | IEEE_Float
8011 when Pragma_Float_Representation => Float_Representation : declare
8019 if Arg_Count = 1 then
8020 Check_Valid_Configuration_Pragma;
8022 Check_Arg_Count (2);
8023 Check_Optional_Identifier (Arg2, Name_Entity);
8024 Check_Arg_Is_Local_Name (Arg2);
8027 Check_No_Identifier (Arg1);
8028 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
8030 if not OpenVMS_On_Target then
8031 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8033 ("?pragma% ignored (applies only to Open'V'M'S)");
8039 -- One argument case
8041 if Arg_Count = 1 then
8042 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8043 if Opt.Float_Format = 'I' then
8044 Error_Pragma ("'I'E'E'E format previously specified");
8047 Opt.Float_Format := 'V';
8050 if Opt.Float_Format = 'V' then
8051 Error_Pragma ("'V'A'X format previously specified");
8054 Opt.Float_Format := 'I';
8057 Set_Standard_Fpt_Formats;
8059 -- Two argument case
8062 Argx := Get_Pragma_Arg (Arg2);
8064 if not Is_Entity_Name (Argx)
8065 or else not Is_Floating_Point_Type (Entity (Argx))
8068 ("second argument of% pragma must be floating-point type",
8072 Ent := Entity (Argx);
8073 Digs := UI_To_Int (Digits_Value (Ent));
8075 -- Two arguments, VAX_Float case
8077 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8079 when 6 => Set_F_Float (Ent);
8080 when 9 => Set_D_Float (Ent);
8081 when 15 => Set_G_Float (Ent);
8085 ("wrong digits value, must be 6,9 or 15", Arg2);
8088 -- Two arguments, IEEE_Float case
8092 when 6 => Set_IEEE_Short (Ent);
8093 when 15 => Set_IEEE_Long (Ent);
8097 ("wrong digits value, must be 6 or 15", Arg2);
8101 end Float_Representation;
8107 -- pragma Ident (static_string_EXPRESSION)
8109 -- Note: pragma Comment shares this processing. Pragma Comment is
8110 -- identical to Ident, except that the restriction of the argument to
8111 -- 31 characters and the placement restrictions are not enforced for
8114 when Pragma_Ident | Pragma_Comment => Ident : declare
8119 Check_Arg_Count (1);
8120 Check_No_Identifiers;
8121 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
8124 -- For pragma Ident, preserve DEC compatibility by requiring the
8125 -- pragma to appear in a declarative part or package spec.
8127 if Prag_Id = Pragma_Ident then
8128 Check_Is_In_Decl_Part_Or_Package_Spec;
8131 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
8138 GP := Parent (Parent (N));
8140 if Nkind_In (GP, N_Package_Declaration,
8141 N_Generic_Package_Declaration)
8146 -- If we have a compilation unit, then record the ident value,
8147 -- checking for improper duplication.
8149 if Nkind (GP) = N_Compilation_Unit then
8150 CS := Ident_String (Current_Sem_Unit);
8152 if Present (CS) then
8154 -- For Ident, we do not permit multiple instances
8156 if Prag_Id = Pragma_Ident then
8157 Error_Pragma ("duplicate% pragma not permitted");
8159 -- For Comment, we concatenate the string, unless we want
8160 -- to preserve the tree structure for ASIS.
8162 elsif not ASIS_Mode then
8163 Start_String (Strval (CS));
8164 Store_String_Char (' ');
8165 Store_String_Chars (Strval (Str));
8166 Set_Strval (CS, End_String);
8170 -- In VMS, the effect of IDENT is achieved by passing
8171 -- --identification=name as a --for-linker switch.
8173 if OpenVMS_On_Target then
8176 ("--for-linker=--identification=");
8177 String_To_Name_Buffer (Strval (Str));
8178 Store_String_Chars (Name_Buffer (1 .. Name_Len));
8180 -- Only the last processed IDENT is saved. The main
8181 -- purpose is so an IDENT associated with a main
8182 -- procedure will be used in preference to an IDENT
8183 -- associated with a with'd package.
8185 Replace_Linker_Option_String
8186 (End_String, "--for-linker=--identification=");
8189 Set_Ident_String (Current_Sem_Unit, Str);
8192 -- For subunits, we just ignore the Ident, since in GNAT these
8193 -- are not separate object files, and hence not separate units
8194 -- in the unit table.
8196 elsif Nkind (GP) = N_Subunit then
8199 -- Otherwise we have a misplaced pragma Ident, but we ignore
8200 -- this if we are in an instantiation, since it comes from
8201 -- a generic, and has no relevance to the instantiation.
8203 elsif Prag_Id = Pragma_Ident then
8204 if Instantiation_Location (Loc) = No_Location then
8205 Error_Pragma ("pragma% only allowed at outer level");
8215 -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
8216 -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
8218 when Pragma_Implemented => Implemented : declare
8219 Proc_Id : Entity_Id;
8224 Check_Arg_Count (2);
8225 Check_No_Identifiers;
8226 Check_Arg_Is_Identifier (Arg1);
8227 Check_Arg_Is_Local_Name (Arg1);
8229 (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
8231 -- Extract the name of the local procedure
8233 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
8235 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
8236 -- primitive procedure of a synchronized tagged type.
8238 if Ekind (Proc_Id) = E_Procedure
8239 and then Is_Primitive (Proc_Id)
8240 and then Present (First_Formal (Proc_Id))
8242 Typ := Etype (First_Formal (Proc_Id));
8244 if Is_Tagged_Type (Typ)
8247 -- Check for a protected, a synchronized or a task interface
8249 ((Is_Interface (Typ)
8250 and then Is_Synchronized_Interface (Typ))
8252 -- Check for a protected type or a task type that implements
8256 (Is_Concurrent_Record_Type (Typ)
8257 and then Present (Interfaces (Typ)))
8259 -- Check for a private record extension with keyword
8263 (Ekind_In (Typ, E_Record_Type_With_Private,
8264 E_Record_Subtype_With_Private)
8265 and then Synchronized_Present (Parent (Typ))))
8270 ("controlling formal must be of synchronized " &
8271 "tagged type", Arg1);
8275 -- Procedures declared inside a protected type must be accepted
8277 elsif Ekind (Proc_Id) = E_Procedure
8278 and then Is_Protected_Type (Scope (Proc_Id))
8282 -- The first argument is not a primitive procedure
8286 ("pragma % must be applied to a primitive procedure", Arg1);
8290 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
8291 -- By_Protected_Procedure to the primitive procedure of a task
8294 if Chars (Arg2) = Name_By_Protected_Procedure
8295 and then Is_Interface (Typ)
8296 and then Is_Task_Interface (Typ)
8299 ("implementation kind By_Protected_Procedure cannot be " &
8300 "applied to a task interface primitive", Arg2);
8304 Record_Rep_Item (Proc_Id, N);
8307 ----------------------
8308 -- Implicit_Packing --
8309 ----------------------
8311 -- pragma Implicit_Packing;
8313 when Pragma_Implicit_Packing =>
8315 Check_Arg_Count (0);
8316 Implicit_Packing := True;
8323 -- [Convention =>] convention_IDENTIFIER,
8324 -- [Entity =>] local_NAME
8325 -- [, [External_Name =>] static_string_EXPRESSION ]
8326 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8328 when Pragma_Import =>
8329 Check_Ada_83_Warning;
8335 Check_At_Least_N_Arguments (2);
8336 Check_At_Most_N_Arguments (4);
8337 Process_Import_Or_Interface;
8339 ----------------------
8340 -- Import_Exception --
8341 ----------------------
8343 -- pragma Import_Exception (
8344 -- [Internal =>] LOCAL_NAME
8345 -- [, [External =>] EXTERNAL_SYMBOL]
8346 -- [, [Form =>] Ada | VMS]
8347 -- [, [Code =>] static_integer_EXPRESSION]);
8349 when Pragma_Import_Exception => Import_Exception : declare
8350 Args : Args_List (1 .. 4);
8351 Names : constant Name_List (1 .. 4) := (
8357 Internal : Node_Id renames Args (1);
8358 External : Node_Id renames Args (2);
8359 Form : Node_Id renames Args (3);
8360 Code : Node_Id renames Args (4);
8364 Gather_Associations (Names, Args);
8366 if Present (External) and then Present (Code) then
8368 ("cannot give both External and Code options for pragma%");
8371 Process_Extended_Import_Export_Exception_Pragma (
8372 Arg_Internal => Internal,
8373 Arg_External => External,
8377 if not Is_VMS_Exception (Entity (Internal)) then
8378 Set_Imported (Entity (Internal));
8380 end Import_Exception;
8382 ---------------------
8383 -- Import_Function --
8384 ---------------------
8386 -- pragma Import_Function (
8387 -- [Internal =>] LOCAL_NAME,
8388 -- [, [External =>] EXTERNAL_SYMBOL]
8389 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8390 -- [, [Result_Type =>] SUBTYPE_MARK]
8391 -- [, [Mechanism =>] MECHANISM]
8392 -- [, [Result_Mechanism =>] MECHANISM_NAME]
8393 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
8395 -- EXTERNAL_SYMBOL ::=
8397 -- | static_string_EXPRESSION
8399 -- PARAMETER_TYPES ::=
8401 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8403 -- TYPE_DESIGNATOR ::=
8405 -- | subtype_Name ' Access
8409 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8411 -- MECHANISM_ASSOCIATION ::=
8412 -- [formal_parameter_NAME =>] MECHANISM_NAME
8414 -- MECHANISM_NAME ::=
8417 -- | Descriptor [([Class =>] CLASS_NAME)]
8419 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8421 when Pragma_Import_Function => Import_Function : declare
8422 Args : Args_List (1 .. 7);
8423 Names : constant Name_List (1 .. 7) := (
8426 Name_Parameter_Types,
8429 Name_Result_Mechanism,
8430 Name_First_Optional_Parameter);
8432 Internal : Node_Id renames Args (1);
8433 External : Node_Id renames Args (2);
8434 Parameter_Types : Node_Id renames Args (3);
8435 Result_Type : Node_Id renames Args (4);
8436 Mechanism : Node_Id renames Args (5);
8437 Result_Mechanism : Node_Id renames Args (6);
8438 First_Optional_Parameter : Node_Id renames Args (7);
8442 Gather_Associations (Names, Args);
8443 Process_Extended_Import_Export_Subprogram_Pragma (
8444 Arg_Internal => Internal,
8445 Arg_External => External,
8446 Arg_Parameter_Types => Parameter_Types,
8447 Arg_Result_Type => Result_Type,
8448 Arg_Mechanism => Mechanism,
8449 Arg_Result_Mechanism => Result_Mechanism,
8450 Arg_First_Optional_Parameter => First_Optional_Parameter);
8451 end Import_Function;
8457 -- pragma Import_Object (
8458 -- [Internal =>] LOCAL_NAME
8459 -- [, [External =>] EXTERNAL_SYMBOL]
8460 -- [, [Size =>] EXTERNAL_SYMBOL]);
8462 -- EXTERNAL_SYMBOL ::=
8464 -- | static_string_EXPRESSION
8466 when Pragma_Import_Object => Import_Object : declare
8467 Args : Args_List (1 .. 3);
8468 Names : constant Name_List (1 .. 3) := (
8473 Internal : Node_Id renames Args (1);
8474 External : Node_Id renames Args (2);
8475 Size : Node_Id renames Args (3);
8479 Gather_Associations (Names, Args);
8480 Process_Extended_Import_Export_Object_Pragma (
8481 Arg_Internal => Internal,
8482 Arg_External => External,
8486 ----------------------
8487 -- Import_Procedure --
8488 ----------------------
8490 -- pragma Import_Procedure (
8491 -- [Internal =>] LOCAL_NAME
8492 -- [, [External =>] EXTERNAL_SYMBOL]
8493 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8494 -- [, [Mechanism =>] MECHANISM]
8495 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
8497 -- EXTERNAL_SYMBOL ::=
8499 -- | static_string_EXPRESSION
8501 -- PARAMETER_TYPES ::=
8503 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8505 -- TYPE_DESIGNATOR ::=
8507 -- | subtype_Name ' Access
8511 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8513 -- MECHANISM_ASSOCIATION ::=
8514 -- [formal_parameter_NAME =>] MECHANISM_NAME
8516 -- MECHANISM_NAME ::=
8519 -- | Descriptor [([Class =>] CLASS_NAME)]
8521 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8523 when Pragma_Import_Procedure => Import_Procedure : declare
8524 Args : Args_List (1 .. 5);
8525 Names : constant Name_List (1 .. 5) := (
8528 Name_Parameter_Types,
8530 Name_First_Optional_Parameter);
8532 Internal : Node_Id renames Args (1);
8533 External : Node_Id renames Args (2);
8534 Parameter_Types : Node_Id renames Args (3);
8535 Mechanism : Node_Id renames Args (4);
8536 First_Optional_Parameter : Node_Id renames Args (5);
8540 Gather_Associations (Names, Args);
8541 Process_Extended_Import_Export_Subprogram_Pragma (
8542 Arg_Internal => Internal,
8543 Arg_External => External,
8544 Arg_Parameter_Types => Parameter_Types,
8545 Arg_Mechanism => Mechanism,
8546 Arg_First_Optional_Parameter => First_Optional_Parameter);
8547 end Import_Procedure;
8549 -----------------------------
8550 -- Import_Valued_Procedure --
8551 -----------------------------
8553 -- pragma Import_Valued_Procedure (
8554 -- [Internal =>] LOCAL_NAME
8555 -- [, [External =>] EXTERNAL_SYMBOL]
8556 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8557 -- [, [Mechanism =>] MECHANISM]
8558 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
8560 -- EXTERNAL_SYMBOL ::=
8562 -- | static_string_EXPRESSION
8564 -- PARAMETER_TYPES ::=
8566 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8568 -- TYPE_DESIGNATOR ::=
8570 -- | subtype_Name ' Access
8574 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8576 -- MECHANISM_ASSOCIATION ::=
8577 -- [formal_parameter_NAME =>] MECHANISM_NAME
8579 -- MECHANISM_NAME ::=
8582 -- | Descriptor [([Class =>] CLASS_NAME)]
8584 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8586 when Pragma_Import_Valued_Procedure =>
8587 Import_Valued_Procedure : declare
8588 Args : Args_List (1 .. 5);
8589 Names : constant Name_List (1 .. 5) := (
8592 Name_Parameter_Types,
8594 Name_First_Optional_Parameter);
8596 Internal : Node_Id renames Args (1);
8597 External : Node_Id renames Args (2);
8598 Parameter_Types : Node_Id renames Args (3);
8599 Mechanism : Node_Id renames Args (4);
8600 First_Optional_Parameter : Node_Id renames Args (5);
8604 Gather_Associations (Names, Args);
8605 Process_Extended_Import_Export_Subprogram_Pragma (
8606 Arg_Internal => Internal,
8607 Arg_External => External,
8608 Arg_Parameter_Types => Parameter_Types,
8609 Arg_Mechanism => Mechanism,
8610 Arg_First_Optional_Parameter => First_Optional_Parameter);
8611 end Import_Valued_Procedure;
8617 -- pragma Independent (LOCAL_NAME);
8619 when Pragma_Independent => Independent : declare
8626 Check_Ada_83_Warning;
8628 Check_No_Identifiers;
8629 Check_Arg_Count (1);
8630 Check_Arg_Is_Local_Name (Arg1);
8631 E_Id := Get_Pragma_Arg (Arg1);
8633 if Etype (E_Id) = Any_Type then
8638 D := Declaration_Node (E);
8641 -- Check duplicate before we chain ourselves!
8643 Check_Duplicate_Pragma (E);
8645 -- Check appropriate entity
8648 if Rep_Item_Too_Early (E, N)
8650 Rep_Item_Too_Late (E, N)
8654 Check_First_Subtype (Arg1);
8657 elsif K = N_Object_Declaration
8658 or else (K = N_Component_Declaration
8659 and then Original_Record_Component (E) = E)
8661 if Rep_Item_Too_Late (E, N) then
8667 ("inappropriate entity for pragma%", Arg1);
8670 Independence_Checks.Append ((N, E));
8673 ----------------------------
8674 -- Independent_Components --
8675 ----------------------------
8677 -- pragma Atomic_Components (array_LOCAL_NAME);
8679 -- This processing is shared by Volatile_Components
8681 when Pragma_Independent_Components => Independent_Components : declare
8688 Check_Ada_83_Warning;
8690 Check_No_Identifiers;
8691 Check_Arg_Count (1);
8692 Check_Arg_Is_Local_Name (Arg1);
8693 E_Id := Get_Pragma_Arg (Arg1);
8695 if Etype (E_Id) = Any_Type then
8701 -- Check duplicate before we chain ourselves!
8703 Check_Duplicate_Pragma (E);
8705 -- Check appropriate entity
8707 if Rep_Item_Too_Early (E, N)
8709 Rep_Item_Too_Late (E, N)
8714 D := Declaration_Node (E);
8717 if (K = N_Full_Type_Declaration
8718 and then (Is_Array_Type (E) or else Is_Record_Type (E)))
8720 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
8721 and then Nkind (D) = N_Object_Declaration
8722 and then Nkind (Object_Definition (D)) =
8723 N_Constrained_Array_Definition)
8725 Independence_Checks.Append ((N, E));
8728 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
8730 end Independent_Components;
8732 ------------------------
8733 -- Initialize_Scalars --
8734 ------------------------
8736 -- pragma Initialize_Scalars;
8738 when Pragma_Initialize_Scalars =>
8740 Check_Arg_Count (0);
8741 Check_Valid_Configuration_Pragma;
8742 Check_Restriction (No_Initialize_Scalars, N);
8744 -- Initialize_Scalars creates false positives in CodePeer,
8745 -- so ignore this pragma in this mode.
8747 if not Restriction_Active (No_Initialize_Scalars)
8748 and then not CodePeer_Mode
8750 Init_Or_Norm_Scalars := True;
8751 Initialize_Scalars := True;
8758 -- pragma Inline ( NAME {, NAME} );
8760 when Pragma_Inline =>
8762 -- Pragma is active if inlining option is active
8764 Process_Inline (Inline_Active);
8770 -- pragma Inline_Always ( NAME {, NAME} );
8772 when Pragma_Inline_Always =>
8775 -- Pragma always active unless in CodePeer mode, since this causes
8776 -- walk order issues.
8778 if not CodePeer_Mode then
8779 Process_Inline (True);
8782 --------------------
8783 -- Inline_Generic --
8784 --------------------
8786 -- pragma Inline_Generic (NAME {, NAME});
8788 when Pragma_Inline_Generic =>
8790 Process_Generic_List;
8792 ----------------------
8793 -- Inspection_Point --
8794 ----------------------
8796 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
8798 when Pragma_Inspection_Point => Inspection_Point : declare
8803 if Arg_Count > 0 then
8806 Exp := Get_Pragma_Arg (Arg);
8809 if not Is_Entity_Name (Exp)
8810 or else not Is_Object (Entity (Exp))
8812 Error_Pragma_Arg ("object name required", Arg);
8819 end Inspection_Point;
8825 -- pragma Interface (
8826 -- [ Convention =>] convention_IDENTIFIER,
8827 -- [ Entity =>] local_NAME
8828 -- [, [External_Name =>] static_string_EXPRESSION ]
8829 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8831 when Pragma_Interface =>
8838 Check_At_Least_N_Arguments (2);
8839 Check_At_Most_N_Arguments (4);
8840 Process_Import_Or_Interface;
8842 -- In Ada 2005, the permission to use Interface (a reserved word)
8843 -- as a pragma name is considered an obsolescent feature.
8845 if Ada_Version >= Ada_2005 then
8847 (No_Obsolescent_Features, Pragma_Identifier (N));
8850 --------------------
8851 -- Interface_Name --
8852 --------------------
8854 -- pragma Interface_Name (
8855 -- [ Entity =>] local_NAME
8856 -- [,[External_Name =>] static_string_EXPRESSION ]
8857 -- [,[Link_Name =>] static_string_EXPRESSION ]);
8859 when Pragma_Interface_Name => Interface_Name : declare
8868 ((Name_Entity, Name_External_Name, Name_Link_Name));
8869 Check_At_Least_N_Arguments (2);
8870 Check_At_Most_N_Arguments (3);
8871 Id := Get_Pragma_Arg (Arg1);
8874 if not Is_Entity_Name (Id) then
8876 ("first argument for pragma% must be entity name", Arg1);
8877 elsif Etype (Id) = Any_Type then
8880 Def_Id := Entity (Id);
8883 -- Special DEC-compatible processing for the object case, forces
8884 -- object to be imported.
8886 if Ekind (Def_Id) = E_Variable then
8887 Kill_Size_Check_Code (Def_Id);
8888 Note_Possible_Modification (Id, Sure => False);
8890 -- Initialization is not allowed for imported variable
8892 if Present (Expression (Parent (Def_Id)))
8893 and then Comes_From_Source (Expression (Parent (Def_Id)))
8895 Error_Msg_Sloc := Sloc (Def_Id);
8897 ("no initialization allowed for declaration of& #",
8901 -- For compatibility, support VADS usage of providing both
8902 -- pragmas Interface and Interface_Name to obtain the effect
8903 -- of a single Import pragma.
8905 if Is_Imported (Def_Id)
8906 and then Present (First_Rep_Item (Def_Id))
8907 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
8909 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
8913 Set_Imported (Def_Id);
8916 Set_Is_Public (Def_Id);
8917 Process_Interface_Name (Def_Id, Arg2, Arg3);
8920 -- Otherwise must be subprogram
8922 elsif not Is_Subprogram (Def_Id) then
8924 ("argument of pragma% is not subprogram", Arg1);
8927 Check_At_Most_N_Arguments (3);
8931 -- Loop through homonyms
8934 Def_Id := Get_Base_Subprogram (Hom_Id);
8936 if Is_Imported (Def_Id) then
8937 Process_Interface_Name (Def_Id, Arg2, Arg3);
8941 exit when From_Aspect_Specification (N);
8942 Hom_Id := Homonym (Hom_Id);
8944 exit when No (Hom_Id)
8945 or else Scope (Hom_Id) /= Current_Scope;
8950 ("argument of pragma% is not imported subprogram",
8956 -----------------------
8957 -- Interrupt_Handler --
8958 -----------------------
8960 -- pragma Interrupt_Handler (handler_NAME);
8962 when Pragma_Interrupt_Handler =>
8963 Check_Ada_83_Warning;
8964 Check_Arg_Count (1);
8965 Check_No_Identifiers;
8967 if No_Run_Time_Mode then
8968 Error_Msg_CRT ("Interrupt_Handler pragma", N);
8970 Check_Interrupt_Or_Attach_Handler;
8971 Process_Interrupt_Or_Attach_Handler;
8974 ------------------------
8975 -- Interrupt_Priority --
8976 ------------------------
8978 -- pragma Interrupt_Priority [(EXPRESSION)];
8980 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
8981 P : constant Node_Id := Parent (N);
8985 Check_Ada_83_Warning;
8987 if Arg_Count /= 0 then
8988 Arg := Get_Pragma_Arg (Arg1);
8989 Check_Arg_Count (1);
8990 Check_No_Identifiers;
8992 -- The expression must be analyzed in the special manner
8993 -- described in "Handling of Default and Per-Object
8994 -- Expressions" in sem.ads.
8996 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
8999 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
9003 elsif Has_Pragma_Priority (P) then
9004 Error_Pragma ("duplicate pragma% not allowed");
9007 Set_Has_Pragma_Priority (P, True);
9008 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
9010 end Interrupt_Priority;
9012 ---------------------
9013 -- Interrupt_State --
9014 ---------------------
9016 -- pragma Interrupt_State (
9017 -- [Name =>] INTERRUPT_ID,
9018 -- [State =>] INTERRUPT_STATE);
9020 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
9021 -- INTERRUPT_STATE => System | Runtime | User
9023 -- Note: if the interrupt id is given as an identifier, then it must
9024 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
9025 -- given as a static integer expression which must be in the range of
9026 -- Ada.Interrupts.Interrupt_ID.
9028 when Pragma_Interrupt_State => Interrupt_State : declare
9030 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
9031 -- This is the entity Ada.Interrupts.Interrupt_ID;
9033 State_Type : Character;
9034 -- Set to 's'/'r'/'u' for System/Runtime/User
9037 -- Index to entry in Interrupt_States table
9040 -- Value of interrupt
9042 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
9043 -- The first argument to the pragma
9045 Int_Ent : Entity_Id;
9046 -- Interrupt entity in Ada.Interrupts.Names
9050 Check_Arg_Order ((Name_Name, Name_State));
9051 Check_Arg_Count (2);
9053 Check_Optional_Identifier (Arg1, Name_Name);
9054 Check_Optional_Identifier (Arg2, Name_State);
9055 Check_Arg_Is_Identifier (Arg2);
9057 -- First argument is identifier
9059 if Nkind (Arg1X) = N_Identifier then
9061 -- Search list of names in Ada.Interrupts.Names
9063 Int_Ent := First_Entity (RTE (RE_Names));
9065 if No (Int_Ent) then
9066 Error_Pragma_Arg ("invalid interrupt name", Arg1);
9068 elsif Chars (Int_Ent) = Chars (Arg1X) then
9069 Int_Val := Expr_Value (Constant_Value (Int_Ent));
9073 Next_Entity (Int_Ent);
9076 -- First argument is not an identifier, so it must be a static
9077 -- expression of type Ada.Interrupts.Interrupt_ID.
9080 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
9081 Int_Val := Expr_Value (Arg1X);
9083 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
9085 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
9088 ("value not in range of type " &
9089 """Ada.Interrupts.Interrupt_'I'D""", Arg1);
9095 case Chars (Get_Pragma_Arg (Arg2)) is
9096 when Name_Runtime => State_Type := 'r';
9097 when Name_System => State_Type := 's';
9098 when Name_User => State_Type := 'u';
9101 Error_Pragma_Arg ("invalid interrupt state", Arg2);
9104 -- Check if entry is already stored
9106 IST_Num := Interrupt_States.First;
9108 -- If entry not found, add it
9110 if IST_Num > Interrupt_States.Last then
9111 Interrupt_States.Append
9112 ((Interrupt_Number => UI_To_Int (Int_Val),
9113 Interrupt_State => State_Type,
9114 Pragma_Loc => Loc));
9117 -- Case of entry for the same entry
9119 elsif Int_Val = Interrupt_States.Table (IST_Num).
9122 -- If state matches, done, no need to make redundant entry
9125 State_Type = Interrupt_States.Table (IST_Num).
9128 -- Otherwise if state does not match, error
9131 Interrupt_States.Table (IST_Num).Pragma_Loc;
9133 ("state conflicts with that given #", Arg2);
9137 IST_Num := IST_Num + 1;
9139 end Interrupt_State;
9141 ----------------------
9142 -- Java_Constructor --
9143 ----------------------
9145 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
9147 -- Also handles pragma CIL_Constructor
9149 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
9150 Java_Constructor : declare
9151 Convention : Convention_Id;
9155 This_Formal : Entity_Id;
9159 Check_Arg_Count (1);
9160 Check_Optional_Identifier (Arg1, Name_Entity);
9161 Check_Arg_Is_Local_Name (Arg1);
9163 Id := Get_Pragma_Arg (Arg1);
9164 Find_Program_Unit_Name (Id);
9166 -- If we did not find the name, we are done
9168 if Etype (Id) = Any_Type then
9172 -- Check wrong use of pragma in wrong VM target
9174 if VM_Target = No_VM then
9177 elsif VM_Target = CLI_Target
9178 and then Prag_Id = Pragma_Java_Constructor
9180 Error_Pragma ("must use pragma 'C'I'L_'Constructor");
9182 elsif VM_Target = JVM_Target
9183 and then Prag_Id = Pragma_CIL_Constructor
9185 Error_Pragma ("must use pragma 'Java_'Constructor");
9189 when Pragma_CIL_Constructor => Convention := Convention_CIL;
9190 when Pragma_Java_Constructor => Convention := Convention_Java;
9191 when others => null;
9194 Hom_Id := Entity (Id);
9196 -- Loop through homonyms
9199 Def_Id := Get_Base_Subprogram (Hom_Id);
9201 -- The constructor is required to be a function
9203 if Ekind (Def_Id) /= E_Function then
9204 if VM_Target = JVM_Target then
9206 ("pragma% requires function returning a " &
9207 "'Java access type", Def_Id);
9210 ("pragma% requires function returning a " &
9211 "'C'I'L access type", Def_Id);
9215 -- Check arguments: For tagged type the first formal must be
9216 -- named "this" and its type must be a named access type
9217 -- designating a class-wide tagged type that has convention
9218 -- CIL/Java. The first formal must also have a null default
9219 -- value. For example:
9221 -- type Typ is tagged ...
9222 -- type Ref is access all Typ;
9223 -- pragma Convention (CIL, Typ);
9225 -- function New_Typ (This : Ref) return Ref;
9226 -- function New_Typ (This : Ref; I : Integer) return Ref;
9227 -- pragma Cil_Constructor (New_Typ);
9229 -- Reason: The first formal must NOT be a primitive of the
9232 -- This rule also applies to constructors of delegates used
9233 -- to interface with standard target libraries. For example:
9235 -- type Delegate is access procedure ...
9236 -- pragma Import (CIL, Delegate, ...);
9238 -- function new_Delegate
9239 -- (This : Delegate := null; ... ) return Delegate;
9241 -- For value-types this rule does not apply.
9243 if not Is_Value_Type (Etype (Def_Id)) then
9244 if No (First_Formal (Def_Id)) then
9245 Error_Msg_Name_1 := Pname;
9246 Error_Msg_N ("% function must have parameters", Def_Id);
9250 -- In the JRE library we have several occurrences in which
9251 -- the "this" parameter is not the first formal.
9253 This_Formal := First_Formal (Def_Id);
9255 -- In the JRE library we have several occurrences in which
9256 -- the "this" parameter is not the first formal. Search for
9259 if VM_Target = JVM_Target then
9260 while Present (This_Formal)
9261 and then Get_Name_String (Chars (This_Formal)) /= "this"
9263 Next_Formal (This_Formal);
9266 if No (This_Formal) then
9267 This_Formal := First_Formal (Def_Id);
9271 -- Warning: The first parameter should be named "this".
9272 -- We temporarily allow it because we have the following
9273 -- case in the Java runtime (file s-osinte.ads) ???
9275 -- function new_Thread
9276 -- (Self_Id : System.Address) return Thread_Id;
9277 -- pragma Java_Constructor (new_Thread);
9279 if VM_Target = JVM_Target
9280 and then Get_Name_String (Chars (First_Formal (Def_Id)))
9282 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
9286 elsif Get_Name_String (Chars (This_Formal)) /= "this" then
9287 Error_Msg_Name_1 := Pname;
9289 ("first formal of % function must be named `this`",
9290 Parent (This_Formal));
9292 elsif not Is_Access_Type (Etype (This_Formal)) then
9293 Error_Msg_Name_1 := Pname;
9295 ("first formal of % function must be an access type",
9296 Parameter_Type (Parent (This_Formal)));
9298 -- For delegates the type of the first formal must be a
9299 -- named access-to-subprogram type (see previous example)
9301 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
9302 and then Ekind (Etype (This_Formal))
9303 /= E_Access_Subprogram_Type
9305 Error_Msg_Name_1 := Pname;
9307 ("first formal of % function must be a named access" &
9308 " to subprogram type",
9309 Parameter_Type (Parent (This_Formal)));
9311 -- Warning: We should reject anonymous access types because
9312 -- the constructor must not be handled as a primitive of the
9313 -- tagged type. We temporarily allow it because this profile
9314 -- is currently generated by cil2ada???
9316 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
9317 and then not Ekind_In (Etype (This_Formal),
9319 E_General_Access_Type,
9320 E_Anonymous_Access_Type)
9322 Error_Msg_Name_1 := Pname;
9324 ("first formal of % function must be a named access" &
9326 Parameter_Type (Parent (This_Formal)));
9328 elsif Atree.Convention
9329 (Designated_Type (Etype (This_Formal))) /= Convention
9331 Error_Msg_Name_1 := Pname;
9333 if Convention = Convention_Java then
9335 ("pragma% requires convention 'Cil in designated" &
9337 Parameter_Type (Parent (This_Formal)));
9340 ("pragma% requires convention 'Java in designated" &
9342 Parameter_Type (Parent (This_Formal)));
9345 elsif No (Expression (Parent (This_Formal)))
9346 or else Nkind (Expression (Parent (This_Formal))) /= N_Null
9348 Error_Msg_Name_1 := Pname;
9350 ("pragma% requires first formal with default `null`",
9351 Parameter_Type (Parent (This_Formal)));
9355 -- Check result type: the constructor must be a function
9357 -- * a value type (only allowed in the CIL compiler)
9358 -- * an access-to-subprogram type with convention Java/CIL
9359 -- * an access-type designating a type that has convention
9362 if Is_Value_Type (Etype (Def_Id)) then
9365 -- Access-to-subprogram type with convention Java/CIL
9367 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
9368 if Atree.Convention (Etype (Def_Id)) /= Convention then
9369 if Convention = Convention_Java then
9371 ("pragma% requires function returning a " &
9372 "'Java access type", Arg1);
9374 pragma Assert (Convention = Convention_CIL);
9376 ("pragma% requires function returning a " &
9377 "'C'I'L access type", Arg1);
9381 elsif Ekind (Etype (Def_Id)) in Access_Kind then
9382 if not Ekind_In (Etype (Def_Id), E_Access_Type,
9383 E_General_Access_Type)
9386 (Designated_Type (Etype (Def_Id))) /= Convention
9388 Error_Msg_Name_1 := Pname;
9390 if Convention = Convention_Java then
9392 ("pragma% requires function returning a named" &
9393 "'Java access type", Arg1);
9396 ("pragma% requires function returning a named" &
9397 "'C'I'L access type", Arg1);
9402 Set_Is_Constructor (Def_Id);
9403 Set_Convention (Def_Id, Convention);
9404 Set_Is_Imported (Def_Id);
9406 exit when From_Aspect_Specification (N);
9407 Hom_Id := Homonym (Hom_Id);
9409 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
9411 end Java_Constructor;
9413 ----------------------
9414 -- Java_Interface --
9415 ----------------------
9417 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
9419 when Pragma_Java_Interface => Java_Interface : declare
9425 Check_Arg_Count (1);
9426 Check_Optional_Identifier (Arg1, Name_Entity);
9427 Check_Arg_Is_Local_Name (Arg1);
9429 Arg := Get_Pragma_Arg (Arg1);
9432 if Etype (Arg) = Any_Type then
9436 if not Is_Entity_Name (Arg)
9437 or else not Is_Type (Entity (Arg))
9439 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
9442 Typ := Underlying_Type (Entity (Arg));
9444 -- For now simply check some of the semantic constraints on the
9445 -- type. This currently leaves out some restrictions on interface
9446 -- types, namely that the parent type must be java.lang.Object.Typ
9447 -- and that all primitives of the type should be declared
9450 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
9451 Error_Pragma_Arg ("pragma% requires an abstract "
9452 & "tagged type", Arg1);
9454 elsif not Has_Discriminants (Typ)
9455 or else Ekind (Etype (First_Discriminant (Typ)))
9456 /= E_Anonymous_Access_Type
9458 not Is_Class_Wide_Type
9459 (Designated_Type (Etype (First_Discriminant (Typ))))
9462 ("type must have a class-wide access discriminant", Arg1);
9470 -- pragma Keep_Names ([On => ] local_NAME);
9472 when Pragma_Keep_Names => Keep_Names : declare
9477 Check_Arg_Count (1);
9478 Check_Optional_Identifier (Arg1, Name_On);
9479 Check_Arg_Is_Local_Name (Arg1);
9481 Arg := Get_Pragma_Arg (Arg1);
9484 if Etype (Arg) = Any_Type then
9488 if not Is_Entity_Name (Arg)
9489 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
9492 ("pragma% requires a local enumeration type", Arg1);
9495 Set_Discard_Names (Entity (Arg), False);
9502 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
9504 when Pragma_License =>
9506 Check_Arg_Count (1);
9507 Check_No_Identifiers;
9508 Check_Valid_Configuration_Pragma;
9509 Check_Arg_Is_Identifier (Arg1);
9512 Sind : constant Source_File_Index :=
9513 Source_Index (Current_Sem_Unit);
9516 case Chars (Get_Pragma_Arg (Arg1)) is
9518 Set_License (Sind, GPL);
9520 when Name_Modified_GPL =>
9521 Set_License (Sind, Modified_GPL);
9523 when Name_Restricted =>
9524 Set_License (Sind, Restricted);
9526 when Name_Unrestricted =>
9527 Set_License (Sind, Unrestricted);
9530 Error_Pragma_Arg ("invalid license name", Arg1);
9538 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
9540 when Pragma_Link_With => Link_With : declare
9546 if Operating_Mode = Generate_Code
9547 and then In_Extended_Main_Source_Unit (N)
9549 Check_At_Least_N_Arguments (1);
9550 Check_No_Identifiers;
9551 Check_Is_In_Decl_Part_Or_Package_Spec;
9552 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
9556 while Present (Arg) loop
9557 Check_Arg_Is_Static_Expression (Arg, Standard_String);
9559 -- Store argument, converting sequences of spaces to a
9560 -- single null character (this is one of the differences
9561 -- in processing between Link_With and Linker_Options).
9564 C : constant Char_Code := Get_Char_Code (' ');
9565 S : constant String_Id :=
9566 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
9567 L : constant Nat := String_Length (S);
9570 procedure Skip_Spaces;
9571 -- Advance F past any spaces
9577 procedure Skip_Spaces is
9579 while F <= L and then Get_String_Char (S, F) = C loop
9584 -- Start of processing for Arg_Store
9587 Skip_Spaces; -- skip leading spaces
9589 -- Loop through characters, changing any embedded
9590 -- sequence of spaces to a single null character (this
9591 -- is how Link_With/Linker_Options differ)
9594 if Get_String_Char (S, F) = C then
9597 Store_String_Char (ASCII.NUL);
9600 Store_String_Char (Get_String_Char (S, F));
9608 if Present (Arg) then
9609 Store_String_Char (ASCII.NUL);
9613 Store_Linker_Option_String (End_String);
9621 -- pragma Linker_Alias (
9622 -- [Entity =>] LOCAL_NAME
9623 -- [Target =>] static_string_EXPRESSION);
9625 when Pragma_Linker_Alias =>
9627 Check_Arg_Order ((Name_Entity, Name_Target));
9628 Check_Arg_Count (2);
9629 Check_Optional_Identifier (Arg1, Name_Entity);
9630 Check_Optional_Identifier (Arg2, Name_Target);
9631 Check_Arg_Is_Library_Level_Local_Name (Arg1);
9632 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
9634 -- The only processing required is to link this item on to the
9635 -- list of rep items for the given entity. This is accomplished
9636 -- by the call to Rep_Item_Too_Late (when no error is detected
9637 -- and False is returned).
9639 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
9642 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
9645 ------------------------
9646 -- Linker_Constructor --
9647 ------------------------
9649 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
9651 -- Code is shared with Linker_Destructor
9653 -----------------------
9654 -- Linker_Destructor --
9655 -----------------------
9657 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
9659 when Pragma_Linker_Constructor |
9660 Pragma_Linker_Destructor =>
9661 Linker_Constructor : declare
9667 Check_Arg_Count (1);
9668 Check_No_Identifiers;
9669 Check_Arg_Is_Local_Name (Arg1);
9670 Arg1_X := Get_Pragma_Arg (Arg1);
9672 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
9674 if not Is_Library_Level_Entity (Proc) then
9676 ("argument for pragma% must be library level entity", Arg1);
9679 -- The only processing required is to link this item on to the
9680 -- list of rep items for the given entity. This is accomplished
9681 -- by the call to Rep_Item_Too_Late (when no error is detected
9682 -- and False is returned).
9684 if Rep_Item_Too_Late (Proc, N) then
9687 Set_Has_Gigi_Rep_Item (Proc);
9689 end Linker_Constructor;
9691 --------------------
9692 -- Linker_Options --
9693 --------------------
9695 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
9697 when Pragma_Linker_Options => Linker_Options : declare
9701 Check_Ada_83_Warning;
9702 Check_No_Identifiers;
9703 Check_Arg_Count (1);
9704 Check_Is_In_Decl_Part_Or_Package_Spec;
9705 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
9706 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
9709 while Present (Arg) loop
9710 Check_Arg_Is_Static_Expression (Arg, Standard_String);
9711 Store_String_Char (ASCII.NUL);
9713 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
9717 if Operating_Mode = Generate_Code
9718 and then In_Extended_Main_Source_Unit (N)
9720 Store_Linker_Option_String (End_String);
9724 --------------------
9725 -- Linker_Section --
9726 --------------------
9728 -- pragma Linker_Section (
9729 -- [Entity =>] LOCAL_NAME
9730 -- [Section =>] static_string_EXPRESSION);
9732 when Pragma_Linker_Section =>
9734 Check_Arg_Order ((Name_Entity, Name_Section));
9735 Check_Arg_Count (2);
9736 Check_Optional_Identifier (Arg1, Name_Entity);
9737 Check_Optional_Identifier (Arg2, Name_Section);
9738 Check_Arg_Is_Library_Level_Local_Name (Arg1);
9739 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
9741 -- This pragma applies only to objects
9743 if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) then
9744 Error_Pragma_Arg ("pragma% applies only to objects", Arg1);
9747 -- The only processing required is to link this item on to the
9748 -- list of rep items for the given entity. This is accomplished
9749 -- by the call to Rep_Item_Too_Late (when no error is detected
9750 -- and False is returned).
9752 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
9755 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
9762 -- pragma List (On | Off)
9764 -- There is nothing to do here, since we did all the processing for
9765 -- this pragma in Par.Prag (so that it works properly even in syntax
9771 --------------------
9772 -- Locking_Policy --
9773 --------------------
9775 -- pragma Locking_Policy (policy_IDENTIFIER);
9777 when Pragma_Locking_Policy => declare
9781 Check_Ada_83_Warning;
9782 Check_Arg_Count (1);
9783 Check_No_Identifiers;
9784 Check_Arg_Is_Locking_Policy (Arg1);
9785 Check_Valid_Configuration_Pragma;
9786 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
9787 LP := Fold_Upper (Name_Buffer (1));
9789 if Locking_Policy /= ' '
9790 and then Locking_Policy /= LP
9792 Error_Msg_Sloc := Locking_Policy_Sloc;
9793 Error_Pragma ("locking policy incompatible with policy#");
9795 -- Set new policy, but always preserve System_Location since we
9796 -- like the error message with the run time name.
9799 Locking_Policy := LP;
9801 if Locking_Policy_Sloc /= System_Location then
9802 Locking_Policy_Sloc := Loc;
9811 -- pragma Long_Float (D_Float | G_Float);
9813 when Pragma_Long_Float =>
9815 Check_Valid_Configuration_Pragma;
9816 Check_Arg_Count (1);
9817 Check_No_Identifier (Arg1);
9818 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
9820 if not OpenVMS_On_Target then
9821 Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
9826 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
9827 if Opt.Float_Format_Long = 'G' then
9828 Error_Pragma ("G_Float previously specified");
9831 Opt.Float_Format_Long := 'D';
9833 -- G_Float case (this is the default, does not need overriding)
9836 if Opt.Float_Format_Long = 'D' then
9837 Error_Pragma ("D_Float previously specified");
9840 Opt.Float_Format_Long := 'G';
9843 Set_Standard_Fpt_Formats;
9845 -----------------------
9846 -- Machine_Attribute --
9847 -----------------------
9849 -- pragma Machine_Attribute (
9850 -- [Entity =>] LOCAL_NAME,
9851 -- [Attribute_Name =>] static_string_EXPRESSION
9852 -- [, [Info =>] static_EXPRESSION] );
9854 when Pragma_Machine_Attribute => Machine_Attribute : declare
9859 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
9861 if Arg_Count = 3 then
9862 Check_Optional_Identifier (Arg3, Name_Info);
9863 Check_Arg_Is_Static_Expression (Arg3);
9865 Check_Arg_Count (2);
9868 Check_Optional_Identifier (Arg1, Name_Entity);
9869 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
9870 Check_Arg_Is_Local_Name (Arg1);
9871 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
9872 Def_Id := Entity (Get_Pragma_Arg (Arg1));
9874 if Is_Access_Type (Def_Id) then
9875 Def_Id := Designated_Type (Def_Id);
9878 if Rep_Item_Too_Early (Def_Id, N) then
9882 Def_Id := Underlying_Type (Def_Id);
9884 -- The only processing required is to link this item on to the
9885 -- list of rep items for the given entity. This is accomplished
9886 -- by the call to Rep_Item_Too_Late (when no error is detected
9887 -- and False is returned).
9889 if Rep_Item_Too_Late (Def_Id, N) then
9892 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
9894 end Machine_Attribute;
9901 -- (MAIN_OPTION [, MAIN_OPTION]);
9904 -- [STACK_SIZE =>] static_integer_EXPRESSION
9905 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
9906 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
9908 when Pragma_Main => Main : declare
9909 Args : Args_List (1 .. 3);
9910 Names : constant Name_List (1 .. 3) := (
9912 Name_Task_Stack_Size_Default,
9913 Name_Time_Slicing_Enabled);
9919 Gather_Associations (Names, Args);
9921 for J in 1 .. 2 loop
9922 if Present (Args (J)) then
9923 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
9927 if Present (Args (3)) then
9928 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
9932 while Present (Nod) loop
9933 if Nkind (Nod) = N_Pragma
9934 and then Pragma_Name (Nod) = Name_Main
9936 Error_Msg_Name_1 := Pname;
9937 Error_Msg_N ("duplicate pragma% not permitted", Nod);
9948 -- pragma Main_Storage
9949 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
9951 -- MAIN_STORAGE_OPTION ::=
9952 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
9953 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
9955 when Pragma_Main_Storage => Main_Storage : declare
9956 Args : Args_List (1 .. 2);
9957 Names : constant Name_List (1 .. 2) := (
9958 Name_Working_Storage,
9965 Gather_Associations (Names, Args);
9967 for J in 1 .. 2 loop
9968 if Present (Args (J)) then
9969 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
9973 Check_In_Main_Program;
9976 while Present (Nod) loop
9977 if Nkind (Nod) = N_Pragma
9978 and then Pragma_Name (Nod) = Name_Main_Storage
9980 Error_Msg_Name_1 := Pname;
9981 Error_Msg_N ("duplicate pragma% not permitted", Nod);
9992 -- pragma Memory_Size (NUMERIC_LITERAL)
9994 when Pragma_Memory_Size =>
9997 -- Memory size is simply ignored
9999 Check_No_Identifiers;
10000 Check_Arg_Count (1);
10001 Check_Arg_Is_Integer_Literal (Arg1);
10009 -- The only correct use of this pragma is on its own in a file, in
10010 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
10011 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
10012 -- check for a file containing nothing but a No_Body pragma). If we
10013 -- attempt to process it during normal semantics processing, it means
10014 -- it was misplaced.
10016 when Pragma_No_Body =>
10024 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
10026 when Pragma_No_Return => No_Return : declare
10034 Check_At_Least_N_Arguments (1);
10036 -- Loop through arguments of pragma
10039 while Present (Arg) loop
10040 Check_Arg_Is_Local_Name (Arg);
10041 Id := Get_Pragma_Arg (Arg);
10044 if not Is_Entity_Name (Id) then
10045 Error_Pragma_Arg ("entity name required", Arg);
10048 if Etype (Id) = Any_Type then
10052 -- Loop to find matching procedures
10057 and then Scope (E) = Current_Scope
10059 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
10062 -- Set flag on any alias as well
10064 if Is_Overloadable (E) and then Present (Alias (E)) then
10065 Set_No_Return (Alias (E));
10071 exit when From_Aspect_Specification (N);
10076 Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
10087 -- pragma No_Run_Time;
10089 -- Note: this pragma is retained for backwards compatibility. See
10090 -- body of Rtsfind for full details on its handling.
10092 when Pragma_No_Run_Time =>
10094 Check_Valid_Configuration_Pragma;
10095 Check_Arg_Count (0);
10097 No_Run_Time_Mode := True;
10098 Configurable_Run_Time_Mode := True;
10100 -- Set Duration to 32 bits if word size is 32
10102 if Ttypes.System_Word_Size = 32 then
10103 Duration_32_Bits_On_Target := True;
10106 -- Set appropriate restrictions
10108 Set_Restriction (No_Finalization, N);
10109 Set_Restriction (No_Exception_Handlers, N);
10110 Set_Restriction (Max_Tasks, N, 0);
10111 Set_Restriction (No_Tasking, N);
10113 ------------------------
10114 -- No_Strict_Aliasing --
10115 ------------------------
10117 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
10119 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
10124 Check_At_Most_N_Arguments (1);
10126 if Arg_Count = 0 then
10127 Check_Valid_Configuration_Pragma;
10128 Opt.No_Strict_Aliasing := True;
10131 Check_Optional_Identifier (Arg2, Name_Entity);
10132 Check_Arg_Is_Local_Name (Arg1);
10133 E_Id := Entity (Get_Pragma_Arg (Arg1));
10135 if E_Id = Any_Type then
10137 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
10138 Error_Pragma_Arg ("pragma% requires access type", Arg1);
10141 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
10143 end No_Strict_Aliasing;
10145 -----------------------
10146 -- Normalize_Scalars --
10147 -----------------------
10149 -- pragma Normalize_Scalars;
10151 when Pragma_Normalize_Scalars =>
10152 Check_Ada_83_Warning;
10153 Check_Arg_Count (0);
10154 Check_Valid_Configuration_Pragma;
10156 -- Normalize_Scalars creates false positives in CodePeer, so
10157 -- ignore this pragma in this mode.
10159 if not CodePeer_Mode then
10160 Normalize_Scalars := True;
10161 Init_Or_Norm_Scalars := True;
10168 -- pragma Obsolescent;
10170 -- pragma Obsolescent (
10171 -- [Message =>] static_string_EXPRESSION
10172 -- [,[Version =>] Ada_05]]);
10174 -- pragma Obsolescent (
10175 -- [Entity =>] NAME
10176 -- [,[Message =>] static_string_EXPRESSION
10177 -- [,[Version =>] Ada_05]] );
10179 when Pragma_Obsolescent => Obsolescent : declare
10183 procedure Set_Obsolescent (E : Entity_Id);
10184 -- Given an entity Ent, mark it as obsolescent if appropriate
10186 ---------------------
10187 -- Set_Obsolescent --
10188 ---------------------
10190 procedure Set_Obsolescent (E : Entity_Id) is
10199 -- Entity name was given
10201 if Present (Ename) then
10203 -- If entity name matches, we are fine. Save entity in
10204 -- pragma argument, for ASIS use.
10206 if Chars (Ename) = Chars (Ent) then
10207 Set_Entity (Ename, Ent);
10208 Generate_Reference (Ent, Ename);
10210 -- If entity name does not match, only possibility is an
10211 -- enumeration literal from an enumeration type declaration.
10213 elsif Ekind (Ent) /= E_Enumeration_Type then
10215 ("pragma % entity name does not match declaration");
10218 Ent := First_Literal (E);
10222 ("pragma % entity name does not match any " &
10223 "enumeration literal");
10225 elsif Chars (Ent) = Chars (Ename) then
10226 Set_Entity (Ename, Ent);
10227 Generate_Reference (Ent, Ename);
10231 Ent := Next_Literal (Ent);
10237 -- Ent points to entity to be marked
10239 if Arg_Count >= 1 then
10241 -- Deal with static string argument
10243 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
10244 S := Strval (Get_Pragma_Arg (Arg1));
10246 for J in 1 .. String_Length (S) loop
10247 if not In_Character_Range (Get_String_Char (S, J)) then
10249 ("pragma% argument does not allow wide characters",
10254 Obsolescent_Warnings.Append
10255 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
10257 -- Check for Ada_05 parameter
10259 if Arg_Count /= 1 then
10260 Check_Arg_Count (2);
10263 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
10266 Check_Arg_Is_Identifier (Argx);
10268 if Chars (Argx) /= Name_Ada_05 then
10269 Error_Msg_Name_2 := Name_Ada_05;
10271 ("only allowed argument for pragma% is %", Argx);
10274 if Ada_Version_Explicit < Ada_2005
10275 or else not Warn_On_Ada_2005_Compatibility
10283 -- Set flag if pragma active
10286 Set_Is_Obsolescent (Ent);
10290 end Set_Obsolescent;
10292 -- Start of processing for pragma Obsolescent
10297 Check_At_Most_N_Arguments (3);
10299 -- See if first argument specifies an entity name
10303 (Chars (Arg1) = Name_Entity
10305 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
10307 N_Operator_Symbol))
10309 Ename := Get_Pragma_Arg (Arg1);
10311 -- Eliminate first argument, so we can share processing
10315 Arg_Count := Arg_Count - 1;
10317 -- No Entity name argument given
10323 if Arg_Count >= 1 then
10324 Check_Optional_Identifier (Arg1, Name_Message);
10326 if Arg_Count = 2 then
10327 Check_Optional_Identifier (Arg2, Name_Version);
10331 -- Get immediately preceding declaration
10334 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
10338 -- Cases where we do not follow anything other than another pragma
10342 -- First case: library level compilation unit declaration with
10343 -- the pragma immediately following the declaration.
10345 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
10347 (Defining_Entity (Unit (Parent (Parent (N)))));
10350 -- Case 2: library unit placement for package
10354 Ent : constant Entity_Id := Find_Lib_Unit_Name;
10356 if Is_Package_Or_Generic_Package (Ent) then
10357 Set_Obsolescent (Ent);
10363 -- Cases where we must follow a declaration
10366 if Nkind (Decl) not in N_Declaration
10367 and then Nkind (Decl) not in N_Later_Decl_Item
10368 and then Nkind (Decl) not in N_Generic_Declaration
10369 and then Nkind (Decl) not in N_Renaming_Declaration
10372 ("pragma% misplaced, "
10373 & "must immediately follow a declaration");
10376 Set_Obsolescent (Defining_Entity (Decl));
10386 -- pragma Optimize (Time | Space | Off);
10388 -- The actual check for optimize is done in Gigi. Note that this
10389 -- pragma does not actually change the optimization setting, it
10390 -- simply checks that it is consistent with the pragma.
10392 when Pragma_Optimize =>
10393 Check_No_Identifiers;
10394 Check_Arg_Count (1);
10395 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
10397 ------------------------
10398 -- Optimize_Alignment --
10399 ------------------------
10401 -- pragma Optimize_Alignment (Time | Space | Off);
10403 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
10405 Check_No_Identifiers;
10406 Check_Arg_Count (1);
10407 Check_Valid_Configuration_Pragma;
10410 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
10414 Opt.Optimize_Alignment := 'T';
10416 Opt.Optimize_Alignment := 'S';
10418 Opt.Optimize_Alignment := 'O';
10420 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
10424 -- Set indication that mode is set locally. If we are in fact in a
10425 -- configuration pragma file, this setting is harmless since the
10426 -- switch will get reset anyway at the start of each unit.
10428 Optimize_Alignment_Local := True;
10429 end Optimize_Alignment;
10435 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
10437 when Pragma_Ordered => Ordered : declare
10438 Assoc : constant Node_Id := Arg1;
10444 Check_No_Identifiers;
10445 Check_Arg_Count (1);
10446 Check_Arg_Is_Local_Name (Arg1);
10448 Type_Id := Get_Pragma_Arg (Assoc);
10449 Find_Type (Type_Id);
10450 Typ := Entity (Type_Id);
10452 if Typ = Any_Type then
10455 Typ := Underlying_Type (Typ);
10458 if not Is_Enumeration_Type (Typ) then
10459 Error_Pragma ("pragma% must specify enumeration type");
10462 Check_First_Subtype (Arg1);
10463 Set_Has_Pragma_Ordered (Base_Type (Typ));
10470 -- pragma Pack (first_subtype_LOCAL_NAME);
10472 when Pragma_Pack => Pack : declare
10473 Assoc : constant Node_Id := Arg1;
10477 Ignore : Boolean := False;
10480 Check_No_Identifiers;
10481 Check_Arg_Count (1);
10482 Check_Arg_Is_Local_Name (Arg1);
10484 Type_Id := Get_Pragma_Arg (Assoc);
10485 Find_Type (Type_Id);
10486 Typ := Entity (Type_Id);
10489 or else Rep_Item_Too_Early (Typ, N)
10493 Typ := Underlying_Type (Typ);
10496 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
10497 Error_Pragma ("pragma% must specify array or record type");
10500 Check_First_Subtype (Arg1);
10501 Check_Duplicate_Pragma (Typ);
10505 if Is_Array_Type (Typ) then
10506 Ctyp := Component_Type (Typ);
10508 -- Ignore pack that does nothing
10510 if Known_Static_Esize (Ctyp)
10511 and then Known_Static_RM_Size (Ctyp)
10512 and then Esize (Ctyp) = RM_Size (Ctyp)
10513 and then Addressable (Esize (Ctyp))
10518 -- Process OK pragma Pack. Note that if there is a separate
10519 -- component clause present, the Pack will be cancelled. This
10520 -- processing is in Freeze.
10522 if not Rep_Item_Too_Late (Typ, N) then
10524 -- In the context of static code analysis, we do not need
10525 -- complex front-end expansions related to pragma Pack,
10526 -- so disable handling of pragma Pack in this case.
10528 if CodePeer_Mode then
10531 -- Don't attempt any packing for VM targets. We possibly
10532 -- could deal with some cases of array bit-packing, but we
10533 -- don't bother, since this is not a typical kind of
10534 -- representation in the VM context anyway (and would not
10535 -- for example work nicely with the debugger).
10537 elsif VM_Target /= No_VM then
10538 if not GNAT_Mode then
10540 ("?pragma% ignored in this configuration");
10543 -- Normal case where we do the pack action
10547 Set_Is_Packed (Base_Type (Typ), Sense);
10548 Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense);
10551 Set_Has_Pragma_Pack (Base_Type (Typ), Sense);
10553 -- Complete reset action for Aspect_Cancel case
10555 if Sense = False then
10557 -- Cancel size unless explicitly set
10559 if not Has_Size_Clause (Typ)
10560 and then not Has_Object_Size_Clause (Typ)
10562 Set_Esize (Typ, Uint_0);
10563 Set_RM_Size (Typ, Uint_0);
10564 Set_Alignment (Typ, Uint_0);
10565 Set_Packed_Array_Type (Typ, Empty);
10568 -- Reset component size unless explicitly set
10570 if not Has_Component_Size_Clause (Typ) then
10571 if Known_Static_Esize (Ctyp)
10572 and then Known_Static_RM_Size (Ctyp)
10573 and then Esize (Ctyp) = RM_Size (Ctyp)
10574 and then Addressable (Esize (Ctyp))
10577 (Base_Type (Typ), Esize (Ctyp));
10580 (Base_Type (Typ), Uint_0);
10587 -- For record types, the pack is always effective
10589 else pragma Assert (Is_Record_Type (Typ));
10590 if not Rep_Item_Too_Late (Typ, N) then
10592 -- Ignore pack request with warning in VM mode (skip warning
10593 -- if we are compiling GNAT run time library).
10595 if VM_Target /= No_VM then
10596 if not GNAT_Mode then
10598 ("?pragma% ignored in this configuration");
10601 -- Normal case of pack request active
10604 Set_Is_Packed (Base_Type (Typ), Sense);
10605 Set_Has_Pragma_Pack (Base_Type (Typ), Sense);
10606 Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense);
10608 -- Complete reset action for Aspect_Cancel case
10610 if Sense = False then
10612 -- Cancel size if not explicitly given
10614 if not Has_Size_Clause (Typ)
10615 and then not Has_Object_Size_Clause (Typ)
10617 Set_Esize (Typ, Uint_0);
10618 Set_Alignment (Typ, Uint_0);
10632 -- There is nothing to do here, since we did all the processing for
10633 -- this pragma in Par.Prag (so that it works properly even in syntax
10636 when Pragma_Page =>
10643 -- pragma Passive [(PASSIVE_FORM)];
10645 -- PASSIVE_FORM ::= Semaphore | No
10647 when Pragma_Passive =>
10650 if Nkind (Parent (N)) /= N_Task_Definition then
10651 Error_Pragma ("pragma% must be within task definition");
10654 if Arg_Count /= 0 then
10655 Check_Arg_Count (1);
10656 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
10659 ----------------------------------
10660 -- Preelaborable_Initialization --
10661 ----------------------------------
10663 -- pragma Preelaborable_Initialization (DIRECT_NAME);
10665 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
10670 Check_Arg_Count (1);
10671 Check_No_Identifiers;
10672 Check_Arg_Is_Identifier (Arg1);
10673 Check_Arg_Is_Local_Name (Arg1);
10674 Check_First_Subtype (Arg1);
10675 Ent := Entity (Get_Pragma_Arg (Arg1));
10677 if not Is_Private_Type (Ent)
10678 and then not Is_Protected_Type (Ent)
10681 ("pragma % can only be applied to private or protected type",
10685 -- Give an error if the pragma is applied to a protected type that
10686 -- does not qualify (due to having entries, or due to components
10687 -- that do not qualify).
10689 if Is_Protected_Type (Ent)
10690 and then not Has_Preelaborable_Initialization (Ent)
10693 ("protected type & does not have preelaborable " &
10694 "initialization", Ent);
10696 -- Otherwise mark the type as definitely having preelaborable
10700 Set_Known_To_Have_Preelab_Init (Ent);
10703 if Has_Pragma_Preelab_Init (Ent)
10704 and then Warn_On_Redundant_Constructs
10706 Error_Pragma ("?duplicate pragma%!");
10708 Set_Has_Pragma_Preelab_Init (Ent);
10712 --------------------
10713 -- Persistent_BSS --
10714 --------------------
10716 -- pragma Persistent_BSS [(object_NAME)];
10718 when Pragma_Persistent_BSS => Persistent_BSS : declare
10725 Check_At_Most_N_Arguments (1);
10727 -- Case of application to specific object (one argument)
10729 if Arg_Count = 1 then
10730 Check_Arg_Is_Library_Level_Local_Name (Arg1);
10732 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
10734 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
10737 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
10740 Ent := Entity (Get_Pragma_Arg (Arg1));
10741 Decl := Parent (Ent);
10743 if Rep_Item_Too_Late (Ent, N) then
10747 if Present (Expression (Decl)) then
10749 ("object for pragma% cannot have initialization", Arg1);
10752 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
10754 ("object type for pragma% is not potentially persistent",
10758 Check_Duplicate_Pragma (Ent);
10762 Make_Linker_Section_Pragma
10763 (Ent, Sloc (N), ".persistent.bss");
10764 Insert_After (N, Prag);
10768 -- Case of use as configuration pragma with no arguments
10771 Check_Valid_Configuration_Pragma;
10772 Persistent_BSS_Mode := True;
10774 end Persistent_BSS;
10780 -- pragma Polling (ON | OFF);
10782 when Pragma_Polling =>
10784 Check_Arg_Count (1);
10785 Check_No_Identifiers;
10786 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
10787 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
10789 -------------------
10790 -- Postcondition --
10791 -------------------
10793 -- pragma Postcondition ([Check =>] Boolean_Expression
10794 -- [,[Message =>] String_Expression]);
10796 when Pragma_Postcondition => Postcondition : declare
10798 pragma Warnings (Off, In_Body);
10802 Check_At_Least_N_Arguments (1);
10803 Check_At_Most_N_Arguments (2);
10804 Check_Optional_Identifier (Arg1, Name_Check);
10806 -- All we need to do here is call the common check procedure,
10807 -- the remainder of the processing is found in Sem_Ch6/Sem_Ch7.
10809 Check_Precondition_Postcondition (In_Body);
10816 -- pragma Precondition ([Check =>] Boolean_Expression
10817 -- [,[Message =>] String_Expression]);
10819 when Pragma_Precondition => Precondition : declare
10824 Check_At_Least_N_Arguments (1);
10825 Check_At_Most_N_Arguments (2);
10826 Check_Optional_Identifier (Arg1, Name_Check);
10827 Check_Precondition_Postcondition (In_Body);
10829 -- If in spec, nothing more to do. If in body, then we convert the
10830 -- pragma to pragma Check (Precondition, cond [, msg]). Note we do
10831 -- this whether or not precondition checks are enabled. That works
10832 -- fine since pragma Check will do this check, and will also
10833 -- analyze the condition itself in the proper context.
10838 Chars => Name_Check,
10839 Pragma_Argument_Associations => New_List (
10840 Make_Pragma_Argument_Association (Loc,
10842 Make_Identifier (Loc,
10843 Chars => Name_Precondition)),
10845 Make_Pragma_Argument_Association (Sloc (Arg1),
10846 Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
10848 if Arg_Count = 2 then
10849 Append_To (Pragma_Argument_Associations (N),
10850 Make_Pragma_Argument_Association (Sloc (Arg2),
10851 Expression => Relocate_Node (Get_Pragma_Arg (Arg2))));
10862 -- pragma Preelaborate [(library_unit_NAME)];
10864 -- Set the flag Is_Preelaborated of program unit name entity
10866 when Pragma_Preelaborate => Preelaborate : declare
10867 Pa : constant Node_Id := Parent (N);
10868 Pk : constant Node_Kind := Nkind (Pa);
10872 Check_Ada_83_Warning;
10873 Check_Valid_Library_Unit_Pragma;
10875 if Nkind (N) = N_Null_Statement then
10879 Ent := Find_Lib_Unit_Name;
10880 Check_Duplicate_Pragma (Ent);
10882 -- This filters out pragmas inside generic parent then
10883 -- show up inside instantiation
10886 and then not (Pk = N_Package_Specification
10887 and then Present (Generic_Parent (Pa)))
10889 if not Debug_Flag_U then
10890 Set_Is_Preelaborated (Ent, Sense);
10891 Set_Suppress_Elaboration_Warnings (Ent, Sense);
10896 ---------------------
10897 -- Preelaborate_05 --
10898 ---------------------
10900 -- pragma Preelaborate_05 [(library_unit_NAME)];
10902 -- This pragma is useable only in GNAT_Mode, where it is used like
10903 -- pragma Preelaborate but it is only effective in Ada 2005 mode
10904 -- (otherwise it is ignored). This is used to implement AI-362 which
10905 -- recategorizes some run-time packages in Ada 2005 mode.
10907 when Pragma_Preelaborate_05 => Preelaborate_05 : declare
10912 Check_Valid_Library_Unit_Pragma;
10914 if not GNAT_Mode then
10915 Error_Pragma ("pragma% only available in GNAT mode");
10918 if Nkind (N) = N_Null_Statement then
10922 -- This is one of the few cases where we need to test the value of
10923 -- Ada_Version_Explicit rather than Ada_Version (which is always
10924 -- set to Ada_2012 in a predefined unit), we need to know the
10925 -- explicit version set to know if this pragma is active.
10927 if Ada_Version_Explicit >= Ada_2005 then
10928 Ent := Find_Lib_Unit_Name;
10929 Set_Is_Preelaborated (Ent);
10930 Set_Suppress_Elaboration_Warnings (Ent);
10932 end Preelaborate_05;
10938 -- pragma Priority (EXPRESSION);
10940 when Pragma_Priority => Priority : declare
10941 P : constant Node_Id := Parent (N);
10945 Check_No_Identifiers;
10946 Check_Arg_Count (1);
10950 if Nkind (P) = N_Subprogram_Body then
10951 Check_In_Main_Program;
10953 Arg := Get_Pragma_Arg (Arg1);
10954 Analyze_And_Resolve (Arg, Standard_Integer);
10958 if not Is_Static_Expression (Arg) then
10959 Flag_Non_Static_Expr
10960 ("main subprogram priority is not static!", Arg);
10963 -- If constraint error, then we already signalled an error
10965 elsif Raises_Constraint_Error (Arg) then
10968 -- Otherwise check in range
10972 Val : constant Uint := Expr_Value (Arg);
10976 or else Val > Expr_Value (Expression
10977 (Parent (RTE (RE_Max_Priority))))
10980 ("main subprogram priority is out of range", Arg1);
10986 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
10988 -- Load an arbitrary entity from System.Tasking to make sure
10989 -- this package is implicitly with'ed, since we need to have
10990 -- the tasking run-time active for the pragma Priority to have
10994 Discard : Entity_Id;
10995 pragma Warnings (Off, Discard);
10997 Discard := RTE (RE_Task_List);
11000 -- Task or Protected, must be of type Integer
11002 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
11003 Arg := Get_Pragma_Arg (Arg1);
11005 -- The expression must be analyzed in the special manner
11006 -- described in "Handling of Default and Per-Object
11007 -- Expressions" in sem.ads.
11009 Preanalyze_Spec_Expression (Arg, Standard_Integer);
11011 if not Is_Static_Expression (Arg) then
11012 Check_Restriction (Static_Priorities, Arg);
11015 -- Anything else is incorrect
11021 if Has_Pragma_Priority (P) then
11022 Error_Pragma ("duplicate pragma% not allowed");
11024 Set_Has_Pragma_Priority (P, True);
11026 if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
11027 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
11028 -- exp_ch9 should use this ???
11033 -----------------------------------
11034 -- Priority_Specific_Dispatching --
11035 -----------------------------------
11037 -- pragma Priority_Specific_Dispatching (
11038 -- policy_IDENTIFIER,
11039 -- first_priority_EXPRESSION,
11040 -- last_priority_EXPRESSION);
11042 when Pragma_Priority_Specific_Dispatching =>
11043 Priority_Specific_Dispatching : declare
11044 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
11045 -- This is the entity System.Any_Priority;
11048 Lower_Bound : Node_Id;
11049 Upper_Bound : Node_Id;
11055 Check_Arg_Count (3);
11056 Check_No_Identifiers;
11057 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
11058 Check_Valid_Configuration_Pragma;
11059 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
11060 DP := Fold_Upper (Name_Buffer (1));
11062 Lower_Bound := Get_Pragma_Arg (Arg2);
11063 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
11064 Lower_Val := Expr_Value (Lower_Bound);
11066 Upper_Bound := Get_Pragma_Arg (Arg3);
11067 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
11068 Upper_Val := Expr_Value (Upper_Bound);
11070 -- It is not allowed to use Task_Dispatching_Policy and
11071 -- Priority_Specific_Dispatching in the same partition.
11073 if Task_Dispatching_Policy /= ' ' then
11074 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11076 ("pragma% incompatible with Task_Dispatching_Policy#");
11078 -- Check lower bound in range
11080 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
11082 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
11085 ("first_priority is out of range", Arg2);
11087 -- Check upper bound in range
11089 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
11091 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
11094 ("last_priority is out of range", Arg3);
11096 -- Check that the priority range is valid
11098 elsif Lower_Val > Upper_Val then
11100 ("last_priority_expression must be greater than" &
11101 " or equal to first_priority_expression");
11103 -- Store the new policy, but always preserve System_Location since
11104 -- we like the error message with the run-time name.
11107 -- Check overlapping in the priority ranges specified in other
11108 -- Priority_Specific_Dispatching pragmas within the same
11109 -- partition. We can only check those we know about!
11112 Specific_Dispatching.First .. Specific_Dispatching.Last
11114 if Specific_Dispatching.Table (J).First_Priority in
11115 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
11116 or else Specific_Dispatching.Table (J).Last_Priority in
11117 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
11120 Specific_Dispatching.Table (J).Pragma_Loc;
11122 ("priority range overlaps with "
11123 & "Priority_Specific_Dispatching#");
11127 -- The use of Priority_Specific_Dispatching is incompatible
11128 -- with Task_Dispatching_Policy.
11130 if Task_Dispatching_Policy /= ' ' then
11131 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11133 ("Priority_Specific_Dispatching incompatible "
11134 & "with Task_Dispatching_Policy#");
11137 -- The use of Priority_Specific_Dispatching forces ceiling
11140 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
11141 Error_Msg_Sloc := Locking_Policy_Sloc;
11143 ("Priority_Specific_Dispatching incompatible "
11144 & "with Locking_Policy#");
11146 -- Set the Ceiling_Locking policy, but preserve System_Location
11147 -- since we like the error message with the run time name.
11150 Locking_Policy := 'C';
11152 if Locking_Policy_Sloc /= System_Location then
11153 Locking_Policy_Sloc := Loc;
11157 -- Add entry in the table
11159 Specific_Dispatching.Append
11160 ((Dispatching_Policy => DP,
11161 First_Priority => UI_To_Int (Lower_Val),
11162 Last_Priority => UI_To_Int (Upper_Val),
11163 Pragma_Loc => Loc));
11165 end Priority_Specific_Dispatching;
11171 -- pragma Profile (profile_IDENTIFIER);
11173 -- profile_IDENTIFIER => Restricted | Ravenscar
11175 when Pragma_Profile =>
11177 Check_Arg_Count (1);
11178 Check_Valid_Configuration_Pragma;
11179 Check_No_Identifiers;
11182 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
11184 if Chars (Argx) = Name_Ravenscar then
11185 Set_Ravenscar_Profile (N);
11186 elsif Chars (Argx) = Name_Restricted then
11187 Set_Profile_Restrictions
11188 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
11190 Error_Pragma_Arg ("& is not a valid profile", Argx);
11194 ----------------------
11195 -- Profile_Warnings --
11196 ----------------------
11198 -- pragma Profile_Warnings (profile_IDENTIFIER);
11200 -- profile_IDENTIFIER => Restricted | Ravenscar
11202 when Pragma_Profile_Warnings =>
11204 Check_Arg_Count (1);
11205 Check_Valid_Configuration_Pragma;
11206 Check_No_Identifiers;
11209 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
11211 if Chars (Argx) = Name_Ravenscar then
11212 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
11213 elsif Chars (Argx) = Name_Restricted then
11214 Set_Profile_Restrictions (Restricted, N, Warn => True);
11216 Error_Pragma_Arg ("& is not a valid profile", Argx);
11220 --------------------------
11221 -- Propagate_Exceptions --
11222 --------------------------
11224 -- pragma Propagate_Exceptions;
11226 -- Note: this pragma is obsolete and has no effect
11228 when Pragma_Propagate_Exceptions =>
11230 Check_Arg_Count (0);
11232 if In_Extended_Main_Source_Unit (N) then
11233 Propagate_Exceptions := True;
11240 -- pragma Psect_Object (
11241 -- [Internal =>] LOCAL_NAME,
11242 -- [, [External =>] EXTERNAL_SYMBOL]
11243 -- [, [Size =>] EXTERNAL_SYMBOL]);
11245 when Pragma_Psect_Object | Pragma_Common_Object =>
11246 Psect_Object : declare
11247 Args : Args_List (1 .. 3);
11248 Names : constant Name_List (1 .. 3) := (
11253 Internal : Node_Id renames Args (1);
11254 External : Node_Id renames Args (2);
11255 Size : Node_Id renames Args (3);
11257 Def_Id : Entity_Id;
11259 procedure Check_Too_Long (Arg : Node_Id);
11260 -- Posts message if the argument is an identifier with more
11261 -- than 31 characters, or a string literal with more than
11262 -- 31 characters, and we are operating under VMS
11264 --------------------
11265 -- Check_Too_Long --
11266 --------------------
11268 procedure Check_Too_Long (Arg : Node_Id) is
11269 X : constant Node_Id := Original_Node (Arg);
11272 if not Nkind_In (X, N_String_Literal, N_Identifier) then
11274 ("inappropriate argument for pragma %", Arg);
11277 if OpenVMS_On_Target then
11278 if (Nkind (X) = N_String_Literal
11279 and then String_Length (Strval (X)) > 31)
11281 (Nkind (X) = N_Identifier
11282 and then Length_Of_Name (Chars (X)) > 31)
11285 ("argument for pragma % is longer than 31 characters",
11289 end Check_Too_Long;
11291 -- Start of processing for Common_Object/Psect_Object
11295 Gather_Associations (Names, Args);
11296 Process_Extended_Import_Export_Internal_Arg (Internal);
11298 Def_Id := Entity (Internal);
11300 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
11302 ("pragma% must designate an object", Internal);
11305 Check_Too_Long (Internal);
11307 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
11309 ("cannot use pragma% for imported/exported object",
11313 if Is_Concurrent_Type (Etype (Internal)) then
11315 ("cannot specify pragma % for task/protected object",
11319 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
11321 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
11323 Error_Msg_N ("?duplicate Common/Psect_Object pragma", N);
11326 if Ekind (Def_Id) = E_Constant then
11328 ("cannot specify pragma % for a constant", Internal);
11331 if Is_Record_Type (Etype (Internal)) then
11337 Ent := First_Entity (Etype (Internal));
11338 while Present (Ent) loop
11339 Decl := Declaration_Node (Ent);
11341 if Ekind (Ent) = E_Component
11342 and then Nkind (Decl) = N_Component_Declaration
11343 and then Present (Expression (Decl))
11344 and then Warn_On_Export_Import
11347 ("?object for pragma % has defaults", Internal);
11357 if Present (Size) then
11358 Check_Too_Long (Size);
11361 if Present (External) then
11362 Check_Arg_Is_External_Name (External);
11363 Check_Too_Long (External);
11366 -- If all error tests pass, link pragma on to the rep item chain
11368 Record_Rep_Item (Def_Id, N);
11375 -- pragma Pure [(library_unit_NAME)];
11377 when Pragma_Pure => Pure : declare
11381 Check_Ada_83_Warning;
11382 Check_Valid_Library_Unit_Pragma;
11384 if Nkind (N) = N_Null_Statement then
11388 Ent := Find_Lib_Unit_Name;
11390 Set_Has_Pragma_Pure (Ent);
11391 Set_Suppress_Elaboration_Warnings (Ent);
11398 -- pragma Pure_05 [(library_unit_NAME)];
11400 -- This pragma is useable only in GNAT_Mode, where it is used like
11401 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
11402 -- it is ignored). It may be used after a pragma Preelaborate, in
11403 -- which case it overrides the effect of the pragma Preelaborate.
11404 -- This is used to implement AI-362 which recategorizes some run-time
11405 -- packages in Ada 2005 mode.
11407 when Pragma_Pure_05 => Pure_05 : declare
11412 Check_Valid_Library_Unit_Pragma;
11414 if not GNAT_Mode then
11415 Error_Pragma ("pragma% only available in GNAT mode");
11418 if Nkind (N) = N_Null_Statement then
11422 -- This is one of the few cases where we need to test the value of
11423 -- Ada_Version_Explicit rather than Ada_Version (which is always
11424 -- set to Ada_2012 in a predefined unit), we need to know the
11425 -- explicit version set to know if this pragma is active.
11427 if Ada_Version_Explicit >= Ada_2005 then
11428 Ent := Find_Lib_Unit_Name;
11429 Set_Is_Preelaborated (Ent, False);
11431 Set_Suppress_Elaboration_Warnings (Ent);
11435 -------------------
11436 -- Pure_Function --
11437 -------------------
11439 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
11441 when Pragma_Pure_Function => Pure_Function : declare
11444 Def_Id : Entity_Id;
11445 Effective : Boolean := False;
11449 Check_Arg_Count (1);
11450 Check_Optional_Identifier (Arg1, Name_Entity);
11451 Check_Arg_Is_Local_Name (Arg1);
11452 E_Id := Get_Pragma_Arg (Arg1);
11454 if Error_Posted (E_Id) then
11458 -- Loop through homonyms (overloadings) of referenced entity
11460 E := Entity (E_Id);
11462 if Present (E) then
11464 Def_Id := Get_Base_Subprogram (E);
11466 if not Ekind_In (Def_Id, E_Function,
11467 E_Generic_Function,
11471 ("pragma% requires a function name", Arg1);
11474 Set_Is_Pure (Def_Id, Sense);
11476 if not Has_Pragma_Pure_Function (Def_Id) then
11477 Set_Has_Pragma_Pure_Function (Def_Id, Sense);
11478 Effective := Sense;
11481 exit when From_Aspect_Specification (N);
11483 exit when No (E) or else Scope (E) /= Current_Scope;
11486 if Sense and then not Effective
11487 and then Warn_On_Redundant_Constructs
11490 ("pragma Pure_Function on& is redundant?",
11496 --------------------
11497 -- Queuing_Policy --
11498 --------------------
11500 -- pragma Queuing_Policy (policy_IDENTIFIER);
11502 when Pragma_Queuing_Policy => declare
11506 Check_Ada_83_Warning;
11507 Check_Arg_Count (1);
11508 Check_No_Identifiers;
11509 Check_Arg_Is_Queuing_Policy (Arg1);
11510 Check_Valid_Configuration_Pragma;
11511 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
11512 QP := Fold_Upper (Name_Buffer (1));
11514 if Queuing_Policy /= ' '
11515 and then Queuing_Policy /= QP
11517 Error_Msg_Sloc := Queuing_Policy_Sloc;
11518 Error_Pragma ("queuing policy incompatible with policy#");
11520 -- Set new policy, but always preserve System_Location since we
11521 -- like the error message with the run time name.
11524 Queuing_Policy := QP;
11526 if Queuing_Policy_Sloc /= System_Location then
11527 Queuing_Policy_Sloc := Loc;
11532 -----------------------
11533 -- Relative_Deadline --
11534 -----------------------
11536 -- pragma Relative_Deadline (time_span_EXPRESSION);
11538 when Pragma_Relative_Deadline => Relative_Deadline : declare
11539 P : constant Node_Id := Parent (N);
11544 Check_No_Identifiers;
11545 Check_Arg_Count (1);
11547 Arg := Get_Pragma_Arg (Arg1);
11549 -- The expression must be analyzed in the special manner described
11550 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
11552 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
11556 if Nkind (P) = N_Subprogram_Body then
11557 Check_In_Main_Program;
11561 elsif Nkind (P) = N_Task_Definition then
11564 -- Anything else is incorrect
11570 if Has_Relative_Deadline_Pragma (P) then
11571 Error_Pragma ("duplicate pragma% not allowed");
11573 Set_Has_Relative_Deadline_Pragma (P, True);
11575 if Nkind (P) = N_Task_Definition then
11576 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
11579 end Relative_Deadline;
11581 ---------------------------
11582 -- Remote_Call_Interface --
11583 ---------------------------
11585 -- pragma Remote_Call_Interface [(library_unit_NAME)];
11587 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
11588 Cunit_Node : Node_Id;
11589 Cunit_Ent : Entity_Id;
11593 Check_Ada_83_Warning;
11594 Check_Valid_Library_Unit_Pragma;
11596 if Nkind (N) = N_Null_Statement then
11600 Cunit_Node := Cunit (Current_Sem_Unit);
11601 K := Nkind (Unit (Cunit_Node));
11602 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
11604 if K = N_Package_Declaration
11605 or else K = N_Generic_Package_Declaration
11606 or else K = N_Subprogram_Declaration
11607 or else K = N_Generic_Subprogram_Declaration
11608 or else (K = N_Subprogram_Body
11609 and then Acts_As_Spec (Unit (Cunit_Node)))
11614 "pragma% must apply to package or subprogram declaration");
11617 Set_Is_Remote_Call_Interface (Cunit_Ent);
11618 end Remote_Call_Interface;
11624 -- pragma Remote_Types [(library_unit_NAME)];
11626 when Pragma_Remote_Types => Remote_Types : declare
11627 Cunit_Node : Node_Id;
11628 Cunit_Ent : Entity_Id;
11631 Check_Ada_83_Warning;
11632 Check_Valid_Library_Unit_Pragma;
11634 if Nkind (N) = N_Null_Statement then
11638 Cunit_Node := Cunit (Current_Sem_Unit);
11639 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
11641 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
11642 N_Generic_Package_Declaration)
11645 ("pragma% can only apply to a package declaration");
11648 Set_Is_Remote_Types (Cunit_Ent);
11655 -- pragma Ravenscar;
11657 when Pragma_Ravenscar =>
11659 Check_Arg_Count (0);
11660 Check_Valid_Configuration_Pragma;
11661 Set_Ravenscar_Profile (N);
11663 if Warn_On_Obsolescent_Feature then
11664 Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N);
11665 Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N);
11668 -------------------------
11669 -- Restricted_Run_Time --
11670 -------------------------
11672 -- pragma Restricted_Run_Time;
11674 when Pragma_Restricted_Run_Time =>
11676 Check_Arg_Count (0);
11677 Check_Valid_Configuration_Pragma;
11678 Set_Profile_Restrictions
11679 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
11681 if Warn_On_Obsolescent_Feature then
11683 ("pragma Restricted_Run_Time is an obsolescent feature?", N);
11684 Error_Msg_N ("|use pragma Profile (Restricted) instead", N);
11691 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
11694 -- restriction_IDENTIFIER
11695 -- | restriction_parameter_IDENTIFIER => EXPRESSION
11697 when Pragma_Restrictions =>
11698 Process_Restrictions_Or_Restriction_Warnings
11699 (Warn => Treat_Restrictions_As_Warnings);
11701 --------------------------
11702 -- Restriction_Warnings --
11703 --------------------------
11705 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
11708 -- restriction_IDENTIFIER
11709 -- | restriction_parameter_IDENTIFIER => EXPRESSION
11711 when Pragma_Restriction_Warnings =>
11713 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
11719 -- pragma Reviewable;
11721 when Pragma_Reviewable =>
11722 Check_Ada_83_Warning;
11723 Check_Arg_Count (0);
11725 -- Call dummy debugging function rv. This is done to assist front
11726 -- end debugging. By placing a Reviewable pragma in the source
11727 -- program, a breakpoint on rv catches this place in the source,
11728 -- allowing convenient stepping to the point of interest.
11732 --------------------------
11733 -- Short_Circuit_And_Or --
11734 --------------------------
11736 when Pragma_Short_Circuit_And_Or =>
11738 Check_Arg_Count (0);
11739 Check_Valid_Configuration_Pragma;
11740 Short_Circuit_And_Or := True;
11742 -------------------
11743 -- Share_Generic --
11744 -------------------
11746 -- pragma Share_Generic (NAME {, NAME});
11748 when Pragma_Share_Generic =>
11750 Process_Generic_List;
11756 -- pragma Shared (LOCAL_NAME);
11758 when Pragma_Shared =>
11760 Process_Atomic_Shared_Volatile;
11762 --------------------
11763 -- Shared_Passive --
11764 --------------------
11766 -- pragma Shared_Passive [(library_unit_NAME)];
11768 -- Set the flag Is_Shared_Passive of program unit name entity
11770 when Pragma_Shared_Passive => Shared_Passive : declare
11771 Cunit_Node : Node_Id;
11772 Cunit_Ent : Entity_Id;
11775 Check_Ada_83_Warning;
11776 Check_Valid_Library_Unit_Pragma;
11778 if Nkind (N) = N_Null_Statement then
11782 Cunit_Node := Cunit (Current_Sem_Unit);
11783 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
11785 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
11786 N_Generic_Package_Declaration)
11789 ("pragma% can only apply to a package declaration");
11792 Set_Is_Shared_Passive (Cunit_Ent);
11793 end Shared_Passive;
11795 -----------------------
11796 -- Short_Descriptors --
11797 -----------------------
11799 -- pragma Short_Descriptors;
11801 when Pragma_Short_Descriptors =>
11803 Check_Arg_Count (0);
11804 Check_Valid_Configuration_Pragma;
11805 Short_Descriptors := True;
11807 ----------------------
11808 -- Source_File_Name --
11809 ----------------------
11811 -- There are five forms for this pragma:
11813 -- pragma Source_File_Name (
11814 -- [UNIT_NAME =>] unit_NAME,
11815 -- BODY_FILE_NAME => STRING_LITERAL
11816 -- [, [INDEX =>] INTEGER_LITERAL]);
11818 -- pragma Source_File_Name (
11819 -- [UNIT_NAME =>] unit_NAME,
11820 -- SPEC_FILE_NAME => STRING_LITERAL
11821 -- [, [INDEX =>] INTEGER_LITERAL]);
11823 -- pragma Source_File_Name (
11824 -- BODY_FILE_NAME => STRING_LITERAL
11825 -- [, DOT_REPLACEMENT => STRING_LITERAL]
11826 -- [, CASING => CASING_SPEC]);
11828 -- pragma Source_File_Name (
11829 -- SPEC_FILE_NAME => STRING_LITERAL
11830 -- [, DOT_REPLACEMENT => STRING_LITERAL]
11831 -- [, CASING => CASING_SPEC]);
11833 -- pragma Source_File_Name (
11834 -- SUBUNIT_FILE_NAME => STRING_LITERAL
11835 -- [, DOT_REPLACEMENT => STRING_LITERAL]
11836 -- [, CASING => CASING_SPEC]);
11838 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
11840 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
11841 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
11842 -- only be used when no project file is used, while SFNP can only be
11843 -- used when a project file is used.
11845 -- No processing here. Processing was completed during parsing, since
11846 -- we need to have file names set as early as possible. Units are
11847 -- loaded well before semantic processing starts.
11849 -- The only processing we defer to this point is the check for
11850 -- correct placement.
11852 when Pragma_Source_File_Name =>
11854 Check_Valid_Configuration_Pragma;
11856 ------------------------------
11857 -- Source_File_Name_Project --
11858 ------------------------------
11860 -- See Source_File_Name for syntax
11862 -- No processing here. Processing was completed during parsing, since
11863 -- we need to have file names set as early as possible. Units are
11864 -- loaded well before semantic processing starts.
11866 -- The only processing we defer to this point is the check for
11867 -- correct placement.
11869 when Pragma_Source_File_Name_Project =>
11871 Check_Valid_Configuration_Pragma;
11873 -- Check that a pragma Source_File_Name_Project is used only in a
11874 -- configuration pragmas file.
11876 -- Pragmas Source_File_Name_Project should only be generated by
11877 -- the Project Manager in configuration pragmas files.
11879 -- This is really an ugly test. It seems to depend on some
11880 -- accidental and undocumented property. At the very least it
11881 -- needs to be documented, but it would be better to have a
11882 -- clean way of testing if we are in a configuration file???
11884 if Present (Parent (N)) then
11886 ("pragma% can only appear in a configuration pragmas file");
11889 ----------------------
11890 -- Source_Reference --
11891 ----------------------
11893 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
11895 -- Nothing to do, all processing completed in Par.Prag, since we need
11896 -- the information for possible parser messages that are output.
11898 when Pragma_Source_Reference =>
11901 --------------------------------
11902 -- Static_Elaboration_Desired --
11903 --------------------------------
11905 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
11907 when Pragma_Static_Elaboration_Desired =>
11909 Check_At_Most_N_Arguments (1);
11911 if Is_Compilation_Unit (Current_Scope)
11912 and then Ekind (Current_Scope) = E_Package
11914 Set_Static_Elaboration_Desired (Current_Scope, True);
11916 Error_Pragma ("pragma% must apply to a library-level package");
11923 -- pragma Storage_Size (EXPRESSION);
11925 when Pragma_Storage_Size => Storage_Size : declare
11926 P : constant Node_Id := Parent (N);
11930 Check_No_Identifiers;
11931 Check_Arg_Count (1);
11933 -- The expression must be analyzed in the special manner described
11934 -- in "Handling of Default Expressions" in sem.ads.
11936 Arg := Get_Pragma_Arg (Arg1);
11937 Preanalyze_Spec_Expression (Arg, Any_Integer);
11939 if not Is_Static_Expression (Arg) then
11940 Check_Restriction (Static_Storage_Size, Arg);
11943 if Nkind (P) /= N_Task_Definition then
11948 if Has_Storage_Size_Pragma (P) then
11949 Error_Pragma ("duplicate pragma% not allowed");
11951 Set_Has_Storage_Size_Pragma (P, True);
11954 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
11955 -- ??? exp_ch9 should use this!
11963 -- pragma Storage_Unit (NUMERIC_LITERAL);
11965 -- Only permitted argument is System'Storage_Unit value
11967 when Pragma_Storage_Unit =>
11968 Check_No_Identifiers;
11969 Check_Arg_Count (1);
11970 Check_Arg_Is_Integer_Literal (Arg1);
11972 if Intval (Get_Pragma_Arg (Arg1)) /=
11973 UI_From_Int (Ttypes.System_Storage_Unit)
11975 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
11977 ("the only allowed argument for pragma% is ^", Arg1);
11980 --------------------
11981 -- Stream_Convert --
11982 --------------------
11984 -- pragma Stream_Convert (
11985 -- [Entity =>] type_LOCAL_NAME,
11986 -- [Read =>] function_NAME,
11987 -- [Write =>] function NAME);
11989 when Pragma_Stream_Convert => Stream_Convert : declare
11991 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
11992 -- Check that the given argument is the name of a local function
11993 -- of one argument that is not overloaded earlier in the current
11994 -- local scope. A check is also made that the argument is a
11995 -- function with one parameter.
11997 --------------------------------------
11998 -- Check_OK_Stream_Convert_Function --
11999 --------------------------------------
12001 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
12005 Check_Arg_Is_Local_Name (Arg);
12006 Ent := Entity (Get_Pragma_Arg (Arg));
12008 if Has_Homonym (Ent) then
12010 ("argument for pragma% may not be overloaded", Arg);
12013 if Ekind (Ent) /= E_Function
12014 or else No (First_Formal (Ent))
12015 or else Present (Next_Formal (First_Formal (Ent)))
12018 ("argument for pragma% must be" &
12019 " function of one argument", Arg);
12021 end Check_OK_Stream_Convert_Function;
12023 -- Start of processing for Stream_Convert
12027 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
12028 Check_Arg_Count (3);
12029 Check_Optional_Identifier (Arg1, Name_Entity);
12030 Check_Optional_Identifier (Arg2, Name_Read);
12031 Check_Optional_Identifier (Arg3, Name_Write);
12032 Check_Arg_Is_Local_Name (Arg1);
12033 Check_OK_Stream_Convert_Function (Arg2);
12034 Check_OK_Stream_Convert_Function (Arg3);
12037 Typ : constant Entity_Id :=
12038 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
12039 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
12040 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
12043 Check_First_Subtype (Arg1);
12045 -- Check for too early or too late. Note that we don't enforce
12046 -- the rule about primitive operations in this case, since, as
12047 -- is the case for explicit stream attributes themselves, these
12048 -- restrictions are not appropriate. Note that the chaining of
12049 -- the pragma by Rep_Item_Too_Late is actually the critical
12050 -- processing done for this pragma.
12052 if Rep_Item_Too_Early (Typ, N)
12054 Rep_Item_Too_Late (Typ, N, FOnly => True)
12059 -- Return if previous error
12061 if Etype (Typ) = Any_Type
12063 Etype (Read) = Any_Type
12065 Etype (Write) = Any_Type
12072 if Underlying_Type (Etype (Read)) /= Typ then
12074 ("incorrect return type for function&", Arg2);
12077 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
12079 ("incorrect parameter type for function&", Arg3);
12082 if Underlying_Type (Etype (First_Formal (Read))) /=
12083 Underlying_Type (Etype (Write))
12086 ("result type of & does not match Read parameter type",
12090 end Stream_Convert;
12092 -------------------------
12093 -- Style_Checks (GNAT) --
12094 -------------------------
12096 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
12098 -- This is processed by the parser since some of the style checks
12099 -- take place during source scanning and parsing. This means that
12100 -- we don't need to issue error messages here.
12102 when Pragma_Style_Checks => Style_Checks : declare
12103 A : constant Node_Id := Get_Pragma_Arg (Arg1);
12109 Check_No_Identifiers;
12111 -- Two argument form
12113 if Arg_Count = 2 then
12114 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12121 E_Id := Get_Pragma_Arg (Arg2);
12124 if not Is_Entity_Name (E_Id) then
12126 ("second argument of pragma% must be entity name",
12130 E := Entity (E_Id);
12136 Set_Suppress_Style_Checks (E,
12137 (Chars (Get_Pragma_Arg (Arg1)) = Name_Off));
12138 exit when No (Homonym (E));
12144 -- One argument form
12147 Check_Arg_Count (1);
12149 if Nkind (A) = N_String_Literal then
12153 Slen : constant Natural := Natural (String_Length (S));
12154 Options : String (1 .. Slen);
12160 C := Get_String_Char (S, Int (J));
12161 exit when not In_Character_Range (C);
12162 Options (J) := Get_Character (C);
12164 -- If at end of string, set options. As per discussion
12165 -- above, no need to check for errors, since we issued
12166 -- them in the parser.
12169 Set_Style_Check_Options (Options);
12177 elsif Nkind (A) = N_Identifier then
12178 if Chars (A) = Name_All_Checks then
12180 Set_GNAT_Style_Check_Options;
12182 Set_Default_Style_Check_Options;
12185 elsif Chars (A) = Name_On then
12186 Style_Check := True;
12188 elsif Chars (A) = Name_Off then
12189 Style_Check := False;
12199 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
12201 when Pragma_Subtitle =>
12203 Check_Arg_Count (1);
12204 Check_Optional_Identifier (Arg1, Name_Subtitle);
12205 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
12212 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
12214 when Pragma_Suppress =>
12215 Process_Suppress_Unsuppress (True);
12221 -- pragma Suppress_All;
12223 -- The only check made here is that the pragma has no arguments.
12224 -- There are no placement rules, and the processing required (setting
12225 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
12226 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
12227 -- then creates and inserts a pragma Suppress (All_Checks).
12229 when Pragma_Suppress_All =>
12231 Check_Arg_Count (0);
12233 -------------------------
12234 -- Suppress_Debug_Info --
12235 -------------------------
12237 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
12239 when Pragma_Suppress_Debug_Info =>
12241 Check_Arg_Count (1);
12242 Check_Optional_Identifier (Arg1, Name_Entity);
12243 Check_Arg_Is_Local_Name (Arg1);
12244 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)), Sense);
12246 ----------------------------------
12247 -- Suppress_Exception_Locations --
12248 ----------------------------------
12250 -- pragma Suppress_Exception_Locations;
12252 when Pragma_Suppress_Exception_Locations =>
12254 Check_Arg_Count (0);
12255 Check_Valid_Configuration_Pragma;
12256 Exception_Locations_Suppressed := True;
12258 -----------------------------
12259 -- Suppress_Initialization --
12260 -----------------------------
12262 -- pragma Suppress_Initialization ([Entity =>] type_Name);
12264 when Pragma_Suppress_Initialization => Suppress_Init : declare
12270 Check_Arg_Count (1);
12271 Check_Optional_Identifier (Arg1, Name_Entity);
12272 Check_Arg_Is_Local_Name (Arg1);
12274 E_Id := Get_Pragma_Arg (Arg1);
12276 if Etype (E_Id) = Any_Type then
12280 E := Entity (E_Id);
12282 if Is_Type (E) then
12283 if Is_Incomplete_Or_Private_Type (E) then
12284 if No (Full_View (Base_Type (E))) then
12286 ("argument of pragma% cannot be an incomplete type",
12289 Set_Suppress_Init_Proc (Full_View (Base_Type (E)));
12292 Set_Suppress_Init_Proc (Base_Type (E));
12297 ("pragma% requires argument that is a type name", Arg1);
12305 -- pragma System_Name (DIRECT_NAME);
12307 -- Syntax check: one argument, which must be the identifier GNAT or
12308 -- the identifier GCC, no other identifiers are acceptable.
12310 when Pragma_System_Name =>
12312 Check_No_Identifiers;
12313 Check_Arg_Count (1);
12314 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
12316 -----------------------------
12317 -- Task_Dispatching_Policy --
12318 -----------------------------
12320 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
12322 when Pragma_Task_Dispatching_Policy => declare
12326 Check_Ada_83_Warning;
12327 Check_Arg_Count (1);
12328 Check_No_Identifiers;
12329 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
12330 Check_Valid_Configuration_Pragma;
12331 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
12332 DP := Fold_Upper (Name_Buffer (1));
12334 if Task_Dispatching_Policy /= ' '
12335 and then Task_Dispatching_Policy /= DP
12337 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
12339 ("task dispatching policy incompatible with policy#");
12341 -- Set new policy, but always preserve System_Location since we
12342 -- like the error message with the run time name.
12345 Task_Dispatching_Policy := DP;
12347 if Task_Dispatching_Policy_Sloc /= System_Location then
12348 Task_Dispatching_Policy_Sloc := Loc;
12357 -- pragma Task_Info (EXPRESSION);
12359 when Pragma_Task_Info => Task_Info : declare
12360 P : constant Node_Id := Parent (N);
12365 if Nkind (P) /= N_Task_Definition then
12366 Error_Pragma ("pragma% must appear in task definition");
12369 Check_No_Identifiers;
12370 Check_Arg_Count (1);
12372 Analyze_And_Resolve
12373 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
12375 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
12379 if Has_Task_Info_Pragma (P) then
12380 Error_Pragma ("duplicate pragma% not allowed");
12382 Set_Has_Task_Info_Pragma (P, True);
12390 -- pragma Task_Name (string_EXPRESSION);
12392 when Pragma_Task_Name => Task_Name : declare
12393 P : constant Node_Id := Parent (N);
12397 Check_No_Identifiers;
12398 Check_Arg_Count (1);
12400 Arg := Get_Pragma_Arg (Arg1);
12402 -- The expression is used in the call to Create_Task, and must be
12403 -- expanded there, not in the context of the current spec. It must
12404 -- however be analyzed to capture global references, in case it
12405 -- appears in a generic context.
12407 Preanalyze_And_Resolve (Arg, Standard_String);
12409 if Nkind (P) /= N_Task_Definition then
12413 if Has_Task_Name_Pragma (P) then
12414 Error_Pragma ("duplicate pragma% not allowed");
12416 Set_Has_Task_Name_Pragma (P, True);
12417 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
12425 -- pragma Task_Storage (
12426 -- [Task_Type =>] LOCAL_NAME,
12427 -- [Top_Guard =>] static_integer_EXPRESSION);
12429 when Pragma_Task_Storage => Task_Storage : declare
12430 Args : Args_List (1 .. 2);
12431 Names : constant Name_List (1 .. 2) := (
12435 Task_Type : Node_Id renames Args (1);
12436 Top_Guard : Node_Id renames Args (2);
12442 Gather_Associations (Names, Args);
12444 if No (Task_Type) then
12446 ("missing task_type argument for pragma%");
12449 Check_Arg_Is_Local_Name (Task_Type);
12451 Ent := Entity (Task_Type);
12453 if not Is_Task_Type (Ent) then
12455 ("argument for pragma% must be task type", Task_Type);
12458 if No (Top_Guard) then
12460 ("pragma% takes two arguments", Task_Type);
12462 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
12465 Check_First_Subtype (Task_Type);
12467 if Rep_Item_Too_Late (Ent, N) then
12472 --------------------------
12473 -- Thread_Local_Storage --
12474 --------------------------
12476 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
12478 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
12484 Check_Arg_Count (1);
12485 Check_Optional_Identifier (Arg1, Name_Entity);
12486 Check_Arg_Is_Library_Level_Local_Name (Arg1);
12488 Id := Get_Pragma_Arg (Arg1);
12491 if not Is_Entity_Name (Id)
12492 or else Ekind (Entity (Id)) /= E_Variable
12494 Error_Pragma_Arg ("local variable name required", Arg1);
12499 if Rep_Item_Too_Early (E, N)
12500 or else Rep_Item_Too_Late (E, N)
12505 Set_Has_Pragma_Thread_Local_Storage (E);
12506 Set_Has_Gigi_Rep_Item (E);
12507 end Thread_Local_Storage;
12513 -- pragma Time_Slice (static_duration_EXPRESSION);
12515 when Pragma_Time_Slice => Time_Slice : declare
12521 Check_Arg_Count (1);
12522 Check_No_Identifiers;
12523 Check_In_Main_Program;
12524 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
12526 if not Error_Posted (Arg1) then
12528 while Present (Nod) loop
12529 if Nkind (Nod) = N_Pragma
12530 and then Pragma_Name (Nod) = Name_Time_Slice
12532 Error_Msg_Name_1 := Pname;
12533 Error_Msg_N ("duplicate pragma% not permitted", Nod);
12540 -- Process only if in main unit
12542 if Get_Source_Unit (Loc) = Main_Unit then
12543 Opt.Time_Slice_Set := True;
12544 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
12546 if Val <= Ureal_0 then
12547 Opt.Time_Slice_Value := 0;
12549 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
12550 Opt.Time_Slice_Value := 1_000_000_000;
12553 Opt.Time_Slice_Value :=
12554 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
12563 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
12565 -- TITLING_OPTION ::=
12566 -- [Title =>] STRING_LITERAL
12567 -- | [Subtitle =>] STRING_LITERAL
12569 when Pragma_Title => Title : declare
12570 Args : Args_List (1 .. 2);
12571 Names : constant Name_List (1 .. 2) := (
12577 Gather_Associations (Names, Args);
12580 for J in 1 .. 2 loop
12581 if Present (Args (J)) then
12582 Check_Arg_Is_Static_Expression (Args (J), Standard_String);
12587 ---------------------
12588 -- Unchecked_Union --
12589 ---------------------
12591 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
12593 when Pragma_Unchecked_Union => Unchecked_Union : declare
12594 Assoc : constant Node_Id := Arg1;
12595 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
12606 Check_No_Identifiers;
12607 Check_Arg_Count (1);
12608 Check_Arg_Is_Local_Name (Arg1);
12610 Find_Type (Type_Id);
12611 Typ := Entity (Type_Id);
12614 or else Rep_Item_Too_Early (Typ, N)
12618 Typ := Underlying_Type (Typ);
12621 if Rep_Item_Too_Late (Typ, N) then
12625 Check_First_Subtype (Arg1);
12627 -- Note remaining cases are references to a type in the current
12628 -- declarative part. If we find an error, we post the error on
12629 -- the relevant type declaration at an appropriate point.
12631 if not Is_Record_Type (Typ) then
12632 Error_Msg_N ("Unchecked_Union must be record type", Typ);
12635 elsif Is_Tagged_Type (Typ) then
12636 Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
12639 elsif Is_Limited_Type (Typ) then
12641 ("Unchecked_Union must not be limited record type", Typ);
12642 Explain_Limited_Type (Typ, Typ);
12646 if not Has_Discriminants (Typ) then
12648 ("Unchecked_Union must have one discriminant", Typ);
12652 Discr := First_Discriminant (Typ);
12653 while Present (Discr) loop
12654 if No (Discriminant_Default_Value (Discr)) then
12656 ("Unchecked_Union discriminant must have default value",
12660 Next_Discriminant (Discr);
12663 Tdef := Type_Definition (Declaration_Node (Typ));
12664 Clist := Component_List (Tdef);
12666 Comp := First (Component_Items (Clist));
12667 while Present (Comp) loop
12668 Check_Component (Comp, Typ);
12672 if No (Clist) or else No (Variant_Part (Clist)) then
12674 ("Unchecked_Union must have variant part",
12679 Vpart := Variant_Part (Clist);
12681 Variant := First (Variants (Vpart));
12682 while Present (Variant) loop
12683 Check_Variant (Variant, Typ);
12688 Set_Is_Unchecked_Union (Typ, Sense);
12691 Set_Convention (Typ, Convention_C);
12694 Set_Has_Unchecked_Union (Base_Type (Typ), Sense);
12695 Set_Is_Unchecked_Union (Base_Type (Typ), Sense);
12696 end Unchecked_Union;
12698 ------------------------
12699 -- Unimplemented_Unit --
12700 ------------------------
12702 -- pragma Unimplemented_Unit;
12704 -- Note: this only gives an error if we are generating code, or if
12705 -- we are in a generic library unit (where the pragma appears in the
12706 -- body, not in the spec).
12708 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
12709 Cunitent : constant Entity_Id :=
12710 Cunit_Entity (Get_Source_Unit (Loc));
12711 Ent_Kind : constant Entity_Kind :=
12716 Check_Arg_Count (0);
12718 if Operating_Mode = Generate_Code
12719 or else Ent_Kind = E_Generic_Function
12720 or else Ent_Kind = E_Generic_Procedure
12721 or else Ent_Kind = E_Generic_Package
12723 Get_Name_String (Chars (Cunitent));
12724 Set_Casing (Mixed_Case);
12725 Write_Str (Name_Buffer (1 .. Name_Len));
12726 Write_Str (" is not supported in this configuration");
12728 raise Unrecoverable_Error;
12730 end Unimplemented_Unit;
12732 ------------------------
12733 -- Universal_Aliasing --
12734 ------------------------
12736 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
12738 when Pragma_Universal_Aliasing => Universal_Alias : declare
12743 Check_Arg_Count (1);
12744 Check_Optional_Identifier (Arg2, Name_Entity);
12745 Check_Arg_Is_Local_Name (Arg1);
12746 E_Id := Entity (Get_Pragma_Arg (Arg1));
12748 if E_Id = Any_Type then
12750 elsif No (E_Id) or else not Is_Type (E_Id) then
12751 Error_Pragma_Arg ("pragma% requires type", Arg1);
12754 Set_Universal_Aliasing (Implementation_Base_Type (E_Id), Sense);
12755 end Universal_Alias;
12757 --------------------
12758 -- Universal_Data --
12759 --------------------
12761 -- pragma Universal_Data [(library_unit_NAME)];
12763 when Pragma_Universal_Data =>
12766 -- If this is a configuration pragma, then set the universal
12767 -- addressing option, otherwise confirm that the pragma satisfies
12768 -- the requirements of library unit pragma placement and leave it
12769 -- to the GNAAMP back end to detect the pragma (avoids transitive
12770 -- setting of the option due to withed units).
12772 if Is_Configuration_Pragma then
12773 Universal_Addressing_On_AAMP := True;
12775 Check_Valid_Library_Unit_Pragma;
12778 if not AAMP_On_Target then
12779 Error_Pragma ("?pragma% ignored (applies only to AAMP)");
12786 -- pragma Unmodified (local_Name {, local_Name});
12788 when Pragma_Unmodified => Unmodified : declare
12789 Arg_Node : Node_Id;
12790 Arg_Expr : Node_Id;
12791 Arg_Ent : Entity_Id;
12795 Check_At_Least_N_Arguments (1);
12797 -- Loop through arguments
12800 while Present (Arg_Node) loop
12801 Check_No_Identifier (Arg_Node);
12803 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
12804 -- in fact generate reference, so that the entity will have a
12805 -- reference, which will inhibit any warnings about it not
12806 -- being referenced, and also properly show up in the ali file
12807 -- as a reference. But this reference is recorded before the
12808 -- Has_Pragma_Unreferenced flag is set, so that no warning is
12809 -- generated for this reference.
12811 Check_Arg_Is_Local_Name (Arg_Node);
12812 Arg_Expr := Get_Pragma_Arg (Arg_Node);
12814 if Is_Entity_Name (Arg_Expr) then
12815 Arg_Ent := Entity (Arg_Expr);
12817 if not Is_Assignable (Arg_Ent) then
12819 ("pragma% can only be applied to a variable",
12822 Set_Has_Pragma_Unmodified (Arg_Ent, Sense);
12834 -- pragma Unreferenced (local_Name {, local_Name});
12836 -- or when used in a context clause:
12838 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
12840 when Pragma_Unreferenced => Unreferenced : declare
12841 Arg_Node : Node_Id;
12842 Arg_Expr : Node_Id;
12843 Arg_Ent : Entity_Id;
12848 Check_At_Least_N_Arguments (1);
12850 -- Check case of appearing within context clause
12852 if Is_In_Context_Clause then
12854 -- The arguments must all be units mentioned in a with clause
12855 -- in the same context clause. Note we already checked (in
12856 -- Par.Prag) that the arguments are either identifiers or
12857 -- selected components.
12860 while Present (Arg_Node) loop
12861 Citem := First (List_Containing (N));
12862 while Citem /= N loop
12863 if Nkind (Citem) = N_With_Clause
12865 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
12867 Set_Has_Pragma_Unreferenced
12870 (Library_Unit (Citem))));
12872 (Get_Pragma_Arg (Arg_Node), Name (Citem));
12881 ("argument of pragma% is not with'ed unit", Arg_Node);
12887 -- Case of not in list of context items
12891 while Present (Arg_Node) loop
12892 Check_No_Identifier (Arg_Node);
12894 -- Note: the analyze call done by Check_Arg_Is_Local_Name
12895 -- will in fact generate reference, so that the entity will
12896 -- have a reference, which will inhibit any warnings about
12897 -- it not being referenced, and also properly show up in the
12898 -- ali file as a reference. But this reference is recorded
12899 -- before the Has_Pragma_Unreferenced flag is set, so that
12900 -- no warning is generated for this reference.
12902 Check_Arg_Is_Local_Name (Arg_Node);
12903 Arg_Expr := Get_Pragma_Arg (Arg_Node);
12905 if Is_Entity_Name (Arg_Expr) then
12906 Arg_Ent := Entity (Arg_Expr);
12908 -- If the entity is overloaded, the pragma applies to the
12909 -- most recent overloading, as documented. In this case,
12910 -- name resolution does not generate a reference, so it
12911 -- must be done here explicitly.
12913 if Is_Overloaded (Arg_Expr) then
12914 Generate_Reference (Arg_Ent, N);
12917 Set_Has_Pragma_Unreferenced (Arg_Ent, Sense);
12925 --------------------------
12926 -- Unreferenced_Objects --
12927 --------------------------
12929 -- pragma Unreferenced_Objects (local_Name {, local_Name});
12931 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
12932 Arg_Node : Node_Id;
12933 Arg_Expr : Node_Id;
12937 Check_At_Least_N_Arguments (1);
12940 while Present (Arg_Node) loop
12941 Check_No_Identifier (Arg_Node);
12942 Check_Arg_Is_Local_Name (Arg_Node);
12943 Arg_Expr := Get_Pragma_Arg (Arg_Node);
12945 if not Is_Entity_Name (Arg_Expr)
12946 or else not Is_Type (Entity (Arg_Expr))
12949 ("argument for pragma% must be type or subtype", Arg_Node);
12952 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr), Sense);
12955 end Unreferenced_Objects;
12957 ------------------------------
12958 -- Unreserve_All_Interrupts --
12959 ------------------------------
12961 -- pragma Unreserve_All_Interrupts;
12963 when Pragma_Unreserve_All_Interrupts =>
12965 Check_Arg_Count (0);
12967 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
12968 Unreserve_All_Interrupts := True;
12975 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
12977 when Pragma_Unsuppress =>
12979 Process_Suppress_Unsuppress (False);
12981 -------------------
12982 -- Use_VADS_Size --
12983 -------------------
12985 -- pragma Use_VADS_Size;
12987 when Pragma_Use_VADS_Size =>
12989 Check_Arg_Count (0);
12990 Check_Valid_Configuration_Pragma;
12991 Use_VADS_Size := True;
12993 ---------------------
12994 -- Validity_Checks --
12995 ---------------------
12997 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
12999 when Pragma_Validity_Checks => Validity_Checks : declare
13000 A : constant Node_Id := Get_Pragma_Arg (Arg1);
13006 Check_Arg_Count (1);
13007 Check_No_Identifiers;
13009 if Nkind (A) = N_String_Literal then
13013 Slen : constant Natural := Natural (String_Length (S));
13014 Options : String (1 .. Slen);
13020 C := Get_String_Char (S, Int (J));
13021 exit when not In_Character_Range (C);
13022 Options (J) := Get_Character (C);
13025 Set_Validity_Check_Options (Options);
13033 elsif Nkind (A) = N_Identifier then
13035 if Chars (A) = Name_All_Checks then
13036 Set_Validity_Check_Options ("a");
13038 elsif Chars (A) = Name_On then
13039 Validity_Checks_On := True;
13041 elsif Chars (A) = Name_Off then
13042 Validity_Checks_On := False;
13046 end Validity_Checks;
13052 -- pragma Volatile (LOCAL_NAME);
13054 when Pragma_Volatile =>
13055 Process_Atomic_Shared_Volatile;
13057 -------------------------
13058 -- Volatile_Components --
13059 -------------------------
13061 -- pragma Volatile_Components (array_LOCAL_NAME);
13063 -- Volatile is handled by the same circuit as Atomic_Components
13069 -- pragma Warnings (On | Off);
13070 -- pragma Warnings (On | Off, LOCAL_NAME);
13071 -- pragma Warnings (static_string_EXPRESSION);
13072 -- pragma Warnings (On | Off, STRING_LITERAL);
13074 when Pragma_Warnings => Warnings : begin
13076 Check_At_Least_N_Arguments (1);
13077 Check_No_Identifiers;
13079 -- If debug flag -gnatd.i is set, pragma is ignored
13081 if Debug_Flag_Dot_I then
13085 -- Process various forms of the pragma
13088 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
13091 -- One argument case
13093 if Arg_Count = 1 then
13095 -- On/Off one argument case was processed by parser
13097 if Nkind (Argx) = N_Identifier
13099 (Chars (Argx) = Name_On
13101 Chars (Argx) = Name_Off)
13105 -- One argument case must be ON/OFF or static string expr
13107 elsif not Is_Static_String_Expression (Arg1) then
13109 ("argument of pragma% must be On/Off or " &
13110 "static string expression", Arg1);
13112 -- One argument string expression case
13116 Lit : constant Node_Id := Expr_Value_S (Argx);
13117 Str : constant String_Id := Strval (Lit);
13118 Len : constant Nat := String_Length (Str);
13126 while J <= Len loop
13127 C := Get_String_Char (Str, J);
13128 OK := In_Character_Range (C);
13131 Chr := Get_Character (C);
13135 if J < Len and then Chr = '.' then
13137 C := Get_String_Char (Str, J);
13138 Chr := Get_Character (C);
13140 if not Set_Dot_Warning_Switch (Chr) then
13142 ("invalid warning switch character " &
13149 OK := Set_Warning_Switch (Chr);
13155 ("invalid warning switch character " & Chr,
13164 -- Two or more arguments (must be two)
13167 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13168 Check_At_Most_N_Arguments (2);
13176 E_Id := Get_Pragma_Arg (Arg2);
13179 -- In the expansion of an inlined body, a reference to
13180 -- the formal may be wrapped in a conversion if the
13181 -- actual is a conversion. Retrieve the real entity name.
13183 if (In_Instance_Body
13184 or else In_Inlined_Body)
13185 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
13187 E_Id := Expression (E_Id);
13190 -- Entity name case
13192 if Is_Entity_Name (E_Id) then
13193 E := Entity (E_Id);
13200 (E, (Chars (Get_Pragma_Arg (Arg1)) =
13203 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
13204 and then Warn_On_Warnings_Off
13206 Warnings_Off_Pragmas.Append ((N, E));
13209 if Is_Enumeration_Type (E) then
13213 Lit := First_Literal (E);
13214 while Present (Lit) loop
13215 Set_Warnings_Off (Lit);
13216 Next_Literal (Lit);
13221 exit when No (Homonym (E));
13226 -- Error if not entity or static string literal case
13228 elsif not Is_Static_String_Expression (Arg2) then
13230 ("second argument of pragma% must be entity " &
13231 "name or static string expression", Arg2);
13233 -- String literal case
13236 String_To_Name_Buffer
13237 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
13239 -- Note on configuration pragma case: If this is a
13240 -- configuration pragma, then for an OFF pragma, we
13241 -- just set Config True in the call, which is all
13242 -- that needs to be done. For the case of ON, this
13243 -- is normally an error, unless it is canceling the
13244 -- effect of a previous OFF pragma in the same file.
13245 -- In any other case, an error will be signalled (ON
13246 -- with no matching OFF).
13248 if Chars (Argx) = Name_Off then
13249 Set_Specific_Warning_Off
13250 (Loc, Name_Buffer (1 .. Name_Len),
13251 Config => Is_Configuration_Pragma);
13253 elsif Chars (Argx) = Name_On then
13254 Set_Specific_Warning_On
13255 (Loc, Name_Buffer (1 .. Name_Len), Err);
13259 ("?pragma Warnings On with no " &
13260 "matching Warnings Off",
13270 -------------------
13271 -- Weak_External --
13272 -------------------
13274 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
13276 when Pragma_Weak_External => Weak_External : declare
13281 Check_Arg_Count (1);
13282 Check_Optional_Identifier (Arg1, Name_Entity);
13283 Check_Arg_Is_Library_Level_Local_Name (Arg1);
13284 Ent := Entity (Get_Pragma_Arg (Arg1));
13286 if Rep_Item_Too_Early (Ent, N) then
13289 Ent := Underlying_Type (Ent);
13292 -- The only processing required is to link this item on to the
13293 -- list of rep items for the given entity. This is accomplished
13294 -- by the call to Rep_Item_Too_Late (when no error is detected
13295 -- and False is returned).
13297 if Rep_Item_Too_Late (Ent, N) then
13300 Set_Has_Gigi_Rep_Item (Ent);
13304 -----------------------------
13305 -- Wide_Character_Encoding --
13306 -----------------------------
13308 -- pragma Wide_Character_Encoding (IDENTIFIER);
13310 when Pragma_Wide_Character_Encoding =>
13313 -- Nothing to do, handled in parser. Note that we do not enforce
13314 -- configuration pragma placement, this pragma can appear at any
13315 -- place in the source, allowing mixed encodings within a single
13320 --------------------
13321 -- Unknown_Pragma --
13322 --------------------
13324 -- Should be impossible, since the case of an unknown pragma is
13325 -- separately processed before the case statement is entered.
13327 when Unknown_Pragma =>
13328 raise Program_Error;
13331 -- AI05-0144: detect dangerous order dependence. Disabled for now,
13332 -- until AI is formally approved.
13334 -- Check_Order_Dependence;
13337 when Pragma_Exit => null;
13338 end Analyze_Pragma;
13340 -------------------
13341 -- Check_Enabled --
13342 -------------------
13344 function Check_Enabled (Nam : Name_Id) return Boolean is
13348 PP := Opt.Check_Policy_List;
13351 return Assertions_Enabled;
13354 Nam = Chars (Expression (First (Pragma_Argument_Associations (PP))))
13357 Chars (Expression (Last (Pragma_Argument_Associations (PP))))
13359 when Name_On | Name_Check =>
13361 when Name_Off | Name_Ignore =>
13364 raise Program_Error;
13368 PP := Next_Pragma (PP);
13373 ---------------------------------
13374 -- Delay_Config_Pragma_Analyze --
13375 ---------------------------------
13377 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
13379 return Pragma_Name (N) = Name_Interrupt_State
13381 Pragma_Name (N) = Name_Priority_Specific_Dispatching;
13382 end Delay_Config_Pragma_Analyze;
13384 -------------------------
13385 -- Get_Base_Subprogram --
13386 -------------------------
13388 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
13389 Result : Entity_Id;
13392 -- Follow subprogram renaming chain
13395 while Is_Subprogram (Result)
13397 (Is_Generic_Instance (Result)
13398 or else Nkind (Parent (Declaration_Node (Result))) =
13399 N_Subprogram_Renaming_Declaration)
13400 and then Present (Alias (Result))
13402 Result := Alias (Result);
13406 end Get_Base_Subprogram;
13412 procedure Initialize is
13417 -----------------------------
13418 -- Is_Config_Static_String --
13419 -----------------------------
13421 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
13423 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
13424 -- This is an internal recursive function that is just like the outer
13425 -- function except that it adds the string to the name buffer rather
13426 -- than placing the string in the name buffer.
13428 ------------------------------
13429 -- Add_Config_Static_String --
13430 ------------------------------
13432 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
13439 if Nkind (N) = N_Op_Concat then
13440 if Add_Config_Static_String (Left_Opnd (N)) then
13441 N := Right_Opnd (N);
13447 if Nkind (N) /= N_String_Literal then
13448 Error_Msg_N ("string literal expected for pragma argument", N);
13452 for J in 1 .. String_Length (Strval (N)) loop
13453 C := Get_String_Char (Strval (N), J);
13455 if not In_Character_Range (C) then
13457 ("string literal contains invalid wide character",
13458 Sloc (N) + 1 + Source_Ptr (J));
13462 Add_Char_To_Name_Buffer (Get_Character (C));
13467 end Add_Config_Static_String;
13469 -- Start of processing for Is_Config_Static_String
13474 return Add_Config_Static_String (Arg);
13475 end Is_Config_Static_String;
13477 -----------------------------------------
13478 -- Is_Non_Significant_Pragma_Reference --
13479 -----------------------------------------
13481 -- This function makes use of the following static table which indicates
13482 -- whether a given pragma is significant.
13484 -- -1 indicates that references in any argument position are significant
13485 -- 0 indicates that appearence in any argument is not significant
13486 -- +n indicates that appearence as argument n is significant, but all
13487 -- other arguments are not significant
13488 -- 99 special processing required (e.g. for pragma Check)
13490 Sig_Flags : constant array (Pragma_Id) of Int :=
13491 (Pragma_AST_Entry => -1,
13492 Pragma_Abort_Defer => -1,
13493 Pragma_Ada_83 => -1,
13494 Pragma_Ada_95 => -1,
13495 Pragma_Ada_05 => -1,
13496 Pragma_Ada_2005 => -1,
13497 Pragma_Ada_12 => -1,
13498 Pragma_Ada_2012 => -1,
13499 Pragma_All_Calls_Remote => -1,
13500 Pragma_Annotate => -1,
13501 Pragma_Assert => -1,
13502 Pragma_Assertion_Policy => 0,
13503 Pragma_Assume_No_Invalid_Values => 0,
13504 Pragma_Asynchronous => -1,
13505 Pragma_Atomic => 0,
13506 Pragma_Atomic_Components => 0,
13507 Pragma_Attach_Handler => -1,
13508 Pragma_Check => 99,
13509 Pragma_Check_Name => 0,
13510 Pragma_Check_Policy => 0,
13511 Pragma_CIL_Constructor => -1,
13512 Pragma_CPP_Class => 0,
13513 Pragma_CPP_Constructor => 0,
13514 Pragma_CPP_Virtual => 0,
13515 Pragma_CPP_Vtable => 0,
13516 Pragma_C_Pass_By_Copy => 0,
13517 Pragma_Comment => 0,
13518 Pragma_Common_Object => -1,
13519 Pragma_Compile_Time_Error => -1,
13520 Pragma_Compile_Time_Warning => -1,
13521 Pragma_Compiler_Unit => 0,
13522 Pragma_Complete_Representation => 0,
13523 Pragma_Complex_Representation => 0,
13524 Pragma_Component_Alignment => -1,
13525 Pragma_Controlled => 0,
13526 Pragma_Convention => 0,
13527 Pragma_Convention_Identifier => 0,
13528 Pragma_Debug => -1,
13529 Pragma_Debug_Policy => 0,
13530 Pragma_Detect_Blocking => -1,
13531 Pragma_Dimension => -1,
13532 Pragma_Discard_Names => 0,
13533 Pragma_Elaborate => -1,
13534 Pragma_Elaborate_All => -1,
13535 Pragma_Elaborate_Body => -1,
13536 Pragma_Elaboration_Checks => -1,
13537 Pragma_Eliminate => -1,
13538 Pragma_Export => -1,
13539 Pragma_Export_Exception => -1,
13540 Pragma_Export_Function => -1,
13541 Pragma_Export_Object => -1,
13542 Pragma_Export_Procedure => -1,
13543 Pragma_Export_Value => -1,
13544 Pragma_Export_Valued_Procedure => -1,
13545 Pragma_Extend_System => -1,
13546 Pragma_Extensions_Allowed => -1,
13547 Pragma_External => -1,
13548 Pragma_Favor_Top_Level => -1,
13549 Pragma_External_Name_Casing => -1,
13550 Pragma_Fast_Math => -1,
13551 Pragma_Finalize_Storage_Only => 0,
13552 Pragma_Float_Representation => 0,
13553 Pragma_Ident => -1,
13554 Pragma_Implemented => -1,
13555 Pragma_Implicit_Packing => 0,
13556 Pragma_Import => +2,
13557 Pragma_Import_Exception => 0,
13558 Pragma_Import_Function => 0,
13559 Pragma_Import_Object => 0,
13560 Pragma_Import_Procedure => 0,
13561 Pragma_Import_Valued_Procedure => 0,
13562 Pragma_Independent => 0,
13563 Pragma_Independent_Components => 0,
13564 Pragma_Initialize_Scalars => -1,
13565 Pragma_Inline => 0,
13566 Pragma_Inline_Always => 0,
13567 Pragma_Inline_Generic => 0,
13568 Pragma_Inspection_Point => -1,
13569 Pragma_Interface => +2,
13570 Pragma_Interface_Name => +2,
13571 Pragma_Interrupt_Handler => -1,
13572 Pragma_Interrupt_Priority => -1,
13573 Pragma_Interrupt_State => -1,
13574 Pragma_Java_Constructor => -1,
13575 Pragma_Java_Interface => -1,
13576 Pragma_Keep_Names => 0,
13577 Pragma_License => -1,
13578 Pragma_Link_With => -1,
13579 Pragma_Linker_Alias => -1,
13580 Pragma_Linker_Constructor => -1,
13581 Pragma_Linker_Destructor => -1,
13582 Pragma_Linker_Options => -1,
13583 Pragma_Linker_Section => -1,
13585 Pragma_Locking_Policy => -1,
13586 Pragma_Long_Float => -1,
13587 Pragma_Machine_Attribute => -1,
13589 Pragma_Main_Storage => -1,
13590 Pragma_Memory_Size => -1,
13591 Pragma_No_Return => 0,
13592 Pragma_No_Body => 0,
13593 Pragma_No_Run_Time => -1,
13594 Pragma_No_Strict_Aliasing => -1,
13595 Pragma_Normalize_Scalars => -1,
13596 Pragma_Obsolescent => 0,
13597 Pragma_Optimize => -1,
13598 Pragma_Optimize_Alignment => -1,
13599 Pragma_Ordered => 0,
13602 Pragma_Passive => -1,
13603 Pragma_Preelaborable_Initialization => -1,
13604 Pragma_Polling => -1,
13605 Pragma_Persistent_BSS => 0,
13606 Pragma_Postcondition => -1,
13607 Pragma_Precondition => -1,
13608 Pragma_Preelaborate => -1,
13609 Pragma_Preelaborate_05 => -1,
13610 Pragma_Priority => -1,
13611 Pragma_Priority_Specific_Dispatching => -1,
13612 Pragma_Profile => 0,
13613 Pragma_Profile_Warnings => 0,
13614 Pragma_Propagate_Exceptions => -1,
13615 Pragma_Psect_Object => -1,
13617 Pragma_Pure_05 => -1,
13618 Pragma_Pure_Function => -1,
13619 Pragma_Queuing_Policy => -1,
13620 Pragma_Ravenscar => -1,
13621 Pragma_Relative_Deadline => -1,
13622 Pragma_Remote_Call_Interface => -1,
13623 Pragma_Remote_Types => -1,
13624 Pragma_Restricted_Run_Time => -1,
13625 Pragma_Restriction_Warnings => -1,
13626 Pragma_Restrictions => -1,
13627 Pragma_Reviewable => -1,
13628 Pragma_Short_Circuit_And_Or => -1,
13629 Pragma_Share_Generic => -1,
13630 Pragma_Shared => -1,
13631 Pragma_Shared_Passive => -1,
13632 Pragma_Short_Descriptors => 0,
13633 Pragma_Source_File_Name => -1,
13634 Pragma_Source_File_Name_Project => -1,
13635 Pragma_Source_Reference => -1,
13636 Pragma_Storage_Size => -1,
13637 Pragma_Storage_Unit => -1,
13638 Pragma_Static_Elaboration_Desired => -1,
13639 Pragma_Stream_Convert => -1,
13640 Pragma_Style_Checks => -1,
13641 Pragma_Subtitle => -1,
13642 Pragma_Suppress => 0,
13643 Pragma_Suppress_Exception_Locations => 0,
13644 Pragma_Suppress_All => -1,
13645 Pragma_Suppress_Debug_Info => 0,
13646 Pragma_Suppress_Initialization => 0,
13647 Pragma_System_Name => -1,
13648 Pragma_Task_Dispatching_Policy => -1,
13649 Pragma_Task_Info => -1,
13650 Pragma_Task_Name => -1,
13651 Pragma_Task_Storage => 0,
13652 Pragma_Thread_Local_Storage => 0,
13653 Pragma_Time_Slice => -1,
13654 Pragma_Title => -1,
13655 Pragma_Unchecked_Union => 0,
13656 Pragma_Unimplemented_Unit => -1,
13657 Pragma_Universal_Aliasing => -1,
13658 Pragma_Universal_Data => -1,
13659 Pragma_Unmodified => -1,
13660 Pragma_Unreferenced => -1,
13661 Pragma_Unreferenced_Objects => -1,
13662 Pragma_Unreserve_All_Interrupts => -1,
13663 Pragma_Unsuppress => 0,
13664 Pragma_Use_VADS_Size => -1,
13665 Pragma_Validity_Checks => -1,
13666 Pragma_Volatile => 0,
13667 Pragma_Volatile_Components => 0,
13668 Pragma_Warnings => -1,
13669 Pragma_Weak_External => -1,
13670 Pragma_Wide_Character_Encoding => 0,
13671 Unknown_Pragma => 0);
13673 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
13682 if Nkind (P) /= N_Pragma_Argument_Association then
13686 Id := Get_Pragma_Id (Parent (P));
13687 C := Sig_Flags (Id);
13699 -- For pragma Check, the first argument is not significant,
13700 -- the second and the third (if present) arguments are
13703 when Pragma_Check =>
13705 P = First (Pragma_Argument_Associations (Parent (P)));
13708 raise Program_Error;
13712 A := First (Pragma_Argument_Associations (Parent (P)));
13713 for J in 1 .. C - 1 loop
13721 return A = P; -- is this wrong way round ???
13724 end Is_Non_Significant_Pragma_Reference;
13726 ------------------------------
13727 -- Is_Pragma_String_Literal --
13728 ------------------------------
13730 -- This function returns true if the corresponding pragma argument is a
13731 -- static string expression. These are the only cases in which string
13732 -- literals can appear as pragma arguments. We also allow a string literal
13733 -- as the first argument to pragma Assert (although it will of course
13734 -- always generate a type error).
13736 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
13737 Pragn : constant Node_Id := Parent (Par);
13738 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
13739 Pname : constant Name_Id := Pragma_Name (Pragn);
13745 N := First (Assoc);
13752 if Pname = Name_Assert then
13755 elsif Pname = Name_Export then
13758 elsif Pname = Name_Ident then
13761 elsif Pname = Name_Import then
13764 elsif Pname = Name_Interface_Name then
13767 elsif Pname = Name_Linker_Alias then
13770 elsif Pname = Name_Linker_Section then
13773 elsif Pname = Name_Machine_Attribute then
13776 elsif Pname = Name_Source_File_Name then
13779 elsif Pname = Name_Source_Reference then
13782 elsif Pname = Name_Title then
13785 elsif Pname = Name_Subtitle then
13791 end Is_Pragma_String_Literal;
13793 --------------------------------------
13794 -- Process_Compilation_Unit_Pragmas --
13795 --------------------------------------
13797 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
13799 -- A special check for pragma Suppress_All, a very strange DEC pragma,
13800 -- strange because it comes at the end of the unit. Rational has the
13801 -- same name for a pragma, but treats it as a program unit pragma, In
13802 -- GNAT we just decide to allow it anywhere at all. If it appeared then
13803 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
13804 -- node, and we insert a pragma Suppress (All_Checks) at the start of
13805 -- the context clause to ensure the correct processing.
13807 if Has_Pragma_Suppress_All (N) then
13808 Prepend_To (Context_Items (N),
13809 Make_Pragma (Sloc (N),
13810 Chars => Name_Suppress,
13811 Pragma_Argument_Associations => New_List (
13812 Make_Pragma_Argument_Association (Sloc (N),
13814 Make_Identifier (Sloc (N),
13815 Chars => Name_All_Checks)))));
13818 -- Nothing else to do at the current time!
13820 end Process_Compilation_Unit_Pragmas;
13831 --------------------------------
13832 -- Set_Encoded_Interface_Name --
13833 --------------------------------
13835 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
13836 Str : constant String_Id := Strval (S);
13837 Len : constant Int := String_Length (Str);
13842 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
13845 -- Stores encoded value of character code CC. The encoding we use an
13846 -- underscore followed by four lower case hex digits.
13852 procedure Encode is
13854 Store_String_Char (Get_Char_Code ('_'));
13856 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
13858 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
13860 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
13862 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
13865 -- Start of processing for Set_Encoded_Interface_Name
13868 -- If first character is asterisk, this is a link name, and we leave it
13869 -- completely unmodified. We also ignore null strings (the latter case
13870 -- happens only in error cases) and no encoding should occur for Java or
13871 -- AAMP interface names.
13874 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
13875 or else VM_Target /= No_VM
13876 or else AAMP_On_Target
13878 Set_Interface_Name (E, S);
13883 CC := Get_String_Char (Str, J);
13885 exit when not In_Character_Range (CC);
13887 C := Get_Character (CC);
13889 exit when C /= '_' and then C /= '$'
13890 and then C not in '0' .. '9'
13891 and then C not in 'a' .. 'z'
13892 and then C not in 'A' .. 'Z';
13895 Set_Interface_Name (E, S);
13903 -- Here we need to encode. The encoding we use as follows:
13904 -- three underscores + four hex digits (lower case)
13908 for J in 1 .. String_Length (Str) loop
13909 CC := Get_String_Char (Str, J);
13911 if not In_Character_Range (CC) then
13914 C := Get_Character (CC);
13916 if C = '_' or else C = '$'
13917 or else C in '0' .. '9'
13918 or else C in 'a' .. 'z'
13919 or else C in 'A' .. 'Z'
13921 Store_String_Char (CC);
13928 Set_Interface_Name (E,
13929 Make_String_Literal (Sloc (S),
13930 Strval => End_String));
13932 end Set_Encoded_Interface_Name;
13934 -------------------
13935 -- Set_Unit_Name --
13936 -------------------
13938 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
13943 if Nkind (N) = N_Identifier
13944 and then Nkind (With_Item) = N_Identifier
13946 Set_Entity (N, Entity (With_Item));
13948 elsif Nkind (N) = N_Selected_Component then
13949 Change_Selected_Component_To_Expanded_Name (N);
13950 Set_Entity (N, Entity (With_Item));
13951 Set_Entity (Selector_Name (N), Entity (N));
13953 Pref := Prefix (N);
13954 Scop := Scope (Entity (N));
13955 while Nkind (Pref) = N_Selected_Component loop
13956 Change_Selected_Component_To_Expanded_Name (Pref);
13957 Set_Entity (Selector_Name (Pref), Scop);
13958 Set_Entity (Pref, Scop);
13959 Pref := Prefix (Pref);
13960 Scop := Scope (Scop);
13963 Set_Entity (Pref, Scop);