1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with 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_Dist; use Exp_Dist;
41 with Exp_Util; use Exp_Util;
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;
87 with Warnsw; use Warnsw;
89 package body Sem_Prag is
91 ----------------------------------------------
92 -- Common Handling of Import-Export Pragmas --
93 ----------------------------------------------
95 -- In the following section, a number of Import_xxx and Export_xxx pragmas
96 -- are defined by GNAT. These are compatible with the DEC pragmas of the
97 -- same name, and all have the following common form and processing:
100 -- [Internal =>] LOCAL_NAME
101 -- [, [External =>] EXTERNAL_SYMBOL]
102 -- [, other optional parameters ]);
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
109 -- EXTERNAL_SYMBOL ::=
111 -- | static_string_EXPRESSION
113 -- The internal LOCAL_NAME designates the entity that is imported or
114 -- exported, and must refer to an entity in the current declarative
115 -- part (as required by the rules for LOCAL_NAME).
117 -- The external linker name is designated by the External parameter if
118 -- given, or the Internal parameter if not (if there is no External
119 -- parameter, the External parameter is a copy of the Internal name).
121 -- If the External parameter is given as a string, then this string is
122 -- treated as an external name (exactly as though it had been given as an
123 -- External_Name parameter for a normal Import pragma).
125 -- If the External parameter is given as an identifier (or there is no
126 -- External parameter, so that the Internal identifier is used), then
127 -- the external name is the characters of the identifier, translated
128 -- to all upper case letters for OpenVMS versions of GNAT, and to all
129 -- lower case letters for all other versions
131 -- Note: the external name specified or implied by any of these special
132 -- Import_xxx or Export_xxx pragmas override an external or link name
133 -- specified in a previous Import or Export pragma.
135 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
136 -- named notation, following the standard rules for subprogram calls, i.e.
137 -- parameters can be given in any order if named notation is used, and
138 -- positional and named notation can be mixed, subject to the rule that all
139 -- positional parameters must appear first.
141 -- Note: All these pragmas are implemented exactly following the DEC design
142 -- and implementation and are intended to be fully compatible with the use
143 -- of these pragmas in the DEC Ada compiler.
145 --------------------------------------------
146 -- Checking for Duplicated External Names --
147 --------------------------------------------
149 -- It is suspicious if two separate Export pragmas use the same external
150 -- name. The following table is used to diagnose this situation so that
151 -- an appropriate warning can be issued.
153 -- The Node_Id stored is for the N_String_Literal node created to hold
154 -- the value of the external name. The Sloc of this node is used to
155 -- cross-reference the location of the duplication.
157 package Externals is new Table.Table (
158 Table_Component_Type => Node_Id,
159 Table_Index_Type => Int,
160 Table_Low_Bound => 0,
161 Table_Initial => 100,
162 Table_Increment => 100,
163 Table_Name => "Name_Externals");
165 -------------------------------------
166 -- Local Subprograms and Variables --
167 -------------------------------------
169 function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
170 -- This routine is used for possible casing adjustment of an explicit
171 -- external name supplied as a string literal (the node N), according to
172 -- the casing requirement of Opt.External_Name_Casing. If this is set to
173 -- As_Is, then the string literal is returned unchanged, but if it is set
174 -- to Uppercase or Lowercase, then a new string literal with appropriate
175 -- casing is constructed.
177 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
178 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
179 -- original one, following the renaming chain) is returned. Otherwise the
180 -- entity is returned unchanged. Should be in Einfo???
182 procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id);
183 -- Preanalyze the boolean expressions in the Requires and Ensures arguments
184 -- of a Test_Case pragma if present (possibly Empty). We treat these as
185 -- spec expressions (i.e. similar to a default expression).
188 -- This is a dummy function called by the processing for pragma Reviewable.
189 -- It is there for assisting front end debugging. By placing a Reviewable
190 -- pragma in the source program, a breakpoint on rv catches this place in
191 -- the source, allowing convenient stepping to the point of interest.
193 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
194 -- Place semantic information on the argument of an Elaborate/Elaborate_All
195 -- pragma. Entity name for unit and its parents is taken from item in
196 -- previous with_clause that mentions the unit.
198 -------------------------------
199 -- Adjust_External_Name_Case --
200 -------------------------------
202 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
206 -- Adjust case of literal if required
208 if Opt.External_Name_Exp_Casing = As_Is then
212 -- Copy existing string
218 for J in 1 .. String_Length (Strval (N)) loop
219 CC := Get_String_Char (Strval (N), J);
221 if Opt.External_Name_Exp_Casing = Uppercase
222 and then CC >= Get_Char_Code ('a')
223 and then CC <= Get_Char_Code ('z')
225 Store_String_Char (CC - 32);
227 elsif Opt.External_Name_Exp_Casing = Lowercase
228 and then CC >= Get_Char_Code ('A')
229 and then CC <= Get_Char_Code ('Z')
231 Store_String_Char (CC + 32);
234 Store_String_Char (CC);
239 Make_String_Literal (Sloc (N),
240 Strval => End_String);
242 end Adjust_External_Name_Case;
244 ------------------------------
245 -- Analyze_PPC_In_Decl_Part --
246 ------------------------------
248 procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
249 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
252 -- Install formals and push subprogram spec onto scope stack so that we
253 -- can see the formals from the pragma.
258 -- Preanalyze the boolean expression, we treat this as a spec expression
259 -- (i.e. similar to a default expression).
261 Preanalyze_Spec_Expression
262 (Get_Pragma_Arg (Arg1), Standard_Boolean);
264 -- Remove the subprogram from the scope stack now that the pre-analysis
265 -- of the precondition/postcondition is done.
268 end Analyze_PPC_In_Decl_Part;
274 procedure Analyze_Pragma (N : Node_Id) is
275 Loc : constant Source_Ptr := Sloc (N);
276 Pname : constant Name_Id := Pragma_Name (N);
279 Pragma_Exit : exception;
280 -- This exception is used to exit pragma processing completely. It is
281 -- used when an error is detected, and no further processing is
282 -- required. It is also used if an earlier error has left the tree in
283 -- a state where the pragma should not be processed.
286 -- Number of pragma argument associations
292 -- First four pragma arguments (pragma argument association nodes, or
293 -- Empty if the corresponding argument does not exist).
295 type Name_List is array (Natural range <>) of Name_Id;
296 type Args_List is array (Natural range <>) of Node_Id;
297 -- Types used for arguments to Check_Arg_Order and Gather_Associations
299 procedure Ada_2005_Pragma;
300 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
301 -- Ada 95 mode, these are implementation defined pragmas, so should be
302 -- caught by the No_Implementation_Pragmas restriction.
304 procedure Ada_2012_Pragma;
305 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
306 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
307 -- should be caught by the No_Implementation_Pragmas restriction.
309 procedure Check_Ada_83_Warning;
310 -- Issues a warning message for the current pragma if operating in Ada
311 -- 83 mode (used for language pragmas that are not a standard part of
312 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use
315 procedure Check_Arg_Count (Required : Nat);
316 -- Check argument count for pragma is equal to given parameter. If not,
317 -- then issue an error message and raise Pragma_Exit.
319 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
320 -- Arg which can either be a pragma argument association, in which case
321 -- the check is applied to the expression of the association or an
322 -- expression directly.
324 procedure Check_Arg_Is_External_Name (Arg : Node_Id);
325 -- Check that an argument has the right form for an EXTERNAL_NAME
326 -- parameter of an extended import/export pragma. The rule is that the
327 -- name must be an identifier or string literal (in Ada 83 mode) or a
328 -- static string expression (in Ada 95 mode).
330 procedure Check_Arg_Is_Identifier (Arg : Node_Id);
331 -- Check the specified argument Arg to make sure that it is an
332 -- identifier. If not give error and raise Pragma_Exit.
334 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
335 -- Check the specified argument Arg to make sure that it is an integer
336 -- literal. If not give error and raise Pragma_Exit.
338 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
339 -- Check the specified argument Arg to make sure that it has the proper
340 -- syntactic form for a local name and meets the semantic requirements
341 -- for a local name. The local name is analyzed as part of the
342 -- processing for this call. In addition, the local name is required
343 -- to represent an entity at the library level.
345 procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
346 -- Check the specified argument Arg to make sure that it has the proper
347 -- syntactic form for a local name and meets the semantic requirements
348 -- for a local name. The local name is analyzed as part of the
349 -- processing for this call.
351 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
352 -- Check the specified argument Arg to make sure that it is a valid
353 -- locking policy name. If not give error and raise Pragma_Exit.
355 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
356 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id);
357 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3, N4 : Name_Id);
358 -- Check the specified argument Arg to make sure that it is an
359 -- identifier whose name matches either N1 or N2 (or N3 if present).
360 -- If not then give error and raise Pragma_Exit.
362 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
363 -- Check the specified argument Arg to make sure that it is a valid
364 -- queuing policy name. If not give error and raise Pragma_Exit.
366 procedure Check_Arg_Is_Static_Expression
368 Typ : Entity_Id := Empty);
369 -- Check the specified argument Arg to make sure that it is a static
370 -- expression of the given type (i.e. it will be analyzed and resolved
371 -- using this type, which can be any valid argument to Resolve, e.g.
372 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
373 -- Typ is left Empty, then any static expression is allowed.
375 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
376 -- Check the specified argument Arg to make sure that it is a valid task
377 -- dispatching policy name. If not give error and raise Pragma_Exit.
379 procedure Check_Arg_Order (Names : Name_List);
380 -- Checks for an instance of two arguments with identifiers for the
381 -- current pragma which are not in the sequence indicated by Names,
382 -- and if so, generates a fatal message about bad order of arguments.
384 procedure Check_At_Least_N_Arguments (N : Nat);
385 -- Check there are at least N arguments present
387 procedure Check_At_Most_N_Arguments (N : Nat);
388 -- Check there are no more than N arguments present
390 procedure Check_Component
393 In_Variant_Part : Boolean := False);
394 -- Examine an Unchecked_Union component for correct use of per-object
395 -- constrained subtypes, and for restrictions on finalizable components.
396 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
397 -- should be set when Comp comes from a record variant.
399 procedure Check_Duplicate_Pragma (E : Entity_Id);
400 -- Check if a pragma of the same name as the current pragma is already
401 -- chained as a rep pragma to the given entity. If so give a message
402 -- about the duplicate, and then raise Pragma_Exit so does not return.
403 -- Also checks for delayed aspect specification node in the chain.
405 procedure Check_Duplicated_Export_Name (Nam : Node_Id);
406 -- Nam is an N_String_Literal node containing the external name set by
407 -- an Import or Export pragma (or extended Import or Export pragma).
408 -- This procedure checks for possible duplications if this is the export
409 -- case, and if found, issues an appropriate error message.
411 procedure Check_First_Subtype (Arg : Node_Id);
412 -- Checks that Arg, whose expression is an entity name, references a
415 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
416 -- Checks that the given argument has an identifier, and if so, requires
417 -- it to match the given identifier name. If there is no identifier, or
418 -- a non-matching identifier, then an error message is given and
419 -- Pragma_Exit is raised.
421 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
422 -- Checks that the given argument has an identifier, and if so, requires
423 -- it to match one of the given identifier names. If there is no
424 -- identifier, or a non-matching identifier, then an error message is
425 -- given and Pragma_Exit is raised. This checks the optional identifier
426 -- of a pragma argument, not the argument itself like
427 -- Check_Arg_Is_One_Of does.
429 procedure Check_In_Main_Program;
430 -- Common checks for pragmas that appear within a main program
431 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
433 procedure Check_Interrupt_Or_Attach_Handler;
434 -- Common processing for first argument of pragma Interrupt_Handler or
435 -- pragma Attach_Handler.
437 procedure Check_Is_In_Decl_Part_Or_Package_Spec;
438 -- Check that pragma appears in a declarative part, or in a package
439 -- specification, i.e. that it does not occur in a statement sequence
442 procedure Check_No_Identifier (Arg : Node_Id);
443 -- Checks that the given argument does not have an identifier. If
444 -- an identifier is present, then an error message is issued, and
445 -- Pragma_Exit is raised.
447 procedure Check_No_Identifiers;
448 -- Checks that none of the arguments to the pragma has an identifier.
449 -- If any argument has an identifier, then an error message is issued,
450 -- and Pragma_Exit is raised.
452 procedure Check_No_Link_Name;
453 -- Checks that no link name is specified
455 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
456 -- Checks if the given argument has an identifier, and if so, requires
457 -- it to match the given identifier name. If there is a non-matching
458 -- identifier, then an error message is given and Pragma_Exit is raised.
460 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
461 -- Checks if the given argument has an identifier, and if so, requires
462 -- it to match the given identifier name. If there is a non-matching
463 -- identifier, then an error message is given and Pragma_Exit is raised.
464 -- In this version of the procedure, the identifier name is given as
465 -- a string with lower case letters.
467 procedure Check_Precondition_Postcondition (In_Body : out Boolean);
468 -- Called to process a precondition or postcondition pragma. There are
471 -- The pragma appears after a subprogram spec
473 -- If the corresponding check is not enabled, the pragma is analyzed
474 -- but otherwise ignored and control returns with In_Body set False.
476 -- If the check is enabled, then the first step is to analyze the
477 -- pragma, but this is skipped if the subprogram spec appears within
478 -- a package specification (because this is the case where we delay
479 -- analysis till the end of the spec). Then (whether or not it was
480 -- analyzed), the pragma is chained to the subprogram in question
481 -- (using Spec_PPC_List and Next_Pragma) and control returns to the
482 -- caller with In_Body set False.
484 -- The pragma appears at the start of subprogram body declarations
486 -- In this case an immediate return to the caller is made with
487 -- In_Body set True, and the pragma is NOT analyzed.
489 -- In all other cases, an error message for bad placement is given
491 procedure Check_Static_Constraint (Constr : Node_Id);
492 -- Constr is a constraint from an N_Subtype_Indication node from a
493 -- component constraint in an Unchecked_Union type. This routine checks
494 -- that the constraint is static as required by the restrictions for
497 procedure Check_Test_Case;
498 -- Called to process a test-case pragma. The treatment is similar to the
499 -- one for pre- and postcondition in Check_Precondition_Postcondition.
500 -- There are three cases:
502 -- The pragma appears after a subprogram spec
504 -- The first step is to analyze the pragma, but this is skipped if
505 -- the subprogram spec appears within a package specification
506 -- (because this is the case where we delay analysis till the end of
507 -- the spec). Then (whether or not it was analyzed), the pragma is
508 -- chained to the subprogram in question (using Spec_TC_List and
511 -- The pragma appears at the start of subprogram body declarations
513 -- In this case an immediate return to the caller is made, and the
514 -- pragma is NOT analyzed.
516 -- In all other cases, an error message for bad placement is given
518 procedure Check_Valid_Configuration_Pragma;
519 -- Legality checks for placement of a configuration pragma
521 procedure Check_Valid_Library_Unit_Pragma;
522 -- Legality checks for library unit pragmas. A special case arises for
523 -- pragmas in generic instances that come from copies of the original
524 -- library unit pragmas in the generic templates. In the case of other
525 -- than library level instantiations these can appear in contexts which
526 -- would normally be invalid (they only apply to the original template
527 -- and to library level instantiations), and they are simply ignored,
528 -- which is implemented by rewriting them as null statements.
530 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
531 -- Check an Unchecked_Union variant for lack of nested variants and
532 -- presence of at least one component. UU_Typ is the related Unchecked_
535 procedure Error_Pragma (Msg : String);
536 pragma No_Return (Error_Pragma);
537 -- Outputs error message for current pragma. The message contains a %
538 -- that will be replaced with the pragma name, and the flag is placed
539 -- on the pragma itself. Pragma_Exit is then raised.
541 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
542 pragma No_Return (Error_Pragma_Arg);
543 -- Outputs error message for current pragma. The message may contain
544 -- a % that will be replaced with the pragma name. The parameter Arg
545 -- may either be a pragma argument association, in which case the flag
546 -- is placed on the expression of this association, or an expression,
547 -- in which case the flag is placed directly on the expression. The
548 -- message is placed using Error_Msg_N, so the message may also contain
549 -- an & insertion character which will reference the given Arg value.
550 -- After placing the message, Pragma_Exit is raised.
552 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
553 pragma No_Return (Error_Pragma_Arg);
554 -- Similar to above form of Error_Pragma_Arg except that two messages
555 -- are provided, the second is a continuation comment starting with \.
557 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
558 pragma No_Return (Error_Pragma_Arg_Ident);
559 -- Outputs error message for current pragma. The message may contain
560 -- a % that will be replaced with the pragma name. The parameter Arg
561 -- must be a pragma argument association with a non-empty identifier
562 -- (i.e. its Chars field must be set), and the error message is placed
563 -- on the identifier. The message is placed using Error_Msg_N so
564 -- the message may also contain an & insertion character which will
565 -- reference the identifier. After placing the message, Pragma_Exit
568 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
569 pragma No_Return (Error_Pragma_Ref);
570 -- Outputs error message for current pragma. The message may contain
571 -- a % that will be replaced with the pragma name. The parameter Ref
572 -- must be an entity whose name can be referenced by & and sloc by #.
573 -- After placing the message, Pragma_Exit is raised.
575 function Find_Lib_Unit_Name return Entity_Id;
576 -- Used for a library unit pragma to find the entity to which the
577 -- library unit pragma applies, returns the entity found.
579 procedure Find_Program_Unit_Name (Id : Node_Id);
580 -- If the pragma is a compilation unit pragma, the id must denote the
581 -- compilation unit in the same compilation, and the pragma must appear
582 -- in the list of preceding or trailing pragmas. If it is a program
583 -- unit pragma that is not a compilation unit pragma, then the
584 -- identifier must be visible.
586 function Find_Unique_Parameterless_Procedure
588 Arg : Node_Id) return Entity_Id;
589 -- Used for a procedure pragma to find the unique parameterless
590 -- procedure identified by Name, returns it if it exists, otherwise
591 -- errors out and uses Arg as the pragma argument for the message.
593 procedure Fix_Error (Msg : in out String);
594 -- This is called prior to issuing an error message. Msg is a string
595 -- which typically contains the substring pragma. If the current pragma
596 -- comes from an aspect, each such "pragma" substring is replaced with
597 -- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
598 -- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).
600 procedure Gather_Associations
602 Args : out Args_List);
603 -- This procedure is used to gather the arguments for a pragma that
604 -- permits arbitrary ordering of parameters using the normal rules
605 -- for named and positional parameters. The Names argument is a list
606 -- of Name_Id values that corresponds to the allowed pragma argument
607 -- association identifiers in order. The result returned in Args is
608 -- a list of corresponding expressions that are the pragma arguments.
609 -- Note that this is a list of expressions, not of pragma argument
610 -- associations (Gather_Associations has completely checked all the
611 -- optional identifiers when it returns). An entry in Args is Empty
612 -- on return if the corresponding argument is not present.
614 procedure GNAT_Pragma;
615 -- Called for all GNAT defined pragmas to check the relevant restriction
616 -- (No_Implementation_Pragmas).
618 function Is_Before_First_Decl
619 (Pragma_Node : Node_Id;
620 Decls : List_Id) return Boolean;
621 -- Return True if Pragma_Node is before the first declarative item in
622 -- Decls where Decls is the list of declarative items.
624 function Is_Configuration_Pragma return Boolean;
625 -- Determines if the placement of the current pragma is appropriate
626 -- for a configuration pragma.
628 function Is_In_Context_Clause return Boolean;
629 -- Returns True if pragma appears within the context clause of a unit,
630 -- and False for any other placement (does not generate any messages).
632 function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
633 -- Analyzes the argument, and determines if it is a static string
634 -- expression, returns True if so, False if non-static or not String.
636 procedure Pragma_Misplaced;
637 pragma No_Return (Pragma_Misplaced);
638 -- Issue fatal error message for misplaced pragma
640 procedure Process_Atomic_Shared_Volatile;
641 -- Common processing for pragmas Atomic, Shared, Volatile. Note that
642 -- Shared is an obsolete Ada 83 pragma, treated as being identical
643 -- in effect to pragma Atomic.
645 procedure Process_Compile_Time_Warning_Or_Error;
646 -- Common processing for Compile_Time_Error and Compile_Time_Warning
648 procedure Process_Convention
649 (C : out Convention_Id;
650 Ent : out Entity_Id);
651 -- Common processing for Convention, Interface, Import and Export.
652 -- Checks first two arguments of pragma, and sets the appropriate
653 -- convention value in the specified entity or entities. On return
654 -- C is the convention, Ent is the referenced entity.
656 procedure Process_Extended_Import_Export_Exception_Pragma
657 (Arg_Internal : Node_Id;
658 Arg_External : Node_Id;
661 -- Common processing for the pragmas Import/Export_Exception. The three
662 -- arguments correspond to the three named parameters of the pragma. An
663 -- argument is empty if the corresponding parameter is not present in
666 procedure Process_Extended_Import_Export_Object_Pragma
667 (Arg_Internal : Node_Id;
668 Arg_External : Node_Id;
670 -- Common processing for the pragmas Import/Export_Object. The three
671 -- arguments correspond to the three named parameters of the pragmas. An
672 -- argument is empty if the corresponding parameter is not present in
675 procedure Process_Extended_Import_Export_Internal_Arg
676 (Arg_Internal : Node_Id := Empty);
677 -- Common processing for all extended Import and Export pragmas. The
678 -- argument is the pragma parameter for the Internal argument. If
679 -- Arg_Internal is empty or inappropriate, an error message is posted.
680 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
681 -- set to identify the referenced entity.
683 procedure Process_Extended_Import_Export_Subprogram_Pragma
684 (Arg_Internal : Node_Id;
685 Arg_External : Node_Id;
686 Arg_Parameter_Types : Node_Id;
687 Arg_Result_Type : Node_Id := Empty;
688 Arg_Mechanism : Node_Id;
689 Arg_Result_Mechanism : Node_Id := Empty;
690 Arg_First_Optional_Parameter : Node_Id := Empty);
691 -- Common processing for all extended Import and Export pragmas applying
692 -- to subprograms. The caller omits any arguments that do not apply to
693 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
694 -- only in the Import_Function and Export_Function cases). The argument
695 -- names correspond to the allowed pragma association identifiers.
697 procedure Process_Generic_List;
698 -- Common processing for Share_Generic and Inline_Generic
700 procedure Process_Import_Or_Interface;
701 -- Common processing for Import of Interface
703 procedure Process_Import_Predefined_Type;
704 -- Processing for completing a type with pragma Import. This is used
705 -- to declare types that match predefined C types, especially for cases
706 -- without corresponding Ada predefined type.
708 procedure Process_Inline (Active : Boolean);
709 -- Common processing for Inline and Inline_Always. The parameter
710 -- indicates if the inline pragma is active, i.e. if it should actually
711 -- cause inlining to occur.
713 procedure Process_Interface_Name
714 (Subprogram_Def : Entity_Id;
717 -- Given the last two arguments of pragma Import, pragma Export, or
718 -- pragma Interface_Name, performs validity checks and sets the
719 -- Interface_Name field of the given subprogram entity to the
720 -- appropriate external or link name, depending on the arguments given.
721 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
722 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
723 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
724 -- nor Link_Arg is present, the interface name is set to the default
725 -- from the subprogram name.
727 procedure Process_Interrupt_Or_Attach_Handler;
728 -- Common processing for Interrupt and Attach_Handler pragmas
730 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
731 -- Common processing for Restrictions and Restriction_Warnings pragmas.
732 -- Warn is True for Restriction_Warnings, or for Restrictions if the
733 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
734 -- is not set in the Restrictions case.
736 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
737 -- Common processing for Suppress and Unsuppress. The boolean parameter
738 -- Suppress_Case is True for the Suppress case, and False for the
741 procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
742 -- This procedure sets the Is_Exported flag for the given entity,
743 -- checking that the entity was not previously imported. Arg is
744 -- the argument that specified the entity. A check is also made
745 -- for exporting inappropriate entities.
747 procedure Set_Extended_Import_Export_External_Name
748 (Internal_Ent : Entity_Id;
749 Arg_External : Node_Id);
750 -- Common processing for all extended import export pragmas. The first
751 -- argument, Internal_Ent, is the internal entity, which has already
752 -- been checked for validity by the caller. Arg_External is from the
753 -- Import or Export pragma, and may be null if no External parameter
754 -- was present. If Arg_External is present and is a non-null string
755 -- (a null string is treated as the default), then the Interface_Name
756 -- field of Internal_Ent is set appropriately.
758 procedure Set_Imported (E : Entity_Id);
759 -- This procedure sets the Is_Imported flag for the given entity,
760 -- checking that it is not previously exported or imported.
762 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
763 -- Mech is a parameter passing mechanism (see Import_Function syntax
764 -- for MECHANISM_NAME). This routine checks that the mechanism argument
765 -- has the right form, and if not issues an error message. If the
766 -- argument has the right form then the Mechanism field of Ent is
767 -- set appropriately.
769 procedure Set_Ravenscar_Profile (N : Node_Id);
770 -- Activate the set of configuration pragmas and restrictions that make
771 -- up the Ravenscar Profile. N is the corresponding pragma node, which
772 -- is used for error messages on any constructs that violate the
775 ---------------------
776 -- Ada_2005_Pragma --
777 ---------------------
779 procedure Ada_2005_Pragma is
781 if Ada_Version <= Ada_95 then
782 Check_Restriction (No_Implementation_Pragmas, N);
786 ---------------------
787 -- Ada_2012_Pragma --
788 ---------------------
790 procedure Ada_2012_Pragma is
792 if Ada_Version <= Ada_2005 then
793 Check_Restriction (No_Implementation_Pragmas, N);
797 --------------------------
798 -- Check_Ada_83_Warning --
799 --------------------------
801 procedure Check_Ada_83_Warning is
803 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
804 Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
806 end Check_Ada_83_Warning;
808 ---------------------
809 -- Check_Arg_Count --
810 ---------------------
812 procedure Check_Arg_Count (Required : Nat) is
814 if Arg_Count /= Required then
815 Error_Pragma ("wrong number of arguments for pragma%");
819 --------------------------------
820 -- Check_Arg_Is_External_Name --
821 --------------------------------
823 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
824 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
827 if Nkind (Argx) = N_Identifier then
831 Analyze_And_Resolve (Argx, Standard_String);
833 if Is_OK_Static_Expression (Argx) then
836 elsif Etype (Argx) = Any_Type then
839 -- An interesting special case, if we have a string literal and
840 -- we are in Ada 83 mode, then we allow it even though it will
841 -- not be flagged as static. This allows expected Ada 83 mode
842 -- use of external names which are string literals, even though
843 -- technically these are not static in Ada 83.
845 elsif Ada_Version = Ada_83
846 and then Nkind (Argx) = N_String_Literal
850 -- Static expression that raises Constraint_Error. This has
851 -- already been flagged, so just exit from pragma processing.
853 elsif Is_Static_Expression (Argx) then
856 -- Here we have a real error (non-static expression)
859 Error_Msg_Name_1 := Pname;
863 "argument for pragma% must be a identifier or "
864 & "static string expression!";
867 Flag_Non_Static_Expr (Msg, Argx);
872 end Check_Arg_Is_External_Name;
874 -----------------------------
875 -- Check_Arg_Is_Identifier --
876 -----------------------------
878 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
879 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
881 if Nkind (Argx) /= N_Identifier then
883 ("argument for pragma% must be identifier", Argx);
885 end Check_Arg_Is_Identifier;
887 ----------------------------------
888 -- Check_Arg_Is_Integer_Literal --
889 ----------------------------------
891 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
892 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
894 if Nkind (Argx) /= N_Integer_Literal then
896 ("argument for pragma% must be integer literal", Argx);
898 end Check_Arg_Is_Integer_Literal;
900 -------------------------------------------
901 -- Check_Arg_Is_Library_Level_Local_Name --
902 -------------------------------------------
906 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
907 -- | library_unit_NAME
909 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
911 Check_Arg_Is_Local_Name (Arg);
913 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
914 and then Comes_From_Source (N)
917 ("argument for pragma% must be library level entity", Arg);
919 end Check_Arg_Is_Library_Level_Local_Name;
921 -----------------------------
922 -- Check_Arg_Is_Local_Name --
923 -----------------------------
927 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
928 -- | library_unit_NAME
930 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
931 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
936 if Nkind (Argx) not in N_Direct_Name
937 and then (Nkind (Argx) /= N_Attribute_Reference
938 or else Present (Expressions (Argx))
939 or else Nkind (Prefix (Argx)) /= N_Identifier)
940 and then (not Is_Entity_Name (Argx)
941 or else not Is_Compilation_Unit (Entity (Argx)))
943 Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
946 -- No further check required if not an entity name
948 if not Is_Entity_Name (Argx) then
954 Ent : constant Entity_Id := Entity (Argx);
955 Scop : constant Entity_Id := Scope (Ent);
957 -- Case of a pragma applied to a compilation unit: pragma must
958 -- occur immediately after the program unit in the compilation.
960 if Is_Compilation_Unit (Ent) then
962 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
964 -- Case of pragma placed immediately after spec
966 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
969 -- Case of pragma placed immediately after body
971 elsif Nkind (Decl) = N_Subprogram_Declaration
972 and then Present (Corresponding_Body (Decl))
976 (Parent (Unit_Declaration_Node
977 (Corresponding_Body (Decl))));
979 -- All other cases are illegal
986 -- Special restricted placement rule from 10.2.1(11.8/2)
988 elsif Is_Generic_Formal (Ent)
989 and then Prag_Id = Pragma_Preelaborable_Initialization
991 OK := List_Containing (N) =
992 Generic_Formal_Declarations
993 (Unit_Declaration_Node (Scop));
995 -- Default case, just check that the pragma occurs in the scope
996 -- of the entity denoted by the name.
999 OK := Current_Scope = Scop;
1004 ("pragma% argument must be in same declarative part", Arg);
1008 end Check_Arg_Is_Local_Name;
1010 ---------------------------------
1011 -- Check_Arg_Is_Locking_Policy --
1012 ---------------------------------
1014 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
1015 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1018 Check_Arg_Is_Identifier (Argx);
1020 if not Is_Locking_Policy_Name (Chars (Argx)) then
1021 Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
1023 end Check_Arg_Is_Locking_Policy;
1025 -------------------------
1026 -- Check_Arg_Is_One_Of --
1027 -------------------------
1029 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
1030 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1033 Check_Arg_Is_Identifier (Argx);
1035 if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
1036 Error_Msg_Name_2 := N1;
1037 Error_Msg_Name_3 := N2;
1038 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
1040 end Check_Arg_Is_One_Of;
1042 procedure Check_Arg_Is_One_Of
1044 N1, N2, N3 : Name_Id)
1046 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1049 Check_Arg_Is_Identifier (Argx);
1051 if Chars (Argx) /= N1
1052 and then Chars (Argx) /= N2
1053 and then Chars (Argx) /= N3
1055 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
1057 end Check_Arg_Is_One_Of;
1059 procedure Check_Arg_Is_One_Of
1061 N1, N2, N3, N4 : Name_Id)
1063 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1066 Check_Arg_Is_Identifier (Argx);
1068 if Chars (Argx) /= N1
1069 and then Chars (Argx) /= N2
1070 and then Chars (Argx) /= N3
1071 and then Chars (Argx) /= N4
1073 Error_Pragma_Arg ("invalid argument for pragma%", Argx);
1075 end Check_Arg_Is_One_Of;
1077 ---------------------------------
1078 -- Check_Arg_Is_Queuing_Policy --
1079 ---------------------------------
1081 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
1082 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1085 Check_Arg_Is_Identifier (Argx);
1087 if not Is_Queuing_Policy_Name (Chars (Argx)) then
1088 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
1090 end Check_Arg_Is_Queuing_Policy;
1092 ------------------------------------
1093 -- Check_Arg_Is_Static_Expression --
1094 ------------------------------------
1096 procedure Check_Arg_Is_Static_Expression
1098 Typ : Entity_Id := Empty)
1100 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1103 if Present (Typ) then
1104 Analyze_And_Resolve (Argx, Typ);
1106 Analyze_And_Resolve (Argx);
1109 if Is_OK_Static_Expression (Argx) then
1112 elsif Etype (Argx) = Any_Type then
1115 -- An interesting special case, if we have a string literal and we
1116 -- are in Ada 83 mode, then we allow it even though it will not be
1117 -- flagged as static. This allows the use of Ada 95 pragmas like
1118 -- Import in Ada 83 mode. They will of course be flagged with
1119 -- warnings as usual, but will not cause errors.
1121 elsif Ada_Version = Ada_83
1122 and then Nkind (Argx) = N_String_Literal
1126 -- Static expression that raises Constraint_Error. This has already
1127 -- been flagged, so just exit from pragma processing.
1129 elsif Is_Static_Expression (Argx) then
1132 -- Finally, we have a real error
1135 Error_Msg_Name_1 := Pname;
1139 "argument for pragma% must be a static expression!";
1142 Flag_Non_Static_Expr (Msg, Argx);
1147 end Check_Arg_Is_Static_Expression;
1149 ------------------------------------------
1150 -- Check_Arg_Is_Task_Dispatching_Policy --
1151 ------------------------------------------
1153 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
1154 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1157 Check_Arg_Is_Identifier (Argx);
1159 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
1161 ("& is not a valid task dispatching policy name", Argx);
1163 end Check_Arg_Is_Task_Dispatching_Policy;
1165 ---------------------
1166 -- Check_Arg_Order --
1167 ---------------------
1169 procedure Check_Arg_Order (Names : Name_List) is
1172 Highest_So_Far : Natural := 0;
1173 -- Highest index in Names seen do far
1177 for J in 1 .. Arg_Count loop
1178 if Chars (Arg) /= No_Name then
1179 for K in Names'Range loop
1180 if Chars (Arg) = Names (K) then
1181 if K < Highest_So_Far then
1182 Error_Msg_Name_1 := Pname;
1184 ("parameters out of order for pragma%", Arg);
1185 Error_Msg_Name_1 := Names (K);
1186 Error_Msg_Name_2 := Names (Highest_So_Far);
1187 Error_Msg_N ("\% must appear before %", Arg);
1191 Highest_So_Far := K;
1199 end Check_Arg_Order;
1201 --------------------------------
1202 -- Check_At_Least_N_Arguments --
1203 --------------------------------
1205 procedure Check_At_Least_N_Arguments (N : Nat) is
1207 if Arg_Count < N then
1208 Error_Pragma ("too few arguments for pragma%");
1210 end Check_At_Least_N_Arguments;
1212 -------------------------------
1213 -- Check_At_Most_N_Arguments --
1214 -------------------------------
1216 procedure Check_At_Most_N_Arguments (N : Nat) is
1219 if Arg_Count > N then
1221 for J in 1 .. N loop
1223 Error_Pragma_Arg ("too many arguments for pragma%", Arg);
1226 end Check_At_Most_N_Arguments;
1228 ---------------------
1229 -- Check_Component --
1230 ---------------------
1232 procedure Check_Component
1235 In_Variant_Part : Boolean := False)
1237 Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
1238 Sindic : constant Node_Id :=
1239 Subtype_Indication (Component_Definition (Comp));
1240 Typ : constant Entity_Id := Etype (Comp_Id);
1242 function Inside_Generic_Body (Id : Entity_Id) return Boolean;
1243 -- Determine whether entity Id appears inside a generic body.
1244 -- Shouldn't this be in a more general place ???
1246 -------------------------
1247 -- Inside_Generic_Body --
1248 -------------------------
1250 function Inside_Generic_Body (Id : Entity_Id) return Boolean is
1255 while Present (S) and then S /= Standard_Standard loop
1256 if Ekind (S) = E_Generic_Package
1257 and then In_Package_Body (S)
1266 end Inside_Generic_Body;
1268 -- Start of processing for Check_Component
1271 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
1272 -- object constraint, then the component type shall be an Unchecked_
1275 if Nkind (Sindic) = N_Subtype_Indication
1276 and then Has_Per_Object_Constraint (Comp_Id)
1277 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
1280 ("component subtype subject to per-object constraint " &
1281 "must be an Unchecked_Union", Comp);
1283 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
1284 -- the body of a generic unit, or within the body of any of its
1285 -- descendant library units, no part of the type of a component
1286 -- declared in a variant_part of the unchecked union type shall be of
1287 -- a formal private type or formal private extension declared within
1288 -- the formal part of the generic unit.
1290 elsif Ada_Version >= Ada_2012
1291 and then Inside_Generic_Body (UU_Typ)
1292 and then In_Variant_Part
1293 and then Is_Private_Type (Typ)
1294 and then Is_Generic_Type (Typ)
1297 ("component of Unchecked_Union cannot be of generic type", Comp);
1299 elsif Needs_Finalization (Typ) then
1301 ("component of Unchecked_Union cannot be controlled", Comp);
1303 elsif Has_Task (Typ) then
1305 ("component of Unchecked_Union cannot have tasks", Comp);
1307 end Check_Component;
1309 ----------------------------
1310 -- Check_Duplicate_Pragma --
1311 ----------------------------
1313 procedure Check_Duplicate_Pragma (E : Entity_Id) is
1317 -- Nothing to do if this pragma comes from an aspect specification,
1318 -- since we could not be duplicating a pragma, and we dealt with the
1319 -- case of duplicated aspects in Analyze_Aspect_Specifications.
1321 if From_Aspect_Specification (N) then
1325 -- Otherwise current pragma may duplicate previous pragma or a
1326 -- previously given aspect specification for the same pragma.
1328 P := Get_Rep_Item_For_Entity (E, Pragma_Name (N));
1331 Error_Msg_Name_1 := Pragma_Name (N);
1332 Error_Msg_Sloc := Sloc (P);
1334 if Nkind (P) = N_Aspect_Specification
1335 or else From_Aspect_Specification (P)
1337 Error_Msg_NE ("aspect% for & previously given#", N, E);
1339 Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
1344 end Check_Duplicate_Pragma;
1346 ----------------------------------
1347 -- Check_Duplicated_Export_Name --
1348 ----------------------------------
1350 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
1351 String_Val : constant String_Id := Strval (Nam);
1354 -- We are only interested in the export case, and in the case of
1355 -- generics, it is the instance, not the template, that is the
1356 -- problem (the template will generate a warning in any case).
1358 if not Inside_A_Generic
1359 and then (Prag_Id = Pragma_Export
1361 Prag_Id = Pragma_Export_Procedure
1363 Prag_Id = Pragma_Export_Valued_Procedure
1365 Prag_Id = Pragma_Export_Function)
1367 for J in Externals.First .. Externals.Last loop
1368 if String_Equal (String_Val, Strval (Externals.Table (J))) then
1369 Error_Msg_Sloc := Sloc (Externals.Table (J));
1370 Error_Msg_N ("external name duplicates name given#", Nam);
1375 Externals.Append (Nam);
1377 end Check_Duplicated_Export_Name;
1379 -------------------------
1380 -- Check_First_Subtype --
1381 -------------------------
1383 procedure Check_First_Subtype (Arg : Node_Id) is
1384 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1385 Ent : constant Entity_Id := Entity (Argx);
1388 if Is_First_Subtype (Ent) then
1391 elsif Is_Type (Ent) then
1393 ("pragma% cannot apply to subtype", Argx);
1395 elsif Is_Object (Ent) then
1397 ("pragma% cannot apply to object, requires a type", Argx);
1401 ("pragma% cannot apply to&, requires a type", Argx);
1403 end Check_First_Subtype;
1405 ----------------------
1406 -- Check_Identifier --
1407 ----------------------
1409 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
1412 and then Nkind (Arg) = N_Pragma_Argument_Association
1414 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
1415 Error_Msg_Name_1 := Pname;
1416 Error_Msg_Name_2 := Id;
1417 Error_Msg_N ("pragma% argument expects identifier%", Arg);
1421 end Check_Identifier;
1423 --------------------------------
1424 -- Check_Identifier_Is_One_Of --
1425 --------------------------------
1427 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
1430 and then Nkind (Arg) = N_Pragma_Argument_Association
1432 if Chars (Arg) = No_Name then
1433 Error_Msg_Name_1 := Pname;
1434 Error_Msg_N ("pragma% argument expects an identifier", Arg);
1437 elsif Chars (Arg) /= N1
1438 and then Chars (Arg) /= N2
1440 Error_Msg_Name_1 := Pname;
1441 Error_Msg_N ("invalid identifier for pragma% argument", Arg);
1445 end Check_Identifier_Is_One_Of;
1447 ---------------------------
1448 -- Check_In_Main_Program --
1449 ---------------------------
1451 procedure Check_In_Main_Program is
1452 P : constant Node_Id := Parent (N);
1455 -- Must be at in subprogram body
1457 if Nkind (P) /= N_Subprogram_Body then
1458 Error_Pragma ("% pragma allowed only in subprogram");
1460 -- Otherwise warn if obviously not main program
1462 elsif Present (Parameter_Specifications (Specification (P)))
1463 or else not Is_Compilation_Unit (Defining_Entity (P))
1465 Error_Msg_Name_1 := Pname;
1467 ("?pragma% is only effective in main program", N);
1469 end Check_In_Main_Program;
1471 ---------------------------------------
1472 -- Check_Interrupt_Or_Attach_Handler --
1473 ---------------------------------------
1475 procedure Check_Interrupt_Or_Attach_Handler is
1476 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
1477 Handler_Proc, Proc_Scope : Entity_Id;
1482 if Prag_Id = Pragma_Interrupt_Handler then
1483 Check_Restriction (No_Dynamic_Attachment, N);
1486 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
1487 Proc_Scope := Scope (Handler_Proc);
1489 -- On AAMP only, a pragma Interrupt_Handler is supported for
1490 -- nonprotected parameterless procedures.
1492 if not AAMP_On_Target
1493 or else Prag_Id = Pragma_Attach_Handler
1495 if Ekind (Proc_Scope) /= E_Protected_Type then
1497 ("argument of pragma% must be protected procedure", Arg1);
1500 if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
1501 Error_Pragma ("pragma% must be in protected definition");
1505 if not Is_Library_Level_Entity (Proc_Scope)
1506 or else (AAMP_On_Target
1507 and then not Is_Library_Level_Entity (Handler_Proc))
1510 ("argument for pragma% must be library level entity", Arg1);
1513 -- AI05-0033: A pragma cannot appear within a generic body, because
1514 -- instance can be in a nested scope. The check that protected type
1515 -- is itself a library-level declaration is done elsewhere.
1517 -- Note: we omit this check in Codepeer mode to properly handle code
1518 -- prior to AI-0033 (pragmas don't matter to codepeer in any case).
1520 if Inside_A_Generic then
1521 if Ekind (Scope (Current_Scope)) = E_Generic_Package
1522 and then In_Package_Body (Scope (Current_Scope))
1523 and then not CodePeer_Mode
1525 Error_Pragma ("pragma% cannot be used inside a generic");
1528 end Check_Interrupt_Or_Attach_Handler;
1530 -------------------------------------------
1531 -- Check_Is_In_Decl_Part_Or_Package_Spec --
1532 -------------------------------------------
1534 procedure Check_Is_In_Decl_Part_Or_Package_Spec is
1543 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
1546 elsif Nkind_In (P, N_Package_Specification,
1551 -- Note: the following tests seem a little peculiar, because
1552 -- they test for bodies, but if we were in the statement part
1553 -- of the body, we would already have hit the handled statement
1554 -- sequence, so the only way we get here is by being in the
1555 -- declarative part of the body.
1557 elsif Nkind_In (P, N_Subprogram_Body,
1568 Error_Pragma ("pragma% is not in declarative part or package spec");
1569 end Check_Is_In_Decl_Part_Or_Package_Spec;
1571 -------------------------
1572 -- Check_No_Identifier --
1573 -------------------------
1575 procedure Check_No_Identifier (Arg : Node_Id) is
1577 if Nkind (Arg) = N_Pragma_Argument_Association
1578 and then Chars (Arg) /= No_Name
1580 Error_Pragma_Arg_Ident
1581 ("pragma% does not permit identifier& here", Arg);
1583 end Check_No_Identifier;
1585 --------------------------
1586 -- Check_No_Identifiers --
1587 --------------------------
1589 procedure Check_No_Identifiers is
1592 if Arg_Count > 0 then
1594 while Present (Arg_Node) loop
1595 Check_No_Identifier (Arg_Node);
1599 end Check_No_Identifiers;
1601 ------------------------
1602 -- Check_No_Link_Name --
1603 ------------------------
1605 procedure Check_No_Link_Name is
1608 and then Chars (Arg3) = Name_Link_Name
1613 if Present (Arg4) then
1615 ("Link_Name argument not allowed for Import Intrinsic", Arg4);
1617 end Check_No_Link_Name;
1619 -------------------------------
1620 -- Check_Optional_Identifier --
1621 -------------------------------
1623 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
1626 and then Nkind (Arg) = N_Pragma_Argument_Association
1627 and then Chars (Arg) /= No_Name
1629 if Chars (Arg) /= Id then
1630 Error_Msg_Name_1 := Pname;
1631 Error_Msg_Name_2 := Id;
1632 Error_Msg_N ("pragma% argument expects identifier%", Arg);
1636 end Check_Optional_Identifier;
1638 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
1640 Name_Buffer (1 .. Id'Length) := Id;
1641 Name_Len := Id'Length;
1642 Check_Optional_Identifier (Arg, Name_Find);
1643 end Check_Optional_Identifier;
1645 --------------------------------------
1646 -- Check_Precondition_Postcondition --
1647 --------------------------------------
1649 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
1653 procedure Chain_PPC (PO : Node_Id);
1654 -- If PO is an entry or a [generic] subprogram declaration node, then
1655 -- the precondition/postcondition applies to this subprogram and the
1656 -- processing for the pragma is completed. Otherwise the pragma is
1663 procedure Chain_PPC (PO : Node_Id) is
1668 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
1669 if not From_Aspect_Specification (N) then
1671 ("pragma% cannot be applied to abstract subprogram");
1673 elsif Class_Present (N) then
1678 ("aspect % requires ''Class for abstract subprogram");
1681 -- AI05-0230: The same restriction applies to null procedures. For
1682 -- compatibility with earlier uses of the Ada pragma, apply this
1683 -- rule only to aspect specifications.
1685 -- The above discrpency needs documentation. Robert is dubious
1686 -- about whether it is a good idea ???
1688 elsif Nkind (PO) = N_Subprogram_Declaration
1689 and then Nkind (Specification (PO)) = N_Procedure_Specification
1690 and then Null_Present (Specification (PO))
1691 and then From_Aspect_Specification (N)
1692 and then not Class_Present (N)
1695 ("aspect % requires ''Class for null procedure");
1697 elsif not Nkind_In (PO, N_Subprogram_Declaration,
1698 N_Generic_Subprogram_Declaration,
1699 N_Entry_Declaration)
1704 -- Here if we have [generic] subprogram or entry declaration
1706 if Nkind (PO) = N_Entry_Declaration then
1707 S := Defining_Entity (PO);
1709 S := Defining_Unit_Name (Specification (PO));
1712 -- Make sure we do not have the case of a precondition pragma when
1713 -- the Pre'Class aspect is present.
1715 -- We do this by looking at pragmas already chained to the entity
1716 -- since the aspect derived pragma will be put on this list first.
1718 if Pragma_Name (N) = Name_Precondition then
1719 if not From_Aspect_Specification (N) then
1720 P := Spec_PPC_List (Contract (S));
1721 while Present (P) loop
1722 if Pragma_Name (P) = Name_Precondition
1723 and then From_Aspect_Specification (P)
1724 and then Class_Present (P)
1726 Error_Msg_Sloc := Sloc (P);
1728 ("pragma% not allowed, `Pre''Class` aspect given#");
1731 P := Next_Pragma (P);
1736 -- Similarly check for Pre with inherited Pre'Class. Note that
1737 -- we cover the aspect case as well here.
1739 if Pragma_Name (N) = Name_Precondition
1740 and then not Class_Present (N)
1743 Inherited : constant Subprogram_List :=
1744 Inherited_Subprograms (S);
1748 for J in Inherited'Range loop
1749 P := Spec_PPC_List (Contract (Inherited (J)));
1750 while Present (P) loop
1751 if Pragma_Name (P) = Name_Precondition
1752 and then Class_Present (P)
1754 Error_Msg_Sloc := Sloc (P);
1756 ("pragma% not allowed, `Pre''Class` "
1757 & "aspect inherited from#");
1760 P := Next_Pragma (P);
1766 -- Note: we do not analyze the pragma at this point. Instead we
1767 -- delay this analysis until the end of the declarative part in
1768 -- which the pragma appears. This implements the required delay
1769 -- in this analysis, allowing forward references. The analysis
1770 -- happens at the end of Analyze_Declarations.
1772 -- Chain spec PPC pragma to list for subprogram
1774 Set_Next_Pragma (N, Spec_PPC_List (Contract (S)));
1775 Set_Spec_PPC_List (Contract (S), N);
1777 -- Return indicating spec case
1783 -- Start of processing for Check_Precondition_Postcondition
1786 if not Is_List_Member (N) then
1790 -- Preanalyze message argument if present. Visibility in this
1791 -- argument is established at the point of pragma occurrence.
1793 if Arg_Count = 2 then
1794 Check_Optional_Identifier (Arg2, Name_Message);
1795 Preanalyze_Spec_Expression
1796 (Get_Pragma_Arg (Arg2), Standard_String);
1799 -- Record if pragma is enabled
1801 if Check_Enabled (Pname) then
1802 Set_SCO_Pragma_Enabled (Loc);
1805 -- If we are within an inlined body, the legality of the pragma
1806 -- has been checked already.
1808 if In_Inlined_Body then
1813 -- Search prior declarations
1816 while Present (Prev (P)) loop
1819 -- If the previous node is a generic subprogram, do not go to to
1820 -- the original node, which is the unanalyzed tree: we need to
1821 -- attach the pre/postconditions to the analyzed version at this
1822 -- point. They get propagated to the original tree when analyzing
1823 -- the corresponding body.
1825 if Nkind (P) not in N_Generic_Declaration then
1826 PO := Original_Node (P);
1831 -- Skip past prior pragma
1833 if Nkind (PO) = N_Pragma then
1836 -- Skip stuff not coming from source
1838 elsif not Comes_From_Source (PO) then
1840 -- The condition may apply to a subprogram instantiation
1842 if Nkind (PO) = N_Subprogram_Declaration
1843 and then Present (Generic_Parent (Specification (PO)))
1848 -- For all other cases of non source code, do nothing
1854 -- Only remaining possibility is subprogram declaration
1862 -- If we fall through loop, pragma is at start of list, so see if it
1863 -- is at the start of declarations of a subprogram body.
1865 if Nkind (Parent (N)) = N_Subprogram_Body
1866 and then List_Containing (N) = Declarations (Parent (N))
1868 if Operating_Mode /= Generate_Code
1869 or else Inside_A_Generic
1871 -- Analyze pragma expression for correctness and for ASIS use
1873 Preanalyze_Spec_Expression
1874 (Get_Pragma_Arg (Arg1), Standard_Boolean);
1880 -- See if it is in the pragmas after a library level subprogram
1882 elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
1883 Chain_PPC (Unit (Parent (Parent (N))));
1887 -- If we fall through, pragma was misplaced
1890 end Check_Precondition_Postcondition;
1892 -----------------------------
1893 -- Check_Static_Constraint --
1894 -----------------------------
1896 -- Note: for convenience in writing this procedure, in addition to
1897 -- the officially (i.e. by spec) allowed argument which is always a
1898 -- constraint, it also allows ranges and discriminant associations.
1899 -- Above is not clear ???
1901 procedure Check_Static_Constraint (Constr : Node_Id) is
1903 procedure Require_Static (E : Node_Id);
1904 -- Require given expression to be static expression
1906 --------------------
1907 -- Require_Static --
1908 --------------------
1910 procedure Require_Static (E : Node_Id) is
1912 if not Is_OK_Static_Expression (E) then
1913 Flag_Non_Static_Expr
1914 ("non-static constraint not allowed in Unchecked_Union!", E);
1919 -- Start of processing for Check_Static_Constraint
1922 case Nkind (Constr) is
1923 when N_Discriminant_Association =>
1924 Require_Static (Expression (Constr));
1927 Require_Static (Low_Bound (Constr));
1928 Require_Static (High_Bound (Constr));
1930 when N_Attribute_Reference =>
1931 Require_Static (Type_Low_Bound (Etype (Prefix (Constr))));
1932 Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
1934 when N_Range_Constraint =>
1935 Check_Static_Constraint (Range_Expression (Constr));
1937 when N_Index_Or_Discriminant_Constraint =>
1941 IDC := First (Constraints (Constr));
1942 while Present (IDC) loop
1943 Check_Static_Constraint (IDC);
1951 end Check_Static_Constraint;
1953 ---------------------
1954 -- Check_Test_Case --
1955 ---------------------
1957 procedure Check_Test_Case is
1961 procedure Chain_TC (PO : Node_Id);
1962 -- If PO is an entry or a [generic] subprogram declaration node, then
1963 -- the test-case applies to this subprogram and the processing for
1964 -- the pragma is completed. Otherwise the pragma is misplaced.
1970 procedure Chain_TC (PO : Node_Id) is
1974 if Nkind (PO) = N_Abstract_Subprogram_Declaration then
1975 if From_Aspect_Specification (N) then
1977 ("aspect% cannot be applied to abstract subprogram");
1980 ("pragma% cannot be applied to abstract subprogram");
1983 elsif not Nkind_In (PO, N_Subprogram_Declaration,
1984 N_Generic_Subprogram_Declaration,
1985 N_Entry_Declaration)
1990 -- Here if we have [generic] subprogram or entry declaration
1992 if Nkind (PO) = N_Entry_Declaration then
1993 S := Defining_Entity (PO);
1995 S := Defining_Unit_Name (Specification (PO));
1998 -- Note: we do not analyze the pragma at this point. Instead we
1999 -- delay this analysis until the end of the declarative part in
2000 -- which the pragma appears. This implements the required delay
2001 -- in this analysis, allowing forward references. The analysis
2002 -- happens at the end of Analyze_Declarations.
2004 -- There should not be another test case with the same name
2005 -- associated to this subprogram.
2008 Name : constant String_Id := Get_Name_From_Test_Case_Pragma (N);
2012 TC := Spec_TC_List (Contract (S));
2013 while Present (TC) loop
2016 (Name, Get_Name_From_Test_Case_Pragma (TC))
2018 Error_Msg_Sloc := Sloc (TC);
2020 if From_Aspect_Specification (N) then
2021 Error_Pragma ("name for aspect% is already used#");
2023 Error_Pragma ("name for pragma% is already used#");
2027 TC := Next_Pragma (TC);
2031 -- Chain spec TC pragma to list for subprogram
2033 Set_Next_Pragma (N, Spec_TC_List (Contract (S)));
2034 Set_Spec_TC_List (Contract (S), N);
2037 -- Start of processing for Check_Test_Case
2040 if not Is_List_Member (N) then
2044 -- Search prior declarations
2047 while Present (Prev (P)) loop
2050 -- If the previous node is a generic subprogram, do not go to to
2051 -- the original node, which is the unanalyzed tree: we need to
2052 -- attach the test-case to the analyzed version at this point.
2053 -- They get propagated to the original tree when analyzing the
2054 -- corresponding body.
2056 if Nkind (P) not in N_Generic_Declaration then
2057 PO := Original_Node (P);
2062 -- Skip past prior pragma
2064 if Nkind (PO) = N_Pragma then
2067 -- Skip stuff not coming from source
2069 elsif not Comes_From_Source (PO) then
2072 -- Only remaining possibility is subprogram declaration
2080 -- If we fall through loop, pragma is at start of list, so see if it
2081 -- is in the pragmas after a library level subprogram.
2083 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
2084 Chain_TC (Unit (Parent (Parent (N))));
2088 -- If we fall through, pragma was misplaced
2091 end Check_Test_Case;
2093 --------------------------------------
2094 -- Check_Valid_Configuration_Pragma --
2095 --------------------------------------
2097 -- A configuration pragma must appear in the context clause of a
2098 -- compilation unit, and only other pragmas may precede it. Note that
2099 -- the test also allows use in a configuration pragma file.
2101 procedure Check_Valid_Configuration_Pragma is
2103 if not Is_Configuration_Pragma then
2104 Error_Pragma ("incorrect placement for configuration pragma%");
2106 end Check_Valid_Configuration_Pragma;
2108 -------------------------------------
2109 -- Check_Valid_Library_Unit_Pragma --
2110 -------------------------------------
2112 procedure Check_Valid_Library_Unit_Pragma is
2114 Parent_Node : Node_Id;
2115 Unit_Name : Entity_Id;
2116 Unit_Kind : Node_Kind;
2117 Unit_Node : Node_Id;
2118 Sindex : Source_File_Index;
2121 if not Is_List_Member (N) then
2125 Plist := List_Containing (N);
2126 Parent_Node := Parent (Plist);
2128 if Parent_Node = Empty then
2131 -- Case of pragma appearing after a compilation unit. In this case
2132 -- it must have an argument with the corresponding name and must
2133 -- be part of the following pragmas of its parent.
2135 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
2136 if Plist /= Pragmas_After (Parent_Node) then
2139 elsif Arg_Count = 0 then
2141 ("argument required if outside compilation unit");
2144 Check_No_Identifiers;
2145 Check_Arg_Count (1);
2146 Unit_Node := Unit (Parent (Parent_Node));
2147 Unit_Kind := Nkind (Unit_Node);
2149 Analyze (Get_Pragma_Arg (Arg1));
2151 if Unit_Kind = N_Generic_Subprogram_Declaration
2152 or else Unit_Kind = N_Subprogram_Declaration
2154 Unit_Name := Defining_Entity (Unit_Node);
2156 elsif Unit_Kind in N_Generic_Instantiation then
2157 Unit_Name := Defining_Entity (Unit_Node);
2160 Unit_Name := Cunit_Entity (Current_Sem_Unit);
2163 if Chars (Unit_Name) /=
2164 Chars (Entity (Get_Pragma_Arg (Arg1)))
2167 ("pragma% argument is not current unit name", Arg1);
2170 if Ekind (Unit_Name) = E_Package
2171 and then Present (Renamed_Entity (Unit_Name))
2173 Error_Pragma ("pragma% not allowed for renamed package");
2177 -- Pragma appears other than after a compilation unit
2180 -- Here we check for the generic instantiation case and also
2181 -- for the case of processing a generic formal package. We
2182 -- detect these cases by noting that the Sloc on the node
2183 -- does not belong to the current compilation unit.
2185 Sindex := Source_Index (Current_Sem_Unit);
2187 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
2188 Rewrite (N, Make_Null_Statement (Loc));
2191 -- If before first declaration, the pragma applies to the
2192 -- enclosing unit, and the name if present must be this name.
2194 elsif Is_Before_First_Decl (N, Plist) then
2195 Unit_Node := Unit_Declaration_Node (Current_Scope);
2196 Unit_Kind := Nkind (Unit_Node);
2198 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
2201 elsif Unit_Kind = N_Subprogram_Body
2202 and then not Acts_As_Spec (Unit_Node)
2206 elsif Nkind (Parent_Node) = N_Package_Body then
2209 elsif Nkind (Parent_Node) = N_Package_Specification
2210 and then Plist = Private_Declarations (Parent_Node)
2214 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
2215 or else Nkind (Parent_Node) =
2216 N_Generic_Subprogram_Declaration)
2217 and then Plist = Generic_Formal_Declarations (Parent_Node)
2221 elsif Arg_Count > 0 then
2222 Analyze (Get_Pragma_Arg (Arg1));
2224 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
2226 ("name in pragma% must be enclosing unit", Arg1);
2229 -- It is legal to have no argument in this context
2235 -- Error if not before first declaration. This is because a
2236 -- library unit pragma argument must be the name of a library
2237 -- unit (RM 10.1.5(7)), but the only names permitted in this
2238 -- context are (RM 10.1.5(6)) names of subprogram declarations,
2239 -- generic subprogram declarations or generic instantiations.
2243 ("pragma% misplaced, must be before first declaration");
2247 end Check_Valid_Library_Unit_Pragma;
2253 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
2254 Clist : constant Node_Id := Component_List (Variant);
2258 if not Is_Non_Empty_List (Component_Items (Clist)) then
2260 ("Unchecked_Union may not have empty component list",
2265 Comp := First (Component_Items (Clist));
2266 while Present (Comp) loop
2267 Check_Component (Comp, UU_Typ, In_Variant_Part => True);
2276 procedure Error_Pragma (Msg : String) is
2277 MsgF : String := Msg;
2279 Error_Msg_Name_1 := Pname;
2281 Error_Msg_N (MsgF, N);
2285 ----------------------
2286 -- Error_Pragma_Arg --
2287 ----------------------
2289 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
2290 MsgF : String := Msg;
2292 Error_Msg_Name_1 := Pname;
2294 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
2296 end Error_Pragma_Arg;
2298 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
2299 MsgF : String := Msg1;
2301 Error_Msg_Name_1 := Pname;
2303 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
2304 Error_Pragma_Arg (Msg2, Arg);
2305 end Error_Pragma_Arg;
2307 ----------------------------
2308 -- Error_Pragma_Arg_Ident --
2309 ----------------------------
2311 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
2312 MsgF : String := Msg;
2314 Error_Msg_Name_1 := Pname;
2316 Error_Msg_N (MsgF, Arg);
2318 end Error_Pragma_Arg_Ident;
2320 ----------------------
2321 -- Error_Pragma_Ref --
2322 ----------------------
2324 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
2325 MsgF : String := Msg;
2327 Error_Msg_Name_1 := Pname;
2329 Error_Msg_Sloc := Sloc (Ref);
2330 Error_Msg_NE (MsgF, N, Ref);
2332 end Error_Pragma_Ref;
2334 ------------------------
2335 -- Find_Lib_Unit_Name --
2336 ------------------------
2338 function Find_Lib_Unit_Name return Entity_Id is
2340 -- Return inner compilation unit entity, for case of nested
2341 -- categorization pragmas. This happens in generic unit.
2343 if Nkind (Parent (N)) = N_Package_Specification
2344 and then Defining_Entity (Parent (N)) /= Current_Scope
2346 return Defining_Entity (Parent (N));
2348 return Current_Scope;
2350 end Find_Lib_Unit_Name;
2352 ----------------------------
2353 -- Find_Program_Unit_Name --
2354 ----------------------------
2356 procedure Find_Program_Unit_Name (Id : Node_Id) is
2357 Unit_Name : Entity_Id;
2358 Unit_Kind : Node_Kind;
2359 P : constant Node_Id := Parent (N);
2362 if Nkind (P) = N_Compilation_Unit then
2363 Unit_Kind := Nkind (Unit (P));
2365 if Unit_Kind = N_Subprogram_Declaration
2366 or else Unit_Kind = N_Package_Declaration
2367 or else Unit_Kind in N_Generic_Declaration
2369 Unit_Name := Defining_Entity (Unit (P));
2371 if Chars (Id) = Chars (Unit_Name) then
2372 Set_Entity (Id, Unit_Name);
2373 Set_Etype (Id, Etype (Unit_Name));
2375 Set_Etype (Id, Any_Type);
2377 ("cannot find program unit referenced by pragma%");
2381 Set_Etype (Id, Any_Type);
2382 Error_Pragma ("pragma% inapplicable to this unit");
2388 end Find_Program_Unit_Name;
2390 -----------------------------------------
2391 -- Find_Unique_Parameterless_Procedure --
2392 -----------------------------------------
2394 function Find_Unique_Parameterless_Procedure
2396 Arg : Node_Id) return Entity_Id
2398 Proc : Entity_Id := Empty;
2401 -- The body of this procedure needs some comments ???
2403 if not Is_Entity_Name (Name) then
2405 ("argument of pragma% must be entity name", Arg);
2407 elsif not Is_Overloaded (Name) then
2408 Proc := Entity (Name);
2410 if Ekind (Proc) /= E_Procedure
2411 or else Present (First_Formal (Proc))
2414 ("argument of pragma% must be parameterless procedure", Arg);
2419 Found : Boolean := False;
2421 Index : Interp_Index;
2424 Get_First_Interp (Name, Index, It);
2425 while Present (It.Nam) loop
2428 if Ekind (Proc) = E_Procedure
2429 and then No (First_Formal (Proc))
2433 Set_Entity (Name, Proc);
2434 Set_Is_Overloaded (Name, False);
2437 ("ambiguous handler name for pragma% ", Arg);
2441 Get_Next_Interp (Index, It);
2446 ("argument of pragma% must be parameterless procedure",
2449 Proc := Entity (Name);
2455 end Find_Unique_Parameterless_Procedure;
2461 procedure Fix_Error (Msg : in out String) is
2463 if From_Aspect_Specification (N) then
2464 for J in Msg'First .. Msg'Last - 5 loop
2465 if Msg (J .. J + 5) = "pragma" then
2466 Msg (J .. J + 5) := "aspect";
2470 if Error_Msg_Name_1 = Name_Precondition then
2471 Error_Msg_Name_1 := Name_Pre;
2472 elsif Error_Msg_Name_1 = Name_Postcondition then
2473 Error_Msg_Name_1 := Name_Post;
2478 -------------------------
2479 -- Gather_Associations --
2480 -------------------------
2482 procedure Gather_Associations
2484 Args : out Args_List)
2489 -- Initialize all parameters to Empty
2491 for J in Args'Range loop
2495 -- That's all we have to do if there are no argument associations
2497 if No (Pragma_Argument_Associations (N)) then
2501 -- Otherwise first deal with any positional parameters present
2503 Arg := First (Pragma_Argument_Associations (N));
2504 for Index in Args'Range loop
2505 exit when No (Arg) or else Chars (Arg) /= No_Name;
2506 Args (Index) := Get_Pragma_Arg (Arg);
2510 -- Positional parameters all processed, if any left, then we
2511 -- have too many positional parameters.
2513 if Present (Arg) and then Chars (Arg) = No_Name then
2515 ("too many positional associations for pragma%", Arg);
2518 -- Process named parameters if any are present
2520 while Present (Arg) loop
2521 if Chars (Arg) = No_Name then
2523 ("positional association cannot follow named association",
2527 for Index in Names'Range loop
2528 if Names (Index) = Chars (Arg) then
2529 if Present (Args (Index)) then
2531 ("duplicate argument association for pragma%", Arg);
2533 Args (Index) := Get_Pragma_Arg (Arg);
2538 if Index = Names'Last then
2539 Error_Msg_Name_1 := Pname;
2540 Error_Msg_N ("pragma% does not allow & argument", Arg);
2542 -- Check for possible misspelling
2544 for Index1 in Names'Range loop
2545 if Is_Bad_Spelling_Of
2546 (Chars (Arg), Names (Index1))
2548 Error_Msg_Name_1 := Names (Index1);
2549 Error_Msg_N -- CODEFIX
2550 ("\possible misspelling of%", Arg);
2562 end Gather_Associations;
2568 procedure GNAT_Pragma is
2570 Check_Restriction (No_Implementation_Pragmas, N);
2573 --------------------------
2574 -- Is_Before_First_Decl --
2575 --------------------------
2577 function Is_Before_First_Decl
2578 (Pragma_Node : Node_Id;
2579 Decls : List_Id) return Boolean
2581 Item : Node_Id := First (Decls);
2584 -- Only other pragmas can come before this pragma
2587 if No (Item) or else Nkind (Item) /= N_Pragma then
2590 elsif Item = Pragma_Node then
2596 end Is_Before_First_Decl;
2598 -----------------------------
2599 -- Is_Configuration_Pragma --
2600 -----------------------------
2602 -- A configuration pragma must appear in the context clause of a
2603 -- compilation unit, and only other pragmas may precede it. Note that
2604 -- the test below also permits use in a configuration pragma file.
2606 function Is_Configuration_Pragma return Boolean is
2607 Lis : constant List_Id := List_Containing (N);
2608 Par : constant Node_Id := Parent (N);
2612 -- If no parent, then we are in the configuration pragma file,
2613 -- so the placement is definitely appropriate.
2618 -- Otherwise we must be in the context clause of a compilation unit
2619 -- and the only thing allowed before us in the context list is more
2620 -- configuration pragmas.
2622 elsif Nkind (Par) = N_Compilation_Unit
2623 and then Context_Items (Par) = Lis
2630 elsif Nkind (Prg) /= N_Pragma then
2640 end Is_Configuration_Pragma;
2642 --------------------------
2643 -- Is_In_Context_Clause --
2644 --------------------------
2646 function Is_In_Context_Clause return Boolean is
2648 Parent_Node : Node_Id;
2651 if not Is_List_Member (N) then
2655 Plist := List_Containing (N);
2656 Parent_Node := Parent (Plist);
2658 if Parent_Node = Empty
2659 or else Nkind (Parent_Node) /= N_Compilation_Unit
2660 or else Context_Items (Parent_Node) /= Plist
2667 end Is_In_Context_Clause;
2669 ---------------------------------
2670 -- Is_Static_String_Expression --
2671 ---------------------------------
2673 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
2674 Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2677 Analyze_And_Resolve (Argx);
2678 return Is_OK_Static_Expression (Argx)
2679 and then Nkind (Argx) = N_String_Literal;
2680 end Is_Static_String_Expression;
2682 ----------------------
2683 -- Pragma_Misplaced --
2684 ----------------------
2686 procedure Pragma_Misplaced is
2688 Error_Pragma ("incorrect placement of pragma%");
2689 end Pragma_Misplaced;
2691 ------------------------------------
2692 -- Process Atomic_Shared_Volatile --
2693 ------------------------------------
2695 procedure Process_Atomic_Shared_Volatile is
2702 procedure Set_Atomic (E : Entity_Id);
2703 -- Set given type as atomic, and if no explicit alignment was given,
2704 -- set alignment to unknown, since back end knows what the alignment
2705 -- requirements are for atomic arrays. Note: this step is necessary
2706 -- for derived types.
2712 procedure Set_Atomic (E : Entity_Id) is
2716 if not Has_Alignment_Clause (E) then
2717 Set_Alignment (E, Uint_0);
2721 -- Start of processing for Process_Atomic_Shared_Volatile
2724 Check_Ada_83_Warning;
2725 Check_No_Identifiers;
2726 Check_Arg_Count (1);
2727 Check_Arg_Is_Local_Name (Arg1);
2728 E_Id := Get_Pragma_Arg (Arg1);
2730 if Etype (E_Id) = Any_Type then
2735 D := Declaration_Node (E);
2738 -- Check duplicate before we chain ourselves!
2740 Check_Duplicate_Pragma (E);
2742 -- Now check appropriateness of the entity
2745 if Rep_Item_Too_Early (E, N)
2747 Rep_Item_Too_Late (E, N)
2751 Check_First_Subtype (Arg1);
2754 if Prag_Id /= Pragma_Volatile then
2756 Set_Atomic (Underlying_Type (E));
2757 Set_Atomic (Base_Type (E));
2760 -- Attribute belongs on the base type. If the view of the type is
2761 -- currently private, it also belongs on the underlying type.
2763 Set_Is_Volatile (Base_Type (E));
2764 Set_Is_Volatile (Underlying_Type (E));
2766 Set_Treat_As_Volatile (E);
2767 Set_Treat_As_Volatile (Underlying_Type (E));
2769 elsif K = N_Object_Declaration
2770 or else (K = N_Component_Declaration
2771 and then Original_Record_Component (E) = E)
2773 if Rep_Item_Too_Late (E, N) then
2777 if Prag_Id /= Pragma_Volatile then
2780 -- If the object declaration has an explicit initialization, a
2781 -- temporary may have to be created to hold the expression, to
2782 -- ensure that access to the object remain atomic.
2784 if Nkind (Parent (E)) = N_Object_Declaration
2785 and then Present (Expression (Parent (E)))
2787 Set_Has_Delayed_Freeze (E);
2790 -- An interesting improvement here. If an object of type X is
2791 -- declared atomic, and the type X is not atomic, that's a
2792 -- pity, since it may not have appropriate alignment etc. We
2793 -- can rescue this in the special case where the object and
2794 -- type are in the same unit by just setting the type as
2795 -- atomic, so that the back end will process it as atomic.
2797 Utyp := Underlying_Type (Etype (E));
2800 and then Sloc (E) > No_Location
2801 and then Sloc (Utyp) > No_Location
2803 Get_Source_File_Index (Sloc (E)) =
2804 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
2806 Set_Is_Atomic (Underlying_Type (Etype (E)));
2810 Set_Is_Volatile (E);
2811 Set_Treat_As_Volatile (E);
2815 ("inappropriate entity for pragma%", Arg1);
2817 end Process_Atomic_Shared_Volatile;
2819 -------------------------------------------
2820 -- Process_Compile_Time_Warning_Or_Error --
2821 -------------------------------------------
2823 procedure Process_Compile_Time_Warning_Or_Error is
2824 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
2827 Check_Arg_Count (2);
2828 Check_No_Identifiers;
2829 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
2830 Analyze_And_Resolve (Arg1x, Standard_Boolean);
2832 if Compile_Time_Known_Value (Arg1x) then
2833 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
2835 Str : constant String_Id :=
2836 Strval (Get_Pragma_Arg (Arg2));
2837 Len : constant Int := String_Length (Str);
2842 Cent : constant Entity_Id :=
2843 Cunit_Entity (Current_Sem_Unit);
2845 Force : constant Boolean :=
2846 Prag_Id = Pragma_Compile_Time_Warning
2848 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
2849 and then (Ekind (Cent) /= E_Package
2850 or else not In_Private_Part (Cent));
2851 -- Set True if this is the warning case, and we are in the
2852 -- visible part of a package spec, or in a subprogram spec,
2853 -- in which case we want to force the client to see the
2854 -- warning, even though it is not in the main unit.
2857 -- Loop through segments of message separated by line feeds.
2858 -- We output these segments as separate messages with
2859 -- continuation marks for all but the first.
2864 Error_Msg_Strlen := 0;
2866 -- Loop to copy characters from argument to error message
2870 exit when Ptr > Len;
2871 CC := Get_String_Char (Str, Ptr);
2874 -- Ignore wide chars ??? else store character
2876 if In_Character_Range (CC) then
2877 C := Get_Character (CC);
2878 exit when C = ASCII.LF;
2879 Error_Msg_Strlen := Error_Msg_Strlen + 1;
2880 Error_Msg_String (Error_Msg_Strlen) := C;
2884 -- Here with one line ready to go
2886 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
2888 -- If this is a warning in a spec, then we want clients
2889 -- to see the warning, so mark the message with the
2890 -- special sequence !! to force the warning. In the case
2891 -- of a package spec, we do not force this if we are in
2892 -- the private part of the spec.
2895 if Cont = False then
2896 Error_Msg_N ("<~!!", Arg1);
2899 Error_Msg_N ("\<~!!", Arg1);
2902 -- Error, rather than warning, or in a body, so we do not
2903 -- need to force visibility for client (error will be
2904 -- output in any case, and this is the situation in which
2905 -- we do not want a client to get a warning, since the
2906 -- warning is in the body or the spec private part).
2909 if Cont = False then
2910 Error_Msg_N ("<~", Arg1);
2913 Error_Msg_N ("\<~", Arg1);
2917 exit when Ptr > Len;
2922 end Process_Compile_Time_Warning_Or_Error;
2924 ------------------------
2925 -- Process_Convention --
2926 ------------------------
2928 procedure Process_Convention
2929 (C : out Convention_Id;
2930 Ent : out Entity_Id)
2936 Comp_Unit : Unit_Number_Type;
2938 procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
2939 -- Called if we have more than one Export/Import/Convention pragma.
2940 -- This is generally illegal, but we have a special case of allowing
2941 -- Import and Interface to coexist if they specify the convention in
2942 -- a consistent manner. We are allowed to do this, since Interface is
2943 -- an implementation defined pragma, and we choose to do it since we
2944 -- know Rational allows this combination. S is the entity id of the
2945 -- subprogram in question. This procedure also sets the special flag
2946 -- Import_Interface_Present in both pragmas in the case where we do
2947 -- have matching Import and Interface pragmas.
2949 procedure Set_Convention_From_Pragma (E : Entity_Id);
2950 -- Set convention in entity E, and also flag that the entity has a
2951 -- convention pragma. If entity is for a private or incomplete type,
2952 -- also set convention and flag on underlying type. This procedure
2953 -- also deals with the special case of C_Pass_By_Copy convention.
2955 -------------------------------
2956 -- Diagnose_Multiple_Pragmas --
2957 -------------------------------
2959 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
2960 Pdec : constant Node_Id := Declaration_Node (S);
2964 function Same_Convention (Decl : Node_Id) return Boolean;
2965 -- Decl is a pragma node. This function returns True if this
2966 -- pragma has a first argument that is an identifier with a
2967 -- Chars field corresponding to the Convention_Id C.
2969 function Same_Name (Decl : Node_Id) return Boolean;
2970 -- Decl is a pragma node. This function returns True if this
2971 -- pragma has a second argument that is an identifier with a
2972 -- Chars field that matches the Chars of the current subprogram.
2974 ---------------------
2975 -- Same_Convention --
2976 ---------------------
2978 function Same_Convention (Decl : Node_Id) return Boolean is
2979 Arg1 : constant Node_Id :=
2980 First (Pragma_Argument_Associations (Decl));
2983 if Present (Arg1) then
2985 Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
2987 if Nkind (Arg) = N_Identifier
2988 and then Is_Convention_Name (Chars (Arg))
2989 and then Get_Convention_Id (Chars (Arg)) = C
2997 end Same_Convention;
3003 function Same_Name (Decl : Node_Id) return Boolean is
3004 Arg1 : constant Node_Id :=
3005 First (Pragma_Argument_Associations (Decl));
3013 Arg2 := Next (Arg1);
3020 Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
3022 if Nkind (Arg) = N_Identifier
3023 and then Chars (Arg) = Chars (S)
3032 -- Start of processing for Diagnose_Multiple_Pragmas
3037 -- Definitely give message if we have Convention/Export here
3039 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
3042 -- If we have an Import or Export, scan back from pragma to
3043 -- find any previous pragma applying to the same procedure.
3044 -- The scan will be terminated by the start of the list, or
3045 -- hitting the subprogram declaration. This won't allow one
3046 -- pragma to appear in the public part and one in the private
3047 -- part, but that seems very unlikely in practice.
3051 while Present (Decl) and then Decl /= Pdec loop
3053 -- Look for pragma with same name as us
3055 if Nkind (Decl) = N_Pragma
3056 and then Same_Name (Decl)
3058 -- Give error if same as our pragma or Export/Convention
3060 if Pragma_Name (Decl) = Name_Export
3062 Pragma_Name (Decl) = Name_Convention
3064 Pragma_Name (Decl) = Pragma_Name (N)
3068 -- Case of Import/Interface or the other way round
3070 elsif Pragma_Name (Decl) = Name_Interface
3072 Pragma_Name (Decl) = Name_Import
3074 -- Here we know that we have Import and Interface. It
3075 -- doesn't matter which way round they are. See if
3076 -- they specify the same convention. If so, all OK,
3077 -- and set special flags to stop other messages
3079 if Same_Convention (Decl) then
3080 Set_Import_Interface_Present (N);
3081 Set_Import_Interface_Present (Decl);
3084 -- If different conventions, special message
3087 Error_Msg_Sloc := Sloc (Decl);
3089 ("convention differs from that given#", Arg1);
3099 -- Give message if needed if we fall through those tests
3103 ("at most one Convention/Export/Import pragma is allowed",
3106 end Diagnose_Multiple_Pragmas;
3108 --------------------------------
3109 -- Set_Convention_From_Pragma --
3110 --------------------------------
3112 procedure Set_Convention_From_Pragma (E : Entity_Id) is
3114 -- Ada 2005 (AI-430): Check invalid attempt to change convention
3115 -- for an overridden dispatching operation. Technically this is
3116 -- an amendment and should only be done in Ada 2005 mode. However,
3117 -- this is clearly a mistake, since the problem that is addressed
3118 -- by this AI is that there is a clear gap in the RM!
3120 if Is_Dispatching_Operation (E)
3121 and then Present (Overridden_Operation (E))
3122 and then C /= Convention (Overridden_Operation (E))
3125 ("cannot change convention for " &
3126 "overridden dispatching operation",
3130 -- Set the convention
3132 Set_Convention (E, C);
3133 Set_Has_Convention_Pragma (E);
3135 if Is_Incomplete_Or_Private_Type (E)
3136 and then Present (Underlying_Type (E))
3138 Set_Convention (Underlying_Type (E), C);
3139 Set_Has_Convention_Pragma (Underlying_Type (E), True);
3142 -- A class-wide type should inherit the convention of the specific
3143 -- root type (although this isn't specified clearly by the RM).
3145 if Is_Type (E) and then Present (Class_Wide_Type (E)) then
3146 Set_Convention (Class_Wide_Type (E), C);
3149 -- If the entity is a record type, then check for special case of
3150 -- C_Pass_By_Copy, which is treated the same as C except that the
3151 -- special record flag is set. This convention is only permitted
3152 -- on record types (see AI95-00131).
3154 if Cname = Name_C_Pass_By_Copy then
3155 if Is_Record_Type (E) then
3156 Set_C_Pass_By_Copy (Base_Type (E));
3157 elsif Is_Incomplete_Or_Private_Type (E)
3158 and then Is_Record_Type (Underlying_Type (E))
3160 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
3163 ("C_Pass_By_Copy convention allowed only for record type",
3168 -- If the entity is a derived boolean type, check for the special
3169 -- case of convention C, C++, or Fortran, where we consider any
3170 -- nonzero value to represent true.
3172 if Is_Discrete_Type (E)
3173 and then Root_Type (Etype (E)) = Standard_Boolean
3179 C = Convention_Fortran)
3181 Set_Nonzero_Is_True (Base_Type (E));
3183 end Set_Convention_From_Pragma;
3185 -- Start of processing for Process_Convention
3188 Check_At_Least_N_Arguments (2);
3189 Check_Optional_Identifier (Arg1, Name_Convention);
3190 Check_Arg_Is_Identifier (Arg1);
3191 Cname := Chars (Get_Pragma_Arg (Arg1));
3193 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
3194 -- tested again below to set the critical flag).
3196 if Cname = Name_C_Pass_By_Copy then
3199 -- Otherwise we must have something in the standard convention list
3201 elsif Is_Convention_Name (Cname) then
3202 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
3204 -- In DEC VMS, it seems that there is an undocumented feature that
3205 -- any unrecognized convention is treated as the default, which for
3206 -- us is convention C. It does not seem so terrible to do this
3207 -- unconditionally, silently in the VMS case, and with a warning
3208 -- in the non-VMS case.
3211 if Warn_On_Export_Import and not OpenVMS_On_Target then
3213 ("?unrecognized convention name, C assumed",
3214 Get_Pragma_Arg (Arg1));
3220 Check_Optional_Identifier (Arg2, Name_Entity);
3221 Check_Arg_Is_Local_Name (Arg2);
3223 Id := Get_Pragma_Arg (Arg2);
3226 if not Is_Entity_Name (Id) then
3227 Error_Pragma_Arg ("entity name required", Arg2);
3232 -- Set entity to return
3236 -- Ada_Pass_By_Copy special checking
3238 if C = Convention_Ada_Pass_By_Copy then
3239 if not Is_First_Subtype (E) then
3241 ("convention `Ada_Pass_By_Copy` only "
3242 & "allowed for types", Arg2);
3245 if Is_By_Reference_Type (E) then
3247 ("convention `Ada_Pass_By_Copy` not allowed for "
3248 & "by-reference type", Arg1);
3252 -- Ada_Pass_By_Reference special checking
3254 if C = Convention_Ada_Pass_By_Reference then
3255 if not Is_First_Subtype (E) then
3257 ("convention `Ada_Pass_By_Reference` only "
3258 & "allowed for types", Arg2);
3261 if Is_By_Copy_Type (E) then
3263 ("convention `Ada_Pass_By_Reference` not allowed for "
3264 & "by-copy type", Arg1);
3268 -- Go to renamed subprogram if present, since convention applies to
3269 -- the actual renamed entity, not to the renaming entity. If the
3270 -- subprogram is inherited, go to parent subprogram.
3272 if Is_Subprogram (E)
3273 and then Present (Alias (E))
3275 if Nkind (Parent (Declaration_Node (E))) =
3276 N_Subprogram_Renaming_Declaration
3278 if Scope (E) /= Scope (Alias (E)) then
3280 ("cannot apply pragma% to non-local entity&#", E);
3285 elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
3286 N_Private_Extension_Declaration)
3287 and then Scope (E) = Scope (Alias (E))
3291 -- Return the parent subprogram the entity was inherited from
3297 -- Check that we are not applying this to a specless body
3299 if Is_Subprogram (E)
3300 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
3303 ("pragma% requires separate spec and must come before body");
3306 -- Check that we are not applying this to a named constant
3308 if Ekind_In (E, E_Named_Integer, E_Named_Real) then
3309 Error_Msg_Name_1 := Pname;
3311 ("cannot apply pragma% to named constant!",
3312 Get_Pragma_Arg (Arg2));
3314 ("\supply appropriate type for&!", Arg2);
3317 if Ekind (E) = E_Enumeration_Literal then
3318 Error_Pragma ("enumeration literal not allowed for pragma%");
3321 -- Check for rep item appearing too early or too late
3323 if Etype (E) = Any_Type
3324 or else Rep_Item_Too_Early (E, N)
3328 elsif Present (Underlying_Type (E)) then
3329 E := Underlying_Type (E);
3332 if Rep_Item_Too_Late (E, N) then
3336 if Has_Convention_Pragma (E) then
3337 Diagnose_Multiple_Pragmas (E);
3339 elsif Convention (E) = Convention_Protected
3340 or else Ekind (Scope (E)) = E_Protected_Type
3343 ("a protected operation cannot be given a different convention",
3347 -- For Intrinsic, a subprogram is required
3349 if C = Convention_Intrinsic
3350 and then not Is_Subprogram (E)
3351 and then not Is_Generic_Subprogram (E)
3354 ("second argument of pragma% must be a subprogram", Arg2);
3357 -- For Stdcall, a subprogram, variable or subprogram type is required
3359 if C = Convention_Stdcall
3360 and then not Is_Subprogram (E)
3361 and then not Is_Generic_Subprogram (E)
3362 and then Ekind (E) /= E_Variable
3365 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
3368 ("second argument of pragma% must be subprogram (type)",
3372 if not Is_Subprogram (E)
3373 and then not Is_Generic_Subprogram (E)
3375 Set_Convention_From_Pragma (E);
3378 Check_First_Subtype (Arg2);
3379 Set_Convention_From_Pragma (Base_Type (E));
3381 -- For subprograms, we must set the convention on the
3382 -- internally generated directly designated type as well.
3384 if Ekind (E) = E_Access_Subprogram_Type then
3385 Set_Convention_From_Pragma (Directly_Designated_Type (E));
3389 -- For the subprogram case, set proper convention for all homonyms
3390 -- in same scope and the same declarative part, i.e. the same
3391 -- compilation unit.
3394 Comp_Unit := Get_Source_Unit (E);
3395 Set_Convention_From_Pragma (E);
3397 -- Treat a pragma Import as an implicit body, for GPS use
3399 if Prag_Id = Pragma_Import then
3400 Generate_Reference (E, Id, 'b');
3403 -- Loop through the homonyms of the pragma argument's entity
3408 exit when No (E1) or else Scope (E1) /= Current_Scope;
3410 -- Do not set the pragma on inherited operations or on formal
3413 if Comes_From_Source (E1)
3414 and then Comp_Unit = Get_Source_Unit (E1)
3415 and then not Is_Formal_Subprogram (E1)
3416 and then Nkind (Original_Node (Parent (E1))) /=
3417 N_Full_Type_Declaration
3419 if Present (Alias (E1))
3420 and then Scope (E1) /= Scope (Alias (E1))
3423 ("cannot apply pragma% to non-local entity& declared#",
3427 Set_Convention_From_Pragma (E1);
3429 if Prag_Id = Pragma_Import then
3430 Generate_Reference (E1, Id, 'b');
3434 -- For aspect case, do NOT apply to homonyms
3436 exit when From_Aspect_Specification (N);
3439 end Process_Convention;
3441 -----------------------------------------------------
3442 -- Process_Extended_Import_Export_Exception_Pragma --
3443 -----------------------------------------------------
3445 procedure Process_Extended_Import_Export_Exception_Pragma
3446 (Arg_Internal : Node_Id;
3447 Arg_External : Node_Id;
3455 if not OpenVMS_On_Target then
3457 ("?pragma% ignored (applies only to Open'V'M'S)");
3460 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3461 Def_Id := Entity (Arg_Internal);
3463 if Ekind (Def_Id) /= E_Exception then
3465 ("pragma% must refer to declared exception", Arg_Internal);
3468 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
3470 if Present (Arg_Form) then
3471 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
3474 if Present (Arg_Form)
3475 and then Chars (Arg_Form) = Name_Ada
3479 Set_Is_VMS_Exception (Def_Id);
3480 Set_Exception_Code (Def_Id, No_Uint);
3483 if Present (Arg_Code) then
3484 if not Is_VMS_Exception (Def_Id) then
3486 ("Code option for pragma% not allowed for Ada case",
3490 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
3491 Code_Val := Expr_Value (Arg_Code);
3493 if not UI_Is_In_Int_Range (Code_Val) then
3495 ("Code option for pragma% must be in 32-bit range",
3499 Set_Exception_Code (Def_Id, Code_Val);
3502 end Process_Extended_Import_Export_Exception_Pragma;
3504 -------------------------------------------------
3505 -- Process_Extended_Import_Export_Internal_Arg --
3506 -------------------------------------------------
3508 procedure Process_Extended_Import_Export_Internal_Arg
3509 (Arg_Internal : Node_Id := Empty)
3512 if No (Arg_Internal) then
3513 Error_Pragma ("Internal parameter required for pragma%");
3516 if Nkind (Arg_Internal) = N_Identifier then
3519 elsif Nkind (Arg_Internal) = N_Operator_Symbol
3520 and then (Prag_Id = Pragma_Import_Function
3522 Prag_Id = Pragma_Export_Function)
3528 ("wrong form for Internal parameter for pragma%", Arg_Internal);
3531 Check_Arg_Is_Local_Name (Arg_Internal);
3532 end Process_Extended_Import_Export_Internal_Arg;
3534 --------------------------------------------------
3535 -- Process_Extended_Import_Export_Object_Pragma --
3536 --------------------------------------------------
3538 procedure Process_Extended_Import_Export_Object_Pragma
3539 (Arg_Internal : Node_Id;
3540 Arg_External : Node_Id;
3546 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3547 Def_Id := Entity (Arg_Internal);
3549 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
3551 ("pragma% must designate an object", Arg_Internal);
3554 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
3556 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
3559 ("previous Common/Psect_Object applies, pragma % not permitted",
3563 if Rep_Item_Too_Late (Def_Id, N) then
3567 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
3569 if Present (Arg_Size) then
3570 Check_Arg_Is_External_Name (Arg_Size);
3573 -- Export_Object case
3575 if Prag_Id = Pragma_Export_Object then
3576 if not Is_Library_Level_Entity (Def_Id) then
3578 ("argument for pragma% must be library level entity",
3582 if Ekind (Current_Scope) = E_Generic_Package then
3583 Error_Pragma ("pragma& cannot appear in a generic unit");
3586 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
3588 ("exported object must have compile time known size",
3592 if Warn_On_Export_Import and then Is_Exported (Def_Id) then
3593 Error_Msg_N ("?duplicate Export_Object pragma", N);
3595 Set_Exported (Def_Id, Arg_Internal);
3598 -- Import_Object case
3601 if Is_Concurrent_Type (Etype (Def_Id)) then
3603 ("cannot use pragma% for task/protected object",
3607 if Ekind (Def_Id) = E_Constant then
3609 ("cannot import a constant", Arg_Internal);
3612 if Warn_On_Export_Import
3613 and then Has_Discriminants (Etype (Def_Id))
3616 ("imported value must be initialized?", Arg_Internal);
3619 if Warn_On_Export_Import
3620 and then Is_Access_Type (Etype (Def_Id))
3623 ("cannot import object of an access type?", Arg_Internal);
3626 if Warn_On_Export_Import
3627 and then Is_Imported (Def_Id)
3630 ("?duplicate Import_Object pragma", N);
3632 -- Check for explicit initialization present. Note that an
3633 -- initialization generated by the code generator, e.g. for an
3634 -- access type, does not count here.
3636 elsif Present (Expression (Parent (Def_Id)))
3639 (Original_Node (Expression (Parent (Def_Id))))
3641 Error_Msg_Sloc := Sloc (Def_Id);
3643 ("imported entities cannot be initialized (RM B.1(24))",
3644 "\no initialization allowed for & declared#", Arg1);
3646 Set_Imported (Def_Id);
3647 Note_Possible_Modification (Arg_Internal, Sure => False);
3650 end Process_Extended_Import_Export_Object_Pragma;
3652 ------------------------------------------------------
3653 -- Process_Extended_Import_Export_Subprogram_Pragma --
3654 ------------------------------------------------------
3656 procedure Process_Extended_Import_Export_Subprogram_Pragma
3657 (Arg_Internal : Node_Id;
3658 Arg_External : Node_Id;
3659 Arg_Parameter_Types : Node_Id;
3660 Arg_Result_Type : Node_Id := Empty;
3661 Arg_Mechanism : Node_Id;
3662 Arg_Result_Mechanism : Node_Id := Empty;
3663 Arg_First_Optional_Parameter : Node_Id := Empty)
3669 Ambiguous : Boolean;
3673 function Same_Base_Type
3675 Formal : Entity_Id) return Boolean;
3676 -- Determines if Ptype references the type of Formal. Note that only
3677 -- the base types need to match according to the spec. Ptype here is
3678 -- the argument from the pragma, which is either a type name, or an
3679 -- access attribute.
3681 --------------------
3682 -- Same_Base_Type --
3683 --------------------
3685 function Same_Base_Type
3687 Formal : Entity_Id) return Boolean
3689 Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
3693 -- Case where pragma argument is typ'Access
3695 if Nkind (Ptype) = N_Attribute_Reference
3696 and then Attribute_Name (Ptype) = Name_Access
3698 Pref := Prefix (Ptype);
3701 if not Is_Entity_Name (Pref)
3702 or else Entity (Pref) = Any_Type
3707 -- We have a match if the corresponding argument is of an
3708 -- anonymous access type, and its designated type matches the
3709 -- type of the prefix of the access attribute
3711 return Ekind (Ftyp) = E_Anonymous_Access_Type
3712 and then Base_Type (Entity (Pref)) =
3713 Base_Type (Etype (Designated_Type (Ftyp)));
3715 -- Case where pragma argument is a type name
3720 if not Is_Entity_Name (Ptype)
3721 or else Entity (Ptype) = Any_Type
3726 -- We have a match if the corresponding argument is of the type
3727 -- given in the pragma (comparing base types)
3729 return Base_Type (Entity (Ptype)) = Ftyp;
3733 -- Start of processing for
3734 -- Process_Extended_Import_Export_Subprogram_Pragma
3737 Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3741 -- Loop through homonyms (overloadings) of the entity
3743 Hom_Id := Entity (Arg_Internal);
3744 while Present (Hom_Id) loop
3745 Def_Id := Get_Base_Subprogram (Hom_Id);
3747 -- We need a subprogram in the current scope
3749 if not Is_Subprogram (Def_Id)
3750 or else Scope (Def_Id) /= Current_Scope
3757 -- Pragma cannot apply to subprogram body
3759 if Is_Subprogram (Def_Id)
3760 and then Nkind (Parent (Declaration_Node (Def_Id))) =
3764 ("pragma% requires separate spec"
3765 & " and must come before body");
3768 -- Test result type if given, note that the result type
3769 -- parameter can only be present for the function cases.
3771 if Present (Arg_Result_Type)
3772 and then not Same_Base_Type (Arg_Result_Type, Def_Id)
3776 elsif Etype (Def_Id) /= Standard_Void_Type
3778 (Pname = Name_Export_Procedure
3780 Pname = Name_Import_Procedure)
3784 -- Test parameter types if given. Note that this parameter
3785 -- has not been analyzed (and must not be, since it is
3786 -- semantic nonsense), so we get it as the parser left it.
3788 elsif Present (Arg_Parameter_Types) then
3789 Check_Matching_Types : declare
3794 Formal := First_Formal (Def_Id);
3796 if Nkind (Arg_Parameter_Types) = N_Null then
3797 if Present (Formal) then
3801 -- A list of one type, e.g. (List) is parsed as
3802 -- a parenthesized expression.
3804 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
3805 and then Paren_Count (Arg_Parameter_Types) = 1
3808 or else Present (Next_Formal (Formal))
3813 Same_Base_Type (Arg_Parameter_Types, Formal);
3816 -- A list of more than one type is parsed as a aggregate
3818 elsif Nkind (Arg_Parameter_Types) = N_Aggregate
3819 and then Paren_Count (Arg_Parameter_Types) = 0
3821 Ptype := First (Expressions (Arg_Parameter_Types));
3822 while Present (Ptype) or else Present (Formal) loop
3825 or else not Same_Base_Type (Ptype, Formal)
3830 Next_Formal (Formal);
3835 -- Anything else is of the wrong form
3839 ("wrong form for Parameter_Types parameter",
3840 Arg_Parameter_Types);
3842 end Check_Matching_Types;
3845 -- Match is now False if the entry we found did not match
3846 -- either a supplied Parameter_Types or Result_Types argument
3852 -- Ambiguous case, the flag Ambiguous shows if we already
3853 -- detected this and output the initial messages.
3856 if not Ambiguous then
3858 Error_Msg_Name_1 := Pname;
3860 ("pragma% does not uniquely identify subprogram!",
3862 Error_Msg_Sloc := Sloc (Ent);
3863 Error_Msg_N ("matching subprogram #!", N);
3867 Error_Msg_Sloc := Sloc (Def_Id);
3868 Error_Msg_N ("matching subprogram #!", N);
3873 Hom_Id := Homonym (Hom_Id);
3876 -- See if we found an entry
3879 if not Ambiguous then
3880 if Is_Generic_Subprogram (Entity (Arg_Internal)) then
3882 ("pragma% cannot be given for generic subprogram");
3885 ("pragma% does not identify local subprogram");
3892 -- Import pragmas must be for imported entities
3894 if Prag_Id = Pragma_Import_Function
3896 Prag_Id = Pragma_Import_Procedure
3898 Prag_Id = Pragma_Import_Valued_Procedure
3900 if not Is_Imported (Ent) then
3902 ("pragma Import or Interface must precede pragma%");
3905 -- Here we have the Export case which can set the entity as exported
3907 -- But does not do so if the specified external name is null, since
3908 -- that is taken as a signal in DEC Ada 83 (with which we want to be
3909 -- compatible) to request no external name.
3911 elsif Nkind (Arg_External) = N_String_Literal
3912 and then String_Length (Strval (Arg_External)) = 0
3916 -- In all other cases, set entity as exported
3919 Set_Exported (Ent, Arg_Internal);
3922 -- Special processing for Valued_Procedure cases
3924 if Prag_Id = Pragma_Import_Valued_Procedure
3926 Prag_Id = Pragma_Export_Valued_Procedure
3928 Formal := First_Formal (Ent);
3931 Error_Pragma ("at least one parameter required for pragma%");
3933 elsif Ekind (Formal) /= E_Out_Parameter then
3934 Error_Pragma ("first parameter must have mode out for pragma%");
3937 Set_Is_Valued_Procedure (Ent);
3941 Set_Extended_Import_Export_External_Name (Ent, Arg_External);
3943 -- Process Result_Mechanism argument if present. We have already
3944 -- checked that this is only allowed for the function case.
3946 if Present (Arg_Result_Mechanism) then
3947 Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
3950 -- Process Mechanism parameter if present. Note that this parameter
3951 -- is not analyzed, and must not be analyzed since it is semantic
3952 -- nonsense, so we get it in exactly as the parser left it.
3954 if Present (Arg_Mechanism) then
3962 -- A single mechanism association without a formal parameter
3963 -- name is parsed as a parenthesized expression. All other
3964 -- cases are parsed as aggregates, so we rewrite the single
3965 -- parameter case as an aggregate for consistency.
3967 if Nkind (Arg_Mechanism) /= N_Aggregate
3968 and then Paren_Count (Arg_Mechanism) = 1
3970 Rewrite (Arg_Mechanism,
3971 Make_Aggregate (Sloc (Arg_Mechanism),
3972 Expressions => New_List (
3973 Relocate_Node (Arg_Mechanism))));
3976 -- Case of only mechanism name given, applies to all formals
3978 if Nkind (Arg_Mechanism) /= N_Aggregate then
3979 Formal := First_Formal (Ent);
3980 while Present (Formal) loop
3981 Set_Mechanism_Value (Formal, Arg_Mechanism);
3982 Next_Formal (Formal);
3985 -- Case of list of mechanism associations given
3988 if Null_Record_Present (Arg_Mechanism) then
3990 ("inappropriate form for Mechanism parameter",
3994 -- Deal with positional ones first
3996 Formal := First_Formal (Ent);
3998 if Present (Expressions (Arg_Mechanism)) then
3999 Mname := First (Expressions (Arg_Mechanism));
4000 while Present (Mname) loop
4003 ("too many mechanism associations", Mname);
4006 Set_Mechanism_Value (Formal, Mname);
4007 Next_Formal (Formal);
4012 -- Deal with named entries
4014 if Present (Component_Associations (Arg_Mechanism)) then
4015 Massoc := First (Component_Associations (Arg_Mechanism));
4016 while Present (Massoc) loop
4017 Choice := First (Choices (Massoc));
4019 if Nkind (Choice) /= N_Identifier
4020 or else Present (Next (Choice))
4023 ("incorrect form for mechanism association",
4027 Formal := First_Formal (Ent);
4031 ("parameter name & not present", Choice);
4034 if Chars (Choice) = Chars (Formal) then
4036 (Formal, Expression (Massoc));
4038 -- Set entity on identifier (needed by ASIS)
4040 Set_Entity (Choice, Formal);
4045 Next_Formal (Formal);
4055 -- Process First_Optional_Parameter argument if present. We have
4056 -- already checked that this is only allowed for the Import case.
4058 if Present (Arg_First_Optional_Parameter) then
4059 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
4061 ("first optional parameter must be formal parameter name",
4062 Arg_First_Optional_Parameter);
4065 Formal := First_Formal (Ent);
4069 ("specified formal parameter& not found",
4070 Arg_First_Optional_Parameter);
4073 exit when Chars (Formal) =
4074 Chars (Arg_First_Optional_Parameter);
4076 Next_Formal (Formal);
4079 Set_First_Optional_Parameter (Ent, Formal);
4081 -- Check specified and all remaining formals have right form
4083 while Present (Formal) loop
4084 if Ekind (Formal) /= E_In_Parameter then
4086 ("optional formal& is not of mode in!",
4087 Arg_First_Optional_Parameter, Formal);
4090 Dval := Default_Value (Formal);
4094 ("optional formal& does not have default value!",
4095 Arg_First_Optional_Parameter, Formal);
4097 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
4102 ("default value for optional formal& is non-static!",
4103 Arg_First_Optional_Parameter, Formal);
4107 Set_Is_Optional_Parameter (Formal);
4108 Next_Formal (Formal);
4111 end Process_Extended_Import_Export_Subprogram_Pragma;
4113 --------------------------
4114 -- Process_Generic_List --
4115 --------------------------
4117 procedure Process_Generic_List is
4122 Check_No_Identifiers;
4123 Check_At_Least_N_Arguments (1);
4126 while Present (Arg) loop
4127 Exp := Get_Pragma_Arg (Arg);
4130 if not Is_Entity_Name (Exp)
4132 (not Is_Generic_Instance (Entity (Exp))
4134 not Is_Generic_Unit (Entity (Exp)))
4137 ("pragma% argument must be name of generic unit/instance",
4143 end Process_Generic_List;
4145 ------------------------------------
4146 -- Process_Import_Predefined_Type --
4147 ------------------------------------
4149 procedure Process_Import_Predefined_Type is
4150 Loc : constant Source_Ptr := Sloc (N);
4152 Ftyp : Node_Id := Empty;
4158 String_To_Name_Buffer (Strval (Expression (Arg3)));
4161 Elmt := First_Elmt (Predefined_Float_Types);
4162 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
4166 Ftyp := Node (Elmt);
4168 if Present (Ftyp) then
4170 -- Don't build a derived type declaration, because predefined C
4171 -- types have no declaration anywhere, so cannot really be named.
4172 -- Instead build a full type declaration, starting with an
4173 -- appropriate type definition is built
4175 if Is_Floating_Point_Type (Ftyp) then
4176 Def := Make_Floating_Point_Definition (Loc,
4177 Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
4178 Make_Real_Range_Specification (Loc,
4179 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
4180 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
4182 -- Should never have a predefined type we cannot handle
4185 raise Program_Error;
4188 -- Build and insert a Full_Type_Declaration, which will be
4189 -- analyzed as soon as this list entry has been analyzed.
4191 Decl := Make_Full_Type_Declaration (Loc,
4192 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
4193 Type_Definition => Def);
4195 Insert_After (N, Decl);
4196 Mark_Rewrite_Insertion (Decl);
4199 Error_Pragma_Arg ("no matching type found for pragma%",
4202 end Process_Import_Predefined_Type;
4204 ---------------------------------
4205 -- Process_Import_Or_Interface --
4206 ---------------------------------
4208 procedure Process_Import_Or_Interface is
4214 Process_Convention (C, Def_Id);
4215 Kill_Size_Check_Code (Def_Id);
4216 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
4218 if Ekind_In (Def_Id, E_Variable, E_Constant) then
4220 -- We do not permit Import to apply to a renaming declaration
4222 if Present (Renamed_Object (Def_Id)) then
4224 ("pragma% not allowed for object renaming", Arg2);
4226 -- User initialization is not allowed for imported object, but
4227 -- the object declaration may contain a default initialization,
4228 -- that will be discarded. Note that an explicit initialization
4229 -- only counts if it comes from source, otherwise it is simply
4230 -- the code generator making an implicit initialization explicit.
4232 elsif Present (Expression (Parent (Def_Id)))
4233 and then Comes_From_Source (Expression (Parent (Def_Id)))
4235 Error_Msg_Sloc := Sloc (Def_Id);
4237 ("no initialization allowed for declaration of& #",
4238 "\imported entities cannot be initialized (RM B.1(24))",
4242 Set_Imported (Def_Id);
4243 Process_Interface_Name (Def_Id, Arg3, Arg4);
4245 -- Note that we do not set Is_Public here. That's because we
4246 -- only want to set it if there is no address clause, and we
4247 -- don't know that yet, so we delay that processing till
4250 -- pragma Import completes deferred constants
4252 if Ekind (Def_Id) = E_Constant then
4253 Set_Has_Completion (Def_Id);
4256 -- It is not possible to import a constant of an unconstrained
4257 -- array type (e.g. string) because there is no simple way to
4258 -- write a meaningful subtype for it.
4260 if Is_Array_Type (Etype (Def_Id))
4261 and then not Is_Constrained (Etype (Def_Id))
4264 ("imported constant& must have a constrained subtype",
4269 elsif Is_Subprogram (Def_Id)
4270 or else Is_Generic_Subprogram (Def_Id)
4272 -- If the name is overloaded, pragma applies to all of the denoted
4273 -- entities in the same declarative part.
4276 while Present (Hom_Id) loop
4277 Def_Id := Get_Base_Subprogram (Hom_Id);
4279 -- Ignore inherited subprograms because the pragma will apply
4280 -- to the parent operation, which is the one called.
4282 if Is_Overloadable (Def_Id)
4283 and then Present (Alias (Def_Id))
4287 -- If it is not a subprogram, it must be in an outer scope and
4288 -- pragma does not apply.
4290 elsif not Is_Subprogram (Def_Id)
4291 and then not Is_Generic_Subprogram (Def_Id)
4295 -- The pragma does not apply to primitives of interfaces
4297 elsif Is_Dispatching_Operation (Def_Id)
4298 and then Present (Find_Dispatching_Type (Def_Id))
4299 and then Is_Interface (Find_Dispatching_Type (Def_Id))
4303 -- Verify that the homonym is in the same declarative part (not
4304 -- just the same scope).
4306 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
4307 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
4312 Set_Imported (Def_Id);
4314 -- Reject an Import applied to an abstract subprogram
4316 if Is_Subprogram (Def_Id)
4317 and then Is_Abstract_Subprogram (Def_Id)
4319 Error_Msg_Sloc := Sloc (Def_Id);
4321 ("cannot import abstract subprogram& declared#",
4325 -- Special processing for Convention_Intrinsic
4327 if C = Convention_Intrinsic then
4329 -- Link_Name argument not allowed for intrinsic
4333 Set_Is_Intrinsic_Subprogram (Def_Id);
4335 -- If no external name is present, then check that this
4336 -- is a valid intrinsic subprogram. If an external name
4337 -- is present, then this is handled by the back end.
4340 Check_Intrinsic_Subprogram
4341 (Def_Id, Get_Pragma_Arg (Arg2));
4345 -- All interfaced procedures need an external symbol created
4346 -- for them since they are always referenced from another
4349 Set_Is_Public (Def_Id);
4351 -- Verify that the subprogram does not have a completion
4352 -- through a renaming declaration. For other completions the
4353 -- pragma appears as a too late representation.
4356 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
4360 and then Nkind (Decl) = N_Subprogram_Declaration
4361 and then Present (Corresponding_Body (Decl))
4362 and then Nkind (Unit_Declaration_Node
4363 (Corresponding_Body (Decl))) =
4364 N_Subprogram_Renaming_Declaration
4366 Error_Msg_Sloc := Sloc (Def_Id);
4368 ("cannot import&, renaming already provided for " &
4369 "declaration #", N, Def_Id);
4373 Set_Has_Completion (Def_Id);
4374 Process_Interface_Name (Def_Id, Arg3, Arg4);
4377 if Is_Compilation_Unit (Hom_Id) then
4379 -- Its possible homonyms are not affected by the pragma.
4380 -- Such homonyms might be present in the context of other
4381 -- units being compiled.
4386 Hom_Id := Homonym (Hom_Id);
4390 -- When the convention is Java or CIL, we also allow Import to be
4391 -- given for packages, generic packages, exceptions, record
4392 -- components, and access to subprograms.
4394 elsif (C = Convention_Java or else C = Convention_CIL)
4396 (Is_Package_Or_Generic_Package (Def_Id)
4397 or else Ekind (Def_Id) = E_Exception
4398 or else Ekind (Def_Id) = E_Access_Subprogram_Type
4399 or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
4401 Set_Imported (Def_Id);
4402 Set_Is_Public (Def_Id);
4403 Process_Interface_Name (Def_Id, Arg3, Arg4);
4405 -- Import a CPP class
4407 elsif Is_Record_Type (Def_Id)
4408 and then C = Convention_CPP
4410 -- Types treated as CPP classes must be declared limited (note:
4411 -- this used to be a warning but there is no real benefit to it
4412 -- since we did effectively intend to treat the type as limited
4415 if not Is_Limited_Type (Def_Id) then
4417 ("imported 'C'P'P type must be limited",
4418 Get_Pragma_Arg (Arg2));
4421 Set_Is_CPP_Class (Def_Id);
4423 -- Imported CPP types must not have discriminants (because C++
4424 -- classes do not have discriminants).
4426 if Has_Discriminants (Def_Id) then
4428 ("imported 'C'P'P type cannot have discriminants",
4429 First (Discriminant_Specifications
4430 (Declaration_Node (Def_Id))));
4433 -- Components of imported CPP types must not have default
4434 -- expressions because the constructor (if any) is on the
4438 Tdef : constant Node_Id :=
4439 Type_Definition (Declaration_Node (Def_Id));
4444 if Nkind (Tdef) = N_Record_Definition then
4445 Clist := Component_List (Tdef);
4448 pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
4449 Clist := Component_List (Record_Extension_Part (Tdef));
4452 if Present (Clist) then
4453 Comp := First (Component_Items (Clist));
4454 while Present (Comp) loop
4455 if Present (Expression (Comp)) then
4457 ("component of imported 'C'P'P type cannot have" &
4458 " default expression", Expression (Comp));
4466 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
4468 Check_Arg_Count (3);
4469 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
4471 Process_Import_Predefined_Type;
4475 ("second argument of pragma% must be object, subprogram" &
4476 " or incomplete type",
4480 -- If this pragma applies to a compilation unit, then the unit, which
4481 -- is a subprogram, does not require (or allow) a body. We also do
4482 -- not need to elaborate imported procedures.
4484 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
4486 Cunit : constant Node_Id := Parent (Parent (N));
4488 Set_Body_Required (Cunit, False);
4491 end Process_Import_Or_Interface;
4493 --------------------
4494 -- Process_Inline --
4495 --------------------
4497 procedure Process_Inline (Active : Boolean) is
4504 Effective : Boolean := False;
4505 -- Set True if inline has some effect, i.e. if there is at least one
4506 -- subprogram set as inlined as a result of the use of the pragma.
4508 procedure Make_Inline (Subp : Entity_Id);
4509 -- Subp is the defining unit name of the subprogram declaration. Set
4510 -- the flag, as well as the flag in the corresponding body, if there
4513 procedure Set_Inline_Flags (Subp : Entity_Id);
4514 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
4515 -- Has_Pragma_Inline_Always for the Inline_Always case.
4517 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
4518 -- Returns True if it can be determined at this stage that inlining
4519 -- is not possible, for example if the body is available and contains
4520 -- exception handlers, we prevent inlining, since otherwise we can
4521 -- get undefined symbols at link time. This function also emits a
4522 -- warning if front-end inlining is enabled and the pragma appears
4525 -- ??? is business with link symbols still valid, or does it relate
4526 -- to front end ZCX which is being phased out ???
4528 ---------------------------
4529 -- Inlining_Not_Possible --
4530 ---------------------------
4532 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
4533 Decl : constant Node_Id := Unit_Declaration_Node (Subp);
4537 if Nkind (Decl) = N_Subprogram_Body then
4538 Stats := Handled_Statement_Sequence (Decl);
4539 return Present (Exception_Handlers (Stats))
4540 or else Present (At_End_Proc (Stats));
4542 elsif Nkind (Decl) = N_Subprogram_Declaration
4543 and then Present (Corresponding_Body (Decl))
4545 if Front_End_Inlining
4546 and then Analyzed (Corresponding_Body (Decl))
4548 Error_Msg_N ("pragma appears too late, ignored?", N);
4551 -- If the subprogram is a renaming as body, the body is just a
4552 -- call to the renamed subprogram, and inlining is trivially
4556 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
4557 N_Subprogram_Renaming_Declaration
4563 Handled_Statement_Sequence
4564 (Unit_Declaration_Node (Corresponding_Body (Decl)));
4567 Present (Exception_Handlers (Stats))
4568 or else Present (At_End_Proc (Stats));
4572 -- If body is not available, assume the best, the check is
4573 -- performed again when compiling enclosing package bodies.
4577 end Inlining_Not_Possible;
4583 procedure Make_Inline (Subp : Entity_Id) is
4584 Kind : constant Entity_Kind := Ekind (Subp);
4585 Inner_Subp : Entity_Id := Subp;
4588 -- Ignore if bad type, avoid cascaded error
4590 if Etype (Subp) = Any_Type then
4594 -- Ignore if all inlining is suppressed
4596 elsif Suppress_All_Inlining then
4600 -- If inlining is not possible, for now do not treat as an error
4602 elsif Inlining_Not_Possible (Subp) then
4606 -- Here we have a candidate for inlining, but we must exclude
4607 -- derived operations. Otherwise we would end up trying to inline
4608 -- a phantom declaration, and the result would be to drag in a
4609 -- body which has no direct inlining associated with it. That
4610 -- would not only be inefficient but would also result in the
4611 -- backend doing cross-unit inlining in cases where it was
4612 -- definitely inappropriate to do so.
4614 -- However, a simple Comes_From_Source test is insufficient, since
4615 -- we do want to allow inlining of generic instances which also do
4616 -- not come from source. We also need to recognize specs generated
4617 -- by the front-end for bodies that carry the pragma. Finally,
4618 -- predefined operators do not come from source but are not
4619 -- inlineable either.
4621 elsif Is_Generic_Instance (Subp)
4622 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
4626 elsif not Comes_From_Source (Subp)
4627 and then Scope (Subp) /= Standard_Standard
4633 -- The referenced entity must either be the enclosing entity, or
4634 -- an entity declared within the current open scope.
4636 if Present (Scope (Subp))
4637 and then Scope (Subp) /= Current_Scope
4638 and then Subp /= Current_Scope
4641 ("argument of% must be entity in current scope", Assoc);
4645 -- Processing for procedure, operator or function. If subprogram
4646 -- is aliased (as for an instance) indicate that the renamed
4647 -- entity (if declared in the same unit) is inlined.
4649 if Is_Subprogram (Subp) then
4650 Inner_Subp := Ultimate_Alias (Inner_Subp);
4652 if In_Same_Source_Unit (Subp, Inner_Subp) then
4653 Set_Inline_Flags (Inner_Subp);
4655 Decl := Parent (Parent (Inner_Subp));
4657 if Nkind (Decl) = N_Subprogram_Declaration
4658 and then Present (Corresponding_Body (Decl))
4660 Set_Inline_Flags (Corresponding_Body (Decl));
4662 elsif Is_Generic_Instance (Subp) then
4664 -- Indicate that the body needs to be created for
4665 -- inlining subsequent calls. The instantiation node
4666 -- follows the declaration of the wrapper package
4669 if Scope (Subp) /= Standard_Standard
4671 Need_Subprogram_Instance_Body
4672 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
4682 -- For a generic subprogram set flag as well, for use at the point
4683 -- of instantiation, to determine whether the body should be
4686 elsif Is_Generic_Subprogram (Subp) then
4687 Set_Inline_Flags (Subp);
4690 -- Literals are by definition inlined
4692 elsif Kind = E_Enumeration_Literal then
4695 -- Anything else is an error
4699 ("expect subprogram name for pragma%", Assoc);
4703 ----------------------
4704 -- Set_Inline_Flags --
4705 ----------------------
4707 procedure Set_Inline_Flags (Subp : Entity_Id) is
4710 Set_Is_Inlined (Subp);
4713 if not Has_Pragma_Inline (Subp) then
4714 Set_Has_Pragma_Inline (Subp);
4718 if Prag_Id = Pragma_Inline_Always then
4719 Set_Has_Pragma_Inline_Always (Subp);
4721 end Set_Inline_Flags;
4723 -- Start of processing for Process_Inline
4726 Check_No_Identifiers;
4727 Check_At_Least_N_Arguments (1);
4730 Inline_Processing_Required := True;
4734 while Present (Assoc) loop
4735 Subp_Id := Get_Pragma_Arg (Assoc);
4739 if Is_Entity_Name (Subp_Id) then
4740 Subp := Entity (Subp_Id);
4742 if Subp = Any_Id then
4744 -- If previous error, avoid cascaded errors
4752 -- For the pragma case, climb homonym chain. This is
4753 -- what implements allowing the pragma in the renaming
4754 -- case, with the result applying to the ancestors.
4756 if not From_Aspect_Specification (N) then
4757 while Present (Homonym (Subp))
4758 and then Scope (Homonym (Subp)) = Current_Scope
4760 Make_Inline (Homonym (Subp));
4761 Subp := Homonym (Subp);
4769 ("inappropriate argument for pragma%", Assoc);
4772 and then Warn_On_Redundant_Constructs
4773 and then not Suppress_All_Inlining
4775 if Inlining_Not_Possible (Subp) then
4777 ("pragma Inline for& is ignored?", N, Entity (Subp_Id));
4780 ("pragma Inline for& is redundant?", N, Entity (Subp_Id));
4788 ----------------------------
4789 -- Process_Interface_Name --
4790 ----------------------------
4792 procedure Process_Interface_Name
4793 (Subprogram_Def : Entity_Id;
4799 String_Val : String_Id;
4801 procedure Check_Form_Of_Interface_Name
4803 Ext_Name_Case : Boolean);
4804 -- SN is a string literal node for an interface name. This routine
4805 -- performs some minimal checks that the name is reasonable. In
4806 -- particular that no spaces or other obviously incorrect characters
4807 -- appear. This is only a warning, since any characters are allowed.
4808 -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
4810 ----------------------------------
4811 -- Check_Form_Of_Interface_Name --
4812 ----------------------------------
4814 procedure Check_Form_Of_Interface_Name
4816 Ext_Name_Case : Boolean)
4818 S : constant String_Id := Strval (Expr_Value_S (SN));
4819 SL : constant Nat := String_Length (S);
4824 Error_Msg_N ("interface name cannot be null string", SN);
4827 for J in 1 .. SL loop
4828 C := Get_String_Char (S, J);
4830 -- Look for dubious character and issue unconditional warning.
4831 -- Definitely dubious if not in character range.
4833 if not In_Character_Range (C)
4835 -- For all cases except CLI target,
4836 -- commas, spaces and slashes are dubious (in CLI, we use
4837 -- commas and backslashes in external names to specify
4838 -- assembly version and public key, while slashes and spaces
4839 -- can be used in names to mark nested classes and
4842 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
4843 and then (Get_Character (C) = ','
4845 Get_Character (C) = '\'))
4846 or else (VM_Target /= CLI_Target
4847 and then (Get_Character (C) = ' '
4849 Get_Character (C) = '/'))
4852 ("?interface name contains illegal character",
4853 Sloc (SN) + Source_Ptr (J));
4856 end Check_Form_Of_Interface_Name;
4858 -- Start of processing for Process_Interface_Name
4861 if No (Link_Arg) then
4862 if No (Ext_Arg) then
4863 if VM_Target = CLI_Target
4864 and then Ekind (Subprogram_Def) = E_Package
4865 and then Nkind (Parent (Subprogram_Def)) =
4866 N_Package_Specification
4867 and then Present (Generic_Parent (Parent (Subprogram_Def)))
4872 (Generic_Parent (Parent (Subprogram_Def))));
4877 elsif Chars (Ext_Arg) = Name_Link_Name then
4879 Link_Nam := Expression (Ext_Arg);
4882 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
4883 Ext_Nam := Expression (Ext_Arg);
4888 Check_Optional_Identifier (Ext_Arg, Name_External_Name);
4889 Check_Optional_Identifier (Link_Arg, Name_Link_Name);
4890 Ext_Nam := Expression (Ext_Arg);
4891 Link_Nam := Expression (Link_Arg);
4894 -- Check expressions for external name and link name are static
4896 if Present (Ext_Nam) then
4897 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
4898 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
4900 -- Verify that external name is not the name of a local entity,
4901 -- which would hide the imported one and could lead to run-time
4902 -- surprises. The problem can only arise for entities declared in
4903 -- a package body (otherwise the external name is fully qualified
4904 -- and will not conflict).
4912 if Prag_Id = Pragma_Import then
4913 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
4915 E := Entity_Id (Get_Name_Table_Info (Nam));
4917 if Nam /= Chars (Subprogram_Def)
4918 and then Present (E)
4919 and then not Is_Overloadable (E)
4920 and then Is_Immediately_Visible (E)
4921 and then not Is_Imported (E)
4922 and then Ekind (Scope (E)) = E_Package
4925 while Present (Par) loop
4926 if Nkind (Par) = N_Package_Body then
4927 Error_Msg_Sloc := Sloc (E);
4929 ("imported entity is hidden by & declared#",
4934 Par := Parent (Par);
4941 if Present (Link_Nam) then
4942 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
4943 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
4946 -- If there is no link name, just set the external name
4948 if No (Link_Nam) then
4949 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
4951 -- For the Link_Name case, the given literal is preceded by an
4952 -- asterisk, which indicates to GCC that the given name should be
4953 -- taken literally, and in particular that no prepending of
4954 -- underlines should occur, even in systems where this is the
4960 if VM_Target = No_VM then
4961 Store_String_Char (Get_Char_Code ('*'));
4964 String_Val := Strval (Expr_Value_S (Link_Nam));
4965 Store_String_Chars (String_Val);
4967 Make_String_Literal (Sloc (Link_Nam),
4968 Strval => End_String);
4971 -- Set the interface name. If the entity is a generic instance, use
4972 -- its alias, which is the callable entity.
4974 if Is_Generic_Instance (Subprogram_Def) then
4975 Set_Encoded_Interface_Name
4976 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
4978 Set_Encoded_Interface_Name
4979 (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
4982 -- We allow duplicated export names in CIL/Java, as they are always
4983 -- enclosed in a namespace that differentiates them, and overloaded
4984 -- entities are supported by the VM.
4986 if Convention (Subprogram_Def) /= Convention_CIL
4988 Convention (Subprogram_Def) /= Convention_Java
4990 Check_Duplicated_Export_Name (Link_Nam);
4992 end Process_Interface_Name;
4994 -----------------------------------------
4995 -- Process_Interrupt_Or_Attach_Handler --
4996 -----------------------------------------
4998 procedure Process_Interrupt_Or_Attach_Handler is
4999 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5000 Handler_Proc : constant Entity_Id := Entity (Arg1_X);
5001 Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
5004 Set_Is_Interrupt_Handler (Handler_Proc);
5006 -- If the pragma is not associated with a handler procedure within a
5007 -- protected type, then it must be for a nonprotected procedure for
5008 -- the AAMP target, in which case we don't associate a representation
5009 -- item with the procedure's scope.
5011 if Ekind (Proc_Scope) = E_Protected_Type then
5012 if Prag_Id = Pragma_Interrupt_Handler
5014 Prag_Id = Pragma_Attach_Handler
5016 Record_Rep_Item (Proc_Scope, N);
5019 end Process_Interrupt_Or_Attach_Handler;
5021 --------------------------------------------------
5022 -- Process_Restrictions_Or_Restriction_Warnings --
5023 --------------------------------------------------
5025 -- Note: some of the simple identifier cases were handled in par-prag,
5026 -- but it is harmless (and more straightforward) to simply handle all
5027 -- cases here, even if it means we repeat a bit of work in some cases.
5029 procedure Process_Restrictions_Or_Restriction_Warnings
5033 R_Id : Restriction_Id;
5038 procedure Check_Unit_Name (N : Node_Id);
5039 -- Checks unit name parameter for No_Dependence. Returns if it has
5040 -- an appropriate form, otherwise raises pragma argument error.
5042 ---------------------
5043 -- Check_Unit_Name --
5044 ---------------------
5046 procedure Check_Unit_Name (N : Node_Id) is
5048 if Nkind (N) = N_Selected_Component then
5049 Check_Unit_Name (Prefix (N));
5050 Check_Unit_Name (Selector_Name (N));
5052 elsif Nkind (N) = N_Identifier then
5057 ("wrong form for unit name for No_Dependence", N);
5059 end Check_Unit_Name;
5061 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
5064 -- Ignore all Restrictions pragma in CodePeer mode
5066 if CodePeer_Mode then
5070 Check_Ada_83_Warning;
5071 Check_At_Least_N_Arguments (1);
5072 Check_Valid_Configuration_Pragma;
5075 while Present (Arg) loop
5077 Expr := Get_Pragma_Arg (Arg);
5079 -- Case of no restriction identifier present
5081 if Id = No_Name then
5082 if Nkind (Expr) /= N_Identifier then
5084 ("invalid form for restriction", Arg);
5089 (Process_Restriction_Synonyms (Expr));
5091 if R_Id not in All_Boolean_Restrictions then
5092 Error_Msg_Name_1 := Pname;
5094 ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
5096 -- Check for possible misspelling
5098 for J in Restriction_Id loop
5100 Rnm : constant String := Restriction_Id'Image (J);
5103 Name_Buffer (1 .. Rnm'Length) := Rnm;
5104 Name_Len := Rnm'Length;
5105 Set_Casing (All_Lower_Case);
5107 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
5109 (Identifier_Casing (Current_Source_File));
5110 Error_Msg_String (1 .. Rnm'Length) :=
5111 Name_Buffer (1 .. Name_Len);
5112 Error_Msg_Strlen := Rnm'Length;
5113 Error_Msg_N -- CODEFIX
5114 ("\possible misspelling of ""~""",
5115 Get_Pragma_Arg (Arg));
5124 if Implementation_Restriction (R_Id) then
5125 Check_Restriction (No_Implementation_Restrictions, Arg);
5128 -- If this is a warning, then set the warning unless we already
5129 -- have a real restriction active (we never want a warning to
5130 -- override a real restriction).
5133 if not Restriction_Active (R_Id) then
5134 Set_Restriction (R_Id, N);
5135 Restriction_Warnings (R_Id) := True;
5138 -- If real restriction case, then set it and make sure that the
5139 -- restriction warning flag is off, since a real restriction
5140 -- always overrides a warning.
5143 Set_Restriction (R_Id, N);
5144 Restriction_Warnings (R_Id) := False;
5147 -- Check for obsolescent restrictions in Ada 2005 mode
5150 and then Ada_Version >= Ada_2005
5151 and then (R_Id = No_Asynchronous_Control
5153 R_Id = No_Unchecked_Deallocation
5155 R_Id = No_Unchecked_Conversion)
5157 Check_Restriction (No_Obsolescent_Features, N);
5160 -- A very special case that must be processed here: pragma
5161 -- Restrictions (No_Exceptions) turns off all run-time
5162 -- checking. This is a bit dubious in terms of the formal
5163 -- language definition, but it is what is intended by RM
5164 -- H.4(12). Restriction_Warnings never affects generated code
5165 -- so this is done only in the real restriction case.
5167 if R_Id = No_Exceptions and then not Warn then
5168 Scope_Suppress := (others => True);
5171 -- Case of No_Dependence => unit-name. Note that the parser
5172 -- already made the necessary entry in the No_Dependence table.
5174 elsif Id = Name_No_Dependence then
5175 Check_Unit_Name (Expr);
5177 -- All other cases of restriction identifier present
5180 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
5181 Analyze_And_Resolve (Expr, Any_Integer);
5183 if R_Id not in All_Parameter_Restrictions then
5185 ("invalid restriction parameter identifier", Arg);
5187 elsif not Is_OK_Static_Expression (Expr) then
5188 Flag_Non_Static_Expr
5189 ("value must be static expression!", Expr);
5192 elsif not Is_Integer_Type (Etype (Expr))
5193 or else Expr_Value (Expr) < 0
5196 ("value must be non-negative integer", Arg);
5199 -- Restriction pragma is active
5201 Val := Expr_Value (Expr);
5203 if not UI_Is_In_Int_Range (Val) then
5205 ("pragma ignored, value too large?", Arg);
5208 -- Warning case. If the real restriction is active, then we
5209 -- ignore the request, since warning never overrides a real
5210 -- restriction. Otherwise we set the proper warning. Note that
5211 -- this circuit sets the warning again if it is already set,
5212 -- which is what we want, since the constant may have changed.
5215 if not Restriction_Active (R_Id) then
5217 (R_Id, N, Integer (UI_To_Int (Val)));
5218 Restriction_Warnings (R_Id) := True;
5221 -- Real restriction case, set restriction and make sure warning
5222 -- flag is off since real restriction always overrides warning.
5225 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
5226 Restriction_Warnings (R_Id) := False;
5232 end Process_Restrictions_Or_Restriction_Warnings;
5234 ---------------------------------
5235 -- Process_Suppress_Unsuppress --
5236 ---------------------------------
5238 -- Note: this procedure makes entries in the check suppress data
5239 -- structures managed by Sem. See spec of package Sem for full
5240 -- details on how we handle recording of check suppression.
5242 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
5247 In_Package_Spec : constant Boolean :=
5248 Is_Package_Or_Generic_Package (Current_Scope)
5249 and then not In_Package_Body (Current_Scope);
5251 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
5252 -- Used to suppress a single check on the given entity
5254 --------------------------------
5255 -- Suppress_Unsuppress_Echeck --
5256 --------------------------------
5258 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
5260 Set_Checks_May_Be_Suppressed (E);
5262 if In_Package_Spec then
5263 Push_Global_Suppress_Stack_Entry
5266 Suppress => Suppress_Case);
5269 Push_Local_Suppress_Stack_Entry
5272 Suppress => Suppress_Case);
5275 -- If this is a first subtype, and the base type is distinct,
5276 -- then also set the suppress flags on the base type.
5278 if Is_First_Subtype (E)
5279 and then Etype (E) /= E
5281 Suppress_Unsuppress_Echeck (Etype (E), C);
5283 end Suppress_Unsuppress_Echeck;
5285 -- Start of processing for Process_Suppress_Unsuppress
5288 -- Ignore pragma Suppress/Unsuppress in codepeer mode on user code:
5289 -- we want to generate checks for analysis purposes, as set by -gnatC
5291 if CodePeer_Mode and then Comes_From_Source (N) then
5295 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
5296 -- declarative part or a package spec (RM 11.5(5)).
5298 if not Is_Configuration_Pragma then
5299 Check_Is_In_Decl_Part_Or_Package_Spec;
5302 Check_At_Least_N_Arguments (1);
5303 Check_At_Most_N_Arguments (2);
5304 Check_No_Identifier (Arg1);
5305 Check_Arg_Is_Identifier (Arg1);
5307 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
5309 if C = No_Check_Id then
5311 ("argument of pragma% is not valid check name", Arg1);
5314 if not Suppress_Case
5315 and then (C = All_Checks or else C = Overflow_Check)
5317 Opt.Overflow_Checks_Unsuppressed := True;
5320 if Arg_Count = 1 then
5322 -- Make an entry in the local scope suppress table. This is the
5323 -- table that directly shows the current value of the scope
5324 -- suppress check for any check id value.
5326 if C = All_Checks then
5328 -- For All_Checks, we set all specific predefined checks with
5329 -- the exception of Elaboration_Check, which is handled
5330 -- specially because of not wanting All_Checks to have the
5331 -- effect of deactivating static elaboration order processing.
5333 for J in Scope_Suppress'Range loop
5334 if J /= Elaboration_Check then
5335 Scope_Suppress (J) := Suppress_Case;
5339 -- If not All_Checks, and predefined check, then set appropriate
5340 -- scope entry. Note that we will set Elaboration_Check if this
5341 -- is explicitly specified.
5343 elsif C in Predefined_Check_Id then
5344 Scope_Suppress (C) := Suppress_Case;
5347 -- Also make an entry in the Local_Entity_Suppress table
5349 Push_Local_Suppress_Stack_Entry
5352 Suppress => Suppress_Case);
5354 -- Case of two arguments present, where the check is suppressed for
5355 -- a specified entity (given as the second argument of the pragma)
5358 -- This is obsolescent in Ada 2005 mode
5360 if Ada_Version >= Ada_2005 then
5361 Check_Restriction (No_Obsolescent_Features, Arg2);
5364 Check_Optional_Identifier (Arg2, Name_On);
5365 E_Id := Get_Pragma_Arg (Arg2);
5368 if not Is_Entity_Name (E_Id) then
5370 ("second argument of pragma% must be entity name", Arg2);
5379 -- Enforce RM 11.5(7) which requires that for a pragma that
5380 -- appears within a package spec, the named entity must be
5381 -- within the package spec. We allow the package name itself
5382 -- to be mentioned since that makes sense, although it is not
5383 -- strictly allowed by 11.5(7).
5386 and then E /= Current_Scope
5387 and then Scope (E) /= Current_Scope
5390 ("entity in pragma% is not in package spec (RM 11.5(7))",
5394 -- Loop through homonyms. As noted below, in the case of a package
5395 -- spec, only homonyms within the package spec are considered.
5398 Suppress_Unsuppress_Echeck (E, C);
5400 if Is_Generic_Instance (E)
5401 and then Is_Subprogram (E)
5402 and then Present (Alias (E))
5404 Suppress_Unsuppress_Echeck (Alias (E), C);
5407 -- Move to next homonym if not aspect spec case
5409 exit when From_Aspect_Specification (N);
5413 -- If we are within a package specification, the pragma only
5414 -- applies to homonyms in the same scope.
5416 exit when In_Package_Spec
5417 and then Scope (E) /= Current_Scope;
5420 end Process_Suppress_Unsuppress;
5426 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
5428 if Is_Imported (E) then
5430 ("cannot export entity& that was previously imported", Arg);
5432 elsif Present (Address_Clause (E)) and then not CodePeer_Mode then
5434 ("cannot export entity& that has an address clause", Arg);
5437 Set_Is_Exported (E);
5439 -- Generate a reference for entity explicitly, because the
5440 -- identifier may be overloaded and name resolution will not
5443 Generate_Reference (E, Arg);
5445 -- Deal with exporting non-library level entity
5447 if not Is_Library_Level_Entity (E) then
5449 -- Not allowed at all for subprograms
5451 if Is_Subprogram (E) then
5452 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
5454 -- Otherwise set public and statically allocated
5458 Set_Is_Statically_Allocated (E);
5460 -- Warn if the corresponding W flag is set and the pragma comes
5461 -- from source. The latter may not be true e.g. on VMS where we
5462 -- expand export pragmas for exception codes associated with
5463 -- imported or exported exceptions. We do not want to generate
5464 -- a warning for something that the user did not write.
5466 if Warn_On_Export_Import
5467 and then Comes_From_Source (Arg)
5470 ("?& has been made static as a result of Export", Arg, E);
5472 ("\this usage is non-standard and non-portable", Arg);
5477 if Warn_On_Export_Import and then Is_Type (E) then
5478 Error_Msg_NE ("exporting a type has no effect?", Arg, E);
5481 if Warn_On_Export_Import and Inside_A_Generic then
5483 ("all instances of& will have the same external name?", Arg, E);
5487 ----------------------------------------------
5488 -- Set_Extended_Import_Export_External_Name --
5489 ----------------------------------------------
5491 procedure Set_Extended_Import_Export_External_Name
5492 (Internal_Ent : Entity_Id;
5493 Arg_External : Node_Id)
5495 Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
5499 if No (Arg_External) then
5503 Check_Arg_Is_External_Name (Arg_External);
5505 if Nkind (Arg_External) = N_String_Literal then
5506 if String_Length (Strval (Arg_External)) = 0 then
5509 New_Name := Adjust_External_Name_Case (Arg_External);
5512 elsif Nkind (Arg_External) = N_Identifier then
5513 New_Name := Get_Default_External_Name (Arg_External);
5515 -- Check_Arg_Is_External_Name should let through only identifiers and
5516 -- string literals or static string expressions (which are folded to
5517 -- string literals).
5520 raise Program_Error;
5523 -- If we already have an external name set (by a prior normal Import
5524 -- or Export pragma), then the external names must match
5526 if Present (Interface_Name (Internal_Ent)) then
5527 Check_Matching_Internal_Names : declare
5528 S1 : constant String_Id := Strval (Old_Name);
5529 S2 : constant String_Id := Strval (New_Name);
5532 -- Called if names do not match
5538 procedure Mismatch is
5540 Error_Msg_Sloc := Sloc (Old_Name);
5542 ("external name does not match that given #",
5546 -- Start of processing for Check_Matching_Internal_Names
5549 if String_Length (S1) /= String_Length (S2) then
5553 for J in 1 .. String_Length (S1) loop
5554 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
5559 end Check_Matching_Internal_Names;
5561 -- Otherwise set the given name
5564 Set_Encoded_Interface_Name (Internal_Ent, New_Name);
5565 Check_Duplicated_Export_Name (New_Name);
5567 end Set_Extended_Import_Export_External_Name;
5573 procedure Set_Imported (E : Entity_Id) is
5575 -- Error message if already imported or exported
5577 if Is_Exported (E) or else Is_Imported (E) then
5579 -- Error if being set Exported twice
5581 if Is_Exported (E) then
5582 Error_Msg_NE ("entity& was previously exported", N, E);
5584 -- OK if Import/Interface case
5586 elsif Import_Interface_Present (N) then
5589 -- Error if being set Imported twice
5592 Error_Msg_NE ("entity& was previously imported", N, E);
5595 Error_Msg_Name_1 := Pname;
5597 ("\(pragma% applies to all previous entities)", N);
5599 Error_Msg_Sloc := Sloc (E);
5600 Error_Msg_NE ("\import not allowed for& declared#", N, E);
5602 -- Here if not previously imported or exported, OK to import
5605 Set_Is_Imported (E);
5607 -- If the entity is an object that is not at the library level,
5608 -- then it is statically allocated. We do not worry about objects
5609 -- with address clauses in this context since they are not really
5610 -- imported in the linker sense.
5613 and then not Is_Library_Level_Entity (E)
5614 and then No (Address_Clause (E))
5616 Set_Is_Statically_Allocated (E);
5623 -------------------------
5624 -- Set_Mechanism_Value --
5625 -------------------------
5627 -- Note: the mechanism name has not been analyzed (and cannot indeed be
5628 -- analyzed, since it is semantic nonsense), so we get it in the exact
5629 -- form created by the parser.
5631 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
5634 Mech_Name_Id : Name_Id;
5636 procedure Bad_Class;
5637 -- Signal bad descriptor class name
5639 procedure Bad_Mechanism;
5640 -- Signal bad mechanism name
5646 procedure Bad_Class is
5648 Error_Pragma_Arg ("unrecognized descriptor class name", Class);
5651 -------------------------
5652 -- Bad_Mechanism_Value --
5653 -------------------------
5655 procedure Bad_Mechanism is
5657 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
5660 -- Start of processing for Set_Mechanism_Value
5663 if Mechanism (Ent) /= Default_Mechanism then
5665 ("mechanism for & has already been set", Mech_Name, Ent);
5668 -- MECHANISM_NAME ::= value | reference | descriptor |
5671 if Nkind (Mech_Name) = N_Identifier then
5672 if Chars (Mech_Name) = Name_Value then
5673 Set_Mechanism (Ent, By_Copy);
5676 elsif Chars (Mech_Name) = Name_Reference then
5677 Set_Mechanism (Ent, By_Reference);
5680 elsif Chars (Mech_Name) = Name_Descriptor then
5681 Check_VMS (Mech_Name);
5683 -- Descriptor => Short_Descriptor if pragma was given
5685 if Short_Descriptors then
5686 Set_Mechanism (Ent, By_Short_Descriptor);
5688 Set_Mechanism (Ent, By_Descriptor);
5693 elsif Chars (Mech_Name) = Name_Short_Descriptor then
5694 Check_VMS (Mech_Name);
5695 Set_Mechanism (Ent, By_Short_Descriptor);
5698 elsif Chars (Mech_Name) = Name_Copy then
5700 ("bad mechanism name, Value assumed", Mech_Name);
5706 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
5707 -- short_descriptor (CLASS_NAME)
5708 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5710 -- Note: this form is parsed as an indexed component
5712 elsif Nkind (Mech_Name) = N_Indexed_Component then
5713 Class := First (Expressions (Mech_Name));
5715 if Nkind (Prefix (Mech_Name)) /= N_Identifier
5716 or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else
5717 Chars (Prefix (Mech_Name)) = Name_Short_Descriptor)
5718 or else Present (Next (Class))
5722 Mech_Name_Id := Chars (Prefix (Mech_Name));
5724 -- Change Descriptor => Short_Descriptor if pragma was given
5726 if Mech_Name_Id = Name_Descriptor
5727 and then Short_Descriptors
5729 Mech_Name_Id := Name_Short_Descriptor;
5733 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
5734 -- short_descriptor (Class => CLASS_NAME)
5735 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
5737 -- Note: this form is parsed as a function call
5739 elsif Nkind (Mech_Name) = N_Function_Call then
5740 Param := First (Parameter_Associations (Mech_Name));
5742 if Nkind (Name (Mech_Name)) /= N_Identifier
5743 or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else
5744 Chars (Name (Mech_Name)) = Name_Short_Descriptor)
5745 or else Present (Next (Param))
5746 or else No (Selector_Name (Param))
5747 or else Chars (Selector_Name (Param)) /= Name_Class
5751 Class := Explicit_Actual_Parameter (Param);
5752 Mech_Name_Id := Chars (Name (Mech_Name));
5759 -- Fall through here with Class set to descriptor class name
5761 Check_VMS (Mech_Name);
5763 if Nkind (Class) /= N_Identifier then
5766 elsif Mech_Name_Id = Name_Descriptor
5767 and then Chars (Class) = Name_UBS
5769 Set_Mechanism (Ent, By_Descriptor_UBS);
5771 elsif Mech_Name_Id = Name_Descriptor
5772 and then Chars (Class) = Name_UBSB
5774 Set_Mechanism (Ent, By_Descriptor_UBSB);
5776 elsif Mech_Name_Id = Name_Descriptor
5777 and then Chars (Class) = Name_UBA
5779 Set_Mechanism (Ent, By_Descriptor_UBA);
5781 elsif Mech_Name_Id = Name_Descriptor
5782 and then Chars (Class) = Name_S
5784 Set_Mechanism (Ent, By_Descriptor_S);
5786 elsif Mech_Name_Id = Name_Descriptor
5787 and then Chars (Class) = Name_SB
5789 Set_Mechanism (Ent, By_Descriptor_SB);
5791 elsif Mech_Name_Id = Name_Descriptor
5792 and then Chars (Class) = Name_A
5794 Set_Mechanism (Ent, By_Descriptor_A);
5796 elsif Mech_Name_Id = Name_Descriptor
5797 and then Chars (Class) = Name_NCA
5799 Set_Mechanism (Ent, By_Descriptor_NCA);
5801 elsif Mech_Name_Id = Name_Short_Descriptor
5802 and then Chars (Class) = Name_UBS
5804 Set_Mechanism (Ent, By_Short_Descriptor_UBS);
5806 elsif Mech_Name_Id = Name_Short_Descriptor
5807 and then Chars (Class) = Name_UBSB
5809 Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
5811 elsif Mech_Name_Id = Name_Short_Descriptor
5812 and then Chars (Class) = Name_UBA
5814 Set_Mechanism (Ent, By_Short_Descriptor_UBA);
5816 elsif Mech_Name_Id = Name_Short_Descriptor
5817 and then Chars (Class) = Name_S
5819 Set_Mechanism (Ent, By_Short_Descriptor_S);
5821 elsif Mech_Name_Id = Name_Short_Descriptor
5822 and then Chars (Class) = Name_SB
5824 Set_Mechanism (Ent, By_Short_Descriptor_SB);
5826 elsif Mech_Name_Id = Name_Short_Descriptor
5827 and then Chars (Class) = Name_A
5829 Set_Mechanism (Ent, By_Short_Descriptor_A);
5831 elsif Mech_Name_Id = Name_Short_Descriptor
5832 and then Chars (Class) = Name_NCA
5834 Set_Mechanism (Ent, By_Short_Descriptor_NCA);
5839 end Set_Mechanism_Value;
5841 ---------------------------
5842 -- Set_Ravenscar_Profile --
5843 ---------------------------
5845 -- The tasks to be done here are
5847 -- Set required policies
5849 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
5850 -- pragma Locking_Policy (Ceiling_Locking)
5852 -- Set Detect_Blocking mode
5854 -- Set required restrictions (see System.Rident for detailed list)
5856 -- Set the No_Dependence rules
5857 -- No_Dependence => Ada.Asynchronous_Task_Control
5858 -- No_Dependence => Ada.Calendar
5859 -- No_Dependence => Ada.Execution_Time.Group_Budget
5860 -- No_Dependence => Ada.Execution_Time.Timers
5861 -- No_Dependence => Ada.Task_Attributes
5862 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
5864 procedure Set_Ravenscar_Profile (N : Node_Id) is
5865 Prefix_Entity : Entity_Id;
5866 Selector_Entity : Entity_Id;
5867 Prefix_Node : Node_Id;
5871 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
5873 if Task_Dispatching_Policy /= ' '
5874 and then Task_Dispatching_Policy /= 'F'
5876 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
5877 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
5879 -- Set the FIFO_Within_Priorities policy, but always preserve
5880 -- System_Location since we like the error message with the run time
5884 Task_Dispatching_Policy := 'F';
5886 if Task_Dispatching_Policy_Sloc /= System_Location then
5887 Task_Dispatching_Policy_Sloc := Loc;
5891 -- pragma Locking_Policy (Ceiling_Locking)
5893 if Locking_Policy /= ' '
5894 and then Locking_Policy /= 'C'
5896 Error_Msg_Sloc := Locking_Policy_Sloc;
5897 Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
5899 -- Set the Ceiling_Locking policy, but preserve System_Location since
5900 -- we like the error message with the run time name.
5903 Locking_Policy := 'C';
5905 if Locking_Policy_Sloc /= System_Location then
5906 Locking_Policy_Sloc := Loc;
5910 -- pragma Detect_Blocking
5912 Detect_Blocking := True;
5914 -- Set the corresponding restrictions
5916 Set_Profile_Restrictions
5917 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
5919 -- Set the No_Dependence restrictions
5921 -- The following No_Dependence restrictions:
5922 -- No_Dependence => Ada.Asynchronous_Task_Control
5923 -- No_Dependence => Ada.Calendar
5924 -- No_Dependence => Ada.Task_Attributes
5925 -- are already set by previous call to Set_Profile_Restrictions.
5927 -- Set the following restrictions which were added to Ada 2005:
5928 -- No_Dependence => Ada.Execution_Time.Group_Budget
5929 -- No_Dependence => Ada.Execution_Time.Timers
5931 if Ada_Version >= Ada_2005 then
5932 Name_Buffer (1 .. 3) := "ada";
5935 Prefix_Entity := Make_Identifier (Loc, Name_Find);
5937 Name_Buffer (1 .. 14) := "execution_time";
5940 Selector_Entity := Make_Identifier (Loc, Name_Find);
5943 Make_Selected_Component
5945 Prefix => Prefix_Entity,
5946 Selector_Name => Selector_Entity);
5948 Name_Buffer (1 .. 13) := "group_budgets";
5951 Selector_Entity := Make_Identifier (Loc, Name_Find);
5954 Make_Selected_Component
5956 Prefix => Prefix_Node,
5957 Selector_Name => Selector_Entity);
5959 Set_Restriction_No_Dependence
5961 Warn => Treat_Restrictions_As_Warnings,
5962 Profile => Ravenscar);
5964 Name_Buffer (1 .. 6) := "timers";
5967 Selector_Entity := Make_Identifier (Loc, Name_Find);
5970 Make_Selected_Component
5972 Prefix => Prefix_Node,
5973 Selector_Name => Selector_Entity);
5975 Set_Restriction_No_Dependence
5977 Warn => Treat_Restrictions_As_Warnings,
5978 Profile => Ravenscar);
5981 -- Set the following restrictions which was added to Ada 2012 (see
5983 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
5985 if Ada_Version >= Ada_2012 then
5986 Name_Buffer (1 .. 6) := "system";
5989 Prefix_Entity := Make_Identifier (Loc, Name_Find);
5991 Name_Buffer (1 .. 15) := "multiprocessors";
5994 Selector_Entity := Make_Identifier (Loc, Name_Find);
5997 Make_Selected_Component
5999 Prefix => Prefix_Entity,
6000 Selector_Name => Selector_Entity);
6002 Name_Buffer (1 .. 19) := "dispatching_domains";
6005 Selector_Entity := Make_Identifier (Loc, Name_Find);
6008 Make_Selected_Component
6010 Prefix => Prefix_Node,
6011 Selector_Name => Selector_Entity);
6013 Set_Restriction_No_Dependence
6015 Warn => Treat_Restrictions_As_Warnings,
6016 Profile => Ravenscar);
6018 end Set_Ravenscar_Profile;
6020 -- Start of processing for Analyze_Pragma
6023 -- The following code is a defense against recursion. Not clear that
6024 -- this can happen legitimately, but perhaps some error situations
6025 -- can cause it, and we did see this recursion during testing.
6027 if Analyzed (N) then
6030 Set_Analyzed (N, True);
6033 -- Deal with unrecognized pragma
6035 if not Is_Pragma_Name (Pname) then
6036 if Warn_On_Unrecognized_Pragma then
6037 Error_Msg_Name_1 := Pname;
6038 Error_Msg_N ("?unrecognized pragma%!", Pragma_Identifier (N));
6040 for PN in First_Pragma_Name .. Last_Pragma_Name loop
6041 if Is_Bad_Spelling_Of (Pname, PN) then
6042 Error_Msg_Name_1 := PN;
6043 Error_Msg_N -- CODEFIX
6044 ("\?possible misspelling of %!", Pragma_Identifier (N));
6053 -- Here to start processing for recognized pragma
6055 Prag_Id := Get_Pragma_Id (Pname);
6065 if Present (Pragma_Argument_Associations (N)) then
6066 Arg_Count := List_Length (Pragma_Argument_Associations (N));
6067 Arg1 := First (Pragma_Argument_Associations (N));
6069 if Present (Arg1) then
6070 Arg2 := Next (Arg1);
6072 if Present (Arg2) then
6073 Arg3 := Next (Arg2);
6075 if Present (Arg3) then
6076 Arg4 := Next (Arg3);
6082 -- An enumeration type defines the pragmas that are supported by the
6083 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
6084 -- into the corresponding enumeration value for the following case.
6092 -- pragma Abort_Defer;
6094 when Pragma_Abort_Defer =>
6096 Check_Arg_Count (0);
6098 -- The only required semantic processing is to check the
6099 -- placement. This pragma must appear at the start of the
6100 -- statement sequence of a handled sequence of statements.
6102 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
6103 or else N /= First (Statements (Parent (N)))
6114 -- Note: this pragma also has some specific processing in Par.Prag
6115 -- because we want to set the Ada version mode during parsing.
6117 when Pragma_Ada_83 =>
6119 Check_Arg_Count (0);
6121 -- We really should check unconditionally for proper configuration
6122 -- pragma placement, since we really don't want mixed Ada modes
6123 -- within a single unit, and the GNAT reference manual has always
6124 -- said this was a configuration pragma, but we did not check and
6125 -- are hesitant to add the check now.
6127 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
6128 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
6129 -- or Ada 2012 mode.
6131 if Ada_Version >= Ada_2005 then
6132 Check_Valid_Configuration_Pragma;
6135 -- Now set Ada 83 mode
6137 Ada_Version := Ada_83;
6138 Ada_Version_Explicit := Ada_Version;
6146 -- Note: this pragma also has some specific processing in Par.Prag
6147 -- because we want to set the Ada 83 version mode during parsing.
6149 when Pragma_Ada_95 =>
6151 Check_Arg_Count (0);
6153 -- We really should check unconditionally for proper configuration
6154 -- pragma placement, since we really don't want mixed Ada modes
6155 -- within a single unit, and the GNAT reference manual has always
6156 -- said this was a configuration pragma, but we did not check and
6157 -- are hesitant to add the check now.
6159 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
6160 -- or Ada 95, so we must check if we are in Ada 2005 mode.
6162 if Ada_Version >= Ada_2005 then
6163 Check_Valid_Configuration_Pragma;
6166 -- Now set Ada 95 mode
6168 Ada_Version := Ada_95;
6169 Ada_Version_Explicit := Ada_Version;
6171 ---------------------
6172 -- Ada_05/Ada_2005 --
6173 ---------------------
6176 -- pragma Ada_05 (LOCAL_NAME);
6179 -- pragma Ada_2005 (LOCAL_NAME):
6181 -- Note: these pragmas also have some specific processing in Par.Prag
6182 -- because we want to set the Ada 2005 version mode during parsing.
6184 when Pragma_Ada_05 | Pragma_Ada_2005 => declare
6190 if Arg_Count = 1 then
6191 Check_Arg_Is_Local_Name (Arg1);
6192 E_Id := Get_Pragma_Arg (Arg1);
6194 if Etype (E_Id) = Any_Type then
6198 Set_Is_Ada_2005_Only (Entity (E_Id));
6201 Check_Arg_Count (0);
6203 -- For Ada_2005 we unconditionally enforce the documented
6204 -- configuration pragma placement, since we do not want to
6205 -- tolerate mixed modes in a unit involving Ada 2005. That
6206 -- would cause real difficulties for those cases where there
6207 -- are incompatibilities between Ada 95 and Ada 2005.
6209 Check_Valid_Configuration_Pragma;
6211 -- Now set appropriate Ada mode
6213 Ada_Version := Ada_2005;
6214 Ada_Version_Explicit := Ada_2005;
6218 ---------------------
6219 -- Ada_12/Ada_2012 --
6220 ---------------------
6223 -- pragma Ada_12 (LOCAL_NAME);
6226 -- pragma Ada_2012 (LOCAL_NAME):
6228 -- Note: these pragmas also have some specific processing in Par.Prag
6229 -- because we want to set the Ada 2012 version mode during parsing.
6231 when Pragma_Ada_12 | Pragma_Ada_2012 => declare
6237 if Arg_Count = 1 then
6238 Check_Arg_Is_Local_Name (Arg1);
6239 E_Id := Get_Pragma_Arg (Arg1);
6241 if Etype (E_Id) = Any_Type then
6245 Set_Is_Ada_2012_Only (Entity (E_Id));
6248 Check_Arg_Count (0);
6250 -- For Ada_2012 we unconditionally enforce the documented
6251 -- configuration pragma placement, since we do not want to
6252 -- tolerate mixed modes in a unit involving Ada 2012. That
6253 -- would cause real difficulties for those cases where there
6254 -- are incompatibilities between Ada 95 and Ada 2012. We could
6255 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
6257 Check_Valid_Configuration_Pragma;
6259 -- Now set appropriate Ada mode
6261 Ada_Version := Ada_2012;
6262 Ada_Version_Explicit := Ada_2012;
6266 ----------------------
6267 -- All_Calls_Remote --
6268 ----------------------
6270 -- pragma All_Calls_Remote [(library_package_NAME)];
6272 when Pragma_All_Calls_Remote => All_Calls_Remote : declare
6273 Lib_Entity : Entity_Id;
6276 Check_Ada_83_Warning;
6277 Check_Valid_Library_Unit_Pragma;
6279 if Nkind (N) = N_Null_Statement then
6283 Lib_Entity := Find_Lib_Unit_Name;
6285 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
6287 if Present (Lib_Entity)
6288 and then not Debug_Flag_U
6290 if not Is_Remote_Call_Interface (Lib_Entity) then
6291 Error_Pragma ("pragma% only apply to rci unit");
6293 -- Set flag for entity of the library unit
6296 Set_Has_All_Calls_Remote (Lib_Entity);
6300 end All_Calls_Remote;
6306 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
6307 -- ARG ::= NAME | EXPRESSION
6309 -- The first two arguments are by convention intended to refer to an
6310 -- external tool and a tool-specific function. These arguments are
6313 when Pragma_Annotate => Annotate : declare
6319 Check_At_Least_N_Arguments (1);
6320 Check_Arg_Is_Identifier (Arg1);
6321 Check_No_Identifiers;
6324 -- Second parameter is optional, it is never analyzed
6329 -- Here if we have a second parameter
6332 -- Second parameter must be identifier
6334 Check_Arg_Is_Identifier (Arg2);
6336 -- Process remaining parameters if any
6339 while Present (Arg) loop
6340 Exp := Get_Pragma_Arg (Arg);
6343 if Is_Entity_Name (Exp) then
6346 -- For string literals, we assume Standard_String as the
6347 -- type, unless the string contains wide or wide_wide
6350 elsif Nkind (Exp) = N_String_Literal then
6351 if Has_Wide_Wide_Character (Exp) then
6352 Resolve (Exp, Standard_Wide_Wide_String);
6353 elsif Has_Wide_Character (Exp) then
6354 Resolve (Exp, Standard_Wide_String);
6356 Resolve (Exp, Standard_String);
6359 elsif Is_Overloaded (Exp) then
6361 ("ambiguous argument for pragma%", Exp);
6376 -- pragma Assert ([Check =>] Boolean_EXPRESSION
6377 -- [, [Message =>] Static_String_EXPRESSION]);
6379 when Pragma_Assert => Assert : declare
6385 Check_At_Least_N_Arguments (1);
6386 Check_At_Most_N_Arguments (2);
6387 Check_Arg_Order ((Name_Check, Name_Message));
6388 Check_Optional_Identifier (Arg1, Name_Check);
6390 -- We treat pragma Assert as equivalent to:
6392 -- pragma Check (Assertion, condition [, msg]);
6394 -- So rewrite pragma in this manner, and analyze the result
6396 Expr := Get_Pragma_Arg (Arg1);
6398 Make_Pragma_Argument_Association (Loc,
6399 Expression => Make_Identifier (Loc, Name_Assertion)),
6401 Make_Pragma_Argument_Association (Sloc (Expr),
6402 Expression => Expr));
6404 if Arg_Count > 1 then
6405 Check_Optional_Identifier (Arg2, Name_Message);
6406 Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
6407 Append_To (Newa, Relocate_Node (Arg2));
6412 Chars => Name_Check,
6413 Pragma_Argument_Associations => Newa));
6417 ----------------------
6418 -- Assertion_Policy --
6419 ----------------------
6421 -- pragma Assertion_Policy (Check | Ignore)
6423 when Pragma_Assertion_Policy => Assertion_Policy : declare
6428 Check_Valid_Configuration_Pragma;
6429 Check_Arg_Count (1);
6430 Check_No_Identifiers;
6431 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
6433 -- We treat pragma Assertion_Policy as equivalent to:
6435 -- pragma Check_Policy (Assertion, policy)
6437 -- So rewrite the pragma in that manner and link on to the chain
6438 -- of Check_Policy pragmas, marking the pragma as analyzed.
6440 Policy := Get_Pragma_Arg (Arg1);
6444 Chars => Name_Check_Policy,
6446 Pragma_Argument_Associations => New_List (
6447 Make_Pragma_Argument_Association (Loc,
6448 Expression => Make_Identifier (Loc, Name_Assertion)),
6450 Make_Pragma_Argument_Association (Loc,
6452 Make_Identifier (Sloc (Policy), Chars (Policy))))));
6455 Set_Next_Pragma (N, Opt.Check_Policy_List);
6456 Opt.Check_Policy_List := N;
6457 end Assertion_Policy;
6459 ------------------------------
6460 -- Assume_No_Invalid_Values --
6461 ------------------------------
6463 -- pragma Assume_No_Invalid_Values (On | Off);
6465 when Pragma_Assume_No_Invalid_Values =>
6467 Check_Valid_Configuration_Pragma;
6468 Check_Arg_Count (1);
6469 Check_No_Identifiers;
6470 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
6472 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
6473 Assume_No_Invalid_Values := True;
6475 Assume_No_Invalid_Values := False;
6482 -- pragma AST_Entry (entry_IDENTIFIER);
6484 when Pragma_AST_Entry => AST_Entry : declare
6490 Check_Arg_Count (1);
6491 Check_No_Identifiers;
6492 Check_Arg_Is_Local_Name (Arg1);
6493 Ent := Entity (Get_Pragma_Arg (Arg1));
6495 -- Note: the implementation of the AST_Entry pragma could handle
6496 -- the entry family case fine, but for now we are consistent with
6497 -- the DEC rules, and do not allow the pragma, which of course
6498 -- has the effect of also forbidding the attribute.
6500 if Ekind (Ent) /= E_Entry then
6502 ("pragma% argument must be simple entry name", Arg1);
6504 elsif Is_AST_Entry (Ent) then
6506 ("duplicate % pragma for entry", Arg1);
6508 elsif Has_Homonym (Ent) then
6510 ("pragma% argument cannot specify overloaded entry", Arg1);
6514 FF : constant Entity_Id := First_Formal (Ent);
6517 if Present (FF) then
6518 if Present (Next_Formal (FF)) then
6520 ("entry for pragma% can have only one argument",
6523 elsif Parameter_Mode (FF) /= E_In_Parameter then
6525 ("entry parameter for pragma% must have mode IN",
6531 Set_Is_AST_Entry (Ent);
6539 -- pragma Asynchronous (LOCAL_NAME);
6541 when Pragma_Asynchronous => Asynchronous : declare
6549 procedure Process_Async_Pragma;
6550 -- Common processing for procedure and access-to-procedure case
6552 --------------------------
6553 -- Process_Async_Pragma --
6554 --------------------------
6556 procedure Process_Async_Pragma is
6559 Set_Is_Asynchronous (Nm);
6563 -- The formals should be of mode IN (RM E.4.1(6))
6566 while Present (S) loop
6567 Formal := Defining_Identifier (S);
6569 if Nkind (Formal) = N_Defining_Identifier
6570 and then Ekind (Formal) /= E_In_Parameter
6573 ("pragma% procedure can only have IN parameter",
6580 Set_Is_Asynchronous (Nm);
6581 end Process_Async_Pragma;
6583 -- Start of processing for pragma Asynchronous
6586 Check_Ada_83_Warning;
6587 Check_No_Identifiers;
6588 Check_Arg_Count (1);
6589 Check_Arg_Is_Local_Name (Arg1);
6591 if Debug_Flag_U then
6595 C_Ent := Cunit_Entity (Current_Sem_Unit);
6596 Analyze (Get_Pragma_Arg (Arg1));
6597 Nm := Entity (Get_Pragma_Arg (Arg1));
6599 if not Is_Remote_Call_Interface (C_Ent)
6600 and then not Is_Remote_Types (C_Ent)
6602 -- This pragma should only appear in an RCI or Remote Types
6603 -- unit (RM E.4.1(4)).
6606 ("pragma% not in Remote_Call_Interface or " &
6607 "Remote_Types unit");
6610 if Ekind (Nm) = E_Procedure
6611 and then Nkind (Parent (Nm)) = N_Procedure_Specification
6613 if not Is_Remote_Call_Interface (Nm) then
6615 ("pragma% cannot be applied on non-remote procedure",
6619 L := Parameter_Specifications (Parent (Nm));
6620 Process_Async_Pragma;
6623 elsif Ekind (Nm) = E_Function then
6625 ("pragma% cannot be applied to function", Arg1);
6627 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
6628 if Is_Record_Type (Nm) then
6630 -- A record type that is the Equivalent_Type for a remote
6631 -- access-to-subprogram type.
6633 N := Declaration_Node (Corresponding_Remote_Type (Nm));
6636 -- A non-expanded RAS type (distribution is not enabled)
6638 N := Declaration_Node (Nm);
6641 if Nkind (N) = N_Full_Type_Declaration
6642 and then Nkind (Type_Definition (N)) =
6643 N_Access_Procedure_Definition
6645 L := Parameter_Specifications (Type_Definition (N));
6646 Process_Async_Pragma;
6648 if Is_Asynchronous (Nm)
6649 and then Expander_Active
6650 and then Get_PCS_Name /= Name_No_DSA
6652 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
6657 ("pragma% cannot reference access-to-function type",
6661 -- Only other possibility is Access-to-class-wide type
6663 elsif Is_Access_Type (Nm)
6664 and then Is_Class_Wide_Type (Designated_Type (Nm))
6666 Check_First_Subtype (Arg1);
6667 Set_Is_Asynchronous (Nm);
6668 if Expander_Active then
6669 RACW_Type_Is_Asynchronous (Nm);
6673 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
6681 -- pragma Atomic (LOCAL_NAME);
6683 when Pragma_Atomic =>
6684 Process_Atomic_Shared_Volatile;
6686 -----------------------
6687 -- Atomic_Components --
6688 -----------------------
6690 -- pragma Atomic_Components (array_LOCAL_NAME);
6692 -- This processing is shared by Volatile_Components
6694 when Pragma_Atomic_Components |
6695 Pragma_Volatile_Components =>
6697 Atomic_Components : declare
6704 Check_Ada_83_Warning;
6705 Check_No_Identifiers;
6706 Check_Arg_Count (1);
6707 Check_Arg_Is_Local_Name (Arg1);
6708 E_Id := Get_Pragma_Arg (Arg1);
6710 if Etype (E_Id) = Any_Type then
6716 Check_Duplicate_Pragma (E);
6718 if Rep_Item_Too_Early (E, N)
6720 Rep_Item_Too_Late (E, N)
6725 D := Declaration_Node (E);
6728 if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
6730 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
6731 and then Nkind (D) = N_Object_Declaration
6732 and then Nkind (Object_Definition (D)) =
6733 N_Constrained_Array_Definition)
6735 -- The flag is set on the object, or on the base type
6737 if Nkind (D) /= N_Object_Declaration then
6741 Set_Has_Volatile_Components (E);
6743 if Prag_Id = Pragma_Atomic_Components then
6744 Set_Has_Atomic_Components (E);
6748 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6750 end Atomic_Components;
6752 --------------------
6753 -- Attach_Handler --
6754 --------------------
6756 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
6758 when Pragma_Attach_Handler =>
6759 Check_Ada_83_Warning;
6760 Check_No_Identifiers;
6761 Check_Arg_Count (2);
6763 if No_Run_Time_Mode then
6764 Error_Msg_CRT ("Attach_Handler pragma", N);
6766 Check_Interrupt_Or_Attach_Handler;
6768 -- The expression that designates the attribute may depend on a
6769 -- discriminant, and is therefore a per- object expression, to
6770 -- be expanded in the init proc. If expansion is enabled, then
6771 -- perform semantic checks on a copy only.
6773 if Expander_Active then
6775 Temp : constant Node_Id :=
6776 New_Copy_Tree (Get_Pragma_Arg (Arg2));
6778 Set_Parent (Temp, N);
6779 Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
6783 Analyze (Get_Pragma_Arg (Arg2));
6784 Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
6787 Process_Interrupt_Or_Attach_Handler;
6790 --------------------
6791 -- C_Pass_By_Copy --
6792 --------------------
6794 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
6796 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
6802 Check_Valid_Configuration_Pragma;
6803 Check_Arg_Count (1);
6804 Check_Optional_Identifier (Arg1, "max_size");
6806 Arg := Get_Pragma_Arg (Arg1);
6807 Check_Arg_Is_Static_Expression (Arg, Any_Integer);
6809 Val := Expr_Value (Arg);
6813 ("maximum size for pragma% must be positive", Arg1);
6815 elsif UI_Is_In_Int_Range (Val) then
6816 Default_C_Record_Mechanism := UI_To_Int (Val);
6818 -- If a giant value is given, Int'Last will do well enough.
6819 -- If sometime someone complains that a record larger than
6820 -- two gigabytes is not copied, we will worry about it then!
6823 Default_C_Record_Mechanism := Mechanism_Type'Last;
6831 -- pragma Check ([Name =>] IDENTIFIER,
6832 -- [Check =>] Boolean_EXPRESSION
6833 -- [,[Message =>] String_EXPRESSION]);
6835 when Pragma_Check => Check : declare
6840 -- Set True if category of assertions referenced by Name enabled
6844 Check_At_Least_N_Arguments (2);
6845 Check_At_Most_N_Arguments (3);
6846 Check_Optional_Identifier (Arg1, Name_Name);
6847 Check_Optional_Identifier (Arg2, Name_Check);
6849 if Arg_Count = 3 then
6850 Check_Optional_Identifier (Arg3, Name_Message);
6851 Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String);
6854 Check_Arg_Is_Identifier (Arg1);
6856 -- Indicate if pragma is enabled. The Original_Node reference here
6857 -- is to deal with pragma Assert rewritten as a Check pragma.
6859 Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
6862 Set_SCO_Pragma_Enabled (Loc);
6865 -- If expansion is active and the check is not enabled then we
6866 -- rewrite the Check as:
6868 -- if False and then condition then
6872 -- The reason we do this rewriting during semantic analysis rather
6873 -- than as part of normal expansion is that we cannot analyze and
6874 -- expand the code for the boolean expression directly, or it may
6875 -- cause insertion of actions that would escape the attempt to
6876 -- suppress the check code.
6878 -- Note that the Sloc for the if statement corresponds to the
6879 -- argument condition, not the pragma itself. The reason for this
6880 -- is that we may generate a warning if the condition is False at
6881 -- compile time, and we do not want to delete this warning when we
6882 -- delete the if statement.
6884 Expr := Get_Pragma_Arg (Arg2);
6886 if Expander_Active and then not Check_On then
6887 Eloc := Sloc (Expr);
6890 Make_If_Statement (Eloc,
6892 Make_And_Then (Eloc,
6893 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
6894 Right_Opnd => Expr),
6895 Then_Statements => New_List (
6896 Make_Null_Statement (Eloc))));
6903 Analyze_And_Resolve (Expr, Any_Boolean);
6911 -- pragma Check_Name (check_IDENTIFIER);
6913 when Pragma_Check_Name =>
6914 Check_No_Identifiers;
6916 Check_Valid_Configuration_Pragma;
6917 Check_Arg_Count (1);
6918 Check_Arg_Is_Identifier (Arg1);
6921 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
6924 for J in Check_Names.First .. Check_Names.Last loop
6925 if Check_Names.Table (J) = Nam then
6930 Check_Names.Append (Nam);
6937 -- pragma Check_Policy (
6938 -- [Name =>] IDENTIFIER,
6939 -- [Policy =>] POLICY_IDENTIFIER);
6941 -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE
6943 -- Note: this is a configuration pragma, but it is allowed to appear
6946 when Pragma_Check_Policy =>
6948 Check_Arg_Count (2);
6949 Check_Optional_Identifier (Arg1, Name_Name);
6950 Check_Optional_Identifier (Arg2, Name_Policy);
6952 (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore);
6954 -- A Check_Policy pragma can appear either as a configuration
6955 -- pragma, or in a declarative part or a package spec (see RM
6956 -- 11.5(5) for rules for Suppress/Unsuppress which are also
6957 -- followed for Check_Policy).
6959 if not Is_Configuration_Pragma then
6960 Check_Is_In_Decl_Part_Or_Package_Spec;
6963 Set_Next_Pragma (N, Opt.Check_Policy_List);
6964 Opt.Check_Policy_List := N;
6966 ---------------------
6967 -- CIL_Constructor --
6968 ---------------------
6970 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
6972 -- Processing for this pragma is shared with Java_Constructor
6978 -- pragma Comment (static_string_EXPRESSION)
6980 -- Processing for pragma Comment shares the circuitry for pragma
6981 -- Ident. The only differences are that Ident enforces a limit of 31
6982 -- characters on its argument, and also enforces limitations on
6983 -- placement for DEC compatibility. Pragma Comment shares neither of
6984 -- these restrictions.
6990 -- pragma Common_Object (
6991 -- [Internal =>] LOCAL_NAME
6992 -- [, [External =>] EXTERNAL_SYMBOL]
6993 -- [, [Size =>] EXTERNAL_SYMBOL]);
6995 -- Processing for this pragma is shared with Psect_Object
6997 ------------------------
6998 -- Compile_Time_Error --
6999 ------------------------
7001 -- pragma Compile_Time_Error
7002 -- (boolean_EXPRESSION, static_string_EXPRESSION);
7004 when Pragma_Compile_Time_Error =>
7006 Process_Compile_Time_Warning_Or_Error;
7008 --------------------------
7009 -- Compile_Time_Warning --
7010 --------------------------
7012 -- pragma Compile_Time_Warning
7013 -- (boolean_EXPRESSION, static_string_EXPRESSION);
7015 when Pragma_Compile_Time_Warning =>
7017 Process_Compile_Time_Warning_Or_Error;
7023 when Pragma_Compiler_Unit =>
7025 Check_Arg_Count (0);
7026 Set_Is_Compiler_Unit (Get_Source_Unit (N));
7028 -----------------------------
7029 -- Complete_Representation --
7030 -----------------------------
7032 -- pragma Complete_Representation;
7034 when Pragma_Complete_Representation =>
7036 Check_Arg_Count (0);
7038 if Nkind (Parent (N)) /= N_Record_Representation_Clause then
7040 ("pragma & must appear within record representation clause");
7043 ----------------------------
7044 -- Complex_Representation --
7045 ----------------------------
7047 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
7049 when Pragma_Complex_Representation => Complex_Representation : declare
7056 Check_Arg_Count (1);
7057 Check_Optional_Identifier (Arg1, Name_Entity);
7058 Check_Arg_Is_Local_Name (Arg1);
7059 E_Id := Get_Pragma_Arg (Arg1);
7061 if Etype (E_Id) = Any_Type then
7067 if not Is_Record_Type (E) then
7069 ("argument for pragma% must be record type", Arg1);
7072 Ent := First_Entity (E);
7075 or else No (Next_Entity (Ent))
7076 or else Present (Next_Entity (Next_Entity (Ent)))
7077 or else not Is_Floating_Point_Type (Etype (Ent))
7078 or else Etype (Ent) /= Etype (Next_Entity (Ent))
7081 ("record for pragma% must have two fields of the same "
7082 & "floating-point type", Arg1);
7085 Set_Has_Complex_Representation (Base_Type (E));
7087 -- We need to treat the type has having a non-standard
7088 -- representation, for back-end purposes, even though in
7089 -- general a complex will have the default representation
7090 -- of a record with two real components.
7092 Set_Has_Non_Standard_Rep (Base_Type (E));
7094 end Complex_Representation;
7096 -------------------------
7097 -- Component_Alignment --
7098 -------------------------
7100 -- pragma Component_Alignment (
7101 -- [Form =>] ALIGNMENT_CHOICE
7102 -- [, [Name =>] type_LOCAL_NAME]);
7104 -- ALIGNMENT_CHOICE ::=
7106 -- | Component_Size_4
7110 when Pragma_Component_Alignment => Component_AlignmentP : declare
7111 Args : Args_List (1 .. 2);
7112 Names : constant Name_List (1 .. 2) := (
7116 Form : Node_Id renames Args (1);
7117 Name : Node_Id renames Args (2);
7119 Atype : Component_Alignment_Kind;
7124 Gather_Associations (Names, Args);
7127 Error_Pragma ("missing Form argument for pragma%");
7130 Check_Arg_Is_Identifier (Form);
7132 -- Get proper alignment, note that Default = Component_Size on all
7133 -- machines we have so far, and we want to set this value rather
7134 -- than the default value to indicate that it has been explicitly
7135 -- set (and thus will not get overridden by the default component
7136 -- alignment for the current scope)
7138 if Chars (Form) = Name_Component_Size then
7139 Atype := Calign_Component_Size;
7141 elsif Chars (Form) = Name_Component_Size_4 then
7142 Atype := Calign_Component_Size_4;
7144 elsif Chars (Form) = Name_Default then
7145 Atype := Calign_Component_Size;
7147 elsif Chars (Form) = Name_Storage_Unit then
7148 Atype := Calign_Storage_Unit;
7152 ("invalid Form parameter for pragma%", Form);
7155 -- Case with no name, supplied, affects scope table entry
7159 (Scope_Stack.Last).Component_Alignment_Default := Atype;
7161 -- Case of name supplied
7164 Check_Arg_Is_Local_Name (Name);
7166 Typ := Entity (Name);
7169 or else Rep_Item_Too_Early (Typ, N)
7173 Typ := Underlying_Type (Typ);
7176 if not Is_Record_Type (Typ)
7177 and then not Is_Array_Type (Typ)
7180 ("Name parameter of pragma% must identify record or " &
7181 "array type", Name);
7184 -- An explicit Component_Alignment pragma overrides an
7185 -- implicit pragma Pack, but not an explicit one.
7187 if not Has_Pragma_Pack (Base_Type (Typ)) then
7188 Set_Is_Packed (Base_Type (Typ), False);
7189 Set_Component_Alignment (Base_Type (Typ), Atype);
7192 end Component_AlignmentP;
7198 -- pragma Controlled (first_subtype_LOCAL_NAME);
7200 when Pragma_Controlled => Controlled : declare
7204 Check_No_Identifiers;
7205 Check_Arg_Count (1);
7206 Check_Arg_Is_Local_Name (Arg1);
7207 Arg := Get_Pragma_Arg (Arg1);
7209 if not Is_Entity_Name (Arg)
7210 or else not Is_Access_Type (Entity (Arg))
7212 Error_Pragma_Arg ("pragma% requires access type", Arg1);
7214 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
7222 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
7223 -- [Entity =>] LOCAL_NAME);
7225 when Pragma_Convention => Convention : declare
7228 pragma Warnings (Off, C);
7229 pragma Warnings (Off, E);
7231 Check_Arg_Order ((Name_Convention, Name_Entity));
7232 Check_Ada_83_Warning;
7233 Check_Arg_Count (2);
7234 Process_Convention (C, E);
7237 ---------------------------
7238 -- Convention_Identifier --
7239 ---------------------------
7241 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
7242 -- [Convention =>] convention_IDENTIFIER);
7244 when Pragma_Convention_Identifier => Convention_Identifier : declare
7250 Check_Arg_Order ((Name_Name, Name_Convention));
7251 Check_Arg_Count (2);
7252 Check_Optional_Identifier (Arg1, Name_Name);
7253 Check_Optional_Identifier (Arg2, Name_Convention);
7254 Check_Arg_Is_Identifier (Arg1);
7255 Check_Arg_Is_Identifier (Arg2);
7256 Idnam := Chars (Get_Pragma_Arg (Arg1));
7257 Cname := Chars (Get_Pragma_Arg (Arg2));
7259 if Is_Convention_Name (Cname) then
7260 Record_Convention_Identifier
7261 (Idnam, Get_Convention_Id (Cname));
7264 ("second arg for % pragma must be convention", Arg2);
7266 end Convention_Identifier;
7272 -- pragma CPP_Class ([Entity =>] local_NAME)
7274 when Pragma_CPP_Class => CPP_Class : declare
7279 if Warn_On_Obsolescent_Feature then
7281 ("'G'N'A'T pragma cpp'_class is now obsolete; replace it" &
7282 " by pragma import?", N);
7286 Check_Arg_Count (1);
7287 Check_Optional_Identifier (Arg1, Name_Entity);
7288 Check_Arg_Is_Local_Name (Arg1);
7290 Arg := Get_Pragma_Arg (Arg1);
7293 if Etype (Arg) = Any_Type then
7297 if not Is_Entity_Name (Arg)
7298 or else not Is_Type (Entity (Arg))
7300 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
7303 Typ := Entity (Arg);
7305 if not Is_Tagged_Type (Typ) then
7306 Error_Pragma_Arg ("pragma% applicable to tagged types ", Arg1);
7309 -- Types treated as CPP classes must be declared limited (note:
7310 -- this used to be a warning but there is no real benefit to it
7311 -- since we did effectively intend to treat the type as limited
7314 if not Is_Limited_Type (Typ) then
7316 ("imported 'C'P'P type must be limited",
7317 Get_Pragma_Arg (Arg1));
7320 Set_Is_CPP_Class (Typ);
7321 Set_Convention (Typ, Convention_CPP);
7323 -- Imported CPP types must not have discriminants (because C++
7324 -- classes do not have discriminants).
7326 if Has_Discriminants (Typ) then
7328 ("imported 'C'P'P type cannot have discriminants",
7329 First (Discriminant_Specifications
7330 (Declaration_Node (Typ))));
7333 -- Components of imported CPP types must not have default
7334 -- expressions because the constructor (if any) is in the
7337 if Is_Incomplete_Or_Private_Type (Typ)
7338 and then No (Underlying_Type (Typ))
7340 -- It should be an error to apply pragma CPP to a private
7341 -- type if the underlying type is not visible (as it is
7342 -- for any representation item). For now, for backward
7343 -- compatibility we do nothing but we cannot check components
7344 -- because they are not available at this stage. All this code
7345 -- will be removed when we cleanup this obsolete GNAT pragma???
7351 Tdef : constant Node_Id :=
7352 Type_Definition (Declaration_Node (Typ));
7357 if Nkind (Tdef) = N_Record_Definition then
7358 Clist := Component_List (Tdef);
7360 pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
7361 Clist := Component_List (Record_Extension_Part (Tdef));
7364 if Present (Clist) then
7365 Comp := First (Component_Items (Clist));
7366 while Present (Comp) loop
7367 if Present (Expression (Comp)) then
7369 ("component of imported 'C'P'P type cannot have" &
7370 " default expression", Expression (Comp));
7380 ---------------------
7381 -- CPP_Constructor --
7382 ---------------------
7384 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
7385 -- [, [External_Name =>] static_string_EXPRESSION ]
7386 -- [, [Link_Name =>] static_string_EXPRESSION ]);
7388 when Pragma_CPP_Constructor => CPP_Constructor : declare
7392 Tag_Typ : Entity_Id;
7396 Check_At_Least_N_Arguments (1);
7397 Check_At_Most_N_Arguments (3);
7398 Check_Optional_Identifier (Arg1, Name_Entity);
7399 Check_Arg_Is_Local_Name (Arg1);
7401 Id := Get_Pragma_Arg (Arg1);
7402 Find_Program_Unit_Name (Id);
7404 -- If we did not find the name, we are done
7406 if Etype (Id) = Any_Type then
7410 Def_Id := Entity (Id);
7412 -- Check if already defined as constructor
7414 if Is_Constructor (Def_Id) then
7416 ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1);
7420 if Ekind (Def_Id) = E_Function
7421 and then (Is_CPP_Class (Etype (Def_Id))
7422 or else (Is_Class_Wide_Type (Etype (Def_Id))
7424 Is_CPP_Class (Root_Type (Etype (Def_Id)))))
7426 if Arg_Count >= 2 then
7427 Set_Imported (Def_Id);
7428 Set_Is_Public (Def_Id);
7429 Process_Interface_Name (Def_Id, Arg2, Arg3);
7432 Set_Has_Completion (Def_Id);
7433 Set_Is_Constructor (Def_Id);
7435 -- Imported C++ constructors are not dispatching primitives
7436 -- because in C++ they don't have a dispatch table slot.
7437 -- However, in Ada the constructor has the profile of a
7438 -- function that returns a tagged type and therefore it has
7439 -- been treated as a primitive operation during semantic
7440 -- analysis. We now remove it from the list of primitive
7441 -- operations of the type.
7443 if Is_Tagged_Type (Etype (Def_Id))
7444 and then not Is_Class_Wide_Type (Etype (Def_Id))
7446 pragma Assert (Is_Dispatching_Operation (Def_Id));
7447 Tag_Typ := Etype (Def_Id);
7449 Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
7450 while Present (Elmt) and then Node (Elmt) /= Def_Id loop
7454 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
7455 Set_Is_Dispatching_Operation (Def_Id, False);
7458 -- For backward compatibility, if the constructor returns a
7459 -- class wide type, and we internally change the return type to
7460 -- the corresponding root type.
7462 if Is_Class_Wide_Type (Etype (Def_Id)) then
7463 Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
7467 ("pragma% requires function returning a 'C'P'P_Class type",
7470 end CPP_Constructor;
7476 when Pragma_CPP_Virtual => CPP_Virtual : declare
7480 if Warn_On_Obsolescent_Feature then
7482 ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " &
7491 when Pragma_CPP_Vtable => CPP_Vtable : declare
7495 if Warn_On_Obsolescent_Feature then
7497 ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
7506 -- pragma CPU (EXPRESSION);
7508 when Pragma_CPU => CPU : declare
7509 P : constant Node_Id := Parent (N);
7514 Check_No_Identifiers;
7515 Check_Arg_Count (1);
7519 if Nkind (P) = N_Subprogram_Body then
7520 Check_In_Main_Program;
7522 Arg := Get_Pragma_Arg (Arg1);
7523 Analyze_And_Resolve (Arg, Any_Integer);
7527 if not Is_Static_Expression (Arg) then
7528 Flag_Non_Static_Expr
7529 ("main subprogram affinity is not static!", Arg);
7532 -- If constraint error, then we already signalled an error
7534 elsif Raises_Constraint_Error (Arg) then
7537 -- Otherwise check in range
7541 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
7542 -- This is the entity System.Multiprocessors.CPU_Range;
7544 Val : constant Uint := Expr_Value (Arg);
7547 if Val < Expr_Value (Type_Low_Bound (CPU_Id))
7549 Val > Expr_Value (Type_High_Bound (CPU_Id))
7552 ("main subprogram CPU is out of range", Arg1);
7558 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
7562 elsif Nkind (P) = N_Task_Definition then
7563 Arg := Get_Pragma_Arg (Arg1);
7565 -- The expression must be analyzed in the special manner
7566 -- described in "Handling of Default and Per-Object
7567 -- Expressions" in sem.ads.
7569 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
7571 -- Anything else is incorrect
7577 if Has_Pragma_CPU (P) then
7578 Error_Pragma ("duplicate pragma% not allowed");
7580 Set_Has_Pragma_CPU (P, True);
7582 if Nkind (P) = N_Task_Definition then
7583 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
7592 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
7594 when Pragma_Debug => Debug : declare
7603 (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active),
7606 if Arg_Count = 2 then
7609 Left_Opnd => Relocate_Node (Cond),
7610 Right_Opnd => Get_Pragma_Arg (Arg1));
7611 Call := Get_Pragma_Arg (Arg2);
7613 Call := Get_Pragma_Arg (Arg1);
7617 N_Indexed_Component,
7620 N_Selected_Component)
7622 -- If this pragma Debug comes from source, its argument was
7623 -- parsed as a name form (which is syntactically identical).
7624 -- Change it to a procedure call statement now.
7626 Change_Name_To_Procedure_Call_Statement (Call);
7628 elsif Nkind (Call) = N_Procedure_Call_Statement then
7630 -- Already in the form of a procedure call statement: nothing
7631 -- to do (could happen in case of an internally generated
7637 -- All other cases: diagnose error
7640 ("argument of pragma% is not procedure call", Sloc (Call));
7644 -- Rewrite into a conditional with an appropriate condition. We
7645 -- wrap the procedure call in a block so that overhead from e.g.
7646 -- use of the secondary stack does not generate execution overhead
7647 -- for suppressed conditions.
7649 Rewrite (N, Make_Implicit_If_Statement (N,
7651 Then_Statements => New_List (
7652 Make_Block_Statement (Loc,
7653 Handled_Statement_Sequence =>
7654 Make_Handled_Sequence_Of_Statements (Loc,
7655 Statements => New_List (Relocate_Node (Call)))))));
7663 -- pragma Debug_Policy (Check | Ignore)
7665 when Pragma_Debug_Policy =>
7667 Check_Arg_Count (1);
7668 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
7669 Debug_Pragmas_Enabled :=
7670 Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
7672 ---------------------
7673 -- Detect_Blocking --
7674 ---------------------
7676 -- pragma Detect_Blocking;
7678 when Pragma_Detect_Blocking =>
7680 Check_Arg_Count (0);
7681 Check_Valid_Configuration_Pragma;
7682 Detect_Blocking := True;
7684 --------------------------
7685 -- Default_Storage_Pool --
7686 --------------------------
7688 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
7690 when Pragma_Default_Storage_Pool =>
7692 Check_Arg_Count (1);
7694 -- Default_Storage_Pool can appear as a configuration pragma, or
7695 -- in a declarative part or a package spec.
7697 if not Is_Configuration_Pragma then
7698 Check_Is_In_Decl_Part_Or_Package_Spec;
7701 -- Case of Default_Storage_Pool (null);
7703 if Nkind (Expression (Arg1)) = N_Null then
7704 Analyze (Expression (Arg1));
7706 -- This is an odd case, this is not really an expression, so
7707 -- we don't have a type for it. So just set the type to Empty.
7709 Set_Etype (Expression (Arg1), Empty);
7711 -- Case of Default_Storage_Pool (storage_pool_NAME);
7714 -- If it's a configuration pragma, then the only allowed
7715 -- argument is "null".
7717 if Is_Configuration_Pragma then
7718 Error_Pragma_Arg ("NULL expected", Arg1);
7721 -- The expected type for a non-"null" argument is
7722 -- Root_Storage_Pool'Class.
7725 (Get_Pragma_Arg (Arg1),
7726 Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
7729 -- Finally, record the pool name (or null). Freeze.Freeze_Entity
7730 -- for an access type will use this information to set the
7731 -- appropriate attributes of the access type.
7733 Default_Pool := Expression (Arg1);
7739 when Pragma_Dimension =>
7741 Check_Arg_Count (4);
7742 Check_No_Identifiers;
7743 Check_Arg_Is_Local_Name (Arg1);
7745 if not Is_Type (Arg1) then
7746 Error_Pragma ("first argument for pragma% must be subtype");
7749 Check_Arg_Is_Static_Expression (Arg2, Standard_Integer);
7750 Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
7751 Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
7757 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
7759 when Pragma_Discard_Names => Discard_Names : declare
7764 Check_Ada_83_Warning;
7766 -- Deal with configuration pragma case
7768 if Arg_Count = 0 and then Is_Configuration_Pragma then
7769 Global_Discard_Names := True;
7772 -- Otherwise, check correct appropriate context
7775 Check_Is_In_Decl_Part_Or_Package_Spec;
7777 if Arg_Count = 0 then
7779 -- If there is no parameter, then from now on this pragma
7780 -- applies to any enumeration, exception or tagged type
7781 -- defined in the current declarative part, and recursively
7782 -- to any nested scope.
7784 Set_Discard_Names (Current_Scope);
7788 Check_Arg_Count (1);
7789 Check_Optional_Identifier (Arg1, Name_On);
7790 Check_Arg_Is_Local_Name (Arg1);
7792 E_Id := Get_Pragma_Arg (Arg1);
7794 if Etype (E_Id) = Any_Type then
7800 if (Is_First_Subtype (E)
7802 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
7803 or else Ekind (E) = E_Exception
7805 Set_Discard_Names (E);
7808 ("inappropriate entity for pragma%", Arg1);
7819 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
7821 when Pragma_Elaborate => Elaborate : declare
7826 -- Pragma must be in context items list of a compilation unit
7828 if not Is_In_Context_Clause then
7832 -- Must be at least one argument
7834 if Arg_Count = 0 then
7835 Error_Pragma ("pragma% requires at least one argument");
7838 -- In Ada 83 mode, there can be no items following it in the
7839 -- context list except other pragmas and implicit with clauses
7840 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
7841 -- placement rule does not apply.
7843 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
7845 while Present (Citem) loop
7846 if Nkind (Citem) = N_Pragma
7847 or else (Nkind (Citem) = N_With_Clause
7848 and then Implicit_With (Citem))
7853 ("(Ada 83) pragma% must be at end of context clause");
7860 -- Finally, the arguments must all be units mentioned in a with
7861 -- clause in the same context clause. Note we already checked (in
7862 -- Par.Prag) that the arguments are all identifiers or selected
7866 Outer : while Present (Arg) loop
7867 Citem := First (List_Containing (N));
7868 Inner : while Citem /= N loop
7869 if Nkind (Citem) = N_With_Clause
7870 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
7872 Set_Elaborate_Present (Citem, True);
7873 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
7874 Generate_Reference (Entity (Name (Citem)), Citem);
7876 -- With the pragma present, elaboration calls on
7877 -- subprograms from the named unit need no further
7878 -- checks, as long as the pragma appears in the current
7879 -- compilation unit. If the pragma appears in some unit
7880 -- in the context, there might still be a need for an
7881 -- Elaborate_All_Desirable from the current compilation
7882 -- to the named unit, so we keep the check enabled.
7884 if In_Extended_Main_Source_Unit (N) then
7885 Set_Suppress_Elaboration_Warnings
7886 (Entity (Name (Citem)));
7897 ("argument of pragma% is not with'ed unit", Arg);
7903 -- Give a warning if operating in static mode with -gnatwl
7904 -- (elaboration warnings enabled) switch set.
7906 if Elab_Warnings and not Dynamic_Elaboration_Checks then
7908 ("?use of pragma Elaborate may not be safe", N);
7910 ("?use pragma Elaborate_All instead if possible", N);
7918 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
7920 when Pragma_Elaborate_All => Elaborate_All : declare
7925 Check_Ada_83_Warning;
7927 -- Pragma must be in context items list of a compilation unit
7929 if not Is_In_Context_Clause then
7933 -- Must be at least one argument
7935 if Arg_Count = 0 then
7936 Error_Pragma ("pragma% requires at least one argument");
7939 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
7940 -- have to appear at the end of the context clause, but may
7941 -- appear mixed in with other items, even in Ada 83 mode.
7943 -- Final check: the arguments must all be units mentioned in
7944 -- a with clause in the same context clause. Note that we
7945 -- already checked (in Par.Prag) that all the arguments are
7946 -- either identifiers or selected components.
7949 Outr : while Present (Arg) loop
7950 Citem := First (List_Containing (N));
7951 Innr : while Citem /= N loop
7952 if Nkind (Citem) = N_With_Clause
7953 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
7955 Set_Elaborate_All_Present (Citem, True);
7956 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
7958 -- Suppress warnings and elaboration checks on the named
7959 -- unit if the pragma is in the current compilation, as
7960 -- for pragma Elaborate.
7962 if In_Extended_Main_Source_Unit (N) then
7963 Set_Suppress_Elaboration_Warnings
7964 (Entity (Name (Citem)));
7973 Set_Error_Posted (N);
7975 ("argument of pragma% is not with'ed unit", Arg);
7982 --------------------
7983 -- Elaborate_Body --
7984 --------------------
7986 -- pragma Elaborate_Body [( library_unit_NAME )];
7988 when Pragma_Elaborate_Body => Elaborate_Body : declare
7989 Cunit_Node : Node_Id;
7990 Cunit_Ent : Entity_Id;
7993 Check_Ada_83_Warning;
7994 Check_Valid_Library_Unit_Pragma;
7996 if Nkind (N) = N_Null_Statement then
8000 Cunit_Node := Cunit (Current_Sem_Unit);
8001 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
8003 if Nkind_In (Unit (Cunit_Node), N_Package_Body,
8006 Error_Pragma ("pragma% must refer to a spec, not a body");
8008 Set_Body_Required (Cunit_Node, True);
8009 Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
8011 -- If we are in dynamic elaboration mode, then we suppress
8012 -- elaboration warnings for the unit, since it is definitely
8013 -- fine NOT to do dynamic checks at the first level (and such
8014 -- checks will be suppressed because no elaboration boolean
8015 -- is created for Elaborate_Body packages).
8017 -- But in the static model of elaboration, Elaborate_Body is
8018 -- definitely NOT good enough to ensure elaboration safety on
8019 -- its own, since the body may WITH other units that are not
8020 -- safe from an elaboration point of view, so a client must
8021 -- still do an Elaborate_All on such units.
8023 -- Debug flag -gnatdD restores the old behavior of 3.13, where
8024 -- Elaborate_Body always suppressed elab warnings.
8026 if Dynamic_Elaboration_Checks or Debug_Flag_DD then
8027 Set_Suppress_Elaboration_Warnings (Cunit_Ent);
8032 ------------------------
8033 -- Elaboration_Checks --
8034 ------------------------
8036 -- pragma Elaboration_Checks (Static | Dynamic);
8038 when Pragma_Elaboration_Checks =>
8040 Check_Arg_Count (1);
8041 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
8042 Dynamic_Elaboration_Checks :=
8043 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
8049 -- pragma Eliminate (
8050 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
8051 -- [,[Entity =>] IDENTIFIER |
8052 -- SELECTED_COMPONENT |
8054 -- [, OVERLOADING_RESOLUTION]);
8056 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
8059 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
8062 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
8064 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
8065 -- Result_Type => result_SUBTYPE_NAME]
8067 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
8068 -- SUBTYPE_NAME ::= STRING_LITERAL
8070 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
8071 -- SOURCE_TRACE ::= STRING_LITERAL
8073 when Pragma_Eliminate => Eliminate : declare
8074 Args : Args_List (1 .. 5);
8075 Names : constant Name_List (1 .. 5) := (
8078 Name_Parameter_Types,
8080 Name_Source_Location);
8082 Unit_Name : Node_Id renames Args (1);
8083 Entity : Node_Id renames Args (2);
8084 Parameter_Types : Node_Id renames Args (3);
8085 Result_Type : Node_Id renames Args (4);
8086 Source_Location : Node_Id renames Args (5);
8090 Check_Valid_Configuration_Pragma;
8091 Gather_Associations (Names, Args);
8093 if No (Unit_Name) then
8094 Error_Pragma ("missing Unit_Name argument for pragma%");
8098 and then (Present (Parameter_Types)
8100 Present (Result_Type)
8102 Present (Source_Location))
8104 Error_Pragma ("missing Entity argument for pragma%");
8107 if (Present (Parameter_Types)
8109 Present (Result_Type))
8111 Present (Source_Location)
8114 ("parameter profile and source location cannot " &
8115 "be used together in pragma%");
8118 Process_Eliminate_Pragma
8132 -- [ Convention =>] convention_IDENTIFIER,
8133 -- [ Entity =>] local_NAME
8134 -- [, [External_Name =>] static_string_EXPRESSION ]
8135 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8137 when Pragma_Export => Export : declare
8141 pragma Warnings (Off, C);
8144 Check_Ada_83_Warning;
8150 Check_At_Least_N_Arguments (2);
8151 Check_At_Most_N_Arguments (4);
8152 Process_Convention (C, Def_Id);
8154 if Ekind (Def_Id) /= E_Constant then
8155 Note_Possible_Modification
8156 (Get_Pragma_Arg (Arg2), Sure => False);
8159 Process_Interface_Name (Def_Id, Arg3, Arg4);
8160 Set_Exported (Def_Id, Arg2);
8162 -- If the entity is a deferred constant, propagate the information
8163 -- to the full view, because gigi elaborates the full view only.
8165 if Ekind (Def_Id) = E_Constant
8166 and then Present (Full_View (Def_Id))
8169 Id2 : constant Entity_Id := Full_View (Def_Id);
8171 Set_Is_Exported (Id2, Is_Exported (Def_Id));
8172 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
8173 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
8178 ----------------------
8179 -- Export_Exception --
8180 ----------------------
8182 -- pragma Export_Exception (
8183 -- [Internal =>] LOCAL_NAME
8184 -- [, [External =>] EXTERNAL_SYMBOL]
8185 -- [, [Form =>] Ada | VMS]
8186 -- [, [Code =>] static_integer_EXPRESSION]);
8188 when Pragma_Export_Exception => Export_Exception : declare
8189 Args : Args_List (1 .. 4);
8190 Names : constant Name_List (1 .. 4) := (
8196 Internal : Node_Id renames Args (1);
8197 External : Node_Id renames Args (2);
8198 Form : Node_Id renames Args (3);
8199 Code : Node_Id renames Args (4);
8204 if Inside_A_Generic then
8205 Error_Pragma ("pragma% cannot be used for generic entities");
8208 Gather_Associations (Names, Args);
8209 Process_Extended_Import_Export_Exception_Pragma (
8210 Arg_Internal => Internal,
8211 Arg_External => External,
8215 if not Is_VMS_Exception (Entity (Internal)) then
8216 Set_Exported (Entity (Internal), Internal);
8218 end Export_Exception;
8220 ---------------------
8221 -- Export_Function --
8222 ---------------------
8224 -- pragma Export_Function (
8225 -- [Internal =>] LOCAL_NAME
8226 -- [, [External =>] EXTERNAL_SYMBOL]
8227 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8228 -- [, [Result_Type =>] TYPE_DESIGNATOR]
8229 -- [, [Mechanism =>] MECHANISM]
8230 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
8232 -- EXTERNAL_SYMBOL ::=
8234 -- | static_string_EXPRESSION
8236 -- PARAMETER_TYPES ::=
8238 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8240 -- TYPE_DESIGNATOR ::=
8242 -- | subtype_Name ' Access
8246 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8248 -- MECHANISM_ASSOCIATION ::=
8249 -- [formal_parameter_NAME =>] MECHANISM_NAME
8251 -- MECHANISM_NAME ::=
8254 -- | Descriptor [([Class =>] CLASS_NAME)]
8256 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8258 when Pragma_Export_Function => Export_Function : declare
8259 Args : Args_List (1 .. 6);
8260 Names : constant Name_List (1 .. 6) := (
8263 Name_Parameter_Types,
8266 Name_Result_Mechanism);
8268 Internal : Node_Id renames Args (1);
8269 External : Node_Id renames Args (2);
8270 Parameter_Types : Node_Id renames Args (3);
8271 Result_Type : Node_Id renames Args (4);
8272 Mechanism : Node_Id renames Args (5);
8273 Result_Mechanism : Node_Id renames Args (6);
8277 Gather_Associations (Names, Args);
8278 Process_Extended_Import_Export_Subprogram_Pragma (
8279 Arg_Internal => Internal,
8280 Arg_External => External,
8281 Arg_Parameter_Types => Parameter_Types,
8282 Arg_Result_Type => Result_Type,
8283 Arg_Mechanism => Mechanism,
8284 Arg_Result_Mechanism => Result_Mechanism);
8285 end Export_Function;
8291 -- pragma Export_Object (
8292 -- [Internal =>] LOCAL_NAME
8293 -- [, [External =>] EXTERNAL_SYMBOL]
8294 -- [, [Size =>] EXTERNAL_SYMBOL]);
8296 -- EXTERNAL_SYMBOL ::=
8298 -- | static_string_EXPRESSION
8300 -- PARAMETER_TYPES ::=
8302 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8304 -- TYPE_DESIGNATOR ::=
8306 -- | subtype_Name ' Access
8310 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8312 -- MECHANISM_ASSOCIATION ::=
8313 -- [formal_parameter_NAME =>] MECHANISM_NAME
8315 -- MECHANISM_NAME ::=
8318 -- | Descriptor [([Class =>] CLASS_NAME)]
8320 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8322 when Pragma_Export_Object => Export_Object : declare
8323 Args : Args_List (1 .. 3);
8324 Names : constant Name_List (1 .. 3) := (
8329 Internal : Node_Id renames Args (1);
8330 External : Node_Id renames Args (2);
8331 Size : Node_Id renames Args (3);
8335 Gather_Associations (Names, Args);
8336 Process_Extended_Import_Export_Object_Pragma (
8337 Arg_Internal => Internal,
8338 Arg_External => External,
8342 ----------------------
8343 -- Export_Procedure --
8344 ----------------------
8346 -- pragma Export_Procedure (
8347 -- [Internal =>] LOCAL_NAME
8348 -- [, [External =>] EXTERNAL_SYMBOL]
8349 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8350 -- [, [Mechanism =>] MECHANISM]);
8352 -- EXTERNAL_SYMBOL ::=
8354 -- | static_string_EXPRESSION
8356 -- PARAMETER_TYPES ::=
8358 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8360 -- TYPE_DESIGNATOR ::=
8362 -- | subtype_Name ' Access
8366 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8368 -- MECHANISM_ASSOCIATION ::=
8369 -- [formal_parameter_NAME =>] MECHANISM_NAME
8371 -- MECHANISM_NAME ::=
8374 -- | Descriptor [([Class =>] CLASS_NAME)]
8376 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8378 when Pragma_Export_Procedure => Export_Procedure : declare
8379 Args : Args_List (1 .. 4);
8380 Names : constant Name_List (1 .. 4) := (
8383 Name_Parameter_Types,
8386 Internal : Node_Id renames Args (1);
8387 External : Node_Id renames Args (2);
8388 Parameter_Types : Node_Id renames Args (3);
8389 Mechanism : Node_Id renames Args (4);
8393 Gather_Associations (Names, Args);
8394 Process_Extended_Import_Export_Subprogram_Pragma (
8395 Arg_Internal => Internal,
8396 Arg_External => External,
8397 Arg_Parameter_Types => Parameter_Types,
8398 Arg_Mechanism => Mechanism);
8399 end Export_Procedure;
8405 -- pragma Export_Value (
8406 -- [Value =>] static_integer_EXPRESSION,
8407 -- [Link_Name =>] static_string_EXPRESSION);
8409 when Pragma_Export_Value =>
8411 Check_Arg_Order ((Name_Value, Name_Link_Name));
8412 Check_Arg_Count (2);
8414 Check_Optional_Identifier (Arg1, Name_Value);
8415 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
8417 Check_Optional_Identifier (Arg2, Name_Link_Name);
8418 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
8420 -----------------------------
8421 -- Export_Valued_Procedure --
8422 -----------------------------
8424 -- pragma Export_Valued_Procedure (
8425 -- [Internal =>] LOCAL_NAME
8426 -- [, [External =>] EXTERNAL_SYMBOL,]
8427 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
8428 -- [, [Mechanism =>] MECHANISM]);
8430 -- EXTERNAL_SYMBOL ::=
8432 -- | static_string_EXPRESSION
8434 -- PARAMETER_TYPES ::=
8436 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
8438 -- TYPE_DESIGNATOR ::=
8440 -- | subtype_Name ' Access
8444 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
8446 -- MECHANISM_ASSOCIATION ::=
8447 -- [formal_parameter_NAME =>] MECHANISM_NAME
8449 -- MECHANISM_NAME ::=
8452 -- | Descriptor [([Class =>] CLASS_NAME)]
8454 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
8456 when Pragma_Export_Valued_Procedure =>
8457 Export_Valued_Procedure : declare
8458 Args : Args_List (1 .. 4);
8459 Names : constant Name_List (1 .. 4) := (
8462 Name_Parameter_Types,
8465 Internal : Node_Id renames Args (1);
8466 External : Node_Id renames Args (2);
8467 Parameter_Types : Node_Id renames Args (3);
8468 Mechanism : Node_Id renames Args (4);
8472 Gather_Associations (Names, Args);
8473 Process_Extended_Import_Export_Subprogram_Pragma (
8474 Arg_Internal => Internal,
8475 Arg_External => External,
8476 Arg_Parameter_Types => Parameter_Types,
8477 Arg_Mechanism => Mechanism);
8478 end Export_Valued_Procedure;
8484 -- pragma Extend_System ([Name =>] Identifier);
8486 when Pragma_Extend_System => Extend_System : declare
8489 Check_Valid_Configuration_Pragma;
8490 Check_Arg_Count (1);
8491 Check_Optional_Identifier (Arg1, Name_Name);
8492 Check_Arg_Is_Identifier (Arg1);
8494 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
8497 and then Name_Buffer (1 .. 4) = "aux_"
8499 if Present (System_Extend_Pragma_Arg) then
8500 if Chars (Get_Pragma_Arg (Arg1)) =
8501 Chars (Expression (System_Extend_Pragma_Arg))
8505 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
8506 Error_Pragma ("pragma% conflicts with that #");
8510 System_Extend_Pragma_Arg := Arg1;
8512 if not GNAT_Mode then
8513 System_Extend_Unit := Arg1;
8517 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
8521 ------------------------
8522 -- Extensions_Allowed --
8523 ------------------------
8525 -- pragma Extensions_Allowed (ON | OFF);
8527 when Pragma_Extensions_Allowed =>
8529 Check_Arg_Count (1);
8530 Check_No_Identifiers;
8531 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
8533 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
8534 Extensions_Allowed := True;
8535 Ada_Version := Ada_Version_Type'Last;
8538 Extensions_Allowed := False;
8539 Ada_Version := Ada_Version_Explicit;
8546 -- pragma External (
8547 -- [ Convention =>] convention_IDENTIFIER,
8548 -- [ Entity =>] local_NAME
8549 -- [, [External_Name =>] static_string_EXPRESSION ]
8550 -- [, [Link_Name =>] static_string_EXPRESSION ]);
8552 when Pragma_External => External : declare
8556 pragma Warnings (Off, C);
8565 Check_At_Least_N_Arguments (2);
8566 Check_At_Most_N_Arguments (4);
8567 Process_Convention (C, Def_Id);
8568 Note_Possible_Modification
8569 (Get_Pragma_Arg (Arg2), Sure => False);
8570 Process_Interface_Name (Def_Id, Arg3, Arg4);
8571 Set_Exported (Def_Id, Arg2);
8574 --------------------------
8575 -- External_Name_Casing --
8576 --------------------------
8578 -- pragma External_Name_Casing (
8579 -- UPPERCASE | LOWERCASE
8580 -- [, AS_IS | UPPERCASE | LOWERCASE]);
8582 when Pragma_External_Name_Casing => External_Name_Casing : declare
8585 Check_No_Identifiers;
8587 if Arg_Count = 2 then
8589 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
8591 case Chars (Get_Pragma_Arg (Arg2)) is
8593 Opt.External_Name_Exp_Casing := As_Is;
8595 when Name_Uppercase =>
8596 Opt.External_Name_Exp_Casing := Uppercase;
8598 when Name_Lowercase =>
8599 Opt.External_Name_Exp_Casing := Lowercase;
8606 Check_Arg_Count (1);
8609 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
8611 case Chars (Get_Pragma_Arg (Arg1)) is
8612 when Name_Uppercase =>
8613 Opt.External_Name_Imp_Casing := Uppercase;
8615 when Name_Lowercase =>
8616 Opt.External_Name_Imp_Casing := Lowercase;
8621 end External_Name_Casing;
8623 --------------------------
8624 -- Favor_Top_Level --
8625 --------------------------
8627 -- pragma Favor_Top_Level (type_NAME);
8629 when Pragma_Favor_Top_Level => Favor_Top_Level : declare
8630 Named_Entity : Entity_Id;
8634 Check_No_Identifiers;
8635 Check_Arg_Count (1);
8636 Check_Arg_Is_Local_Name (Arg1);
8637 Named_Entity := Entity (Get_Pragma_Arg (Arg1));
8639 -- If it's an access-to-subprogram type (in particular, not a
8640 -- subtype), set the flag on that type.
8642 if Is_Access_Subprogram_Type (Named_Entity) then
8643 Set_Can_Use_Internal_Rep (Named_Entity, False);
8645 -- Otherwise it's an error (name denotes the wrong sort of entity)
8649 ("access-to-subprogram type expected",
8650 Get_Pragma_Arg (Arg1));
8652 end Favor_Top_Level;
8658 -- pragma Fast_Math;
8660 when Pragma_Fast_Math =>
8662 Check_No_Identifiers;
8663 Check_Valid_Configuration_Pragma;
8666 ---------------------------
8667 -- Finalize_Storage_Only --
8668 ---------------------------
8670 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
8672 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
8673 Assoc : constant Node_Id := Arg1;
8674 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
8679 Check_No_Identifiers;
8680 Check_Arg_Count (1);
8681 Check_Arg_Is_Local_Name (Arg1);
8683 Find_Type (Type_Id);
8684 Typ := Entity (Type_Id);
8687 or else Rep_Item_Too_Early (Typ, N)
8691 Typ := Underlying_Type (Typ);
8694 if not Is_Controlled (Typ) then
8695 Error_Pragma ("pragma% must specify controlled type");
8698 Check_First_Subtype (Arg1);
8700 if Finalize_Storage_Only (Typ) then
8701 Error_Pragma ("duplicate pragma%, only one allowed");
8703 elsif not Rep_Item_Too_Late (Typ, N) then
8704 Set_Finalize_Storage_Only (Base_Type (Typ), True);
8706 end Finalize_Storage;
8708 --------------------------
8709 -- Float_Representation --
8710 --------------------------
8712 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
8714 -- FLOAT_REP ::= VAX_Float | IEEE_Float
8716 when Pragma_Float_Representation => Float_Representation : declare
8724 if Arg_Count = 1 then
8725 Check_Valid_Configuration_Pragma;
8727 Check_Arg_Count (2);
8728 Check_Optional_Identifier (Arg2, Name_Entity);
8729 Check_Arg_Is_Local_Name (Arg2);
8732 Check_No_Identifier (Arg1);
8733 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
8735 if not OpenVMS_On_Target then
8736 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8738 ("?pragma% ignored (applies only to Open'V'M'S)");
8744 -- One argument case
8746 if Arg_Count = 1 then
8747 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8748 if Opt.Float_Format = 'I' then
8749 Error_Pragma ("'I'E'E'E format previously specified");
8752 Opt.Float_Format := 'V';
8755 if Opt.Float_Format = 'V' then
8756 Error_Pragma ("'V'A'X format previously specified");
8759 Opt.Float_Format := 'I';
8762 Set_Standard_Fpt_Formats;
8764 -- Two argument case
8767 Argx := Get_Pragma_Arg (Arg2);
8769 if not Is_Entity_Name (Argx)
8770 or else not Is_Floating_Point_Type (Entity (Argx))
8773 ("second argument of% pragma must be floating-point type",
8777 Ent := Entity (Argx);
8778 Digs := UI_To_Int (Digits_Value (Ent));
8780 -- Two arguments, VAX_Float case
8782 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
8784 when 6 => Set_F_Float (Ent);
8785 when 9 => Set_D_Float (Ent);
8786 when 15 => Set_G_Float (Ent);
8790 ("wrong digits value, must be 6,9 or 15", Arg2);
8793 -- Two arguments, IEEE_Float case
8797 when 6 => Set_IEEE_Short (Ent);
8798 when 15 => Set_IEEE_Long (Ent);
8802 ("wrong digits value, must be 6 or 15", Arg2);
8806 end Float_Representation;
8812 -- pragma Ident (static_string_EXPRESSION)
8814 -- Note: pragma Comment shares this processing. Pragma Comment is
8815 -- identical to Ident, except that the restriction of the argument to
8816 -- 31 characters and the placement restrictions are not enforced for
8819 when Pragma_Ident | Pragma_Comment => Ident : declare
8824 Check_Arg_Count (1);
8825 Check_No_Identifiers;
8826 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
8829 -- For pragma Ident, preserve DEC compatibility by requiring the
8830 -- pragma to appear in a declarative part or package spec.
8832 if Prag_Id = Pragma_Ident then
8833 Check_Is_In_Decl_Part_Or_Package_Spec;
8836 Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
8843 GP := Parent (Parent (N));
8845 if Nkind_In (GP, N_Package_Declaration,
8846 N_Generic_Package_Declaration)
8851 -- If we have a compilation unit, then record the ident value,
8852 -- checking for improper duplication.
8854 if Nkind (GP) = N_Compilation_Unit then
8855 CS := Ident_String (Current_Sem_Unit);
8857 if Present (CS) then
8859 -- For Ident, we do not permit multiple instances
8861 if Prag_Id = Pragma_Ident then
8862 Error_Pragma ("duplicate% pragma not permitted");
8864 -- For Comment, we concatenate the string, unless we want
8865 -- to preserve the tree structure for ASIS.
8867 elsif not ASIS_Mode then
8868 Start_String (Strval (CS));
8869 Store_String_Char (' ');
8870 Store_String_Chars (Strval (Str));
8871 Set_Strval (CS, End_String);
8875 -- In VMS, the effect of IDENT is achieved by passing
8876 -- --identification=name as a --for-linker switch.
8878 if OpenVMS_On_Target then
8881 ("--for-linker=--identification=");
8882 String_To_Name_Buffer (Strval (Str));
8883 Store_String_Chars (Name_Buffer (1 .. Name_Len));
8885 -- Only the last processed IDENT is saved. The main
8886 -- purpose is so an IDENT associated with a main
8887 -- procedure will be used in preference to an IDENT
8888 -- associated with a with'd package.
8890 Replace_Linker_Option_String
8891 (End_String, "--for-linker=--identification=");
8894 Set_Ident_String (Current_Sem_Unit, Str);
8897 -- For subunits, we just ignore the Ident, since in GNAT these
8898 -- are not separate object files, and hence not separate units
8899 -- in the unit table.
8901 elsif Nkind (GP) = N_Subunit then
8904 -- Otherwise we have a misplaced pragma Ident, but we ignore
8905 -- this if we are in an instantiation, since it comes from
8906 -- a generic, and has no relevance to the instantiation.
8908 elsif Prag_Id = Pragma_Ident then
8909 if Instantiation_Location (Loc) = No_Location then
8910 Error_Pragma ("pragma% only allowed at outer level");
8920 -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
8921 -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
8923 when Pragma_Implemented => Implemented : declare
8924 Proc_Id : Entity_Id;
8929 Check_Arg_Count (2);
8930 Check_No_Identifiers;
8931 Check_Arg_Is_Identifier (Arg1);
8932 Check_Arg_Is_Local_Name (Arg1);
8934 (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
8936 -- Extract the name of the local procedure
8938 Proc_Id := Entity (Get_Pragma_Arg (Arg1));
8940 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
8941 -- primitive procedure of a synchronized tagged type.
8943 if Ekind (Proc_Id) = E_Procedure
8944 and then Is_Primitive (Proc_Id)
8945 and then Present (First_Formal (Proc_Id))
8947 Typ := Etype (First_Formal (Proc_Id));
8949 if Is_Tagged_Type (Typ)
8952 -- Check for a protected, a synchronized or a task interface
8954 ((Is_Interface (Typ)
8955 and then Is_Synchronized_Interface (Typ))
8957 -- Check for a protected type or a task type that implements
8961 (Is_Concurrent_Record_Type (Typ)
8962 and then Present (Interfaces (Typ)))
8964 -- Check for a private record extension with keyword
8968 (Ekind_In (Typ, E_Record_Type_With_Private,
8969 E_Record_Subtype_With_Private)
8970 and then Synchronized_Present (Parent (Typ))))
8975 ("controlling formal must be of synchronized " &
8976 "tagged type", Arg1);
8980 -- Procedures declared inside a protected type must be accepted
8982 elsif Ekind (Proc_Id) = E_Procedure
8983 and then Is_Protected_Type (Scope (Proc_Id))
8987 -- The first argument is not a primitive procedure
8991 ("pragma % must be applied to a primitive procedure", Arg1);
8995 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
8996 -- By_Protected_Procedure to the primitive procedure of a task
8999 if Chars (Arg2) = Name_By_Protected_Procedure
9000 and then Is_Interface (Typ)
9001 and then Is_Task_Interface (Typ)
9004 ("implementation kind By_Protected_Procedure cannot be " &
9005 "applied to a task interface primitive", Arg2);
9009 Record_Rep_Item (Proc_Id, N);
9012 ----------------------
9013 -- Implicit_Packing --
9014 ----------------------
9016 -- pragma Implicit_Packing;
9018 when Pragma_Implicit_Packing =>
9020 Check_Arg_Count (0);
9021 Implicit_Packing := True;
9028 -- [Convention =>] convention_IDENTIFIER,
9029 -- [Entity =>] local_NAME
9030 -- [, [External_Name =>] static_string_EXPRESSION ]
9031 -- [, [Link_Name =>] static_string_EXPRESSION ]);
9033 when Pragma_Import =>
9034 Check_Ada_83_Warning;
9040 Check_At_Least_N_Arguments (2);
9041 Check_At_Most_N_Arguments (4);
9042 Process_Import_Or_Interface;
9044 ----------------------
9045 -- Import_Exception --
9046 ----------------------
9048 -- pragma Import_Exception (
9049 -- [Internal =>] LOCAL_NAME
9050 -- [, [External =>] EXTERNAL_SYMBOL]
9051 -- [, [Form =>] Ada | VMS]
9052 -- [, [Code =>] static_integer_EXPRESSION]);
9054 when Pragma_Import_Exception => Import_Exception : declare
9055 Args : Args_List (1 .. 4);
9056 Names : constant Name_List (1 .. 4) := (
9062 Internal : Node_Id renames Args (1);
9063 External : Node_Id renames Args (2);
9064 Form : Node_Id renames Args (3);
9065 Code : Node_Id renames Args (4);
9069 Gather_Associations (Names, Args);
9071 if Present (External) and then Present (Code) then
9073 ("cannot give both External and Code options for pragma%");
9076 Process_Extended_Import_Export_Exception_Pragma (
9077 Arg_Internal => Internal,
9078 Arg_External => External,
9082 if not Is_VMS_Exception (Entity (Internal)) then
9083 Set_Imported (Entity (Internal));
9085 end Import_Exception;
9087 ---------------------
9088 -- Import_Function --
9089 ---------------------
9091 -- pragma Import_Function (
9092 -- [Internal =>] LOCAL_NAME,
9093 -- [, [External =>] EXTERNAL_SYMBOL]
9094 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
9095 -- [, [Result_Type =>] SUBTYPE_MARK]
9096 -- [, [Mechanism =>] MECHANISM]
9097 -- [, [Result_Mechanism =>] MECHANISM_NAME]
9098 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
9100 -- EXTERNAL_SYMBOL ::=
9102 -- | static_string_EXPRESSION
9104 -- PARAMETER_TYPES ::=
9106 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
9108 -- TYPE_DESIGNATOR ::=
9110 -- | subtype_Name ' Access
9114 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
9116 -- MECHANISM_ASSOCIATION ::=
9117 -- [formal_parameter_NAME =>] MECHANISM_NAME
9119 -- MECHANISM_NAME ::=
9122 -- | Descriptor [([Class =>] CLASS_NAME)]
9124 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9126 when Pragma_Import_Function => Import_Function : declare
9127 Args : Args_List (1 .. 7);
9128 Names : constant Name_List (1 .. 7) := (
9131 Name_Parameter_Types,
9134 Name_Result_Mechanism,
9135 Name_First_Optional_Parameter);
9137 Internal : Node_Id renames Args (1);
9138 External : Node_Id renames Args (2);
9139 Parameter_Types : Node_Id renames Args (3);
9140 Result_Type : Node_Id renames Args (4);
9141 Mechanism : Node_Id renames Args (5);
9142 Result_Mechanism : Node_Id renames Args (6);
9143 First_Optional_Parameter : Node_Id renames Args (7);
9147 Gather_Associations (Names, Args);
9148 Process_Extended_Import_Export_Subprogram_Pragma (
9149 Arg_Internal => Internal,
9150 Arg_External => External,
9151 Arg_Parameter_Types => Parameter_Types,
9152 Arg_Result_Type => Result_Type,
9153 Arg_Mechanism => Mechanism,
9154 Arg_Result_Mechanism => Result_Mechanism,
9155 Arg_First_Optional_Parameter => First_Optional_Parameter);
9156 end Import_Function;
9162 -- pragma Import_Object (
9163 -- [Internal =>] LOCAL_NAME
9164 -- [, [External =>] EXTERNAL_SYMBOL]
9165 -- [, [Size =>] EXTERNAL_SYMBOL]);
9167 -- EXTERNAL_SYMBOL ::=
9169 -- | static_string_EXPRESSION
9171 when Pragma_Import_Object => Import_Object : declare
9172 Args : Args_List (1 .. 3);
9173 Names : constant Name_List (1 .. 3) := (
9178 Internal : Node_Id renames Args (1);
9179 External : Node_Id renames Args (2);
9180 Size : Node_Id renames Args (3);
9184 Gather_Associations (Names, Args);
9185 Process_Extended_Import_Export_Object_Pragma (
9186 Arg_Internal => Internal,
9187 Arg_External => External,
9191 ----------------------
9192 -- Import_Procedure --
9193 ----------------------
9195 -- pragma Import_Procedure (
9196 -- [Internal =>] LOCAL_NAME
9197 -- [, [External =>] EXTERNAL_SYMBOL]
9198 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
9199 -- [, [Mechanism =>] MECHANISM]
9200 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
9202 -- EXTERNAL_SYMBOL ::=
9204 -- | static_string_EXPRESSION
9206 -- PARAMETER_TYPES ::=
9208 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
9210 -- TYPE_DESIGNATOR ::=
9212 -- | subtype_Name ' Access
9216 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
9218 -- MECHANISM_ASSOCIATION ::=
9219 -- [formal_parameter_NAME =>] MECHANISM_NAME
9221 -- MECHANISM_NAME ::=
9224 -- | Descriptor [([Class =>] CLASS_NAME)]
9226 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9228 when Pragma_Import_Procedure => Import_Procedure : declare
9229 Args : Args_List (1 .. 5);
9230 Names : constant Name_List (1 .. 5) := (
9233 Name_Parameter_Types,
9235 Name_First_Optional_Parameter);
9237 Internal : Node_Id renames Args (1);
9238 External : Node_Id renames Args (2);
9239 Parameter_Types : Node_Id renames Args (3);
9240 Mechanism : Node_Id renames Args (4);
9241 First_Optional_Parameter : Node_Id renames Args (5);
9245 Gather_Associations (Names, Args);
9246 Process_Extended_Import_Export_Subprogram_Pragma (
9247 Arg_Internal => Internal,
9248 Arg_External => External,
9249 Arg_Parameter_Types => Parameter_Types,
9250 Arg_Mechanism => Mechanism,
9251 Arg_First_Optional_Parameter => First_Optional_Parameter);
9252 end Import_Procedure;
9254 -----------------------------
9255 -- Import_Valued_Procedure --
9256 -----------------------------
9258 -- pragma Import_Valued_Procedure (
9259 -- [Internal =>] LOCAL_NAME
9260 -- [, [External =>] EXTERNAL_SYMBOL]
9261 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
9262 -- [, [Mechanism =>] MECHANISM]
9263 -- [, [First_Optional_Parameter =>] IDENTIFIER]);
9265 -- EXTERNAL_SYMBOL ::=
9267 -- | static_string_EXPRESSION
9269 -- PARAMETER_TYPES ::=
9271 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
9273 -- TYPE_DESIGNATOR ::=
9275 -- | subtype_Name ' Access
9279 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
9281 -- MECHANISM_ASSOCIATION ::=
9282 -- [formal_parameter_NAME =>] MECHANISM_NAME
9284 -- MECHANISM_NAME ::=
9287 -- | Descriptor [([Class =>] CLASS_NAME)]
9289 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
9291 when Pragma_Import_Valued_Procedure =>
9292 Import_Valued_Procedure : declare
9293 Args : Args_List (1 .. 5);
9294 Names : constant Name_List (1 .. 5) := (
9297 Name_Parameter_Types,
9299 Name_First_Optional_Parameter);
9301 Internal : Node_Id renames Args (1);
9302 External : Node_Id renames Args (2);
9303 Parameter_Types : Node_Id renames Args (3);
9304 Mechanism : Node_Id renames Args (4);
9305 First_Optional_Parameter : Node_Id renames Args (5);
9309 Gather_Associations (Names, Args);
9310 Process_Extended_Import_Export_Subprogram_Pragma (
9311 Arg_Internal => Internal,
9312 Arg_External => External,
9313 Arg_Parameter_Types => Parameter_Types,
9314 Arg_Mechanism => Mechanism,
9315 Arg_First_Optional_Parameter => First_Optional_Parameter);
9316 end Import_Valued_Procedure;
9322 -- pragma Independent (LOCAL_NAME);
9324 when Pragma_Independent => Independent : declare
9331 Check_Ada_83_Warning;
9333 Check_No_Identifiers;
9334 Check_Arg_Count (1);
9335 Check_Arg_Is_Local_Name (Arg1);
9336 E_Id := Get_Pragma_Arg (Arg1);
9338 if Etype (E_Id) = Any_Type then
9343 D := Declaration_Node (E);
9346 -- Check duplicate before we chain ourselves!
9348 Check_Duplicate_Pragma (E);
9350 -- Check appropriate entity
9353 if Rep_Item_Too_Early (E, N)
9355 Rep_Item_Too_Late (E, N)
9359 Check_First_Subtype (Arg1);
9362 elsif K = N_Object_Declaration
9363 or else (K = N_Component_Declaration
9364 and then Original_Record_Component (E) = E)
9366 if Rep_Item_Too_Late (E, N) then
9372 ("inappropriate entity for pragma%", Arg1);
9375 Independence_Checks.Append ((N, E));
9378 ----------------------------
9379 -- Independent_Components --
9380 ----------------------------
9382 -- pragma Atomic_Components (array_LOCAL_NAME);
9384 -- This processing is shared by Volatile_Components
9386 when Pragma_Independent_Components => Independent_Components : declare
9393 Check_Ada_83_Warning;
9395 Check_No_Identifiers;
9396 Check_Arg_Count (1);
9397 Check_Arg_Is_Local_Name (Arg1);
9398 E_Id := Get_Pragma_Arg (Arg1);
9400 if Etype (E_Id) = Any_Type then
9406 -- Check duplicate before we chain ourselves!
9408 Check_Duplicate_Pragma (E);
9410 -- Check appropriate entity
9412 if Rep_Item_Too_Early (E, N)
9414 Rep_Item_Too_Late (E, N)
9419 D := Declaration_Node (E);
9422 if (K = N_Full_Type_Declaration
9423 and then (Is_Array_Type (E) or else Is_Record_Type (E)))
9425 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
9426 and then Nkind (D) = N_Object_Declaration
9427 and then Nkind (Object_Definition (D)) =
9428 N_Constrained_Array_Definition)
9430 Independence_Checks.Append ((N, E));
9433 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
9435 end Independent_Components;
9437 ------------------------
9438 -- Initialize_Scalars --
9439 ------------------------
9441 -- pragma Initialize_Scalars;
9443 when Pragma_Initialize_Scalars =>
9445 Check_Arg_Count (0);
9446 Check_Valid_Configuration_Pragma;
9447 Check_Restriction (No_Initialize_Scalars, N);
9449 -- Initialize_Scalars creates false positives in CodePeer,
9450 -- so ignore this pragma in this mode.
9452 if not Restriction_Active (No_Initialize_Scalars)
9453 and then not CodePeer_Mode
9455 Init_Or_Norm_Scalars := True;
9456 Initialize_Scalars := True;
9463 -- pragma Inline ( NAME {, NAME} );
9465 when Pragma_Inline =>
9467 -- Pragma is active if inlining option is active
9469 Process_Inline (Inline_Active);
9475 -- pragma Inline_Always ( NAME {, NAME} );
9477 when Pragma_Inline_Always =>
9480 -- Pragma always active unless in CodePeer mode, since this causes
9481 -- walk order issues.
9483 if not CodePeer_Mode then
9484 Process_Inline (True);
9487 --------------------
9488 -- Inline_Generic --
9489 --------------------
9491 -- pragma Inline_Generic (NAME {, NAME});
9493 when Pragma_Inline_Generic =>
9495 Process_Generic_List;
9497 ----------------------
9498 -- Inspection_Point --
9499 ----------------------
9501 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
9503 when Pragma_Inspection_Point => Inspection_Point : declare
9508 if Arg_Count > 0 then
9511 Exp := Get_Pragma_Arg (Arg);
9514 if not Is_Entity_Name (Exp)
9515 or else not Is_Object (Entity (Exp))
9517 Error_Pragma_Arg ("object name required", Arg);
9524 end Inspection_Point;
9530 -- pragma Interface (
9531 -- [ Convention =>] convention_IDENTIFIER,
9532 -- [ Entity =>] local_NAME
9533 -- [, [External_Name =>] static_string_EXPRESSION ]
9534 -- [, [Link_Name =>] static_string_EXPRESSION ]);
9536 when Pragma_Interface =>
9543 Check_At_Least_N_Arguments (2);
9544 Check_At_Most_N_Arguments (4);
9545 Process_Import_Or_Interface;
9547 -- In Ada 2005, the permission to use Interface (a reserved word)
9548 -- as a pragma name is considered an obsolescent feature.
9550 if Ada_Version >= Ada_2005 then
9552 (No_Obsolescent_Features, Pragma_Identifier (N));
9555 --------------------
9556 -- Interface_Name --
9557 --------------------
9559 -- pragma Interface_Name (
9560 -- [ Entity =>] local_NAME
9561 -- [,[External_Name =>] static_string_EXPRESSION ]
9562 -- [,[Link_Name =>] static_string_EXPRESSION ]);
9564 when Pragma_Interface_Name => Interface_Name : declare
9573 ((Name_Entity, Name_External_Name, Name_Link_Name));
9574 Check_At_Least_N_Arguments (2);
9575 Check_At_Most_N_Arguments (3);
9576 Id := Get_Pragma_Arg (Arg1);
9579 if not Is_Entity_Name (Id) then
9581 ("first argument for pragma% must be entity name", Arg1);
9582 elsif Etype (Id) = Any_Type then
9585 Def_Id := Entity (Id);
9588 -- Special DEC-compatible processing for the object case, forces
9589 -- object to be imported.
9591 if Ekind (Def_Id) = E_Variable then
9592 Kill_Size_Check_Code (Def_Id);
9593 Note_Possible_Modification (Id, Sure => False);
9595 -- Initialization is not allowed for imported variable
9597 if Present (Expression (Parent (Def_Id)))
9598 and then Comes_From_Source (Expression (Parent (Def_Id)))
9600 Error_Msg_Sloc := Sloc (Def_Id);
9602 ("no initialization allowed for declaration of& #",
9606 -- For compatibility, support VADS usage of providing both
9607 -- pragmas Interface and Interface_Name to obtain the effect
9608 -- of a single Import pragma.
9610 if Is_Imported (Def_Id)
9611 and then Present (First_Rep_Item (Def_Id))
9612 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
9614 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
9618 Set_Imported (Def_Id);
9621 Set_Is_Public (Def_Id);
9622 Process_Interface_Name (Def_Id, Arg2, Arg3);
9625 -- Otherwise must be subprogram
9627 elsif not Is_Subprogram (Def_Id) then
9629 ("argument of pragma% is not subprogram", Arg1);
9632 Check_At_Most_N_Arguments (3);
9636 -- Loop through homonyms
9639 Def_Id := Get_Base_Subprogram (Hom_Id);
9641 if Is_Imported (Def_Id) then
9642 Process_Interface_Name (Def_Id, Arg2, Arg3);
9646 exit when From_Aspect_Specification (N);
9647 Hom_Id := Homonym (Hom_Id);
9649 exit when No (Hom_Id)
9650 or else Scope (Hom_Id) /= Current_Scope;
9655 ("argument of pragma% is not imported subprogram",
9661 -----------------------
9662 -- Interrupt_Handler --
9663 -----------------------
9665 -- pragma Interrupt_Handler (handler_NAME);
9667 when Pragma_Interrupt_Handler =>
9668 Check_Ada_83_Warning;
9669 Check_Arg_Count (1);
9670 Check_No_Identifiers;
9672 if No_Run_Time_Mode then
9673 Error_Msg_CRT ("Interrupt_Handler pragma", N);
9675 Check_Interrupt_Or_Attach_Handler;
9676 Process_Interrupt_Or_Attach_Handler;
9679 ------------------------
9680 -- Interrupt_Priority --
9681 ------------------------
9683 -- pragma Interrupt_Priority [(EXPRESSION)];
9685 when Pragma_Interrupt_Priority => Interrupt_Priority : declare
9686 P : constant Node_Id := Parent (N);
9690 Check_Ada_83_Warning;
9692 if Arg_Count /= 0 then
9693 Arg := Get_Pragma_Arg (Arg1);
9694 Check_Arg_Count (1);
9695 Check_No_Identifiers;
9697 -- The expression must be analyzed in the special manner
9698 -- described in "Handling of Default and Per-Object
9699 -- Expressions" in sem.ads.
9701 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
9704 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
9708 elsif Has_Pragma_Priority (P) then
9709 Error_Pragma ("duplicate pragma% not allowed");
9712 Set_Has_Pragma_Priority (P, True);
9713 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
9715 end Interrupt_Priority;
9717 ---------------------
9718 -- Interrupt_State --
9719 ---------------------
9721 -- pragma Interrupt_State (
9722 -- [Name =>] INTERRUPT_ID,
9723 -- [State =>] INTERRUPT_STATE);
9725 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
9726 -- INTERRUPT_STATE => System | Runtime | User
9728 -- Note: if the interrupt id is given as an identifier, then it must
9729 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
9730 -- given as a static integer expression which must be in the range of
9731 -- Ada.Interrupts.Interrupt_ID.
9733 when Pragma_Interrupt_State => Interrupt_State : declare
9735 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
9736 -- This is the entity Ada.Interrupts.Interrupt_ID;
9738 State_Type : Character;
9739 -- Set to 's'/'r'/'u' for System/Runtime/User
9742 -- Index to entry in Interrupt_States table
9745 -- Value of interrupt
9747 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
9748 -- The first argument to the pragma
9750 Int_Ent : Entity_Id;
9751 -- Interrupt entity in Ada.Interrupts.Names
9755 Check_Arg_Order ((Name_Name, Name_State));
9756 Check_Arg_Count (2);
9758 Check_Optional_Identifier (Arg1, Name_Name);
9759 Check_Optional_Identifier (Arg2, Name_State);
9760 Check_Arg_Is_Identifier (Arg2);
9762 -- First argument is identifier
9764 if Nkind (Arg1X) = N_Identifier then
9766 -- Search list of names in Ada.Interrupts.Names
9768 Int_Ent := First_Entity (RTE (RE_Names));
9770 if No (Int_Ent) then
9771 Error_Pragma_Arg ("invalid interrupt name", Arg1);
9773 elsif Chars (Int_Ent) = Chars (Arg1X) then
9774 Int_Val := Expr_Value (Constant_Value (Int_Ent));
9778 Next_Entity (Int_Ent);
9781 -- First argument is not an identifier, so it must be a static
9782 -- expression of type Ada.Interrupts.Interrupt_ID.
9785 Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
9786 Int_Val := Expr_Value (Arg1X);
9788 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
9790 Int_Val > Expr_Value (Type_High_Bound (Int_Id))
9793 ("value not in range of type " &
9794 """Ada.Interrupts.Interrupt_'I'D""", Arg1);
9800 case Chars (Get_Pragma_Arg (Arg2)) is
9801 when Name_Runtime => State_Type := 'r';
9802 when Name_System => State_Type := 's';
9803 when Name_User => State_Type := 'u';
9806 Error_Pragma_Arg ("invalid interrupt state", Arg2);
9809 -- Check if entry is already stored
9811 IST_Num := Interrupt_States.First;
9813 -- If entry not found, add it
9815 if IST_Num > Interrupt_States.Last then
9816 Interrupt_States.Append
9817 ((Interrupt_Number => UI_To_Int (Int_Val),
9818 Interrupt_State => State_Type,
9819 Pragma_Loc => Loc));
9822 -- Case of entry for the same entry
9824 elsif Int_Val = Interrupt_States.Table (IST_Num).
9827 -- If state matches, done, no need to make redundant entry
9830 State_Type = Interrupt_States.Table (IST_Num).
9833 -- Otherwise if state does not match, error
9836 Interrupt_States.Table (IST_Num).Pragma_Loc;
9838 ("state conflicts with that given #", Arg2);
9842 IST_Num := IST_Num + 1;
9844 end Interrupt_State;
9851 -- ([Entity =>] type_LOCAL_NAME,
9852 -- [Check =>] EXPRESSION
9853 -- [,[Message =>] String_Expression]);
9855 when Pragma_Invariant => Invariant : declare
9860 pragma Unreferenced (Discard);
9864 Check_At_Least_N_Arguments (2);
9865 Check_At_Most_N_Arguments (3);
9866 Check_Optional_Identifier (Arg1, Name_Entity);
9867 Check_Optional_Identifier (Arg2, Name_Check);
9869 if Arg_Count = 3 then
9870 Check_Optional_Identifier (Arg3, Name_Message);
9871 Check_Arg_Is_Static_Expression (Arg3, Standard_String);
9874 Check_Arg_Is_Local_Name (Arg1);
9876 Type_Id := Get_Pragma_Arg (Arg1);
9877 Find_Type (Type_Id);
9878 Typ := Entity (Type_Id);
9880 if Typ = Any_Type then
9883 elsif not Ekind_In (Typ, E_Private_Type,
9884 E_Record_Type_With_Private,
9885 E_Limited_Private_Type)
9888 ("pragma% only allowed for private type", Arg1);
9891 -- Note that the type has at least one invariant, and also that
9892 -- it has inheritable invariants if we have Invariant'Class.
9894 Set_Has_Invariants (Typ);
9896 if Class_Present (N) then
9897 Set_Has_Inheritable_Invariants (Typ);
9900 -- The remaining processing is simply to link the pragma on to
9901 -- the rep item chain, for processing when the type is frozen.
9902 -- This is accomplished by a call to Rep_Item_Too_Late.
9904 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
9907 ----------------------
9908 -- Java_Constructor --
9909 ----------------------
9911 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
9913 -- Also handles pragma CIL_Constructor
9915 when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
9916 Java_Constructor : declare
9917 Convention : Convention_Id;
9921 This_Formal : Entity_Id;
9925 Check_Arg_Count (1);
9926 Check_Optional_Identifier (Arg1, Name_Entity);
9927 Check_Arg_Is_Local_Name (Arg1);
9929 Id := Get_Pragma_Arg (Arg1);
9930 Find_Program_Unit_Name (Id);
9932 -- If we did not find the name, we are done
9934 if Etype (Id) = Any_Type then
9938 -- Check wrong use of pragma in wrong VM target
9940 if VM_Target = No_VM then
9943 elsif VM_Target = CLI_Target
9944 and then Prag_Id = Pragma_Java_Constructor
9946 Error_Pragma ("must use pragma 'C'I'L_'Constructor");
9948 elsif VM_Target = JVM_Target
9949 and then Prag_Id = Pragma_CIL_Constructor
9951 Error_Pragma ("must use pragma 'Java_'Constructor");
9955 when Pragma_CIL_Constructor => Convention := Convention_CIL;
9956 when Pragma_Java_Constructor => Convention := Convention_Java;
9957 when others => null;
9960 Hom_Id := Entity (Id);
9962 -- Loop through homonyms
9965 Def_Id := Get_Base_Subprogram (Hom_Id);
9967 -- The constructor is required to be a function
9969 if Ekind (Def_Id) /= E_Function then
9970 if VM_Target = JVM_Target then
9972 ("pragma% requires function returning a " &
9973 "'Java access type", Def_Id);
9976 ("pragma% requires function returning a " &
9977 "'C'I'L access type", Def_Id);
9981 -- Check arguments: For tagged type the first formal must be
9982 -- named "this" and its type must be a named access type
9983 -- designating a class-wide tagged type that has convention
9984 -- CIL/Java. The first formal must also have a null default
9985 -- value. For example:
9987 -- type Typ is tagged ...
9988 -- type Ref is access all Typ;
9989 -- pragma Convention (CIL, Typ);
9991 -- function New_Typ (This : Ref) return Ref;
9992 -- function New_Typ (This : Ref; I : Integer) return Ref;
9993 -- pragma Cil_Constructor (New_Typ);
9995 -- Reason: The first formal must NOT be a primitive of the
9998 -- This rule also applies to constructors of delegates used
9999 -- to interface with standard target libraries. For example:
10001 -- type Delegate is access procedure ...
10002 -- pragma Import (CIL, Delegate, ...);
10004 -- function new_Delegate
10005 -- (This : Delegate := null; ... ) return Delegate;
10007 -- For value-types this rule does not apply.
10009 if not Is_Value_Type (Etype (Def_Id)) then
10010 if No (First_Formal (Def_Id)) then
10011 Error_Msg_Name_1 := Pname;
10012 Error_Msg_N ("% function must have parameters", Def_Id);
10016 -- In the JRE library we have several occurrences in which
10017 -- the "this" parameter is not the first formal.
10019 This_Formal := First_Formal (Def_Id);
10021 -- In the JRE library we have several occurrences in which
10022 -- the "this" parameter is not the first formal. Search for
10025 if VM_Target = JVM_Target then
10026 while Present (This_Formal)
10027 and then Get_Name_String (Chars (This_Formal)) /= "this"
10029 Next_Formal (This_Formal);
10032 if No (This_Formal) then
10033 This_Formal := First_Formal (Def_Id);
10037 -- Warning: The first parameter should be named "this".
10038 -- We temporarily allow it because we have the following
10039 -- case in the Java runtime (file s-osinte.ads) ???
10041 -- function new_Thread
10042 -- (Self_Id : System.Address) return Thread_Id;
10043 -- pragma Java_Constructor (new_Thread);
10045 if VM_Target = JVM_Target
10046 and then Get_Name_String (Chars (First_Formal (Def_Id)))
10048 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
10052 elsif Get_Name_String (Chars (This_Formal)) /= "this" then
10053 Error_Msg_Name_1 := Pname;
10055 ("first formal of % function must be named `this`",
10056 Parent (This_Formal));
10058 elsif not Is_Access_Type (Etype (This_Formal)) then
10059 Error_Msg_Name_1 := Pname;
10061 ("first formal of % function must be an access type",
10062 Parameter_Type (Parent (This_Formal)));
10064 -- For delegates the type of the first formal must be a
10065 -- named access-to-subprogram type (see previous example)
10067 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
10068 and then Ekind (Etype (This_Formal))
10069 /= E_Access_Subprogram_Type
10071 Error_Msg_Name_1 := Pname;
10073 ("first formal of % function must be a named access" &
10074 " to subprogram type",
10075 Parameter_Type (Parent (This_Formal)));
10077 -- Warning: We should reject anonymous access types because
10078 -- the constructor must not be handled as a primitive of the
10079 -- tagged type. We temporarily allow it because this profile
10080 -- is currently generated by cil2ada???
10082 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
10083 and then not Ekind_In (Etype (This_Formal),
10085 E_General_Access_Type,
10086 E_Anonymous_Access_Type)
10088 Error_Msg_Name_1 := Pname;
10090 ("first formal of % function must be a named access" &
10092 Parameter_Type (Parent (This_Formal)));
10094 elsif Atree.Convention
10095 (Designated_Type (Etype (This_Formal))) /= Convention
10097 Error_Msg_Name_1 := Pname;
10099 if Convention = Convention_Java then
10101 ("pragma% requires convention 'Cil in designated" &
10103 Parameter_Type (Parent (This_Formal)));
10106 ("pragma% requires convention 'Java in designated" &
10108 Parameter_Type (Parent (This_Formal)));
10111 elsif No (Expression (Parent (This_Formal)))
10112 or else Nkind (Expression (Parent (This_Formal))) /= N_Null
10114 Error_Msg_Name_1 := Pname;
10116 ("pragma% requires first formal with default `null`",
10117 Parameter_Type (Parent (This_Formal)));
10121 -- Check result type: the constructor must be a function
10123 -- * a value type (only allowed in the CIL compiler)
10124 -- * an access-to-subprogram type with convention Java/CIL
10125 -- * an access-type designating a type that has convention
10128 if Is_Value_Type (Etype (Def_Id)) then
10131 -- Access-to-subprogram type with convention Java/CIL
10133 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
10134 if Atree.Convention (Etype (Def_Id)) /= Convention then
10135 if Convention = Convention_Java then
10137 ("pragma% requires function returning a " &
10138 "'Java access type", Arg1);
10140 pragma Assert (Convention = Convention_CIL);
10142 ("pragma% requires function returning a " &
10143 "'C'I'L access type", Arg1);
10147 elsif Ekind (Etype (Def_Id)) in Access_Kind then
10148 if not Ekind_In (Etype (Def_Id), E_Access_Type,
10149 E_General_Access_Type)
10152 (Designated_Type (Etype (Def_Id))) /= Convention
10154 Error_Msg_Name_1 := Pname;
10156 if Convention = Convention_Java then
10158 ("pragma% requires function returning a named" &
10159 "'Java access type", Arg1);
10162 ("pragma% requires function returning a named" &
10163 "'C'I'L access type", Arg1);
10168 Set_Is_Constructor (Def_Id);
10169 Set_Convention (Def_Id, Convention);
10170 Set_Is_Imported (Def_Id);
10172 exit when From_Aspect_Specification (N);
10173 Hom_Id := Homonym (Hom_Id);
10175 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
10177 end Java_Constructor;
10179 ----------------------
10180 -- Java_Interface --
10181 ----------------------
10183 -- pragma Java_Interface ([Entity =>] LOCAL_NAME);
10185 when Pragma_Java_Interface => Java_Interface : declare
10191 Check_Arg_Count (1);
10192 Check_Optional_Identifier (Arg1, Name_Entity);
10193 Check_Arg_Is_Local_Name (Arg1);
10195 Arg := Get_Pragma_Arg (Arg1);
10198 if Etype (Arg) = Any_Type then
10202 if not Is_Entity_Name (Arg)
10203 or else not Is_Type (Entity (Arg))
10205 Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
10208 Typ := Underlying_Type (Entity (Arg));
10210 -- For now simply check some of the semantic constraints on the
10211 -- type. This currently leaves out some restrictions on interface
10212 -- types, namely that the parent type must be java.lang.Object.Typ
10213 -- and that all primitives of the type should be declared
10216 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
10217 Error_Pragma_Arg ("pragma% requires an abstract "
10218 & "tagged type", Arg1);
10220 elsif not Has_Discriminants (Typ)
10221 or else Ekind (Etype (First_Discriminant (Typ)))
10222 /= E_Anonymous_Access_Type
10224 not Is_Class_Wide_Type
10225 (Designated_Type (Etype (First_Discriminant (Typ))))
10228 ("type must have a class-wide access discriminant", Arg1);
10230 end Java_Interface;
10236 -- pragma Keep_Names ([On => ] local_NAME);
10238 when Pragma_Keep_Names => Keep_Names : declare
10243 Check_Arg_Count (1);
10244 Check_Optional_Identifier (Arg1, Name_On);
10245 Check_Arg_Is_Local_Name (Arg1);
10247 Arg := Get_Pragma_Arg (Arg1);
10250 if Etype (Arg) = Any_Type then
10254 if not Is_Entity_Name (Arg)
10255 or else Ekind (Entity (Arg)) /= E_Enumeration_Type
10258 ("pragma% requires a local enumeration type", Arg1);
10261 Set_Discard_Names (Entity (Arg), False);
10268 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
10270 when Pragma_License =>
10272 Check_Arg_Count (1);
10273 Check_No_Identifiers;
10274 Check_Valid_Configuration_Pragma;
10275 Check_Arg_Is_Identifier (Arg1);
10278 Sind : constant Source_File_Index :=
10279 Source_Index (Current_Sem_Unit);
10282 case Chars (Get_Pragma_Arg (Arg1)) is
10284 Set_License (Sind, GPL);
10286 when Name_Modified_GPL =>
10287 Set_License (Sind, Modified_GPL);
10289 when Name_Restricted =>
10290 Set_License (Sind, Restricted);
10292 when Name_Unrestricted =>
10293 Set_License (Sind, Unrestricted);
10296 Error_Pragma_Arg ("invalid license name", Arg1);
10304 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
10306 when Pragma_Link_With => Link_With : declare
10312 if Operating_Mode = Generate_Code
10313 and then In_Extended_Main_Source_Unit (N)
10315 Check_At_Least_N_Arguments (1);
10316 Check_No_Identifiers;
10317 Check_Is_In_Decl_Part_Or_Package_Spec;
10318 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
10322 while Present (Arg) loop
10323 Check_Arg_Is_Static_Expression (Arg, Standard_String);
10325 -- Store argument, converting sequences of spaces to a
10326 -- single null character (this is one of the differences
10327 -- in processing between Link_With and Linker_Options).
10329 Arg_Store : declare
10330 C : constant Char_Code := Get_Char_Code (' ');
10331 S : constant String_Id :=
10332 Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
10333 L : constant Nat := String_Length (S);
10336 procedure Skip_Spaces;
10337 -- Advance F past any spaces
10343 procedure Skip_Spaces is
10345 while F <= L and then Get_String_Char (S, F) = C loop
10350 -- Start of processing for Arg_Store
10353 Skip_Spaces; -- skip leading spaces
10355 -- Loop through characters, changing any embedded
10356 -- sequence of spaces to a single null character (this
10357 -- is how Link_With/Linker_Options differ)
10360 if Get_String_Char (S, F) = C then
10363 Store_String_Char (ASCII.NUL);
10366 Store_String_Char (Get_String_Char (S, F));
10374 if Present (Arg) then
10375 Store_String_Char (ASCII.NUL);
10379 Store_Linker_Option_String (End_String);
10387 -- pragma Linker_Alias (
10388 -- [Entity =>] LOCAL_NAME
10389 -- [Target =>] static_string_EXPRESSION);
10391 when Pragma_Linker_Alias =>
10393 Check_Arg_Order ((Name_Entity, Name_Target));
10394 Check_Arg_Count (2);
10395 Check_Optional_Identifier (Arg1, Name_Entity);
10396 Check_Optional_Identifier (Arg2, Name_Target);
10397 Check_Arg_Is_Library_Level_Local_Name (Arg1);
10398 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
10400 -- The only processing required is to link this item on to the
10401 -- list of rep items for the given entity. This is accomplished
10402 -- by the call to Rep_Item_Too_Late (when no error is detected
10403 -- and False is returned).
10405 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
10408 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
10411 ------------------------
10412 -- Linker_Constructor --
10413 ------------------------
10415 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
10417 -- Code is shared with Linker_Destructor
10419 -----------------------
10420 -- Linker_Destructor --
10421 -----------------------
10423 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
10425 when Pragma_Linker_Constructor |
10426 Pragma_Linker_Destructor =>
10427 Linker_Constructor : declare
10433 Check_Arg_Count (1);
10434 Check_No_Identifiers;
10435 Check_Arg_Is_Local_Name (Arg1);
10436 Arg1_X := Get_Pragma_Arg (Arg1);
10438 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
10440 if not Is_Library_Level_Entity (Proc) then
10442 ("argument for pragma% must be library level entity", Arg1);
10445 -- The only processing required is to link this item on to the
10446 -- list of rep items for the given entity. This is accomplished
10447 -- by the call to Rep_Item_Too_Late (when no error is detected
10448 -- and False is returned).
10450 if Rep_Item_Too_Late (Proc, N) then
10453 Set_Has_Gigi_Rep_Item (Proc);
10455 end Linker_Constructor;
10457 --------------------
10458 -- Linker_Options --
10459 --------------------
10461 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
10463 when Pragma_Linker_Options => Linker_Options : declare
10467 Check_Ada_83_Warning;
10468 Check_No_Identifiers;
10469 Check_Arg_Count (1);
10470 Check_Is_In_Decl_Part_Or_Package_Spec;
10471 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
10472 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
10475 while Present (Arg) loop
10476 Check_Arg_Is_Static_Expression (Arg, Standard_String);
10477 Store_String_Char (ASCII.NUL);
10479 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
10483 if Operating_Mode = Generate_Code
10484 and then In_Extended_Main_Source_Unit (N)
10486 Store_Linker_Option_String (End_String);
10488 end Linker_Options;
10490 --------------------
10491 -- Linker_Section --
10492 --------------------
10494 -- pragma Linker_Section (
10495 -- [Entity =>] LOCAL_NAME
10496 -- [Section =>] static_string_EXPRESSION);
10498 when Pragma_Linker_Section =>
10500 Check_Arg_Order ((Name_Entity, Name_Section));
10501 Check_Arg_Count (2);
10502 Check_Optional_Identifier (Arg1, Name_Entity);
10503 Check_Optional_Identifier (Arg2, Name_Section);
10504 Check_Arg_Is_Library_Level_Local_Name (Arg1);
10505 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
10507 -- This pragma applies only to objects
10509 if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) then
10510 Error_Pragma_Arg ("pragma% applies only to objects", Arg1);
10513 -- The only processing required is to link this item on to the
10514 -- list of rep items for the given entity. This is accomplished
10515 -- by the call to Rep_Item_Too_Late (when no error is detected
10516 -- and False is returned).
10518 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
10521 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
10528 -- pragma List (On | Off)
10530 -- There is nothing to do here, since we did all the processing for
10531 -- this pragma in Par.Prag (so that it works properly even in syntax
10534 when Pragma_List =>
10537 --------------------
10538 -- Locking_Policy --
10539 --------------------
10541 -- pragma Locking_Policy (policy_IDENTIFIER);
10543 when Pragma_Locking_Policy => declare
10547 Check_Ada_83_Warning;
10548 Check_Arg_Count (1);
10549 Check_No_Identifiers;
10550 Check_Arg_Is_Locking_Policy (Arg1);
10551 Check_Valid_Configuration_Pragma;
10552 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
10553 LP := Fold_Upper (Name_Buffer (1));
10555 if Locking_Policy /= ' '
10556 and then Locking_Policy /= LP
10558 Error_Msg_Sloc := Locking_Policy_Sloc;
10559 Error_Pragma ("locking policy incompatible with policy#");
10561 -- Set new policy, but always preserve System_Location since we
10562 -- like the error message with the run time name.
10565 Locking_Policy := LP;
10567 if Locking_Policy_Sloc /= System_Location then
10568 Locking_Policy_Sloc := Loc;
10577 -- pragma Long_Float (D_Float | G_Float);
10579 when Pragma_Long_Float =>
10581 Check_Valid_Configuration_Pragma;
10582 Check_Arg_Count (1);
10583 Check_No_Identifier (Arg1);
10584 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
10586 if not OpenVMS_On_Target then
10587 Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
10592 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
10593 if Opt.Float_Format_Long = 'G' then
10594 Error_Pragma ("G_Float previously specified");
10597 Opt.Float_Format_Long := 'D';
10599 -- G_Float case (this is the default, does not need overriding)
10602 if Opt.Float_Format_Long = 'D' then
10603 Error_Pragma ("D_Float previously specified");
10606 Opt.Float_Format_Long := 'G';
10609 Set_Standard_Fpt_Formats;
10611 -----------------------
10612 -- Machine_Attribute --
10613 -----------------------
10615 -- pragma Machine_Attribute (
10616 -- [Entity =>] LOCAL_NAME,
10617 -- [Attribute_Name =>] static_string_EXPRESSION
10618 -- [, [Info =>] static_EXPRESSION] );
10620 when Pragma_Machine_Attribute => Machine_Attribute : declare
10621 Def_Id : Entity_Id;
10625 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
10627 if Arg_Count = 3 then
10628 Check_Optional_Identifier (Arg3, Name_Info);
10629 Check_Arg_Is_Static_Expression (Arg3);
10631 Check_Arg_Count (2);
10634 Check_Optional_Identifier (Arg1, Name_Entity);
10635 Check_Optional_Identifier (Arg2, Name_Attribute_Name);
10636 Check_Arg_Is_Local_Name (Arg1);
10637 Check_Arg_Is_Static_Expression (Arg2, Standard_String);
10638 Def_Id := Entity (Get_Pragma_Arg (Arg1));
10640 if Is_Access_Type (Def_Id) then
10641 Def_Id := Designated_Type (Def_Id);
10644 if Rep_Item_Too_Early (Def_Id, N) then
10648 Def_Id := Underlying_Type (Def_Id);
10650 -- The only processing required is to link this item on to the
10651 -- list of rep items for the given entity. This is accomplished
10652 -- by the call to Rep_Item_Too_Late (when no error is detected
10653 -- and False is returned).
10655 if Rep_Item_Too_Late (Def_Id, N) then
10658 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
10660 end Machine_Attribute;
10667 -- (MAIN_OPTION [, MAIN_OPTION]);
10670 -- [STACK_SIZE =>] static_integer_EXPRESSION
10671 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
10672 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
10674 when Pragma_Main => Main : declare
10675 Args : Args_List (1 .. 3);
10676 Names : constant Name_List (1 .. 3) := (
10678 Name_Task_Stack_Size_Default,
10679 Name_Time_Slicing_Enabled);
10685 Gather_Associations (Names, Args);
10687 for J in 1 .. 2 loop
10688 if Present (Args (J)) then
10689 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
10693 if Present (Args (3)) then
10694 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
10698 while Present (Nod) loop
10699 if Nkind (Nod) = N_Pragma
10700 and then Pragma_Name (Nod) = Name_Main
10702 Error_Msg_Name_1 := Pname;
10703 Error_Msg_N ("duplicate pragma% not permitted", Nod);
10714 -- pragma Main_Storage
10715 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
10717 -- MAIN_STORAGE_OPTION ::=
10718 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
10719 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
10721 when Pragma_Main_Storage => Main_Storage : declare
10722 Args : Args_List (1 .. 2);
10723 Names : constant Name_List (1 .. 2) := (
10724 Name_Working_Storage,
10731 Gather_Associations (Names, Args);
10733 for J in 1 .. 2 loop
10734 if Present (Args (J)) then
10735 Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
10739 Check_In_Main_Program;
10742 while Present (Nod) loop
10743 if Nkind (Nod) = N_Pragma
10744 and then Pragma_Name (Nod) = Name_Main_Storage
10746 Error_Msg_Name_1 := Pname;
10747 Error_Msg_N ("duplicate pragma% not permitted", Nod);
10758 -- pragma Memory_Size (NUMERIC_LITERAL)
10760 when Pragma_Memory_Size =>
10763 -- Memory size is simply ignored
10765 Check_No_Identifiers;
10766 Check_Arg_Count (1);
10767 Check_Arg_Is_Integer_Literal (Arg1);
10775 -- The only correct use of this pragma is on its own in a file, in
10776 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
10777 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
10778 -- check for a file containing nothing but a No_Body pragma). If we
10779 -- attempt to process it during normal semantics processing, it means
10780 -- it was misplaced.
10782 when Pragma_No_Body =>
10790 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
10792 when Pragma_No_Return => No_Return : declare
10800 Check_At_Least_N_Arguments (1);
10802 -- Loop through arguments of pragma
10805 while Present (Arg) loop
10806 Check_Arg_Is_Local_Name (Arg);
10807 Id := Get_Pragma_Arg (Arg);
10810 if not Is_Entity_Name (Id) then
10811 Error_Pragma_Arg ("entity name required", Arg);
10814 if Etype (Id) = Any_Type then
10818 -- Loop to find matching procedures
10823 and then Scope (E) = Current_Scope
10825 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
10828 -- Set flag on any alias as well
10830 if Is_Overloadable (E) and then Present (Alias (E)) then
10831 Set_No_Return (Alias (E));
10837 exit when From_Aspect_Specification (N);
10842 Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
10853 -- pragma No_Run_Time;
10855 -- Note: this pragma is retained for backwards compatibility. See
10856 -- body of Rtsfind for full details on its handling.
10858 when Pragma_No_Run_Time =>
10860 Check_Valid_Configuration_Pragma;
10861 Check_Arg_Count (0);
10863 No_Run_Time_Mode := True;
10864 Configurable_Run_Time_Mode := True;
10866 -- Set Duration to 32 bits if word size is 32
10868 if Ttypes.System_Word_Size = 32 then
10869 Duration_32_Bits_On_Target := True;
10872 -- Set appropriate restrictions
10874 Set_Restriction (No_Finalization, N);
10875 Set_Restriction (No_Exception_Handlers, N);
10876 Set_Restriction (Max_Tasks, N, 0);
10877 Set_Restriction (No_Tasking, N);
10879 ------------------------
10880 -- No_Strict_Aliasing --
10881 ------------------------
10883 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
10885 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
10890 Check_At_Most_N_Arguments (1);
10892 if Arg_Count = 0 then
10893 Check_Valid_Configuration_Pragma;
10894 Opt.No_Strict_Aliasing := True;
10897 Check_Optional_Identifier (Arg2, Name_Entity);
10898 Check_Arg_Is_Local_Name (Arg1);
10899 E_Id := Entity (Get_Pragma_Arg (Arg1));
10901 if E_Id = Any_Type then
10903 elsif No (E_Id) or else not Is_Access_Type (E_Id) then
10904 Error_Pragma_Arg ("pragma% requires access type", Arg1);
10907 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
10909 end No_Strict_Aliasing;
10911 -----------------------
10912 -- Normalize_Scalars --
10913 -----------------------
10915 -- pragma Normalize_Scalars;
10917 when Pragma_Normalize_Scalars =>
10918 Check_Ada_83_Warning;
10919 Check_Arg_Count (0);
10920 Check_Valid_Configuration_Pragma;
10922 -- Normalize_Scalars creates false positives in CodePeer, so
10923 -- ignore this pragma in this mode.
10925 if not CodePeer_Mode then
10926 Normalize_Scalars := True;
10927 Init_Or_Norm_Scalars := True;
10934 -- pragma Obsolescent;
10936 -- pragma Obsolescent (
10937 -- [Message =>] static_string_EXPRESSION
10938 -- [,[Version =>] Ada_05]]);
10940 -- pragma Obsolescent (
10941 -- [Entity =>] NAME
10942 -- [,[Message =>] static_string_EXPRESSION
10943 -- [,[Version =>] Ada_05]] );
10945 when Pragma_Obsolescent => Obsolescent : declare
10949 procedure Set_Obsolescent (E : Entity_Id);
10950 -- Given an entity Ent, mark it as obsolescent if appropriate
10952 ---------------------
10953 -- Set_Obsolescent --
10954 ---------------------
10956 procedure Set_Obsolescent (E : Entity_Id) is
10965 -- Entity name was given
10967 if Present (Ename) then
10969 -- If entity name matches, we are fine. Save entity in
10970 -- pragma argument, for ASIS use.
10972 if Chars (Ename) = Chars (Ent) then
10973 Set_Entity (Ename, Ent);
10974 Generate_Reference (Ent, Ename);
10976 -- If entity name does not match, only possibility is an
10977 -- enumeration literal from an enumeration type declaration.
10979 elsif Ekind (Ent) /= E_Enumeration_Type then
10981 ("pragma % entity name does not match declaration");
10984 Ent := First_Literal (E);
10988 ("pragma % entity name does not match any " &
10989 "enumeration literal");
10991 elsif Chars (Ent) = Chars (Ename) then
10992 Set_Entity (Ename, Ent);
10993 Generate_Reference (Ent, Ename);
10997 Ent := Next_Literal (Ent);
11003 -- Ent points to entity to be marked
11005 if Arg_Count >= 1 then
11007 -- Deal with static string argument
11009 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
11010 S := Strval (Get_Pragma_Arg (Arg1));
11012 for J in 1 .. String_Length (S) loop
11013 if not In_Character_Range (Get_String_Char (S, J)) then
11015 ("pragma% argument does not allow wide characters",
11020 Obsolescent_Warnings.Append
11021 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
11023 -- Check for Ada_05 parameter
11025 if Arg_Count /= 1 then
11026 Check_Arg_Count (2);
11029 Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
11032 Check_Arg_Is_Identifier (Argx);
11034 if Chars (Argx) /= Name_Ada_05 then
11035 Error_Msg_Name_2 := Name_Ada_05;
11037 ("only allowed argument for pragma% is %", Argx);
11040 if Ada_Version_Explicit < Ada_2005
11041 or else not Warn_On_Ada_2005_Compatibility
11049 -- Set flag if pragma active
11052 Set_Is_Obsolescent (Ent);
11056 end Set_Obsolescent;
11058 -- Start of processing for pragma Obsolescent
11063 Check_At_Most_N_Arguments (3);
11065 -- See if first argument specifies an entity name
11069 (Chars (Arg1) = Name_Entity
11071 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
11073 N_Operator_Symbol))
11075 Ename := Get_Pragma_Arg (Arg1);
11077 -- Eliminate first argument, so we can share processing
11081 Arg_Count := Arg_Count - 1;
11083 -- No Entity name argument given
11089 if Arg_Count >= 1 then
11090 Check_Optional_Identifier (Arg1, Name_Message);
11092 if Arg_Count = 2 then
11093 Check_Optional_Identifier (Arg2, Name_Version);
11097 -- Get immediately preceding declaration
11100 while Present (Decl) and then Nkind (Decl) = N_Pragma loop
11104 -- Cases where we do not follow anything other than another pragma
11108 -- First case: library level compilation unit declaration with
11109 -- the pragma immediately following the declaration.
11111 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
11113 (Defining_Entity (Unit (Parent (Parent (N)))));
11116 -- Case 2: library unit placement for package
11120 Ent : constant Entity_Id := Find_Lib_Unit_Name;
11122 if Is_Package_Or_Generic_Package (Ent) then
11123 Set_Obsolescent (Ent);
11129 -- Cases where we must follow a declaration
11132 if Nkind (Decl) not in N_Declaration
11133 and then Nkind (Decl) not in N_Later_Decl_Item
11134 and then Nkind (Decl) not in N_Generic_Declaration
11135 and then Nkind (Decl) not in N_Renaming_Declaration
11138 ("pragma% misplaced, "
11139 & "must immediately follow a declaration");
11142 Set_Obsolescent (Defining_Entity (Decl));
11152 -- pragma Optimize (Time | Space | Off);
11154 -- The actual check for optimize is done in Gigi. Note that this
11155 -- pragma does not actually change the optimization setting, it
11156 -- simply checks that it is consistent with the pragma.
11158 when Pragma_Optimize =>
11159 Check_No_Identifiers;
11160 Check_Arg_Count (1);
11161 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
11163 ------------------------
11164 -- Optimize_Alignment --
11165 ------------------------
11167 -- pragma Optimize_Alignment (Time | Space | Off);
11169 when Pragma_Optimize_Alignment => Optimize_Alignment : begin
11171 Check_No_Identifiers;
11172 Check_Arg_Count (1);
11173 Check_Valid_Configuration_Pragma;
11176 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
11180 Opt.Optimize_Alignment := 'T';
11182 Opt.Optimize_Alignment := 'S';
11184 Opt.Optimize_Alignment := 'O';
11186 Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
11190 -- Set indication that mode is set locally. If we are in fact in a
11191 -- configuration pragma file, this setting is harmless since the
11192 -- switch will get reset anyway at the start of each unit.
11194 Optimize_Alignment_Local := True;
11195 end Optimize_Alignment;
11201 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
11203 when Pragma_Ordered => Ordered : declare
11204 Assoc : constant Node_Id := Arg1;
11210 Check_No_Identifiers;
11211 Check_Arg_Count (1);
11212 Check_Arg_Is_Local_Name (Arg1);
11214 Type_Id := Get_Pragma_Arg (Assoc);
11215 Find_Type (Type_Id);
11216 Typ := Entity (Type_Id);
11218 if Typ = Any_Type then
11221 Typ := Underlying_Type (Typ);
11224 if not Is_Enumeration_Type (Typ) then
11225 Error_Pragma ("pragma% must specify enumeration type");
11228 Check_First_Subtype (Arg1);
11229 Set_Has_Pragma_Ordered (Base_Type (Typ));
11236 -- pragma Pack (first_subtype_LOCAL_NAME);
11238 when Pragma_Pack => Pack : declare
11239 Assoc : constant Node_Id := Arg1;
11243 Ignore : Boolean := False;
11246 Check_No_Identifiers;
11247 Check_Arg_Count (1);
11248 Check_Arg_Is_Local_Name (Arg1);
11250 Type_Id := Get_Pragma_Arg (Assoc);
11251 Find_Type (Type_Id);
11252 Typ := Entity (Type_Id);
11255 or else Rep_Item_Too_Early (Typ, N)
11259 Typ := Underlying_Type (Typ);
11262 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
11263 Error_Pragma ("pragma% must specify array or record type");
11266 Check_First_Subtype (Arg1);
11267 Check_Duplicate_Pragma (Typ);
11271 if Is_Array_Type (Typ) then
11272 Ctyp := Component_Type (Typ);
11274 -- Ignore pack that does nothing
11276 if Known_Static_Esize (Ctyp)
11277 and then Known_Static_RM_Size (Ctyp)
11278 and then Esize (Ctyp) = RM_Size (Ctyp)
11279 and then Addressable (Esize (Ctyp))
11284 -- Process OK pragma Pack. Note that if there is a separate
11285 -- component clause present, the Pack will be cancelled. This
11286 -- processing is in Freeze.
11288 if not Rep_Item_Too_Late (Typ, N) then
11290 -- In the context of static code analysis, we do not need
11291 -- complex front-end expansions related to pragma Pack,
11292 -- so disable handling of pragma Pack in this case.
11294 if CodePeer_Mode then
11297 -- Don't attempt any packing for VM targets. We possibly
11298 -- could deal with some cases of array bit-packing, but we
11299 -- don't bother, since this is not a typical kind of
11300 -- representation in the VM context anyway (and would not
11301 -- for example work nicely with the debugger).
11303 elsif VM_Target /= No_VM then
11304 if not GNAT_Mode then
11306 ("?pragma% ignored in this configuration");
11309 -- Normal case where we do the pack action
11313 Set_Is_Packed (Base_Type (Typ));
11314 Set_Has_Non_Standard_Rep (Base_Type (Typ));
11317 Set_Has_Pragma_Pack (Base_Type (Typ));
11321 -- For record types, the pack is always effective
11323 else pragma Assert (Is_Record_Type (Typ));
11324 if not Rep_Item_Too_Late (Typ, N) then
11326 -- Ignore pack request with warning in VM mode (skip warning
11327 -- if we are compiling GNAT run time library).
11329 if VM_Target /= No_VM then
11330 if not GNAT_Mode then
11332 ("?pragma% ignored in this configuration");
11335 -- Normal case of pack request active
11338 Set_Is_Packed (Base_Type (Typ));
11339 Set_Has_Pragma_Pack (Base_Type (Typ));
11340 Set_Has_Non_Standard_Rep (Base_Type (Typ));
11352 -- There is nothing to do here, since we did all the processing for
11353 -- this pragma in Par.Prag (so that it works properly even in syntax
11356 when Pragma_Page =>
11363 -- pragma Passive [(PASSIVE_FORM)];
11365 -- PASSIVE_FORM ::= Semaphore | No
11367 when Pragma_Passive =>
11370 if Nkind (Parent (N)) /= N_Task_Definition then
11371 Error_Pragma ("pragma% must be within task definition");
11374 if Arg_Count /= 0 then
11375 Check_Arg_Count (1);
11376 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
11379 ----------------------------------
11380 -- Preelaborable_Initialization --
11381 ----------------------------------
11383 -- pragma Preelaborable_Initialization (DIRECT_NAME);
11385 when Pragma_Preelaborable_Initialization => Preelab_Init : declare
11390 Check_Arg_Count (1);
11391 Check_No_Identifiers;
11392 Check_Arg_Is_Identifier (Arg1);
11393 Check_Arg_Is_Local_Name (Arg1);
11394 Check_First_Subtype (Arg1);
11395 Ent := Entity (Get_Pragma_Arg (Arg1));
11397 if not (Is_Private_Type (Ent)
11399 Is_Protected_Type (Ent)
11401 (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent)))
11404 ("pragma % can only be applied to private, formal derived or "
11405 & "protected type",
11409 -- Give an error if the pragma is applied to a protected type that
11410 -- does not qualify (due to having entries, or due to components
11411 -- that do not qualify).
11413 if Is_Protected_Type (Ent)
11414 and then not Has_Preelaborable_Initialization (Ent)
11417 ("protected type & does not have preelaborable " &
11418 "initialization", Ent);
11420 -- Otherwise mark the type as definitely having preelaborable
11424 Set_Known_To_Have_Preelab_Init (Ent);
11427 if Has_Pragma_Preelab_Init (Ent)
11428 and then Warn_On_Redundant_Constructs
11430 Error_Pragma ("?duplicate pragma%!");
11432 Set_Has_Pragma_Preelab_Init (Ent);
11436 --------------------
11437 -- Persistent_BSS --
11438 --------------------
11440 -- pragma Persistent_BSS [(object_NAME)];
11442 when Pragma_Persistent_BSS => Persistent_BSS : declare
11449 Check_At_Most_N_Arguments (1);
11451 -- Case of application to specific object (one argument)
11453 if Arg_Count = 1 then
11454 Check_Arg_Is_Library_Level_Local_Name (Arg1);
11456 if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
11458 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
11461 Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
11464 Ent := Entity (Get_Pragma_Arg (Arg1));
11465 Decl := Parent (Ent);
11467 if Rep_Item_Too_Late (Ent, N) then
11471 if Present (Expression (Decl)) then
11473 ("object for pragma% cannot have initialization", Arg1);
11476 if not Is_Potentially_Persistent_Type (Etype (Ent)) then
11478 ("object type for pragma% is not potentially persistent",
11482 Check_Duplicate_Pragma (Ent);
11485 Make_Linker_Section_Pragma
11486 (Ent, Sloc (N), ".persistent.bss");
11487 Insert_After (N, Prag);
11490 -- Case of use as configuration pragma with no arguments
11493 Check_Valid_Configuration_Pragma;
11494 Persistent_BSS_Mode := True;
11496 end Persistent_BSS;
11502 -- pragma Polling (ON | OFF);
11504 when Pragma_Polling =>
11506 Check_Arg_Count (1);
11507 Check_No_Identifiers;
11508 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11509 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
11511 -------------------
11512 -- Postcondition --
11513 -------------------
11515 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
11516 -- [,[Message =>] String_EXPRESSION]);
11518 when Pragma_Postcondition => Postcondition : declare
11520 pragma Warnings (Off, In_Body);
11524 Check_At_Least_N_Arguments (1);
11525 Check_At_Most_N_Arguments (2);
11526 Check_Optional_Identifier (Arg1, Name_Check);
11528 -- All we need to do here is call the common check procedure,
11529 -- the remainder of the processing is found in Sem_Ch6/Sem_Ch7.
11531 Check_Precondition_Postcondition (In_Body);
11538 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
11539 -- [,[Message =>] String_EXPRESSION]);
11541 when Pragma_Precondition => Precondition : declare
11546 Check_At_Least_N_Arguments (1);
11547 Check_At_Most_N_Arguments (2);
11548 Check_Optional_Identifier (Arg1, Name_Check);
11549 Check_Precondition_Postcondition (In_Body);
11551 -- If in spec, nothing more to do. If in body, then we convert the
11552 -- pragma to pragma Check (Precondition, cond [, msg]). Note we do
11553 -- this whether or not precondition checks are enabled. That works
11554 -- fine since pragma Check will do this check, and will also
11555 -- analyze the condition itself in the proper context.
11560 Chars => Name_Check,
11561 Pragma_Argument_Associations => New_List (
11562 Make_Pragma_Argument_Association (Loc,
11563 Expression => Make_Identifier (Loc, Name_Precondition)),
11565 Make_Pragma_Argument_Association (Sloc (Arg1),
11566 Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
11568 if Arg_Count = 2 then
11569 Append_To (Pragma_Argument_Associations (N),
11570 Make_Pragma_Argument_Association (Sloc (Arg2),
11571 Expression => Relocate_Node (Get_Pragma_Arg (Arg2))));
11582 -- pragma Predicate
11583 -- ([Entity =>] type_LOCAL_NAME,
11584 -- [Check =>] EXPRESSION);
11586 when Pragma_Predicate => Predicate : declare
11591 pragma Unreferenced (Discard);
11595 Check_Arg_Count (2);
11596 Check_Optional_Identifier (Arg1, Name_Entity);
11597 Check_Optional_Identifier (Arg2, Name_Check);
11599 Check_Arg_Is_Local_Name (Arg1);
11601 Type_Id := Get_Pragma_Arg (Arg1);
11602 Find_Type (Type_Id);
11603 Typ := Entity (Type_Id);
11605 if Typ = Any_Type then
11609 -- The remaining processing is simply to link the pragma on to
11610 -- the rep item chain, for processing when the type is frozen.
11611 -- This is accomplished by a call to Rep_Item_Too_Late. We also
11612 -- mark the type as having predicates.
11614 Set_Has_Predicates (Typ);
11615 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
11622 -- pragma Preelaborate [(library_unit_NAME)];
11624 -- Set the flag Is_Preelaborated of program unit name entity
11626 when Pragma_Preelaborate => Preelaborate : declare
11627 Pa : constant Node_Id := Parent (N);
11628 Pk : constant Node_Kind := Nkind (Pa);
11632 Check_Ada_83_Warning;
11633 Check_Valid_Library_Unit_Pragma;
11635 if Nkind (N) = N_Null_Statement then
11639 Ent := Find_Lib_Unit_Name;
11640 Check_Duplicate_Pragma (Ent);
11642 -- This filters out pragmas inside generic parent then
11643 -- show up inside instantiation
11646 and then not (Pk = N_Package_Specification
11647 and then Present (Generic_Parent (Pa)))
11649 if not Debug_Flag_U then
11650 Set_Is_Preelaborated (Ent);
11651 Set_Suppress_Elaboration_Warnings (Ent);
11656 ---------------------
11657 -- Preelaborate_05 --
11658 ---------------------
11660 -- pragma Preelaborate_05 [(library_unit_NAME)];
11662 -- This pragma is useable only in GNAT_Mode, where it is used like
11663 -- pragma Preelaborate but it is only effective in Ada 2005 mode
11664 -- (otherwise it is ignored). This is used to implement AI-362 which
11665 -- recategorizes some run-time packages in Ada 2005 mode.
11667 when Pragma_Preelaborate_05 => Preelaborate_05 : declare
11672 Check_Valid_Library_Unit_Pragma;
11674 if not GNAT_Mode then
11675 Error_Pragma ("pragma% only available in GNAT mode");
11678 if Nkind (N) = N_Null_Statement then
11682 -- This is one of the few cases where we need to test the value of
11683 -- Ada_Version_Explicit rather than Ada_Version (which is always
11684 -- set to Ada_2012 in a predefined unit), we need to know the
11685 -- explicit version set to know if this pragma is active.
11687 if Ada_Version_Explicit >= Ada_2005 then
11688 Ent := Find_Lib_Unit_Name;
11689 Set_Is_Preelaborated (Ent);
11690 Set_Suppress_Elaboration_Warnings (Ent);
11692 end Preelaborate_05;
11698 -- pragma Priority (EXPRESSION);
11700 when Pragma_Priority => Priority : declare
11701 P : constant Node_Id := Parent (N);
11705 Check_No_Identifiers;
11706 Check_Arg_Count (1);
11710 if Nkind (P) = N_Subprogram_Body then
11711 Check_In_Main_Program;
11713 Arg := Get_Pragma_Arg (Arg1);
11714 Analyze_And_Resolve (Arg, Standard_Integer);
11718 if not Is_Static_Expression (Arg) then
11719 Flag_Non_Static_Expr
11720 ("main subprogram priority is not static!", Arg);
11723 -- If constraint error, then we already signalled an error
11725 elsif Raises_Constraint_Error (Arg) then
11728 -- Otherwise check in range
11732 Val : constant Uint := Expr_Value (Arg);
11736 or else Val > Expr_Value (Expression
11737 (Parent (RTE (RE_Max_Priority))))
11740 ("main subprogram priority is out of range", Arg1);
11746 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
11748 -- Load an arbitrary entity from System.Tasking to make sure
11749 -- this package is implicitly with'ed, since we need to have
11750 -- the tasking run-time active for the pragma Priority to have
11754 Discard : Entity_Id;
11755 pragma Warnings (Off, Discard);
11757 Discard := RTE (RE_Task_List);
11760 -- Task or Protected, must be of type Integer
11762 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
11763 Arg := Get_Pragma_Arg (Arg1);
11765 -- The expression must be analyzed in the special manner
11766 -- described in "Handling of Default and Per-Object
11767 -- Expressions" in sem.ads.
11769 Preanalyze_Spec_Expression (Arg, Standard_Integer);
11771 if not Is_Static_Expression (Arg) then
11772 Check_Restriction (Static_Priorities, Arg);
11775 -- Anything else is incorrect
11781 if Has_Pragma_Priority (P) then
11782 Error_Pragma ("duplicate pragma% not allowed");
11784 Set_Has_Pragma_Priority (P, True);
11786 if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
11787 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
11788 -- exp_ch9 should use this ???
11793 -----------------------------------
11794 -- Priority_Specific_Dispatching --
11795 -----------------------------------
11797 -- pragma Priority_Specific_Dispatching (
11798 -- policy_IDENTIFIER,
11799 -- first_priority_EXPRESSION,
11800 -- last_priority_EXPRESSION);
11802 when Pragma_Priority_Specific_Dispatching =>
11803 Priority_Specific_Dispatching : declare
11804 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
11805 -- This is the entity System.Any_Priority;
11808 Lower_Bound : Node_Id;
11809 Upper_Bound : Node_Id;
11815 Check_Arg_Count (3);
11816 Check_No_Identifiers;
11817 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
11818 Check_Valid_Configuration_Pragma;
11819 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
11820 DP := Fold_Upper (Name_Buffer (1));
11822 Lower_Bound := Get_Pragma_Arg (Arg2);
11823 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
11824 Lower_Val := Expr_Value (Lower_Bound);
11826 Upper_Bound := Get_Pragma_Arg (Arg3);
11827 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
11828 Upper_Val := Expr_Value (Upper_Bound);
11830 -- It is not allowed to use Task_Dispatching_Policy and
11831 -- Priority_Specific_Dispatching in the same partition.
11833 if Task_Dispatching_Policy /= ' ' then
11834 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11836 ("pragma% incompatible with Task_Dispatching_Policy#");
11838 -- Check lower bound in range
11840 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
11842 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
11845 ("first_priority is out of range", Arg2);
11847 -- Check upper bound in range
11849 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
11851 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
11854 ("last_priority is out of range", Arg3);
11856 -- Check that the priority range is valid
11858 elsif Lower_Val > Upper_Val then
11860 ("last_priority_expression must be greater than" &
11861 " or equal to first_priority_expression");
11863 -- Store the new policy, but always preserve System_Location since
11864 -- we like the error message with the run-time name.
11867 -- Check overlapping in the priority ranges specified in other
11868 -- Priority_Specific_Dispatching pragmas within the same
11869 -- partition. We can only check those we know about!
11872 Specific_Dispatching.First .. Specific_Dispatching.Last
11874 if Specific_Dispatching.Table (J).First_Priority in
11875 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
11876 or else Specific_Dispatching.Table (J).Last_Priority in
11877 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
11880 Specific_Dispatching.Table (J).Pragma_Loc;
11882 ("priority range overlaps with "
11883 & "Priority_Specific_Dispatching#");
11887 -- The use of Priority_Specific_Dispatching is incompatible
11888 -- with Task_Dispatching_Policy.
11890 if Task_Dispatching_Policy /= ' ' then
11891 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11893 ("Priority_Specific_Dispatching incompatible "
11894 & "with Task_Dispatching_Policy#");
11897 -- The use of Priority_Specific_Dispatching forces ceiling
11900 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
11901 Error_Msg_Sloc := Locking_Policy_Sloc;
11903 ("Priority_Specific_Dispatching incompatible "
11904 & "with Locking_Policy#");
11906 -- Set the Ceiling_Locking policy, but preserve System_Location
11907 -- since we like the error message with the run time name.
11910 Locking_Policy := 'C';
11912 if Locking_Policy_Sloc /= System_Location then
11913 Locking_Policy_Sloc := Loc;
11917 -- Add entry in the table
11919 Specific_Dispatching.Append
11920 ((Dispatching_Policy => DP,
11921 First_Priority => UI_To_Int (Lower_Val),
11922 Last_Priority => UI_To_Int (Upper_Val),
11923 Pragma_Loc => Loc));
11925 end Priority_Specific_Dispatching;
11931 -- pragma Profile (profile_IDENTIFIER);
11933 -- profile_IDENTIFIER => Restricted | Ravenscar
11935 when Pragma_Profile =>
11937 Check_Arg_Count (1);
11938 Check_Valid_Configuration_Pragma;
11939 Check_No_Identifiers;
11942 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
11944 if Chars (Argx) = Name_Ravenscar then
11945 Set_Ravenscar_Profile (N);
11946 elsif Chars (Argx) = Name_Restricted then
11947 Set_Profile_Restrictions
11948 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
11950 Error_Pragma_Arg ("& is not a valid profile", Argx);
11954 ----------------------
11955 -- Profile_Warnings --
11956 ----------------------
11958 -- pragma Profile_Warnings (profile_IDENTIFIER);
11960 -- profile_IDENTIFIER => Restricted | Ravenscar
11962 when Pragma_Profile_Warnings =>
11964 Check_Arg_Count (1);
11965 Check_Valid_Configuration_Pragma;
11966 Check_No_Identifiers;
11969 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
11971 if Chars (Argx) = Name_Ravenscar then
11972 Set_Profile_Restrictions (Ravenscar, N, Warn => True);
11973 elsif Chars (Argx) = Name_Restricted then
11974 Set_Profile_Restrictions (Restricted, N, Warn => True);
11976 Error_Pragma_Arg ("& is not a valid profile", Argx);
11980 --------------------------
11981 -- Propagate_Exceptions --
11982 --------------------------
11984 -- pragma Propagate_Exceptions;
11986 -- Note: this pragma is obsolete and has no effect
11988 when Pragma_Propagate_Exceptions =>
11990 Check_Arg_Count (0);
11992 if In_Extended_Main_Source_Unit (N) then
11993 Propagate_Exceptions := True;
12000 -- pragma Psect_Object (
12001 -- [Internal =>] LOCAL_NAME,
12002 -- [, [External =>] EXTERNAL_SYMBOL]
12003 -- [, [Size =>] EXTERNAL_SYMBOL]);
12005 when Pragma_Psect_Object | Pragma_Common_Object =>
12006 Psect_Object : declare
12007 Args : Args_List (1 .. 3);
12008 Names : constant Name_List (1 .. 3) := (
12013 Internal : Node_Id renames Args (1);
12014 External : Node_Id renames Args (2);
12015 Size : Node_Id renames Args (3);
12017 Def_Id : Entity_Id;
12019 procedure Check_Too_Long (Arg : Node_Id);
12020 -- Posts message if the argument is an identifier with more
12021 -- than 31 characters, or a string literal with more than
12022 -- 31 characters, and we are operating under VMS
12024 --------------------
12025 -- Check_Too_Long --
12026 --------------------
12028 procedure Check_Too_Long (Arg : Node_Id) is
12029 X : constant Node_Id := Original_Node (Arg);
12032 if not Nkind_In (X, N_String_Literal, N_Identifier) then
12034 ("inappropriate argument for pragma %", Arg);
12037 if OpenVMS_On_Target then
12038 if (Nkind (X) = N_String_Literal
12039 and then String_Length (Strval (X)) > 31)
12041 (Nkind (X) = N_Identifier
12042 and then Length_Of_Name (Chars (X)) > 31)
12045 ("argument for pragma % is longer than 31 characters",
12049 end Check_Too_Long;
12051 -- Start of processing for Common_Object/Psect_Object
12055 Gather_Associations (Names, Args);
12056 Process_Extended_Import_Export_Internal_Arg (Internal);
12058 Def_Id := Entity (Internal);
12060 if not Ekind_In (Def_Id, E_Constant, E_Variable) then
12062 ("pragma% must designate an object", Internal);
12065 Check_Too_Long (Internal);
12067 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
12069 ("cannot use pragma% for imported/exported object",
12073 if Is_Concurrent_Type (Etype (Internal)) then
12075 ("cannot specify pragma % for task/protected object",
12079 if Has_Rep_Pragma (Def_Id, Name_Common_Object)
12081 Has_Rep_Pragma (Def_Id, Name_Psect_Object)
12083 Error_Msg_N ("?duplicate Common/Psect_Object pragma", N);
12086 if Ekind (Def_Id) = E_Constant then
12088 ("cannot specify pragma % for a constant", Internal);
12091 if Is_Record_Type (Etype (Internal)) then
12097 Ent := First_Entity (Etype (Internal));
12098 while Present (Ent) loop
12099 Decl := Declaration_Node (Ent);
12101 if Ekind (Ent) = E_Component
12102 and then Nkind (Decl) = N_Component_Declaration
12103 and then Present (Expression (Decl))
12104 and then Warn_On_Export_Import
12107 ("?object for pragma % has defaults", Internal);
12117 if Present (Size) then
12118 Check_Too_Long (Size);
12121 if Present (External) then
12122 Check_Arg_Is_External_Name (External);
12123 Check_Too_Long (External);
12126 -- If all error tests pass, link pragma on to the rep item chain
12128 Record_Rep_Item (Def_Id, N);
12135 -- pragma Pure [(library_unit_NAME)];
12137 when Pragma_Pure => Pure : declare
12141 Check_Ada_83_Warning;
12142 Check_Valid_Library_Unit_Pragma;
12144 if Nkind (N) = N_Null_Statement then
12148 Ent := Find_Lib_Unit_Name;
12150 Set_Has_Pragma_Pure (Ent);
12151 Set_Suppress_Elaboration_Warnings (Ent);
12158 -- pragma Pure_05 [(library_unit_NAME)];
12160 -- This pragma is useable only in GNAT_Mode, where it is used like
12161 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise
12162 -- it is ignored). It may be used after a pragma Preelaborate, in
12163 -- which case it overrides the effect of the pragma Preelaborate.
12164 -- This is used to implement AI-362 which recategorizes some run-time
12165 -- packages in Ada 2005 mode.
12167 when Pragma_Pure_05 => Pure_05 : declare
12172 Check_Valid_Library_Unit_Pragma;
12174 if not GNAT_Mode then
12175 Error_Pragma ("pragma% only available in GNAT mode");
12178 if Nkind (N) = N_Null_Statement then
12182 -- This is one of the few cases where we need to test the value of
12183 -- Ada_Version_Explicit rather than Ada_Version (which is always
12184 -- set to Ada_2012 in a predefined unit), we need to know the
12185 -- explicit version set to know if this pragma is active.
12187 if Ada_Version_Explicit >= Ada_2005 then
12188 Ent := Find_Lib_Unit_Name;
12189 Set_Is_Preelaborated (Ent, False);
12191 Set_Suppress_Elaboration_Warnings (Ent);
12195 -------------------
12196 -- Pure_Function --
12197 -------------------
12199 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
12201 when Pragma_Pure_Function => Pure_Function : declare
12204 Def_Id : Entity_Id;
12205 Effective : Boolean := False;
12209 Check_Arg_Count (1);
12210 Check_Optional_Identifier (Arg1, Name_Entity);
12211 Check_Arg_Is_Local_Name (Arg1);
12212 E_Id := Get_Pragma_Arg (Arg1);
12214 if Error_Posted (E_Id) then
12218 -- Loop through homonyms (overloadings) of referenced entity
12220 E := Entity (E_Id);
12222 if Present (E) then
12224 Def_Id := Get_Base_Subprogram (E);
12226 if not Ekind_In (Def_Id, E_Function,
12227 E_Generic_Function,
12231 ("pragma% requires a function name", Arg1);
12234 Set_Is_Pure (Def_Id);
12236 if not Has_Pragma_Pure_Function (Def_Id) then
12237 Set_Has_Pragma_Pure_Function (Def_Id);
12241 exit when From_Aspect_Specification (N);
12243 exit when No (E) or else Scope (E) /= Current_Scope;
12247 and then Warn_On_Redundant_Constructs
12250 ("pragma Pure_Function on& is redundant?",
12256 --------------------
12257 -- Queuing_Policy --
12258 --------------------
12260 -- pragma Queuing_Policy (policy_IDENTIFIER);
12262 when Pragma_Queuing_Policy => declare
12266 Check_Ada_83_Warning;
12267 Check_Arg_Count (1);
12268 Check_No_Identifiers;
12269 Check_Arg_Is_Queuing_Policy (Arg1);
12270 Check_Valid_Configuration_Pragma;
12271 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
12272 QP := Fold_Upper (Name_Buffer (1));
12274 if Queuing_Policy /= ' '
12275 and then Queuing_Policy /= QP
12277 Error_Msg_Sloc := Queuing_Policy_Sloc;
12278 Error_Pragma ("queuing policy incompatible with policy#");
12280 -- Set new policy, but always preserve System_Location since we
12281 -- like the error message with the run time name.
12284 Queuing_Policy := QP;
12286 if Queuing_Policy_Sloc /= System_Location then
12287 Queuing_Policy_Sloc := Loc;
12292 -----------------------
12293 -- Relative_Deadline --
12294 -----------------------
12296 -- pragma Relative_Deadline (time_span_EXPRESSION);
12298 when Pragma_Relative_Deadline => Relative_Deadline : declare
12299 P : constant Node_Id := Parent (N);
12304 Check_No_Identifiers;
12305 Check_Arg_Count (1);
12307 Arg := Get_Pragma_Arg (Arg1);
12309 -- The expression must be analyzed in the special manner described
12310 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
12312 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
12316 if Nkind (P) = N_Subprogram_Body then
12317 Check_In_Main_Program;
12321 elsif Nkind (P) = N_Task_Definition then
12324 -- Anything else is incorrect
12330 if Has_Relative_Deadline_Pragma (P) then
12331 Error_Pragma ("duplicate pragma% not allowed");
12333 Set_Has_Relative_Deadline_Pragma (P, True);
12335 if Nkind (P) = N_Task_Definition then
12336 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
12339 end Relative_Deadline;
12341 ---------------------------
12342 -- Remote_Call_Interface --
12343 ---------------------------
12345 -- pragma Remote_Call_Interface [(library_unit_NAME)];
12347 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
12348 Cunit_Node : Node_Id;
12349 Cunit_Ent : Entity_Id;
12353 Check_Ada_83_Warning;
12354 Check_Valid_Library_Unit_Pragma;
12356 if Nkind (N) = N_Null_Statement then
12360 Cunit_Node := Cunit (Current_Sem_Unit);
12361 K := Nkind (Unit (Cunit_Node));
12362 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
12364 if K = N_Package_Declaration
12365 or else K = N_Generic_Package_Declaration
12366 or else K = N_Subprogram_Declaration
12367 or else K = N_Generic_Subprogram_Declaration
12368 or else (K = N_Subprogram_Body
12369 and then Acts_As_Spec (Unit (Cunit_Node)))
12374 "pragma% must apply to package or subprogram declaration");
12377 Set_Is_Remote_Call_Interface (Cunit_Ent);
12378 end Remote_Call_Interface;
12384 -- pragma Remote_Types [(library_unit_NAME)];
12386 when Pragma_Remote_Types => Remote_Types : declare
12387 Cunit_Node : Node_Id;
12388 Cunit_Ent : Entity_Id;
12391 Check_Ada_83_Warning;
12392 Check_Valid_Library_Unit_Pragma;
12394 if Nkind (N) = N_Null_Statement then
12398 Cunit_Node := Cunit (Current_Sem_Unit);
12399 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
12401 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
12402 N_Generic_Package_Declaration)
12405 ("pragma% can only apply to a package declaration");
12408 Set_Is_Remote_Types (Cunit_Ent);
12415 -- pragma Ravenscar;
12417 when Pragma_Ravenscar =>
12419 Check_Arg_Count (0);
12420 Check_Valid_Configuration_Pragma;
12421 Set_Ravenscar_Profile (N);
12423 if Warn_On_Obsolescent_Feature then
12424 Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N);
12425 Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N);
12428 -------------------------
12429 -- Restricted_Run_Time --
12430 -------------------------
12432 -- pragma Restricted_Run_Time;
12434 when Pragma_Restricted_Run_Time =>
12436 Check_Arg_Count (0);
12437 Check_Valid_Configuration_Pragma;
12438 Set_Profile_Restrictions
12439 (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
12441 if Warn_On_Obsolescent_Feature then
12443 ("pragma Restricted_Run_Time is an obsolescent feature?", N);
12444 Error_Msg_N ("|use pragma Profile (Restricted) instead", N);
12451 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
12454 -- restriction_IDENTIFIER
12455 -- | restriction_parameter_IDENTIFIER => EXPRESSION
12457 when Pragma_Restrictions =>
12458 Process_Restrictions_Or_Restriction_Warnings
12459 (Warn => Treat_Restrictions_As_Warnings);
12461 --------------------------
12462 -- Restriction_Warnings --
12463 --------------------------
12465 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
12468 -- restriction_IDENTIFIER
12469 -- | restriction_parameter_IDENTIFIER => EXPRESSION
12471 when Pragma_Restriction_Warnings =>
12473 Process_Restrictions_Or_Restriction_Warnings (Warn => True);
12479 -- pragma Reviewable;
12481 when Pragma_Reviewable =>
12482 Check_Ada_83_Warning;
12483 Check_Arg_Count (0);
12485 -- Call dummy debugging function rv. This is done to assist front
12486 -- end debugging. By placing a Reviewable pragma in the source
12487 -- program, a breakpoint on rv catches this place in the source,
12488 -- allowing convenient stepping to the point of interest.
12492 --------------------------
12493 -- Short_Circuit_And_Or --
12494 --------------------------
12496 when Pragma_Short_Circuit_And_Or =>
12498 Check_Arg_Count (0);
12499 Check_Valid_Configuration_Pragma;
12500 Short_Circuit_And_Or := True;
12502 -------------------
12503 -- Share_Generic --
12504 -------------------
12506 -- pragma Share_Generic (NAME {, NAME});
12508 when Pragma_Share_Generic =>
12510 Process_Generic_List;
12516 -- pragma Shared (LOCAL_NAME);
12518 when Pragma_Shared =>
12520 Process_Atomic_Shared_Volatile;
12522 --------------------
12523 -- Shared_Passive --
12524 --------------------
12526 -- pragma Shared_Passive [(library_unit_NAME)];
12528 -- Set the flag Is_Shared_Passive of program unit name entity
12530 when Pragma_Shared_Passive => Shared_Passive : declare
12531 Cunit_Node : Node_Id;
12532 Cunit_Ent : Entity_Id;
12535 Check_Ada_83_Warning;
12536 Check_Valid_Library_Unit_Pragma;
12538 if Nkind (N) = N_Null_Statement then
12542 Cunit_Node := Cunit (Current_Sem_Unit);
12543 Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
12545 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
12546 N_Generic_Package_Declaration)
12549 ("pragma% can only apply to a package declaration");
12552 Set_Is_Shared_Passive (Cunit_Ent);
12553 end Shared_Passive;
12555 -----------------------
12556 -- Short_Descriptors --
12557 -----------------------
12559 -- pragma Short_Descriptors;
12561 when Pragma_Short_Descriptors =>
12563 Check_Arg_Count (0);
12564 Check_Valid_Configuration_Pragma;
12565 Short_Descriptors := True;
12567 ----------------------
12568 -- Source_File_Name --
12569 ----------------------
12571 -- There are five forms for this pragma:
12573 -- pragma Source_File_Name (
12574 -- [UNIT_NAME =>] unit_NAME,
12575 -- BODY_FILE_NAME => STRING_LITERAL
12576 -- [, [INDEX =>] INTEGER_LITERAL]);
12578 -- pragma Source_File_Name (
12579 -- [UNIT_NAME =>] unit_NAME,
12580 -- SPEC_FILE_NAME => STRING_LITERAL
12581 -- [, [INDEX =>] INTEGER_LITERAL]);
12583 -- pragma Source_File_Name (
12584 -- BODY_FILE_NAME => STRING_LITERAL
12585 -- [, DOT_REPLACEMENT => STRING_LITERAL]
12586 -- [, CASING => CASING_SPEC]);
12588 -- pragma Source_File_Name (
12589 -- SPEC_FILE_NAME => STRING_LITERAL
12590 -- [, DOT_REPLACEMENT => STRING_LITERAL]
12591 -- [, CASING => CASING_SPEC]);
12593 -- pragma Source_File_Name (
12594 -- SUBUNIT_FILE_NAME => STRING_LITERAL
12595 -- [, DOT_REPLACEMENT => STRING_LITERAL]
12596 -- [, CASING => CASING_SPEC]);
12598 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
12600 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
12601 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
12602 -- only be used when no project file is used, while SFNP can only be
12603 -- used when a project file is used.
12605 -- No processing here. Processing was completed during parsing, since
12606 -- we need to have file names set as early as possible. Units are
12607 -- loaded well before semantic processing starts.
12609 -- The only processing we defer to this point is the check for
12610 -- correct placement.
12612 when Pragma_Source_File_Name =>
12614 Check_Valid_Configuration_Pragma;
12616 ------------------------------
12617 -- Source_File_Name_Project --
12618 ------------------------------
12620 -- See Source_File_Name for syntax
12622 -- No processing here. Processing was completed during parsing, since
12623 -- we need to have file names set as early as possible. Units are
12624 -- loaded well before semantic processing starts.
12626 -- The only processing we defer to this point is the check for
12627 -- correct placement.
12629 when Pragma_Source_File_Name_Project =>
12631 Check_Valid_Configuration_Pragma;
12633 -- Check that a pragma Source_File_Name_Project is used only in a
12634 -- configuration pragmas file.
12636 -- Pragmas Source_File_Name_Project should only be generated by
12637 -- the Project Manager in configuration pragmas files.
12639 -- This is really an ugly test. It seems to depend on some
12640 -- accidental and undocumented property. At the very least it
12641 -- needs to be documented, but it would be better to have a
12642 -- clean way of testing if we are in a configuration file???
12644 if Present (Parent (N)) then
12646 ("pragma% can only appear in a configuration pragmas file");
12649 ----------------------
12650 -- Source_Reference --
12651 ----------------------
12653 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
12655 -- Nothing to do, all processing completed in Par.Prag, since we need
12656 -- the information for possible parser messages that are output.
12658 when Pragma_Source_Reference =>
12661 --------------------------------
12662 -- Static_Elaboration_Desired --
12663 --------------------------------
12665 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
12667 when Pragma_Static_Elaboration_Desired =>
12669 Check_At_Most_N_Arguments (1);
12671 if Is_Compilation_Unit (Current_Scope)
12672 and then Ekind (Current_Scope) = E_Package
12674 Set_Static_Elaboration_Desired (Current_Scope, True);
12676 Error_Pragma ("pragma% must apply to a library-level package");
12683 -- pragma Storage_Size (EXPRESSION);
12685 when Pragma_Storage_Size => Storage_Size : declare
12686 P : constant Node_Id := Parent (N);
12690 Check_No_Identifiers;
12691 Check_Arg_Count (1);
12693 -- The expression must be analyzed in the special manner described
12694 -- in "Handling of Default Expressions" in sem.ads.
12696 Arg := Get_Pragma_Arg (Arg1);
12697 Preanalyze_Spec_Expression (Arg, Any_Integer);
12699 if not Is_Static_Expression (Arg) then
12700 Check_Restriction (Static_Storage_Size, Arg);
12703 if Nkind (P) /= N_Task_Definition then
12708 if Has_Storage_Size_Pragma (P) then
12709 Error_Pragma ("duplicate pragma% not allowed");
12711 Set_Has_Storage_Size_Pragma (P, True);
12714 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
12715 -- ??? exp_ch9 should use this!
12723 -- pragma Storage_Unit (NUMERIC_LITERAL);
12725 -- Only permitted argument is System'Storage_Unit value
12727 when Pragma_Storage_Unit =>
12728 Check_No_Identifiers;
12729 Check_Arg_Count (1);
12730 Check_Arg_Is_Integer_Literal (Arg1);
12732 if Intval (Get_Pragma_Arg (Arg1)) /=
12733 UI_From_Int (Ttypes.System_Storage_Unit)
12735 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
12737 ("the only allowed argument for pragma% is ^", Arg1);
12740 --------------------
12741 -- Stream_Convert --
12742 --------------------
12744 -- pragma Stream_Convert (
12745 -- [Entity =>] type_LOCAL_NAME,
12746 -- [Read =>] function_NAME,
12747 -- [Write =>] function NAME);
12749 when Pragma_Stream_Convert => Stream_Convert : declare
12751 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
12752 -- Check that the given argument is the name of a local function
12753 -- of one argument that is not overloaded earlier in the current
12754 -- local scope. A check is also made that the argument is a
12755 -- function with one parameter.
12757 --------------------------------------
12758 -- Check_OK_Stream_Convert_Function --
12759 --------------------------------------
12761 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
12765 Check_Arg_Is_Local_Name (Arg);
12766 Ent := Entity (Get_Pragma_Arg (Arg));
12768 if Has_Homonym (Ent) then
12770 ("argument for pragma% may not be overloaded", Arg);
12773 if Ekind (Ent) /= E_Function
12774 or else No (First_Formal (Ent))
12775 or else Present (Next_Formal (First_Formal (Ent)))
12778 ("argument for pragma% must be" &
12779 " function of one argument", Arg);
12781 end Check_OK_Stream_Convert_Function;
12783 -- Start of processing for Stream_Convert
12787 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
12788 Check_Arg_Count (3);
12789 Check_Optional_Identifier (Arg1, Name_Entity);
12790 Check_Optional_Identifier (Arg2, Name_Read);
12791 Check_Optional_Identifier (Arg3, Name_Write);
12792 Check_Arg_Is_Local_Name (Arg1);
12793 Check_OK_Stream_Convert_Function (Arg2);
12794 Check_OK_Stream_Convert_Function (Arg3);
12797 Typ : constant Entity_Id :=
12798 Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
12799 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
12800 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
12803 Check_First_Subtype (Arg1);
12805 -- Check for too early or too late. Note that we don't enforce
12806 -- the rule about primitive operations in this case, since, as
12807 -- is the case for explicit stream attributes themselves, these
12808 -- restrictions are not appropriate. Note that the chaining of
12809 -- the pragma by Rep_Item_Too_Late is actually the critical
12810 -- processing done for this pragma.
12812 if Rep_Item_Too_Early (Typ, N)
12814 Rep_Item_Too_Late (Typ, N, FOnly => True)
12819 -- Return if previous error
12821 if Etype (Typ) = Any_Type
12823 Etype (Read) = Any_Type
12825 Etype (Write) = Any_Type
12832 if Underlying_Type (Etype (Read)) /= Typ then
12834 ("incorrect return type for function&", Arg2);
12837 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
12839 ("incorrect parameter type for function&", Arg3);
12842 if Underlying_Type (Etype (First_Formal (Read))) /=
12843 Underlying_Type (Etype (Write))
12846 ("result type of & does not match Read parameter type",
12850 end Stream_Convert;
12852 -------------------------
12853 -- Style_Checks (GNAT) --
12854 -------------------------
12856 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
12858 -- This is processed by the parser since some of the style checks
12859 -- take place during source scanning and parsing. This means that
12860 -- we don't need to issue error messages here.
12862 when Pragma_Style_Checks => Style_Checks : declare
12863 A : constant Node_Id := Get_Pragma_Arg (Arg1);
12869 Check_No_Identifiers;
12871 -- Two argument form
12873 if Arg_Count = 2 then
12874 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12881 E_Id := Get_Pragma_Arg (Arg2);
12884 if not Is_Entity_Name (E_Id) then
12886 ("second argument of pragma% must be entity name",
12890 E := Entity (E_Id);
12896 Set_Suppress_Style_Checks (E,
12897 (Chars (Get_Pragma_Arg (Arg1)) = Name_Off));
12898 exit when No (Homonym (E));
12904 -- One argument form
12907 Check_Arg_Count (1);
12909 if Nkind (A) = N_String_Literal then
12913 Slen : constant Natural := Natural (String_Length (S));
12914 Options : String (1 .. Slen);
12920 C := Get_String_Char (S, Int (J));
12921 exit when not In_Character_Range (C);
12922 Options (J) := Get_Character (C);
12924 -- If at end of string, set options. As per discussion
12925 -- above, no need to check for errors, since we issued
12926 -- them in the parser.
12929 Set_Style_Check_Options (Options);
12937 elsif Nkind (A) = N_Identifier then
12938 if Chars (A) = Name_All_Checks then
12940 Set_GNAT_Style_Check_Options;
12942 Set_Default_Style_Check_Options;
12945 elsif Chars (A) = Name_On then
12946 Style_Check := True;
12948 elsif Chars (A) = Name_Off then
12949 Style_Check := False;
12959 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
12961 when Pragma_Subtitle =>
12963 Check_Arg_Count (1);
12964 Check_Optional_Identifier (Arg1, Name_Subtitle);
12965 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
12972 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
12974 when Pragma_Suppress =>
12975 Process_Suppress_Unsuppress (True);
12981 -- pragma Suppress_All;
12983 -- The only check made here is that the pragma has no arguments.
12984 -- There are no placement rules, and the processing required (setting
12985 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
12986 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
12987 -- then creates and inserts a pragma Suppress (All_Checks).
12989 when Pragma_Suppress_All =>
12991 Check_Arg_Count (0);
12993 -------------------------
12994 -- Suppress_Debug_Info --
12995 -------------------------
12997 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
12999 when Pragma_Suppress_Debug_Info =>
13001 Check_Arg_Count (1);
13002 Check_Optional_Identifier (Arg1, Name_Entity);
13003 Check_Arg_Is_Local_Name (Arg1);
13004 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
13006 ----------------------------------
13007 -- Suppress_Exception_Locations --
13008 ----------------------------------
13010 -- pragma Suppress_Exception_Locations;
13012 when Pragma_Suppress_Exception_Locations =>
13014 Check_Arg_Count (0);
13015 Check_Valid_Configuration_Pragma;
13016 Exception_Locations_Suppressed := True;
13018 -----------------------------
13019 -- Suppress_Initialization --
13020 -----------------------------
13022 -- pragma Suppress_Initialization ([Entity =>] type_Name);
13024 when Pragma_Suppress_Initialization => Suppress_Init : declare
13030 Check_Arg_Count (1);
13031 Check_Optional_Identifier (Arg1, Name_Entity);
13032 Check_Arg_Is_Local_Name (Arg1);
13034 E_Id := Get_Pragma_Arg (Arg1);
13036 if Etype (E_Id) = Any_Type then
13040 E := Entity (E_Id);
13042 if not Is_Type (E) then
13043 Error_Pragma_Arg ("pragma% requires type or subtype", Arg1);
13046 if Rep_Item_Too_Early (E, N)
13048 Rep_Item_Too_Late (E, N, FOnly => True)
13053 -- For incomplete/private type, set flag on full view
13055 if Is_Incomplete_Or_Private_Type (E) then
13056 if No (Full_View (Base_Type (E))) then
13058 ("argument of pragma% cannot be an incomplete type", Arg1);
13060 Set_Suppress_Initialization (Full_View (Base_Type (E)));
13063 -- For first subtype, set flag on base type
13065 elsif Is_First_Subtype (E) then
13066 Set_Suppress_Initialization (Base_Type (E));
13068 -- For other than first subtype, set flag on subtype itself
13071 Set_Suppress_Initialization (E);
13079 -- pragma System_Name (DIRECT_NAME);
13081 -- Syntax check: one argument, which must be the identifier GNAT or
13082 -- the identifier GCC, no other identifiers are acceptable.
13084 when Pragma_System_Name =>
13086 Check_No_Identifiers;
13087 Check_Arg_Count (1);
13088 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
13090 -----------------------------
13091 -- Task_Dispatching_Policy --
13092 -----------------------------
13094 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
13096 when Pragma_Task_Dispatching_Policy => declare
13100 Check_Ada_83_Warning;
13101 Check_Arg_Count (1);
13102 Check_No_Identifiers;
13103 Check_Arg_Is_Task_Dispatching_Policy (Arg1);
13104 Check_Valid_Configuration_Pragma;
13105 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
13106 DP := Fold_Upper (Name_Buffer (1));
13108 if Task_Dispatching_Policy /= ' '
13109 and then Task_Dispatching_Policy /= DP
13111 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
13113 ("task dispatching policy incompatible with policy#");
13115 -- Set new policy, but always preserve System_Location since we
13116 -- like the error message with the run time name.
13119 Task_Dispatching_Policy := DP;
13121 if Task_Dispatching_Policy_Sloc /= System_Location then
13122 Task_Dispatching_Policy_Sloc := Loc;
13131 -- pragma Task_Info (EXPRESSION);
13133 when Pragma_Task_Info => Task_Info : declare
13134 P : constant Node_Id := Parent (N);
13139 if Nkind (P) /= N_Task_Definition then
13140 Error_Pragma ("pragma% must appear in task definition");
13143 Check_No_Identifiers;
13144 Check_Arg_Count (1);
13146 Analyze_And_Resolve
13147 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
13149 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
13153 if Has_Task_Info_Pragma (P) then
13154 Error_Pragma ("duplicate pragma% not allowed");
13156 Set_Has_Task_Info_Pragma (P, True);
13164 -- pragma Task_Name (string_EXPRESSION);
13166 when Pragma_Task_Name => Task_Name : declare
13167 P : constant Node_Id := Parent (N);
13171 Check_No_Identifiers;
13172 Check_Arg_Count (1);
13174 Arg := Get_Pragma_Arg (Arg1);
13176 -- The expression is used in the call to Create_Task, and must be
13177 -- expanded there, not in the context of the current spec. It must
13178 -- however be analyzed to capture global references, in case it
13179 -- appears in a generic context.
13181 Preanalyze_And_Resolve (Arg, Standard_String);
13183 if Nkind (P) /= N_Task_Definition then
13187 if Has_Task_Name_Pragma (P) then
13188 Error_Pragma ("duplicate pragma% not allowed");
13190 Set_Has_Task_Name_Pragma (P, True);
13191 Record_Rep_Item (Defining_Identifier (Parent (P)), N);
13199 -- pragma Task_Storage (
13200 -- [Task_Type =>] LOCAL_NAME,
13201 -- [Top_Guard =>] static_integer_EXPRESSION);
13203 when Pragma_Task_Storage => Task_Storage : declare
13204 Args : Args_List (1 .. 2);
13205 Names : constant Name_List (1 .. 2) := (
13209 Task_Type : Node_Id renames Args (1);
13210 Top_Guard : Node_Id renames Args (2);
13216 Gather_Associations (Names, Args);
13218 if No (Task_Type) then
13220 ("missing task_type argument for pragma%");
13223 Check_Arg_Is_Local_Name (Task_Type);
13225 Ent := Entity (Task_Type);
13227 if not Is_Task_Type (Ent) then
13229 ("argument for pragma% must be task type", Task_Type);
13232 if No (Top_Guard) then
13234 ("pragma% takes two arguments", Task_Type);
13236 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
13239 Check_First_Subtype (Task_Type);
13241 if Rep_Item_Too_Late (Ent, N) then
13250 -- pragma Test_Case ([Name =>] static_string_EXPRESSION
13251 -- ,[Mode =>] (Normal | Robustness)
13252 -- [, Requires => Boolean_EXPRESSION]
13253 -- [, Ensures => Boolean_EXPRESSION]);
13255 when Pragma_Test_Case => Test_Case : declare
13258 Check_At_Least_N_Arguments (3);
13259 Check_At_Most_N_Arguments (4);
13261 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
13263 Check_Optional_Identifier (Arg1, Name_Name);
13264 Check_Arg_Is_Static_Expression (Arg1, Standard_String);
13265 Check_Optional_Identifier (Arg2, Name_Mode);
13266 Check_Arg_Is_One_Of (Arg2, Name_Normal, Name_Robustness);
13268 if Arg_Count = 4 then
13269 Check_Identifier (Arg3, Name_Requires);
13270 Check_Identifier (Arg4, Name_Ensures);
13272 Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
13278 --------------------------
13279 -- Thread_Local_Storage --
13280 --------------------------
13282 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
13284 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
13290 Check_Arg_Count (1);
13291 Check_Optional_Identifier (Arg1, Name_Entity);
13292 Check_Arg_Is_Library_Level_Local_Name (Arg1);
13294 Id := Get_Pragma_Arg (Arg1);
13297 if not Is_Entity_Name (Id)
13298 or else Ekind (Entity (Id)) /= E_Variable
13300 Error_Pragma_Arg ("local variable name required", Arg1);
13305 if Rep_Item_Too_Early (E, N)
13306 or else Rep_Item_Too_Late (E, N)
13311 Set_Has_Pragma_Thread_Local_Storage (E);
13312 Set_Has_Gigi_Rep_Item (E);
13313 end Thread_Local_Storage;
13319 -- pragma Time_Slice (static_duration_EXPRESSION);
13321 when Pragma_Time_Slice => Time_Slice : declare
13327 Check_Arg_Count (1);
13328 Check_No_Identifiers;
13329 Check_In_Main_Program;
13330 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
13332 if not Error_Posted (Arg1) then
13334 while Present (Nod) loop
13335 if Nkind (Nod) = N_Pragma
13336 and then Pragma_Name (Nod) = Name_Time_Slice
13338 Error_Msg_Name_1 := Pname;
13339 Error_Msg_N ("duplicate pragma% not permitted", Nod);
13346 -- Process only if in main unit
13348 if Get_Source_Unit (Loc) = Main_Unit then
13349 Opt.Time_Slice_Set := True;
13350 Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
13352 if Val <= Ureal_0 then
13353 Opt.Time_Slice_Value := 0;
13355 elsif Val > UR_From_Uint (UI_From_Int (1000)) then
13356 Opt.Time_Slice_Value := 1_000_000_000;
13359 Opt.Time_Slice_Value :=
13360 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
13369 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
13371 -- TITLING_OPTION ::=
13372 -- [Title =>] STRING_LITERAL
13373 -- | [Subtitle =>] STRING_LITERAL
13375 when Pragma_Title => Title : declare
13376 Args : Args_List (1 .. 2);
13377 Names : constant Name_List (1 .. 2) := (
13383 Gather_Associations (Names, Args);
13386 for J in 1 .. 2 loop
13387 if Present (Args (J)) then
13388 Check_Arg_Is_Static_Expression (Args (J), Standard_String);
13393 ---------------------
13394 -- Unchecked_Union --
13395 ---------------------
13397 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
13399 when Pragma_Unchecked_Union => Unchecked_Union : declare
13400 Assoc : constant Node_Id := Arg1;
13401 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
13412 Check_No_Identifiers;
13413 Check_Arg_Count (1);
13414 Check_Arg_Is_Local_Name (Arg1);
13416 Find_Type (Type_Id);
13417 Typ := Entity (Type_Id);
13420 or else Rep_Item_Too_Early (Typ, N)
13424 Typ := Underlying_Type (Typ);
13427 if Rep_Item_Too_Late (Typ, N) then
13431 Check_First_Subtype (Arg1);
13433 -- Note remaining cases are references to a type in the current
13434 -- declarative part. If we find an error, we post the error on
13435 -- the relevant type declaration at an appropriate point.
13437 if not Is_Record_Type (Typ) then
13438 Error_Msg_N ("Unchecked_Union must be record type", Typ);
13441 elsif Is_Tagged_Type (Typ) then
13442 Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
13445 elsif Is_Limited_Type (Typ) then
13447 ("Unchecked_Union must not be limited record type", Typ);
13448 Explain_Limited_Type (Typ, Typ);
13452 if not Has_Discriminants (Typ) then
13454 ("Unchecked_Union must have one discriminant", Typ);
13458 Discr := First_Discriminant (Typ);
13459 while Present (Discr) loop
13460 if No (Discriminant_Default_Value (Discr)) then
13462 ("Unchecked_Union discriminant must have default value",
13466 Next_Discriminant (Discr);
13469 Tdef := Type_Definition (Declaration_Node (Typ));
13470 Clist := Component_List (Tdef);
13472 Comp := First (Component_Items (Clist));
13473 while Present (Comp) loop
13474 Check_Component (Comp, Typ);
13478 if No (Clist) or else No (Variant_Part (Clist)) then
13480 ("Unchecked_Union must have variant part",
13485 Vpart := Variant_Part (Clist);
13487 Variant := First (Variants (Vpart));
13488 while Present (Variant) loop
13489 Check_Variant (Variant, Typ);
13494 Set_Is_Unchecked_Union (Typ);
13495 Set_Convention (Typ, Convention_C);
13496 Set_Has_Unchecked_Union (Base_Type (Typ));
13497 Set_Is_Unchecked_Union (Base_Type (Typ));
13498 end Unchecked_Union;
13500 ------------------------
13501 -- Unimplemented_Unit --
13502 ------------------------
13504 -- pragma Unimplemented_Unit;
13506 -- Note: this only gives an error if we are generating code, or if
13507 -- we are in a generic library unit (where the pragma appears in the
13508 -- body, not in the spec).
13510 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
13511 Cunitent : constant Entity_Id :=
13512 Cunit_Entity (Get_Source_Unit (Loc));
13513 Ent_Kind : constant Entity_Kind :=
13518 Check_Arg_Count (0);
13520 if Operating_Mode = Generate_Code
13521 or else Ent_Kind = E_Generic_Function
13522 or else Ent_Kind = E_Generic_Procedure
13523 or else Ent_Kind = E_Generic_Package
13525 Get_Name_String (Chars (Cunitent));
13526 Set_Casing (Mixed_Case);
13527 Write_Str (Name_Buffer (1 .. Name_Len));
13528 Write_Str (" is not supported in this configuration");
13530 raise Unrecoverable_Error;
13532 end Unimplemented_Unit;
13534 ------------------------
13535 -- Universal_Aliasing --
13536 ------------------------
13538 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
13540 when Pragma_Universal_Aliasing => Universal_Alias : declare
13545 Check_Arg_Count (1);
13546 Check_Optional_Identifier (Arg2, Name_Entity);
13547 Check_Arg_Is_Local_Name (Arg1);
13548 E_Id := Entity (Get_Pragma_Arg (Arg1));
13550 if E_Id = Any_Type then
13552 elsif No (E_Id) or else not Is_Type (E_Id) then
13553 Error_Pragma_Arg ("pragma% requires type", Arg1);
13556 Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
13557 end Universal_Alias;
13559 --------------------
13560 -- Universal_Data --
13561 --------------------
13563 -- pragma Universal_Data [(library_unit_NAME)];
13565 when Pragma_Universal_Data =>
13568 -- If this is a configuration pragma, then set the universal
13569 -- addressing option, otherwise confirm that the pragma satisfies
13570 -- the requirements of library unit pragma placement and leave it
13571 -- to the GNAAMP back end to detect the pragma (avoids transitive
13572 -- setting of the option due to withed units).
13574 if Is_Configuration_Pragma then
13575 Universal_Addressing_On_AAMP := True;
13577 Check_Valid_Library_Unit_Pragma;
13580 if not AAMP_On_Target then
13581 Error_Pragma ("?pragma% ignored (applies only to AAMP)");
13588 -- pragma Unmodified (local_Name {, local_Name});
13590 when Pragma_Unmodified => Unmodified : declare
13591 Arg_Node : Node_Id;
13592 Arg_Expr : Node_Id;
13593 Arg_Ent : Entity_Id;
13597 Check_At_Least_N_Arguments (1);
13599 -- Loop through arguments
13602 while Present (Arg_Node) loop
13603 Check_No_Identifier (Arg_Node);
13605 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
13606 -- in fact generate reference, so that the entity will have a
13607 -- reference, which will inhibit any warnings about it not
13608 -- being referenced, and also properly show up in the ali file
13609 -- as a reference. But this reference is recorded before the
13610 -- Has_Pragma_Unreferenced flag is set, so that no warning is
13611 -- generated for this reference.
13613 Check_Arg_Is_Local_Name (Arg_Node);
13614 Arg_Expr := Get_Pragma_Arg (Arg_Node);
13616 if Is_Entity_Name (Arg_Expr) then
13617 Arg_Ent := Entity (Arg_Expr);
13619 if not Is_Assignable (Arg_Ent) then
13621 ("pragma% can only be applied to a variable",
13624 Set_Has_Pragma_Unmodified (Arg_Ent);
13636 -- pragma Unreferenced (local_Name {, local_Name});
13638 -- or when used in a context clause:
13640 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
13642 when Pragma_Unreferenced => Unreferenced : declare
13643 Arg_Node : Node_Id;
13644 Arg_Expr : Node_Id;
13645 Arg_Ent : Entity_Id;
13650 Check_At_Least_N_Arguments (1);
13652 -- Check case of appearing within context clause
13654 if Is_In_Context_Clause then
13656 -- The arguments must all be units mentioned in a with clause
13657 -- in the same context clause. Note we already checked (in
13658 -- Par.Prag) that the arguments are either identifiers or
13659 -- selected components.
13662 while Present (Arg_Node) loop
13663 Citem := First (List_Containing (N));
13664 while Citem /= N loop
13665 if Nkind (Citem) = N_With_Clause
13667 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
13669 Set_Has_Pragma_Unreferenced
13672 (Library_Unit (Citem))));
13674 (Get_Pragma_Arg (Arg_Node), Name (Citem));
13683 ("argument of pragma% is not with'ed unit", Arg_Node);
13689 -- Case of not in list of context items
13693 while Present (Arg_Node) loop
13694 Check_No_Identifier (Arg_Node);
13696 -- Note: the analyze call done by Check_Arg_Is_Local_Name
13697 -- will in fact generate reference, so that the entity will
13698 -- have a reference, which will inhibit any warnings about
13699 -- it not being referenced, and also properly show up in the
13700 -- ali file as a reference. But this reference is recorded
13701 -- before the Has_Pragma_Unreferenced flag is set, so that
13702 -- no warning is generated for this reference.
13704 Check_Arg_Is_Local_Name (Arg_Node);
13705 Arg_Expr := Get_Pragma_Arg (Arg_Node);
13707 if Is_Entity_Name (Arg_Expr) then
13708 Arg_Ent := Entity (Arg_Expr);
13710 -- If the entity is overloaded, the pragma applies to the
13711 -- most recent overloading, as documented. In this case,
13712 -- name resolution does not generate a reference, so it
13713 -- must be done here explicitly.
13715 if Is_Overloaded (Arg_Expr) then
13716 Generate_Reference (Arg_Ent, N);
13719 Set_Has_Pragma_Unreferenced (Arg_Ent);
13727 --------------------------
13728 -- Unreferenced_Objects --
13729 --------------------------
13731 -- pragma Unreferenced_Objects (local_Name {, local_Name});
13733 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
13734 Arg_Node : Node_Id;
13735 Arg_Expr : Node_Id;
13739 Check_At_Least_N_Arguments (1);
13742 while Present (Arg_Node) loop
13743 Check_No_Identifier (Arg_Node);
13744 Check_Arg_Is_Local_Name (Arg_Node);
13745 Arg_Expr := Get_Pragma_Arg (Arg_Node);
13747 if not Is_Entity_Name (Arg_Expr)
13748 or else not Is_Type (Entity (Arg_Expr))
13751 ("argument for pragma% must be type or subtype", Arg_Node);
13754 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
13757 end Unreferenced_Objects;
13759 ------------------------------
13760 -- Unreserve_All_Interrupts --
13761 ------------------------------
13763 -- pragma Unreserve_All_Interrupts;
13765 when Pragma_Unreserve_All_Interrupts =>
13767 Check_Arg_Count (0);
13769 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
13770 Unreserve_All_Interrupts := True;
13777 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
13779 when Pragma_Unsuppress =>
13781 Process_Suppress_Unsuppress (False);
13783 -------------------
13784 -- Use_VADS_Size --
13785 -------------------
13787 -- pragma Use_VADS_Size;
13789 when Pragma_Use_VADS_Size =>
13791 Check_Arg_Count (0);
13792 Check_Valid_Configuration_Pragma;
13793 Use_VADS_Size := True;
13795 ---------------------
13796 -- Validity_Checks --
13797 ---------------------
13799 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
13801 when Pragma_Validity_Checks => Validity_Checks : declare
13802 A : constant Node_Id := Get_Pragma_Arg (Arg1);
13808 Check_Arg_Count (1);
13809 Check_No_Identifiers;
13811 if Nkind (A) = N_String_Literal then
13815 Slen : constant Natural := Natural (String_Length (S));
13816 Options : String (1 .. Slen);
13822 C := Get_String_Char (S, Int (J));
13823 exit when not In_Character_Range (C);
13824 Options (J) := Get_Character (C);
13827 Set_Validity_Check_Options (Options);
13835 elsif Nkind (A) = N_Identifier then
13837 if Chars (A) = Name_All_Checks then
13838 Set_Validity_Check_Options ("a");
13840 elsif Chars (A) = Name_On then
13841 Validity_Checks_On := True;
13843 elsif Chars (A) = Name_Off then
13844 Validity_Checks_On := False;
13848 end Validity_Checks;
13854 -- pragma Volatile (LOCAL_NAME);
13856 when Pragma_Volatile =>
13857 Process_Atomic_Shared_Volatile;
13859 -------------------------
13860 -- Volatile_Components --
13861 -------------------------
13863 -- pragma Volatile_Components (array_LOCAL_NAME);
13865 -- Volatile is handled by the same circuit as Atomic_Components
13871 -- pragma Warnings (On | Off);
13872 -- pragma Warnings (On | Off, LOCAL_NAME);
13873 -- pragma Warnings (static_string_EXPRESSION);
13874 -- pragma Warnings (On | Off, STRING_LITERAL);
13876 when Pragma_Warnings => Warnings : begin
13878 Check_At_Least_N_Arguments (1);
13879 Check_No_Identifiers;
13881 -- If debug flag -gnatd.i is set, pragma is ignored
13883 if Debug_Flag_Dot_I then
13887 -- Process various forms of the pragma
13890 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
13893 -- One argument case
13895 if Arg_Count = 1 then
13897 -- On/Off one argument case was processed by parser
13899 if Nkind (Argx) = N_Identifier
13901 (Chars (Argx) = Name_On
13903 Chars (Argx) = Name_Off)
13907 -- One argument case must be ON/OFF or static string expr
13909 elsif not Is_Static_String_Expression (Arg1) then
13911 ("argument of pragma% must be On/Off or " &
13912 "static string expression", Arg1);
13914 -- One argument string expression case
13918 Lit : constant Node_Id := Expr_Value_S (Argx);
13919 Str : constant String_Id := Strval (Lit);
13920 Len : constant Nat := String_Length (Str);
13928 while J <= Len loop
13929 C := Get_String_Char (Str, J);
13930 OK := In_Character_Range (C);
13933 Chr := Get_Character (C);
13937 if J < Len and then Chr = '.' then
13939 C := Get_String_Char (Str, J);
13940 Chr := Get_Character (C);
13942 if not Set_Dot_Warning_Switch (Chr) then
13944 ("invalid warning switch character " &
13951 OK := Set_Warning_Switch (Chr);
13957 ("invalid warning switch character " & Chr,
13966 -- Two or more arguments (must be two)
13969 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
13970 Check_At_Most_N_Arguments (2);
13978 E_Id := Get_Pragma_Arg (Arg2);
13981 -- In the expansion of an inlined body, a reference to
13982 -- the formal may be wrapped in a conversion if the
13983 -- actual is a conversion. Retrieve the real entity name.
13985 if (In_Instance_Body
13986 or else In_Inlined_Body)
13987 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
13989 E_Id := Expression (E_Id);
13992 -- Entity name case
13994 if Is_Entity_Name (E_Id) then
13995 E := Entity (E_Id);
14002 (E, (Chars (Get_Pragma_Arg (Arg1)) =
14005 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
14006 and then Warn_On_Warnings_Off
14008 Warnings_Off_Pragmas.Append ((N, E));
14011 if Is_Enumeration_Type (E) then
14015 Lit := First_Literal (E);
14016 while Present (Lit) loop
14017 Set_Warnings_Off (Lit);
14018 Next_Literal (Lit);
14023 exit when No (Homonym (E));
14028 -- Error if not entity or static string literal case
14030 elsif not Is_Static_String_Expression (Arg2) then
14032 ("second argument of pragma% must be entity " &
14033 "name or static string expression", Arg2);
14035 -- String literal case
14038 String_To_Name_Buffer
14039 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
14041 -- Note on configuration pragma case: If this is a
14042 -- configuration pragma, then for an OFF pragma, we
14043 -- just set Config True in the call, which is all
14044 -- that needs to be done. For the case of ON, this
14045 -- is normally an error, unless it is canceling the
14046 -- effect of a previous OFF pragma in the same file.
14047 -- In any other case, an error will be signalled (ON
14048 -- with no matching OFF).
14050 if Chars (Argx) = Name_Off then
14051 Set_Specific_Warning_Off
14052 (Loc, Name_Buffer (1 .. Name_Len),
14053 Config => Is_Configuration_Pragma);
14055 elsif Chars (Argx) = Name_On then
14056 Set_Specific_Warning_On
14057 (Loc, Name_Buffer (1 .. Name_Len), Err);
14061 ("?pragma Warnings On with no " &
14062 "matching Warnings Off",
14072 -------------------
14073 -- Weak_External --
14074 -------------------
14076 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
14078 when Pragma_Weak_External => Weak_External : declare
14083 Check_Arg_Count (1);
14084 Check_Optional_Identifier (Arg1, Name_Entity);
14085 Check_Arg_Is_Library_Level_Local_Name (Arg1);
14086 Ent := Entity (Get_Pragma_Arg (Arg1));
14088 if Rep_Item_Too_Early (Ent, N) then
14091 Ent := Underlying_Type (Ent);
14094 -- The only processing required is to link this item on to the
14095 -- list of rep items for the given entity. This is accomplished
14096 -- by the call to Rep_Item_Too_Late (when no error is detected
14097 -- and False is returned).
14099 if Rep_Item_Too_Late (Ent, N) then
14102 Set_Has_Gigi_Rep_Item (Ent);
14106 -----------------------------
14107 -- Wide_Character_Encoding --
14108 -----------------------------
14110 -- pragma Wide_Character_Encoding (IDENTIFIER);
14112 when Pragma_Wide_Character_Encoding =>
14115 -- Nothing to do, handled in parser. Note that we do not enforce
14116 -- configuration pragma placement, this pragma can appear at any
14117 -- place in the source, allowing mixed encodings within a single
14122 --------------------
14123 -- Unknown_Pragma --
14124 --------------------
14126 -- Should be impossible, since the case of an unknown pragma is
14127 -- separately processed before the case statement is entered.
14129 when Unknown_Pragma =>
14130 raise Program_Error;
14133 -- AI05-0144: detect dangerous order dependence. Disabled for now,
14134 -- until AI is formally approved.
14136 -- Check_Order_Dependence;
14139 when Pragma_Exit => null;
14140 end Analyze_Pragma;
14142 -----------------------------
14143 -- Analyze_TC_In_Decl_Part --
14144 -----------------------------
14146 procedure Analyze_TC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
14148 -- Install formals and push subprogram spec onto scope stack so that we
14149 -- can see the formals from the pragma.
14151 Install_Formals (S);
14154 -- Preanalyze the boolean expressions, we treat these as spec
14155 -- expressions (i.e. similar to a default expression).
14157 Preanalyze_TC_Args (Get_Requires_From_Test_Case_Pragma (N),
14158 Get_Ensures_From_Test_Case_Pragma (N));
14160 -- Remove the subprogram from the scope stack now that the pre-analysis
14161 -- of the expressions in the test-case is done.
14164 end Analyze_TC_In_Decl_Part;
14166 -------------------
14167 -- Check_Enabled --
14168 -------------------
14170 function Check_Enabled (Nam : Name_Id) return Boolean is
14174 -- Loop through entries in check policy list
14176 PP := Opt.Check_Policy_List;
14178 -- If there are no specific entries that matched, then we let the
14179 -- setting of assertions govern. Note that this provides the needed
14180 -- compatibility with the RM for the cases of assertion, invariant,
14181 -- precondition, predicate, and postcondition.
14184 return Assertions_Enabled;
14186 -- Here we have an entry see if it matches
14190 PPA : constant List_Id := Pragma_Argument_Associations (PP);
14193 if Nam = Chars (Get_Pragma_Arg (First (PPA))) then
14194 case (Chars (Get_Pragma_Arg (Last (PPA)))) is
14195 when Name_On | Name_Check =>
14197 when Name_Off | Name_Ignore =>
14200 raise Program_Error;
14204 PP := Next_Pragma (PP);
14211 ---------------------------------
14212 -- Delay_Config_Pragma_Analyze --
14213 ---------------------------------
14215 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
14217 return Pragma_Name (N) = Name_Interrupt_State
14219 Pragma_Name (N) = Name_Priority_Specific_Dispatching;
14220 end Delay_Config_Pragma_Analyze;
14222 -------------------------
14223 -- Get_Base_Subprogram --
14224 -------------------------
14226 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
14227 Result : Entity_Id;
14230 -- Follow subprogram renaming chain
14233 while Is_Subprogram (Result)
14235 Nkind (Parent (Declaration_Node (Result))) =
14236 N_Subprogram_Renaming_Declaration
14237 and then Present (Alias (Result))
14239 Result := Alias (Result);
14243 end Get_Base_Subprogram;
14249 procedure Initialize is
14254 -----------------------------
14255 -- Is_Config_Static_String --
14256 -----------------------------
14258 function Is_Config_Static_String (Arg : Node_Id) return Boolean is
14260 function Add_Config_Static_String (Arg : Node_Id) return Boolean;
14261 -- This is an internal recursive function that is just like the outer
14262 -- function except that it adds the string to the name buffer rather
14263 -- than placing the string in the name buffer.
14265 ------------------------------
14266 -- Add_Config_Static_String --
14267 ------------------------------
14269 function Add_Config_Static_String (Arg : Node_Id) return Boolean is
14276 if Nkind (N) = N_Op_Concat then
14277 if Add_Config_Static_String (Left_Opnd (N)) then
14278 N := Right_Opnd (N);
14284 if Nkind (N) /= N_String_Literal then
14285 Error_Msg_N ("string literal expected for pragma argument", N);
14289 for J in 1 .. String_Length (Strval (N)) loop
14290 C := Get_String_Char (Strval (N), J);
14292 if not In_Character_Range (C) then
14294 ("string literal contains invalid wide character",
14295 Sloc (N) + 1 + Source_Ptr (J));
14299 Add_Char_To_Name_Buffer (Get_Character (C));
14304 end Add_Config_Static_String;
14306 -- Start of processing for Is_Config_Static_String
14311 return Add_Config_Static_String (Arg);
14312 end Is_Config_Static_String;
14314 -----------------------------------------
14315 -- Is_Non_Significant_Pragma_Reference --
14316 -----------------------------------------
14318 -- This function makes use of the following static table which indicates
14319 -- whether a given pragma is significant.
14321 -- -1 indicates that references in any argument position are significant
14322 -- 0 indicates that appearance in any argument is not significant
14323 -- +n indicates that appearance as argument n is significant, but all
14324 -- other arguments are not significant
14325 -- 99 special processing required (e.g. for pragma Check)
14327 Sig_Flags : constant array (Pragma_Id) of Int :=
14328 (Pragma_AST_Entry => -1,
14329 Pragma_Abort_Defer => -1,
14330 Pragma_Ada_83 => -1,
14331 Pragma_Ada_95 => -1,
14332 Pragma_Ada_05 => -1,
14333 Pragma_Ada_2005 => -1,
14334 Pragma_Ada_12 => -1,
14335 Pragma_Ada_2012 => -1,
14336 Pragma_All_Calls_Remote => -1,
14337 Pragma_Annotate => -1,
14338 Pragma_Assert => -1,
14339 Pragma_Assertion_Policy => 0,
14340 Pragma_Assume_No_Invalid_Values => 0,
14341 Pragma_Asynchronous => -1,
14342 Pragma_Atomic => 0,
14343 Pragma_Atomic_Components => 0,
14344 Pragma_Attach_Handler => -1,
14345 Pragma_Check => 99,
14346 Pragma_Check_Name => 0,
14347 Pragma_Check_Policy => 0,
14348 Pragma_CIL_Constructor => -1,
14349 Pragma_CPP_Class => 0,
14350 Pragma_CPP_Constructor => 0,
14351 Pragma_CPP_Virtual => 0,
14352 Pragma_CPP_Vtable => 0,
14354 Pragma_C_Pass_By_Copy => 0,
14355 Pragma_Comment => 0,
14356 Pragma_Common_Object => -1,
14357 Pragma_Compile_Time_Error => -1,
14358 Pragma_Compile_Time_Warning => -1,
14359 Pragma_Compiler_Unit => 0,
14360 Pragma_Complete_Representation => 0,
14361 Pragma_Complex_Representation => 0,
14362 Pragma_Component_Alignment => -1,
14363 Pragma_Controlled => 0,
14364 Pragma_Convention => 0,
14365 Pragma_Convention_Identifier => 0,
14366 Pragma_Debug => -1,
14367 Pragma_Debug_Policy => 0,
14368 Pragma_Detect_Blocking => -1,
14369 Pragma_Default_Storage_Pool => -1,
14370 Pragma_Dimension => -1,
14371 Pragma_Discard_Names => 0,
14372 Pragma_Elaborate => -1,
14373 Pragma_Elaborate_All => -1,
14374 Pragma_Elaborate_Body => -1,
14375 Pragma_Elaboration_Checks => -1,
14376 Pragma_Eliminate => -1,
14377 Pragma_Export => -1,
14378 Pragma_Export_Exception => -1,
14379 Pragma_Export_Function => -1,
14380 Pragma_Export_Object => -1,
14381 Pragma_Export_Procedure => -1,
14382 Pragma_Export_Value => -1,
14383 Pragma_Export_Valued_Procedure => -1,
14384 Pragma_Extend_System => -1,
14385 Pragma_Extensions_Allowed => -1,
14386 Pragma_External => -1,
14387 Pragma_Favor_Top_Level => -1,
14388 Pragma_External_Name_Casing => -1,
14389 Pragma_Fast_Math => -1,
14390 Pragma_Finalize_Storage_Only => 0,
14391 Pragma_Float_Representation => 0,
14392 Pragma_Ident => -1,
14393 Pragma_Implemented => -1,
14394 Pragma_Implicit_Packing => 0,
14395 Pragma_Import => +2,
14396 Pragma_Import_Exception => 0,
14397 Pragma_Import_Function => 0,
14398 Pragma_Import_Object => 0,
14399 Pragma_Import_Procedure => 0,
14400 Pragma_Import_Valued_Procedure => 0,
14401 Pragma_Independent => 0,
14402 Pragma_Independent_Components => 0,
14403 Pragma_Initialize_Scalars => -1,
14404 Pragma_Inline => 0,
14405 Pragma_Inline_Always => 0,
14406 Pragma_Inline_Generic => 0,
14407 Pragma_Inspection_Point => -1,
14408 Pragma_Interface => +2,
14409 Pragma_Interface_Name => +2,
14410 Pragma_Interrupt_Handler => -1,
14411 Pragma_Interrupt_Priority => -1,
14412 Pragma_Interrupt_State => -1,
14413 Pragma_Invariant => -1,
14414 Pragma_Java_Constructor => -1,
14415 Pragma_Java_Interface => -1,
14416 Pragma_Keep_Names => 0,
14417 Pragma_License => -1,
14418 Pragma_Link_With => -1,
14419 Pragma_Linker_Alias => -1,
14420 Pragma_Linker_Constructor => -1,
14421 Pragma_Linker_Destructor => -1,
14422 Pragma_Linker_Options => -1,
14423 Pragma_Linker_Section => -1,
14425 Pragma_Locking_Policy => -1,
14426 Pragma_Long_Float => -1,
14427 Pragma_Machine_Attribute => -1,
14429 Pragma_Main_Storage => -1,
14430 Pragma_Memory_Size => -1,
14431 Pragma_No_Return => 0,
14432 Pragma_No_Body => 0,
14433 Pragma_No_Run_Time => -1,
14434 Pragma_No_Strict_Aliasing => -1,
14435 Pragma_Normalize_Scalars => -1,
14436 Pragma_Obsolescent => 0,
14437 Pragma_Optimize => -1,
14438 Pragma_Optimize_Alignment => -1,
14439 Pragma_Ordered => 0,
14442 Pragma_Passive => -1,
14443 Pragma_Preelaborable_Initialization => -1,
14444 Pragma_Polling => -1,
14445 Pragma_Persistent_BSS => 0,
14446 Pragma_Postcondition => -1,
14447 Pragma_Precondition => -1,
14448 Pragma_Predicate => -1,
14449 Pragma_Preelaborate => -1,
14450 Pragma_Preelaborate_05 => -1,
14451 Pragma_Priority => -1,
14452 Pragma_Priority_Specific_Dispatching => -1,
14453 Pragma_Profile => 0,
14454 Pragma_Profile_Warnings => 0,
14455 Pragma_Propagate_Exceptions => -1,
14456 Pragma_Psect_Object => -1,
14458 Pragma_Pure_05 => -1,
14459 Pragma_Pure_Function => -1,
14460 Pragma_Queuing_Policy => -1,
14461 Pragma_Ravenscar => -1,
14462 Pragma_Relative_Deadline => -1,
14463 Pragma_Remote_Call_Interface => -1,
14464 Pragma_Remote_Types => -1,
14465 Pragma_Restricted_Run_Time => -1,
14466 Pragma_Restriction_Warnings => -1,
14467 Pragma_Restrictions => -1,
14468 Pragma_Reviewable => -1,
14469 Pragma_Short_Circuit_And_Or => -1,
14470 Pragma_Share_Generic => -1,
14471 Pragma_Shared => -1,
14472 Pragma_Shared_Passive => -1,
14473 Pragma_Short_Descriptors => 0,
14474 Pragma_Source_File_Name => -1,
14475 Pragma_Source_File_Name_Project => -1,
14476 Pragma_Source_Reference => -1,
14477 Pragma_Storage_Size => -1,
14478 Pragma_Storage_Unit => -1,
14479 Pragma_Static_Elaboration_Desired => -1,
14480 Pragma_Stream_Convert => -1,
14481 Pragma_Style_Checks => -1,
14482 Pragma_Subtitle => -1,
14483 Pragma_Suppress => 0,
14484 Pragma_Suppress_Exception_Locations => 0,
14485 Pragma_Suppress_All => -1,
14486 Pragma_Suppress_Debug_Info => 0,
14487 Pragma_Suppress_Initialization => 0,
14488 Pragma_System_Name => -1,
14489 Pragma_Task_Dispatching_Policy => -1,
14490 Pragma_Task_Info => -1,
14491 Pragma_Task_Name => -1,
14492 Pragma_Task_Storage => 0,
14493 Pragma_Test_Case => -1,
14494 Pragma_Thread_Local_Storage => 0,
14495 Pragma_Time_Slice => -1,
14496 Pragma_Title => -1,
14497 Pragma_Unchecked_Union => 0,
14498 Pragma_Unimplemented_Unit => -1,
14499 Pragma_Universal_Aliasing => -1,
14500 Pragma_Universal_Data => -1,
14501 Pragma_Unmodified => -1,
14502 Pragma_Unreferenced => -1,
14503 Pragma_Unreferenced_Objects => -1,
14504 Pragma_Unreserve_All_Interrupts => -1,
14505 Pragma_Unsuppress => 0,
14506 Pragma_Use_VADS_Size => -1,
14507 Pragma_Validity_Checks => -1,
14508 Pragma_Volatile => 0,
14509 Pragma_Volatile_Components => 0,
14510 Pragma_Warnings => -1,
14511 Pragma_Weak_External => -1,
14512 Pragma_Wide_Character_Encoding => 0,
14513 Unknown_Pragma => 0);
14515 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
14524 if Nkind (P) /= N_Pragma_Argument_Association then
14528 Id := Get_Pragma_Id (Parent (P));
14529 C := Sig_Flags (Id);
14541 -- For pragma Check, the first argument is not significant,
14542 -- the second and the third (if present) arguments are
14545 when Pragma_Check =>
14547 P = First (Pragma_Argument_Associations (Parent (P)));
14550 raise Program_Error;
14554 A := First (Pragma_Argument_Associations (Parent (P)));
14555 for J in 1 .. C - 1 loop
14563 return A = P; -- is this wrong way round ???
14566 end Is_Non_Significant_Pragma_Reference;
14568 ------------------------------
14569 -- Is_Pragma_String_Literal --
14570 ------------------------------
14572 -- This function returns true if the corresponding pragma argument is a
14573 -- static string expression. These are the only cases in which string
14574 -- literals can appear as pragma arguments. We also allow a string literal
14575 -- as the first argument to pragma Assert (although it will of course
14576 -- always generate a type error).
14578 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
14579 Pragn : constant Node_Id := Parent (Par);
14580 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
14581 Pname : constant Name_Id := Pragma_Name (Pragn);
14587 N := First (Assoc);
14594 if Pname = Name_Assert then
14597 elsif Pname = Name_Export then
14600 elsif Pname = Name_Ident then
14603 elsif Pname = Name_Import then
14606 elsif Pname = Name_Interface_Name then
14609 elsif Pname = Name_Linker_Alias then
14612 elsif Pname = Name_Linker_Section then
14615 elsif Pname = Name_Machine_Attribute then
14618 elsif Pname = Name_Source_File_Name then
14621 elsif Pname = Name_Source_Reference then
14624 elsif Pname = Name_Title then
14627 elsif Pname = Name_Subtitle then
14633 end Is_Pragma_String_Literal;
14635 ------------------------
14636 -- Preanalyze_TC_Args --
14637 ------------------------
14639 procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id) is
14641 -- Preanalyze the boolean expressions, we treat these as spec
14642 -- expressions (i.e. similar to a default expression).
14644 if Present (Arg_Req) then
14645 Preanalyze_Spec_Expression
14646 (Get_Pragma_Arg (Arg_Req), Standard_Boolean);
14649 if Present (Arg_Ens) then
14650 Preanalyze_Spec_Expression
14651 (Get_Pragma_Arg (Arg_Ens), Standard_Boolean);
14653 end Preanalyze_TC_Args;
14655 --------------------------------------
14656 -- Process_Compilation_Unit_Pragmas --
14657 --------------------------------------
14659 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
14661 -- A special check for pragma Suppress_All, a very strange DEC pragma,
14662 -- strange because it comes at the end of the unit. Rational has the
14663 -- same name for a pragma, but treats it as a program unit pragma, In
14664 -- GNAT we just decide to allow it anywhere at all. If it appeared then
14665 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
14666 -- node, and we insert a pragma Suppress (All_Checks) at the start of
14667 -- the context clause to ensure the correct processing.
14669 if Has_Pragma_Suppress_All (N) then
14670 Prepend_To (Context_Items (N),
14671 Make_Pragma (Sloc (N),
14672 Chars => Name_Suppress,
14673 Pragma_Argument_Associations => New_List (
14674 Make_Pragma_Argument_Association (Sloc (N),
14675 Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
14678 -- Nothing else to do at the current time!
14680 end Process_Compilation_Unit_Pragmas;
14691 --------------------------------
14692 -- Set_Encoded_Interface_Name --
14693 --------------------------------
14695 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
14696 Str : constant String_Id := Strval (S);
14697 Len : constant Int := String_Length (Str);
14702 Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
14705 -- Stores encoded value of character code CC. The encoding we use an
14706 -- underscore followed by four lower case hex digits.
14712 procedure Encode is
14714 Store_String_Char (Get_Char_Code ('_'));
14716 (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
14718 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
14720 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
14722 (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
14725 -- Start of processing for Set_Encoded_Interface_Name
14728 -- If first character is asterisk, this is a link name, and we leave it
14729 -- completely unmodified. We also ignore null strings (the latter case
14730 -- happens only in error cases) and no encoding should occur for Java or
14731 -- AAMP interface names.
14734 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
14735 or else VM_Target /= No_VM
14736 or else AAMP_On_Target
14738 Set_Interface_Name (E, S);
14743 CC := Get_String_Char (Str, J);
14745 exit when not In_Character_Range (CC);
14747 C := Get_Character (CC);
14749 exit when C /= '_' and then C /= '$'
14750 and then C not in '0' .. '9'
14751 and then C not in 'a' .. 'z'
14752 and then C not in 'A' .. 'Z';
14755 Set_Interface_Name (E, S);
14763 -- Here we need to encode. The encoding we use as follows:
14764 -- three underscores + four hex digits (lower case)
14768 for J in 1 .. String_Length (Str) loop
14769 CC := Get_String_Char (Str, J);
14771 if not In_Character_Range (CC) then
14774 C := Get_Character (CC);
14776 if C = '_' or else C = '$'
14777 or else C in '0' .. '9'
14778 or else C in 'a' .. 'z'
14779 or else C in 'A' .. 'Z'
14781 Store_String_Char (CC);
14788 Set_Interface_Name (E,
14789 Make_String_Literal (Sloc (S),
14790 Strval => End_String));
14792 end Set_Encoded_Interface_Name;
14794 -------------------
14795 -- Set_Unit_Name --
14796 -------------------
14798 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
14803 if Nkind (N) = N_Identifier
14804 and then Nkind (With_Item) = N_Identifier
14806 Set_Entity (N, Entity (With_Item));
14808 elsif Nkind (N) = N_Selected_Component then
14809 Change_Selected_Component_To_Expanded_Name (N);
14810 Set_Entity (N, Entity (With_Item));
14811 Set_Entity (Selector_Name (N), Entity (N));
14813 Pref := Prefix (N);
14814 Scop := Scope (Entity (N));
14815 while Nkind (Pref) = N_Selected_Component loop
14816 Change_Selected_Component_To_Expanded_Name (Pref);
14817 Set_Entity (Selector_Name (Pref), Scop);
14818 Set_Entity (Pref, Scop);
14819 Pref := Prefix (Pref);
14820 Scop := Scope (Scop);
14823 Set_Entity (Pref, Scop);