Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / sem_prag.adb < prev next >

Wrap

Text File | 1996-09-28 | 125KB | 3,682 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ P R A G -- -- -- -- B o d y -- -- -- -- $Revision: 1.207 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This unit contains the semantic processing for all pragmas, both language -- and implementation defined. For most pragmas, the parser only does the -- most basic job of checking the syntax, so Sem_Prag also contains the code -- to complete the syntax checks. Certain pragmas are handled partially or -- completely by the parser (see Par.Prag for further details). with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Util; use Exp_Util; with Features; use Features; with Lib; use Lib; with Lib.Writ; use Lib.Writ; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; with Sem_Intr; use Sem_Intr; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; with Stringt; use Stringt; with Tbuild; use Tbuild; with Ttypes; with Uintp; use Uintp; package body Sem_Prag is -------------------------------------------------------- -- Description of GNAT Implementation-Defined Pragmas -- -------------------------------------------------------- -- pragma Abort_Defer; -- -- This pragma is implementation (GNAT) defined. It must appear at -- the start of the statement sequence of a handled sequence of -- statements (right after the begin). It has the effect of deferring -- aborts for the sequence of statements (but not for the declarations -- or handlers, if any, associated with this statement sequence). -- pragma Ada_83; -- -- This pragma is an implementation (GNAT) defined configuration -- pragma whose effect is to establish Ada 83 mode for the unit to -- which it applies, regardless of the mode set by the command line -- switches. -- pragma Ada_95; -- -- This pragma is an implementation (GNAT) defined configuration -- pragma whose effect is to establish Ada 95 mode for the unit to -- which it applies, regardless of the mode set by the command line -- switches. Note that this mode is set automatically for Ada and System -- and their children, so it need not be given in these contexts. -- pragma Annotate (IDENTIFIER {, ARG); -- ARG ::= NAME | EXPRESSION -- This pragma is an implementation (GNAT) defined pragma used to -- annotate programs. The first argument is simply an identifier -- that identifies the type of annotation. GNAT verifies that this -- is an identifier, but does not otherwise analyze it. The arguments -- following this identifier are analyzed as follows: -- -- String literals are assumed to be of type Standard.String -- Names of entities are simply analyzed as entity names -- All other expressions are analyzed as expressions, and must -- be unambiguous -- -- The analyzed pragma is retained in the tree, but not otherwise -- processed by any part of the GNAT compiler. This pragma is intended -- for use by external tools. -- pragma Assert (Boolean_EXPRESSION [,static_string_EXPRESSION]); -- -- This pragma is implementation (GNAT) defined. Its effect depends -- on whether the corresponding command line switch is set to activate -- assertions. If assertions are inactive, the pragma has no effect. -- If asserts are enabled, then the semantics of the pragma is exactly -- equivalent to: -- -- if not Boolean_EXPRESSION then -- System.Assertions.Raise_Assert_Failure (string_EXPRESSION); -- end if; -- -- The effect of the call is to raise System.Assertions.Assert_Failure. -- The string argument, if given, is the message associated with the -- exception occurrence. If no second argument is given, the default -- message is "file:nnn", where file is the name of the source file -- containing the assert, and nnn is the line number of the assert. -- -- Note: a pragma is not a statement, so if a statement sequence -- contains nothing but a pragma assert, then a null statement is -- required in addition, as in: -- -- ... -- if J > 3 then -- pragma (Assert (K > 3, "Bad value for K")); -- null; -- end if; -- -- Note: if the boolean expression has side effects, then these side -- effects will turn on and off with the setting of the assertions mode, -- resulting in assertions that have an effect on the program. This -- should generally be avoided. -- -- Note: the maximum length of the string given as the second argument -- is 200 characters (the maximum lengh of an exception occurrence -- message). -- pragma CPP_Class ([Entity =>] LOCAL_NAME) -- The argument denotes an entity in the current declarative region -- that is declared as a tagged or untagged record type. It indicates -- that the type corresponds to an externally declared C++ class type, -- and is to be layed out the same way that C++ would lay out the type. -- If (and only if) the type is tagged, at least one component in the -- record must be of type Interfaces.CPP.Vtable_Ptr, corresponding to -- the C++ Vtable (or Vtables in the case of multiple inheritance) -- used for dispatching. -- -- Types for which CPP_Class is defined do not have assignment or -- equality operators defined (such operations can be imported or -- declared as subprograms as required). Initialization is allowed -- only by constructor functions (see pragma CPP_Constructor). -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME); -- This pragma identifies an imported function (imported in the usual -- way with pragma Import) as corresponding to a C++ constructor. The -- identified function must be previously mentioned in a pragma Import -- with convention C++, and must be of one of the following forms: -- -- function Fname return T'Class; -- function Fname (<parameters>) return T'Class; -- -- where T is a tagged type to which the pragma CPP_Class applies. -- -- The first form is the default constructor, used when an object -- of type T is created on the Ada side with no explicit constructor. -- Other constructors (including the copy constructor, which is simply -- a special case of the second form in which the one and only argument -- is of type T), can only appear in two contexts: -- -- On the right side of an initialization of an object of type T -- In an extension aggregate for an object of a type derived from T -- -- Note that although the constructor is described as a function that -- returns a value on the Ada side, it is typically a procedure with -- an extra implicit argument (the object being initialized) at the -- implementation level. GNAT takes care of issuing the appropriate -- call, whatever it is, to get the object properly initialized. -- -- Note: in the case of derived objects, there are two possible forms -- for declaring and creating an object: -- -- New_Object : Derived_T; -- New_Object : Derived_T := (constructor-function-call with ...); -- -- In the first case the default constructor is called, and extension -- fields if any are initialized according to the default initialization -- expressions in the Ada declaration. In the second case, the given -- constructor is called, and the extension aggregate indicates the -- explicit values of the extension fields. -- -- Note: if no constructors are imported then it is impossible to -- create any objects on the Ada side. If no default constructor is -- imported, then only the initialization forms using an explicit -- call to a constructor are permitted. -- pragma CPP_Destructor ([Entity =>] LOCAL_NAME); -- -- This pragma identifies an imported procedure (imported in the usual -- way with pragma Import) as corresponding to a C++ destructor. The -- identified procedure must be previously mentioned in a pragma Import -- with convention C++, and must be of the following forms: -- -- procedure Fname (obj : in out T'Class); -- -- where T is a tagged type to which the pragma CPP_Class applies. -- This procedure will be called automaticlly on scope exit if any -- objects of T are created on the Ada side. -- pragma CPP_Virtual -- [Entity =>] LOCAL_NAME -- [ [Vtable_Ptr =>] Component_NAME, -- [Position =>] static_integer_EXPRESSION]); -- -- This pragma serves the same function as pragma Import for the case -- of a virtual function that is imported from C++. Entity must refer -- to a primitive subprogram of a tagged type to which pragma CPP_Class -- applies. Vtable_Ptr specifies the Vtable_Ptr component which contains -- the entry for this virtual function, and Position is the sequential -- number counting virtual functions for this Vtable starting at 1. -- -- The Vtable_Ptr and Position arguments may be omitted if there is -- one Vtable_Ptr present (single inheritance case), and all virtual -- functions are imported, since then the compiler can deduce both -- these values. -- -- Note that no External_Name or Link_Name arguments are required for -- a virtual function, since it is always accessed indirectly via the -- appropriate Vtable entry. -- pragma CPP_Vtable ( -- [Entity =>] LOCAL_NAME -- [Vtable_Ptr =>] Component_NAME, -- [Entry_Count =>] static_integer_EXPRESSION); -- -- One CPP_Vtable pragma can be present for each component of type -- CPP.Interfaces.Vtable_Ptr in a record to which pragma CPP_Class -- applies. Entity is the tagged type, Vtable_Ptr is the record field -- of type Vtable_Ptr, and Entry_Count is the number of virtual -- functions on the C++ side (not all of which need to be imported -- on the Ada side). -- -- It is permissible to omit the CPP_Vtable pragma if there is only -- one Vtable_Ptr component in the record, and all virtual functions -- are imported on the Ada side (the default value for the entry count -- in this case is simply the total number of virtual functions). -- pragma Debug (PROCEDURE_CALL_STATEMENT); -- -- This pragma is implementation (GNAT) defined. Its effect depends -- on the setting of the Assertions_Enabled flag in Opt. If this -- flag is off (False), then the pragma has no effect. If the flag -- is on (True), then the semantics of the pragma is equivalent to -- the procedure call. -- pragma Error_Monitoring (ON | OFF, STRING_LITERAL) -- -- This pragma is implementation (GNAT) defined. It is used to bracket -- a section of code, using one pragma with argument ON to start the -- section, and another with argument OFF to end the section. Within -- the monitored section of code, any error message issued will be -- considered a warning from the point of view of the return code -- issued by the compilation. Furthermore at least one such error -- must occur within each monitored region. If no error occurs, a -- fatal (non-warning) message is issued. The use of the pragma -- Error_Monitoring causes code generation to be turned off (since -- there really are errors in the program). -- -- If a second argument is given, then there is an additional check -- that the first error issued in the monitored region exactly matches -- the characters given in the string literal. The second argument is -- only relevant for the ON case, it is ignored for the OFF case. -- -- This pragma is provided to allow easy automation of error message -- generation, e.g. in ACVC B tests, and is primarily intended for -- compiler testing purposes. -- pragma Interface_Name ( -- [Entity =>] LOCAL_NAME -- [,[External_Name =>] static_string_EXPRESSION]] -- [,[Link_Name =>] static_string_EXPRESSION]] ); -- -- This pragma is implementation (GNAT) defined. It is an alternative -- way of specifying the interface name for an interfaced subprogram, -- and is provided for compatibility with Ada 83 compilers that use -- the pragma for this purpose. At least one of the arguments external -- name or link name must be present. -- pragma Machine_Attribute ( -- [Attribute_Name =>] static_string_EXPRESSION -- ,[Entity =>] LOCAL_NAME ); -- -- This pragma is implementation (GNAT) defined. Machine dependent -- attributes can be specified for types and/or declarations. Currently -- only subprogram entities are supported. This pragma is semantically -- equivalent to __attribute__(( <Attribute_Name> )) in Gnu C, where -- <Attribute_Name> is recognized by the Gnu C macros: -- -- VALID_MACHINE_TYPE_ATTRIBUTE -- VALID_MACHINE_DECL_ATTRIBUTE, -- -- which are defined in the configuration header file tm.h. Further -- documentation can be found in the gcc distribution document: tm.texi. -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]); -- -- This pragma is implementation (GNAT) defined. It typically appears -- as the first line of a source file. The integer value is the logical -- line number of the line following the pragma line (for use in error -- messages and debugging information). The second argument is a static -- string constant that specifies the file name to be used in error -- messages and debugging information. This is most notably used for -- the output of gnatchop with the -r switch, to make sure that the -- original unchopped source file is the one referred to. -- -- Note: the second argument must be a string literal, it cannot be -- a static string expression other than a string literal. This is -- because its value is needed for error messages issued by all phases -- of the compiler. -- pragma Unimplemented_Unit; -- -- This pragma is implementation (GNAT) defined. If it occurs in a -- unit that is processed by the compiler, the compilation is aborted -- with the message xxx not implemented, where xxx is the name of -- the current compilation unit followed by a compiler abort. This -- pragma is intended to allow the compiler to handle unimplemented -- library units in a clean manner. -- -- The abort only hapens if code is being generated. This allows the -- use of specs of unimplemented packages in syntax or semantic -- checking mode. -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); -- -- This pragma is implementation (GNAT) defined. It undoes the effect -- of a previous pragma Unsuppress. If there is no corresponding -- pragma Suppress in effect, then it has no effect. The range of -- the effect is the same as for pragma Suppress. The meaning of the -- arguments is identical to that used in pragma Suppress. -- -- One important application is to ensure that checks are on in cases -- where code depends on the checks for its correct functioning, so -- that the code will compile correctly even if the compiler switches -- are set to suppress checks. ----------------------- -- Local Subprograms -- ----------------------- function Is_Generic_Subprogram (Id : Entity_Id) return Boolean; -- Return True if Id is a generic procedure or a function -------------------- -- Analyze_Pragma -- -------------------- procedure Analyze_Pragma (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Prag_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N)); Pragma_Error : exception; -- This is exception is raised if any error is detected in a pragma Arg_Count : Int; -- Number of pragma argument associations function Arg1 return Node_Id; function Arg2 return Node_Id; function Arg3 return Node_Id; function Arg4 return Node_Id; -- Obtain specified Pragma_Argument_Association. It is allowable to -- call the routine for the argument one past the last present argument, -- but that is the only case in which a non-present argument can be -- referenced. procedure Check_Ada_83_Warning; -- Issues a warning message for the current pragma if operating in Ada -- 83 mode (used for language pragmas that are not a standard part of -- Ada 83). This procedure does not raise Error_Pragma. Also notes use -- of 95 pragma. procedure Check_Arg_Count (Required : Int); -- Check argument count for pragma is equal to given parameter. -- If not, then issue an error message and raise Error_Resync. procedure Check_Arg_Is_Convention (Arg : Node_Id); -- Check the expression of the specified argument to make sure that it -- is a valid convention name. If not give error and raise Pragma_Error. -- This procedure also checks for the possible allowed presence of the -- identifier Convention for this argument. procedure Check_Arg_Is_Identifier (Arg : Node_Id); -- Check the expression of the specified argument to make sure that -- it is an identifier. If not give error and raise Pragma_Error. procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id); -- Check the expression of the specified argument to make sure that it -- is an integer literal. If not give error and raise Pragma_Error. procedure Check_Arg_Is_Local_Name (Arg : Node_Id); -- Check the expression of the specified argument to make sure that -- it has the proper syntactic form for a local name and meets the -- semantic requirements for a local name. The local name is analyzed -- as part of the processing for this call. procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id); -- Check the expression of the specified argument to make sure that -- it is a valid locking policy name. If not give error and raise -- Pragma_Error. procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id); -- Check the expression of the specified argument to make sure that it -- is an identifier whose name matches either N1 or N2 (or N3). If not, -- then issue an error message and raise Error_Resync. procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id); -- Check the expression of the specified argument to make sure that -- it is a valid queuing policy name. If not give error and raise -- Pragma_Error. procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); -- Check the expression of the specified argument to make sure that -- it is a valid task dispatching policy name. If not give error and -- raise Pragma_Error. procedure Check_At_Least_One_Argument; -- Check there is at least one argument. procedure Check_Is_In_Decl_Part_Or_Package_Spec; -- Check that pragma appears in a declarative part, or in a package -- specification, i.e. that it does not occur in a statement sequence -- in a body. procedure Check_No_Identifier (Arg : Node_Id); -- Checks that the given argument does not have an identifier. If -- an identifier is present, then an error message is issued, and -- Pragma_Error is raised. procedure Check_No_Identifiers; -- Checks that none of the arguments to the pragma has an identifier. -- If any argument has an identifier, then an error message is issued, -- and Pragma_Error is raised. procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); -- Checks if the given argument has an identifier, and if so, requires -- it to match the given identifier name. If there is a non-matching -- identifier, then an error message is given and Error_Pragmas raised. procedure Check_Static_String_Expr (Expr : Node_Id); -- Checks that the given argument expression is a static string -- expression. Note that the argument is the expression, not the -- pragma argument association. procedure Check_Valid_Configuration_Pragma; -- Legality checks for placement of a configuration pragma procedure Check_Valid_Library_Unit_Pragma; -- Legality checks for library unit pragmas procedure Error_Pragma (Msg : String); -- Outputs error message for current pragma. The message contains an % -- that will be replaced with the pragma name, and the flag is placed -- on the pragma itself. Pragma_Error is then raised. procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id); -- Outputs error message for current pragma. The message contains an % -- that will be replaced with the pragma name, and the flag is placed -- on the expression of the pragma argument specified by Arg. After -- placing the message, Pragma_Error is raised. function Find_Lib_Unit_Name return Entity_Id; -- Find the defining entity of the spec library unit name. procedure Find_Program_Unit_Name (Id : Node_Id); -- If the pragma is a compilation unit pragma, the id must denote the -- compilation unit in the same compilation, and the pragma must appear -- in the list of preceding or trailing pragmas. If it is a program -- unit pragma that is not a compilation unit pragma, then the -- identifier must be visible. function Is_Before_First_Decl (Pragma_Node : Node_Id; Decls : List_Id) return Boolean; -- Return True if Pragma_Node is before the first declarative item in -- Decls where Decls is the list of declarative items. function Is_Configuration_Pragma return Boolean; -- Deterermines if the placement of the current pragma is appropriate -- for a configuration pragma (precedes the current compilation unit) function Is_Inside_Generic_Instantiation (Pragma_Node : Node_Id) return Boolean; -- Return True if Pragma_Node is inside a generic instantiation. procedure Pragma_Misplaced; -- Issue fatal error message for misplaced pragma procedure Pragma_Not_Implemented; -- Issue warning message for unimplemented pragma procedure Process_Convention (C : out Convention_Id; E : out Entity_Id); -- Common procesing for Convention, Interface, Import and Export. -- Checks first two arguments of pragma, and sets the appropriate -- convention value in the specified entity or entities. On return -- C is the convention, E is the referenced entity. procedure Process_Interface_Name (Subprogram_Def : Entity_Id; Ext_Arg : Node_Id; Link_Arg : Node_Id); -- Given the last two arguments of pragma Import, pragma Export, or -- pragma Interface_Name, performs validity checks and sets the -- Interface_Name field of the given subprogram entity to the -- appropriate external or link name, depending on the arguments -- given. Ext_Arg is always present, but Link_Arg may be missing. -- Note that Ext_Arg may represent the Link_Name if Link_Arg is -- missing, and appropriate named notation is used for Ext_Arg. procedure Process_Suppress_Unsuppress (Sense : Boolean); -- Common processing for Suppress and Unsuppress ---------- -- Arg1 -- ---------- function Arg1 return Node_Id is begin return First (Pragma_Argument_Associations (N)); end Arg1; ---------- -- Arg2 -- ---------- function Arg2 return Node_Id is begin return Next (Arg1); end Arg2; ---------- -- Arg3 -- ---------- function Arg3 return Node_Id is begin return Next (Arg2); end Arg3; ---------- -- Arg4 -- ---------- function Arg4 return Node_Id is begin return Next (Arg3); end Arg4; -------------------------- -- Check_Ada_83_Warning -- -------------------------- procedure Check_Ada_83_Warning is begin Note_Feature (New_Pragmas, Loc); if Ada_83 and then Comes_From_Source (N) then Error_Msg_N ("(Ada 83) pragma& is non-standard?", N); end if; end Check_Ada_83_Warning; --------------------- -- Check_Arg_Count -- --------------------- procedure Check_Arg_Count (Required : Int) is begin if Arg_Count /= Required then Error_Pragma ("wrong number of arguments for pragma%"); end if; end Check_Arg_Count; ----------------------------- -- Check_Arg_Is_Convention -- ----------------------------- procedure Check_Arg_Is_Convention (Arg : Node_Id) is begin Check_Arg_Is_Identifier (Arg); Check_Optional_Identifier (Arg, Name_Convention); if not Is_Convention_Name (Chars (Expression (Arg))) then Error_Pragma_Arg ("argument of pragma% is not valid convention name", Arg); end if; end Check_Arg_Is_Convention; ----------------------------- -- Check_Arg_Is_Identifier -- ----------------------------- procedure Check_Arg_Is_Identifier (Arg : Node_Id) is begin if Nkind (Expression (Arg)) /= N_Identifier then Error_Pragma_Arg ("argument for pragma% must be identifier", Arg); end if; end Check_Arg_Is_Identifier; ---------------------------------- -- Check_Arg_Is_Integer_Literal -- ---------------------------------- procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is begin if Nkind (Expression (Arg)) /= N_Integer_Literal then Error_Pragma_Arg ("argument for pragma% must be integer literal", Arg); end if; end Check_Arg_Is_Integer_Literal; ----------------------------- -- Check_Arg_Is_Local_Name -- ----------------------------- -- LOCAL_NAME ::= -- DIRECT_NAME -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR -- | library_unit_NAME procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is Argx : constant Node_Id := Expression (Arg); begin if Nkind (Argx) not in N_Direct_Name and then (Nkind (Argx) /= N_Selected_Component or else Nkind (Selector_Name (Argx)) /= N_Identifier) and then (Nkind (Argx) /= N_Attribute_Reference or else Present (Expressions (Argx)) or else Nkind (Prefix (Argx)) /= N_Identifier) then Error_Pragma_Arg ("argument for pragma% must be local name", Arg); end if; Analyze (Argx); -- Semantic checking required here ??? end Check_Arg_Is_Local_Name; --------------------------------- -- Check_Arg_Is_Locking_Policy -- --------------------------------- procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is begin Check_Arg_Is_Identifier (Arg); if not Is_Locking_Policy_Name (Chars (Expression (Arg))) then Error_Pragma_Arg ("argument of pragma% is not valid locking policy name", Arg1); end if; end Check_Arg_Is_Locking_Policy; ------------------------- -- Check_Arg_Is_One_Of -- ------------------------- procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is Argx : constant Node_Id := Expression (Arg); begin Check_Arg_Is_Identifier (Arg); if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then Error_Msg_Name_2 := N1; Error_Msg_Name_3 := N2; Error_Pragma_Arg ("argument for pragma% must be% or%", Arg); end if; end Check_Arg_Is_One_Of; procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id) is Argx : constant Node_Id := Expression (Arg); begin Check_Arg_Is_Identifier (Arg); if Chars (Argx) /= N1 and then Chars (Argx) /= N2 and then Chars (Argx) /= N3 then Error_Pragma_Arg ("invalid argument for pragma%", Arg); end if; end Check_Arg_Is_One_Of; --------------------------------- -- Check_Arg_Is_Queuing_Policy -- --------------------------------- procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is begin Check_Arg_Is_Identifier (Arg); if not Is_Queuing_Policy_Name (Chars (Expression (Arg))) then Error_Pragma_Arg ("argument of pragma% is not valid queuing policy name", Arg1); end if; end Check_Arg_Is_Queuing_Policy; ------------------------------------------ -- Check_Arg_Is_Task_Dispatching_Policy -- ------------------------------------------ procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is begin Check_Arg_Is_Identifier (Arg); if not Is_Task_Dispatching_Policy_Name (Chars (Expression (Arg))) then Error_Pragma_Arg ("argument of pragma% is not valid task dispatching policy name", Arg); end if; end Check_Arg_Is_Task_Dispatching_Policy; --------------------------------- -- Check_At_Least_One_Argument -- --------------------------------- procedure Check_At_Least_One_Argument is begin if Arg_Count = 0 then Error_Pragma ("pragma% requires at least one argument"); end if; end Check_At_Least_One_Argument; ------------------------------------------- -- Check_Is_In_Decl_Part_Or_Package_Spec -- ------------------------------------------- procedure Check_Is_In_Decl_Part_Or_Package_Spec is P : Node_Id; begin P := Parent (N); loop if No (P) then exit; elsif Nkind (P) = N_Handled_Sequence_Of_Statements then exit; elsif Nkind (P) = N_Package_Specification then return; elsif Nkind (P) = N_Block_Statement then return; -- Note: the following tests seem a little peculiar, because -- they test for bodies, but if we were in the statement part -- of the body, we would already have hit the handled statement -- sequence, so the only way we get here is by being in the -- declarative part of the body. elsif Nkind (P) = N_Subprogram_Body or else Nkind (P) = N_Package_Body or else Nkind (P) = N_Task_Body or else Nkind (P) = N_Entry_Body then return; end if; P := Parent (P); end loop; Error_Pragma ("pragma% is not in declarative part or package spec"); end Check_Is_In_Decl_Part_Or_Package_Spec; ------------------------- -- Check_No_Identifier -- ------------------------- procedure Check_No_Identifier (Arg : Node_Id) is begin if Chars (Arg) /= No_Name then Error_Pragma_Arg ("pragma% does not permit named arguments", Arg); end if; end Check_No_Identifier; -------------------------- -- Check_No_Identifiers -- -------------------------- procedure Check_No_Identifiers is Arg_Node : Node_Id; begin if Arg_Count > 0 then Arg_Node := Arg1; while Present (Arg_Node) loop Check_No_Identifier (Arg_Node); Arg_Node := Next (Arg_Node); end loop; end if; end Check_No_Identifiers; ------------------------------- -- Check_Optional_Identifier -- ------------------------------- procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is begin if Present (Arg) and then Chars (Arg) /= No_Name then if Chars (Arg) /= Id then Error_Msg_Name_1 := Chars (N); Error_Msg_Name_2 := Id; Error_Msg_N ("pragma% argument expects identifier%", Arg); raise Pragma_Error; end if; end if; end Check_Optional_Identifier; ------------------------------ -- Check_Static_String_Expr -- ------------------------------ procedure Check_Static_String_Expr (Expr : Node_Id) is begin Analyze (Expr); Resolve (Expr, Standard_String); if Etype (Expr) = Any_Type then raise Pragma_Error; elsif not Is_Static_Expression (Expr) then Error_Pragma_Arg ("static string expression required here", Parent (Expr)); end if; end Check_Static_String_Expr; -------------------------------------- -- Check_Valid_Configuration_Pragma -- -------------------------------------- -- A configuration pragma must appear in the context clause of -- a compilation unit, at the start of the list (i.e. only other -- pragmas may precede it). procedure Check_Valid_Configuration_Pragma is begin if not Is_Configuration_Pragma then Error_Pragma ("incorrect placement for configuration pragma%"); end if; end Check_Valid_Configuration_Pragma; ------------------------------------- -- Check_Valid_Library_Unit_Pragma -- ------------------------------------- procedure Check_Valid_Library_Unit_Pragma is Decl : Node_Id; Plist : List_Id; Parent_Node : Node_Id; Unit_Name : Entity_Id; Valid : Boolean := True; Unit_Kind : Node_Kind; Unit_Node : Node_Id; begin if not Is_List_Member (N) then Pragma_Misplaced; Valid := False; else Plist := List_Containing (N); Parent_Node := Parent (Plist); if Parent_Node = Empty then Pragma_Misplaced; elsif Nkind (Parent_Node) = N_Compilation_Unit then -- Pragma must appear after a compilation_unit, and must have -- an argument with the right name. if Plist /= Following_Pragmas (Parent_Node) then Pragma_Misplaced; elsif Arg_Count > 0 then Check_No_Identifiers; Check_Arg_Count (1); Unit_Node := Unit (Parent_Node); Unit_Kind := Nkind (Unit_Node); Analyze (Expression (Arg1)); if Unit_Kind = N_Generic_Subprogram_Declaration or else Unit_Kind = N_Subprogram_Declaration then Unit_Name := Defining_Unit_Simple_Name (Specification (Unit_Node)); elsif Unit_Kind = N_Function_Instantiation or else Unit_Kind = N_Package_Instantiation or else Unit_Kind = N_Procedure_Instantiation then Unit_Name := Defining_Unit_Simple_Name (Unit_Node); -- Special case for generic instantiation. The library -- unit entity fetched using the normal (non-instantiation -- scope-wise) mechanism differs from the value obtained -- from Cunit_Entity (Current_Sem_Unit) in the case of an -- instantiation. The latter is used in Lib.Writ and in -- other situations. ??? elsif Unit_Kind = N_Package_Declaration and then Present (Generic_Parent (Specification (Unit_Node))) then Unit_Name := Defining_Unit_Simple_Name (Specification (Unit_Node)); case Prag_Id is when Pragma_Preelaborate => Set_Is_Preelaborated (Cunit_Entity ( Current_Sem_Unit)); when Pragma_Pure => Set_Is_Pure (Cunit_Entity (Current_Sem_Unit)); when Pragma_Remote_Call_Interface => Set_Is_Remote_Call_Interface (Cunit_Entity (Current_Sem_Unit)); when Pragma_Remote_Types => Set_Is_Remote_Types (Cunit_Entity (Current_Sem_Unit)); when Pragma_Shared_Passive => Set_Is_Shared_Passive (Cunit_Entity (Current_Sem_Unit)); when Pragma_All_Calls_Remote => Set_Has_All_Calls_Remote (Cunit_Entity (Current_Sem_Unit)); when others => null; end case; else Unit_Name := Cunit_Entity (Current_Sem_Unit); end if; if Unit_Name /= Entity (Expression (Arg1)) then Error_Pragma_Arg ("pragma% argument is not current unit name", Arg1); end if; else Error_Pragma ("missing argument in pragma%"); end if; elsif Is_Before_First_Decl (N, Plist) then -- Name is optional, pragma applies to enclosing unit. Unit_Node := Get_Declaration_Node (Current_Scope); Unit_Kind := Nkind (Unit_Node); if (Unit_Kind = N_Package_Declaration and then Present (Generic_Parent (Specification (Unit_Node)))) or else Nkind (Original_Node (Unit_Node)) = N_Formal_Package_Declaration then -- The pragma appears in (the equivalent of) an instance. -- validation takes place in the generic itself. return; elsif Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then Pragma_Misplaced; elsif Unit_Kind = N_Package_Body or else Unit_Kind = N_Subprogram_Body then Pragma_Misplaced; elsif Arg_Count > 0 then Analyze (Expression (Arg1)); if Entity (Expression (Arg1)) /= Current_Scope then Error_Pragma_Arg ("name in pragma% must be enclosing unit", Arg1); end if; else -- Pragma with no argument is legal here. return; end if; -- If not first in declarative part, name is required. elsif Arg_Count > 0 then Analyze (Expression (Arg1)); Unit_Name := Entity (Expression (Arg1)); Unit_Node := Get_Declaration_Node (Unit_Name); if Scope (Unit_Name) /= Current_Scope then Error_Pragma_Arg ("argument of pragma% is not in current scope", Arg1); elsif Nkind (Unit_Node) not in N_Generic_Instantiation and then Nkind (Unit_Node) /= N_Generic_Subprogram_Declaration and then Nkind (Unit_Node) /= N_Subprogram_Declaration then Error_Pragma_Arg ("invalid name in pragma%", Arg1); end if; else Error_Pragma ("missing argument in pragma%"); end if; end if; end Check_Valid_Library_Unit_Pragma; ------------------ -- Error_Pragma -- ------------------ procedure Error_Pragma (Msg : String) is begin Error_Msg_Name_1 := Chars (N); Error_Msg_N (Msg, N); raise Pragma_Error; end Error_Pragma; --------------------------- -- Error_Pragma_Arg -- --------------------------- procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is begin Error_Msg_Name_1 := Chars (N); Error_Msg_N (Msg, Expression (Arg)); raise Pragma_Error; end Error_Pragma_Arg; ------------------------ -- Find_Lib_Unit_Name -- ------------------------ function Find_Lib_Unit_Name return Entity_Id is Lib_Unit : constant Node_Id := Enclosing_Lib_Unit_Node (N); Unit_Entity : Entity_Id := Current_Scope; Unit_Kind : Node_Kind := Nkind (Unit (Lib_Unit)); begin -- This routine is used for categorization pragmas that are -- inside the compilation (library) unit. if Unit_Kind in N_Generic_Renaming_Declaration or else Unit_Kind = N_Package_Renaming_Declaration or else Unit_Kind = N_Subprogram_Renaming_Declaration then -- Library_Unit_Renaming not allowed for Pure, Preelaborate Error_Msg_N ("pragma& cannot follow library unit renaming", N); Unit_Entity := Empty; end if; -- Return inner compilation unit entity, in case of anested -- categorization pragmas. This happens in a nested package -- renaming of an instantiation of a generic package whose -- spec has a categorization pragma. N is the pragma node. if Nkind (Parent (N)) = N_Package_Specification and then Defining_Unit_Simple_Name (Parent (N)) /= Unit_Entity then return Defining_Unit_Simple_Name (Parent (N)); end if; return Unit_Entity; end Find_Lib_Unit_Name; ---------------------------- -- Find_Program_Unit_Name -- ---------------------------- procedure Find_Program_Unit_Name (Id : Node_Id) is Unit_Name : Entity_Id; Unit_Kind : Node_Kind; P : constant Node_Id := Parent (N); begin if Nkind (P) = N_Compilation_Unit then Unit_Kind := Nkind (Unit (P)); if Unit_Kind = N_Subprogram_Declaration or else Unit_Kind = N_Package_Declaration or else Unit_Kind in N_Generic_Declaration then Unit_Name := Defining_Unit_Simple_Name (Specification (Unit (P))); if Chars (Id) = Chars (Unit_Name) then Set_Entity (Id, Unit_Name); Set_Etype (Id, Etype (Unit_Name)); else Set_Etype (Id, Any_Type); Error_Pragma ("cannot find program unit referenced by pragma%"); end if; else Set_Etype (Id, Any_Type); Error_Pragma ("pragma% inapplicable to this unit"); end if; else Analyze (Id); end if; end Find_Program_Unit_Name; -------------------------- -- Is_Before_First_Decl -- -------------------------- function Is_Before_First_Decl (Pragma_Node : Node_Id; Decls : List_Id) return Boolean is Item : Node_Id := First (Decls); begin if Is_Inside_Generic_Instantiation (Pragma_Node) then return True; end if; -- Only pragmas can come before this Pragma_Node. loop if No (Item) or else Nkind (Item) /= N_Pragma then return False; elsif Item = Pragma_Node then return True; end if; Item := Next (Item); end loop; end Is_Before_First_Decl; ----------------------------- -- Is_Configuration_Pragma -- ----------------------------- -- A configuration pragma must appear in the context clause of -- a compilation unit, at the start of the list (i.e. only other -- pragmas may precede it). function Is_Configuration_Pragma return Boolean is Lis : constant List_Id := List_Containing (N); Par : constant Node_Id := Parent (N); Prg : Node_Id; begin if Nkind (Par) = N_Compilation_Unit and then Context_Items (Par) = Lis then Prg := First (Lis); loop if Prg = N then return True; elsif Nkind (Prg) /= N_Pragma then return False; end if; Prg := Next (Prg); end loop; else return False; end if; end Is_Configuration_Pragma; ------------------------------------- -- Is_Inside_Generic_Instantiation -- ------------------------------------- function Is_Inside_Generic_Instantiation (Pragma_Node : Node_Id) return Boolean is Parent_Node : Node_Id := Parent (Pragma_Node); Parent_Kind : Node_Kind := Nkind (Parent_Node); begin -- Notice that a library unit pragma inside generic body is -- misplaced and will be found later. if Parent_Kind = N_Package_Specification then if Present (Generic_Parent (Parent_Node)) then return True; end if; -- It is impossible to be inside (generic) subprogram_spec elsif Parent_Kind = N_Subprogram_Body then if Present (Generic_Parent (Parent (Corresponding_Spec ( Parent (Parent_Node))))) then return True; end if; end if; return False; end Is_Inside_Generic_Instantiation; ---------------------- -- Pragma_Misplaced -- ---------------------- procedure Pragma_Misplaced is begin Error_Pragma ("incorrect placement of pragma%"); end Pragma_Misplaced; ---------------------------- -- Pragma_Not_Implemented -- ---------------------------- procedure Pragma_Not_Implemented is begin Error_Pragma ("pragma% not implemented?"); end Pragma_Not_Implemented; ------------------------ -- Process_Convention -- ------------------------ procedure Process_Convention (C : out Convention_Id; E : out Entity_Id) is Id : Node_Id; E1 : Entity_Id; Compilation_Unit : Node_Id; function Get_Compilation_Unit (N : Node_Id) return Node_Id; function Get_Compilation_Unit (N : Node_Id) return Node_Id is Unit : Node_Id := N; begin while Nkind (Unit) /= N_Compilation_Unit loop Unit := Parent (Unit); end loop; return Unit; end Get_Compilation_Unit; begin Check_Arg_Is_Convention (Arg1); Check_Arg_Is_Local_Name (Arg2); Check_Optional_Identifier (Arg2, Name_Entity); C := Get_Convention_Id (Chars (Expression (Arg1))); Id := Expression (Arg2); -- The following if is highly suspicious. It was derived from -- the code in 1.181 which handles intrinsic quite separately. -- It does not work to do Analyze (Id) for the case of an -- operator symbol to which pragma Convention Intrinsic is -- applied, so presumably this code is wrong for specifying -- a foreign convention for an operator ??? if C = Convention_Intrinsic then Find_Program_Unit_Name (Id); else Analyze (Id); if not Is_Entity_Name (Id) then Error_Pragma_Arg ("entity name required", Arg2); end if; end if; if Etype (Id) = Any_Type then raise Pragma_Error; end if; E := Entity (Id); -- For Intrinsic or Stdcall, a subprogram is required if (C = Convention_Intrinsic or else C = Convention_Stdcall) and then not Is_Subprogram (E) and then not Is_Generic_Subprogram (E) then Error_Pragma_Arg ("second argument of pragma% must be a subprogram", Arg2); end if; if Scope (E) /= Current_Scope then Error_Pragma_Arg ("pragma% must be in same declarative part", Arg2); end if; if not Is_Subprogram (E) and then not Is_Generic_Subprogram (E) then Set_Convention (E, C); else E1 := E; -- Only Homonyms in the same compilation unit count Compilation_Unit := Get_Compilation_Unit (E1); while Present (E1) and then Scope (E1) = Current_Scope loop if Compilation_Unit = Get_Compilation_Unit (E1) then Set_Convention (E1, C); end if; E1 := Homonym (E1); end loop; end if; end Process_Convention; ---------------------------- -- Process_Interface_Name -- ---------------------------- procedure Process_Interface_Name (Subprogram_Def : Entity_Id; Ext_Arg : Node_Id; Link_Arg : Node_Id) is Ext_Nam : Node_Id; Link_Nam : Node_Id; begin if No (Link_Arg) then if Chars (Ext_Arg) = No_Name or else Chars (Ext_Arg) = Name_External_Name then Ext_Nam := Expression (Ext_Arg); Link_Nam := Empty; else Ext_Nam := Empty; Link_Nam := Expression (Ext_Arg); end if; else Ext_Nam := Expression (Ext_Arg); Link_Nam := Expression (Link_Arg); end if; -- Check expressions for external name and link name are static if Present (Ext_Nam) then Check_Static_String_Expr (Ext_Nam); end if; if Present (Link_Nam) then Check_Static_String_Expr (Link_Nam); end if; -- If there is no link name, just set the external name if No (Link_Nam) then Set_Interface_Name (Subprogram_Def, Ext_Nam); -- For the Link_Name case, the given literal is preceded by an -- asterisk, which indicates to GCC that the given name should -- be taken literally, and in particular that no prepending of -- underlines should occur, even in systems where this is the -- normal default. else Start_String; Store_String_Char (Get_Char_Code ('*')); for J in 1 .. String_Length (Strval (Link_Nam)) loop Store_String_Char (Get_String_Char (Strval (Link_Nam), J)); end loop; Link_Nam := Make_String_Literal (Sloc (Link_Nam), End_String); Set_Interface_Name (Subprogram_Def, Link_Nam); end if; end Process_Interface_Name; --------------------------------- -- Process_Suppress_Unsuppress -- --------------------------------- procedure Process_Suppress_Unsuppress (Sense : Boolean) is C : constant Check_Id := Get_Check_Id (Chars (Expression (Arg1))); E_Id : Node_Id; E : Entity_Id; Effective : Boolean; procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); -- Used to suppress a single check on the given entity procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is begin -- First set appropriate suppress flags in the entity case C is when Access_Check => Effective := Suppress_Access_Checks (E); Set_Suppress_Access_Checks (E, Sense); when Accessibility_Check => Effective := Suppress_Accessibility_Checks (E); Set_Suppress_Accessibility_Checks (E, Sense); when Discriminant_Check => Effective := Suppress_Discriminant_Checks (E); Set_Suppress_Discriminant_Checks (E, Sense); when Division_Check => Effective := Suppress_Division_Checks (E); Set_Suppress_Division_Checks (E, Sense); when Elaboration_Check => Effective := Suppress_Elaboration_Checks (E); Set_Suppress_Elaboration_Checks (E, Sense); when Index_Check => Effective := Suppress_Index_Checks (E); Set_Suppress_Index_Checks (E, Sense); when Length_Check => Effective := Suppress_Length_Checks (E); Set_Suppress_Length_Checks (E, Sense); when Overflow_Check => Effective := Suppress_Overflow_Checks (E); Set_Suppress_Overflow_Checks (E, Sense); when Range_Check => Effective := Suppress_Range_Checks (E); Set_Suppress_Range_Checks (E, Sense); when Storage_Check => Effective := Suppress_Storage_Checks (E); Set_Suppress_Storage_Checks (E, Sense); when Tag_Check => Effective := Suppress_Tag_Checks (E); Set_Suppress_Tag_Checks (E, Sense); when All_Checks => Suppress_Unsuppress_Echeck (E, Access_Check); Suppress_Unsuppress_Echeck (E, Accessibility_Check); Suppress_Unsuppress_Echeck (E, Discriminant_Check); Suppress_Unsuppress_Echeck (E, Division_Check); Suppress_Unsuppress_Echeck (E, Elaboration_Check); Suppress_Unsuppress_Echeck (E, Index_Check); Suppress_Unsuppress_Echeck (E, Length_Check); Suppress_Unsuppress_Echeck (E, Overflow_Check); Suppress_Unsuppress_Echeck (E, Range_Check); Suppress_Unsuppress_Echeck (E, Storage_Check); Suppress_Unsuppress_Echeck (E, Tag_Check); end case; -- If the entity is not declared in the current scope, then we -- make an entry in the Entity_Suppress table so that the flag -- will be removed on exit. This entry is only made if the -- suppress did something (i.e. the flag was not already set). if Effective and then Scope (E) /= Current_Scope then Entity_Suppress.Increment_Last; Entity_Suppress.Table (Entity_Suppress.Last).Entity := E; Entity_Suppress.Table (Entity_Suppress.Last).Check := C; end if; end Suppress_Unsuppress_Echeck; -- Start of processing for Process_Suppress_Unsuppress begin if Arg_Count = 1 then case C is when Access_Check => Scope_Suppress.Access_Checks := Sense; when Accessibility_Check => Scope_Suppress.Accessibility_Checks := Sense; when Discriminant_Check => Scope_Suppress.Discriminant_Checks := Sense; when Division_Check => Scope_Suppress.Division_Checks := Sense; when Elaboration_Check => Scope_Suppress.Elaboration_Checks := Sense; when Index_Check => Scope_Suppress.Index_Checks := Sense; when Length_Check => Scope_Suppress.Length_Checks := Sense; when Overflow_Check => Scope_Suppress.Overflow_Checks := Sense; when Range_Check => Scope_Suppress.Range_Checks := Sense; when Storage_Check => Scope_Suppress.Storage_Checks := Sense; when Tag_Check => Scope_Suppress.Tag_Checks := Sense; when All_Checks => Scope_Suppress := (others => Sense); end case; -- Case of two arguments present, where the check is -- suppressed for a specified entity (given as the second -- argument of the pragma) else E_Id := Expression (Arg2); Analyze (E_Id); E := Entity (E_Id); if E = Any_Id then return; else Suppress_Unsuppress_Echeck (E, C); while Present (Homonym (E)) loop E := Homonym (E); Suppress_Unsuppress_Echeck (E, C); end loop; end if; end if; end Process_Suppress_Unsuppress; -------------------------------------------- -- Start of processing for Analyze_Pragma -- -------------------------------------------- begin -- Count number of arguments declare Arg_Node : Node_Id; begin Arg_Count := 0; if Present (Pragma_Argument_Associations (N)) then Arg_Node := Arg1; while Arg_Node /= Empty loop Arg_Count := Arg_Count + 1; Arg_Node := Next (Arg_Node); end loop; end if; end; -- An enumeration type defines the pragmas that are supported by the -- implementation. Get_Pragma_Id (in package Prag) transorms a name -- into the corresponding enumeration value for the following case. case Prag_Id is ----------------- -- Abort_Defer -- ----------------- -- pragma Abort_Defer; when Pragma_Abort_Defer => Note_Feature (Implementation_Dependent_Pragmas, Loc); Check_Arg_Count (0); -- The only required semantic processing is to check the -- placement. This pragma must appear at the start of the -- statement sequence of a handled sequence of statements. if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements or else N /= First (Statements (Parent (N))) then Pragma_Misplaced; end if; ------------ -- Ada_83 -- ------------ -- pragma Ada_83; -- Note: this pragma also has some specific processing in Par.Prag -- because we want to set the Ada 83 mode switch during parsing. when Pragma_Ada_83 => Note_Feature (Implementation_Dependent_Pragmas, Loc); Ada_83 := True; Ada_95 := False; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; ------------ -- Ada_95 -- ------------ -- pragma Ada_83; -- Note: this pragma also has some specific processing in Par.Prag -- because we want to set the Ada 83 mode switch during parsing. when Pragma_Ada_95 => Note_Feature (Implementation_Dependent_Pragmas, Loc); Ada_83 := False; Ada_95 := True; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; ---------------------- -- All_Calls_Remote -- ---------------------- -- pragma All_Calls_Remote [(library_package_NAME)]; when Pragma_All_Calls_Remote => All_Calls_Remote : declare Ey : Entity_Id; begin Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; Ey := Find_Lib_Unit_Name; -- This pragma should only apply to a RCI unit (RM E.2.3(23)). if Present (Ey) and then not Debug_Flag_U then if not Is_Remote_Call_Interface (Ey) then Error_Pragma ("pragma% only apply to rci unit"); -- Set flag for entity of the library unit else Set_Has_All_Calls_Remote (Ey); end if; end if; end All_Calls_Remote; -------------- -- Annotate -- -------------- -- pragma Annotate (IDENTIFIER {, ARG); -- ARG ::= NAME | EXPRESSION when Pragma_Annotate => Annotate : begin Note_Feature (Implementation_Dependent_Pragmas, Loc); Check_At_Least_One_Argument; Check_Arg_Is_Identifier (Arg1); declare Arg : Node_Id := Arg2; begin while Present (Arg) loop Analyze (Arg); if Is_Entity_Name (Arg) then null; elsif Nkind (Arg) = N_String_Literal then Resolve (Arg, Standard_String); elsif Is_Overloaded (Arg) then Error_Pragma_Arg ("ambiguous argument for pragma%", Arg); else Resolve (Arg, Etype (Arg)); end if; end loop; end; end Annotate; ------------ -- Assert -- ------------ -- pragma Assert (Boolean_EXPRESSION); when Pragma_Assert => Note_Feature (Implementation_Dependent_Pragmas, Loc); Check_No_Identifiers; if Arg_Count > 1 then Check_Arg_Count (2); Check_Static_String_Expr (Expression (Arg2)); end if; ------------------ -- Asynchronous -- ------------------ -- pragma Asynchronous (LOCAL_NAME); when Pragma_Asynchronous => Asynchronous : declare Ey : constant Entity_Id := Find_Lib_Unit_Name; F : Boolean; Nm : Entity_Id; L : List_Id; S : Node_Id; N : Node_Id; I : Entity_Id; begin Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); if not Present (Ey) or else Debug_Flag_U then return; end if; Analyze (Expression (Arg1)); Nm := Entity (Expression (Arg1)); if not Is_Remote_Call_Interface (Ey) and then not Is_Remote_Types (Ey) then -- This pragma should only appear in an RCI or Remote Types -- unit. AARM E.4.1(4,4a) Error_Pragma ("pragma% not in rci or remote types unit"); elsif not Is_Remote_Call_Interface (Nm) and then not Is_Remote_Types (Ey) then -- The argumnet should be declared in RCI or Remote Types -- unit AARM E.4.1(4,4a) Error_Pragma_Arg ("pragma% argument not in rci/remote types unit", Arg1); end if; if Ekind (Nm) = E_Procedure and then Nkind (Parent (Nm)) = N_Procedure_Specification then L := Parameter_Specifications (Parent (Nm)); if not Present (L) then Set_Is_Asynchronous (Nm); return; end if; -- The formals should be of mode in E.4.1(6) S := First (L); while Present (S) loop I := Defining_Identifier (S); if Nkind (I) = N_Defining_Identifier and then Ekind (I) /= E_In_Parameter then Error_Pragma_Arg ("pragma% remote procedure with mode in only" , Arg1); end if; S := Next (S); end loop; Set_Is_Asynchronous (Nm); return; elsif Ekind (Nm) = E_Access_Subprogram_Type then N := Declaration_Node (Nm); if Nkind (N) = N_Full_Type_Declaration and then Nkind (Type_Definition (N)) = N_Access_Procedure_Definition then L := Parameter_Specifications (Type_Definition (N)); if not Present (L) then Set_Is_Asynchronous (Nm); return; end if; -- The formals should be of mode in E.4.1(7) S := First (L); while Present (S) loop I := Defining_Identifier (S); if Nkind (I) = N_Defining_Identifier and then Ekind (I) /= E_In_Parameter then Error_Pragma_Arg ("pragma% remote procedure with mode in only", Arg1); end if; S := Next (S); end loop; Set_Is_Asynchronous (Nm); else Error_Pragma_Arg ("pragma% remote access-to-procedure type only", Arg1); end if; else -- Access-to-class-wide type Set_Is_Asynchronous (Nm); end if; end Asynchronous; ------------ -- Atomic -- ------------ -- pragma Atomic (LOCAL_NAME); -- The old Ada 83 pragma Shared is treated like pragma Atomic -- Volatile shares the same circuit when Pragma_Atomic | Pragma_Shared | Pragma_Volatile => Atomic : declare E_Id : Node_Id := Expression (Arg1); E : Entity_Id; D : Node_Id; K : Node_Kind; begin Note_Feature (New_Representation_Pragmas, Loc); Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); if Etype (E_Id) = Any_Type then return; end if; E := Entity (E_Id); D := Declaration_Node (E); K := Nkind (D); if K = N_Object_Declaration or else K = N_Full_Type_Declaration or else (K = N_Component_Declaration and then Original_Record_Component (E) = E) then if Prag_Id /= Pragma_Volatile then Set_Is_Atomic (E); end if; Set_Is_Volatile (E); else Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); end if; end Atomic; ----------------------- -- Atomic_Components -- ----------------------- -- pragma Atomic_Components (array_LOCAL_NAME); -- This processing is shared by Volatile_Components when Pragma_Atomic_Components | Pragma_Volatile_Components => Atomic_Components : declare E_Id : Node_Id := Expression (Arg1); E : Entity_Id; D : Node_Id; K : Node_Kind; begin Note_Feature (New_Representation_Pragmas, Loc); Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); if Etype (E_Id) = Any_Type then return; end if; E := Entity (E_Id); D := Declaration_Node (E); K := Nkind (D); if (K = N_Full_Type_Declaration and then Is_Array_Type (E)) or else ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable) and then Nkind (D) = N_Object_Declaration and then Nkind (Object_Definition (D)) = N_Constrained_Array_Definition) then -- For consistency, always set these flags on the underlying -- base type if E is an object. The test above verifies that -- it is safe to do this. if Nkind (D) = N_Object_Declaration then E := Base_Type (Etype (E)); end if; if Prag_Id = Pragma_Atomic_Components then Set_Has_Atomic_Components (E); end if; Set_Has_Volatile_Components (E); else Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); end if; end Atomic_Components; -------------------- -- Attach_Handler -- -------------------- -- pragma Attach_Handler (handler_NAME, EXPRESSION); when Pragma_Attach_Handler => Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (2); Pragma_Not_Implemented; ---------------- -- Controlled -- ---------------- -- pragma Controlled (first_subtype_LOCAL_NAME); when Pragma_Controlled => Controlled : declare Arg : Node_Id; begin Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); Arg := Expression (Arg1); if not Is_Entity_Name (Arg) or else not Is_Access_Type (Entity (Arg)) then Error_Pragma_Arg ("pragma% requires access type", Arg1); else Set_Has_Pragma_Controlled (Entity (Arg)); end if; end Controlled; ---------------- -- Convention -- ---------------- -- pragma Convention ([Convention =>] convention_IDENTIFIER, -- [Entity =>] LOCAL_NAME); when Pragma_Convention => Convention : declare C : Convention_Id; E : Entity_Id; begin Note_Feature (New_Representation_Pragmas, Loc); Check_Ada_83_Warning; Check_Arg_Count (2); Process_Convention (C, E); end Convention; --------------- -- CPP_Class -- --------------- -- pragma CPP_Class ([Entity =>] LOCAL_NAME) when Pragma_CPP_Class => CPP_Class : declare Arg : Node_Id; Typ : Entity_Id; Default_DTC : Entity_Id := Empty; VTP_Type : constant Entity_Id := RTE (RE_Vtable_Ptr); C : Entity_Id; Tag_C : Entity_Id; begin Check_Ada_83_Warning; Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); Arg := Expression (Arg1); Analyze (Arg); if Etype (Arg) = Any_Type then return; end if; if not Is_Entity_Name (Arg) or else not Is_Type (Entity (Arg)) then Error_Pragma_Arg ("pragma% requires a type mark", Arg1); end if; Typ := Entity (Arg); if not Is_Record_Type (Typ) then Error_Pragma_Arg ("pragma% applicable to a record, " & "tagged record or record extension", Arg1); end if; Default_DTC := First_Component (Typ); while Present (Default_DTC) and then Etype (Default_DTC) /= VTP_Type loop Default_DTC := Next_Component (Default_DTC); end loop; if not Is_Tagged_Type (Typ) and then Present (Default_DTC) then Error_Pragma_Arg ("only tagged records can contain vtable pointers", Arg1); elsif Is_Tagged_Type (Typ) and then Typ = Root_Type (Typ) and then No (Default_DTC) then Error_Pragma_Arg ("a cpp_class must contain a vtable pointer", Arg1); else Set_Is_CPP_Class (Typ); Set_Is_Limited_Record (Typ); Set_Is_Tag (Default_DTC); Set_DT_Entry_Count (Default_DTC, No_Uint); if Typ = Root_Type (Typ) then -- Get rid of the _tag component which is only useful for -- regular tagged types Tag_C := Tag_Component (Typ); C := First_Entity (Typ); if C = Tag_C then Set_First_Entity (Typ, Next_Entity (Tag_C)); else while Next_Entity (C) /= Tag_C loop C := Next_Entity (C); end loop; Set_Next_Entity (C, Next_Entity (Tag_C)); end if; end if; end if; end CPP_Class; --------------------- -- CPP_Constructor -- --------------------- -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME); when Pragma_CPP_Constructor => CPP_Constructor : declare Id : Entity_Id; Def_Id : Entity_Id; begin Check_Ada_83_Warning; Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); Id := Expression (Arg1); Find_Program_Unit_Name (Id); -- If we did not find the name, we are done if Etype (Id) = Any_Type then return; end if; Def_Id := Entity (Id); if Ekind (Def_Id) = E_Function and then Is_Class_Wide_Type (Etype (Def_Id)) and then Is_CPP_Class (Etype (Etype (Def_Id))) then if Arg_Count >= 2 then Process_Interface_Name (Def_Id, Arg2, Arg3); end if; if No (Parameter_Specifications (Parent (Def_Id))) then Set_Has_Completion (Def_Id); Set_Is_Constructor (Def_Id); else Unimplemented (Arg1, "non-default constructors"); end if; else Error_Pragma_Arg ("pragma% requires function returning a cpp_class type", Arg1); end if; end CPP_Constructor; -------------------- -- CPP_Destructor -- -------------------- -- pragma CPP_Destructor ([Entity =>] LOCAL_NAME); when Pragma_CPP_Destructor => Check_Ada_83_Warning; Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); Pragma_Not_Implemented; ----------------- -- CPP_Virtual -- ----------------- -- pragma CPP_Virtual -- [Entity =>] LOCAL_NAME -- [ [Vtable_Ptr =>] LOCAL_NAME, -- [Position =>] static_integer_EXPRESSION]); when Pragma_CPP_Virtual => CPP_Virtual : declare Arg : Node_Id; Typ : Entity_Id; Subp : Entity_Id; VTP_Type : constant Entity_Id := RTE (RE_Vtable_Ptr); DTC : Entity_Id; V : Uint; begin Check_Ada_83_Warning; if Arg_Count = 3 then Check_Optional_Identifier (Arg2, Name_Vtable_Ptr); Check_Optional_Identifier (Arg3, Name_Entry_Count); else Check_Arg_Count (1); end if; Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); -- First argument must be a subprogram name Arg := Expression (Arg1); Find_Program_Unit_Name (Arg); if Etype (Arg) = Any_Type then return; else Subp := Entity (Arg); end if; if not (Is_Subprogram (Subp) and then Is_Dispatching_Operation (Subp)) then Error_Pragma_Arg ("pragma% must reference a primitive operation", Arg1); end if; Typ := Find_Dispatching_Type (Subp); -- If only one Argument defaults are : -- . DTC_Entity is the default Vtable pointer -- . DT_Position will be set at the freezing point if Arg_Count = 1 then Set_DTC_Entity (Subp, Tag_Component (Typ)); return; end if; -- Second argument is a component name of type Vtable_Ptr Arg := Expression (Arg2); if Nkind (Arg) /= N_Identifier then Error_Msg_NE ("must be a& component name", Arg, Typ); raise Pragma_Error; end if; DTC := First_Component (Typ); while Present (DTC) and then Chars (DTC) /= Chars (Arg) loop DTC := Next_Component (DTC); end loop; if No (DTC) then Error_Msg_NE ("must be a& component name", Arg, Typ); raise Pragma_Error; elsif Etype (DTC) /= VTP_Type then Wrong_Type (Arg, VTP_Type); return; end if; -- Third argument is an integer (DT_Position) Arg := Expression (Arg3); Analyze (Arg); Resolve (Arg, Any_Integer); if not Is_Static_Expression (Arg) then Error_Pragma_Arg ("third argument of pragma% must be a static expression", Arg3); else V := Expr_Value (Expression (Arg3)); if V <= 0 then Error_Pragma_Arg ("third argument of pragma% must be positive", Arg3); else Set_DTC_Entity (Subp, DTC); Set_DT_Position (Subp, V); end if; end if; end CPP_Virtual; ---------------- -- CPP_Vtable -- ---------------- -- pragma CPP_Vtable ( -- [Entity =>] LOCAL_NAME -- [Vtable_Ptr =>] LOCAL_NAME, -- [Entry_Count =>] static_integer_EXPRESSION); when Pragma_CPP_Vtable => CPP_Vtable : declare Arg : Node_Id; Typ : Entity_Id; Already_a_Tag : Boolean := False; Comp : Entity_Id := Empty; VTP_Type : constant Entity_Id := RTE (RE_Vtable_Ptr); DTC : Entity_Id; V : Uint; Elmt : Elmt_Id; begin Check_Ada_83_Warning; Check_Arg_Count (3); Check_Optional_Identifier (Arg1, Name_Entity); Check_Optional_Identifier (Arg2, Name_Vtable_Ptr); Check_Optional_Identifier (Arg3, Name_Entry_Count); Check_Arg_Is_Local_Name (Arg1); -- First argument is a record type name Arg := Expression (Arg1); Analyze (Arg); if Etype (Arg) = Any_Type then return; else Typ := Entity (Arg); end if; if not (Is_Type (Typ) and then Is_CPP_Class (Typ)) then Error_Pragma_Arg ("cpp_class type expected", Arg1); end if; -- Second argument is a component name of type Vtable_Ptr Arg := Expression (Arg2); if Nkind (Arg) /= N_Identifier then Error_Msg_NE ("must be a& component name", Arg, Typ); raise Pragma_Error; end if; DTC := First_Component (Typ); while Present (DTC) and then Chars (DTC) /= Chars (Arg) loop DTC := Next_Component (DTC); end loop; if No (DTC) then Error_Msg_NE ("must be a& component name", Arg, Typ); raise Pragma_Error; elsif Etype (DTC) /= VTP_Type then Wrong_Type (DTC, VTP_Type); return; -- If it is the first pragma Vtable, This becomes the default tag elsif (not Is_Tag (DTC)) and then DT_Entry_Count (Tag_Component (Typ)) = No_Uint then Set_Is_Tag (Tag_Component (Typ), False); Set_Is_Tag (DTC, True); Set_DT_Entry_Count (DTC, No_Uint); end if; -- Those pragmas must appear before any primitive operation -- definition (except inherited ones) otherwise the default -- may be wrong Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Elmt) loop if No (Alias (Node (Elmt))) then Error_Msg_Sloc := Sloc (Node (Elmt)); Error_Pragma ("pragma% must appear before this primitive operation"); end if; Elmt := Next_Elmt (Elmt); end loop; -- Third argument is an integer (DT_Entry_Count) Arg := Expression (Arg3); Analyze (Arg); Resolve (Arg, Any_Integer); if not Is_Static_Expression (Arg) then Error_Pragma_Arg ("entry count for pragma% must be a static expression", Arg3); else V := Expr_Value (Expression (Arg3)); if V <= 0 then Error_Pragma_Arg ("entry count for pragma% must be positive", Arg3); else Set_DT_Entry_Count (DTC, V); end if; end if; end CPP_Vtable; ----------- -- Debug -- ----------- when Pragma_Debug => Debug : begin Note_Feature (Implementation_Dependent_Pragmas, Loc); -- If we are not in debug mode then rewrite the pragma with -- a null statement and do not even analyze the pragma. if not Assertions_Enabled then Rewrite_Substitute_Tree (N, Make_Null_Statement (Loc)); -- If we are in debug mode, then rewrite the pragma with its -- corresponding procedure call, and then analyze the call. else Rewrite_Substitute_Tree (N, New_Copy (Debug_Statement (N))); Analyze (N); end if; end Debug; ------------------- -- Discard_Names -- ------------------- -- pragma Discard_Names [([On =>] LOCAL_NAME)]; when Pragma_Discard_Names => Discard_Names : declare E_Id : Node_Id; E : Entity_Id; begin Note_Feature (New_Representation_Pragmas, Loc); Check_Ada_83_Warning; -- Deal with configuration pragma case -- For now, ignored ??? if Arg_Count = 0 and then Is_Configuration_Pragma then return; -- Otherwise, check correct appropriate context else Check_Is_In_Decl_Part_Or_Package_Spec; -- For now, ignore the case of no parameter present ??? if Arg_Count = 0 then return; else Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_On); Check_Arg_Is_Local_Name (Arg1); E_Id := Expression (Arg1); if Etype (E_Id) = Any_Type then return; else E := Entity (E_Id); end if; if (Is_First_Subtype (E) and then (Is_Enumeration_Type (E) or else Is_Tagged_Type (E))) or else Ekind (E) = E_Exception then Set_Discard_Names (E); else Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); end if; end if; end if; end Discard_Names; --------------- -- Elaborate -- --------------- -- pragma Elaborate (library_unit_NAME {, library_unit_NAME}); when Pragma_Elaborate => Elaborate : declare Plist : List_Id; Parent_Node : Node_Id; Arg : Node_Id; Citem : Node_Id; begin -- Pragma must be in context items list of a compilation unit if not Is_List_Member (N) then Pragma_Misplaced; return; else Plist := List_Containing (N); Parent_Node := Parent (Plist); if Parent_Node = Empty or else Nkind (Parent_Node) /= N_Compilation_Unit or else Context_Items (Parent_Node) /= Plist then Pragma_Misplaced; return; end if; end if; -- In Ada 83 mode, there can be no items following it in the -- context list except other pragmas and implicit with clauses -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this -- placement rule does not apply. if Ada_83 and then Comes_From_Source (N) then Citem := Next (N); while Present (Citem) loop if Nkind (Citem) = N_Pragma or else (Nkind (Citem) = N_With_Clause and then Implicit_With (Citem)) then null; else Error_Pragma ("(Ada 83) pragma% must be at end of context clause"); end if; Citem := Next (Citem); end loop; end if; -- Finally, the arguments must all be units mentioned in a with -- clause in the same context clause. Note we already checked -- (in Par.Prag) that the arguments are either identifiers or Arg := Arg1; Outer : while Present (Arg) loop Citem := First (Plist); Inner : while Citem /= N loop if Nkind (Citem) = N_With_Clause and then Same_Name (Name (Citem), Expression (Arg)) then Set_Elaborate_Present (Citem, True); exit Inner; end if; Citem := Next (Citem); end loop Inner; if Citem = N then Error_Pragma_Arg ("Argument of pragma% is not with'ed unit", Arg); end if; Arg := Next (Arg); end loop Outer; end Elaborate; ------------------- -- Elaborate_All -- ------------------- when Pragma_Elaborate_All => Elaborate_All : declare Plist : List_Id; Parent_Node : Node_Id; Arg : Node_Id; Citem : Node_Id; begin -- Pragma must be in context items list of a compilation unit if not Is_List_Member (N) then Pragma_Misplaced; return; else Plist := List_Containing (N); Parent_Node := Parent (Plist); if Parent_Node = Empty or else Nkind (Parent_Node) /= N_Compilation_Unit or else Context_Items (Parent_Node) /= Plist then Pragma_Misplaced; return; end if; end if; -- Note: unlike pragma Elaborate, pragma Elaborate_All does not -- have to appear at the end of the context clause, but may -- appear mixed in with other items. -- Final check: the arguments must all be units mentioned in -- a with clause in the same context clause. Note that we -- already checked (in Par.Prag) that all the arguments are -- either identifiers or selected components. Arg := Arg1; Outr : while Present (Arg) loop Citem := First (Plist); Innr : while Citem /= N loop if Nkind (Citem) = N_With_Clause and then Same_Name (Name (Citem), Expression (Arg)) then Set_Elaborate_All_Present (Citem, True); exit Innr; end if; Citem := Next (Citem); end loop Innr; if Citem = N then Error_Pragma_Arg ("Argument of pragma% is not with'ed unit", Arg); end if; Arg := Next (Arg); end loop Outr; end Elaborate_All; -------------------- -- Elaborate_Body -- -------------------- when Pragma_Elaborate_Body => Elaborate_Body : declare Plist : List_Id; Cunit_Node : Node_Id; begin Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; Plist := List_Containing (N); Cunit_Node := Parent (Plist); -- Case of pragma appearing in declarative part. Only -- legal if it is in a package specification. if Nkind (Cunit_Node) /= N_Compilation_Unit then if Nkind (Cunit_Node) = N_Package_Specification then Cunit_Node := Parent (Parent (Cunit_Node)); else Pragma_Misplaced; return; end if; end if; Set_Elaborate_Body_Present (Cunit_Node, True); Set_Body_Required (Cunit_Node, True); end Elaborate_Body; ---------------------- -- Error_Monitoring -- ---------------------- when Pragma_Error_Monitoring => Error_Monitoring : declare procedure Monitoring_Off; -- Turn error monitoring mode off procedure Monitoring_Off is begin Error_Monitoring_On := False; if Monitored_Errors = 0 then Error_Pragma ("no errors in monitored region"); elsif Monitored_Message = Error_Name then Error_Pragma ("incorrect error message issued"); end if; end Monitoring_Off; begin Note_Feature (Implementation_Dependent_Pragmas, Loc); -- Error_Monitoring (ON) if Chars (Expression (Arg1)) = Name_On then if Error_Monitoring_On then Monitoring_Off; end if; Error_Monitoring_On := True; Monitored_Errors := 0; if Arg_Count = 2 then -- We need an entry in the names table for the given message -- since that's how Errout stores error text for messages. declare Msg : constant String_Id := Expr_Value_S (Expression (Arg2)); begin Name_Len := Natural (String_Length (Msg)); for J in 1 .. Name_Len loop Name_Buffer (J) := Get_Character (Get_String_Char (Msg, Int (J))); end loop; Monitored_Message := Name_Find; end; else Monitored_Message := No_Name; end if; -- Error_Monitoring (OFF) else Monitoring_Off; end if; end Error_Monitoring; ------------ -- Export -- ------------ when Pragma_Export => Export : declare C : Convention_Id; Def_Id : Entity_Id; begin Note_Feature (New_Representation_Pragmas, Loc); Process_Convention (C, Def_Id); if Arg_Count >= 3 then Process_Interface_Name (Def_Id, Arg3, Arg4); end if; if not Is_Public (Def_Id) then Error_Pragma_Arg ("internal entity cannot be exported", Arg2); end if; -- Should there be error tests on kind of entity here ??? Set_Is_Exported (Def_Id); end Export; ------------ -- Import -- ------------ when Pragma_Import | Pragma_Interface => Import : declare C : Convention_Id; Def_Id : Entity_Id; begin Note_Feature (New_Representation_Pragmas, Loc); Process_Convention (C, Def_Id); if Ekind (Def_Id) = E_Variable then -- Initialization is not allowed for imported variable -- The No_Location is used to mark the default initialization -- of access types -- Use of No_Location here is really ugly??? if Present (Expression (Parent (Def_Id))) and then Sloc (Expression (Parent (Def_Id))) /= No_Location then Error_Msg_Sloc := Sloc (Def_Id); Error_Pragma_Arg ("no initialization allowed for declaration of& #", Arg2); else Set_Is_Imported (Def_Id); Set_Is_Public (Def_Id); if Arg_Count >= 3 then Process_Interface_Name (Def_Id, Arg3, Arg4); end if; end if; elsif Is_Subprogram (Def_Id) or else Is_Generic_Subprogram (Def_Id) then -- If name is overloaded, pragma applies to all the -- denoted entities in the same declarative part. -- Ignore inherited subprograms, because the pragma will -- apply to the parent operation which is the one called. while Present (Def_Id) loop if Is_Overloadable (Def_Id) and then Present (Alias (Def_Id)) then null; -- What exactly is the following test for ??? elsif Parent (Get_Declaration_Node (Def_Id)) /= Parent (N) then exit; else Set_Is_Imported (Def_Id); -- If Import intrinsic, set intrinsic flag -- and verify that it is known as such. if C = Convention_Intrinsic then Set_Is_Intrinsic_Subprogram (Def_Id); Check_Intrinsic_Subprogram (Def_Id, Expression (Arg2)); end if; -- All interfaced procedures need an external -- symbol created for them since they are -- always referenced from another object file. Set_Is_Public (Def_Id); Set_Has_Completion (Def_Id); if Arg_Count >= 3 then Process_Interface_Name (Def_Id, Arg3, Arg4); end if; end if; Def_Id := Homonym (Def_Id); end loop; else Error_Pragma_Arg ("second argument of pragma% must be subprogram or variable", Arg2); end if; end Import; ------------ -- Inline -- ------------ when Pragma_Inline => Inline : declare Assoc : Node_Id; Decl : Node_Id; Subp_Id : Node_Id; Subp : Entity_Id; procedure Make_Inline (Subp : Entity_Id); -- Subp is the defining unit name of the subprogram -- declaration. Set the flag, as well as the flag in the -- corresponding boy, if there is one present. procedure Make_Inline (Subp : Entity_Id) is Kind : Entity_Kind := Ekind (Subp); begin if Etype (Subp) = Any_Type then return; -- The referenced entity must either be the enclosing entity, -- or an entity declared within the current open scope. elsif Present (Scope (Subp)) and then Scope (Subp) /= Current_Scope and then Subp /= Current_Scope then Pragma_Misplaced; return; end if; -- Processing for procedure, operator or function if Kind = E_Procedure or else Kind = E_Function or else Kind = E_Operator then Set_Is_Inlined (Subp, True); Decl := Parent (Parent (Subp)); if Nkind (Decl) = N_Subprogram_Declaration and then Present (Corresponding_Body (Decl)) then Set_Is_Inlined (Corresponding_Body (Decl), True); end if; -- Don't do anything for a generic procedure or generic -- function. The instance will be marked inlined as -- required during the compilation of the instance. elsif Kind = E_Generic_Procedure or else Kind = E_Generic_Function then null; -- Literals are by definition inlined. elsif Kind = E_Enumeration_Literal then null; -- Anything else is an error else Error_Pragma_Arg ("expect subprogram name for pragma%", Assoc); end if; end Make_Inline; begin Assoc := Arg1; while Present (Assoc) loop Subp_Id := Expression (Assoc); Analyze (Subp_Id); Subp := Entity (Subp_Id); if Subp = Any_Id then null; else Make_Inline (Subp); while Present (Homonym (Subp)) and then Scope (Homonym (Subp)) = Current_Scope loop Make_Inline (Homonym (Subp)); Subp := Homonym (Subp); end loop; end if; Assoc := Next (Assoc); end loop; end Inline; ---------------------- -- Inspection_Point -- ---------------------- -- pragma Inspection_Point [(object_NAME {, object_NAME})]; when Pragma_Inspection_Point => Inspection_Point : declare Arg : Node_Id; Exp : Node_Id; begin if Arg_Count < 2 then Check_Arg_Count (1); end if; Arg := Arg1; while Present (Arg) loop Exp := Expression (Arg); Analyze (Exp); if not Is_Entity_Name (Exp) or else (Ekind (Entity (Exp)) /= E_Variable and then Ekind (Entity (Exp)) /= E_Constant) then Error_Pragma_Arg ("object name required", Arg); end if; Arg := Next (Arg); end loop; end Inspection_Point; --------------- -- Interface -- --------------- -- Pragma Interface is processed by the same circuit as pragma -- Import (except that for Interface, the parser has verified -- that only two arguments are present, so the processing for -- the third and fourth arguments has no effect for Interface). -------------------- -- Interface_Name -- -------------------- when Pragma_Interface_Name => Interface_Name : declare Id : constant Node_Id := Expression (Arg1); Link_Name : constant Node_Id := Expression (Arg2); Proc_Def_Id : Entity_Id; begin Note_Feature (Implementation_Dependent_Pragmas, Loc); Analyze (Id); -- Remaining processing is needed only if we found the name. -- Check that name represents a subprogram for which a pragma -- Interface has been given. Then process the interface name. if Etype (Id) /= Any_Type then Proc_Def_Id := Entity (Id); if not Is_Subprogram (Proc_Def_Id) then Error_Pragma_Arg ("argument of pragma% is not subprogram", Arg1); elsif not Is_Imported (Proc_Def_Id) then Error_Pragma_Arg ("argument of pragma% is not imported subprogram", Arg1); else Process_Interface_Name (Proc_Def_Id, Arg2, Arg3); end if; end if; end Interface_Name; ----------------------- -- Interrupt_Handler -- ----------------------- when Pragma_Interrupt_Handler => Check_Ada_83_Warning; Check_Arg_Count (1); Check_No_Identifiers; Pragma_Not_Implemented; ------------------------ -- Interrupt_Priority -- ------------------------ -- pragma Interrupt_Priority [(EXPRESSION)]; when Pragma_Interrupt_Priority => Interrupt_Priority : declare P : constant Node_Id := Parent (N); begin Check_Ada_83_Warning; if Arg_Count /= 0 then Check_Arg_Count (1); Check_No_Identifiers; -- Set In_Default_Expression for per-object case??? Analyze (Expression (Arg1)); Resolve (Expression (Arg1), RTE (RE_Priority)); end if; if Nkind (P) /= N_Task_Definition and then Nkind (P) /= N_Protected_Definition then Pragma_Misplaced; return; elsif Has_Priority_Pragma (P) then Error_Pragma ("duplicate pragma% not allowed"); else Set_Has_Priority_Pragma (P, True); end if; end Interrupt_Priority; -------------------- -- Linker_Options -- -------------------- -- pragma Linker_Options [string_EXPRESSION] when Pragma_Linker_Options => Check_Ada_83_Warning; Check_Arg_Count (1); Check_No_Identifiers; Check_Static_String_Expr (Expression (Arg1)); Store_Linker_Option_String (Expr_Value_S (Expression (Arg1))); ---------- -- List -- ---------- -- There is nothing to do here, since we did all the processing -- for this pragma in Par.Prag (so that it works properly even in -- syntax only mode) when Pragma_List => null; -------------------- -- Locking_Policy -- -------------------- when Pragma_Locking_Policy => Check_Ada_83_Warning; Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_Locking_Policy (Arg1); ----------------------- -- Machine_Attribute -- ----------------------- -- pragma Machine_Attribute ( -- [Attribute_Name =>] static_string_EXPRESSION -- ,[Entity =>] LOCAL_NAME ); when Pragma_Machine_Attribute => Machine_Attribute : declare Attr_Nam : Node_Id; Id : Entity_Id; Def_Id : Entity_Id; begin Note_Feature (New_Representation_Pragmas, Loc); Check_Ada_83_Warning; Check_Arg_Count (2); Check_Arg_Is_Local_Name (Arg2); Check_Optional_Identifier (Arg1, Name_Attribute_Name); Check_Optional_Identifier (Arg2, Name_Entity); Attr_Nam := Expression (Arg1); Check_Static_String_Expr (Attr_Nam); Id := Expression (Arg2); Analyze (Id); Def_Id := Entity (Id); if not Is_Subprogram (Def_Id) then Error_Pragma ("pragma% not implemented for other than subprograms"); end if; Set_Has_Machine_Attribute (Def_Id, True); Set_Machine_Attribute (Def_Id, N); end Machine_Attribute; ----------------- -- Memory_Size -- ----------------- -- pragma Memory_Size (NUMERIC_LITERAL) when Pragma_Memory_Size => -- Memory size is simply ignored Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Integer_Literal (Arg1); ----------------------- -- Normalize_Scalars -- ----------------------- -- pragma Normalize_Scalars; when Pragma_Normalize_Scalars => Check_Ada_83_Warning; Check_Arg_Count (0); Pragma_Not_Implemented; -------------- -- Optimize -- -------------- -- The actual check for optimize is done in Gigi. Note that this -- pragma does not actually change the optimization setting, it -- simply checks that it is consistent with the pragma. when Pragma_Optimize => Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off); ---------- -- Pack -- ---------- -- pragma Pack (first_subtype_LOCAL_NAME); when Pragma_Pack => Pack : declare Assoc : Node_Id := Arg1; Type_Id : Node_Id := Expression (Assoc); Typ : Entity_Id; Ctyp : Entity_Id; begin Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); Find_Type (Type_Id); Typ := Entity (Type_Id); if Typ = Any_Type then return; elsif Scope (Typ) /= Current_Scope then Error_Pragma ("pragma% does not specify type in same declarative part"); -- Array type elsif Is_Array_Type (Typ) then Ctyp := Component_Type (Typ); -- Pragma only has an effect if component type is a scalar -- type with a size in the range 1..4. Also (temporary -- limitation) we do not implement pack for other than -- one dimensional arrays. if not Is_Scalar_Type (Ctyp) or else Esize (Ctyp) = 0 or else Esize (Ctyp) > 4 or else Number_Dimensions (Typ) > 1 then Error_Pragma ("?pragma% has no effect"); else Set_Is_Packed (Typ); Set_Is_Packed (Base_Type (Typ)); Set_Has_Non_Standard_Rep (Typ); end if; -- Record type elsif Is_Record_Type (Typ) then Set_Is_Packed (Typ); Set_Has_Non_Standard_Rep (Typ); -- Any other type is an error else Error_Pragma ("pragma% does not specify composite type"); end if; end Pack; ---------- -- Page -- ---------- -- There is nothing to do here, since we did all the processing -- for this pragma in Par.Prag (so that it works properly even in -- syntax only mode) when Pragma_Page => null; ------------------ -- Preelaborate -- ------------------ -- Set the flag Is_Preelaborated of program unit name entity when Pragma_Preelaborate => Preelaborate : declare Ent : Entity_Id; Pa : Node_Id := Parent (N); Pk : Node_Kind := Nkind (Pa); begin Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; Ent := Find_Lib_Unit_Name; -- This filters out pragmas inside generic parent then -- show up inside instantiation if Present (Ent) and then not (Pk = N_Package_Specification and then Present (Generic_Parent (Pa))) then if not Debug_Flag_U then Set_Is_Preelaborated (Ent); end if; end if; end Preelaborate; -------------- -- Priority -- -------------- -- pragma Priority (EXPRESSION); when Pragma_Priority => Priority : declare P : constant Node_Id := Parent (N); begin Check_No_Identifiers; Check_Arg_Count (1); Analyze (Expression (Arg1)); -- Subprogram case, must be static and in range System'Priority if Nkind (P) = N_Subprogram_Body then Resolve (Expression (Arg1), RTE (RE_Priority)); if not Is_Static_Expression (Expression (Arg1)) then Error_Pragma_Arg ("main subprogram priority is not static", Arg1); end if; Set_Main_Priority (Get_Sloc_Unit_Number (Loc), UI_To_Int (Expr_Value (Expression (Arg1)))); -- Task or Protected, must be of type Integer elsif Nkind (P) = N_Protected_Definition or else Nkind (P) = N_Task_Definition then Resolve (Expression (Arg1), Standard_Integer); -- Anything else is incorrect else Pragma_Misplaced; end if; if Has_Priority_Pragma (P) then Error_Pragma ("duplicate pragma% not allowed"); else Set_Has_Priority_Pragma (P, True); end if; end Priority; ---------- -- Pure -- ---------- -- Set the flag Is_Pure of program unit name entity when Pragma_Pure => Pure : declare Ey : Entity_Id; Pa : Node_Id := Parent (N); Pk : Node_Kind := Nkind (Pa); begin Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; Ey := Find_Lib_Unit_Name; -- This filters out pragmas inside generic parent then -- show up inside instantiation if Present (Ey) and then not (Pk = N_Package_Specification and then Present (Generic_Parent (Pa))) then if not Debug_Flag_U then Set_Is_Pure (Ey); end if; end if; end Pure; -------------------- -- Queuing_Policy -- -------------------- when Pragma_Queuing_Policy => Check_Ada_83_Warning; Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_Queuing_Policy (Arg1); Pragma_Not_Implemented; --------------------------- -- Remote_Call_Interface -- --------------------------- -- Set the flag Is_Remote_Call_Interface of program unit name entity when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare Ey : Entity_Id; Pa : Node_Id := Parent (N); Pk : Node_Kind := Nkind (Pa); begin Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; Ey := Find_Lib_Unit_Name; -- This filters out pragmas inside generic parent then -- show up inside instantiation if Present (Ey) and then not (Pk = N_Package_Specification and then Present (Generic_Parent (Pa))) then if not Debug_Flag_U then Set_Is_Remote_Call_Interface (Ey); end if; end if; end Remote_Call_Interface; ------------------ -- Remote_Types -- ------------------ -- Set the flag Is_Remote_Types of program unit name entity when Pragma_Remote_Types => Remote_Types : declare Ey : Entity_Id; Pa : Node_Id := Parent (N); Pk : Node_Kind := Nkind (Pa); begin Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; Ey := Find_Lib_Unit_Name; -- This filters out pragmas inside generic parent then -- show up inside instantiation if Present (Ey) and then not (Pk = N_Package_Specification and then Present (Generic_Parent (Pa))) then if not Debug_Flag_U then Set_Is_Remote_Types (Ey); end if; end if; end Remote_Types; ------------------ -- Restrictions -- ------------------ -- pragma Restrictions (RESTRICTION {, RESTRICTION}); -- RESTRICTION ::= -- restriction_IDENTIFIER -- | restriction_parameter_IDENTIFIER => EXPRESSION when Pragma_Restrictions => Check_Ada_83_Warning; Check_At_Least_One_Argument; Pragma_Not_Implemented; ---------------- -- Reviewable -- ---------------- -- pragma Reviewable; when Pragma_Reviewable => Check_Ada_83_Warning; Check_Arg_Count (0); ------------ -- Shared -- ------------ -- pragma Shared (LOCAL_NAME); -- Processing is shared with pragma Atomic -------------------- -- Shared_Passive -- -------------------- -- Set the flag Is_Shared_Passive of program unit name entity when Pragma_Shared_Passive => Shared_Passive : declare Ey : Entity_Id; Pa : Node_Id := Parent (N); Pk : Node_Kind := Nkind (Pa); begin Check_Ada_83_Warning; Check_Valid_Library_Unit_Pragma; Ey := Find_Lib_Unit_Name; -- This filters out pragmas inside generic parent then -- show up inside instantiation if Present (Ey) and then not (Pk = N_Package_Specification and then Present (Generic_Parent (Pa))) then if not Debug_Flag_U then Set_Is_Shared_Passive (Ey); end if; end if; end Shared_Passive; ---------------------- -- Source_Reference -- ---------------------- -- Nothing to do, all processing completed in Par.Prag, since we -- need the information for possible parser messages that are output when Pragma_Source_Reference => null; ------------------ -- Storage_Size -- ------------------ -- pragma Storage_Size (EXPRESSION); when Pragma_Storage_Size => Storage_Size : declare P : constant Node_Id := Parent (N); begin Check_No_Identifiers; Check_Arg_Count (1); -- Set In_Default_Expression for per-object case??? Analyze (Expression (Arg1)); Resolve (Expression (Arg1), Any_Integer); if Nkind (P) /= N_Task_Definition then Pragma_Misplaced; return; else if Has_Storage_Size_Pragma (P) then Error_Pragma ("duplicate pragma% not allowed"); else Set_Has_Storage_Size_Pragma (P, True); end if; end if; end Storage_Size; ------------------ -- Storage_Unit -- ------------------ -- pragma Storage_Unit (NUMERIC_LITERAL); -- Only permitted argument is System'Storage_Unit value when Pragma_Storage_Unit => Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Integer_Literal (Arg1); if Intval (Expression (Arg1)) /= UI_From_Int (Ttypes.System_Storage_Unit) then Error_Msg_Uint_1 := Intval (Expression (Arg1)); Error_Pragma_Arg ("the only allowed argument for pragma% is ^", Arg1); end if; -------------- -- Suppress -- -------------- when Pragma_Suppress => Process_Suppress_Unsuppress (True); ----------------- -- System_Name -- ----------------- -- pragma System_Name (DIRECT_NAME); -- Syntax check: one argument, which must be the identifier GNAT -- or the identifier GCC, no other identifiers are acceptable. when Pragma_System_Name => Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat); ----------------------------- -- Task_Dispatching_Policy -- ----------------------------- when Pragma_Task_Dispatching_Policy => Check_Ada_83_Warning; Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_Task_Dispatching_Policy (Arg1); ------------------------ -- Unimplemented_Unit -- ------------------------ -- pragma Unimplemented_Unit; -- Note: this only gives an error if we are generating code, -- or if we are in a generic library unit (where the pragma -- appears in the body, not in the spec). when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare Cunitent : Entity_Id := Cunit_Entity (Get_Sloc_Unit_Number (Loc)); Ent_Kind : Entity_Kind := Ekind (Cunitent); begin Check_Arg_Count (0); if Operating_Mode = Generate_Code or else Ent_Kind = E_Generic_Function or else Ent_Kind = E_Generic_Procedure or else Ent_Kind = E_Generic_Package then Error_Msg_N ("& is not implemented", Cunitent); raise Unrecoverable_Error; end if; end Unimplemented_Unit; ---------------- -- Unsuppress -- ---------------- when Pragma_Unsuppress => Process_Suppress_Unsuppress (False); -------------- -- Volatile -- -------------- -- pragma Volatile (LOCAL_NAME); -- Volatile is handled by the same circuit as Atomic ------------------------- -- Volatile_Components -- ------------------------- -- pragma Volatile_Components (array_LOCAL_NAME); -- Volatile is handled by the same circuit as Atomic_Components end case; exception when Pragma_Error => null; end Analyze_Pragma; --------------------------- -- Is_Generic_Subprogram -- --------------------------- function Is_Generic_Subprogram (Id : Entity_Id) return Boolean is begin return Ekind (Id) = E_Generic_Procedure or else Ekind (Id) = E_Generic_Function; end Is_Generic_Subprogram; ------------------------------ -- Is_Pragma_String_Literal -- ------------------------------ -- This function returns true if the corresponding pragma argument is -- a static string expression. These are the only cases in which string -- literals can appear as pragma arguments. We also allow a string -- literal as the first argument to pragma Assert (although it will -- of course always generate a type error). function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is Pragn : constant Node_Id := Parent (Par); Assoc : constant List_Id := Pragma_Argument_Associations (Pragn); Pname : constant Name_Id := Chars (Pragn); Argn : Natural; N : Node_Id; begin Argn := 1; N := First (Assoc); loop exit when N = Par; Argn := Argn + 1; N := Next (N); end loop; if Pname = Name_Assert then return True; elsif Pname = Name_Error_Monitoring then return Argn = 2; elsif Pname = Name_Export then return Argn > 2; elsif Pname = Name_Import then return Argn > 2; elsif Pname = Name_Interface_Name then return Argn > 1; elsif Pname = Name_Machine_Attribute then return Argn = 1; elsif Pname = Name_Source_Reference then return Argn = 2; else return False; end if; end Is_Pragma_String_Literal; end Sem_Prag;