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, CPU).
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 CPU (EXPRESSION);
6970 when Pragma_CPU => CPU : declare
6971 P : constant Node_Id := Parent (N);
6976 Check_No_Identifiers;
6977 Check_Arg_Count (1);
6981 if Nkind (P) = N_Subprogram_Body then
6982 Check_In_Main_Program;
6984 Arg := Get_Pragma_Arg (Arg1);
6985 Analyze_And_Resolve (Arg, Any_Integer);
6989 if not Is_Static_Expression (Arg) then
6990 Flag_Non_Static_Expr
6991 ("main subprogram affinity is not static!", Arg);
6994 -- If constraint error, then we already signalled an error
6996 elsif Raises_Constraint_Error (Arg) then
6999 -- Otherwise check in range
7003 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
7004 -- This is the entity System.Multiprocessors.CPU_Range;
7006 Val : constant Uint := Expr_Value (Arg);
7009 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
7011 Val > Expr_Value (Type_High_Bound (CPU_Id))
7014 ("main subprogram CPU is out of range", Arg1);
7020 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
7024 elsif Nkind (P) = N_Task_Definition then
7025 Arg := Get_Pragma_Arg (Arg1);
7027 -- The expression must be analyzed in the special manner
7028 -- described in "Handling of Default and Per-Object
7029 -- Expressions" in sem.ads.
7031 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
7033 -- Anything else is incorrect
7039 if Has_Pragma_CPU (P) then
7040 Error_Pragma ("duplicate pragma% not allowed");
7042 Set_Has_Pragma_CPU (P, True);
7044 if Nkind (P) = N_Task_Definition then
7045 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
7054 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
7056 when Pragma_Debug => Debug : declare
7064 (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active),
7067 if Arg_Count = 2 then
7070 Left_Opnd => Relocate_Node (Cond),
7071 Right_Opnd => Get_Pragma_Arg (Arg1));
7074 -- Rewrite into a conditional with an appropriate condition. We
7075 -- wrap the procedure call in a block so that overhead from e.g.
7076 -- use of the secondary stack does not generate execution overhead
7077 -- for suppressed conditions.
7079 Rewrite (N, Make_Implicit_If_Statement (N,
7081 Then_Statements => New_List (
7082 Make_Block_Statement (Loc,
7083 Handled_Statement_Sequence =>
7084 Make_Handled_Sequence_Of_Statements (Loc,
7085 Statements => New_List (
7086 Relocate_Node (Debug_Statement (N))))))));
7094 -- pragma Debug_Policy (Check | Ignore)
7096 when Pragma_Debug_Policy =>
7098 Check_Arg_Count (1);
7099 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
7100 Debug_Pragmas_Enabled :=
7101 Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
7103 ---------------------
7104 -- Detect_Blocking --
7105 ---------------------
7107 -- pragma Detect_Blocking;
7109 when Pragma_Detect_Blocking =>
7111 Check_Arg_Count (0);
7112 Check_Valid_Configuration_Pragma;
7113 Detect_Blocking := True;
7119 when Pragma_Dimension =>
7121 Check_Arg_Count (4);
7122 Check_No_Identifiers;
7123 Check_Arg_Is_Local_Name (Arg1);
7125 if not Is_Type (Arg1) then
7126 Error_Pragma ("first argument for pragma% must be subtype");
7129 Check_Arg_Is_Static_Expression (Arg2, Standard_Integer);
7130 Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
7131 Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
7137 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
7139 when Pragma_Discard_Names => Discard_Names : declare
7144 Check_Ada_83_Warning;
7146 -- Deal with configuration pragma case
7148 if Arg_Count = 0 and then Is_Configuration_Pragma then
7149 Global_Discard_Names := True;
7152 -- Otherwise, check correct appropriate context
7155 Check_Is_In_Decl_Part_Or_Package_Spec;
7157 if Arg_Count = 0 then
7159 -- If there is no parameter, then from now on this pragma
7160 -- applies to any enumeration, exception or tagged type
7161 -- defined in the current declarative part, and recursively
7162 -- to any nested scope.
7164 Set_Discard_Names (Current_Scope, Sense);
7168 Check_Arg_Count (1);
7169 Check_Optional_Identifier (Arg1, Name_On);
7170 Check_Arg_Is_Local_Name (Arg1);
7172 E_Id := Get_Pragma_Arg (Arg1);
7174 if Etype (E_Id) = Any_Type then
7180 if (Is_First_Subtype (E)
7182 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
7183 or else Ekind (E) = E_Exception
7185 Set_Discard_Names (E, Sense);
7188 ("inappropriate entity for pragma%", Arg1);
7199 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
7201 when Pragma_Elaborate => Elaborate : declare
7206 -- Pragma must be in context items list of a compilation unit
7208 if not Is_In_Context_Clause then
7212 -- Must be at least one argument
7214 if Arg_Count = 0 then
7215 Error_Pragma ("pragma% requires at least one argument");
7218 -- In Ada 83 mode, there can be no items following it in the
7219 -- context list except other pragmas and implicit with clauses
7220 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
7221 -- placement rule does not apply.
7223 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
7225 while Present (Citem) loop
7226 if Nkind (Citem) = N_Pragma
7227 or else (Nkind (Citem) = N_With_Clause
7228 and then Implicit_With (Citem))
7233 ("(Ada 83) pragma% must be at end of context clause");
7240 -- Finally, the arguments must all be units mentioned in a with
7241 -- clause in the same context clause. Note we already checked (in
7242 -- Par.Prag) that the arguments are all identifiers or selected
7246 Outer : while Present (Arg) loop
7247 Citem := First (List_Containing (N));
7248 Inner : while Citem /= N loop
7249 if Nkind (Citem) = N_With_Clause
7250 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
7252 Set_Elaborate_Present (Citem, True);
7253 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
7255 -- With the pragma present, elaboration calls on
7256 -- subprograms from the named unit need no further
7257 -- checks, as long as the pragma appears in the current
7258 -- compilation unit. If the pragma appears in some unit
7259 -- in the context, there might still be a need for an
7260 -- Elaborate_All_Desirable from the current compilation
7261 -- to the named unit, so we keep the check enabled.
7263 if In_Extended_Main_Source_Unit (N) then
7264 Set_Suppress_Elaboration_Warnings
7265 (Entity (Name (Citem)));
7276 ("argument of pragma% is not with'ed unit", Arg);
7282 -- Give a warning if operating in static mode with -gnatwl
7283 -- (elaboration warnings enabled) switch set.
7285 if Elab_Warnings and not Dynamic_Elaboration_Checks then
7287 ("?use of pragma Elaborate may not be safe", N);
7289 ("?use pragma Elaborate_All instead if possible", N);
7297 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
7299 when Pragma_Elaborate_All => Elaborate_All : declare
7304 Check_Ada_83_Warning;
7306 -- Pragma must be in context items list of a compilation unit
7308 if not Is_In_Context_Clause then
7312 -- Must be at least one argument
7314 if Arg_Count = 0 then
7315 Error_Pragma ("pragma% requires at least one argument");
7318 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
7319 -- have to appear at the end of the context clause, but may
7320 -- appear mixed in with other items, even in Ada 83 mode.
7322 -- Final check: the arguments must all be units mentioned in
7323 -- a with clause in the same context clause. Note that we
7324 -- already checked (in Par.Prag) that all the arguments are
7325 -- either identifiers or selected components.
7328 Outr : while Present (Arg) loop
7329 Citem := First (List_Containing (N));
7330 Innr : while Citem /= N loop
7331 if Nkind (Citem) = N_With_Clause
7332 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
7334 Set_Elaborate_All_Present (Citem, True);
7335 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
7337 -- Suppress warnings and elaboration checks on the named
7338 -- unit if the pragma is in the current compilation, as
7339 -- for pragma Elaborate.
7341 if In_Extended_Main_Source_Unit (N) then
7342 Set_Suppress_Elaboration_Warnings
7343 (Entity (Name (Citem)));
7352 Set_Error_Posted (N);
7354 ("argument of pragma% is not with'ed unit", Arg);
7361 --------------------
7362 -- Elaborate_Body --
7363 --------------------
7365 -- pragma Elaborate_Body [( library_unit_NAME )];
7367 when Pragma_Elaborate_Body => Elaborate_Body : declare
7368 Cunit_Node : Node_Id;
7369 Cunit_Ent : Entity_Id;
7372 Check_Ada_83_Warning;
7373 Check_Valid_Library_Unit_Pragma;
7375 if Nkind (N) = N_Null_Statement then
7379 Cunit_Node := Cunit (Current_Sem_Unit);
7380 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
7382 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
7385 Error_Pragma ("pragma% must refer to a spec, not a body");
7387 Set_Body_Required (Cunit_Node, True);
7388 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
7390 -- If we are in dynamic elaboration mode, then we suppress
7391 -- elaboration warnings for the unit, since it is definitely
7392 -- fine NOT to do dynamic checks at the first level (and such
7393 -- checks will be suppressed because no elaboration boolean
7394 -- is created for Elaborate_Body packages).
7396 -- But in the static model of elaboration, Elaborate_Body is
7397 -- definitely NOT good enough to ensure elaboration safety on
7398 -- its own, since the body may WITH other units that are not
7399 -- safe from an elaboration point of view, so a client must
7400 -- still do an Elaborate_All on such units.
7402 -- Debug flag -gnatdD restores the old behavior of 3.13, where
7403 -- Elaborate_Body always suppressed elab warnings.
7405 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
7406 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
7411 ------------------------
7412 -- Elaboration_Checks --
7413 ------------------------
7415 -- pragma Elaboration_Checks (Static | Dynamic);
7417 when Pragma_Elaboration_Checks =>
7419 Check_Arg_Count (1);
7420 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
7421 Dynamic_Elaboration_Checks :=
7422 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
7428 -- pragma Eliminate (
7429 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
7430 -- [,[Entity =>] IDENTIFIER |
7431 -- SELECTED_COMPONENT |
7433 -- [, OVERLOADING_RESOLUTION]);
7435 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
7438 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
7441 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
7443 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
7444 -- Result_Type => result_SUBTYPE_NAME]
7446 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
7447 -- SUBTYPE_NAME ::= STRING_LITERAL
7449 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
7450 -- SOURCE_TRACE ::= STRING_LITERAL
7452 when Pragma_Eliminate => Eliminate : declare
7453 Args : Args_List (1 .. 5);
7454 Names : constant Name_List (1 .. 5) := (
7457 Name_Parameter_Types,
7459 Name_Source_Location);
7461 Unit_Name : Node_Id renames Args (1);
7462 Entity : Node_Id renames Args (2);
7463 Parameter_Types : Node_Id renames Args (3);
7464 Result_Type : Node_Id renames Args (4);
7465 Source_Location : Node_Id renames Args (5);
7469 Check_Valid_Configuration_Pragma;
7470 Gather_Associations (Names, Args);
7472 if No (Unit_Name) then
7473 Error_Pragma ("missing Unit_Name argument for pragma%");
7477 and then (Present (Parameter_Types)
7479 Present (Result_Type)
7481 Present (Source_Location))
7483 Error_Pragma ("missing Entity argument for pragma%");
7486 if (Present (Parameter_Types)
7488 Present (Result_Type))
7490 Present (Source_Location)
7493 ("parameter profile and source location cannot " &
7494 "be used together in pragma%");
7497 Process_Eliminate_Pragma
7511 -- [ Convention =>] convention_IDENTIFIER,
7512 -- [ Entity =>] local_NAME
7513 -- [, [External_Name =>] static_string_EXPRESSION ]
7514 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7516 when Pragma_Export => Export : declare
7520 pragma Warnings (Off, C);
7523 Check_Ada_83_Warning;
7529 Check_At_Least_N_Arguments (2);
7530 Check_At_Most_N_Arguments (4);
7531 Process_Convention (C, Def_Id);
7533 if Ekind (Def_Id) /= E_Constant then
7534 Note_Possible_Modification
7535 (Get_Pragma_Arg (Arg2), Sure => False);
7538 Process_Interface_Name (Def_Id, Arg3, Arg4);
7539 Set_Exported (Def_Id, Arg2);
7541 -- If the entity is a deferred constant, propagate the information
7542 -- to the full view, because gigi elaborates the full view only.
7544 if Ekind (Def_Id) = E_Constant
7545 and then Present (Full_View (Def_Id))
7548 Id2 : constant Entity_Id := Full_View (Def_Id);
7550 Set_Is_Exported (Id2, Is_Exported (Def_Id));
7551 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
7552 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
7557 ----------------------
7558 -- Export_Exception --
7559 ----------------------
7561 -- pragma Export_Exception (
7562 -- [Internal =>] LOCAL_NAME
7563 -- [, [External =>] EXTERNAL_SYMBOL]
7564 -- [, [Form =>] Ada | VMS]
7565 -- [, [Code =>] static_integer_EXPRESSION]);
7567 when Pragma_Export_Exception => Export_Exception : declare
7568 Args : Args_List (1 .. 4);
7569 Names : constant Name_List (1 .. 4) := (
7575 Internal : Node_Id renames Args (1);
7576 External : Node_Id renames Args (2);
7577 Form : Node_Id renames Args (3);
7578 Code : Node_Id renames Args (4);
7583 if Inside_A_Generic then
7584 Error_Pragma ("pragma% cannot be used for generic entities");
7587 Gather_Associations (Names, Args);
7588 Process_Extended_Import_Export_Exception_Pragma (
7589 Arg_Internal => Internal,
7590 Arg_External => External,
7594 if not Is_VMS_Exception (Entity (Internal)) then
7595 Set_Exported (Entity (Internal), Internal);
7597 end Export_Exception;
7599 ---------------------
7600 -- Export_Function --
7601 ---------------------
7603 -- pragma Export_Function (
7604 -- [Internal =>] LOCAL_NAME
7605 -- [, [External =>] EXTERNAL_SYMBOL]
7606 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7607 -- [, [Result_Type =>] TYPE_DESIGNATOR]
7608 -- [, [Mechanism =>] MECHANISM]
7609 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
7611 -- EXTERNAL_SYMBOL ::=
7613 -- | static_string_EXPRESSION
7615 -- PARAMETER_TYPES ::=
7617 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7619 -- TYPE_DESIGNATOR ::=
7621 -- | subtype_Name ' Access
7625 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7627 -- MECHANISM_ASSOCIATION ::=
7628 -- [formal_parameter_NAME =>] MECHANISM_NAME
7630 -- MECHANISM_NAME ::=
7633 -- | Descriptor [([Class =>] CLASS_NAME)]
7635 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7637 when Pragma_Export_Function => Export_Function : declare
7638 Args : Args_List (1 .. 6);
7639 Names : constant Name_List (1 .. 6) := (
7642 Name_Parameter_Types,
7645 Name_Result_Mechanism);
7647 Internal : Node_Id renames Args (1);
7648 External : Node_Id renames Args (2);
7649 Parameter_Types : Node_Id renames Args (3);
7650 Result_Type : Node_Id renames Args (4);
7651 Mechanism : Node_Id renames Args (5);
7652 Result_Mechanism : Node_Id renames Args (6);
7656 Gather_Associations (Names, Args);
7657 Process_Extended_Import_Export_Subprogram_Pragma (
7658 Arg_Internal => Internal,
7659 Arg_External => External,
7660 Arg_Parameter_Types => Parameter_Types,
7661 Arg_Result_Type => Result_Type,
7662 Arg_Mechanism => Mechanism,
7663 Arg_Result_Mechanism => Result_Mechanism);
7664 end Export_Function;
7670 -- pragma Export_Object (
7671 -- [Internal =>] LOCAL_NAME
7672 -- [, [External =>] EXTERNAL_SYMBOL]
7673 -- [, [Size =>] EXTERNAL_SYMBOL]);
7675 -- EXTERNAL_SYMBOL ::=
7677 -- | static_string_EXPRESSION
7679 -- PARAMETER_TYPES ::=
7681 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7683 -- TYPE_DESIGNATOR ::=
7685 -- | subtype_Name ' Access
7689 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7691 -- MECHANISM_ASSOCIATION ::=
7692 -- [formal_parameter_NAME =>] MECHANISM_NAME
7694 -- MECHANISM_NAME ::=
7697 -- | Descriptor [([Class =>] CLASS_NAME)]
7699 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7701 when Pragma_Export_Object => Export_Object : declare
7702 Args : Args_List (1 .. 3);
7703 Names : constant Name_List (1 .. 3) := (
7708 Internal : Node_Id renames Args (1);
7709 External : Node_Id renames Args (2);
7710 Size : Node_Id renames Args (3);
7714 Gather_Associations (Names, Args);
7715 Process_Extended_Import_Export_Object_Pragma (
7716 Arg_Internal => Internal,
7717 Arg_External => External,
7721 ----------------------
7722 -- Export_Procedure --
7723 ----------------------
7725 -- pragma Export_Procedure (
7726 -- [Internal =>] LOCAL_NAME
7727 -- [, [External =>] EXTERNAL_SYMBOL]
7728 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7729 -- [, [Mechanism =>] MECHANISM]);
7731 -- EXTERNAL_SYMBOL ::=
7733 -- | static_string_EXPRESSION
7735 -- PARAMETER_TYPES ::=
7737 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7739 -- TYPE_DESIGNATOR ::=
7741 -- | subtype_Name ' Access
7745 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7747 -- MECHANISM_ASSOCIATION ::=
7748 -- [formal_parameter_NAME =>] MECHANISM_NAME
7750 -- MECHANISM_NAME ::=
7753 -- | Descriptor [([Class =>] CLASS_NAME)]
7755 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7757 when Pragma_Export_Procedure => Export_Procedure : declare
7758 Args : Args_List (1 .. 4);
7759 Names : constant Name_List (1 .. 4) := (
7762 Name_Parameter_Types,
7765 Internal : Node_Id renames Args (1);
7766 External : Node_Id renames Args (2);
7767 Parameter_Types : Node_Id renames Args (3);
7768 Mechanism : Node_Id renames Args (4);
7772 Gather_Associations (Names, Args);
7773 Process_Extended_Import_Export_Subprogram_Pragma (
7774 Arg_Internal => Internal,
7775 Arg_External => External,
7776 Arg_Parameter_Types => Parameter_Types,
7777 Arg_Mechanism => Mechanism);
7778 end Export_Procedure;
7784 -- pragma Export_Value (
7785 -- [Value =>] static_integer_EXPRESSION,
7786 -- [Link_Name =>] static_string_EXPRESSION);
7788 when Pragma_Export_Value =>
7790 Check_Arg_Order ((Name_Value, Name_Link_Name));
7791 Check_Arg_Count (2);
7793 Check_Optional_Identifier (Arg1, Name_Value);
7794 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
7796 Check_Optional_Identifier (Arg2, Name_Link_Name);
7797 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
7799 -----------------------------
7800 -- Export_Valued_Procedure --
7801 -----------------------------
7803 -- pragma Export_Valued_Procedure (
7804 -- [Internal =>] LOCAL_NAME
7805 -- [, [External =>] EXTERNAL_SYMBOL,]
7806 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
7807 -- [, [Mechanism =>] MECHANISM]);
7809 -- EXTERNAL_SYMBOL ::=
7811 -- | static_string_EXPRESSION
7813 -- PARAMETER_TYPES ::=
7815 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7817 -- TYPE_DESIGNATOR ::=
7819 -- | subtype_Name ' Access
7823 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7825 -- MECHANISM_ASSOCIATION ::=
7826 -- [formal_parameter_NAME =>] MECHANISM_NAME
7828 -- MECHANISM_NAME ::=
7831 -- | Descriptor [([Class =>] CLASS_NAME)]
7833 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7835 when Pragma_Export_Valued_Procedure =>
7836 Export_Valued_Procedure : declare
7837 Args : Args_List (1 .. 4);
7838 Names : constant Name_List (1 .. 4) := (
7841 Name_Parameter_Types,
7844 Internal : Node_Id renames Args (1);
7845 External : Node_Id renames Args (2);
7846 Parameter_Types : Node_Id renames Args (3);
7847 Mechanism : Node_Id renames Args (4);
7851 Gather_Associations (Names, Args);
7852 Process_Extended_Import_Export_Subprogram_Pragma (
7853 Arg_Internal => Internal,
7854 Arg_External => External,
7855 Arg_Parameter_Types => Parameter_Types,
7856 Arg_Mechanism => Mechanism);
7857 end Export_Valued_Procedure;
7863 -- pragma Extend_System ([Name =>] Identifier);
7865 when Pragma_Extend_System => Extend_System : declare
7868 Check_Valid_Configuration_Pragma;
7869 Check_Arg_Count (1);
7870 Check_Optional_Identifier (Arg1, Name_Name);
7871 Check_Arg_Is_Identifier (Arg1);
7873 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
7876 and then Name_Buffer (1 .. 4) = "aux_"
7878 if Present (System_Extend_Pragma_Arg) then
7879 if Chars (Get_Pragma_Arg (Arg1)) =
7880 Chars (Expression (System_Extend_Pragma_Arg))
7884 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
7885 Error_Pragma ("pragma% conflicts with that #");
7889 System_Extend_Pragma_Arg := Arg1;
7891 if not GNAT_Mode then
7892 System_Extend_Unit := Arg1;
7896 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
7900 ------------------------
7901 -- Extensions_Allowed --
7902 ------------------------
7904 -- pragma Extensions_Allowed (ON | OFF);
7906 when Pragma_Extensions_Allowed =>
7908 Check_Arg_Count (1);
7909 Check_No_Identifiers;
7910 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
7912 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
7913 Extensions_Allowed := True;
7914 Ada_Version := Ada_Version_Type'Last;
7917 Extensions_Allowed := False;
7918 Ada_Version := Ada_Version_Explicit;
7925 -- pragma External (
7926 -- [ Convention =>] convention_IDENTIFIER,
7927 -- [ Entity =>] local_NAME
7928 -- [, [External_Name =>] static_string_EXPRESSION ]
7929 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7931 when Pragma_External => External : declare
7935 pragma Warnings (Off, C);
7944 Check_At_Least_N_Arguments (2);
7945 Check_At_Most_N_Arguments (4);
7946 Process_Convention (C, Def_Id);
7947 Note_Possible_Modification
7948 (Get_Pragma_Arg (Arg2), Sure => False);
7949 Process_Interface_Name (Def_Id, Arg3, Arg4);
7950 Set_Exported (Def_Id, Arg2);
7953 --------------------------
7954 -- External_Name_Casing --
7955 --------------------------
7957 -- pragma External_Name_Casing (
7958 -- UPPERCASE | LOWERCASE
7959 -- [, AS_IS | UPPERCASE | LOWERCASE]);
7961 when Pragma_External_Name_Casing => External_Name_Casing : declare
7964 Check_No_Identifiers;
7966 if Arg_Count = 2 then
7968 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
7970 case Chars (Get_Pragma_Arg (Arg2)) is
7972 Opt.External_Name_Exp_Casing := As_Is;
7974 when Name_Uppercase =>
7975 Opt.External_Name_Exp_Casing := Uppercase;
7977 when Name_Lowercase =>
7978 Opt.External_Name_Exp_Casing := Lowercase;
7985 Check_Arg_Count (1);
7988 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
7990 case Chars (Get_Pragma_Arg (Arg1)) is
7991 when Name_Uppercase =>
7992 Opt.External_Name_Imp_Casing := Uppercase;
7994 when Name_Lowercase =>
7995 Opt.External_Name_Imp_Casing := Lowercase;
8000 end External_Name_Casing;
8002 --------------------------
8003 -- Favor_Top_Level --
8004 --------------------------
8006 -- pragma Favor_Top_Level (type_NAME);
8008 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
8009 Named_Entity : Entity_Id;
8013 Check_No_Identifiers;
8014 Check_Arg_Count (1);
8015 Check_Arg_Is_Local_Name (Arg1);
8016 Named_Entity := Entity (Get_Pragma_Arg (Arg1));
8018 -- If it's an access-to-subprogram type (in particular, not a
8019 -- subtype), set the flag on that type.
8021 if Is_Access_Subprogram_Type (Named_Entity) then
8023 Set_Can_Use_Internal_Rep (Named_Entity, False);
8026 -- Otherwise it's an error (name denotes the wrong sort of entity)
8030 ("access-to-subprogram type expected",
8031 Get_Pragma_Arg (Arg1));
8033 end Favor_Top_Level;
8039 -- pragma Fast_Math;
8041 when Pragma_Fast_Math =>
8043 Check_No_Identifiers;
8044 Check_Valid_Configuration_Pragma;
8047 ---------------------------
8048 -- Finalize_Storage_Only --
8049 ---------------------------
8051 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
8053 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
8054 Assoc : constant Node_Id := Arg1;
8055 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
8060 Check_No_Identifiers;
8061 Check_Arg_Count (1);
8062 Check_Arg_Is_Local_Name (Arg1);
8064 Find_Type (Type_Id);
8065 Typ := Entity (Type_Id);
8068 or else Rep_Item_Too_Early (Typ, N)
8072 Typ := Underlying_Type (Typ);
8075 if not Is_Controlled (Typ) then
8076 Error_Pragma ("pragma% must specify controlled type");
8079 Check_First_Subtype (Arg1);
8081 if Finalize_Storage_Only (Typ) then
8082 Error_Pragma ("duplicate pragma%, only one allowed");
8084 elsif not Rep_Item_Too_Late (Typ, N) then
8085 Set_Finalize_Storage_Only (Base_Type (Typ), True);
8087 end Finalize_Storage;
8089 --------------------------
8090 -- Float_Representation --
8091 --------------------------
8093 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
8095 -- FLOAT_REP ::= VAX_Float | IEEE_Float
8097 when Pragma_Float_Representation => Float_Representation : declare
8105 if Arg_Count = 1 then
8106 Check_Valid_Configuration_Pragma;
8108 Check_Arg_Count (2);
8109 Check_Optional_Identifier (Arg2, Name_Entity);
8110 Check_Arg_Is_Local_Name (Arg2);
8113 Check_No_Identifier (Arg1);
8114 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
8116 if not OpenVMS_On_Target then
8117 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8119 ("?pragma% ignored (applies only to Open'V'M'S)");
8125 -- One argument case
8127 if Arg_Count = 1 then
8128 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8129 if Opt.Float_Format = 'I' then
8130 Error_Pragma ("'I'E'E'E format previously specified");
8133 Opt.Float_Format := 'V';
8136 if Opt.Float_Format = 'V' then
8137 Error_Pragma ("'V'A'X format previously specified");
8140 Opt.Float_Format := 'I';
8143 Set_Standard_Fpt_Formats;
8145 -- Two argument case
8148 Argx := Get_Pragma_Arg (Arg2);
8150 if not Is_Entity_Name (Argx)
8151 or else not Is_Floating_Point_Type (Entity (Argx))
8154 ("second argument of% pragma must be floating-point type",
8158 Ent := Entity (Argx);
8159 Digs := UI_To_Int (Digits_Value (Ent));
8161 -- Two arguments, VAX_Float case
8163 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8165 when 6 => Set_F_Float (Ent);
8166 when 9 => Set_D_Float (Ent);
8167 when 15 => Set_G_Float (Ent);
8171 ("wrong digits value, must be 6,9 or 15", Arg2);
8174 -- Two arguments, IEEE_Float case
8178 when 6 => Set_IEEE_Short (Ent);
8179 when 15 => Set_IEEE_Long (Ent);
8183 ("wrong digits value, must be 6 or 15", Arg2);
8187 end Float_Representation;
8193 -- pragma Ident (static_string_EXPRESSION)
8195 -- Note: pragma Comment shares this processing. Pragma Comment is
8196 -- identical to Ident, except that the restriction of the argument to
8197 -- 31 characters and the placement restrictions are not enforced for
8200 when Pragma_Ident | Pragma_Comment => Ident : declare
8205 Check_Arg_Count (1);
8206 Check_No_Identifiers;
8207 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
8210 -- For pragma Ident, preserve DEC compatibility by requiring the
8211 -- pragma to appear in a declarative part or package spec.
8213 if Prag_Id = Pragma_Ident then
8214 Check_Is_In_Decl_Part_Or_Package_Spec;
8217 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
8224 GP := Parent (Parent (N));
8226 if Nkind_In (GP, N_Package_Declaration,
8227 N_Generic_Package_Declaration)
8232 -- If we have a compilation unit, then record the ident value,
8233 -- checking for improper duplication.
8235 if Nkind (GP) = N_Compilation_Unit then
8236 CS := Ident_String (Current_Sem_Unit);
8238 if Present (CS) then
8240 -- For Ident, we do not permit multiple instances
8242 if Prag_Id = Pragma_Ident then
8243 Error_Pragma ("duplicate% pragma not permitted");
8245 -- For Comment, we concatenate the string, unless we want
8246 -- to preserve the tree structure for ASIS.
8248 elsif not ASIS_Mode then
8249 Start_String (Strval (CS));
8250 Store_String_Char (' ');
8251 Store_String_Chars (Strval (Str));
8252 Set_Strval (CS, End_String);
8256 -- In VMS, the effect of IDENT is achieved by passing
8257 -- --identification=name as a --for-linker switch.
8259 if OpenVMS_On_Target then
8262 ("--for-linker=--identification=");
8263 String_To_Name_Buffer (Strval (Str));
8264 Store_String_Chars (Name_Buffer (1 .. Name_Len));
8266 -- Only the last processed IDENT is saved. The main
8267 -- purpose is so an IDENT associated with a main
8268 -- procedure will be used in preference to an IDENT
8269 -- associated with a with'd package.
8271 Replace_Linker_Option_String
8272 (End_String, "--for-linker=--identification=");
8275 Set_Ident_String (Current_Sem_Unit, Str);
8278 -- For subunits, we just ignore the Ident, since in GNAT these
8279 -- are not separate object files, and hence not separate units
8280 -- in the unit table.
8282 elsif Nkind (GP) = N_Subunit then
8285 -- Otherwise we have a misplaced pragma Ident, but we ignore
8286 -- this if we are in an instantiation, since it comes from
8287 -- a generic, and has no relevance to the instantiation.
8289 elsif Prag_Id = Pragma_Ident then
8290 if Instantiation_Location (Loc) = No_Location then
8291 Error_Pragma ("pragma% only allowed at outer level");
8301 -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
8302 -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
8304 when Pragma_Implemented => Implemented : declare
8305 Proc_Id : Entity_Id;
8310 Check_Arg_Count (2);
8311 Check_No_Identifiers;
8312 Check_Arg_Is_Identifier (Arg1);
8313 Check_Arg_Is_Local_Name (Arg1);
8315 (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
8317 -- Extract the name of the local procedure
8319 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
8321 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
8322 -- primitive procedure of a synchronized tagged type.
8324 if Ekind (Proc_Id) = E_Procedure
8325 and then Is_Primitive (Proc_Id)
8326 and then Present (First_Formal (Proc_Id))
8328 Typ := Etype (First_Formal (Proc_Id));
8330 if Is_Tagged_Type (Typ)
8333 -- Check for a protected, a synchronized or a task interface
8335 ((Is_Interface (Typ)
8336 and then Is_Synchronized_Interface (Typ))
8338 -- Check for a protected type or a task type that implements
8342 (Is_Concurrent_Record_Type (Typ)
8343 and then Present (Interfaces (Typ)))
8345 -- Check for a private record extension with keyword
8349 (Ekind_In (Typ, E_Record_Type_With_Private,
8350 E_Record_Subtype_With_Private)
8351 and then Synchronized_Present (Parent (Typ))))
8356 ("controlling formal must be of synchronized " &
8357 "tagged type", Arg1);
8361 -- Procedures declared inside a protected type must be accepted
8363 elsif Ekind (Proc_Id) = E_Procedure
8364 and then Is_Protected_Type (Scope (Proc_Id))
8368 -- The first argument is not a primitive procedure
8372 ("pragma % must be applied to a primitive procedure", Arg1);
8376 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
8377 -- By_Protected_Procedure to the primitive procedure of a task
8380 if Chars (Arg2) = Name_By_Protected_Procedure
8381 and then Is_Interface (Typ)
8382 and then Is_Task_Interface (Typ)
8385 ("implementation kind By_Protected_Procedure cannot be " &
8386 "applied to a task interface primitive", Arg2);
8390 Record_Rep_Item (Proc_Id, N);
8393 ----------------------
8394 -- Implicit_Packing --
8395 ----------------------
8397 -- pragma Implicit_Packing;
8399 when Pragma_Implicit_Packing =>
8401 Check_Arg_Count (0);
8402 Implicit_Packing := True;
8409 -- [Convention =>] convention_IDENTIFIER,
8410 -- [Entity =>] local_NAME
8411 -- [, [External_Name =>] static_string_EXPRESSION ]
8412 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8414 when Pragma_Import =>
8415 Check_Ada_83_Warning;
8421 Check_At_Least_N_Arguments (2);
8422 Check_At_Most_N_Arguments (4);
8423 Process_Import_Or_Interface;
8425 ----------------------
8426 -- Import_Exception --
8427 ----------------------
8429 -- pragma Import_Exception (
8430 -- [Internal =>] LOCAL_NAME
8431 -- [, [External =>] EXTERNAL_SYMBOL]
8432 -- [, [Form =>] Ada | VMS]
8433 -- [, [Code =>] static_integer_EXPRESSION]);
8435 when Pragma_Import_Exception => Import_Exception : declare
8436 Args : Args_List (1 .. 4);
8437 Names : constant Name_List (1 .. 4) := (
8443 Internal : Node_Id renames Args (1);
8444 External : Node_Id renames Args (2);
8445 Form : Node_Id renames Args (3);
8446 Code : Node_Id renames Args (4);
8450 Gather_Associations (Names, Args);
8452 if Present (External) and then Present (Code) then
8454 ("cannot give both External and Code options for pragma%");
8457 Process_Extended_Import_Export_Exception_Pragma (
8458 Arg_Internal => Internal,
8459 Arg_External => External,
8463 if not Is_VMS_Exception (Entity (Internal)) then
8464 Set_Imported (Entity (Internal));
8466 end Import_Exception;
8468 ---------------------
8469 -- Import_Function --
8470 ---------------------
8472 -- pragma Import_Function (
8473 -- [Internal =>] LOCAL_NAME,
8474 -- [, [External =>] EXTERNAL_SYMBOL]
8475 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8476 -- [, [Result_Type =>] SUBTYPE_MARK]
8477 -- [, [Mechanism =>] MECHANISM]
8478 -- [, [Result_Mechanism =>] MECHANISM_NAME]
8479 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
8481 -- EXTERNAL_SYMBOL ::=
8483 -- | static_string_EXPRESSION
8485 -- PARAMETER_TYPES ::=
8487 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8489 -- TYPE_DESIGNATOR ::=
8491 -- | subtype_Name ' Access
8495 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8497 -- MECHANISM_ASSOCIATION ::=
8498 -- [formal_parameter_NAME =>] MECHANISM_NAME
8500 -- MECHANISM_NAME ::=
8503 -- | Descriptor [([Class =>] CLASS_NAME)]
8505 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8507 when Pragma_Import_Function => Import_Function : declare
8508 Args : Args_List (1 .. 7);
8509 Names : constant Name_List (1 .. 7) := (
8512 Name_Parameter_Types,
8515 Name_Result_Mechanism,
8516 Name_First_Optional_Parameter);
8518 Internal : Node_Id renames Args (1);
8519 External : Node_Id renames Args (2);
8520 Parameter_Types : Node_Id renames Args (3);
8521 Result_Type : Node_Id renames Args (4);
8522 Mechanism : Node_Id renames Args (5);
8523 Result_Mechanism : Node_Id renames Args (6);
8524 First_Optional_Parameter : Node_Id renames Args (7);
8528 Gather_Associations (Names, Args);
8529 Process_Extended_Import_Export_Subprogram_Pragma (
8530 Arg_Internal => Internal,
8531 Arg_External => External,
8532 Arg_Parameter_Types => Parameter_Types,
8533 Arg_Result_Type => Result_Type,
8534 Arg_Mechanism => Mechanism,
8535 Arg_Result_Mechanism => Result_Mechanism,
8536 Arg_First_Optional_Parameter => First_Optional_Parameter);
8537 end Import_Function;
8543 -- pragma Import_Object (
8544 -- [Internal =>] LOCAL_NAME
8545 -- [, [External =>] EXTERNAL_SYMBOL]
8546 -- [, [Size =>] EXTERNAL_SYMBOL]);
8548 -- EXTERNAL_SYMBOL ::=
8550 -- | static_string_EXPRESSION
8552 when Pragma_Import_Object => Import_Object : declare
8553 Args : Args_List (1 .. 3);
8554 Names : constant Name_List (1 .. 3) := (
8559 Internal : Node_Id renames Args (1);
8560 External : Node_Id renames Args (2);
8561 Size : Node_Id renames Args (3);
8565 Gather_Associations (Names, Args);
8566 Process_Extended_Import_Export_Object_Pragma (
8567 Arg_Internal => Internal,
8568 Arg_External => External,
8572 ----------------------
8573 -- Import_Procedure --
8574 ----------------------
8576 -- pragma Import_Procedure (
8577 -- [Internal =>] LOCAL_NAME
8578 -- [, [External =>] EXTERNAL_SYMBOL]
8579 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8580 -- [, [Mechanism =>] MECHANISM]
8581 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
8583 -- EXTERNAL_SYMBOL ::=
8585 -- | static_string_EXPRESSION
8587 -- PARAMETER_TYPES ::=
8589 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8591 -- TYPE_DESIGNATOR ::=
8593 -- | subtype_Name ' Access
8597 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8599 -- MECHANISM_ASSOCIATION ::=
8600 -- [formal_parameter_NAME =>] MECHANISM_NAME
8602 -- MECHANISM_NAME ::=
8605 -- | Descriptor [([Class =>] CLASS_NAME)]
8607 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8609 when Pragma_Import_Procedure => Import_Procedure : declare
8610 Args : Args_List (1 .. 5);
8611 Names : constant Name_List (1 .. 5) := (
8614 Name_Parameter_Types,
8616 Name_First_Optional_Parameter);
8618 Internal : Node_Id renames Args (1);
8619 External : Node_Id renames Args (2);
8620 Parameter_Types : Node_Id renames Args (3);
8621 Mechanism : Node_Id renames Args (4);
8622 First_Optional_Parameter : Node_Id renames Args (5);
8626 Gather_Associations (Names, Args);
8627 Process_Extended_Import_Export_Subprogram_Pragma (
8628 Arg_Internal => Internal,
8629 Arg_External => External,
8630 Arg_Parameter_Types => Parameter_Types,
8631 Arg_Mechanism => Mechanism,
8632 Arg_First_Optional_Parameter => First_Optional_Parameter);
8633 end Import_Procedure;
8635 -----------------------------
8636 -- Import_Valued_Procedure --
8637 -----------------------------
8639 -- pragma Import_Valued_Procedure (
8640 -- [Internal =>] LOCAL_NAME
8641 -- [, [External =>] EXTERNAL_SYMBOL]
8642 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8643 -- [, [Mechanism =>] MECHANISM]
8644 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
8646 -- EXTERNAL_SYMBOL ::=
8648 -- | static_string_EXPRESSION
8650 -- PARAMETER_TYPES ::=
8652 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8654 -- TYPE_DESIGNATOR ::=
8656 -- | subtype_Name ' Access
8660 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8662 -- MECHANISM_ASSOCIATION ::=
8663 -- [formal_parameter_NAME =>] MECHANISM_NAME
8665 -- MECHANISM_NAME ::=
8668 -- | Descriptor [([Class =>] CLASS_NAME)]
8670 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8672 when Pragma_Import_Valued_Procedure =>
8673 Import_Valued_Procedure : declare
8674 Args : Args_List (1 .. 5);
8675 Names : constant Name_List (1 .. 5) := (
8678 Name_Parameter_Types,
8680 Name_First_Optional_Parameter);
8682 Internal : Node_Id renames Args (1);
8683 External : Node_Id renames Args (2);
8684 Parameter_Types : Node_Id renames Args (3);
8685 Mechanism : Node_Id renames Args (4);
8686 First_Optional_Parameter : Node_Id renames Args (5);
8690 Gather_Associations (Names, Args);
8691 Process_Extended_Import_Export_Subprogram_Pragma (
8692 Arg_Internal => Internal,
8693 Arg_External => External,
8694 Arg_Parameter_Types => Parameter_Types,
8695 Arg_Mechanism => Mechanism,
8696 Arg_First_Optional_Parameter => First_Optional_Parameter);
8697 end Import_Valued_Procedure;
8703 -- pragma Independent (LOCAL_NAME);
8705 when Pragma_Independent => Independent : declare
8712 Check_Ada_83_Warning;
8714 Check_No_Identifiers;
8715 Check_Arg_Count (1);
8716 Check_Arg_Is_Local_Name (Arg1);
8717 E_Id := Get_Pragma_Arg (Arg1);
8719 if Etype (E_Id) = Any_Type then
8724 D := Declaration_Node (E);
8727 -- Check duplicate before we chain ourselves!
8729 Check_Duplicate_Pragma (E);
8731 -- Check appropriate entity
8734 if Rep_Item_Too_Early (E, N)
8736 Rep_Item_Too_Late (E, N)
8740 Check_First_Subtype (Arg1);
8743 elsif K = N_Object_Declaration
8744 or else (K = N_Component_Declaration
8745 and then Original_Record_Component (E) = E)
8747 if Rep_Item_Too_Late (E, N) then
8753 ("inappropriate entity for pragma%", Arg1);
8756 Independence_Checks.Append ((N, E));
8759 ----------------------------
8760 -- Independent_Components --
8761 ----------------------------
8763 -- pragma Atomic_Components (array_LOCAL_NAME);
8765 -- This processing is shared by Volatile_Components
8767 when Pragma_Independent_Components => Independent_Components : declare
8774 Check_Ada_83_Warning;
8776 Check_No_Identifiers;
8777 Check_Arg_Count (1);
8778 Check_Arg_Is_Local_Name (Arg1);
8779 E_Id := Get_Pragma_Arg (Arg1);
8781 if Etype (E_Id) = Any_Type then
8787 -- Check duplicate before we chain ourselves!
8789 Check_Duplicate_Pragma (E);
8791 -- Check appropriate entity
8793 if Rep_Item_Too_Early (E, N)
8795 Rep_Item_Too_Late (E, N)
8800 D := Declaration_Node (E);
8803 if (K = N_Full_Type_Declaration
8804 and then (Is_Array_Type (E) or else Is_Record_Type (E)))
8806 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
8807 and then Nkind (D) = N_Object_Declaration
8808 and then Nkind (Object_Definition (D)) =
8809 N_Constrained_Array_Definition)
8811 Independence_Checks.Append ((N, E));
8814 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
8816 end Independent_Components;
8818 ------------------------
8819 -- Initialize_Scalars --
8820 ------------------------
8822 -- pragma Initialize_Scalars;
8824 when Pragma_Initialize_Scalars =>
8826 Check_Arg_Count (0);
8827 Check_Valid_Configuration_Pragma;
8828 Check_Restriction (No_Initialize_Scalars, N);
8830 -- Initialize_Scalars creates false positives in CodePeer,
8831 -- so ignore this pragma in this mode.
8833 if not Restriction_Active (No_Initialize_Scalars)
8834 and then not CodePeer_Mode
8836 Init_Or_Norm_Scalars := True;
8837 Initialize_Scalars := True;
8844 -- pragma Inline ( NAME {, NAME} );
8846 when Pragma_Inline =>
8848 -- Pragma is active if inlining option is active
8850 Process_Inline (Inline_Active);
8856 -- pragma Inline_Always ( NAME {, NAME} );
8858 when Pragma_Inline_Always =>
8861 -- Pragma always active unless in CodePeer mode, since this causes
8862 -- walk order issues.
8864 if not CodePeer_Mode then
8865 Process_Inline (True);
8868 --------------------
8869 -- Inline_Generic --
8870 --------------------
8872 -- pragma Inline_Generic (NAME {, NAME});
8874 when Pragma_Inline_Generic =>
8876 Process_Generic_List;
8878 ----------------------
8879 -- Inspection_Point --
8880 ----------------------
8882 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
8884 when Pragma_Inspection_Point => Inspection_Point : declare
8889 if Arg_Count > 0 then
8892 Exp := Get_Pragma_Arg (Arg);
8895 if not Is_Entity_Name (Exp)
8896 or else not Is_Object (Entity (Exp))
8898 Error_Pragma_Arg ("object name required", Arg);
8905 end Inspection_Point;
8911 -- pragma Interface (
8912 -- [ Convention =>] convention_IDENTIFIER,
8913 -- [ Entity =>] local_NAME
8914 -- [, [External_Name =>] static_string_EXPRESSION ]
8915 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8917 when Pragma_Interface =>
8924 Check_At_Least_N_Arguments (2);
8925 Check_At_Most_N_Arguments (4);
8926 Process_Import_Or_Interface;
8928 -- In Ada 2005, the permission to use Interface (a reserved word)
8929 -- as a pragma name is considered an obsolescent feature.
8931 if Ada_Version >= Ada_2005 then
8933 (No_Obsolescent_Features, Pragma_Identifier (N));
8936 --------------------
8937 -- Interface_Name --
8938 --------------------
8940 -- pragma Interface_Name (
8941 -- [ Entity =>] local_NAME
8942 -- [,[External_Name =>] static_string_EXPRESSION ]
8943 -- [,[Link_Name =>] static_string_EXPRESSION ]);
8945 when Pragma_Interface_Name => Interface_Name : declare
8954 ((Name_Entity, Name_External_Name, Name_Link_Name));
8955 Check_At_Least_N_Arguments (2);
8956 Check_At_Most_N_Arguments (3);
8957 Id := Get_Pragma_Arg (Arg1);
8960 if not Is_Entity_Name (Id) then
8962 ("first argument for pragma% must be entity name", Arg1);
8963 elsif Etype (Id) = Any_Type then
8966 Def_Id := Entity (Id);
8969 -- Special DEC-compatible processing for the object case, forces
8970 -- object to be imported.
8972 if Ekind (Def_Id) = E_Variable then
8973 Kill_Size_Check_Code (Def_Id);
8974 Note_Possible_Modification (Id, Sure => False);
8976 -- Initialization is not allowed for imported variable
8978 if Present (Expression (Parent (Def_Id)))
8979 and then Comes_From_Source (Expression (Parent (Def_Id)))
8981 Error_Msg_Sloc := Sloc (Def_Id);
8983 ("no initialization allowed for declaration of& #",
8987 -- For compatibility, support VADS usage of providing both
8988 -- pragmas Interface and Interface_Name to obtain the effect
8989 -- of a single Import pragma.
8991 if Is_Imported (Def_Id)
8992 and then Present (First_Rep_Item (Def_Id))
8993 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
8995 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
8999 Set_Imported (Def_Id);
9002 Set_Is_Public (Def_Id);
9003 Process_Interface_Name (Def_Id, Arg2, Arg3);
9006 -- Otherwise must be subprogram
9008 elsif not Is_Subprogram (Def_Id) then
9010 ("argument of pragma% is not subprogram", Arg1);
9013 Check_At_Most_N_Arguments (3);
9017 -- Loop through homonyms
9020 Def_Id := Get_Base_Subprogram (Hom_Id);
9022 if Is_Imported (Def_Id) then
9023 Process_Interface_Name (Def_Id, Arg2, Arg3);
9027 exit when From_Aspect_Specification (N);
9028 Hom_Id := Homonym (Hom_Id);
9030 exit when No (Hom_Id)
9031 or else Scope (Hom_Id) /= Current_Scope;
9036 ("argument of pragma% is not imported subprogram",
9042 -----------------------
9043 -- Interrupt_Handler --
9044 -----------------------
9046 -- pragma Interrupt_Handler (handler_NAME);
9048 when Pragma_Interrupt_Handler =>
9049 Check_Ada_83_Warning;
9050 Check_Arg_Count (1);
9051 Check_No_Identifiers;
9053 if No_Run_Time_Mode then
9054 Error_Msg_CRT ("Interrupt_Handler pragma", N);
9056 Check_Interrupt_Or_Attach_Handler;
9057 Process_Interrupt_Or_Attach_Handler;
9060 ------------------------
9061 -- Interrupt_Priority --
9062 ------------------------
9064 -- pragma Interrupt_Priority [(EXPRESSION)];
9066 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
9067 P : constant Node_Id := Parent (N);
9071 Check_Ada_83_Warning;
9073 if Arg_Count /= 0 then
9074 Arg := Get_Pragma_Arg (Arg1);
9075 Check_Arg_Count (1);
9076 Check_No_Identifiers;
9078 -- The expression must be analyzed in the special manner
9079 -- described in "Handling of Default and Per-Object
9080 -- Expressions" in sem.ads.
9082 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
9085 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
9089 elsif Has_Pragma_Priority (P) then
9090 Error_Pragma ("duplicate pragma% not allowed");
9093 Set_Has_Pragma_Priority (P, True);
9094 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
9096 end Interrupt_Priority;
9098 ---------------------
9099 -- Interrupt_State --
9100 ---------------------
9102 -- pragma Interrupt_State (
9103 -- [Name =>] INTERRUPT_ID,
9104 -- [State =>] INTERRUPT_STATE);
9106 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
9107 -- INTERRUPT_STATE => System | Runtime | User
9109 -- Note: if the interrupt id is given as an identifier, then it must
9110 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
9111 -- given as a static integer expression which must be in the range of
9112 -- Ada.Interrupts.Interrupt_ID.
9114 when Pragma_Interrupt_State => Interrupt_State : declare
9116 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
9117 -- This is the entity Ada.Interrupts.Interrupt_ID;
9119 State_Type : Character;
9120 -- Set to 's'/'r'/'u' for System/Runtime/User
9123 -- Index to entry in Interrupt_States table
9126 -- Value of interrupt
9128 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
9129 -- The first argument to the pragma
9131 Int_Ent : Entity_Id;
9132 -- Interrupt entity in Ada.Interrupts.Names
9136 Check_Arg_Order ((Name_Name, Name_State));
9137 Check_Arg_Count (2);
9139 Check_Optional_Identifier (Arg1, Name_Name);
9140 Check_Optional_Identifier (Arg2, Name_State);
9141 Check_Arg_Is_Identifier (Arg2);
9143 -- First argument is identifier
9145 if Nkind (Arg1X) = N_Identifier then
9147 -- Search list of names in Ada.Interrupts.Names
9149 Int_Ent := First_Entity (RTE (RE_Names));
9151 if No (Int_Ent) then
9152 Error_Pragma_Arg ("invalid interrupt name", Arg1);
9154 elsif Chars (Int_Ent) = Chars (Arg1X) then
9155 Int_Val := Expr_Value (Constant_Value (Int_Ent));
9159 Next_Entity (Int_Ent);
9162 -- First argument is not an identifier, so it must be a static
9163 -- expression of type Ada.Interrupts.Interrupt_ID.
9166 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
9167 Int_Val := Expr_Value (Arg1X);
9169 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
9171 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
9174 ("value not in range of type " &
9175 """Ada.Interrupts.Interrupt_'I'D""", Arg1);
9181 case Chars (Get_Pragma_Arg (Arg2)) is
9182 when Name_Runtime => State_Type := 'r';
9183 when Name_System => State_Type := 's';
9184 when Name_User => State_Type := 'u';
9187 Error_Pragma_Arg ("invalid interrupt state", Arg2);
9190 -- Check if entry is already stored
9192 IST_Num := Interrupt_States.First;
9194 -- If entry not found, add it
9196 if IST_Num > Interrupt_States.Last then
9197 Interrupt_States.Append
9198 ((Interrupt_Number => UI_To_Int (Int_Val),
9199 Interrupt_State => State_Type,
9200 Pragma_Loc => Loc));
9203 -- Case of entry for the same entry
9205 elsif Int_Val = Interrupt_States.Table (IST_Num).
9208 -- If state matches, done, no need to make redundant entry
9211 State_Type = Interrupt_States.Table (IST_Num).
9214 -- Otherwise if state does not match, error
9217 Interrupt_States.Table (IST_Num).Pragma_Loc;
9219 ("state conflicts with that given #", Arg2);
9223 IST_Num := IST_Num + 1;
9225 end Interrupt_State;
9227 ----------------------
9228 -- Java_Constructor --
9229 ----------------------
9231 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
9233 -- Also handles pragma CIL_Constructor
9235 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
9236 Java_Constructor : declare
9237 Convention : Convention_Id;
9241 This_Formal : Entity_Id;
9245 Check_Arg_Count (1);
9246 Check_Optional_Identifier (Arg1, Name_Entity);
9247 Check_Arg_Is_Local_Name (Arg1);
9249 Id := Get_Pragma_Arg (Arg1);
9250 Find_Program_Unit_Name (Id);
9252 -- If we did not find the name, we are done
9254 if Etype (Id) = Any_Type then
9258 -- Check wrong use of pragma in wrong VM target
9260 if VM_Target = No_VM then
9263 elsif VM_Target = CLI_Target
9264 and then Prag_Id = Pragma_Java_Constructor
9266 Error_Pragma ("must use pragma 'C'I'L_'Constructor");
9268 elsif VM_Target = JVM_Target
9269 and then Prag_Id = Pragma_CIL_Constructor
9271 Error_Pragma ("must use pragma 'Java_'Constructor");
9275 when Pragma_CIL_Constructor => Convention := Convention_CIL;
9276 when Pragma_Java_Constructor => Convention := Convention_Java;
9277 when others => null;
9280 Hom_Id := Entity (Id);
9282 -- Loop through homonyms
9285 Def_Id := Get_Base_Subprogram (Hom_Id);
9287 -- The constructor is required to be a function
9289 if Ekind (Def_Id) /= E_Function then
9290 if VM_Target = JVM_Target then
9292 ("pragma% requires function returning a " &
9293 "'Java access type", Def_Id);
9296 ("pragma% requires function returning a " &
9297 "'C'I'L access type", Def_Id);
9301 -- Check arguments: For tagged type the first formal must be
9302 -- named "this" and its type must be a named access type
9303 -- designating a class-wide tagged type that has convention
9304 -- CIL/Java. The first formal must also have a null default
9305 -- value. For example:
9307 -- type Typ is tagged ...
9308 -- type Ref is access all Typ;
9309 -- pragma Convention (CIL, Typ);
9311 -- function New_Typ (This : Ref) return Ref;
9312 -- function New_Typ (This : Ref; I : Integer) return Ref;
9313 -- pragma Cil_Constructor (New_Typ);
9315 -- Reason: The first formal must NOT be a primitive of the
9318 -- This rule also applies to constructors of delegates used
9319 -- to interface with standard target libraries. For example:
9321 -- type Delegate is access procedure ...
9322 -- pragma Import (CIL, Delegate, ...);
9324 -- function new_Delegate
9325 -- (This : Delegate := null; ... ) return Delegate;
9327 -- For value-types this rule does not apply.
9329 if not Is_Value_Type (Etype (Def_Id)) then
9330 if No (First_Formal (Def_Id)) then
9331 Error_Msg_Name_1 := Pname;
9332 Error_Msg_N ("% function must have parameters", Def_Id);
9336 -- In the JRE library we have several occurrences in which
9337 -- the "this" parameter is not the first formal.
9339 This_Formal := First_Formal (Def_Id);
9341 -- In the JRE library we have several occurrences in which
9342 -- the "this" parameter is not the first formal. Search for
9345 if VM_Target = JVM_Target then
9346 while Present (This_Formal)
9347 and then Get_Name_String (Chars (This_Formal)) /= "this"
9349 Next_Formal (This_Formal);
9352 if No (This_Formal) then
9353 This_Formal := First_Formal (Def_Id);
9357 -- Warning: The first parameter should be named "this".
9358 -- We temporarily allow it because we have the following
9359 -- case in the Java runtime (file s-osinte.ads) ???
9361 -- function new_Thread
9362 -- (Self_Id : System.Address) return Thread_Id;
9363 -- pragma Java_Constructor (new_Thread);
9365 if VM_Target = JVM_Target
9366 and then Get_Name_String (Chars (First_Formal (Def_Id)))
9368 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
9372 elsif Get_Name_String (Chars (This_Formal)) /= "this" then
9373 Error_Msg_Name_1 := Pname;
9375 ("first formal of % function must be named `this`",
9376 Parent (This_Formal));
9378 elsif not Is_Access_Type (Etype (This_Formal)) then
9379 Error_Msg_Name_1 := Pname;
9381 ("first formal of % function must be an access type",
9382 Parameter_Type (Parent (This_Formal)));
9384 -- For delegates the type of the first formal must be a
9385 -- named access-to-subprogram type (see previous example)
9387 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
9388 and then Ekind (Etype (This_Formal))
9389 /= E_Access_Subprogram_Type
9391 Error_Msg_Name_1 := Pname;
9393 ("first formal of % function must be a named access" &
9394 " to subprogram type",
9395 Parameter_Type (Parent (This_Formal)));
9397 -- Warning: We should reject anonymous access types because
9398 -- the constructor must not be handled as a primitive of the
9399 -- tagged type. We temporarily allow it because this profile
9400 -- is currently generated by cil2ada???
9402 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
9403 and then not Ekind_In (Etype (This_Formal),
9405 E_General_Access_Type,
9406 E_Anonymous_Access_Type)
9408 Error_Msg_Name_1 := Pname;
9410 ("first formal of % function must be a named access" &
9412 Parameter_Type (Parent (This_Formal)));
9414 elsif Atree.Convention
9415 (Designated_Type (Etype (This_Formal))) /= Convention
9417 Error_Msg_Name_1 := Pname;
9419 if Convention = Convention_Java then
9421 ("pragma% requires convention 'Cil in designated" &
9423 Parameter_Type (Parent (This_Formal)));
9426 ("pragma% requires convention 'Java in designated" &
9428 Parameter_Type (Parent (This_Formal)));
9431 elsif No (Expression (Parent (This_Formal)))
9432 or else Nkind (Expression (Parent (This_Formal))) /= N_Null
9434 Error_Msg_Name_1 := Pname;
9436 ("pragma% requires first formal with default `null`",
9437 Parameter_Type (Parent (This_Formal)));
9441 -- Check result type: the constructor must be a function
9443 -- * a value type (only allowed in the CIL compiler)
9444 -- * an access-to-subprogram type with convention Java/CIL
9445 -- * an access-type designating a type that has convention
9448 if Is_Value_Type (Etype (Def_Id)) then
9451 -- Access-to-subprogram type with convention Java/CIL
9453 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
9454 if Atree.Convention (Etype (Def_Id)) /= Convention then
9455 if Convention = Convention_Java then
9457 ("pragma% requires function returning a " &
9458 "'Java access type", Arg1);
9460 pragma Assert (Convention = Convention_CIL);
9462 ("pragma% requires function returning a " &
9463 "'C'I'L access type", Arg1);
9467 elsif Ekind (Etype (Def_Id)) in Access_Kind then
9468 if not Ekind_In (Etype (Def_Id), E_Access_Type,
9469 E_General_Access_Type)
9472 (Designated_Type (Etype (Def_Id))) /= Convention
9474 Error_Msg_Name_1 := Pname;
9476 if Convention = Convention_Java then
9478 ("pragma% requires function returning a named" &
9479 "'Java access type", Arg1);
9482 ("pragma% requires function returning a named" &
9483 "'C'I'L access type", Arg1);
9488 Set_Is_Constructor (Def_Id);
9489 Set_Convention (Def_Id, Convention);
9490 Set_Is_Imported (Def_Id);
9492 exit when From_Aspect_Specification (N);
9493 Hom_Id := Homonym (Hom_Id);
9495 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
9497 end Java_Constructor;
9499 ----------------------
9500 -- Java_Interface --
9501 ----------------------
9503 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
9505 when Pragma_Java_Interface => Java_Interface : declare
9511 Check_Arg_Count (1);
9512 Check_Optional_Identifier (Arg1, Name_Entity);
9513 Check_Arg_Is_Local_Name (Arg1);
9515 Arg := Get_Pragma_Arg (Arg1);
9518 if Etype (Arg) = Any_Type then
9522 if not Is_Entity_Name (Arg)
9523 or else not Is_Type (Entity (Arg))
9525 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
9528 Typ := Underlying_Type (Entity (Arg));
9530 -- For now simply check some of the semantic constraints on the
9531 -- type. This currently leaves out some restrictions on interface
9532 -- types, namely that the parent type must be java.lang.Object.Typ
9533 -- and that all primitives of the type should be declared
9536 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
9537 Error_Pragma_Arg ("pragma% requires an abstract "
9538 & "tagged type", Arg1);
9540 elsif not Has_Discriminants (Typ)
9541 or else Ekind (Etype (First_Discriminant (Typ)))
9542 /= E_Anonymous_Access_Type
9544 not Is_Class_Wide_Type
9545 (Designated_Type (Etype (First_Discriminant (Typ))))
9548 ("type must have a class-wide access discriminant", Arg1);
9556 -- pragma Keep_Names ([On => ] local_NAME);
9558 when Pragma_Keep_Names => Keep_Names : declare
9563 Check_Arg_Count (1);
9564 Check_Optional_Identifier (Arg1, Name_On);
9565 Check_Arg_Is_Local_Name (Arg1);
9567 Arg := Get_Pragma_Arg (Arg1);
9570 if Etype (Arg) = Any_Type then
9574 if not Is_Entity_Name (Arg)
9575 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
9578 ("pragma% requires a local enumeration type", Arg1);
9581 Set_Discard_Names (Entity (Arg), False);
9588 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
9590 when Pragma_License =>
9592 Check_Arg_Count (1);
9593 Check_No_Identifiers;
9594 Check_Valid_Configuration_Pragma;
9595 Check_Arg_Is_Identifier (Arg1);
9598 Sind : constant Source_File_Index :=
9599 Source_Index (Current_Sem_Unit);
9602 case Chars (Get_Pragma_Arg (Arg1)) is
9604 Set_License (Sind, GPL);
9606 when Name_Modified_GPL =>
9607 Set_License (Sind, Modified_GPL);
9609 when Name_Restricted =>
9610 Set_License (Sind, Restricted);
9612 when Name_Unrestricted =>
9613 Set_License (Sind, Unrestricted);
9616 Error_Pragma_Arg ("invalid license name", Arg1);
9624 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
9626 when Pragma_Link_With => Link_With : declare
9632 if Operating_Mode = Generate_Code
9633 and then In_Extended_Main_Source_Unit (N)
9635 Check_At_Least_N_Arguments (1);
9636 Check_No_Identifiers;
9637 Check_Is_In_Decl_Part_Or_Package_Spec;
9638 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
9642 while Present (Arg) loop
9643 Check_Arg_Is_Static_Expression (Arg, Standard_String);
9645 -- Store argument, converting sequences of spaces to a
9646 -- single null character (this is one of the differences
9647 -- in processing between Link_With and Linker_Options).
9650 C : constant Char_Code := Get_Char_Code (' ');
9651 S : constant String_Id :=
9652 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
9653 L : constant Nat := String_Length (S);
9656 procedure Skip_Spaces;
9657 -- Advance F past any spaces
9663 procedure Skip_Spaces is
9665 while F <= L and then Get_String_Char (S, F) = C loop
9670 -- Start of processing for Arg_Store
9673 Skip_Spaces; -- skip leading spaces
9675 -- Loop through characters, changing any embedded
9676 -- sequence of spaces to a single null character (this
9677 -- is how Link_With/Linker_Options differ)
9680 if Get_String_Char (S, F) = C then
9683 Store_String_Char (ASCII.NUL);
9686 Store_String_Char (Get_String_Char (S, F));
9694 if Present (Arg) then
9695 Store_String_Char (ASCII.NUL);
9699 Store_Linker_Option_String (End_String);
9707 -- pragma Linker_Alias (
9708 -- [Entity =>] LOCAL_NAME
9709 -- [Target =>] static_string_EXPRESSION);
9711 when Pragma_Linker_Alias =>
9713 Check_Arg_Order ((Name_Entity, Name_Target));
9714 Check_Arg_Count (2);
9715 Check_Optional_Identifier (Arg1, Name_Entity);
9716 Check_Optional_Identifier (Arg2, Name_Target);
9717 Check_Arg_Is_Library_Level_Local_Name (Arg1);
9718 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
9720 -- The only processing required is to link this item on to the
9721 -- list of rep items for the given entity. This is accomplished
9722 -- by the call to Rep_Item_Too_Late (when no error is detected
9723 -- and False is returned).
9725 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
9728 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
9731 ------------------------
9732 -- Linker_Constructor --
9733 ------------------------
9735 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
9737 -- Code is shared with Linker_Destructor
9739 -----------------------
9740 -- Linker_Destructor --
9741 -----------------------
9743 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
9745 when Pragma_Linker_Constructor |
9746 Pragma_Linker_Destructor =>
9747 Linker_Constructor : declare
9753 Check_Arg_Count (1);
9754 Check_No_Identifiers;
9755 Check_Arg_Is_Local_Name (Arg1);
9756 Arg1_X := Get_Pragma_Arg (Arg1);
9758 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
9760 if not Is_Library_Level_Entity (Proc) then
9762 ("argument for pragma% must be library level entity", Arg1);
9765 -- The only processing required is to link this item on to the
9766 -- list of rep items for the given entity. This is accomplished
9767 -- by the call to Rep_Item_Too_Late (when no error is detected
9768 -- and False is returned).
9770 if Rep_Item_Too_Late (Proc, N) then
9773 Set_Has_Gigi_Rep_Item (Proc);
9775 end Linker_Constructor;
9777 --------------------
9778 -- Linker_Options --
9779 --------------------
9781 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
9783 when Pragma_Linker_Options => Linker_Options : declare
9787 Check_Ada_83_Warning;
9788 Check_No_Identifiers;
9789 Check_Arg_Count (1);
9790 Check_Is_In_Decl_Part_Or_Package_Spec;
9791 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
9792 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
9795 while Present (Arg) loop
9796 Check_Arg_Is_Static_Expression (Arg, Standard_String);
9797 Store_String_Char (ASCII.NUL);
9799 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
9803 if Operating_Mode = Generate_Code
9804 and then In_Extended_Main_Source_Unit (N)
9806 Store_Linker_Option_String (End_String);
9810 --------------------
9811 -- Linker_Section --
9812 --------------------
9814 -- pragma Linker_Section (
9815 -- [Entity =>] LOCAL_NAME
9816 -- [Section =>] static_string_EXPRESSION);
9818 when Pragma_Linker_Section =>
9820 Check_Arg_Order ((Name_Entity, Name_Section));
9821 Check_Arg_Count (2);
9822 Check_Optional_Identifier (Arg1, Name_Entity);
9823 Check_Optional_Identifier (Arg2, Name_Section);
9824 Check_Arg_Is_Library_Level_Local_Name (Arg1);
9825 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
9827 -- This pragma applies only to objects
9829 if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) then
9830 Error_Pragma_Arg ("pragma% applies only to objects", Arg1);
9833 -- The only processing required is to link this item on to the
9834 -- list of rep items for the given entity. This is accomplished
9835 -- by the call to Rep_Item_Too_Late (when no error is detected
9836 -- and False is returned).
9838 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
9841 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
9848 -- pragma List (On | Off)
9850 -- There is nothing to do here, since we did all the processing for
9851 -- this pragma in Par.Prag (so that it works properly even in syntax
9857 --------------------
9858 -- Locking_Policy --
9859 --------------------
9861 -- pragma Locking_Policy (policy_IDENTIFIER);
9863 when Pragma_Locking_Policy => declare
9867 Check_Ada_83_Warning;
9868 Check_Arg_Count (1);
9869 Check_No_Identifiers;
9870 Check_Arg_Is_Locking_Policy (Arg1);
9871 Check_Valid_Configuration_Pragma;
9872 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
9873 LP := Fold_Upper (Name_Buffer (1));
9875 if Locking_Policy /= ' '
9876 and then Locking_Policy /= LP
9878 Error_Msg_Sloc := Locking_Policy_Sloc;
9879 Error_Pragma ("locking policy incompatible with policy#");
9881 -- Set new policy, but always preserve System_Location since we
9882 -- like the error message with the run time name.
9885 Locking_Policy := LP;
9887 if Locking_Policy_Sloc /= System_Location then
9888 Locking_Policy_Sloc := Loc;
9897 -- pragma Long_Float (D_Float | G_Float);
9899 when Pragma_Long_Float =>
9901 Check_Valid_Configuration_Pragma;
9902 Check_Arg_Count (1);
9903 Check_No_Identifier (Arg1);
9904 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
9906 if not OpenVMS_On_Target then
9907 Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
9912 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
9913 if Opt.Float_Format_Long = 'G' then
9914 Error_Pragma ("G_Float previously specified");
9917 Opt.Float_Format_Long := 'D';
9919 -- G_Float case (this is the default, does not need overriding)
9922 if Opt.Float_Format_Long = 'D' then
9923 Error_Pragma ("D_Float previously specified");
9926 Opt.Float_Format_Long := 'G';
9929 Set_Standard_Fpt_Formats;
9931 -----------------------
9932 -- Machine_Attribute --
9933 -----------------------
9935 -- pragma Machine_Attribute (
9936 -- [Entity =>] LOCAL_NAME,
9937 -- [Attribute_Name =>] static_string_EXPRESSION
9938 -- [, [Info =>] static_EXPRESSION] );
9940 when Pragma_Machine_Attribute => Machine_Attribute : declare
9945 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
9947 if Arg_Count = 3 then
9948 Check_Optional_Identifier (Arg3, Name_Info);
9949 Check_Arg_Is_Static_Expression (Arg3);
9951 Check_Arg_Count (2);
9954 Check_Optional_Identifier (Arg1, Name_Entity);
9955 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
9956 Check_Arg_Is_Local_Name (Arg1);
9957 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
9958 Def_Id := Entity (Get_Pragma_Arg (Arg1));
9960 if Is_Access_Type (Def_Id) then
9961 Def_Id := Designated_Type (Def_Id);
9964 if Rep_Item_Too_Early (Def_Id, N) then
9968 Def_Id := Underlying_Type (Def_Id);
9970 -- The only processing required is to link this item on to the
9971 -- list of rep items for the given entity. This is accomplished
9972 -- by the call to Rep_Item_Too_Late (when no error is detected
9973 -- and False is returned).
9975 if Rep_Item_Too_Late (Def_Id, N) then
9978 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
9980 end Machine_Attribute;
9987 -- (MAIN_OPTION [, MAIN_OPTION]);
9990 -- [STACK_SIZE =>] static_integer_EXPRESSION
9991 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
9992 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
9994 when Pragma_Main => Main : declare
9995 Args : Args_List (1 .. 3);
9996 Names : constant Name_List (1 .. 3) := (
9998 Name_Task_Stack_Size_Default,
9999 Name_Time_Slicing_Enabled);
10005 Gather_Associations (Names, Args);
10007 for J in 1 .. 2 loop
10008 if Present (Args (J)) then
10009 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
10013 if Present (Args (3)) then
10014 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
10018 while Present (Nod) loop
10019 if Nkind (Nod) = N_Pragma
10020 and then Pragma_Name (Nod) = Name_Main
10022 Error_Msg_Name_1 := Pname;
10023 Error_Msg_N ("duplicate pragma% not permitted", Nod);
10034 -- pragma Main_Storage
10035 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
10037 -- MAIN_STORAGE_OPTION ::=
10038 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
10039 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
10041 when Pragma_Main_Storage => Main_Storage : declare
10042 Args : Args_List (1 .. 2);
10043 Names : constant Name_List (1 .. 2) := (
10044 Name_Working_Storage,
10051 Gather_Associations (Names, Args);
10053 for J in 1 .. 2 loop
10054 if Present (Args (J)) then
10055 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
10059 Check_In_Main_Program;
10062 while Present (Nod) loop
10063 if Nkind (Nod) = N_Pragma
10064 and then Pragma_Name (Nod) = Name_Main_Storage
10066 Error_Msg_Name_1 := Pname;
10067 Error_Msg_N ("duplicate pragma% not permitted", Nod);
10078 -- pragma Memory_Size (NUMERIC_LITERAL)
10080 when Pragma_Memory_Size =>
10083 -- Memory size is simply ignored
10085 Check_No_Identifiers;
10086 Check_Arg_Count (1);
10087 Check_Arg_Is_Integer_Literal (Arg1);
10095 -- The only correct use of this pragma is on its own in a file, in
10096 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
10097 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
10098 -- check for a file containing nothing but a No_Body pragma). If we
10099 -- attempt to process it during normal semantics processing, it means
10100 -- it was misplaced.
10102 when Pragma_No_Body =>
10110 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
10112 when Pragma_No_Return => No_Return : declare
10120 Check_At_Least_N_Arguments (1);
10122 -- Loop through arguments of pragma
10125 while Present (Arg) loop
10126 Check_Arg_Is_Local_Name (Arg);
10127 Id := Get_Pragma_Arg (Arg);
10130 if not Is_Entity_Name (Id) then
10131 Error_Pragma_Arg ("entity name required", Arg);
10134 if Etype (Id) = Any_Type then
10138 -- Loop to find matching procedures
10143 and then Scope (E) = Current_Scope
10145 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
10148 -- Set flag on any alias as well
10150 if Is_Overloadable (E) and then Present (Alias (E)) then
10151 Set_No_Return (Alias (E));
10157 exit when From_Aspect_Specification (N);
10162 Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
10173 -- pragma No_Run_Time;
10175 -- Note: this pragma is retained for backwards compatibility. See
10176 -- body of Rtsfind for full details on its handling.
10178 when Pragma_No_Run_Time =>
10180 Check_Valid_Configuration_Pragma;
10181 Check_Arg_Count (0);
10183 No_Run_Time_Mode := True;
10184 Configurable_Run_Time_Mode := True;
10186 -- Set Duration to 32 bits if word size is 32
10188 if Ttypes.System_Word_Size = 32 then
10189 Duration_32_Bits_On_Target := True;
10192 -- Set appropriate restrictions
10194 Set_Restriction (No_Finalization, N);
10195 Set_Restriction (No_Exception_Handlers, N);
10196 Set_Restriction (Max_Tasks, N, 0);
10197 Set_Restriction (No_Tasking, N);
10199 ------------------------
10200 -- No_Strict_Aliasing --
10201 ------------------------
10203 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
10205 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
10210 Check_At_Most_N_Arguments (1);
10212 if Arg_Count = 0 then
10213 Check_Valid_Configuration_Pragma;
10214 Opt.No_Strict_Aliasing := True;
10217 Check_Optional_Identifier (Arg2, Name_Entity);
10218 Check_Arg_Is_Local_Name (Arg1);
10219 E_Id := Entity (Get_Pragma_Arg (Arg1));
10221 if E_Id = Any_Type then
10223 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
10224 Error_Pragma_Arg ("pragma% requires access type", Arg1);
10227 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
10229 end No_Strict_Aliasing;
10231 -----------------------
10232 -- Normalize_Scalars --
10233 -----------------------
10235 -- pragma Normalize_Scalars;
10237 when Pragma_Normalize_Scalars =>
10238 Check_Ada_83_Warning;
10239 Check_Arg_Count (0);
10240 Check_Valid_Configuration_Pragma;
10242 -- Normalize_Scalars creates false positives in CodePeer, so
10243 -- ignore this pragma in this mode.
10245 if not CodePeer_Mode then
10246 Normalize_Scalars := True;
10247 Init_Or_Norm_Scalars := True;
10254 -- pragma Obsolescent;
10256 -- pragma Obsolescent (
10257 -- [Message =>] static_string_EXPRESSION
10258 -- [,[Version =>] Ada_05]]);
10260 -- pragma Obsolescent (
10261 -- [Entity =>] NAME
10262 -- [,[Message =>] static_string_EXPRESSION
10263 -- [,[Version =>] Ada_05]] );
10265 when Pragma_Obsolescent => Obsolescent : declare
10269 procedure Set_Obsolescent (E : Entity_Id);
10270 -- Given an entity Ent, mark it as obsolescent if appropriate
10272 ---------------------
10273 -- Set_Obsolescent --
10274 ---------------------
10276 procedure Set_Obsolescent (E : Entity_Id) is
10285 -- Entity name was given
10287 if Present (Ename) then
10289 -- If entity name matches, we are fine. Save entity in
10290 -- pragma argument, for ASIS use.
10292 if Chars (Ename) = Chars (Ent) then
10293 Set_Entity (Ename, Ent);
10294 Generate_Reference (Ent, Ename);
10296 -- If entity name does not match, only possibility is an
10297 -- enumeration literal from an enumeration type declaration.
10299 elsif Ekind (Ent) /= E_Enumeration_Type then
10301 ("pragma % entity name does not match declaration");
10304 Ent := First_Literal (E);
10308 ("pragma % entity name does not match any " &
10309 "enumeration literal");
10311 elsif Chars (Ent) = Chars (Ename) then
10312 Set_Entity (Ename, Ent);
10313 Generate_Reference (Ent, Ename);
10317 Ent := Next_Literal (Ent);
10323 -- Ent points to entity to be marked
10325 if Arg_Count >= 1 then
10327 -- Deal with static string argument
10329 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
10330 S := Strval (Get_Pragma_Arg (Arg1));
10332 for J in 1 .. String_Length (S) loop
10333 if not In_Character_Range (Get_String_Char (S, J)) then
10335 ("pragma% argument does not allow wide characters",
10340 Obsolescent_Warnings.Append
10341 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
10343 -- Check for Ada_05 parameter
10345 if Arg_Count /= 1 then
10346 Check_Arg_Count (2);
10349 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
10352 Check_Arg_Is_Identifier (Argx);
10354 if Chars (Argx) /= Name_Ada_05 then
10355 Error_Msg_Name_2 := Name_Ada_05;
10357 ("only allowed argument for pragma% is %", Argx);
10360 if Ada_Version_Explicit < Ada_2005
10361 or else not Warn_On_Ada_2005_Compatibility
10369 -- Set flag if pragma active
10372 Set_Is_Obsolescent (Ent);
10376 end Set_Obsolescent;
10378 -- Start of processing for pragma Obsolescent
10383 Check_At_Most_N_Arguments (3);
10385 -- See if first argument specifies an entity name
10389 (Chars (Arg1) = Name_Entity
10391 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
10393 N_Operator_Symbol))
10395 Ename := Get_Pragma_Arg (Arg1);
10397 -- Eliminate first argument, so we can share processing
10401 Arg_Count := Arg_Count - 1;
10403 -- No Entity name argument given
10409 if Arg_Count >= 1 then
10410 Check_Optional_Identifier (Arg1, Name_Message);
10412 if Arg_Count = 2 then
10413 Check_Optional_Identifier (Arg2, Name_Version);
10417 -- Get immediately preceding declaration
10420 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
10424 -- Cases where we do not follow anything other than another pragma
10428 -- First case: library level compilation unit declaration with
10429 -- the pragma immediately following the declaration.
10431 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
10433 (Defining_Entity (Unit (Parent (Parent (N)))));
10436 -- Case 2: library unit placement for package
10440 Ent : constant Entity_Id := Find_Lib_Unit_Name;
10442 if Is_Package_Or_Generic_Package (Ent) then
10443 Set_Obsolescent (Ent);
10449 -- Cases where we must follow a declaration
10452 if Nkind (Decl) not in N_Declaration
10453 and then Nkind (Decl) not in N_Later_Decl_Item
10454 and then Nkind (Decl) not in N_Generic_Declaration
10455 and then Nkind (Decl) not in N_Renaming_Declaration
10458 ("pragma% misplaced, "
10459 & "must immediately follow a declaration");
10462 Set_Obsolescent (Defining_Entity (Decl));
10472 -- pragma Optimize (Time | Space | Off);
10474 -- The actual check for optimize is done in Gigi. Note that this
10475 -- pragma does not actually change the optimization setting, it
10476 -- simply checks that it is consistent with the pragma.
10478 when Pragma_Optimize =>
10479 Check_No_Identifiers;
10480 Check_Arg_Count (1);
10481 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
10483 ------------------------
10484 -- Optimize_Alignment --
10485 ------------------------
10487 -- pragma Optimize_Alignment (Time | Space | Off);
10489 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
10491 Check_No_Identifiers;
10492 Check_Arg_Count (1);
10493 Check_Valid_Configuration_Pragma;
10496 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
10500 Opt.Optimize_Alignment := 'T';
10502 Opt.Optimize_Alignment := 'S';
10504 Opt.Optimize_Alignment := 'O';
10506 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
10510 -- Set indication that mode is set locally. If we are in fact in a
10511 -- configuration pragma file, this setting is harmless since the
10512 -- switch will get reset anyway at the start of each unit.
10514 Optimize_Alignment_Local := True;
10515 end Optimize_Alignment;
10521 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
10523 when Pragma_Ordered => Ordered : declare
10524 Assoc : constant Node_Id := Arg1;
10530 Check_No_Identifiers;
10531 Check_Arg_Count (1);
10532 Check_Arg_Is_Local_Name (Arg1);
10534 Type_Id := Get_Pragma_Arg (Assoc);
10535 Find_Type (Type_Id);
10536 Typ := Entity (Type_Id);
10538 if Typ = Any_Type then
10541 Typ := Underlying_Type (Typ);
10544 if not Is_Enumeration_Type (Typ) then
10545 Error_Pragma ("pragma% must specify enumeration type");
10548 Check_First_Subtype (Arg1);
10549 Set_Has_Pragma_Ordered (Base_Type (Typ));
10556 -- pragma Pack (first_subtype_LOCAL_NAME);
10558 when Pragma_Pack => Pack : declare
10559 Assoc : constant Node_Id := Arg1;
10563 Ignore : Boolean := False;
10566 Check_No_Identifiers;
10567 Check_Arg_Count (1);
10568 Check_Arg_Is_Local_Name (Arg1);
10570 Type_Id := Get_Pragma_Arg (Assoc);
10571 Find_Type (Type_Id);
10572 Typ := Entity (Type_Id);
10575 or else Rep_Item_Too_Early (Typ, N)
10579 Typ := Underlying_Type (Typ);
10582 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
10583 Error_Pragma ("pragma% must specify array or record type");
10586 Check_First_Subtype (Arg1);
10587 Check_Duplicate_Pragma (Typ);
10591 if Is_Array_Type (Typ) then
10592 Ctyp := Component_Type (Typ);
10594 -- Ignore pack that does nothing
10596 if Known_Static_Esize (Ctyp)
10597 and then Known_Static_RM_Size (Ctyp)
10598 and then Esize (Ctyp) = RM_Size (Ctyp)
10599 and then Addressable (Esize (Ctyp))
10604 -- Process OK pragma Pack. Note that if there is a separate
10605 -- component clause present, the Pack will be cancelled. This
10606 -- processing is in Freeze.
10608 if not Rep_Item_Too_Late (Typ, N) then
10610 -- In the context of static code analysis, we do not need
10611 -- complex front-end expansions related to pragma Pack,
10612 -- so disable handling of pragma Pack in this case.
10614 if CodePeer_Mode then
10617 -- Don't attempt any packing for VM targets. We possibly
10618 -- could deal with some cases of array bit-packing, but we
10619 -- don't bother, since this is not a typical kind of
10620 -- representation in the VM context anyway (and would not
10621 -- for example work nicely with the debugger).
10623 elsif VM_Target /= No_VM then
10624 if not GNAT_Mode then
10626 ("?pragma% ignored in this configuration");
10629 -- Normal case where we do the pack action
10633 Set_Is_Packed (Base_Type (Typ), Sense);
10634 Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense);
10637 Set_Has_Pragma_Pack (Base_Type (Typ), Sense);
10639 -- Complete reset action for Aspect_Cancel case
10641 if Sense = False then
10643 -- Cancel size unless explicitly set
10645 if not Has_Size_Clause (Typ)
10646 and then not Has_Object_Size_Clause (Typ)
10648 Set_Esize (Typ, Uint_0);
10649 Set_RM_Size (Typ, Uint_0);
10650 Set_Alignment (Typ, Uint_0);
10651 Set_Packed_Array_Type (Typ, Empty);
10654 -- Reset component size unless explicitly set
10656 if not Has_Component_Size_Clause (Typ) then
10657 if Known_Static_Esize (Ctyp)
10658 and then Known_Static_RM_Size (Ctyp)
10659 and then Esize (Ctyp) = RM_Size (Ctyp)
10660 and then Addressable (Esize (Ctyp))
10663 (Base_Type (Typ), Esize (Ctyp));
10666 (Base_Type (Typ), Uint_0);
10673 -- For record types, the pack is always effective
10675 else pragma Assert (Is_Record_Type (Typ));
10676 if not Rep_Item_Too_Late (Typ, N) then
10678 -- Ignore pack request with warning in VM mode (skip warning
10679 -- if we are compiling GNAT run time library).
10681 if VM_Target /= No_VM then
10682 if not GNAT_Mode then
10684 ("?pragma% ignored in this configuration");
10687 -- Normal case of pack request active
10690 Set_Is_Packed (Base_Type (Typ), Sense);
10691 Set_Has_Pragma_Pack (Base_Type (Typ), Sense);
10692 Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense);
10694 -- Complete reset action for Aspect_Cancel case
10696 if Sense = False then
10698 -- Cancel size if not explicitly given
10700 if not Has_Size_Clause (Typ)
10701 and then not Has_Object_Size_Clause (Typ)
10703 Set_Esize (Typ, Uint_0);
10704 Set_Alignment (Typ, Uint_0);
10718 -- There is nothing to do here, since we did all the processing for
10719 -- this pragma in Par.Prag (so that it works properly even in syntax
10722 when Pragma_Page =>
10729 -- pragma Passive [(PASSIVE_FORM)];
10731 -- PASSIVE_FORM ::= Semaphore | No
10733 when Pragma_Passive =>
10736 if Nkind (Parent (N)) /= N_Task_Definition then
10737 Error_Pragma ("pragma% must be within task definition");
10740 if Arg_Count /= 0 then
10741 Check_Arg_Count (1);
10742 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
10745 ----------------------------------
10746 -- Preelaborable_Initialization --
10747 ----------------------------------
10749 -- pragma Preelaborable_Initialization (DIRECT_NAME);
10751 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
10756 Check_Arg_Count (1);
10757 Check_No_Identifiers;
10758 Check_Arg_Is_Identifier (Arg1);
10759 Check_Arg_Is_Local_Name (Arg1);
10760 Check_First_Subtype (Arg1);
10761 Ent := Entity (Get_Pragma_Arg (Arg1));
10763 if not Is_Private_Type (Ent)
10764 and then not Is_Protected_Type (Ent)
10767 ("pragma % can only be applied to private or protected type",
10771 -- Give an error if the pragma is applied to a protected type that
10772 -- does not qualify (due to having entries, or due to components
10773 -- that do not qualify).
10775 if Is_Protected_Type (Ent)
10776 and then not Has_Preelaborable_Initialization (Ent)
10779 ("protected type & does not have preelaborable " &
10780 "initialization", Ent);
10782 -- Otherwise mark the type as definitely having preelaborable
10786 Set_Known_To_Have_Preelab_Init (Ent);
10789 if Has_Pragma_Preelab_Init (Ent)
10790 and then Warn_On_Redundant_Constructs
10792 Error_Pragma ("?duplicate pragma%!");
10794 Set_Has_Pragma_Preelab_Init (Ent);
10798 --------------------
10799 -- Persistent_BSS --
10800 --------------------
10802 -- pragma Persistent_BSS [(object_NAME)];
10804 when Pragma_Persistent_BSS => Persistent_BSS : declare
10811 Check_At_Most_N_Arguments (1);
10813 -- Case of application to specific object (one argument)
10815 if Arg_Count = 1 then
10816 Check_Arg_Is_Library_Level_Local_Name (Arg1);
10818 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
10820 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
10823 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
10826 Ent := Entity (Get_Pragma_Arg (Arg1));
10827 Decl := Parent (Ent);
10829 if Rep_Item_Too_Late (Ent, N) then
10833 if Present (Expression (Decl)) then
10835 ("object for pragma% cannot have initialization", Arg1);
10838 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
10840 ("object type for pragma% is not potentially persistent",
10844 Check_Duplicate_Pragma (Ent);
10848 Make_Linker_Section_Pragma
10849 (Ent, Sloc (N), ".persistent.bss");
10850 Insert_After (N, Prag);
10854 -- Case of use as configuration pragma with no arguments
10857 Check_Valid_Configuration_Pragma;
10858 Persistent_BSS_Mode := True;
10860 end Persistent_BSS;
10866 -- pragma Polling (ON | OFF);
10868 when Pragma_Polling =>
10870 Check_Arg_Count (1);
10871 Check_No_Identifiers;
10872 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
10873 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
10875 -------------------
10876 -- Postcondition --
10877 -------------------
10879 -- pragma Postcondition ([Check =>] Boolean_Expression
10880 -- [,[Message =>] String_Expression]);
10882 when Pragma_Postcondition => Postcondition : declare
10884 pragma Warnings (Off, In_Body);
10888 Check_At_Least_N_Arguments (1);
10889 Check_At_Most_N_Arguments (2);
10890 Check_Optional_Identifier (Arg1, Name_Check);
10892 -- All we need to do here is call the common check procedure,
10893 -- the remainder of the processing is found in Sem_Ch6/Sem_Ch7.
10895 Check_Precondition_Postcondition (In_Body);
10902 -- pragma Precondition ([Check =>] Boolean_Expression
10903 -- [,[Message =>] String_Expression]);
10905 when Pragma_Precondition => Precondition : declare
10910 Check_At_Least_N_Arguments (1);
10911 Check_At_Most_N_Arguments (2);
10912 Check_Optional_Identifier (Arg1, Name_Check);
10913 Check_Precondition_Postcondition (In_Body);
10915 -- If in spec, nothing more to do. If in body, then we convert the
10916 -- pragma to pragma Check (Precondition, cond [, msg]). Note we do
10917 -- this whether or not precondition checks are enabled. That works
10918 -- fine since pragma Check will do this check, and will also
10919 -- analyze the condition itself in the proper context.
10924 Chars => Name_Check,
10925 Pragma_Argument_Associations => New_List (
10926 Make_Pragma_Argument_Association (Loc,
10928 Make_Identifier (Loc,
10929 Chars => Name_Precondition)),
10931 Make_Pragma_Argument_Association (Sloc (Arg1),
10932 Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
10934 if Arg_Count = 2 then
10935 Append_To (Pragma_Argument_Associations (N),
10936 Make_Pragma_Argument_Association (Sloc (Arg2),
10937 Expression => Relocate_Node (Get_Pragma_Arg (Arg2))));
10948 -- pragma Preelaborate [(library_unit_NAME)];
10950 -- Set the flag Is_Preelaborated of program unit name entity
10952 when Pragma_Preelaborate => Preelaborate : declare
10953 Pa : constant Node_Id := Parent (N);
10954 Pk : constant Node_Kind := Nkind (Pa);
10958 Check_Ada_83_Warning;
10959 Check_Valid_Library_Unit_Pragma;
10961 if Nkind (N) = N_Null_Statement then
10965 Ent := Find_Lib_Unit_Name;
10966 Check_Duplicate_Pragma (Ent);
10968 -- This filters out pragmas inside generic parent then
10969 -- show up inside instantiation
10972 and then not (Pk = N_Package_Specification
10973 and then Present (Generic_Parent (Pa)))
10975 if not Debug_Flag_U then
10976 Set_Is_Preelaborated (Ent, Sense);
10977 Set_Suppress_Elaboration_Warnings (Ent, Sense);
10982 ---------------------
10983 -- Preelaborate_05 --
10984 ---------------------
10986 -- pragma Preelaborate_05 [(library_unit_NAME)];
10988 -- This pragma is useable only in GNAT_Mode, where it is used like
10989 -- pragma Preelaborate but it is only effective in Ada 2005 mode
10990 -- (otherwise it is ignored). This is used to implement AI-362 which
10991 -- recategorizes some run-time packages in Ada 2005 mode.
10993 when Pragma_Preelaborate_05 => Preelaborate_05 : declare
10998 Check_Valid_Library_Unit_Pragma;
11000 if not GNAT_Mode then
11001 Error_Pragma ("pragma% only available in GNAT mode");
11004 if Nkind (N) = N_Null_Statement then
11008 -- This is one of the few cases where we need to test the value of
11009 -- Ada_Version_Explicit rather than Ada_Version (which is always
11010 -- set to Ada_2012 in a predefined unit), we need to know the
11011 -- explicit version set to know if this pragma is active.
11013 if Ada_Version_Explicit >= Ada_2005 then
11014 Ent := Find_Lib_Unit_Name;
11015 Set_Is_Preelaborated (Ent);
11016 Set_Suppress_Elaboration_Warnings (Ent);
11018 end Preelaborate_05;
11024 -- pragma Priority (EXPRESSION);
11026 when Pragma_Priority => Priority : declare
11027 P : constant Node_Id := Parent (N);
11031 Check_No_Identifiers;
11032 Check_Arg_Count (1);
11036 if Nkind (P) = N_Subprogram_Body then
11037 Check_In_Main_Program;
11039 Arg := Get_Pragma_Arg (Arg1);
11040 Analyze_And_Resolve (Arg, Standard_Integer);
11044 if not Is_Static_Expression (Arg) then
11045 Flag_Non_Static_Expr
11046 ("main subprogram priority is not static!", Arg);
11049 -- If constraint error, then we already signalled an error
11051 elsif Raises_Constraint_Error (Arg) then
11054 -- Otherwise check in range
11058 Val : constant Uint := Expr_Value (Arg);
11062 or else Val > Expr_Value (Expression
11063 (Parent (RTE (RE_Max_Priority))))
11066 ("main subprogram priority is out of range", Arg1);
11072 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
11074 -- Load an arbitrary entity from System.Tasking to make sure
11075 -- this package is implicitly with'ed, since we need to have
11076 -- the tasking run-time active for the pragma Priority to have
11080 Discard : Entity_Id;
11081 pragma Warnings (Off, Discard);
11083 Discard := RTE (RE_Task_List);
11086 -- Task or Protected, must be of type Integer
11088 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
11089 Arg := Get_Pragma_Arg (Arg1);
11091 -- The expression must be analyzed in the special manner
11092 -- described in "Handling of Default and Per-Object
11093 -- Expressions" in sem.ads.
11095 Preanalyze_Spec_Expression (Arg, Standard_Integer);
11097 if not Is_Static_Expression (Arg) then
11098 Check_Restriction (Static_Priorities, Arg);
11101 -- Anything else is incorrect
11107 if Has_Pragma_Priority (P) then
11108 Error_Pragma ("duplicate pragma% not allowed");
11110 Set_Has_Pragma_Priority (P, True);
11112 if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
11113 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
11114 -- exp_ch9 should use this ???
11119 -----------------------------------
11120 -- Priority_Specific_Dispatching --
11121 -----------------------------------
11123 -- pragma Priority_Specific_Dispatching (
11124 -- policy_IDENTIFIER,
11125 -- first_priority_EXPRESSION,
11126 -- last_priority_EXPRESSION);
11128 when Pragma_Priority_Specific_Dispatching =>
11129 Priority_Specific_Dispatching : declare
11130 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
11131 -- This is the entity System.Any_Priority;
11134 Lower_Bound : Node_Id;
11135 Upper_Bound : Node_Id;
11141 Check_Arg_Count (3);
11142 Check_No_Identifiers;
11143 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
11144 Check_Valid_Configuration_Pragma;
11145 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
11146 DP := Fold_Upper (Name_Buffer (1));
11148 Lower_Bound := Get_Pragma_Arg (Arg2);
11149 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
11150 Lower_Val := Expr_Value (Lower_Bound);
11152 Upper_Bound := Get_Pragma_Arg (Arg3);
11153 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
11154 Upper_Val := Expr_Value (Upper_Bound);
11156 -- It is not allowed to use Task_Dispatching_Policy and
11157 -- Priority_Specific_Dispatching in the same partition.
11159 if Task_Dispatching_Policy /= ' ' then
11160 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11162 ("pragma% incompatible with Task_Dispatching_Policy#");
11164 -- Check lower bound in range
11166 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
11168 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
11171 ("first_priority is out of range", Arg2);
11173 -- Check upper bound in range
11175 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
11177 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
11180 ("last_priority is out of range", Arg3);
11182 -- Check that the priority range is valid
11184 elsif Lower_Val > Upper_Val then
11186 ("last_priority_expression must be greater than" &
11187 " or equal to first_priority_expression");
11189 -- Store the new policy, but always preserve System_Location since
11190 -- we like the error message with the run-time name.
11193 -- Check overlapping in the priority ranges specified in other
11194 -- Priority_Specific_Dispatching pragmas within the same
11195 -- partition. We can only check those we know about!
11198 Specific_Dispatching.First .. Specific_Dispatching.Last
11200 if Specific_Dispatching.Table (J).First_Priority in
11201 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
11202 or else Specific_Dispatching.Table (J).Last_Priority in
11203 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
11206 Specific_Dispatching.Table (J).Pragma_Loc;
11208 ("priority range overlaps with "
11209 & "Priority_Specific_Dispatching#");
11213 -- The use of Priority_Specific_Dispatching is incompatible
11214 -- with Task_Dispatching_Policy.
11216 if Task_Dispatching_Policy /= ' ' then
11217 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11219 ("Priority_Specific_Dispatching incompatible "
11220 & "with Task_Dispatching_Policy#");
11223 -- The use of Priority_Specific_Dispatching forces ceiling
11226 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
11227 Error_Msg_Sloc := Locking_Policy_Sloc;
11229 ("Priority_Specific_Dispatching incompatible "
11230 & "with Locking_Policy#");
11232 -- Set the Ceiling_Locking policy, but preserve System_Location
11233 -- since we like the error message with the run time name.
11236 Locking_Policy := 'C';
11238 if Locking_Policy_Sloc /= System_Location then
11239 Locking_Policy_Sloc := Loc;
11243 -- Add entry in the table
11245 Specific_Dispatching.Append
11246 ((Dispatching_Policy => DP,
11247 First_Priority => UI_To_Int (Lower_Val),
11248 Last_Priority => UI_To_Int (Upper_Val),
11249 Pragma_Loc => Loc));
11251 end Priority_Specific_Dispatching;
11257 -- pragma Profile (profile_IDENTIFIER);
11259 -- profile_IDENTIFIER => Restricted | Ravenscar
11261 when Pragma_Profile =>
11263 Check_Arg_Count (1);
11264 Check_Valid_Configuration_Pragma;
11265 Check_No_Identifiers;
11268 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
11270 if Chars (Argx) = Name_Ravenscar then
11271 Set_Ravenscar_Profile (N);
11272 elsif Chars (Argx) = Name_Restricted then
11273 Set_Profile_Restrictions
11274 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
11276 Error_Pragma_Arg ("& is not a valid profile", Argx);
11280 ----------------------
11281 -- Profile_Warnings --
11282 ----------------------
11284 -- pragma Profile_Warnings (profile_IDENTIFIER);
11286 -- profile_IDENTIFIER => Restricted | Ravenscar
11288 when Pragma_Profile_Warnings =>
11290 Check_Arg_Count (1);
11291 Check_Valid_Configuration_Pragma;
11292 Check_No_Identifiers;
11295 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
11297 if Chars (Argx) = Name_Ravenscar then
11298 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
11299 elsif Chars (Argx) = Name_Restricted then
11300 Set_Profile_Restrictions (Restricted, N, Warn => True);
11302 Error_Pragma_Arg ("& is not a valid profile", Argx);
11306 --------------------------
11307 -- Propagate_Exceptions --
11308 --------------------------
11310 -- pragma Propagate_Exceptions;
11312 -- Note: this pragma is obsolete and has no effect
11314 when Pragma_Propagate_Exceptions =>
11316 Check_Arg_Count (0);
11318 if In_Extended_Main_Source_Unit (N) then
11319 Propagate_Exceptions := True;
11326 -- pragma Psect_Object (
11327 -- [Internal =>] LOCAL_NAME,
11328 -- [, [External =>] EXTERNAL_SYMBOL]
11329 -- [, [Size =>] EXTERNAL_SYMBOL]);
11331 when Pragma_Psect_Object | Pragma_Common_Object =>
11332 Psect_Object : declare
11333 Args : Args_List (1 .. 3);
11334 Names : constant Name_List (1 .. 3) := (
11339 Internal : Node_Id renames Args (1);
11340 External : Node_Id renames Args (2);
11341 Size : Node_Id renames Args (3);
11343 Def_Id : Entity_Id;
11345 procedure Check_Too_Long (Arg : Node_Id);
11346 -- Posts message if the argument is an identifier with more
11347 -- than 31 characters, or a string literal with more than
11348 -- 31 characters, and we are operating under VMS
11350 --------------------
11351 -- Check_Too_Long --
11352 --------------------
11354 procedure Check_Too_Long (Arg : Node_Id) is
11355 X : constant Node_Id := Original_Node (Arg);
11358 if not Nkind_In (X, N_String_Literal, N_Identifier) then
11360 ("inappropriate argument for pragma %", Arg);
11363 if OpenVMS_On_Target then
11364 if (Nkind (X) = N_String_Literal
11365 and then String_Length (Strval (X)) > 31)
11367 (Nkind (X) = N_Identifier
11368 and then Length_Of_Name (Chars (X)) > 31)
11371 ("argument for pragma % is longer than 31 characters",
11375 end Check_Too_Long;
11377 -- Start of processing for Common_Object/Psect_Object
11381 Gather_Associations (Names, Args);
11382 Process_Extended_Import_Export_Internal_Arg (Internal);
11384 Def_Id := Entity (Internal);
11386 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
11388 ("pragma% must designate an object", Internal);
11391 Check_Too_Long (Internal);
11393 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
11395 ("cannot use pragma% for imported/exported object",
11399 if Is_Concurrent_Type (Etype (Internal)) then
11401 ("cannot specify pragma % for task/protected object",
11405 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
11407 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
11409 Error_Msg_N ("?duplicate Common/Psect_Object pragma", N);
11412 if Ekind (Def_Id) = E_Constant then
11414 ("cannot specify pragma % for a constant", Internal);
11417 if Is_Record_Type (Etype (Internal)) then
11423 Ent := First_Entity (Etype (Internal));
11424 while Present (Ent) loop
11425 Decl := Declaration_Node (Ent);
11427 if Ekind (Ent) = E_Component
11428 and then Nkind (Decl) = N_Component_Declaration
11429 and then Present (Expression (Decl))
11430 and then Warn_On_Export_Import
11433 ("?object for pragma % has defaults", Internal);
11443 if Present (Size) then
11444 Check_Too_Long (Size);
11447 if Present (External) then
11448 Check_Arg_Is_External_Name (External);
11449 Check_Too_Long (External);
11452 -- If all error tests pass, link pragma on to the rep item chain
11454 Record_Rep_Item (Def_Id, N);
11461 -- pragma Pure [(library_unit_NAME)];
11463 when Pragma_Pure => Pure : declare
11467 Check_Ada_83_Warning;
11468 Check_Valid_Library_Unit_Pragma;
11470 if Nkind (N) = N_Null_Statement then
11474 Ent := Find_Lib_Unit_Name;
11476 Set_Has_Pragma_Pure (Ent);
11477 Set_Suppress_Elaboration_Warnings (Ent);
11484 -- pragma Pure_05 [(library_unit_NAME)];
11486 -- This pragma is useable only in GNAT_Mode, where it is used like
11487 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
11488 -- it is ignored). It may be used after a pragma Preelaborate, in
11489 -- which case it overrides the effect of the pragma Preelaborate.
11490 -- This is used to implement AI-362 which recategorizes some run-time
11491 -- packages in Ada 2005 mode.
11493 when Pragma_Pure_05 => Pure_05 : declare
11498 Check_Valid_Library_Unit_Pragma;
11500 if not GNAT_Mode then
11501 Error_Pragma ("pragma% only available in GNAT mode");
11504 if Nkind (N) = N_Null_Statement then
11508 -- This is one of the few cases where we need to test the value of
11509 -- Ada_Version_Explicit rather than Ada_Version (which is always
11510 -- set to Ada_2012 in a predefined unit), we need to know the
11511 -- explicit version set to know if this pragma is active.
11513 if Ada_Version_Explicit >= Ada_2005 then
11514 Ent := Find_Lib_Unit_Name;
11515 Set_Is_Preelaborated (Ent, False);
11517 Set_Suppress_Elaboration_Warnings (Ent);
11521 -------------------
11522 -- Pure_Function --
11523 -------------------
11525 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
11527 when Pragma_Pure_Function => Pure_Function : declare
11530 Def_Id : Entity_Id;
11531 Effective : Boolean := False;
11535 Check_Arg_Count (1);
11536 Check_Optional_Identifier (Arg1, Name_Entity);
11537 Check_Arg_Is_Local_Name (Arg1);
11538 E_Id := Get_Pragma_Arg (Arg1);
11540 if Error_Posted (E_Id) then
11544 -- Loop through homonyms (overloadings) of referenced entity
11546 E := Entity (E_Id);
11548 if Present (E) then
11550 Def_Id := Get_Base_Subprogram (E);
11552 if not Ekind_In (Def_Id, E_Function,
11553 E_Generic_Function,
11557 ("pragma% requires a function name", Arg1);
11560 Set_Is_Pure (Def_Id, Sense);
11562 if not Has_Pragma_Pure_Function (Def_Id) then
11563 Set_Has_Pragma_Pure_Function (Def_Id, Sense);
11564 Effective := Sense;
11567 exit when From_Aspect_Specification (N);
11569 exit when No (E) or else Scope (E) /= Current_Scope;
11572 if Sense and then not Effective
11573 and then Warn_On_Redundant_Constructs
11576 ("pragma Pure_Function on& is redundant?",
11582 --------------------
11583 -- Queuing_Policy --
11584 --------------------
11586 -- pragma Queuing_Policy (policy_IDENTIFIER);
11588 when Pragma_Queuing_Policy => declare
11592 Check_Ada_83_Warning;
11593 Check_Arg_Count (1);
11594 Check_No_Identifiers;
11595 Check_Arg_Is_Queuing_Policy (Arg1);
11596 Check_Valid_Configuration_Pragma;
11597 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
11598 QP := Fold_Upper (Name_Buffer (1));
11600 if Queuing_Policy /= ' '
11601 and then Queuing_Policy /= QP
11603 Error_Msg_Sloc := Queuing_Policy_Sloc;
11604 Error_Pragma ("queuing policy incompatible with policy#");
11606 -- Set new policy, but always preserve System_Location since we
11607 -- like the error message with the run time name.
11610 Queuing_Policy := QP;
11612 if Queuing_Policy_Sloc /= System_Location then
11613 Queuing_Policy_Sloc := Loc;
11618 -----------------------
11619 -- Relative_Deadline --
11620 -----------------------
11622 -- pragma Relative_Deadline (time_span_EXPRESSION);
11624 when Pragma_Relative_Deadline => Relative_Deadline : declare
11625 P : constant Node_Id := Parent (N);
11630 Check_No_Identifiers;
11631 Check_Arg_Count (1);
11633 Arg := Get_Pragma_Arg (Arg1);
11635 -- The expression must be analyzed in the special manner described
11636 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
11638 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
11642 if Nkind (P) = N_Subprogram_Body then
11643 Check_In_Main_Program;
11647 elsif Nkind (P) = N_Task_Definition then
11650 -- Anything else is incorrect
11656 if Has_Relative_Deadline_Pragma (P) then
11657 Error_Pragma ("duplicate pragma% not allowed");
11659 Set_Has_Relative_Deadline_Pragma (P, True);
11661 if Nkind (P) = N_Task_Definition then
11662 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
11665 end Relative_Deadline;
11667 ---------------------------
11668 -- Remote_Call_Interface --
11669 ---------------------------
11671 -- pragma Remote_Call_Interface [(library_unit_NAME)];
11673 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
11674 Cunit_Node : Node_Id;
11675 Cunit_Ent : Entity_Id;
11679 Check_Ada_83_Warning;
11680 Check_Valid_Library_Unit_Pragma;
11682 if Nkind (N) = N_Null_Statement then
11686 Cunit_Node := Cunit (Current_Sem_Unit);
11687 K := Nkind (Unit (Cunit_Node));
11688 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
11690 if K = N_Package_Declaration
11691 or else K = N_Generic_Package_Declaration
11692 or else K = N_Subprogram_Declaration
11693 or else K = N_Generic_Subprogram_Declaration
11694 or else (K = N_Subprogram_Body
11695 and then Acts_As_Spec (Unit (Cunit_Node)))
11700 "pragma% must apply to package or subprogram declaration");
11703 Set_Is_Remote_Call_Interface (Cunit_Ent);
11704 end Remote_Call_Interface;
11710 -- pragma Remote_Types [(library_unit_NAME)];
11712 when Pragma_Remote_Types => Remote_Types : declare
11713 Cunit_Node : Node_Id;
11714 Cunit_Ent : Entity_Id;
11717 Check_Ada_83_Warning;
11718 Check_Valid_Library_Unit_Pragma;
11720 if Nkind (N) = N_Null_Statement then
11724 Cunit_Node := Cunit (Current_Sem_Unit);
11725 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
11727 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
11728 N_Generic_Package_Declaration)
11731 ("pragma% can only apply to a package declaration");
11734 Set_Is_Remote_Types (Cunit_Ent);
11741 -- pragma Ravenscar;
11743 when Pragma_Ravenscar =>
11745 Check_Arg_Count (0);
11746 Check_Valid_Configuration_Pragma;
11747 Set_Ravenscar_Profile (N);
11749 if Warn_On_Obsolescent_Feature then
11750 Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N);
11751 Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N);
11754 -------------------------
11755 -- Restricted_Run_Time --
11756 -------------------------
11758 -- pragma Restricted_Run_Time;
11760 when Pragma_Restricted_Run_Time =>
11762 Check_Arg_Count (0);
11763 Check_Valid_Configuration_Pragma;
11764 Set_Profile_Restrictions
11765 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
11767 if Warn_On_Obsolescent_Feature then
11769 ("pragma Restricted_Run_Time is an obsolescent feature?", N);
11770 Error_Msg_N ("|use pragma Profile (Restricted) instead", N);
11777 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
11780 -- restriction_IDENTIFIER
11781 -- | restriction_parameter_IDENTIFIER => EXPRESSION
11783 when Pragma_Restrictions =>
11784 Process_Restrictions_Or_Restriction_Warnings
11785 (Warn => Treat_Restrictions_As_Warnings);
11787 --------------------------
11788 -- Restriction_Warnings --
11789 --------------------------
11791 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
11794 -- restriction_IDENTIFIER
11795 -- | restriction_parameter_IDENTIFIER => EXPRESSION
11797 when Pragma_Restriction_Warnings =>
11799 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
11805 -- pragma Reviewable;
11807 when Pragma_Reviewable =>
11808 Check_Ada_83_Warning;
11809 Check_Arg_Count (0);
11811 -- Call dummy debugging function rv. This is done to assist front
11812 -- end debugging. By placing a Reviewable pragma in the source
11813 -- program, a breakpoint on rv catches this place in the source,
11814 -- allowing convenient stepping to the point of interest.
11818 --------------------------
11819 -- Short_Circuit_And_Or --
11820 --------------------------
11822 when Pragma_Short_Circuit_And_Or =>
11824 Check_Arg_Count (0);
11825 Check_Valid_Configuration_Pragma;
11826 Short_Circuit_And_Or := True;
11828 -------------------
11829 -- Share_Generic --
11830 -------------------
11832 -- pragma Share_Generic (NAME {, NAME});
11834 when Pragma_Share_Generic =>
11836 Process_Generic_List;
11842 -- pragma Shared (LOCAL_NAME);
11844 when Pragma_Shared =>
11846 Process_Atomic_Shared_Volatile;
11848 --------------------
11849 -- Shared_Passive --
11850 --------------------
11852 -- pragma Shared_Passive [(library_unit_NAME)];
11854 -- Set the flag Is_Shared_Passive of program unit name entity
11856 when Pragma_Shared_Passive => Shared_Passive : declare
11857 Cunit_Node : Node_Id;
11858 Cunit_Ent : Entity_Id;
11861 Check_Ada_83_Warning;
11862 Check_Valid_Library_Unit_Pragma;
11864 if Nkind (N) = N_Null_Statement then
11868 Cunit_Node := Cunit (Current_Sem_Unit);
11869 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
11871 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
11872 N_Generic_Package_Declaration)
11875 ("pragma% can only apply to a package declaration");
11878 Set_Is_Shared_Passive (Cunit_Ent);
11879 end Shared_Passive;
11881 -----------------------
11882 -- Short_Descriptors --
11883 -----------------------
11885 -- pragma Short_Descriptors;
11887 when Pragma_Short_Descriptors =>
11889 Check_Arg_Count (0);
11890 Check_Valid_Configuration_Pragma;
11891 Short_Descriptors := True;
11893 ----------------------
11894 -- Source_File_Name --
11895 ----------------------
11897 -- There are five forms for this pragma:
11899 -- pragma Source_File_Name (
11900 -- [UNIT_NAME =>] unit_NAME,
11901 -- BODY_FILE_NAME => STRING_LITERAL
11902 -- [, [INDEX =>] INTEGER_LITERAL]);
11904 -- pragma Source_File_Name (
11905 -- [UNIT_NAME =>] unit_NAME,
11906 -- SPEC_FILE_NAME => STRING_LITERAL
11907 -- [, [INDEX =>] INTEGER_LITERAL]);
11909 -- pragma Source_File_Name (
11910 -- BODY_FILE_NAME => STRING_LITERAL
11911 -- [, DOT_REPLACEMENT => STRING_LITERAL]
11912 -- [, CASING => CASING_SPEC]);
11914 -- pragma Source_File_Name (
11915 -- SPEC_FILE_NAME => STRING_LITERAL
11916 -- [, DOT_REPLACEMENT => STRING_LITERAL]
11917 -- [, CASING => CASING_SPEC]);
11919 -- pragma Source_File_Name (
11920 -- SUBUNIT_FILE_NAME => STRING_LITERAL
11921 -- [, DOT_REPLACEMENT => STRING_LITERAL]
11922 -- [, CASING => CASING_SPEC]);
11924 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
11926 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
11927 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
11928 -- only be used when no project file is used, while SFNP can only be
11929 -- used when a project file is used.
11931 -- No processing here. Processing was completed during parsing, since
11932 -- we need to have file names set as early as possible. Units are
11933 -- loaded well before semantic processing starts.
11935 -- The only processing we defer to this point is the check for
11936 -- correct placement.
11938 when Pragma_Source_File_Name =>
11940 Check_Valid_Configuration_Pragma;
11942 ------------------------------
11943 -- Source_File_Name_Project --
11944 ------------------------------
11946 -- See Source_File_Name for syntax
11948 -- No processing here. Processing was completed during parsing, since
11949 -- we need to have file names set as early as possible. Units are
11950 -- loaded well before semantic processing starts.
11952 -- The only processing we defer to this point is the check for
11953 -- correct placement.
11955 when Pragma_Source_File_Name_Project =>
11957 Check_Valid_Configuration_Pragma;
11959 -- Check that a pragma Source_File_Name_Project is used only in a
11960 -- configuration pragmas file.
11962 -- Pragmas Source_File_Name_Project should only be generated by
11963 -- the Project Manager in configuration pragmas files.
11965 -- This is really an ugly test. It seems to depend on some
11966 -- accidental and undocumented property. At the very least it
11967 -- needs to be documented, but it would be better to have a
11968 -- clean way of testing if we are in a configuration file???
11970 if Present (Parent (N)) then
11972 ("pragma% can only appear in a configuration pragmas file");
11975 ----------------------
11976 -- Source_Reference --
11977 ----------------------
11979 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
11981 -- Nothing to do, all processing completed in Par.Prag, since we need
11982 -- the information for possible parser messages that are output.
11984 when Pragma_Source_Reference =>
11987 --------------------------------
11988 -- Static_Elaboration_Desired --
11989 --------------------------------
11991 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
11993 when Pragma_Static_Elaboration_Desired =>
11995 Check_At_Most_N_Arguments (1);
11997 if Is_Compilation_Unit (Current_Scope)
11998 and then Ekind (Current_Scope) = E_Package
12000 Set_Static_Elaboration_Desired (Current_Scope, True);
12002 Error_Pragma ("pragma% must apply to a library-level package");
12009 -- pragma Storage_Size (EXPRESSION);
12011 when Pragma_Storage_Size => Storage_Size : declare
12012 P : constant Node_Id := Parent (N);
12016 Check_No_Identifiers;
12017 Check_Arg_Count (1);
12019 -- The expression must be analyzed in the special manner described
12020 -- in "Handling of Default Expressions" in sem.ads.
12022 Arg := Get_Pragma_Arg (Arg1);
12023 Preanalyze_Spec_Expression (Arg, Any_Integer);
12025 if not Is_Static_Expression (Arg) then
12026 Check_Restriction (Static_Storage_Size, Arg);
12029 if Nkind (P) /= N_Task_Definition then
12034 if Has_Storage_Size_Pragma (P) then
12035 Error_Pragma ("duplicate pragma% not allowed");
12037 Set_Has_Storage_Size_Pragma (P, True);
12040 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
12041 -- ??? exp_ch9 should use this!
12049 -- pragma Storage_Unit (NUMERIC_LITERAL);
12051 -- Only permitted argument is System'Storage_Unit value
12053 when Pragma_Storage_Unit =>
12054 Check_No_Identifiers;
12055 Check_Arg_Count (1);
12056 Check_Arg_Is_Integer_Literal (Arg1);
12058 if Intval (Get_Pragma_Arg (Arg1)) /=
12059 UI_From_Int (Ttypes.System_Storage_Unit)
12061 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
12063 ("the only allowed argument for pragma% is ^", Arg1);
12066 --------------------
12067 -- Stream_Convert --
12068 --------------------
12070 -- pragma Stream_Convert (
12071 -- [Entity =>] type_LOCAL_NAME,
12072 -- [Read =>] function_NAME,
12073 -- [Write =>] function NAME);
12075 when Pragma_Stream_Convert => Stream_Convert : declare
12077 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
12078 -- Check that the given argument is the name of a local function
12079 -- of one argument that is not overloaded earlier in the current
12080 -- local scope. A check is also made that the argument is a
12081 -- function with one parameter.
12083 --------------------------------------
12084 -- Check_OK_Stream_Convert_Function --
12085 --------------------------------------
12087 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
12091 Check_Arg_Is_Local_Name (Arg);
12092 Ent := Entity (Get_Pragma_Arg (Arg));
12094 if Has_Homonym (Ent) then
12096 ("argument for pragma% may not be overloaded", Arg);
12099 if Ekind (Ent) /= E_Function
12100 or else No (First_Formal (Ent))
12101 or else Present (Next_Formal (First_Formal (Ent)))
12104 ("argument for pragma% must be" &
12105 " function of one argument", Arg);
12107 end Check_OK_Stream_Convert_Function;
12109 -- Start of processing for Stream_Convert
12113 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
12114 Check_Arg_Count (3);
12115 Check_Optional_Identifier (Arg1, Name_Entity);
12116 Check_Optional_Identifier (Arg2, Name_Read);
12117 Check_Optional_Identifier (Arg3, Name_Write);
12118 Check_Arg_Is_Local_Name (Arg1);
12119 Check_OK_Stream_Convert_Function (Arg2);
12120 Check_OK_Stream_Convert_Function (Arg3);
12123 Typ : constant Entity_Id :=
12124 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
12125 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
12126 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
12129 Check_First_Subtype (Arg1);
12131 -- Check for too early or too late. Note that we don't enforce
12132 -- the rule about primitive operations in this case, since, as
12133 -- is the case for explicit stream attributes themselves, these
12134 -- restrictions are not appropriate. Note that the chaining of
12135 -- the pragma by Rep_Item_Too_Late is actually the critical
12136 -- processing done for this pragma.
12138 if Rep_Item_Too_Early (Typ, N)
12140 Rep_Item_Too_Late (Typ, N, FOnly => True)
12145 -- Return if previous error
12147 if Etype (Typ) = Any_Type
12149 Etype (Read) = Any_Type
12151 Etype (Write) = Any_Type
12158 if Underlying_Type (Etype (Read)) /= Typ then
12160 ("incorrect return type for function&", Arg2);
12163 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
12165 ("incorrect parameter type for function&", Arg3);
12168 if Underlying_Type (Etype (First_Formal (Read))) /=
12169 Underlying_Type (Etype (Write))
12172 ("result type of & does not match Read parameter type",
12176 end Stream_Convert;
12178 -------------------------
12179 -- Style_Checks (GNAT) --
12180 -------------------------
12182 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
12184 -- This is processed by the parser since some of the style checks
12185 -- take place during source scanning and parsing. This means that
12186 -- we don't need to issue error messages here.
12188 when Pragma_Style_Checks => Style_Checks : declare
12189 A : constant Node_Id := Get_Pragma_Arg (Arg1);
12195 Check_No_Identifiers;
12197 -- Two argument form
12199 if Arg_Count = 2 then
12200 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12207 E_Id := Get_Pragma_Arg (Arg2);
12210 if not Is_Entity_Name (E_Id) then
12212 ("second argument of pragma% must be entity name",
12216 E := Entity (E_Id);
12222 Set_Suppress_Style_Checks (E,
12223 (Chars (Get_Pragma_Arg (Arg1)) = Name_Off));
12224 exit when No (Homonym (E));
12230 -- One argument form
12233 Check_Arg_Count (1);
12235 if Nkind (A) = N_String_Literal then
12239 Slen : constant Natural := Natural (String_Length (S));
12240 Options : String (1 .. Slen);
12246 C := Get_String_Char (S, Int (J));
12247 exit when not In_Character_Range (C);
12248 Options (J) := Get_Character (C);
12250 -- If at end of string, set options. As per discussion
12251 -- above, no need to check for errors, since we issued
12252 -- them in the parser.
12255 Set_Style_Check_Options (Options);
12263 elsif Nkind (A) = N_Identifier then
12264 if Chars (A) = Name_All_Checks then
12266 Set_GNAT_Style_Check_Options;
12268 Set_Default_Style_Check_Options;
12271 elsif Chars (A) = Name_On then
12272 Style_Check := True;
12274 elsif Chars (A) = Name_Off then
12275 Style_Check := False;
12285 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
12287 when Pragma_Subtitle =>
12289 Check_Arg_Count (1);
12290 Check_Optional_Identifier (Arg1, Name_Subtitle);
12291 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
12298 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
12300 when Pragma_Suppress =>
12301 Process_Suppress_Unsuppress (True);
12307 -- pragma Suppress_All;
12309 -- The only check made here is that the pragma has no arguments.
12310 -- There are no placement rules, and the processing required (setting
12311 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
12312 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
12313 -- then creates and inserts a pragma Suppress (All_Checks).
12315 when Pragma_Suppress_All =>
12317 Check_Arg_Count (0);
12319 -------------------------
12320 -- Suppress_Debug_Info --
12321 -------------------------
12323 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
12325 when Pragma_Suppress_Debug_Info =>
12327 Check_Arg_Count (1);
12328 Check_Optional_Identifier (Arg1, Name_Entity);
12329 Check_Arg_Is_Local_Name (Arg1);
12330 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)), Sense);
12332 ----------------------------------
12333 -- Suppress_Exception_Locations --
12334 ----------------------------------
12336 -- pragma Suppress_Exception_Locations;
12338 when Pragma_Suppress_Exception_Locations =>
12340 Check_Arg_Count (0);
12341 Check_Valid_Configuration_Pragma;
12342 Exception_Locations_Suppressed := True;
12344 -----------------------------
12345 -- Suppress_Initialization --
12346 -----------------------------
12348 -- pragma Suppress_Initialization ([Entity =>] type_Name);
12350 when Pragma_Suppress_Initialization => Suppress_Init : declare
12356 Check_Arg_Count (1);
12357 Check_Optional_Identifier (Arg1, Name_Entity);
12358 Check_Arg_Is_Local_Name (Arg1);
12360 E_Id := Get_Pragma_Arg (Arg1);
12362 if Etype (E_Id) = Any_Type then
12366 E := Entity (E_Id);
12368 if Is_Type (E) then
12369 if Is_Incomplete_Or_Private_Type (E) then
12370 if No (Full_View (Base_Type (E))) then
12372 ("argument of pragma% cannot be an incomplete type",
12375 Set_Suppress_Init_Proc (Full_View (Base_Type (E)));
12378 Set_Suppress_Init_Proc (Base_Type (E));
12383 ("pragma% requires argument that is a type name", Arg1);
12391 -- pragma System_Name (DIRECT_NAME);
12393 -- Syntax check: one argument, which must be the identifier GNAT or
12394 -- the identifier GCC, no other identifiers are acceptable.
12396 when Pragma_System_Name =>
12398 Check_No_Identifiers;
12399 Check_Arg_Count (1);
12400 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
12402 -----------------------------
12403 -- Task_Dispatching_Policy --
12404 -----------------------------
12406 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
12408 when Pragma_Task_Dispatching_Policy => declare
12412 Check_Ada_83_Warning;
12413 Check_Arg_Count (1);
12414 Check_No_Identifiers;
12415 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
12416 Check_Valid_Configuration_Pragma;
12417 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
12418 DP := Fold_Upper (Name_Buffer (1));
12420 if Task_Dispatching_Policy /= ' '
12421 and then Task_Dispatching_Policy /= DP
12423 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
12425 ("task dispatching policy incompatible with policy#");
12427 -- Set new policy, but always preserve System_Location since we
12428 -- like the error message with the run time name.
12431 Task_Dispatching_Policy := DP;
12433 if Task_Dispatching_Policy_Sloc /= System_Location then
12434 Task_Dispatching_Policy_Sloc := Loc;
12443 -- pragma Task_Info (EXPRESSION);
12445 when Pragma_Task_Info => Task_Info : declare
12446 P : constant Node_Id := Parent (N);
12451 if Nkind (P) /= N_Task_Definition then
12452 Error_Pragma ("pragma% must appear in task definition");
12455 Check_No_Identifiers;
12456 Check_Arg_Count (1);
12458 Analyze_And_Resolve
12459 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
12461 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
12465 if Has_Task_Info_Pragma (P) then
12466 Error_Pragma ("duplicate pragma% not allowed");
12468 Set_Has_Task_Info_Pragma (P, True);
12476 -- pragma Task_Name (string_EXPRESSION);
12478 when Pragma_Task_Name => Task_Name : declare
12479 P : constant Node_Id := Parent (N);
12483 Check_No_Identifiers;
12484 Check_Arg_Count (1);
12486 Arg := Get_Pragma_Arg (Arg1);
12488 -- The expression is used in the call to Create_Task, and must be
12489 -- expanded there, not in the context of the current spec. It must
12490 -- however be analyzed to capture global references, in case it
12491 -- appears in a generic context.
12493 Preanalyze_And_Resolve (Arg, Standard_String);
12495 if Nkind (P) /= N_Task_Definition then
12499 if Has_Task_Name_Pragma (P) then
12500 Error_Pragma ("duplicate pragma% not allowed");
12502 Set_Has_Task_Name_Pragma (P, True);
12503 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
12511 -- pragma Task_Storage (
12512 -- [Task_Type =>] LOCAL_NAME,
12513 -- [Top_Guard =>] static_integer_EXPRESSION);
12515 when Pragma_Task_Storage => Task_Storage : declare
12516 Args : Args_List (1 .. 2);
12517 Names : constant Name_List (1 .. 2) := (
12521 Task_Type : Node_Id renames Args (1);
12522 Top_Guard : Node_Id renames Args (2);
12528 Gather_Associations (Names, Args);
12530 if No (Task_Type) then
12532 ("missing task_type argument for pragma%");
12535 Check_Arg_Is_Local_Name (Task_Type);
12537 Ent := Entity (Task_Type);
12539 if not Is_Task_Type (Ent) then
12541 ("argument for pragma% must be task type", Task_Type);
12544 if No (Top_Guard) then
12546 ("pragma% takes two arguments", Task_Type);
12548 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
12551 Check_First_Subtype (Task_Type);
12553 if Rep_Item_Too_Late (Ent, N) then
12558 --------------------------
12559 -- Thread_Local_Storage --
12560 --------------------------
12562 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
12564 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
12570 Check_Arg_Count (1);
12571 Check_Optional_Identifier (Arg1, Name_Entity);
12572 Check_Arg_Is_Library_Level_Local_Name (Arg1);
12574 Id := Get_Pragma_Arg (Arg1);
12577 if not Is_Entity_Name (Id)
12578 or else Ekind (Entity (Id)) /= E_Variable
12580 Error_Pragma_Arg ("local variable name required", Arg1);
12585 if Rep_Item_Too_Early (E, N)
12586 or else Rep_Item_Too_Late (E, N)
12591 Set_Has_Pragma_Thread_Local_Storage (E);
12592 Set_Has_Gigi_Rep_Item (E);
12593 end Thread_Local_Storage;
12599 -- pragma Time_Slice (static_duration_EXPRESSION);
12601 when Pragma_Time_Slice => Time_Slice : declare
12607 Check_Arg_Count (1);
12608 Check_No_Identifiers;
12609 Check_In_Main_Program;
12610 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
12612 if not Error_Posted (Arg1) then
12614 while Present (Nod) loop
12615 if Nkind (Nod) = N_Pragma
12616 and then Pragma_Name (Nod) = Name_Time_Slice
12618 Error_Msg_Name_1 := Pname;
12619 Error_Msg_N ("duplicate pragma% not permitted", Nod);
12626 -- Process only if in main unit
12628 if Get_Source_Unit (Loc) = Main_Unit then
12629 Opt.Time_Slice_Set := True;
12630 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
12632 if Val <= Ureal_0 then
12633 Opt.Time_Slice_Value := 0;
12635 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
12636 Opt.Time_Slice_Value := 1_000_000_000;
12639 Opt.Time_Slice_Value :=
12640 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
12649 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
12651 -- TITLING_OPTION ::=
12652 -- [Title =>] STRING_LITERAL
12653 -- | [Subtitle =>] STRING_LITERAL
12655 when Pragma_Title => Title : declare
12656 Args : Args_List (1 .. 2);
12657 Names : constant Name_List (1 .. 2) := (
12663 Gather_Associations (Names, Args);
12666 for J in 1 .. 2 loop
12667 if Present (Args (J)) then
12668 Check_Arg_Is_Static_Expression (Args (J), Standard_String);
12673 ---------------------
12674 -- Unchecked_Union --
12675 ---------------------
12677 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
12679 when Pragma_Unchecked_Union => Unchecked_Union : declare
12680 Assoc : constant Node_Id := Arg1;
12681 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
12692 Check_No_Identifiers;
12693 Check_Arg_Count (1);
12694 Check_Arg_Is_Local_Name (Arg1);
12696 Find_Type (Type_Id);
12697 Typ := Entity (Type_Id);
12700 or else Rep_Item_Too_Early (Typ, N)
12704 Typ := Underlying_Type (Typ);
12707 if Rep_Item_Too_Late (Typ, N) then
12711 Check_First_Subtype (Arg1);
12713 -- Note remaining cases are references to a type in the current
12714 -- declarative part. If we find an error, we post the error on
12715 -- the relevant type declaration at an appropriate point.
12717 if not Is_Record_Type (Typ) then
12718 Error_Msg_N ("Unchecked_Union must be record type", Typ);
12721 elsif Is_Tagged_Type (Typ) then
12722 Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
12725 elsif Is_Limited_Type (Typ) then
12727 ("Unchecked_Union must not be limited record type", Typ);
12728 Explain_Limited_Type (Typ, Typ);
12732 if not Has_Discriminants (Typ) then
12734 ("Unchecked_Union must have one discriminant", Typ);
12738 Discr := First_Discriminant (Typ);
12739 while Present (Discr) loop
12740 if No (Discriminant_Default_Value (Discr)) then
12742 ("Unchecked_Union discriminant must have default value",
12746 Next_Discriminant (Discr);
12749 Tdef := Type_Definition (Declaration_Node (Typ));
12750 Clist := Component_List (Tdef);
12752 Comp := First (Component_Items (Clist));
12753 while Present (Comp) loop
12754 Check_Component (Comp, Typ);
12758 if No (Clist) or else No (Variant_Part (Clist)) then
12760 ("Unchecked_Union must have variant part",
12765 Vpart := Variant_Part (Clist);
12767 Variant := First (Variants (Vpart));
12768 while Present (Variant) loop
12769 Check_Variant (Variant, Typ);
12774 Set_Is_Unchecked_Union (Typ, Sense);
12777 Set_Convention (Typ, Convention_C);
12780 Set_Has_Unchecked_Union (Base_Type (Typ), Sense);
12781 Set_Is_Unchecked_Union (Base_Type (Typ), Sense);
12782 end Unchecked_Union;
12784 ------------------------
12785 -- Unimplemented_Unit --
12786 ------------------------
12788 -- pragma Unimplemented_Unit;
12790 -- Note: this only gives an error if we are generating code, or if
12791 -- we are in a generic library unit (where the pragma appears in the
12792 -- body, not in the spec).
12794 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
12795 Cunitent : constant Entity_Id :=
12796 Cunit_Entity (Get_Source_Unit (Loc));
12797 Ent_Kind : constant Entity_Kind :=
12802 Check_Arg_Count (0);
12804 if Operating_Mode = Generate_Code
12805 or else Ent_Kind = E_Generic_Function
12806 or else Ent_Kind = E_Generic_Procedure
12807 or else Ent_Kind = E_Generic_Package
12809 Get_Name_String (Chars (Cunitent));
12810 Set_Casing (Mixed_Case);
12811 Write_Str (Name_Buffer (1 .. Name_Len));
12812 Write_Str (" is not supported in this configuration");
12814 raise Unrecoverable_Error;
12816 end Unimplemented_Unit;
12818 ------------------------
12819 -- Universal_Aliasing --
12820 ------------------------
12822 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
12824 when Pragma_Universal_Aliasing => Universal_Alias : declare
12829 Check_Arg_Count (1);
12830 Check_Optional_Identifier (Arg2, Name_Entity);
12831 Check_Arg_Is_Local_Name (Arg1);
12832 E_Id := Entity (Get_Pragma_Arg (Arg1));
12834 if E_Id = Any_Type then
12836 elsif No (E_Id) or else not Is_Type (E_Id) then
12837 Error_Pragma_Arg ("pragma% requires type", Arg1);
12840 Set_Universal_Aliasing (Implementation_Base_Type (E_Id), Sense);
12841 end Universal_Alias;
12843 --------------------
12844 -- Universal_Data --
12845 --------------------
12847 -- pragma Universal_Data [(library_unit_NAME)];
12849 when Pragma_Universal_Data =>
12852 -- If this is a configuration pragma, then set the universal
12853 -- addressing option, otherwise confirm that the pragma satisfies
12854 -- the requirements of library unit pragma placement and leave it
12855 -- to the GNAAMP back end to detect the pragma (avoids transitive
12856 -- setting of the option due to withed units).
12858 if Is_Configuration_Pragma then
12859 Universal_Addressing_On_AAMP := True;
12861 Check_Valid_Library_Unit_Pragma;
12864 if not AAMP_On_Target then
12865 Error_Pragma ("?pragma% ignored (applies only to AAMP)");
12872 -- pragma Unmodified (local_Name {, local_Name});
12874 when Pragma_Unmodified => Unmodified : declare
12875 Arg_Node : Node_Id;
12876 Arg_Expr : Node_Id;
12877 Arg_Ent : Entity_Id;
12881 Check_At_Least_N_Arguments (1);
12883 -- Loop through arguments
12886 while Present (Arg_Node) loop
12887 Check_No_Identifier (Arg_Node);
12889 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
12890 -- in fact generate reference, so that the entity will have a
12891 -- reference, which will inhibit any warnings about it not
12892 -- being referenced, and also properly show up in the ali file
12893 -- as a reference. But this reference is recorded before the
12894 -- Has_Pragma_Unreferenced flag is set, so that no warning is
12895 -- generated for this reference.
12897 Check_Arg_Is_Local_Name (Arg_Node);
12898 Arg_Expr := Get_Pragma_Arg (Arg_Node);
12900 if Is_Entity_Name (Arg_Expr) then
12901 Arg_Ent := Entity (Arg_Expr);
12903 if not Is_Assignable (Arg_Ent) then
12905 ("pragma% can only be applied to a variable",
12908 Set_Has_Pragma_Unmodified (Arg_Ent, Sense);
12920 -- pragma Unreferenced (local_Name {, local_Name});
12922 -- or when used in a context clause:
12924 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
12926 when Pragma_Unreferenced => Unreferenced : declare
12927 Arg_Node : Node_Id;
12928 Arg_Expr : Node_Id;
12929 Arg_Ent : Entity_Id;
12934 Check_At_Least_N_Arguments (1);
12936 -- Check case of appearing within context clause
12938 if Is_In_Context_Clause then
12940 -- The arguments must all be units mentioned in a with clause
12941 -- in the same context clause. Note we already checked (in
12942 -- Par.Prag) that the arguments are either identifiers or
12943 -- selected components.
12946 while Present (Arg_Node) loop
12947 Citem := First (List_Containing (N));
12948 while Citem /= N loop
12949 if Nkind (Citem) = N_With_Clause
12951 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
12953 Set_Has_Pragma_Unreferenced
12956 (Library_Unit (Citem))));
12958 (Get_Pragma_Arg (Arg_Node), Name (Citem));
12967 ("argument of pragma% is not with'ed unit", Arg_Node);
12973 -- Case of not in list of context items
12977 while Present (Arg_Node) loop
12978 Check_No_Identifier (Arg_Node);
12980 -- Note: the analyze call done by Check_Arg_Is_Local_Name
12981 -- will in fact generate reference, so that the entity will
12982 -- have a reference, which will inhibit any warnings about
12983 -- it not being referenced, and also properly show up in the
12984 -- ali file as a reference. But this reference is recorded
12985 -- before the Has_Pragma_Unreferenced flag is set, so that
12986 -- no warning is generated for this reference.
12988 Check_Arg_Is_Local_Name (Arg_Node);
12989 Arg_Expr := Get_Pragma_Arg (Arg_Node);
12991 if Is_Entity_Name (Arg_Expr) then
12992 Arg_Ent := Entity (Arg_Expr);
12994 -- If the entity is overloaded, the pragma applies to the
12995 -- most recent overloading, as documented. In this case,
12996 -- name resolution does not generate a reference, so it
12997 -- must be done here explicitly.
12999 if Is_Overloaded (Arg_Expr) then
13000 Generate_Reference (Arg_Ent, N);
13003 Set_Has_Pragma_Unreferenced (Arg_Ent, Sense);
13011 --------------------------
13012 -- Unreferenced_Objects --
13013 --------------------------
13015 -- pragma Unreferenced_Objects (local_Name {, local_Name});
13017 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
13018 Arg_Node : Node_Id;
13019 Arg_Expr : Node_Id;
13023 Check_At_Least_N_Arguments (1);
13026 while Present (Arg_Node) loop
13027 Check_No_Identifier (Arg_Node);
13028 Check_Arg_Is_Local_Name (Arg_Node);
13029 Arg_Expr := Get_Pragma_Arg (Arg_Node);
13031 if not Is_Entity_Name (Arg_Expr)
13032 or else not Is_Type (Entity (Arg_Expr))
13035 ("argument for pragma% must be type or subtype", Arg_Node);
13038 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr), Sense);
13041 end Unreferenced_Objects;
13043 ------------------------------
13044 -- Unreserve_All_Interrupts --
13045 ------------------------------
13047 -- pragma Unreserve_All_Interrupts;
13049 when Pragma_Unreserve_All_Interrupts =>
13051 Check_Arg_Count (0);
13053 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
13054 Unreserve_All_Interrupts := True;
13061 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
13063 when Pragma_Unsuppress =>
13065 Process_Suppress_Unsuppress (False);
13067 -------------------
13068 -- Use_VADS_Size --
13069 -------------------
13071 -- pragma Use_VADS_Size;
13073 when Pragma_Use_VADS_Size =>
13075 Check_Arg_Count (0);
13076 Check_Valid_Configuration_Pragma;
13077 Use_VADS_Size := True;
13079 ---------------------
13080 -- Validity_Checks --
13081 ---------------------
13083 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
13085 when Pragma_Validity_Checks => Validity_Checks : declare
13086 A : constant Node_Id := Get_Pragma_Arg (Arg1);
13092 Check_Arg_Count (1);
13093 Check_No_Identifiers;
13095 if Nkind (A) = N_String_Literal then
13099 Slen : constant Natural := Natural (String_Length (S));
13100 Options : String (1 .. Slen);
13106 C := Get_String_Char (S, Int (J));
13107 exit when not In_Character_Range (C);
13108 Options (J) := Get_Character (C);
13111 Set_Validity_Check_Options (Options);
13119 elsif Nkind (A) = N_Identifier then
13121 if Chars (A) = Name_All_Checks then
13122 Set_Validity_Check_Options ("a");
13124 elsif Chars (A) = Name_On then
13125 Validity_Checks_On := True;
13127 elsif Chars (A) = Name_Off then
13128 Validity_Checks_On := False;
13132 end Validity_Checks;
13138 -- pragma Volatile (LOCAL_NAME);
13140 when Pragma_Volatile =>
13141 Process_Atomic_Shared_Volatile;
13143 -------------------------
13144 -- Volatile_Components --
13145 -------------------------
13147 -- pragma Volatile_Components (array_LOCAL_NAME);
13149 -- Volatile is handled by the same circuit as Atomic_Components
13155 -- pragma Warnings (On | Off);
13156 -- pragma Warnings (On | Off, LOCAL_NAME);
13157 -- pragma Warnings (static_string_EXPRESSION);
13158 -- pragma Warnings (On | Off, STRING_LITERAL);
13160 when Pragma_Warnings => Warnings : begin
13162 Check_At_Least_N_Arguments (1);
13163 Check_No_Identifiers;
13165 -- If debug flag -gnatd.i is set, pragma is ignored
13167 if Debug_Flag_Dot_I then
13171 -- Process various forms of the pragma
13174 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
13177 -- One argument case
13179 if Arg_Count = 1 then
13181 -- On/Off one argument case was processed by parser
13183 if Nkind (Argx) = N_Identifier
13185 (Chars (Argx) = Name_On
13187 Chars (Argx) = Name_Off)
13191 -- One argument case must be ON/OFF or static string expr
13193 elsif not Is_Static_String_Expression (Arg1) then
13195 ("argument of pragma% must be On/Off or " &
13196 "static string expression", Arg1);
13198 -- One argument string expression case
13202 Lit : constant Node_Id := Expr_Value_S (Argx);
13203 Str : constant String_Id := Strval (Lit);
13204 Len : constant Nat := String_Length (Str);
13212 while J <= Len loop
13213 C := Get_String_Char (Str, J);
13214 OK := In_Character_Range (C);
13217 Chr := Get_Character (C);
13221 if J < Len and then Chr = '.' then
13223 C := Get_String_Char (Str, J);
13224 Chr := Get_Character (C);
13226 if not Set_Dot_Warning_Switch (Chr) then
13228 ("invalid warning switch character " &
13235 OK := Set_Warning_Switch (Chr);
13241 ("invalid warning switch character " & Chr,
13250 -- Two or more arguments (must be two)
13253 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13254 Check_At_Most_N_Arguments (2);
13262 E_Id := Get_Pragma_Arg (Arg2);
13265 -- In the expansion of an inlined body, a reference to
13266 -- the formal may be wrapped in a conversion if the
13267 -- actual is a conversion. Retrieve the real entity name.
13269 if (In_Instance_Body
13270 or else In_Inlined_Body)
13271 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
13273 E_Id := Expression (E_Id);
13276 -- Entity name case
13278 if Is_Entity_Name (E_Id) then
13279 E := Entity (E_Id);
13286 (E, (Chars (Get_Pragma_Arg (Arg1)) =
13289 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
13290 and then Warn_On_Warnings_Off
13292 Warnings_Off_Pragmas.Append ((N, E));
13295 if Is_Enumeration_Type (E) then
13299 Lit := First_Literal (E);
13300 while Present (Lit) loop
13301 Set_Warnings_Off (Lit);
13302 Next_Literal (Lit);
13307 exit when No (Homonym (E));
13312 -- Error if not entity or static string literal case
13314 elsif not Is_Static_String_Expression (Arg2) then
13316 ("second argument of pragma% must be entity " &
13317 "name or static string expression", Arg2);
13319 -- String literal case
13322 String_To_Name_Buffer
13323 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
13325 -- Note on configuration pragma case: If this is a
13326 -- configuration pragma, then for an OFF pragma, we
13327 -- just set Config True in the call, which is all
13328 -- that needs to be done. For the case of ON, this
13329 -- is normally an error, unless it is canceling the
13330 -- effect of a previous OFF pragma in the same file.
13331 -- In any other case, an error will be signalled (ON
13332 -- with no matching OFF).
13334 if Chars (Argx) = Name_Off then
13335 Set_Specific_Warning_Off
13336 (Loc, Name_Buffer (1 .. Name_Len),
13337 Config => Is_Configuration_Pragma);
13339 elsif Chars (Argx) = Name_On then
13340 Set_Specific_Warning_On
13341 (Loc, Name_Buffer (1 .. Name_Len), Err);
13345 ("?pragma Warnings On with no " &
13346 "matching Warnings Off",
13356 -------------------
13357 -- Weak_External --
13358 -------------------
13360 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
13362 when Pragma_Weak_External => Weak_External : declare
13367 Check_Arg_Count (1);
13368 Check_Optional_Identifier (Arg1, Name_Entity);
13369 Check_Arg_Is_Library_Level_Local_Name (Arg1);
13370 Ent := Entity (Get_Pragma_Arg (Arg1));
13372 if Rep_Item_Too_Early (Ent, N) then
13375 Ent := Underlying_Type (Ent);
13378 -- The only processing required is to link this item on to the
13379 -- list of rep items for the given entity. This is accomplished
13380 -- by the call to Rep_Item_Too_Late (when no error is detected
13381 -- and False is returned).
13383 if Rep_Item_Too_Late (Ent, N) then
13386 Set_Has_Gigi_Rep_Item (Ent);
13390 -----------------------------
13391 -- Wide_Character_Encoding --
13392 -----------------------------
13394 -- pragma Wide_Character_Encoding (IDENTIFIER);
13396 when Pragma_Wide_Character_Encoding =>
13399 -- Nothing to do, handled in parser. Note that we do not enforce
13400 -- configuration pragma placement, this pragma can appear at any
13401 -- place in the source, allowing mixed encodings within a single
13406 --------------------
13407 -- Unknown_Pragma --
13408 --------------------
13410 -- Should be impossible, since the case of an unknown pragma is
13411 -- separately processed before the case statement is entered.
13413 when Unknown_Pragma =>
13414 raise Program_Error;
13417 -- AI05-0144: detect dangerous order dependence. Disabled for now,
13418 -- until AI is formally approved.
13420 -- Check_Order_Dependence;
13423 when Pragma_Exit => null;
13424 end Analyze_Pragma;
13426 -------------------
13427 -- Check_Enabled --
13428 -------------------
13430 function Check_Enabled (Nam : Name_Id) return Boolean is
13434 PP := Opt.Check_Policy_List;
13437 return Assertions_Enabled;
13440 Nam = Chars (Expression (First (Pragma_Argument_Associations (PP))))
13443 Chars (Expression (Last (Pragma_Argument_Associations (PP))))
13445 when Name_On | Name_Check =>
13447 when Name_Off | Name_Ignore =>
13450 raise Program_Error;
13454 PP := Next_Pragma (PP);
13459 ---------------------------------
13460 -- Delay_Config_Pragma_Analyze --
13461 ---------------------------------
13463 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
13465 return Pragma_Name (N) = Name_Interrupt_State
13467 Pragma_Name (N) = Name_Priority_Specific_Dispatching;
13468 end Delay_Config_Pragma_Analyze;
13470 -------------------------
13471 -- Get_Base_Subprogram --
13472 -------------------------
13474 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
13475 Result : Entity_Id;
13478 -- Follow subprogram renaming chain
13481 while Is_Subprogram (Result)
13483 (Is_Generic_Instance (Result)
13484 or else Nkind (Parent (Declaration_Node (Result))) =
13485 N_Subprogram_Renaming_Declaration)
13486 and then Present (Alias (Result))
13488 Result := Alias (Result);
13492 end Get_Base_Subprogram;
13498 procedure Initialize is
13503 -----------------------------
13504 -- Is_Config_Static_String --
13505 -----------------------------
13507 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
13509 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
13510 -- This is an internal recursive function that is just like the outer
13511 -- function except that it adds the string to the name buffer rather
13512 -- than placing the string in the name buffer.
13514 ------------------------------
13515 -- Add_Config_Static_String --
13516 ------------------------------
13518 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
13525 if Nkind (N) = N_Op_Concat then
13526 if Add_Config_Static_String (Left_Opnd (N)) then
13527 N := Right_Opnd (N);
13533 if Nkind (N) /= N_String_Literal then
13534 Error_Msg_N ("string literal expected for pragma argument", N);
13538 for J in 1 .. String_Length (Strval (N)) loop
13539 C := Get_String_Char (Strval (N), J);
13541 if not In_Character_Range (C) then
13543 ("string literal contains invalid wide character",
13544 Sloc (N) + 1 + Source_Ptr (J));
13548 Add_Char_To_Name_Buffer (Get_Character (C));
13553 end Add_Config_Static_String;
13555 -- Start of processing for Is_Config_Static_String
13560 return Add_Config_Static_String (Arg);
13561 end Is_Config_Static_String;
13563 -----------------------------------------
13564 -- Is_Non_Significant_Pragma_Reference --
13565 -----------------------------------------
13567 -- This function makes use of the following static table which indicates
13568 -- whether a given pragma is significant.
13570 -- -1 indicates that references in any argument position are significant
13571 -- 0 indicates that appearence in any argument is not significant
13572 -- +n indicates that appearence as argument n is significant, but all
13573 -- other arguments are not significant
13574 -- 99 special processing required (e.g. for pragma Check)
13576 Sig_Flags : constant array (Pragma_Id) of Int :=
13577 (Pragma_AST_Entry => -1,
13578 Pragma_Abort_Defer => -1,
13579 Pragma_Ada_83 => -1,
13580 Pragma_Ada_95 => -1,
13581 Pragma_Ada_05 => -1,
13582 Pragma_Ada_2005 => -1,
13583 Pragma_Ada_12 => -1,
13584 Pragma_Ada_2012 => -1,
13585 Pragma_All_Calls_Remote => -1,
13586 Pragma_Annotate => -1,
13587 Pragma_Assert => -1,
13588 Pragma_Assertion_Policy => 0,
13589 Pragma_Assume_No_Invalid_Values => 0,
13590 Pragma_Asynchronous => -1,
13591 Pragma_Atomic => 0,
13592 Pragma_Atomic_Components => 0,
13593 Pragma_Attach_Handler => -1,
13594 Pragma_Check => 99,
13595 Pragma_Check_Name => 0,
13596 Pragma_Check_Policy => 0,
13597 Pragma_CIL_Constructor => -1,
13598 Pragma_CPP_Class => 0,
13599 Pragma_CPP_Constructor => 0,
13600 Pragma_CPP_Virtual => 0,
13601 Pragma_CPP_Vtable => 0,
13603 Pragma_C_Pass_By_Copy => 0,
13604 Pragma_Comment => 0,
13605 Pragma_Common_Object => -1,
13606 Pragma_Compile_Time_Error => -1,
13607 Pragma_Compile_Time_Warning => -1,
13608 Pragma_Compiler_Unit => 0,
13609 Pragma_Complete_Representation => 0,
13610 Pragma_Complex_Representation => 0,
13611 Pragma_Component_Alignment => -1,
13612 Pragma_Controlled => 0,
13613 Pragma_Convention => 0,
13614 Pragma_Convention_Identifier => 0,
13615 Pragma_Debug => -1,
13616 Pragma_Debug_Policy => 0,
13617 Pragma_Detect_Blocking => -1,
13618 Pragma_Dimension => -1,
13619 Pragma_Discard_Names => 0,
13620 Pragma_Elaborate => -1,
13621 Pragma_Elaborate_All => -1,
13622 Pragma_Elaborate_Body => -1,
13623 Pragma_Elaboration_Checks => -1,
13624 Pragma_Eliminate => -1,
13625 Pragma_Export => -1,
13626 Pragma_Export_Exception => -1,
13627 Pragma_Export_Function => -1,
13628 Pragma_Export_Object => -1,
13629 Pragma_Export_Procedure => -1,
13630 Pragma_Export_Value => -1,
13631 Pragma_Export_Valued_Procedure => -1,
13632 Pragma_Extend_System => -1,
13633 Pragma_Extensions_Allowed => -1,
13634 Pragma_External => -1,
13635 Pragma_Favor_Top_Level => -1,
13636 Pragma_External_Name_Casing => -1,
13637 Pragma_Fast_Math => -1,
13638 Pragma_Finalize_Storage_Only => 0,
13639 Pragma_Float_Representation => 0,
13640 Pragma_Ident => -1,
13641 Pragma_Implemented => -1,
13642 Pragma_Implicit_Packing => 0,
13643 Pragma_Import => +2,
13644 Pragma_Import_Exception => 0,
13645 Pragma_Import_Function => 0,
13646 Pragma_Import_Object => 0,
13647 Pragma_Import_Procedure => 0,
13648 Pragma_Import_Valued_Procedure => 0,
13649 Pragma_Independent => 0,
13650 Pragma_Independent_Components => 0,
13651 Pragma_Initialize_Scalars => -1,
13652 Pragma_Inline => 0,
13653 Pragma_Inline_Always => 0,
13654 Pragma_Inline_Generic => 0,
13655 Pragma_Inspection_Point => -1,
13656 Pragma_Interface => +2,
13657 Pragma_Interface_Name => +2,
13658 Pragma_Interrupt_Handler => -1,
13659 Pragma_Interrupt_Priority => -1,
13660 Pragma_Interrupt_State => -1,
13661 Pragma_Java_Constructor => -1,
13662 Pragma_Java_Interface => -1,
13663 Pragma_Keep_Names => 0,
13664 Pragma_License => -1,
13665 Pragma_Link_With => -1,
13666 Pragma_Linker_Alias => -1,
13667 Pragma_Linker_Constructor => -1,
13668 Pragma_Linker_Destructor => -1,
13669 Pragma_Linker_Options => -1,
13670 Pragma_Linker_Section => -1,
13672 Pragma_Locking_Policy => -1,
13673 Pragma_Long_Float => -1,
13674 Pragma_Machine_Attribute => -1,
13676 Pragma_Main_Storage => -1,
13677 Pragma_Memory_Size => -1,
13678 Pragma_No_Return => 0,
13679 Pragma_No_Body => 0,
13680 Pragma_No_Run_Time => -1,
13681 Pragma_No_Strict_Aliasing => -1,
13682 Pragma_Normalize_Scalars => -1,
13683 Pragma_Obsolescent => 0,
13684 Pragma_Optimize => -1,
13685 Pragma_Optimize_Alignment => -1,
13686 Pragma_Ordered => 0,
13689 Pragma_Passive => -1,
13690 Pragma_Preelaborable_Initialization => -1,
13691 Pragma_Polling => -1,
13692 Pragma_Persistent_BSS => 0,
13693 Pragma_Postcondition => -1,
13694 Pragma_Precondition => -1,
13695 Pragma_Preelaborate => -1,
13696 Pragma_Preelaborate_05 => -1,
13697 Pragma_Priority => -1,
13698 Pragma_Priority_Specific_Dispatching => -1,
13699 Pragma_Profile => 0,
13700 Pragma_Profile_Warnings => 0,
13701 Pragma_Propagate_Exceptions => -1,
13702 Pragma_Psect_Object => -1,
13704 Pragma_Pure_05 => -1,
13705 Pragma_Pure_Function => -1,
13706 Pragma_Queuing_Policy => -1,
13707 Pragma_Ravenscar => -1,
13708 Pragma_Relative_Deadline => -1,
13709 Pragma_Remote_Call_Interface => -1,
13710 Pragma_Remote_Types => -1,
13711 Pragma_Restricted_Run_Time => -1,
13712 Pragma_Restriction_Warnings => -1,
13713 Pragma_Restrictions => -1,
13714 Pragma_Reviewable => -1,
13715 Pragma_Short_Circuit_And_Or => -1,
13716 Pragma_Share_Generic => -1,
13717 Pragma_Shared => -1,
13718 Pragma_Shared_Passive => -1,
13719 Pragma_Short_Descriptors => 0,
13720 Pragma_Source_File_Name => -1,
13721 Pragma_Source_File_Name_Project => -1,
13722 Pragma_Source_Reference => -1,
13723 Pragma_Storage_Size => -1,
13724 Pragma_Storage_Unit => -1,
13725 Pragma_Static_Elaboration_Desired => -1,
13726 Pragma_Stream_Convert => -1,
13727 Pragma_Style_Checks => -1,
13728 Pragma_Subtitle => -1,
13729 Pragma_Suppress => 0,
13730 Pragma_Suppress_Exception_Locations => 0,
13731 Pragma_Suppress_All => -1,
13732 Pragma_Suppress_Debug_Info => 0,
13733 Pragma_Suppress_Initialization => 0,
13734 Pragma_System_Name => -1,
13735 Pragma_Task_Dispatching_Policy => -1,
13736 Pragma_Task_Info => -1,
13737 Pragma_Task_Name => -1,
13738 Pragma_Task_Storage => 0,
13739 Pragma_Thread_Local_Storage => 0,
13740 Pragma_Time_Slice => -1,
13741 Pragma_Title => -1,
13742 Pragma_Unchecked_Union => 0,
13743 Pragma_Unimplemented_Unit => -1,
13744 Pragma_Universal_Aliasing => -1,
13745 Pragma_Universal_Data => -1,
13746 Pragma_Unmodified => -1,
13747 Pragma_Unreferenced => -1,
13748 Pragma_Unreferenced_Objects => -1,
13749 Pragma_Unreserve_All_Interrupts => -1,
13750 Pragma_Unsuppress => 0,
13751 Pragma_Use_VADS_Size => -1,
13752 Pragma_Validity_Checks => -1,
13753 Pragma_Volatile => 0,
13754 Pragma_Volatile_Components => 0,
13755 Pragma_Warnings => -1,
13756 Pragma_Weak_External => -1,
13757 Pragma_Wide_Character_Encoding => 0,
13758 Unknown_Pragma => 0);
13760 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
13769 if Nkind (P) /= N_Pragma_Argument_Association then
13773 Id := Get_Pragma_Id (Parent (P));
13774 C := Sig_Flags (Id);
13786 -- For pragma Check, the first argument is not significant,
13787 -- the second and the third (if present) arguments are
13790 when Pragma_Check =>
13792 P = First (Pragma_Argument_Associations (Parent (P)));
13795 raise Program_Error;
13799 A := First (Pragma_Argument_Associations (Parent (P)));
13800 for J in 1 .. C - 1 loop
13808 return A = P; -- is this wrong way round ???
13811 end Is_Non_Significant_Pragma_Reference;
13813 ------------------------------
13814 -- Is_Pragma_String_Literal --
13815 ------------------------------
13817 -- This function returns true if the corresponding pragma argument is a
13818 -- static string expression. These are the only cases in which string
13819 -- literals can appear as pragma arguments. We also allow a string literal
13820 -- as the first argument to pragma Assert (although it will of course
13821 -- always generate a type error).
13823 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
13824 Pragn : constant Node_Id := Parent (Par);
13825 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
13826 Pname : constant Name_Id := Pragma_Name (Pragn);
13832 N := First (Assoc);
13839 if Pname = Name_Assert then
13842 elsif Pname = Name_Export then
13845 elsif Pname = Name_Ident then
13848 elsif Pname = Name_Import then
13851 elsif Pname = Name_Interface_Name then
13854 elsif Pname = Name_Linker_Alias then
13857 elsif Pname = Name_Linker_Section then
13860 elsif Pname = Name_Machine_Attribute then
13863 elsif Pname = Name_Source_File_Name then
13866 elsif Pname = Name_Source_Reference then
13869 elsif Pname = Name_Title then
13872 elsif Pname = Name_Subtitle then
13878 end Is_Pragma_String_Literal;
13880 --------------------------------------
13881 -- Process_Compilation_Unit_Pragmas --
13882 --------------------------------------
13884 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
13886 -- A special check for pragma Suppress_All, a very strange DEC pragma,
13887 -- strange because it comes at the end of the unit. Rational has the
13888 -- same name for a pragma, but treats it as a program unit pragma, In
13889 -- GNAT we just decide to allow it anywhere at all. If it appeared then
13890 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
13891 -- node, and we insert a pragma Suppress (All_Checks) at the start of
13892 -- the context clause to ensure the correct processing.
13894 if Has_Pragma_Suppress_All (N) then
13895 Prepend_To (Context_Items (N),
13896 Make_Pragma (Sloc (N),
13897 Chars => Name_Suppress,
13898 Pragma_Argument_Associations => New_List (
13899 Make_Pragma_Argument_Association (Sloc (N),
13901 Make_Identifier (Sloc (N),
13902 Chars => Name_All_Checks)))));
13905 -- Nothing else to do at the current time!
13907 end Process_Compilation_Unit_Pragmas;
13918 --------------------------------
13919 -- Set_Encoded_Interface_Name --
13920 --------------------------------
13922 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
13923 Str : constant String_Id := Strval (S);
13924 Len : constant Int := String_Length (Str);
13929 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
13932 -- Stores encoded value of character code CC. The encoding we use an
13933 -- underscore followed by four lower case hex digits.
13939 procedure Encode is
13941 Store_String_Char (Get_Char_Code ('_'));
13943 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
13945 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
13947 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
13949 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
13952 -- Start of processing for Set_Encoded_Interface_Name
13955 -- If first character is asterisk, this is a link name, and we leave it
13956 -- completely unmodified. We also ignore null strings (the latter case
13957 -- happens only in error cases) and no encoding should occur for Java or
13958 -- AAMP interface names.
13961 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
13962 or else VM_Target /= No_VM
13963 or else AAMP_On_Target
13965 Set_Interface_Name (E, S);
13970 CC := Get_String_Char (Str, J);
13972 exit when not In_Character_Range (CC);
13974 C := Get_Character (CC);
13976 exit when C /= '_' and then C /= '$'
13977 and then C not in '0' .. '9'
13978 and then C not in 'a' .. 'z'
13979 and then C not in 'A' .. 'Z';
13982 Set_Interface_Name (E, S);
13990 -- Here we need to encode. The encoding we use as follows:
13991 -- three underscores + four hex digits (lower case)
13995 for J in 1 .. String_Length (Str) loop
13996 CC := Get_String_Char (Str, J);
13998 if not In_Character_Range (CC) then
14001 C := Get_Character (CC);
14003 if C = '_' or else C = '$'
14004 or else C in '0' .. '9'
14005 or else C in 'a' .. 'z'
14006 or else C in 'A' .. 'Z'
14008 Store_String_Char (CC);
14015 Set_Interface_Name (E,
14016 Make_String_Literal (Sloc (S),
14017 Strval => End_String));
14019 end Set_Encoded_Interface_Name;
14021 -------------------
14022 -- Set_Unit_Name --
14023 -------------------
14025 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
14030 if Nkind (N) = N_Identifier
14031 and then Nkind (With_Item) = N_Identifier
14033 Set_Entity (N, Entity (With_Item));
14035 elsif Nkind (N) = N_Selected_Component then
14036 Change_Selected_Component_To_Expanded_Name (N);
14037 Set_Entity (N, Entity (With_Item));
14038 Set_Entity (Selector_Name (N), Entity (N));
14040 Pref := Prefix (N);
14041 Scop := Scope (Entity (N));
14042 while Nkind (Pref) = N_Selected_Component loop
14043 Change_Selected_Component_To_Expanded_Name (Pref);
14044 Set_Entity (Selector_Name (Pref), Scop);
14045 Set_Entity (Pref, Scop);
14046 Pref := Prefix (Pref);
14047 Scop := Scope (Scop);
14050 Set_Entity (Pref, Scop);