X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_prag.adb;h=31799333edeb1a8646062d7fdb55fee07fa86eb4;hb=a34480d83b68142f300347d89d233f971438cf5d;hp=f62d6c8944a4206541eb137ac3f1189ce2811f41;hpb=b9f24e67ccca753dcd167db04c239929542477d2;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f62d6c8944a..31799333ede 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -35,6 +35,7 @@ with Checks; use Checks; with Csets; use Csets; with Debug; use Debug; with Einfo; use Einfo; +with Elists; use Elists; with Errout; use Errout; with Exp_Dist; use Exp_Dist; with Lib; use Lib; @@ -110,13 +111,13 @@ package body Sem_Prag is -- exported, and must refer to an entity in the current declarative -- part (as required by the rules for LOCAL_NAME). - -- The external linker name is designated by the External parameter - -- if given, or the Internal parameter if not (if there is no External + -- The external linker name is designated by the External parameter if + -- given, or the Internal parameter if not (if there is no External -- parameter, the External parameter is a copy of the Internal name). - -- If the External parameter is given as a string, then this string - -- is treated as an external name (exactly as though it had been given - -- as an External_Name parameter for a normal Import pragma). + -- If the External parameter is given as a string, then this string is + -- treated as an external name (exactly as though it had been given as an + -- External_Name parameter for a normal Import pragma). -- If the External parameter is given as an identifier (or there is no -- External parameter, so that the Internal identifier is used), then @@ -128,15 +129,15 @@ package body Sem_Prag is -- Import_xxx or Export_xxx pragmas override an external or link name -- specified in a previous Import or Export pragma. - -- Note: these and all other DEC-compatible GNAT pragmas allow full - -- use of named notation, following the standard rules for subprogram - -- calls, i.e. parameters can be given in any order if named notation - -- is used, and positional and named notation can be mixed, subject to - -- the rule that all positional parameters must appear first. + -- Note: these and all other DEC-compatible GNAT pragmas allow full use of + -- named notation, following the standard rules for subprogram calls, i.e. + -- parameters can be given in any order if named notation is used, and + -- positional and named notation can be mixed, subject to the rule that all + -- positional parameters must appear first. - -- Note: All these pragmas are implemented exactly following the DEC - -- design and implementation and are intended to be fully compatible - -- with the use of these pragmas in the DEC Ada compiler. + -- Note: All these pragmas are implemented exactly following the DEC design + -- and implementation and are intended to be fully compatible with the use + -- of these pragmas in the DEC Ada compiler. -------------------------------------------- -- Checking for Duplicated External Names -- @@ -146,9 +147,9 @@ package body Sem_Prag is -- name. The following table is used to diagnose this situation so that -- an appropriate warning can be issued. - -- The Node_Id stored is for the N_String_Literal node created to - -- hold the value of the external name. The Sloc of this node is - -- used to cross-reference the location of the duplication. + -- The Node_Id stored is for the N_String_Literal node created to hold + -- the value of the external name. The Sloc of this node is used to + -- cross-reference the location of the duplication. package Externals is new Table.Table ( Table_Component_Type => Node_Id, @@ -164,16 +165,16 @@ package body Sem_Prag is function Adjust_External_Name_Case (N : Node_Id) return Node_Id; -- This routine is used for possible casing adjustment of an explicit - -- external name supplied as a string literal (the node N), according - -- to the casing requirement of Opt.External_Name_Casing. If this is - -- set to As_Is, then the string literal is returned unchanged, but if - -- it is set to Uppercase or Lowercase, then a new string literal with - -- appropriate casing is constructed. + -- external name supplied as a string literal (the node N), according to + -- the casing requirement of Opt.External_Name_Casing. If this is set to + -- As_Is, then the string literal is returned unchanged, but if it is set + -- to Uppercase or Lowercase, then a new string literal with appropriate + -- casing is constructed. function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; - -- If Def_Id refers to a renamed subprogram, then the base subprogram - -- (the original one, following the renaming chain) is returned. - -- Otherwise the entity is returned unchanged. Should be in Einfo??? + -- If Def_Id refers to a renamed subprogram, then the base subprogram (the + -- original one, following the renaming chain) is returned. Otherwise the + -- entity is returned unchanged. Should be in Einfo??? function Get_Pragma_Arg (Arg : Node_Id) return Node_Id; -- All the routines that check pragma arguments take either a pragma @@ -190,9 +191,9 @@ package body Sem_Prag is -- the source, allowing convenient stepping to the point of interest. procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id); - -- Place semantic information on the argument of an Elaborate or - -- Elaborate_All pragma. Entity name for unit and its parents is - -- taken from item in previous with_clause that mentions the unit. + -- Place semantic information on the argument of an Elaborate/Elaborate_All + -- pragma. Entity name for unit and its parents is taken from item in + -- previous with_clause that mentions the unit. ------------------------------- -- Adjust_External_Name_Case -- @@ -250,14 +251,14 @@ package body Sem_Prag is Arg2 : constant Node_Id := Next (Arg1); begin - -- Install formals and push subprogram spec onto scope stack - -- so that we can see the formals from the pragma. + -- Install formals and push subprogram spec onto scope stack so that we + -- can see the formals from the pragma. Install_Formals (S); Push_Scope (S); - -- Preanalyze the boolean expression, we treat this as a - -- spec expression (i.e. similar to a default expression). + -- Preanalyze the boolean expression, we treat this as a spec expression + -- (i.e. similar to a default expression). Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); @@ -269,8 +270,8 @@ package body Sem_Prag is (Get_Pragma_Arg (Arg2), Standard_String); end if; - -- Remove the subprogram from the scope stack now that the - -- pre-analysis of the precondition/postcondition is done. + -- Remove the subprogram from the scope stack now that the pre-analysis + -- of the precondition/postcondition is done. End_Scope; end Analyze_PPC_In_Decl_Part; @@ -285,10 +286,10 @@ package body Sem_Prag is Prag_Id : Pragma_Id; Pragma_Exit : exception; - -- This exception is used to exit pragma processing completely. It - -- is used when an error is detected, and no further processing is - -- required. It is also used if an earlier error has left the tree - -- in a state where the pragma should not be processed. + -- This exception is used to exit pragma processing completely. It is + -- used when an error is detected, and no further processing is + -- required. It is also used if an earlier error has left the tree in + -- a state where the pragma should not be processed. Arg_Count : Nat; -- Number of pragma argument associations @@ -297,8 +298,8 @@ package body Sem_Prag is Arg2 : Node_Id; Arg3 : Node_Id; Arg4 : Node_Id; - -- First four pragma arguments (pragma argument association nodes, - -- or Empty if the corresponding argument does not exist). + -- First four pragma arguments (pragma argument association nodes, or + -- Empty if the corresponding argument does not exist). type Name_List is array (Natural range <>) of Name_Id; type Args_List is array (Natural range <>) of Node_Id; @@ -316,40 +317,40 @@ package body Sem_Prag is -- of 95 pragma. procedure Check_Arg_Count (Required : Nat); - -- Check argument count for pragma is equal to given parameter. - -- If not, then issue an error message and raise Pragma_Exit. + -- Check argument count for pragma is equal to given parameter. If not, + -- then issue an error message and raise Pragma_Exit. - -- Note: all routines whose name is Check_Arg_Is_xxx take an - -- argument Arg which can either be a pragma argument association, - -- in which case the check is applied to the expression of the - -- association or an expression directly. + -- Note: all routines whose name is Check_Arg_Is_xxx take an argument + -- Arg which can either be a pragma argument association, in which case + -- the check is applied to the expression of the association or an + -- expression directly. procedure Check_Arg_Is_External_Name (Arg : Node_Id); -- Check that an argument has the right form for an EXTERNAL_NAME - -- parameter of an extended import/export pragma. The rule is that - -- the name must be an identifier or string literal (in Ada 83 mode) - -- or a static string expression (in Ada 95 mode). + -- parameter of an extended import/export pragma. The rule is that the + -- name must be an identifier or string literal (in Ada 83 mode) or a + -- static string expression (in Ada 95 mode). procedure Check_Arg_Is_Identifier (Arg : Node_Id); -- Check the specified argument Arg to make sure that it is an -- identifier. If not give error and raise Pragma_Exit. procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it is an - -- integer literal. If not give error and raise Pragma_Exit. + -- Check the specified argument Arg to make sure that it is an integer + -- literal. If not give error and raise Pragma_Exit. procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id); - -- Check the specified argument Arg 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. In addition, the local - -- name is required to represent an entity at the library level. + -- Check the specified argument Arg 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. In addition, the local name is required + -- to represent an entity at the library level. procedure Check_Arg_Is_Local_Name (Arg : Node_Id); - -- Check the specified argument Arg 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. + -- Check the specified argument Arg 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 specified argument Arg to make sure that it is a valid @@ -368,20 +369,20 @@ package body Sem_Prag is procedure Check_Arg_Is_Static_Expression (Arg : Node_Id; - Typ : Entity_Id); + Typ : Entity_Id := Empty); -- Check the specified argument Arg to make sure that it is a static -- expression of the given type (i.e. it will be analyzed and resolved -- using this type, which can be any valid argument to Resolve, e.g. - -- Any_Integer is OK). If not, given error and raise Pragma_Exit. + -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If + -- Typ is left Empty, then any static expression is allowed. procedure Check_Arg_Is_String_Literal (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it is a - -- string literal. If not give error and raise Pragma_Exit + -- Check the specified argument Arg to make sure that it is a string + -- literal. If not give error and raise Pragma_Exit procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it is a valid - -- valid task dispatching policy name. If not give error and raise - -- Pragma_Exit. + -- Check the specified argument Arg to make sure that it is a valid task + -- dispatching policy name. If not give error and raise Pragma_Exit. procedure Check_Arg_Order (Names : Name_List); -- Checks for an instance of two arguments with identifiers for the @@ -399,22 +400,22 @@ package body Sem_Prag is -- constrained subtypes, and for restrictions on finalizable components. procedure Check_Duplicated_Export_Name (Nam : Node_Id); - -- Nam is an N_String_Literal node containing the external name set - -- by an Import or Export pragma (or extended Import or Export pragma). - -- This procedure checks for possible duplications if this is the - -- export case, and if found, issues an appropriate error message. + -- Nam is an N_String_Literal node containing the external name set by + -- an Import or Export pragma (or extended Import or Export pragma). + -- This procedure checks for possible duplications if this is the export + -- case, and if found, issues an appropriate error message. procedure Check_First_Subtype (Arg : Node_Id); - -- Checks that Arg, whose expression is an entity name referencing - -- a subtype, does not reference a type that is not a first subtype. + -- Checks that Arg, whose expression is an entity name referencing a + -- subtype, does not reference a type that is not a first subtype. procedure Check_In_Main_Program; -- Common checks for pragmas that appear within a main program -- (Priority, Main_Storage, Time_Slice, Relative_Deadline). procedure Check_Interrupt_Or_Attach_Handler; - -- Common processing for first argument of pragma Interrupt_Handler - -- or pragma Attach_Handler. + -- Common processing for first argument of pragma Interrupt_Handler or + -- pragma Attach_Handler. procedure Check_Is_In_Decl_Part_Or_Package_Spec; -- Check that pragma appears in a declarative part, or in a package @@ -595,30 +596,32 @@ package body Sem_Prag is procedure Process_Compile_Time_Warning_Or_Error; -- Common processing for Compile_Time_Error and Compile_Time_Warning - procedure Process_Convention (C : out Convention_Id; E : out Entity_Id); + procedure Process_Convention + (C : out Convention_Id; + Ent : out Entity_Id); -- Common processing 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. + -- C is the convention, Ent is the referenced entity. procedure Process_Extended_Import_Export_Exception_Pragma (Arg_Internal : Node_Id; Arg_External : Node_Id; Arg_Form : Node_Id; Arg_Code : Node_Id); - -- Common processing for the pragmas Import/Export_Exception. - -- The three arguments correspond to the three named parameters of - -- the pragma. An argument is empty if the corresponding parameter - -- is not present in the pragma. + -- Common processing for the pragmas Import/Export_Exception. The three + -- arguments correspond to the three named parameters of the pragma. An + -- argument is empty if the corresponding parameter is not present in + -- the pragma. procedure Process_Extended_Import_Export_Object_Pragma (Arg_Internal : Node_Id; Arg_External : Node_Id; Arg_Size : Node_Id); - -- Common processing for the pragmas Import/Export_Object. - -- The three arguments correspond to the three named parameters - -- of the pragmas. An argument is empty if the corresponding - -- parameter is not present in the pragma. + -- Common processing for the pragmas Import/Export_Object. The three + -- arguments correspond to the three named parameters of the pragmas. An + -- argument is empty if the corresponding parameter is not present in + -- the pragma. procedure Process_Extended_Import_Export_Internal_Arg (Arg_Internal : Node_Id := Empty); @@ -636,12 +639,11 @@ package body Sem_Prag is Arg_Mechanism : Node_Id; Arg_Result_Mechanism : Node_Id := Empty; Arg_First_Optional_Parameter : Node_Id := Empty); - -- Common processing for all extended Import and Export pragmas - -- applying to subprograms. The caller omits any arguments that do - -- not apply to the pragma in question (for example, Arg_Result_Type - -- can be non-Empty only in the Import_Function and Export_Function - -- cases). The argument names correspond to the allowed pragma - -- association identifiers. + -- Common processing for all extended Import and Export pragmas applying + -- to subprograms. The caller omits any arguments that do not apply to + -- the pragma in question (for example, Arg_Result_Type can be non-Empty + -- only in the Import_Function and Export_Function cases). The argument + -- names correspond to the allowed pragma association identifiers. procedure Process_Generic_List; -- Common processing for Share_Generic and Inline_Generic @@ -651,8 +653,8 @@ package body Sem_Prag is procedure Process_Inline (Active : Boolean); -- Common processing for Inline and Inline_Always. The parameter - -- indicates if the inline pragma is active, i.e. if it should - -- actually cause inlining to occur. + -- indicates if the inline pragma is active, i.e. if it should actually + -- cause inlining to occur. procedure Process_Interface_Name (Subprogram_Def : Entity_Id; @@ -661,12 +663,12 @@ package body Sem_Prag is -- 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. - -- If neither Ext_Arg nor Link_Arg is present, the interface name - -- is set to the default from the subprogram name. + -- 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. If neither Ext_Arg + -- nor Link_Arg is present, the interface name is set to the default + -- from the subprogram name. procedure Process_Interrupt_Or_Attach_Handler; -- Common processing for Interrupt and Attach_Handler pragmas @@ -711,10 +713,10 @@ package body Sem_Prag is -- set appropriately. procedure Set_Ravenscar_Profile (N : Node_Id); - -- Activate the set of configuration pragmas and restrictions that - -- make up the Ravenscar Profile. N is the corresponding pragma - -- node, which is used for error messages on any constructs - -- that violate the profile. + -- Activate the set of configuration pragmas and restrictions that make + -- up the Ravenscar Profile. N is the corresponding pragma node, which + -- is used for error messages on any constructs that violate the + -- profile. --------------------- -- Ada_2005_Pragma -- @@ -968,12 +970,16 @@ package body Sem_Prag is procedure Check_Arg_Is_Static_Expression (Arg : Node_Id; - Typ : Entity_Id) + Typ : Entity_Id := Empty) is Argx : constant Node_Id := Get_Pragma_Arg (Arg); begin - Analyze_And_Resolve (Argx, Typ); + if Present (Typ) then + Analyze_And_Resolve (Argx, Typ); + else + Analyze_And_Resolve (Argx); + end if; if Is_OK_Static_Expression (Argx) then return; @@ -981,19 +987,19 @@ package body Sem_Prag is elsif Etype (Argx) = Any_Type then raise Pragma_Exit; - -- An interesting special case, if we have a string literal and - -- we are in Ada 83 mode, then we allow it even though it will - -- not be flagged as static. This allows the use of Ada 95 - -- pragmas like Import in Ada 83 mode. They will of course be - -- flagged with warnings as usual, but will not cause errors. + -- An interesting special case, if we have a string literal and we + -- are in Ada 83 mode, then we allow it even though it will not be + -- flagged as static. This allows the use of Ada 95 pragmas like + -- Import in Ada 83 mode. They will of course be flagged with + -- warnings as usual, but will not cause errors. elsif Ada_Version = Ada_83 and then Nkind (Argx) = N_String_Literal then return; - -- Static expression that raises Constraint_Error. This has - -- already been flagged, so just exit from pragma processing. + -- Static expression that raises Constraint_Error. This has already + -- been flagged, so just exit from pragma processing. elsif Is_Static_Expression (Argx) then raise Pragma_Exit; @@ -1148,6 +1154,14 @@ package body Sem_Prag is String_Val : constant String_Id := Strval (Nam); begin + -- We allow duplicated export names in CIL, as they are always + -- enclosed in a namespace that differentiates them, and overloaded + -- entities are supported by the VM. + + if VM_Target = CLI_Target then + return; + end if; + -- We are only interested in the export case, and in the case of -- generics, it is the instance, not the template, that is the -- problem (the template will generate a warning in any case). @@ -1269,10 +1283,9 @@ package body Sem_Prag is 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 + elsif Nkind_In (P, N_Package_Specification, + N_Block_Statement) + then return; -- Note: the following tests seem a little peculiar, because @@ -1281,10 +1294,10 @@ package body Sem_Prag is -- 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 + elsif Nkind_In (P, N_Subprogram_Body, + N_Package_Body, + N_Task_Body, + N_Entry_Body) then return; end if; @@ -1383,10 +1396,7 @@ package body Sem_Prag is -- the end of the package declarations (for details, see -- Analyze_Package_Specification.Analyze_PPCs). - if Ekind (Scope (S)) /= E_Package - and then - Ekind (Scope (S)) /= E_Generic_Package - then + if not Is_Package_Or_Generic_Package (Scope (S)) then Analyze_PPC_In_Decl_Part (N, S); end if; @@ -1410,7 +1420,7 @@ package body Sem_Prag is -- Record whether pragma is enabled - Set_PPC_Enabled (N, Check_Enabled (Pname)); + Set_Pragma_Enabled (N, Check_Enabled (Pname)); -- If we are within an inlined body, the legality of the pragma -- has been checked already. @@ -1425,7 +1435,18 @@ package body Sem_Prag is P := N; while Present (Prev (P)) loop P := Prev (P); - PO := Original_Node (P); + + -- If the previous node is a generic subprogram, do not go to to + -- the original node, which is the unanalyzed tree: we need to + -- attach the pre/postconditions to the analyzed version at this + -- point. They get propagated to the original tree when analyzing + -- the corresponding body. + + if Nkind (P) not in N_Generic_Declaration then + PO := Original_Node (P); + else + PO := P; + end if; -- Skip past prior pragma @@ -1445,13 +1466,15 @@ package body Sem_Prag is end if; end loop; - -- If we fall through loop, pragma is at start of list, so see if - -- it is at the start of declarations of a subprogram body. + -- If we fall through loop, pragma is at start of list, so see if it + -- is at the start of declarations of a subprogram body. if Nkind (Parent (N)) = N_Subprogram_Body and then List_Containing (N) = Declarations (Parent (N)) then - if Operating_Mode /= Generate_Code then + if Operating_Mode /= Generate_Code + or else Inside_A_Generic + then -- Analyze expression in pragma, for correctness -- and for ASIS use. @@ -1480,8 +1503,8 @@ package body Sem_Prag is ----------------------------- -- Note: for convenience in writing this procedure, in addition to - -- the officially (i.e. by spec) allowed argument which is always - -- a constraint, it also allows ranges and discriminant associations. + -- the officially (i.e. by spec) allowed argument which is always a + -- constraint, it also allows ranges and discriminant associations. -- Above is not clear ??? procedure Check_Static_Constraint (Constr : Node_Id) is @@ -1574,9 +1597,9 @@ package body Sem_Prag is if Parent_Node = Empty then Pragma_Misplaced; - -- Case of pragma appearing after a compilation unit. In this - -- case it must have an argument with the corresponding name - -- and must be part of the following pragmas of its parent. + -- Case of pragma appearing after a compilation unit. In this case + -- it must have an argument with the corresponding name and must + -- be part of the following pragmas of its parent. elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then if Plist /= Pragmas_After (Parent_Node) then @@ -1960,7 +1983,8 @@ package body Sem_Prag is (Chars (Arg), Names (Index1)) then Error_Msg_Name_1 := Names (Index1); - Error_Msg_N ("\possible misspelling of%", Arg); + Error_Msg_N -- CODEFIX + ("\possible misspelling of%", Arg); exit; end if; end loop; @@ -2194,12 +2218,12 @@ package body Sem_Prag is Set_Has_Delayed_Freeze (E); end if; - -- An interesting improvement here. If an object of type X - -- is declared atomic, and the type X is not atomic, that's - -- a pity, since it may not have appropriate alignment etc. - -- We can rescue this in the special case where the object - -- and type are in the same unit by just setting the type - -- as atomic, so that the back end will process it as atomic. + -- An interesting improvement here. If an object of type X is + -- declared atomic, and the type X is not atomic, that's a + -- pity, since it may not have appropriate alignment etc. We + -- can rescue this in the special case where the object and + -- type are in the same unit by just setting the type as + -- atomic, so that the back end will process it as atomic. Utyp := Underlying_Type (Etype (E)); @@ -2261,17 +2285,17 @@ package body Sem_Prag is -- warning, even though it is not in the main unit. begin - -- Loop through segments of message separated by line - -- feeds. We output these segments as separate messages - -- with continuation marks for all but the first. + -- Loop through segments of message separated by line feeds. + -- We output these segments as separate messages with + -- continuation marks for all but the first. Cont := False; Ptr := 1; loop Error_Msg_Strlen := 0; - -- Loop to copy characters from argument to error - -- message string buffer. + -- Loop to copy characters from argument to error message + -- string buffer. loop exit when Ptr > Len; @@ -2333,10 +2357,11 @@ package body Sem_Prag is ------------------------ procedure Process_Convention - (C : out Convention_Id; - E : out Entity_Id) + (C : out Convention_Id; + Ent : out Entity_Id) is Id : Node_Id; + E : Entity_Id; E1 : Entity_Id; Cname : Name_Id; Comp_Unit : Unit_Number_Type; @@ -2379,9 +2404,8 @@ package body Sem_Prag is Set_Has_Convention_Pragma (Underlying_Type (E), True); end if; - -- A class-wide type should inherit the convention of - -- the specific root type (although this isn't specified - -- clearly by the RM). + -- A class-wide type should inherit the convention of the specific + -- root type (although this isn't specified clearly by the RM). if Is_Type (E) and then Present (Class_Wide_Type (E)) then Set_Convention (Class_Wide_Type (E), C); @@ -2406,9 +2430,9 @@ package body Sem_Prag is end if; end if; - -- If the entity is a derived boolean type, check for the - -- special case of convention C, C++, or Fortran, where we - -- consider any nonzero value to represent true. + -- If the entity is a derived boolean type, check for the special + -- case of convention C, C++, or Fortran, where we consider any + -- nonzero value to represent true. if Is_Discrete_Type (E) and then Root_Type (Etype (E)) = Standard_Boolean @@ -2431,9 +2455,8 @@ package body Sem_Prag is Check_Arg_Is_Identifier (Arg1); Cname := Chars (Expression (Arg1)); - -- C_Pass_By_Copy is treated as a synonym for convention C - -- (this is tested again below to set the critical flag) - + -- C_Pass_By_Copy is treated as a synonym for convention C (this is + -- tested again below to set the critical flag). if Cname = Name_C_Pass_By_Copy then C := Convention_C; @@ -2470,6 +2493,10 @@ package body Sem_Prag is E := Entity (Id); + -- Set entity to return + + Ent := E; + -- Go to renamed subprogram if present, since convention applies to -- the actual renamed entity, not to the renaming entity. If the -- subprogram is inherited, go to parent subprogram. @@ -2482,14 +2509,20 @@ package body Sem_Prag is then if Scope (E) /= Scope (Alias (E)) then Error_Pragma_Ref - ("cannot apply pragma% to non-local renaming&#", E); + ("cannot apply pragma% to non-local entity&#", E); end if; + E := Alias (E); - elsif Nkind (Parent (E)) = N_Full_Type_Declaration + elsif Nkind_In (Parent (E), N_Full_Type_Declaration, + N_Private_Extension_Declaration) and then Scope (E) = Scope (Alias (E)) then E := Alias (E); + + -- Return the parent subprogram the entity was inherited from + + Ent := E; end if; end if; @@ -2603,30 +2636,34 @@ package body Sem_Prag is Generate_Reference (E, Id, 'b'); end if; - E1 := E; + -- Loop through the homonyms of the pragma argument's entity + + E1 := Ent; loop E1 := Homonym (E1); exit when No (E1) or else Scope (E1) /= Current_Scope; - -- Do not set the pragma on inherited operations or on - -- formal subprograms. + -- Do not set the pragma on inherited operations or on formal + -- subprograms. if Comes_From_Source (E1) and then Comp_Unit = Get_Source_Unit (E1) and then not Is_Formal_Subprogram (E1) and then Nkind (Original_Node (Parent (E1))) /= - N_Full_Type_Declaration + N_Full_Type_Declaration then if Present (Alias (E1)) and then Scope (E1) /= Scope (Alias (E1)) then Error_Pragma_Ref - ("cannot apply pragma% to non-local renaming&#", E1); + ("cannot apply pragma% to non-local entity& declared#", + E1); end if; + Set_Convention_From_Pragma (E1); if Prag_Id = Pragma_Import then - Generate_Reference (E, Id, 'b'); + Generate_Reference (E1, Id, 'b'); end if; end if; end loop; @@ -2787,8 +2824,7 @@ package body Sem_Prag is end if; if Warn_On_Export_Import and then Is_Exported (Def_Id) then - Error_Msg_N - ("?duplicate Export_Object pragma", N); + Error_Msg_N ("?duplicate Export_Object pragma", N); else Set_Exported (Def_Id, Arg_Internal); end if; @@ -2828,8 +2864,8 @@ package body Sem_Prag is ("?duplicate Import_Object pragma", N); -- Check for explicit initialization present. Note that an - -- initialization that generated by the code generator, e.g. - -- for an access type, does not count here. + -- initialization generated by the code generator, e.g. for an + -- access type, does not count here. elsif Present (Expression (Parent (Def_Id))) and then @@ -2871,10 +2907,10 @@ package body Sem_Prag is function Same_Base_Type (Ptype : Node_Id; Formal : Entity_Id) return Boolean; - -- Determines if Ptype references the type of Formal. Note that - -- only the base types need to match according to the spec. Ptype - -- here is the argument from the pragma, which is either a type - -- name, or an access attribute. + -- Determines if Ptype references the type of Formal. Note that only + -- the base types need to match according to the spec. Ptype here is + -- the argument from the pragma, which is either a type name, or an + -- access attribute. -------------------- -- Same_Base_Type -- @@ -2903,8 +2939,8 @@ package body Sem_Prag is end if; -- We have a match if the corresponding argument is of an - -- anonymous access type, and its designated type matches - -- the type of the prefix of the access attribute + -- anonymous access type, and its designated type matches the + -- type of the prefix of the access attribute return Ekind (Ftyp) = E_Anonymous_Access_Type and then Base_Type (Entity (Pref)) = @@ -2921,8 +2957,8 @@ package body Sem_Prag is raise Pragma_Exit; end if; - -- We have a match if the corresponding argument is of - -- the type given in the pragma (comparing base types) + -- We have a match if the corresponding argument is of the type + -- given in the pragma (comparing base types) return Base_Type (Entity (Ptype)) = Ftyp; end if; @@ -2955,9 +2991,8 @@ package body Sem_Prag is -- Pragma cannot apply to subprogram body if Is_Subprogram (Def_Id) - and then - Nkind (Parent - (Declaration_Node (Def_Id))) = N_Subprogram_Body + and then Nkind (Parent (Declaration_Node (Def_Id))) = + N_Subprogram_Body then Error_Pragma ("pragma% requires separate spec" @@ -3088,7 +3123,7 @@ package body Sem_Prag is return; end if; - -- Import pragmas must be be for imported entities + -- Import pragmas must be for imported entities if Prag_Id = Pragma_Import_Function or else @@ -3097,7 +3132,7 @@ package body Sem_Prag is Prag_Id = Pragma_Import_Valued_Procedure then if not Is_Imported (Ent) then - Error_Pragma + Error_Pragma -- CODEFIX??? ("pragma Import or Interface must precede pragma%"); end if; @@ -3127,12 +3162,10 @@ package body Sem_Prag is Formal := First_Formal (Ent); if No (Formal) then - Error_Pragma - ("at least one parameter required for pragma%"); + Error_Pragma ("at least one parameter required for pragma%"); elsif Ekind (Formal) /= E_Out_Parameter then - Error_Pragma - ("first parameter must have mode out for pragma%"); + Error_Pragma ("first parameter must have mode out for pragma%"); else Set_Is_Valued_Procedure (Ent); @@ -3387,7 +3420,7 @@ package body Sem_Prag is Process_Interface_Name (Def_Id, Arg3, Arg4); -- Note that we do not set Is_Public here. That's because we - -- only want to set if if there is no address clause, and we + -- only want to set it if there is no address clause, and we -- don't know that yet, so we delay that processing till -- freeze time. @@ -3428,16 +3461,16 @@ package body Sem_Prag is then null; - -- If it is not a subprogram, it must be in an outer - -- scope and pragma does not apply. + -- If it is not a subprogram, it must be in an outer scope and + -- pragma does not apply. elsif not Is_Subprogram (Def_Id) and then not Is_Generic_Subprogram (Def_Id) then null; - -- Verify that the homonym is in the same declarative - -- part (not just the same scope). + -- Verify that the homonym is in the same declarative part (not + -- just the same scope). elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N) and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux @@ -3447,6 +3480,17 @@ package body Sem_Prag is else Set_Imported (Def_Id); + -- Reject an Import applied to an abstract subprogram + + if Is_Subprogram (Def_Id) + and then Is_Abstract_Subprogram (Def_Id) + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Msg_NE + ("cannot import abstract subprogram& declared#", + Arg2, Def_Id); + end if; + -- Special processing for Convention_Intrinsic if C = Convention_Intrinsic then @@ -3468,24 +3512,24 @@ package body Sem_Prag is Set_Is_Intrinsic_Subprogram (Def_Id); - -- If no external name is present, then check that - -- this is a valid intrinsic subprogram. If an external - -- name is present, then this is handled by the back end. + -- If no external name is present, then check that this + -- is a valid intrinsic subprogram. If an external name + -- is present, then this is handled by the back end. if No (Arg3) then Check_Intrinsic_Subprogram (Def_Id, Expression (Arg2)); end if; end if; - -- All interfaced procedures need an external symbol - -- created for them since they are always referenced - -- from another object file. + -- All interfaced procedures need an external symbol created + -- for them since they are always referenced from another + -- object file. Set_Is_Public (Def_Id); -- Verify that the subprogram does not have a completion - -- through a renaming declaration. For other completions - -- the pragma appears as a too late representation. + -- through a renaming declaration. For other completions the + -- pragma appears as a too late representation. declare Decl : constant Node_Id := Unit_Declaration_Node (Def_Id); @@ -3494,10 +3538,8 @@ package body Sem_Prag is if Present (Decl) and then Nkind (Decl) = N_Subprogram_Declaration and then Present (Corresponding_Body (Decl)) - and then - Nkind - (Unit_Declaration_Node - (Corresponding_Body (Decl))) = + and then Nkind (Unit_Declaration_Node + (Corresponding_Body (Decl))) = N_Subprogram_Renaming_Declaration then Error_Msg_Sloc := Sloc (Def_Id); @@ -3525,15 +3567,15 @@ package body Sem_Prag is end loop; -- When the convention is Java or CIL, we also allow Import to be - -- given for packages, generic packages, exceptions, and record - -- components. + -- given for packages, generic packages, exceptions, record + -- components, and access to subprograms. elsif (C = Convention_Java or else C = Convention_CIL) and then - (Ekind (Def_Id) = E_Package - or else Ekind (Def_Id) = E_Generic_Package - or else Ekind (Def_Id) = E_Exception - or else Nkind (Parent (Def_Id)) = N_Component_Declaration) + (Is_Package_Or_Generic_Package (Def_Id) + or else Ekind (Def_Id) = E_Exception + or else Ekind (Def_Id) = E_Access_Subprogram_Type + or else Nkind (Parent (Def_Id)) = N_Component_Declaration) then Set_Imported (Def_Id); Set_Is_Public (Def_Id); @@ -3544,40 +3586,77 @@ package body Sem_Prag is elsif Is_Record_Type (Def_Id) and then C = Convention_CPP then - if not Is_Tagged_Type (Def_Id) then - Error_Msg_Sloc := Sloc (Def_Id); - Error_Pragma_Arg ("imported 'C'P'P type must be tagged", Arg2); + -- Types treated as CPP classes are treated as limited, but we + -- don't require them to be declared this way. A warning is + -- issued to encourage the user to declare them as limited. + -- This is not an error, for compatibility reasons, because + -- these types have been supported this way for some time. - else - -- Types treated as CPP classes are treated as limited, but we - -- don't require them to be declared this way. A warning is - -- issued to encourage the user to declare them as limited. - -- This is not an error, for compatibility reasons, because - -- these types have been supported this way for some time. + if not Is_Limited_Type (Def_Id) then + Error_Msg_N + ("imported 'C'P'P type should be " & + "explicitly declared limited?", + Get_Pragma_Arg (Arg2)); + Error_Msg_N + ("\type will be considered limited", + Get_Pragma_Arg (Arg2)); + end if; - if not Is_Limited_Type (Def_Id) then - Error_Msg_N - ("imported 'C'P'P type should be " & - "explicitly declared limited?", - Get_Pragma_Arg (Arg2)); - Error_Msg_N - ("\type will be considered limited", - Get_Pragma_Arg (Arg2)); - end if; + Set_Is_CPP_Class (Def_Id); + Set_Is_Limited_Record (Def_Id); - Set_Is_CPP_Class (Def_Id); - Set_Is_Limited_Record (Def_Id); + -- Imported CPP types must not have discriminants (because C++ + -- classes do not have discriminants). + + if Has_Discriminants (Def_Id) then + Error_Msg_N + ("imported 'C'P'P type cannot have discriminants", + First (Discriminant_Specifications + (Declaration_Node (Def_Id)))); end if; + -- Components of imported CPP types must not have default + -- expressions because the constructor (if any) is on the + -- C++ side. + + declare + Tdef : constant Node_Id := + Type_Definition (Declaration_Node (Def_Id)); + Clist : Node_Id; + Comp : Node_Id; + + begin + if Nkind (Tdef) = N_Record_Definition then + Clist := Component_List (Tdef); + + else + pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); + Clist := Component_List (Record_Extension_Part (Tdef)); + end if; + + if Present (Clist) then + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + if Present (Expression (Comp)) then + Error_Msg_N + ("component of imported 'C'P'P type cannot have" & + " default expression", Expression (Comp)); + end if; + + Next (Comp); + end loop; + end if; + end; + else Error_Pragma_Arg ("second argument of pragma% must be object or subprogram", Arg2); end if; - -- If this pragma applies to a compilation unit, then the unit, - -- which is a subprogram, does not require (or allow) a body. - -- We also do not need to elaborate imported procedures. + -- If this pragma applies to a compilation unit, then the unit, which + -- is a subprogram, does not require (or allow) a body. We also do + -- not need to elaborate imported procedures. if Nkind (Parent (N)) = N_Compilation_Unit_Aux then declare @@ -3601,9 +3680,9 @@ package body Sem_Prag is Effective : Boolean := False; 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 body, if there is one present. + -- Subp is the defining unit name of the subprogram declaration. Set + -- the flag, as well as the flag in the corresponding body, if there + -- is one present. procedure Set_Inline_Flags (Subp : Entity_Id); -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also @@ -3643,9 +3722,9 @@ package body Sem_Prag is Error_Msg_N ("pragma appears too late, ignored?", N); return True; - -- If the subprogram is a renaming as body, the body is - -- just a call to the renamed subprogram, and inlining is - -- trivially possible. + -- If the subprogram is a renaming as body, the body is just a + -- call to the renamed subprogram, and inlining is trivially + -- possible. elsif Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) = @@ -3708,10 +3787,10 @@ package body Sem_Prag is -- However, a simple Comes_From_Source test is insufficient, since -- we do want to allow inlining of generic instances which also do - -- not come from source. We also need to recognize specs - -- generated by the front-end for bodies that carry the pragma. - -- Finally, predefined operators do not come from source but are - -- not inlineable either. + -- not come from source. We also need to recognize specs generated + -- by the front-end for bodies that carry the pragma. Finally, + -- predefined operators do not come from source but are not + -- inlineable either. elsif Is_Generic_Instance (Subp) or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration @@ -3725,8 +3804,8 @@ package body Sem_Prag is return; end if; - -- The referenced entity must either be the enclosing entity, - -- or an entity declared within the current open scope. + -- The referenced entity must either be the enclosing entity, or + -- an entity declared within the current open scope. if Present (Scope (Subp)) and then Scope (Subp) /= Current_Scope @@ -3737,10 +3816,9 @@ package body Sem_Prag is return; end if; - -- Processing for procedure, operator or function. - -- If subprogram is aliased (as for an instance) indicate - -- that the renamed entity (if declared in the same unit) - -- is inlined. + -- Processing for procedure, operator or function. If subprogram + -- is aliased (as for an instance) indicate that the renamed + -- entity (if declared in the same unit) is inlined. if Is_Subprogram (Subp) then while Present (Alias (Inner_Subp)) loop @@ -3760,9 +3838,9 @@ package body Sem_Prag is elsif Is_Generic_Instance (Subp) then -- Indicate that the body needs to be created for - -- inlining subsequent calls. The instantiation - -- node follows the declaration of the wrapper - -- package created for it. + -- inlining subsequent calls. The instantiation node + -- follows the declaration of the wrapper package + -- created for it. if Scope (Subp) /= Standard_Standard and then @@ -3777,9 +3855,9 @@ package body Sem_Prag is Applies := True; - -- For a generic subprogram set flag as well, for use at - -- the point of instantiation, to determine whether the - -- body should be generated. + -- For a generic subprogram set flag as well, for use at the point + -- of instantiation, to determine whether the body should be + -- generated. elsif Is_Generic_Subprogram (Subp) then Set_Inline_Flags (Subp); @@ -3924,22 +4002,21 @@ package body Sem_Prag is if not In_Character_Range (C) - -- Dubious if comma - - or else Get_Character (C) = ',' - - -- For all cases except link names on a CLI target, spaces - -- and slashes are also dubious (in CLI for link names, we - -- use spaces and possibly slashes for special purposes). + -- For all cases except CLI target, + -- commas, spaces and slashes are dubious (in CLI, we use + -- commas and backslashes in external names to specify + -- assembly version and public key, while slashes and spaces + -- can be used in names to mark nested classes and + -- valuetypes). - -- Where is this usage documented ??? - - or else ((Ext_Name_Case or else VM_Target /= CLI_Target) - and then (Get_Character (C) = ' ' - or else - Get_Character (C) = '/' + or else ((not Ext_Name_Case or else VM_Target /= CLI_Target) + and then (Get_Character (C) = ',' or else Get_Character (C) = '\')) + or else (VM_Target /= CLI_Target + and then (Get_Character (C) = ' ' + or else + Get_Character (C) = '/')) then Error_Msg ("?interface name contains illegal character", @@ -4042,8 +4119,8 @@ package body Sem_Prag is Link_Nam := Adjust_External_Name_Case (Expr_Value_S (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 + -- 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. @@ -4078,10 +4155,10 @@ package body Sem_Prag is begin Set_Is_Interrupt_Handler (Handler_Proc); - -- If the pragma is not associated with a handler procedure - -- within a protected type, then it must be for a nonprotected - -- procedure for the AAMP target, in which case we don't - -- associate a representation item with the procedure's scope. + -- If the pragma is not associated with a handler procedure within a + -- protected type, then it must be for a nonprotected procedure for + -- the AAMP target, in which case we don't associate a representation + -- item with the procedure's scope. if Ekind (Proc_Scope) = E_Protected_Type then if Prag_Id = Pragma_Interrupt_Handler @@ -4179,7 +4256,7 @@ package body Sem_Prag is Error_Msg_String (1 .. Rnm'Length) := Name_Buffer (1 .. Name_Len); Error_Msg_Strlen := Rnm'Length; - Error_Msg_N + Error_Msg_N -- CODEFIX ("\possible misspelling of ""~""", Get_Pragma_Arg (Arg)); exit; @@ -4301,9 +4378,7 @@ package body Sem_Prag is E : Entity_Id; In_Package_Spec : constant Boolean := - (Ekind (Current_Scope) = E_Package - or else - Ekind (Current_Scope) = E_Generic_Package) + Is_Package_Or_Generic_Package (Current_Scope) and then not In_Package_Body (Current_Scope); procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); @@ -4343,8 +4418,8 @@ package body Sem_Prag is -- Start of processing for Process_Suppress_Unsuppress begin - -- Suppress/Unsuppress can appear as a configuration pragma, - -- or in a declarative part or a package spec (RM 11.5(5)) + -- Suppress/Unsuppress can appear as a configuration pragma, or in a + -- declarative part or a package spec (RM 11.5(5)). if not Is_Configuration_Pragma then Check_Is_In_Decl_Part_Or_Package_Spec; @@ -4454,8 +4529,8 @@ package body Sem_Prag is E := Homonym (E); exit when No (E); - -- If we are within a package specification, the - -- pragma only applies to homonyms in the same scope. + -- If we are within a package specification, the pragma only + -- applies to homonyms in the same scope. exit when In_Package_Spec and then Scope (E) /= Current_Scope; @@ -4501,12 +4576,11 @@ package body Sem_Prag is Set_Is_Public (E); Set_Is_Statically_Allocated (E); - -- Warn if the corresponding W flag is set and the pragma - -- comes from source. The latter may not be true e.g. on - -- VMS where we expand export pragmas for exception codes - -- associated with imported or exported exceptions. We do - -- not want to generate a warning for something that the - -- user did not write. + -- Warn if the corresponding W flag is set and the pragma comes + -- from source. The latter may not be true e.g. on VMS where we + -- expand export pragmas for exception codes associated with + -- imported or exported exceptions. We do not want to generate + -- a warning for something that the user did not write. if Warn_On_Export_Import and then Comes_From_Source (Arg) @@ -4558,16 +4632,16 @@ package body Sem_Prag is elsif Nkind (Arg_External) = N_Identifier then New_Name := Get_Default_External_Name (Arg_External); - -- Check_Arg_Is_External_Name should let through only - -- identifiers and string literals or static string - -- expressions (which are folded to string literals). + -- Check_Arg_Is_External_Name should let through only identifiers and + -- string literals or static string expressions (which are folded to + -- string literals). else raise Program_Error; end if; - -- If we already have an external name set (by a prior normal - -- Import or Export pragma), then the external names must match + -- If we already have an external name set (by a prior normal Import + -- or Export pragma), then the external names must match if Present (Interface_Name (Internal_Ent)) then Check_Matching_Internal_Names : declare @@ -4639,10 +4713,10 @@ package body Sem_Prag is else Set_Is_Imported (E); - -- If the entity is an object that is not at the library - -- level, then it is statically allocated. We do not worry - -- about objects with address clauses in this context since - -- they are not really imported in the linker sense. + -- If the entity is an object that is not at the library level, + -- then it is statically allocated. We do not worry about objects + -- with address clauses in this context since they are not really + -- imported in the linker sense. if Is_Object (E) and then not Is_Library_Level_Entity (E) @@ -4657,9 +4731,9 @@ package body Sem_Prag is -- Set_Mechanism_Value -- ------------------------- - -- Note: the mechanism name has not been analyzed (and cannot indeed - -- be analyzed, since it is semantic nonsense), so we get it in the - -- exact form created by the parser. + -- Note: the mechanism name has not been analyzed (and cannot indeed be + -- analyzed, since it is semantic nonsense), so we get it in the exact + -- form created by the parser. procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is Class : Node_Id; @@ -4936,7 +5010,7 @@ package body Sem_Prag is for PN in First_Pragma_Name .. Last_Pragma_Name loop if Is_Bad_Spelling_Of (Pname, PN) then Error_Msg_Name_1 := PN; - Error_Msg_N + Error_Msg_N -- CODEFIX ("\?possible misspelling of %!", Pragma_Identifier (N)); exit; end if; @@ -5161,9 +5235,13 @@ package body Sem_Prag is -- Annotate -- -------------- - -- pragma Annotate (IDENTIFIER {, ARG}); + -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]); -- ARG ::= NAME | EXPRESSION + -- The first two arguments are by convention intended to refer to an + -- external tool and a tool-specific function. These arguments are + -- not analyzed. + when Pragma_Annotate => Annotate : begin GNAT_Pragma; Check_At_Least_N_Arguments (1); @@ -5174,26 +5252,43 @@ package body Sem_Prag is Exp : Node_Id; begin - Arg := Arg2; - while Present (Arg) loop - Exp := Expression (Arg); - Analyze (Exp); + -- Second unanalyzed parameter is optional - if Is_Entity_Name (Exp) then - null; + if No (Arg2) then + null; + else + Arg := Next (Arg2); + while Present (Arg) loop + Exp := Expression (Arg); + Analyze (Exp); - elsif Nkind (Exp) = N_String_Literal then - Resolve (Exp, Standard_String); + if Is_Entity_Name (Exp) then + null; - elsif Is_Overloaded (Exp) then - Error_Pragma_Arg ("ambiguous argument for pragma%", Exp); + -- For string literals, we assume Standard_String as the + -- type, unless the string contains wide or wide_wide + -- characters. - else - Resolve (Exp); - end if; + elsif Nkind (Exp) = N_String_Literal then + if Has_Wide_Wide_Character (Exp) then + Resolve (Exp, Standard_Wide_Wide_String); + elsif Has_Wide_Character (Exp) then + Resolve (Exp, Standard_Wide_String); + else + Resolve (Exp, Standard_String); + end if; - Next (Arg); - end loop; + elsif Is_Overloaded (Exp) then + Error_Pragma_Arg + ("ambiguous argument for pragma%", Exp); + + else + Resolve (Exp); + end if; + + Next (Arg); + end loop; + end if; end; end Annotate; @@ -5289,6 +5384,25 @@ package body Sem_Prag is Opt.Check_Policy_List := N; end Assertion_Policy; + ------------------------------ + -- Assume_No_Invalid_Values -- + ------------------------------ + + -- pragma Assume_No_Invalid_Values (On | Off); + + when Pragma_Assume_No_Invalid_Values => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); + + if Chars (Expression (Arg1)) = Name_On then + Assume_No_Invalid_Values := True; + else + Assume_No_Invalid_Values := False; + end if; + --------------- -- AST_Entry -- --------------- @@ -5414,7 +5528,7 @@ package body Sem_Prag is and then not Is_Remote_Types (C_Ent) then -- This pragma should only appear in an RCI or Remote Types - -- unit (RM E.4.1(4)) + -- unit (RM E.4.1(4)). Error_Pragma ("pragma% not in Remote_Call_Interface or " & @@ -5440,18 +5554,18 @@ package body Sem_Prag is elsif Is_Remote_Access_To_Subprogram_Type (Nm) then - if Is_Record_Type (Nm) then - -- A record type that is the Equivalent_Type for - -- a remote access-to-subprogram type. + if Is_Record_Type (Nm) then - N := Declaration_Node (Corresponding_Remote_Type (Nm)); + -- A record type that is the Equivalent_Type for a remote + -- access-to-subprogram type. - else - -- A non-expanded RAS type (case where distribution is - -- not enabled). + N := Declaration_Node (Corresponding_Remote_Type (Nm)); - N := Declaration_Node (Nm); - end if; + else + -- A non-expanded RAS type (distribution is not enabled) + + N := Declaration_Node (Nm); + end if; if Nkind (N) = N_Full_Type_Declaration and then Nkind (Type_Definition (N)) = @@ -5675,6 +5789,7 @@ package body Sem_Prag is Check_Arg_Is_Identifier (Arg1); Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1))); + Set_Pragma_Enabled (N, Check_On); -- If expansion is active and the check is not enabled then we -- rewrite the Check as: @@ -5716,25 +5831,6 @@ package body Sem_Prag is else Analyze_And_Resolve (Expr, Any_Boolean); end if; - - -- If assertion is of the form (X'First = literal), where X is - -- a formal, then set Low_Bound_Known flag on this formal. - - if Nkind (Expr) = N_Op_Eq then - declare - Right : constant Node_Id := Right_Opnd (Expr); - Left : constant Node_Id := Left_Opnd (Expr); - begin - if Nkind (Left) = N_Attribute_Reference - and then Attribute_Name (Left) = Name_First - and then Is_Entity_Name (Prefix (Left)) - and then Is_Formal (Entity (Prefix (Left))) - and then Nkind (Right) = N_Integer_Literal - then - Set_Low_Bound_Known (Entity (Prefix (Left))); - end if; - end; - end if; end Check; ---------------- @@ -5767,19 +5863,20 @@ package body Sem_Prag is -- Check_Policy -- ------------------ - -- pragma Check_Policy ([Name =>] IDENTIFIER, - -- POLICY_IDENTIFIER; + -- pragma Check_Policy ( + -- [Name =>] IDENTIFIER, + -- [Policy =>] POLICY_IDENTIFIER); -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE - -- Note: this is a configuration pragma, but it is allowed to - -- appear anywhere else. + -- Note: this is a configuration pragma, but it is allowed to appear + -- anywhere else. when Pragma_Check_Policy => GNAT_Pragma; Check_Arg_Count (2); - Check_No_Identifier (Arg2); Check_Optional_Identifier (Arg1, Name_Name); + Check_Optional_Identifier (Arg2, Name_Policy); Check_Arg_Is_One_Of (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore); @@ -5961,11 +6058,11 @@ package body Sem_Prag is Check_Arg_Is_Identifier (Form); - -- Get proper alignment, note that Default = Component_Size - -- on all machines we have so far, and we want to set this - -- value rather than the default value to indicate that it - -- has been explicitly set (and thus will not get overridden - -- by the default component alignment for the current scope) + -- Get proper alignment, note that Default = Component_Size on all + -- machines we have so far, and we want to set this value rather + -- than the default value to indicate that it has been explicitly + -- set (and thus will not get overridden by the default component + -- alignment for the current scope) if Chars (Form) = Name_Component_Size then Atype := Calign_Component_Size; @@ -6157,6 +6254,62 @@ package body Sem_Prag is Set_Is_CPP_Class (Typ); Set_Is_Limited_Record (Typ); Set_Convention (Typ, Convention_CPP); + + -- Imported CPP types must not have discriminants (because C++ + -- classes do not have discriminants). + + if Has_Discriminants (Typ) then + Error_Msg_N + ("imported 'C'P'P type cannot have discriminants", + First (Discriminant_Specifications + (Declaration_Node (Typ)))); + end if; + + -- Components of imported CPP types must not have default + -- expressions because the constructor (if any) is in the + -- C++ side. + + if Is_Incomplete_Or_Private_Type (Typ) + and then No (Underlying_Type (Typ)) + then + -- It should be an error to apply pragma CPP to a private + -- type if the underlying type is not visible (as it is + -- for any representation item). For now, for backward + -- compatibility we do nothing but we cannot check components + -- because they are not available at this stage. All this code + -- will be removed when we cleanup this obsolete GNAT pragma??? + + null; + + else + declare + Tdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Clist : Node_Id; + Comp : Node_Id; + + begin + if Nkind (Tdef) = N_Record_Definition then + Clist := Component_List (Tdef); + else + pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); + Clist := Component_List (Record_Extension_Part (Tdef)); + end if; + + if Present (Clist) then + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + if Present (Expression (Comp)) then + Error_Msg_N + ("component of imported 'C'P'P type cannot have" & + " default expression", Expression (Comp)); + end if; + + Next (Comp); + end loop; + end if; + end; + end if; end CPP_Class; --------------------- @@ -6168,8 +6321,10 @@ package body Sem_Prag is -- [, [Link_Name =>] static_string_EXPRESSION ]); when Pragma_CPP_Constructor => CPP_Constructor : declare - Id : Entity_Id; - Def_Id : Entity_Id; + Elmt : Elmt_Id; + Id : Entity_Id; + Def_Id : Entity_Id; + Tag_Typ : Entity_Id; begin GNAT_Pragma; @@ -6190,8 +6345,10 @@ package body Sem_Prag is 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))) + and then (Is_CPP_Class (Etype (Def_Id)) + or else (Is_Class_Wide_Type (Etype (Def_Id)) + and then + Is_CPP_Class (Root_Type (Etype (Def_Id))))) then if Arg_Count >= 2 then Set_Imported (Def_Id); @@ -6199,14 +6356,39 @@ package body Sem_Prag is 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 - Error_Pragma_Arg - ("non-default constructors not implemented", Arg1); + Set_Has_Completion (Def_Id); + Set_Is_Constructor (Def_Id); + + -- Imported C++ constructors are not dispatching primitives + -- because in C++ they don't have a dispatch table slot. + -- However, in Ada the constructor has the profile of a + -- function that returns a tagged type and therefore it has + -- been treated as a primitive operation during semantic + -- analysis. We now remove it from the list of primitive + -- operations of the type. + + if Is_Tagged_Type (Etype (Def_Id)) + and then not Is_Class_Wide_Type (Etype (Def_Id)) + then + pragma Assert (Is_Dispatching_Operation (Def_Id)); + Tag_Typ := Etype (Def_Id); + + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) and then Node (Elmt) /= Def_Id loop + Next_Elmt (Elmt); + end loop; + + Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); + Set_Is_Dispatching_Operation (Def_Id, False); end if; + -- For backward compatibility, if the constructor returns a + -- class wide type, and we internally change the return type to + -- the corresponding root type. + + if Is_Class_Wide_Type (Etype (Def_Id)) then + Set_Etype (Def_Id, Root_Type (Etype (Def_Id))); + end if; else Error_Pragma_Arg ("pragma% requires function returning a 'C'P'P_Class type", @@ -6315,8 +6497,8 @@ package body Sem_Prag is -- pragma Discard_Names [([On =>] LOCAL_NAME)]; when Pragma_Discard_Names => Discard_Names : declare - E_Id : Entity_Id; E : Entity_Id; + E_Id : Entity_Id; begin Check_Ada_83_Warning; @@ -6346,6 +6528,7 @@ package body Sem_Prag is 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 @@ -6355,8 +6538,8 @@ package body Sem_Prag is end if; if (Is_First_Subtype (E) - and then (Is_Enumeration_Type (E) - or else Is_Tagged_Type (E))) + and then + (Is_Enumeration_Type (E) or else Is_Tagged_Type (E))) or else Ekind (E) = E_Exception then Set_Discard_Names (E); @@ -6364,6 +6547,7 @@ package body Sem_Prag is Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); end if; + end if; end if; end Discard_Names; @@ -6555,9 +6739,8 @@ package body Sem_Prag is Cunit_Node := Cunit (Current_Sem_Unit); Cunit_Ent := Cunit_Entity (Current_Sem_Unit); - if Nkind (Unit (Cunit_Node)) = N_Package_Body - or else - Nkind (Unit (Cunit_Node)) = N_Subprogram_Body + if Nkind_In (Unit (Cunit_Node), N_Package_Body, + N_Subprogram_Body) then Error_Pragma ("pragma% must refer to a spec, not a body"); else @@ -6576,8 +6759,8 @@ package body Sem_Prag is -- safe from an elaboration point of view, so a client must -- still do an Elaborate_All on such units. - -- Debug flag -gnatdD restores the old behavior of 3.13, - -- where Elaborate_Body always suppressed elab warnings. + -- Debug flag -gnatdD restores the old behavior of 3.13, where + -- Elaborate_Body always suppressed elab warnings. if Dynamic_Elaboration_Checks or Debug_Flag_DD then Set_Suppress_Elaboration_Warnings (Cunit_Ent); @@ -6603,12 +6786,11 @@ package body Sem_Prag is --------------- -- pragma Eliminate ( - -- [Unit_Name =>] IDENTIFIER | - -- SELECTED_COMPONENT - -- [,[Entity =>] IDENTIFIER | - -- SELECTED_COMPONENT | - -- STRING_LITERAL] - -- [,]OVERLOADING_RESOLUTION); + -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT, + -- [,[Entity =>] IDENTIFIER | + -- SELECTED_COMPONENT | + -- STRING_LITERAL] + -- [, OVERLOADING_RESOLUTION]); -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE | -- SOURCE_LOCATION @@ -6715,9 +6897,8 @@ package body Sem_Prag is Process_Interface_Name (Def_Id, Arg3, Arg4); Set_Exported (Def_Id, Arg2); - -- If the entity is a deferred constant, propagate the - -- information to the full view, because gigi elaborates - -- the full view only. + -- If the entity is a deferred constant, propagate the information + -- to the full view, because gigi elaborates the full view only. if Ekind (Def_Id) = E_Constant and then Present (Full_View (Def_Id)) @@ -7363,10 +7544,10 @@ package body Sem_Prag is -- pragma Ident (static_string_EXPRESSION) - -- Note: pragma Comment shares this processing. Pragma Comment - -- is identical to Ident, except that the restriction of the - -- argument to 31 characters and the placement restrictions - -- are not enforced for pragma Comment. + -- Note: pragma Comment shares this processing. Pragma Comment is + -- identical to Ident, except that the restriction of the argument to + -- 31 characters and the placement restrictions are not enforced for + -- pragma Comment. when Pragma_Ident | Pragma_Comment => Ident : declare Str : Node_Id; @@ -7377,8 +7558,8 @@ package body Sem_Prag is Check_No_Identifiers; Check_Arg_Is_Static_Expression (Arg1, Standard_String); - -- For pragma Ident, preserve DEC compatibility by requiring - -- the pragma to appear in a declarative part or package spec. + -- For pragma Ident, preserve DEC compatibility by requiring the + -- pragma to appear in a declarative part or package spec. if Prag_Id = Pragma_Ident then Check_Is_In_Decl_Part_Or_Package_Spec; @@ -7393,15 +7574,14 @@ package body Sem_Prag is begin GP := Parent (Parent (N)); - if Nkind (GP) = N_Package_Declaration - or else - Nkind (GP) = N_Generic_Package_Declaration + if Nkind_In (GP, N_Package_Declaration, + N_Generic_Package_Declaration) then GP := Parent (GP); end if; - -- If we have a compilation unit, then record the ident - -- value, checking for improper duplication. + -- If we have a compilation unit, then record the ident value, + -- checking for improper duplication. if Nkind (GP) = N_Compilation_Unit then CS := Ident_String (Current_Sem_Unit); @@ -7413,8 +7593,8 @@ package body Sem_Prag is if Prag_Id = Pragma_Ident then Error_Pragma ("duplicate% pragma not permitted"); - -- For Comment, we concatenate the string, unless we - -- want to preserve the tree structure for ASIS. + -- For Comment, we concatenate the string, unless we want + -- to preserve the tree structure for ASIS. elsif not ASIS_Mode then Start_String (Strval (CS)); @@ -7446,9 +7626,9 @@ package body Sem_Prag is Set_Ident_String (Current_Sem_Unit, Str); end if; - -- For subunits, we just ignore the Ident, since in GNAT - -- these are not separate object files, and hence not - -- separate units in the unit table. + -- For subunits, we just ignore the Ident, since in GNAT these + -- are not separate object files, and hence not separate units + -- in the unit table. elsif Nkind (GP) = N_Subunit then null; @@ -7823,7 +8003,12 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; Check_Restriction (No_Initialize_Scalars, N); - if not Restriction_Active (No_Initialize_Scalars) then + -- Initialize_Scalars creates false positives in CodePeer, + -- so ignore this pragma in this mode. + + if not Restriction_Active (No_Initialize_Scalars) + and then not CodePeer_Mode + then Init_Or_Norm_Scalars := True; Initialize_Scalars := True; end if; @@ -8058,9 +8243,7 @@ package body Sem_Prag is Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority)); end if; - if Nkind (P) /= N_Task_Definition - and then Nkind (P) /= N_Protected_Definition - then + if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then Pragma_Misplaced; return; @@ -8084,10 +8267,10 @@ package body Sem_Prag is -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION -- INTERRUPT_STATE => System | Runtime | User - -- Note: if the interrupt id is given as an identifier, then - -- it must be one of the identifiers in Ada.Interrupts.Names. - -- Otherwise it is given as a static integer expression which - -- must be in the range of Ada.Interrupts.Interrupt_ID. + -- Note: if the interrupt id is given as an identifier, then it must + -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is + -- given as a static integer expression which must be in the range of + -- Ada.Interrupts.Interrupt_ID. when Pragma_Interrupt_State => Interrupt_State : declare @@ -8137,8 +8320,8 @@ package body Sem_Prag is Next_Entity (Int_Ent); end loop; - -- First argument is not an identifier, so it must be a - -- static expression of type Ada.Interrupts.Interrupt_ID. + -- First argument is not an identifier, so it must be a static + -- expression of type Ada.Interrupts.Interrupt_ID. else Check_Arg_Is_Static_Expression (Arg1, Any_Integer); @@ -8252,6 +8435,10 @@ package body Sem_Prag is and then (Is_Value_Type (Etype (Def_Id)) or else + (Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type + and then + Atree.Convention (Etype (Def_Id)) = Convention) + or else (Ekind (Etype (Def_Id)) in Access_Kind and then (Atree.Convention @@ -8274,7 +8461,7 @@ package body Sem_Prag is pragma Assert (Convention = Convention_CIL); Error_Pragma_Arg ("pragma% requires function returning a " & - "'CIL access type", Arg1); + "'C'I'L access type", Arg1); end if; end if; @@ -8315,11 +8502,11 @@ package body Sem_Prag is Typ := Underlying_Type (Entity (Arg)); - -- For now we simply check some of the semantic constraints - -- on the type. This currently leaves out some restrictions - -- on interface types, namely that the parent type must be - -- java.lang.Object.Typ and that all primitives of the type - -- should be declared abstract. ??? + -- For now simply check some of the semantic constraints on the + -- type. This currently leaves out some restrictions on interface + -- types, namely that the parent type must be java.lang.Object.Typ + -- and that all primitives of the type should be declared + -- abstract. ??? if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then Error_Pragma_Arg ("pragma% requires an abstract " @@ -8430,10 +8617,9 @@ package body Sem_Prag is while Present (Arg) loop Check_Arg_Is_Static_Expression (Arg, Standard_String); - -- Store argument, converting sequences of spaces - -- to a single null character (this is one of the - -- differences in processing between Link_With - -- and Linker_Options). + -- Store argument, converting sequences of spaces to a + -- single null character (this is one of the differences + -- in processing between Link_With and Linker_Options). Arg_Store : declare C : constant Char_Code := Get_Char_Code (' '); @@ -8462,8 +8648,8 @@ package body Sem_Prag is Skip_Spaces; -- skip leading spaces -- Loop through characters, changing any embedded - -- sequence of spaces to a single null character - -- (this is how Link_With/Linker_Options differ) + -- sequence of spaces to a single null character (this + -- is how Link_With/Linker_Options differ) while F <= L loop if Get_String_Char (S, F) = C then @@ -8635,9 +8821,9 @@ package body Sem_Prag is -- pragma List (On | Off) - -- 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) + -- 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; @@ -8666,8 +8852,8 @@ package body Sem_Prag is Error_Msg_Sloc := Locking_Policy_Sloc; Error_Pragma ("locking policy incompatible with policy#"); - -- Set new policy, but always preserve System_Location since - -- we like the error message with the run time name. + -- Set new policy, but always preserve System_Location since we + -- like the error message with the run time name. else Locking_Policy := LP; @@ -8723,7 +8909,7 @@ package body Sem_Prag is -- pragma Machine_Attribute ( -- [Entity =>] LOCAL_NAME, -- [Attribute_Name =>] static_string_EXPRESSION - -- [, [Info =>] static_string_EXPRESSION] ); + -- [, [Info =>] static_EXPRESSION] ); when Pragma_Machine_Attribute => Machine_Attribute : declare Def_Id : Entity_Id; @@ -8734,7 +8920,7 @@ package body Sem_Prag is if Arg_Count = 3 then Check_Optional_Identifier (Arg3, Name_Info); - Check_Arg_Is_Static_Expression (Arg3, Standard_String); + Check_Arg_Is_Static_Expression (Arg3); else Check_Arg_Count (2); end if; @@ -8904,7 +9090,7 @@ package body Sem_Prag is Arg : Node_Id; begin - GNAT_Pragma; + Ada_2005_Pragma; Check_At_Least_N_Arguments (1); -- Loop through arguments of pragma @@ -8961,8 +9147,8 @@ package body Sem_Prag is -- pragma No_Run_Time; - -- Note: this pragma is retained for backwards compatibility. - -- See body of Rtsfind for full details on its handling. + -- Note: this pragma is retained for backwards compatibility. See + -- body of Rtsfind for full details on its handling. when Pragma_No_Run_Time => GNAT_Pragma; @@ -9027,16 +9213,29 @@ package body Sem_Prag is Check_Ada_83_Warning; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; - Normalize_Scalars := True; - Init_Or_Norm_Scalars := True; + + -- Normalize_Scalars creates false positives in CodePeer, so + -- ignore this pragma in this mode. + + if not CodePeer_Mode then + Normalize_Scalars := True; + Init_Or_Norm_Scalars := True; + end if; ----------------- -- Obsolescent -- ----------------- - -- pragma Obsolescent [( - -- [Entity => NAME,] - -- [(static_string_EXPRESSION [, Ada_05])]; + -- pragma Obsolescent; + + -- pragma Obsolescent ( + -- [Message =>] static_string_EXPRESSION + -- [,[Version =>] Ada_05]]); + + -- pragma Obsolescent ( + -- [Entity =>] NAME + -- [,[Message =>] static_string_EXPRESSION + -- [,[Version =>] Ada_05]] ); when Pragma_Obsolescent => Obsolescent : declare Ename : Node_Id; @@ -9062,10 +9261,12 @@ package body Sem_Prag is if Present (Ename) then - -- If entity name matches, we are fine + -- If entity name matches, we are fine. Save entity in + -- pragma argument, for ASIS use. if Chars (Ename) = Chars (Ent) then - null; + Set_Entity (Ename, Ent); + Generate_Reference (Ent, Ename); -- If entity name does not match, only possibility is an -- enumeration literal from an enumeration type declaration. @@ -9083,6 +9284,8 @@ package body Sem_Prag is "enumeration literal"); elsif Chars (Ent) = Chars (Ename) then + Set_Entity (Ename, Ent); + Generate_Reference (Ent, Ename); exit; else @@ -9157,19 +9360,15 @@ package body Sem_Prag is -- See if first argument specifies an entity name if Arg_Count >= 1 - and then Chars (Arg1) = Name_Entity + and then + (Chars (Arg1) = Name_Entity + or else + Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal, + N_Identifier, + N_Operator_Symbol)) then Ename := Get_Pragma_Arg (Arg1); - if Nkind (Ename) /= N_Character_Literal - and then - Nkind (Ename) /= N_Identifier - and then - Nkind (Ename) /= N_Operator_Symbol - then - Error_Pragma_Arg ("entity name expected for pragma%", Arg1); - end if; - -- Eliminate first argument, so we can share processing Arg1 := Arg2; @@ -9182,7 +9381,13 @@ package body Sem_Prag is Ename := Empty; end if; - Check_No_Identifiers; + if Arg_Count >= 1 then + Check_Optional_Identifier (Arg1, Name_Message); + + if Arg_Count = 2 then + Check_Optional_Identifier (Arg2, Name_Version); + end if; + end if; -- Get immediately preceding declaration @@ -9209,9 +9414,7 @@ package body Sem_Prag is declare Ent : constant Entity_Id := Find_Lib_Unit_Name; begin - if Ekind (Ent) = E_Package - or else Ekind (Ent) = E_Generic_Package - then + if Is_Package_Or_Generic_Package (Ent) then Set_Obsolescent (Ent); return; end if; @@ -9221,13 +9424,14 @@ package body Sem_Prag is -- Cases where we must follow a declaration else - if Nkind (Decl) not in N_Declaration + if Nkind (Decl) not in N_Declaration and then Nkind (Decl) not in N_Later_Decl_Item and then Nkind (Decl) not in N_Generic_Declaration + and then Nkind (Decl) not in N_Renaming_Declaration then Error_Pragma - ("pragma% misplaced, " & - "must immediately follow a declaration"); + ("pragma% misplaced, " + & "must immediately follow a declaration"); else Set_Obsolescent (Defining_Entity (Decl)); @@ -9358,15 +9562,28 @@ package body Sem_Prag is else if not Rep_Item_Too_Late (Typ, N) then - if VM_Target = No_VM then - Set_Is_Packed (Base_Type (Typ)); + + -- In the context of static code analysis, we do not need + -- complex front-end expansions related to pragma Pack, + -- so disable handling of pragma Pack in this case. + + if CodePeer_Mode then + null; + + -- For normal non-VM target, do the packing + + elsif VM_Target = No_VM then + Set_Is_Packed (Base_Type (Typ)); + Set_Has_Pragma_Pack (Base_Type (Typ)); + Set_Has_Non_Standard_Rep (Base_Type (Typ)); + + -- If we ignore the pack, then warn about this, except + -- that we suppress the warning in GNAT mode. + elsif not GNAT_Mode then Error_Pragma ("?pragma% ignored in this configuration"); end if; - - Set_Has_Pragma_Pack (Base_Type (Typ)); - Set_Has_Non_Standard_Rep (Base_Type (Typ)); end if; end if; @@ -9375,13 +9592,13 @@ package body Sem_Prag is else pragma Assert (Is_Record_Type (Typ)); if not Rep_Item_Too_Late (Typ, N) then if VM_Target = No_VM then - Set_Is_Packed (Base_Type (Typ)); + Set_Is_Packed (Base_Type (Typ)); + Set_Has_Pragma_Pack (Base_Type (Typ)); + Set_Has_Non_Standard_Rep (Base_Type (Typ)); + elsif not GNAT_Mode then Error_Pragma ("?pragma% ignored in this configuration"); end if; - - Set_Has_Pragma_Pack (Base_Type (Typ)); - Set_Has_Non_Standard_Rep (Base_Type (Typ)); end if; end if; end Pack; @@ -9392,9 +9609,9 @@ package body Sem_Prag is -- pragma 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) + -- 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; @@ -9584,10 +9801,11 @@ package body Sem_Prag is Check_Precondition_Postcondition (In_Body); - -- If in spec, nothing to do. If in body, then we convert the - -- pragma to pragma Check (Precondition, cond [, msg]). Note we - -- do this whether or not precondition checks are enabled. That - -- works fine since pragma Check will do this check. + -- If in spec, nothing more to do. If in body, then we convert the + -- pragma to pragma Check (Precondition, cond [, msg]). Note we do + -- this whether or not precondition checks are enabled. That works + -- fine since pragma Check will do this check, and will also + -- analyze the condition itself in the proper context. if In_Body then if Arg_Count = 2 then @@ -9595,8 +9813,6 @@ package body Sem_Prag is Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String); end if; - Analyze_And_Resolve (Get_Pragma_Arg (Arg1), Standard_Boolean); - Rewrite (N, Make_Pragma (Loc, Chars => Name_Check, @@ -9762,10 +9978,7 @@ package body Sem_Prag is -- Task or Protected, must be of type Integer - elsif Nkind (P) = N_Protected_Definition - or else - Nkind (P) = N_Task_Definition - then + elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then Arg := Expression (Arg1); -- The expression must be analyzed in the special manner @@ -9789,10 +10002,7 @@ package body Sem_Prag is else Set_Has_Priority_Pragma (P, True); - if Nkind (P) = N_Protected_Definition - or else - Nkind (P) = N_Task_Definition - then + if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then Record_Rep_Item (Defining_Identifier (Parent (P)), N); -- exp_ch9 should use this ??? end if; @@ -10038,10 +10248,7 @@ package body Sem_Prag is X : constant Node_Id := Original_Node (Arg); begin - if Nkind (X) /= N_String_Literal - and then - Nkind (X) /= N_Identifier - then + if not Nkind_In (X, N_String_Literal, N_Identifier) then Error_Pragma_Arg ("inappropriate argument for pragma %", Arg); end if; @@ -10188,6 +10395,7 @@ package body Sem_Prag is if not GNAT_Mode then Error_Pragma ("pragma% only available in GNAT mode"); end if; + if Nkind (N) = N_Null_Statement then return; end if; @@ -10288,8 +10496,8 @@ package body Sem_Prag is Error_Msg_Sloc := Queuing_Policy_Sloc; Error_Pragma ("queuing policy incompatible with policy#"); - -- Set new policy, but always preserve System_Location since - -- we like the error message with the run time name. + -- Set new policy, but always preserve System_Location since we + -- like the error message with the run time name. else Queuing_Policy := QP; @@ -10409,12 +10617,11 @@ package body Sem_Prag is Cunit_Node := Cunit (Current_Sem_Unit); Cunit_Ent := Cunit_Entity (Current_Sem_Unit); - if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration - and then - Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration + if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, + N_Generic_Package_Declaration) then - Error_Pragma ( - "pragma% can only apply to a package declaration"); + Error_Pragma + ("pragma% can only apply to a package declaration"); end if; Set_Is_Remote_Types (Cunit_Ent); @@ -10496,8 +10703,24 @@ package body Sem_Prag is when Pragma_Reviewable => Check_Ada_83_Warning; Check_Arg_Count (0); + + -- Call dummy debugging function rv. This is done to assist front + -- end debugging. By placing a Reviewable pragma in the source + -- program, a breakpoint on rv catches this place in the source, + -- allowing convenient stepping to the point of interest. + rv; + -------------------------- + -- Short_Circuit_And_Or -- + -------------------------- + + when Pragma_Short_Circuit_And_Or => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Short_Circuit_And_Or := True; + ------------------- -- Share_Generic -- ------------------- @@ -10541,12 +10764,11 @@ package body Sem_Prag is Cunit_Node := Cunit (Current_Sem_Unit); Cunit_Ent := Cunit_Entity (Current_Sem_Unit); - if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration - and then - Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration + if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, + N_Generic_Package_Declaration) then - Error_Pragma ( - "pragma% can only apply to a package declaration"); + Error_Pragma + ("pragma% can only apply to a package declaration"); end if; Set_Is_Shared_Passive (Cunit_Ent); @@ -10586,16 +10808,16 @@ package body Sem_Prag is -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma - -- Source_File_Name (SFN), however their usage is exclusive: - -- SFN can only be used when no project file is used, while - -- SFNP can only be used when a project file is used. + -- Source_File_Name (SFN), however their usage is exclusive: SFN can + -- only be used when no project file is used, while SFNP can only be + -- used when a project file is used. - -- No processing here. Processing was completed during parsing, - -- since we need to have file names set as early as possible. - -- Units are loaded well before semantic processing starts. + -- No processing here. Processing was completed during parsing, since + -- we need to have file names set as early as possible. Units are + -- loaded well before semantic processing starts. - -- The only processing we defer to this point is the check - -- for correct placement. + -- The only processing we defer to this point is the check for + -- correct placement. when Pragma_Source_File_Name => GNAT_Pragma; @@ -10607,27 +10829,27 @@ package body Sem_Prag is -- See Source_File_Name for syntax - -- No processing here. Processing was completed during parsing, - -- since we need to have file names set as early as possible. - -- Units are loaded well before semantic processing starts. + -- No processing here. Processing was completed during parsing, since + -- we need to have file names set as early as possible. Units are + -- loaded well before semantic processing starts. - -- The only processing we defer to this point is the check - -- for correct placement. + -- The only processing we defer to this point is the check for + -- correct placement. when Pragma_Source_File_Name_Project => GNAT_Pragma; Check_Valid_Configuration_Pragma; - -- Check that a pragma Source_File_Name_Project is used only - -- in a configuration pragmas file. + -- Check that a pragma Source_File_Name_Project is used only in a + -- configuration pragmas file. - -- Pragmas Source_File_Name_Project should only be generated - -- by the Project Manager in configuration pragmas files. + -- Pragmas Source_File_Name_Project should only be generated by + -- the Project Manager in configuration pragmas files. -- This is really an ugly test. It seems to depend on some - -- accidental and undocumented property. At the very least - -- it needs to be documented, but it would be better to have - -- a clean way of testing if we are in a configuration file??? + -- accidental and undocumented property. At the very least it + -- needs to be documented, but it would be better to have a + -- clean way of testing if we are in a configuration file??? if Present (Parent (N)) then Error_Pragma @@ -10640,8 +10862,8 @@ package body Sem_Prag is -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]); - -- Nothing to do, all processing completed in Par.Prag, since we - -- need the information for possible parser messages that are output + -- 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 => GNAT_Pragma; @@ -10737,10 +10959,10 @@ package body Sem_Prag is when Pragma_Stream_Convert => Stream_Convert : declare procedure Check_OK_Stream_Convert_Function (Arg : Node_Id); - -- Check that the given argument is the name of a local - -- function of one argument that is not overloaded earlier - -- in the current local scope. A check is also made that the - -- argument is a function with one parameter. + -- Check that the given argument is the name of a local function + -- of one argument that is not overloaded earlier in the current + -- local scope. A check is also made that the argument is a + -- function with one parameter. -------------------------------------- -- Check_OK_Stream_Convert_Function -- @@ -10843,9 +11065,9 @@ package body Sem_Prag is -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); - -- This is processed by the parser since some of the style - -- checks take place during source scanning and parsing. This - -- means that we don't need to issue error messages here. + -- This is processed by the parser since some of the style checks + -- take place during source scanning and parsing. This means that + -- we don't need to issue error messages here. when Pragma_Style_Checks => Style_Checks : declare A : constant Node_Id := Expression (Arg1); @@ -10963,11 +11185,10 @@ package body Sem_Prag is -- pragma Suppress_All; - -- The only check made here is that the pragma appears in the - -- proper place, i.e. following a compilation unit. If indeed - -- it appears in this context, then the parser has already - -- inserted an equivalent pragma Suppress (All_Checks) to get - -- the required effect. + -- The only check made here is that the pragma appears in the proper + -- place, i.e. following a compilation unit. If indeed it appears in + -- this context, then the parser has already inserted an equivalent + -- pragma Suppress (All_Checks) to get the required effect. when Pragma_Suppress_All => GNAT_Pragma; @@ -11055,8 +11276,8 @@ package body Sem_Prag is -- pragma System_Name (DIRECT_NAME); - -- Syntax check: one argument, which must be the identifier GNAT - -- or the identifier GCC, no other identifiers are acceptable. + -- Syntax check: one argument, which must be the identifier GNAT or + -- the identifier GCC, no other identifiers are acceptable. when Pragma_System_Name => GNAT_Pragma; @@ -11089,8 +11310,8 @@ package body Sem_Prag is Error_Pragma ("task dispatching policy incompatible with policy#"); - -- Set new policy, but always preserve System_Location since - -- we like the error message with the run time name. + -- Set new policy, but always preserve System_Location since we + -- like the error message with the run time name. else Task_Dispatching_Policy := DP; @@ -11148,7 +11369,13 @@ package body Sem_Prag is Check_Arg_Count (1); Arg := Expression (Arg1); - Analyze_And_Resolve (Arg, Standard_String); + + -- The expression is used in the call to Create_Task, and must be + -- expanded there, not in the context of the current spec. It must + -- however be analyzed to capture global references, in case it + -- appears in a generic context. + + Preanalyze_And_Resolve (Arg, Standard_String); if Nkind (P) /= N_Task_Definition then Pragma_Misplaced; @@ -11213,6 +11440,43 @@ package body Sem_Prag is end if; end Task_Storage; + -------------------------- + -- Thread_Local_Storage -- + -------------------------- + + -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME); + + when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare + Id : Node_Id; + E : Entity_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Library_Level_Local_Name (Arg1); + + Id := Expression (Arg1); + Analyze (Id); + + if not Is_Entity_Name (Id) + or else Ekind (Entity (Id)) /= E_Variable + then + Error_Pragma_Arg ("local variable name required", Arg1); + end if; + + E := Entity (Id); + + if Rep_Item_Too_Early (E, N) + or else Rep_Item_Too_Late (E, N) + then + raise Pragma_Exit; + end if; + + Set_Has_Pragma_Thread_Local_Storage (E); + Set_Has_Gigi_Rep_Item (E); + end Thread_Local_Storage; + ---------------- -- Time_Slice -- ---------------- @@ -11403,9 +11667,9 @@ package body Sem_Prag is -- 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). + -- 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 : constant Entity_Id := @@ -11466,10 +11730,10 @@ package body Sem_Prag is GNAT_Pragma; -- If this is a configuration pragma, then set the universal - -- addressing option, otherwise confirm that the pragma - -- satisfies the requirements of library unit pragma placement - -- and leave it to the GNAAMP back end to detect the pragma - -- (avoids transitive setting of the option due to withed units). + -- addressing option, otherwise confirm that the pragma satisfies + -- the requirements of library unit pragma placement and leave it + -- to the GNAAMP back end to detect the pragma (avoids transitive + -- setting of the option due to withed units). if Is_Configuration_Pragma then Universal_Addressing_On_AAMP := True; @@ -11502,13 +11766,13 @@ package body Sem_Prag is while Present (Arg_Node) loop Check_No_Identifier (Arg_Node); - -- Note: the analyze call done by Check_Arg_Is_Local_Name - -- will in fact generate reference, so that the entity will - -- have a reference, which will inhibit any warnings about - -- it not being referenced, and also properly show up in the - -- ali file as a reference. But this reference is recorded - -- before the Has_Pragma_Unreferenced flag is set, so that - -- no warning is generated for this reference. + -- Note: the analyze call done by Check_Arg_Is_Local_Name will + -- in fact generate reference, so that the entity will have a + -- reference, which will inhibit any warnings about it not + -- being referenced, and also properly show up in the ali file + -- as a reference. But this reference is recorded before the + -- Has_Pragma_Unreferenced flag is set, so that no warning is + -- generated for this reference. Check_Arg_Is_Local_Name (Arg_Node); Arg_Expr := Get_Pragma_Arg (Arg_Node); @@ -11776,6 +12040,14 @@ package body Sem_Prag is Check_At_Least_N_Arguments (1); Check_No_Identifiers; + -- If debug flag -gnatd.i is set, pragma is ignored + + if Debug_Flag_Dot_I then + return; + end if; + + -- Process various forms of the pragma + declare Argx : constant Node_Id := Get_Pragma_Arg (Arg1); @@ -12082,7 +12354,7 @@ package body Sem_Prag is and then (Is_Generic_Instance (Result) or else Nkind (Parent (Declaration_Node (Result))) = - N_Subprogram_Renaming_Declaration) + N_Subprogram_Renaming_Declaration) and then Present (Alias (Result)) loop Result := Alias (Result); @@ -12120,9 +12392,9 @@ package body Sem_Prag is function Is_Config_Static_String (Arg : Node_Id) return Boolean is function Add_Config_Static_String (Arg : Node_Id) return Boolean; - -- This is an internal recursive function that is just like the - -- outer function except that it adds the string to the name buffer - -- rather than placing the string in the name buffer. + -- This is an internal recursive function that is just like the outer + -- function except that it adds the string to the name buffer rather + -- than placing the string in the name buffer. ------------------------------ -- Add_Config_Static_String -- @@ -12198,6 +12470,7 @@ package body Sem_Prag is Pragma_Annotate => -1, Pragma_Assert => -1, Pragma_Assertion_Policy => 0, + Pragma_Assume_No_Invalid_Values => 0, Pragma_Asynchronous => -1, Pragma_Atomic => 0, Pragma_Atomic_Components => 0, @@ -12318,6 +12591,7 @@ package body Sem_Prag is Pragma_Restriction_Warnings => -1, Pragma_Restrictions => -1, Pragma_Reviewable => -1, + Pragma_Short_Circuit_And_Or => -1, Pragma_Share_Generic => -1, Pragma_Shared => -1, Pragma_Shared_Passive => -1, @@ -12340,6 +12614,7 @@ package body Sem_Prag is Pragma_Task_Info => -1, Pragma_Task_Name => -1, Pragma_Task_Storage => 0, + Pragma_Thread_Local_Storage => 0, Pragma_Time_Slice => -1, Pragma_Title => -1, Pragma_Unchecked_Union => 0, @@ -12417,11 +12692,11 @@ package body Sem_Prag is -- 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). + -- 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); @@ -12486,11 +12761,11 @@ package body Sem_Prag is procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is begin - -- A special check for pragma Suppress_All. This is a strange DEC - -- pragma, strange because it comes at the end of the unit. If we - -- have a pragma Suppress_All in the Pragmas_After of the current - -- unit, then we insert a pragma Suppress (All_Checks) at the start - -- of the context clause to ensure the correct processing. + -- A special check for pragma Suppress_All, a very strange DEC pragma, + -- strange because it comes at the end of the unit. If we have a pragma + -- Suppress_All in the Pragmas_After of the current unit, then we insert + -- a pragma Suppress (All_Checks) at the start of the context clause to + -- ensure the correct processing. declare PA : constant List_Id := Pragmas_After (Aux_Decls_Node (N)); @@ -12541,8 +12816,8 @@ package body Sem_Prag is Hex : constant array (0 .. 15) of Character := "0123456789abcdef"; procedure Encode; - -- Stores encoded value of character code CC. The encoding we - -- use an underscore followed by four lower case hex digits. + -- Stores encoded value of character code CC. The encoding we use an + -- underscore followed by four lower case hex digits. ------------ -- Encode -- @@ -12564,10 +12839,10 @@ package body Sem_Prag is -- Start of processing for Set_Encoded_Interface_Name begin - -- If first character is asterisk, this is a link name, and we - -- leave it completely unmodified. We also ignore null strings - -- (the latter case happens only in error cases) and no encoding - -- should occur for Java or AAMP interface names. + -- If first character is asterisk, this is a link name, and we leave it + -- completely unmodified. We also ignore null strings (the latter case + -- happens only in error cases) and no encoding should occur for Java or + -- AAMP interface names. if Len = 0 or else Get_String_Char (Str, 1) = Get_Char_Code ('*')