From 74c7ae526b21dbee30c26a8bda2bb7ae90b42692 Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 31 Jul 2014 13:48:33 +0000 Subject: [PATCH] 2014-07-31 Robert Dewar * cstand.adb, einfo.adb, einfo.ads, errout.adb, exp_attr.adb, exp_prag.adb, frontend.adb, interfac.ads, par-prag.adb, s-auxdec.ads, s-filofl.ads, s-fishfl.ads, s-fvadfl.ads, s-fvaffl.ads, s-fvagfl.ads, s-vaflop.ads, sem_attr.adb, sem_attr.ads, sem_ch13.adb, sem_ch3.adb, sem_ch8.adb, sem_prag.adb, snames.adb-tmpl, snames.ads-tmpl: Remove obsolete VMS-specific code. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@213369 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 9 + gcc/ada/cstand.adb | 5 - gcc/ada/einfo.adb | 20 +- gcc/ada/einfo.ads | 15 +- gcc/ada/errout.adb | 69 +----- gcc/ada/exp_attr.adb | 64 ----- gcc/ada/exp_prag.adb | 179 -------------- gcc/ada/frontend.adb | 16 -- gcc/ada/interfac.ads | 11 +- gcc/ada/par-prag.adb | 5 - gcc/ada/s-auxdec.ads | 14 +- gcc/ada/s-filofl.ads | 5 +- gcc/ada/s-fishfl.ads | 5 +- gcc/ada/s-fvadfl.ads | 9 +- gcc/ada/s-fvaffl.ads | 9 +- gcc/ada/s-fvagfl.ads | 9 +- gcc/ada/s-vaflop.ads | 25 +- gcc/ada/sem_attr.adb | 167 +------------ gcc/ada/sem_attr.ads | 19 +- gcc/ada/sem_ch13.adb | 18 +- gcc/ada/sem_ch3.adb | 9 - gcc/ada/sem_ch8.adb | 57 ++--- gcc/ada/sem_prag.adb | 643 +++--------------------------------------------- gcc/ada/snames.adb-tmpl | 52 ++-- gcc/ada/snames.ads-tmpl | 35 +-- 25 files changed, 124 insertions(+), 1345 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 488e759..e6c4cb8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,14 @@ 2014-07-31 Robert Dewar + * cstand.adb, einfo.adb, einfo.ads, errout.adb, exp_attr.adb, + exp_prag.adb, frontend.adb, interfac.ads, + par-prag.adb, s-auxdec.ads, s-filofl.ads, s-fishfl.ads, s-fvadfl.ads, + s-fvaffl.ads, s-fvagfl.ads, s-vaflop.ads, sem_attr.adb, sem_attr.ads, + sem_ch13.adb, sem_ch3.adb, sem_ch8.adb, sem_prag.adb, snames.adb-tmpl, + snames.ads-tmpl: Remove obsolete VMS-specific code. + +2014-07-31 Robert Dewar + * sem_ch3.adb, sem_ch13.adb: Minor reformatting. 2014-07-31 Arnaud Charlet diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index c4a8b1d..8261a41 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -2125,11 +2125,6 @@ package body CStand is Exponent : constant Uint := Emax - Mantissa; begin - -- Note: for the call from Cstand to initially create the types in - -- Standard, Float_Rep will never be VAX_Native. Circuitry in Sem_Vfpt - -- will adjust these types appropriately VAX_Native if a pragma - -- Float_Representation (VAX_Float) is used. - H := Make_Float_Literal (Stloc, Radix, Significand, Exponent); L := Make_Float_Literal (Stloc, Radix, -Significand, Exponent); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index d4929c3..664d24b 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -7367,13 +7367,6 @@ package body Einfo is when others => return No_Uint; end case; - when VAX_Native => - case Digs is - when 1 .. 9 => return 2**7 - 1; - when 10 .. 15 => return 2**10 - 1; - when others => return No_Uint; - end case; - when AAMP => return Uint_2 ** Uint_7 - Uint_1; end case; @@ -7387,7 +7380,6 @@ package body Einfo is begin case Float_Rep (Id) is when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id); - when VAX_Native => return -Machine_Emax_Value (Id); when AAMP => return -Machine_Emax_Value (Id); end case; end Machine_Emin_Value; @@ -7410,14 +7402,6 @@ package body Einfo is when others => return No_Uint; end case; - when VAX_Native => - case Digs is - when 1 .. 6 => return Uint_24; - when 7 .. 9 => return UI_From_Int (56); - when 10 .. 15 => return UI_From_Int (53); - when others => return No_Uint; - end case; - when AAMP => case Digs is when 1 .. 6 => return Uint_24; @@ -7434,7 +7418,7 @@ package body Einfo is function Machine_Radix_Value (Id : E) return U is begin case Float_Rep (Id) is - when IEEE_Binary | VAX_Native | AAMP => + when IEEE_Binary | AAMP => return Uint_2; end case; end Machine_Radix_Value; @@ -8209,7 +8193,7 @@ package body Einfo is function Vax_Float (Id : E) return B is begin - return Is_Floating_Point_Type (Id) and then Float_Rep (Id) = VAX_Native; + return False; end Vax_Float; ------------------------ diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index e71b576..b29821b 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2068,13 +2068,11 @@ package Einfo is -- access to subprograms (JGNAT only). Set to Empty unless an export, -- import, or interface name pragma has explicitly specified an external -- name, in which case it references an N_String_Literal node for the --- specified external name. In the case of exceptions, the field is set --- by Import_Exception/Export_Exception (which can be used in OpenVMS --- versions only). Note that if this field is Empty, and Is_Imported --- or Is_Exported is set, then the default interface name is the name --- of the entity, cased in a manner that is appropriate to the system --- in use. Note that Interface_Name is ignored if an address clause --- is present (since it is meaningless in this case). +-- specified external name. Note that if this field is Empty, and +-- Is_Imported or Is_Exported is set, then the default interface name +-- is the name of the entity, cased in a manner that is appropriate to +-- the system in use. Note that Interface_Name is ignored if an address +-- clause is present (since it is meaningless in this case). -- -- An additional special case usage of this field is in JGNAT for -- E_Component and E_Discriminant. JGNAT allows these entities to be @@ -6252,8 +6250,7 @@ package Einfo is ----------------------------------- type Float_Rep_Kind is ( - IEEE_Binary, -- IEEE 754p conform binary format - VAX_Native, -- VAX D, F, G or H format + IEEE_Binary, -- IEEE 754p conforming binary format AAMP); -- AAMP format --------------- diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 4fc2805..cae81b1 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -37,7 +37,6 @@ with Einfo; use Einfo; with Erroutc; use Erroutc; with Fname; use Fname; with Gnatvsn; use Gnatvsn; -with Hostparm; use Hostparm; with Lib; use Lib; with Opt; use Opt; with Nlists; use Nlists; @@ -190,14 +189,6 @@ package body Errout is -- should have 'Class appended to its name (see Add_Class procedure), and -- is otherwise unchanged. - procedure VMS_Convert; - -- This procedure has no effect if called when the host is not OpenVMS. If - -- the host is indeed OpenVMS, then the error message stored in Msg_Buffer - -- is scanned for appearances of switch names which need converting to - -- corresponding VMS qualifier names. See Gnames/Vnames table in Errout - -- spec for precise definition of the conversion that is performed by this - -- routine in OpenVMS mode. - function Warn_Insertion return String; -- This is called for warning messages only (so Warning_Msg_Char is set) -- and returns a corresponding string to use at the beginning of generated @@ -1678,11 +1669,6 @@ package body Errout is -- error to make sure that *something* appears on standard error in -- an error situation. - -- Formerly, only the "# errors" suffix was sent to stderr, whereas - -- "# lines:" appeared on stdout. This caused problems on VMS when - -- the stdout buffer was flushed, giving an extra line feed after - -- the prefix. - if Total_Errors_Detected + Warnings_Detected /= 0 and then not Brief_Output and then (Verbose_Mode or Full_List) @@ -2331,9 +2317,7 @@ package body Errout is -- Loop through file names to find matching one. This is a bit slow, but -- we only do it in error situations so it is not so terrible. Note that -- if the loop does not exit, then the desired case will be left set to - -- Mixed_Case, this can happen if the name was not in canonical form, - -- and gets canonicalized on VMS. Possibly we could fix this by - -- unconditionally canonicalizing these names ??? + -- Mixed_Case, this can happen if the name was not in canonical form. for J in 1 .. Last_Source_File loop Get_Name_String (Full_Debug_Name (J)); @@ -2980,8 +2964,6 @@ package body Errout is Set_Msg_Char (C); end case; end loop; - - VMS_Convert; end Set_Msg_Text; ---------------- @@ -3292,55 +3274,6 @@ package body Errout is end if; end Unwind_Internal_Type; - ----------------- - -- VMS_Convert -- - ----------------- - - procedure VMS_Convert is - P : Natural; - L : Natural; - N : Natural; - - begin - if not OpenVMS then - return; - end if; - - P := Msg_Buffer'First; - loop - if P >= Msglen then - return; - end if; - - if Msg_Buffer (P) = '-' then - for G in Gnames'Range loop - L := Gnames (G)'Length; - - -- See if we have "-ggg switch", where ggg is Gnames entry - - if P + L + 7 <= Msglen - and then Msg_Buffer (P + 1 .. P + L) = Gnames (G).all - and then Msg_Buffer (P + L + 1 .. P + L + 7) = " switch" - then - -- Replace by "/vvv qualifier", where vvv is Vnames entry - - N := Vnames (G)'Length; - Msg_Buffer (P + N + 11 .. Msglen + N - L + 3) := - Msg_Buffer (P + L + 8 .. Msglen); - Msg_Buffer (P) := '/'; - Msg_Buffer (P + 1 .. P + N) := Vnames (G).all; - Msg_Buffer (P + N + 1 .. P + N + 10) := " qualifier"; - P := P + N + 10; - Msglen := Msglen + N - L + 3; - exit; - end if; - end loop; - end if; - - P := P + 1; - end loop; - end VMS_Convert; - -------------------- -- Warn_Insertion -- -------------------- diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 6bc73b7..e2ec15d 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2255,70 +2255,6 @@ package body Exp_Attr is end if; end Alignment; - --------------- - -- AST_Entry -- - --------------- - - when Attribute_AST_Entry => AST_Entry : declare - Ttyp : Entity_Id; - T_Id : Node_Id; - Eent : Entity_Id; - - Entry_Ref : Node_Id; - -- The reference to the entry or entry family - - Index : Node_Id; - -- The index expression for an entry family reference, or - -- the Empty if Entry_Ref references a simple entry. - - begin - if Nkind (Pref) = N_Indexed_Component then - Entry_Ref := Prefix (Pref); - Index := First (Expressions (Pref)); - else - Entry_Ref := Pref; - Index := Empty; - end if; - - -- Get expression for Task_Id and the entry entity - - if Nkind (Entry_Ref) = N_Selected_Component then - T_Id := - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Identity, - Prefix => Prefix (Entry_Ref)); - - Ttyp := Etype (Prefix (Entry_Ref)); - Eent := Entity (Selector_Name (Entry_Ref)); - - else - T_Id := - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc)); - - Eent := Entity (Entry_Ref); - - -- We have to find the enclosing task to get the task type - -- There must be one, since we already validated this earlier - - Ttyp := Current_Scope; - while not Is_Task_Type (Ttyp) loop - Ttyp := Scope (Ttyp); - end loop; - end if; - - -- Now rewrite the attribute with a call to Create_AST_Handler - - Rewrite (N, - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc), - Parameter_Associations => New_List ( - T_Id, - Entry_Index_Expression (Loc, Eent, Index, Ttyp)))); - - Analyze_And_Resolve (N, RTE (RE_AST_Handler)); - end AST_Entry; - --------- -- Bit -- --------- diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 417a76d..1816294 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -41,14 +41,12 @@ with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; -with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Stringt; use Stringt; with Stand; use Stand; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; with Validsw; use Validsw; @@ -68,7 +66,6 @@ package body Exp_Prag is procedure Expand_Pragma_Check (N : Node_Id); procedure Expand_Pragma_Common_Object (N : Node_Id); procedure Expand_Pragma_Import_Or_Interface (N : Node_Id); - procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); procedure Expand_Pragma_Loop_Variant (N : Node_Id); @@ -818,15 +815,9 @@ package body Exp_Prag is when Pragma_Common_Object => Expand_Pragma_Common_Object (N); - when Pragma_Export_Exception => - Expand_Pragma_Import_Export_Exception (N); - when Pragma_Import => Expand_Pragma_Import_Or_Interface (N); - when Pragma_Import_Exception => - Expand_Pragma_Import_Export_Exception (N); - when Pragma_Inspection_Point => Expand_Pragma_Inspection_Point (N); @@ -1292,176 +1283,6 @@ package body Exp_Prag is end if; end Expand_Pragma_Import_Or_Interface; - ------------------------------------------- - -- Expand_Pragma_Import_Export_Exception -- - ------------------------------------------- - - -- For a VMS exception fix up the language field with "VMS" instead of - -- "Ada" (gigi needs this), create a constant that will be the value of - -- the VMS condition code and stuff the Interface_Name field with the - -- unexpanded name of the exception (if not already set). For a Ada - -- exception, just stuff the Interface_Name field with the unexpanded - -- name of the exception (if not already set). - - procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is - begin - -- This pragma is only effective on OpenVMS systems, it was ignored on - -- non-VMS systems, and we need to ignore it here as well. - - if not OpenVMS_On_Target then - return; - end if; - - declare - Id : constant Entity_Id := Entity (Arg1 (N)); - Call : constant Node_Id := Register_Exception_Call (Id); - Loc : constant Source_Ptr := Sloc (N); - - begin - if Present (Call) then - declare - Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V'); - Export_Pragma : Node_Id; - Excep_Alias : Node_Id; - Excep_Object : Node_Id; - Excep_Image : String_Id; - Exdata : List_Id; - Lang_Char : Node_Id; - Code : Node_Id; - - begin - -- Compute the symbol for the code of the condition - - if Present (Interface_Name (Id)) then - Excep_Image := Strval (Interface_Name (Id)); - else - Get_Name_String (Chars (Id)); - Set_All_Upper_Case; - Excep_Image := String_From_Name_Buffer; - end if; - - Exdata := Component_Associations (Expression (Parent (Id))); - - if Is_VMS_Exception (Id) then - Lang_Char := Next (First (Exdata)); - - -- Change the one-character language designator to 'V' - - Rewrite (Expression (Lang_Char), - Make_Character_Literal (Loc, - Chars => Name_uV, - Char_Literal_Value => - UI_From_Int (Character'Pos ('V')))); - Analyze (Expression (Lang_Char)); - - if Exception_Code (Id) /= No_Uint then - - -- The code for the exception is present. Create a linker - -- alias to define the symbol. - - Code := - Unchecked_Convert_To (RTE (RE_Address), - Make_Integer_Literal (Loc, - Intval => Exception_Code (Id))); - - -- Declare a dummy object - - Excep_Object := - Make_Object_Declaration (Loc, - Defining_Identifier => Excep_Internal, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc)); - - Insert_Action (N, Excep_Object); - Analyze (Excep_Object); - - -- Clear severity bits - - Start_String; - Store_String_Int - (UI_To_Int (Exception_Code (Id)) / 8 * 8); - - -- Insert a pragma Linker_Alias to set the value of the - -- dummy object symbol. - - Excep_Alias := - Make_Pragma (Loc, - Chars => Name_Linker_Alias, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => - New_Occurrence_Of (Excep_Internal, Loc)), - - Make_Pragma_Argument_Association (Loc, - Expression => - Make_String_Literal (Loc, End_String)))); - - Insert_Action (N, Excep_Alias); - Analyze (Excep_Alias); - - -- Insert a pragma Export to give a Linker_Name to the - -- dummy object. - - Export_Pragma := - Make_Pragma (Loc, - Chars => Name_Export, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_C)), - - Make_Pragma_Argument_Association (Loc, - Expression => - New_Occurrence_Of (Excep_Internal, Loc)), - - Make_Pragma_Argument_Association (Loc, - Expression => - Make_String_Literal (Loc, Excep_Image)), - - Make_Pragma_Argument_Association (Loc, - Expression => - Make_String_Literal (Loc, Excep_Image)))); - - Insert_Action (N, Export_Pragma); - Analyze (Export_Pragma); - - else - Code := - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Import_Address), Loc), - Parameter_Associations => New_List - (Make_String_Literal (Loc, - Strval => Excep_Image))); - end if; - - -- Generate the call to Register_VMS_Exception - - Rewrite (Call, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of - (RTE (RE_Register_VMS_Exception), Loc), - Parameter_Associations => New_List ( - Code, - Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Id, Loc), - Attribute_Name => Name_Unrestricted_Access))))); - - Analyze_And_Resolve (Code, RTE (RE_Address)); - Analyze (Call); - end if; - - if No (Interface_Name (Id)) then - Set_Interface_Name (Id, - Make_String_Literal - (Sloc => Loc, - Strval => Excep_Image)); - end if; - end; - end if; - end; - end Expand_Pragma_Import_Export_Exception; - ------------------------------------ -- Expand_Pragma_Inspection_Point -- ------------------------------------ diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index e1c785d..5cea4db 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -57,7 +57,6 @@ with Sem_Ch8; use Sem_Ch8; with Sem_SCIL; with Sem_Elab; use Sem_Elab; with Sem_Prag; use Sem_Prag; -with Sem_VFpt; use Sem_VFpt; with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Sinput; use Sinput; @@ -191,21 +190,6 @@ begin Config_Pragmas := Empty_List; end if; - -- Check for VAX Float - - if Targparm.VAX_Float_On_Target then - - -- pragma Float_Representation (VAX_Float); - - Opt.Float_Format := 'V'; - - -- pragma Long_Float (G_Float); - - Opt.Float_Format_Long := 'G'; - - Set_Standard_Fpt_Formats; - end if; - -- Now deal with specified config pragmas files if there are any if Opt.Config_File_Names /= null then diff --git a/gcc/ada/interfac.ads b/gcc/ada/interfac.ads index fe6bb0f..1c88a50 100644 --- a/gcc/ada/interfac.ads +++ b/gcc/ada/interfac.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -152,19 +152,12 @@ package Interfaces is pragma Import (Intrinsic, Rotate_Left); pragma Import (Intrinsic, Rotate_Right); - -- IEEE Floating point types. Note that the form of these definitions - -- ensures that the work on VMS, even if the standard library is compiled - -- using a Float_Representation pragma for Vax_Float. - - pragma Warnings (Off); - -- Turn off warnings for targets not providing IEEE floating-point types + -- IEEE Floating point types type IEEE_Float_32 is digits 6; - pragma Float_Representation (IEEE_Float, IEEE_Float_32); for IEEE_Float_32'Size use 32; type IEEE_Float_64 is digits 15; - pragma Float_Representation (IEEE_Float, IEEE_Float_64); for IEEE_Float_64'Size use 64; -- If there is an IEEE extended float available on the machine, we assume diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index f755611..ea770fd 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1151,7 +1151,6 @@ begin Pragma_Assertion_Policy | Pragma_Assume | Pragma_Assume_No_Invalid_Values | - Pragma_AST_Entry | Pragma_All_Calls_Remote | Pragma_Allow_Integer_Address | Pragma_Annotate | @@ -1201,7 +1200,6 @@ begin Pragma_Elaboration_Checks | Pragma_Enable_Atomic_Synchronization | Pragma_Export | - Pragma_Export_Exception | Pragma_Export_Function | Pragma_Export_Object | Pragma_Export_Procedure | @@ -1213,14 +1211,12 @@ begin Pragma_Favor_Top_Level | Pragma_Fast_Math | Pragma_Finalize_Storage_Only | - Pragma_Float_Representation | Pragma_Global | Pragma_Ident | Pragma_Implementation_Defined | Pragma_Implemented | Pragma_Implicit_Packing | Pragma_Import | - Pragma_Import_Exception | Pragma_Import_Function | Pragma_Import_Object | Pragma_Import_Procedure | @@ -1252,7 +1248,6 @@ begin Pragma_Linker_Section | Pragma_Lock_Free | Pragma_Locking_Policy | - Pragma_Long_Float | Pragma_Loop_Invariant | Pragma_Loop_Optimize | Pragma_Loop_Variant | diff --git a/gcc/ada/s-auxdec.ads b/gcc/ada/s-auxdec.ads index 59ba5ec..6c585cc 100644 --- a/gcc/ada/s-auxdec.ads +++ b/gcc/ada/s-auxdec.ads @@ -109,27 +109,15 @@ package System.Aux_DEC is -- Floating point type declarations for VAX floating point data types - pragma Warnings (Off); - -- ??? needs comment - type F_Float is digits 6; - pragma Float_Representation (VAX_Float, F_Float); - type D_Float is digits 9; - pragma Float_Representation (Vax_Float, D_Float); - type G_Float is digits 15; - pragma Float_Representation (Vax_Float, G_Float); + -- We provide the type names, but these will be IEEE, not VMS format -- Floating point type declarations for IEEE floating point data types type IEEE_Single_Float is digits 6; - pragma Float_Representation (IEEE_Float, IEEE_Single_Float); - type IEEE_Double_Float is digits 15; - pragma Float_Representation (IEEE_Float, IEEE_Double_Float); - - pragma Warnings (On); Non_Ada_Error : exception; diff --git a/gcc/ada/s-filofl.ads b/gcc/ada/s-filofl.ads index e3aba15..3f40af8 100644 --- a/gcc/ada/s-filofl.ads +++ b/gcc/ada/s-filofl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -34,13 +34,14 @@ -- we can't just use Long_Float, since this may have been mapped to Vax_Float -- using a Float_Representation configuration pragma. +-- TO BE RMOVED ??? + with System.Fat_Gen; package System.Fat_IEEE_Long_Float is pragma Pure; type Fat_IEEE_Long is digits 15; - pragma Float_Representation (IEEE_Float, Fat_IEEE_Long); -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package diff --git a/gcc/ada/s-fishfl.ads b/gcc/ada/s-fishfl.ads index 335b714..c5f1bac 100644 --- a/gcc/ada/s-fishfl.ads +++ b/gcc/ada/s-fishfl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -34,13 +34,14 @@ -- we can't just use Float, since this may have been mapped to Vax_Float -- using a Float_Representation configuration pragma. +-- TO BE REMOVED ??? + with System.Fat_Gen; package System.Fat_IEEE_Short_Float is pragma Pure; type Fat_IEEE_Short is digits 6; - pragma Float_Representation (IEEE_Float, Fat_IEEE_Short); -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package diff --git a/gcc/ada/s-fvadfl.ads b/gcc/ada/s-fvadfl.ads index a007fdf..c5fedaf 100644 --- a/gcc/ada/s-fvadfl.ads +++ b/gcc/ada/s-fvadfl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -32,17 +32,14 @@ -- This package contains an instantiation of the floating-point attribute -- runtime routines for VAX D-float for use on VMS targets. +-- TO BE REMOVED ??? + with System.Fat_Gen; package System.Fat_VAX_D_Float is pragma Pure; - pragma Warnings (Off); - -- This unit is normally used only for VMS, but we compile it for other - -- targets for the convenience of testing vms code using -gnatdm. - type Fat_VAX_D is digits 9; - pragma Float_Representation (VAX_Float, Fat_VAX_D); -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package diff --git a/gcc/ada/s-fvaffl.ads b/gcc/ada/s-fvaffl.ads index 13dd0c7..fddcb64 100644 --- a/gcc/ada/s-fvaffl.ads +++ b/gcc/ada/s-fvaffl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -32,17 +32,14 @@ -- This package contains an instantiation of the floating-point attribute -- runtime routines for VAX F-float for use on VMS targets. +-- TO BE REMOVED ??? + with System.Fat_Gen; package System.Fat_VAX_F_Float is pragma Pure; - pragma Warnings (Off); - -- This unit is normally used only for VMS, but we compile it for other - -- targets for the convenience of testing vms code using -gnatdm. - type Fat_VAX_F is digits 6; - pragma Float_Representation (VAX_Float, Fat_VAX_F); -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package diff --git a/gcc/ada/s-fvagfl.ads b/gcc/ada/s-fvagfl.ads index 18ce996..15bbc56 100644 --- a/gcc/ada/s-fvagfl.ads +++ b/gcc/ada/s-fvagfl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -32,17 +32,14 @@ -- This package contains an instantiation of the floating-point attribute -- runtime routines for VAX F-float for use on VMS targets. +-- TO BE REMOVED ??? + with System.Fat_Gen; package System.Fat_VAX_G_Float is pragma Pure; - pragma Warnings (Off); - -- This unit is normally used only for VMS, but we compile it for other - -- targets for the convenience of testing vms code using -gnatdm. - type Fat_VAX_G is digits 15; - pragma Float_Representation (VAX_Float, Fat_VAX_G); -- Note the only entity from this package that is accessed by Rtsfind -- is the name of the package instantiation. Entities within this package diff --git a/gcc/ada/s-vaflop.ads b/gcc/ada/s-vaflop.ads index 49120b7..1cb077e 100644 --- a/gcc/ada/s-vaflop.ads +++ b/gcc/ada/s-vaflop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2014, 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- -- @@ -30,34 +30,17 @@ ------------------------------------------------------------------------------ -- This package contains runtime routines for handling the non-IEEE --- floating-point formats used on the Vax and the Alpha. +-- floating-point formats used on the Vax. -package System.Vax_Float_Operations is +-- TO BE REMOVED ??? - pragma Warnings (Off); - -- Suppress warnings if not on Alpha/VAX +package System.Vax_Float_Operations is type D is digits 9; - pragma Float_Representation (VAX_Float, D); - -- D Float type on Vax - type G is digits 15; - pragma Float_Representation (VAX_Float, G); - -- G Float type on Vax - type F is digits 6; - pragma Float_Representation (VAX_Float, F); - -- F Float type on Vax - type S is digits 6; - pragma Float_Representation (IEEE_Float, S); - -- IEEE short - type T is digits 15; - pragma Float_Representation (IEEE_Float, T); - -- IEEE long - - pragma Warnings (On); type Q is range -2 ** 63 .. +(2 ** 63 - 1); -- 64-bit signed integer diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 951ec06..bff4539 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -536,18 +536,6 @@ package body Sem_Attr is end if; end; - -- Allow Address if the prefix is a reference to the AST_Entry - -- attribute. If expansion is active, the attribute will be - -- replaced by a function call, and address will work fine and - -- get the proper value, but if expansion is not active, then - -- the check here allows proper semantic analysis of the reference. - - elsif Nkind (P) = N_Attribute_Reference - and then Attribute_Name (P) = Name_AST_Entry - then - Rewrite (N, - New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); - -- Object is OK elsif Is_Object_Reference (P) then @@ -2514,7 +2502,7 @@ package body Sem_Attr is -- parameterless call. Entry attributes are handled specially below. if Is_Entity_Name (P) - and then not Nam_In (Aname, Name_Count, Name_Caller, Name_AST_Entry) + and then not Nam_In (Aname, Name_Count, Name_Caller) then Check_Parameterless_Call (P); end if; @@ -2522,10 +2510,10 @@ package body Sem_Attr is if Is_Overloaded (P) then -- Ada 2005 (AI-345): Since protected and task types have - -- primitive entry wrappers, the attributes Count, Caller and - -- AST_Entry require a context check + -- primitive entry wrappers, the attributes Count, and Caller + -- require a context check - if Nam_In (Aname, Name_Count, Name_Caller, Name_AST_Entry) then + if Nam_In (Aname, Name_Count, Name_Caller) then declare Count : Natural := 0; I : Interp_Index; @@ -2697,129 +2685,6 @@ package body Sem_Attr is Set_Etype (N, RTE (RE_Asm_Output_Operand)); - --------------- - -- AST_Entry -- - --------------- - - when Attribute_AST_Entry => AST_Entry : declare - Ent : Entity_Id; - Pref : Node_Id; - Ptyp : Entity_Id; - - Indexed : Boolean; - -- Indicates if entry family index is present. Note the coding - -- here handles the entry family case, but in fact it cannot be - -- executed currently, because pragma AST_Entry does not permit - -- the specification of an entry family. - - procedure Bad_AST_Entry; - -- Signal a bad AST_Entry pragma - - function OK_Entry (E : Entity_Id) return Boolean; - -- Checks that E is of an appropriate entity kind for an entry - -- (i.e. E_Entry if Index is False, or E_Entry_Family if Index - -- is set True for the entry family case). In the True case, - -- makes sure that Is_AST_Entry is set on the entry. - - ------------------- - -- Bad_AST_Entry -- - ------------------- - - procedure Bad_AST_Entry is - begin - Error_Attr_P ("prefix for % attribute must be task entry"); - end Bad_AST_Entry; - - -------------- - -- OK_Entry -- - -------------- - - function OK_Entry (E : Entity_Id) return Boolean is - Result : Boolean; - - begin - if Indexed then - Result := (Ekind (E) = E_Entry_Family); - else - Result := (Ekind (E) = E_Entry); - end if; - - if Result then - if not Is_AST_Entry (E) then - Error_Msg_Name_2 := Aname; - Error_Attr ("% attribute requires previous % pragma", P); - end if; - end if; - - return Result; - end OK_Entry; - - -- Start of processing for AST_Entry - - begin - Check_VMS (N); - Check_E0; - - -- Deal with entry family case - - if Nkind (P) = N_Indexed_Component then - Pref := Prefix (P); - Indexed := True; - else - Pref := P; - Indexed := False; - end if; - - Ptyp := Etype (Pref); - - if Ptyp = Any_Type or else Error_Posted (Pref) then - return; - end if; - - -- If the prefix is a selected component whose prefix is of an - -- access type, then introduce an explicit dereference. - -- ??? Could we reuse Check_Dereference here? - - if Nkind (Pref) = N_Selected_Component - and then Is_Access_Type (Ptyp) - then - Rewrite (Pref, - Make_Explicit_Dereference (Sloc (Pref), - Relocate_Node (Pref))); - Analyze_And_Resolve (Pref, Designated_Type (Ptyp)); - end if; - - -- Prefix can be of the form a.b, where a is a task object - -- and b is one of the entries of the corresponding task type. - - if Nkind (Pref) = N_Selected_Component - and then OK_Entry (Entity (Selector_Name (Pref))) - and then Is_Object_Reference (Prefix (Pref)) - and then Is_Task_Type (Etype (Prefix (Pref))) - then - null; - - -- Otherwise the prefix must be an entry of a containing task, - -- or of a variable of the enclosing task type. - - else - if Nkind_In (Pref, N_Identifier, N_Expanded_Name) then - Ent := Entity (Pref); - - if not OK_Entry (Ent) - or else not In_Open_Scopes (Scope (Ent)) - then - Bad_AST_Entry; - end if; - - else - Bad_AST_Entry; - end if; - end if; - - Set_Etype (N, RTE (RE_AST_Handler)); - end AST_Entry; - ----------------------------- -- Atomic_Always_Lock_Free -- ----------------------------- @@ -7858,20 +7723,6 @@ package body Sem_Attr is end if; end Alignment_Block; - --------------- - -- AST_Entry -- - --------------- - - -- Can only be folded in No_Ast_Handler case - - when Attribute_AST_Entry => - if not Is_AST_Entry (P_Entity) then - Rewrite (N, - New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc)); - else - null; - end if; - ----------------------------- -- Atomic_Always_Lock_Free -- ----------------------------- @@ -10837,16 +10688,6 @@ package body Sem_Attr is end if; end Address_Attribute; - --------------- - -- AST_Entry -- - --------------- - - -- Prefix of the AST_Entry attribute is an entry name which must - -- not be resolved, since this is definitely not an entry call. - - when Attribute_AST_Entry => - null; - ------------------ -- Body_Version -- ------------------ diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index 7583ab4..c70eb06d 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -89,23 +89,6 @@ package Sem_Attr is -- Machine_Code to construct machine instructions. See documentation -- in package Machine_Code in file s-maccod.ads. - --------------- - -- AST_Entry -- - --------------- - - Attribute_AST_Entry => True, - -- E'Ast_Entry, where E is a task entry, yields a value of the - -- predefined type System.DEC.AST_Handler, that enables the given - -- entry to be called when an AST occurs. If the name to which the - -- attribute applies has not been specified with the pragma AST_Entry, - -- the attribute returns the value No_Ast_Handler, and no AST occurs. - -- If the entry is for a task that is not callable (T'Callable False), - -- the exception program error is raised. If an AST occurs for an - -- entry of a task that is terminated, the program is erroneous. - -- - -- The attribute AST_Entry is supported only in OpenVMS versions - -- of GNAT. It will be rejected as illegal in other GNAT versions. - --------- -- Bit -- --------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index f952445..bf720be 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -10875,19 +10875,10 @@ package body Sem_Ch13 is then return 0; - -- Access types. Normally an access type cannot have a size smaller - -- than the size of System.Address. The exception is on VMS, where - -- we have short and long addresses, and it is possible for an access - -- type to have a short address size (and thus be less than the size - -- of System.Address itself). We simply skip the check for VMS, and - -- leave it to the back end to do the check. + -- Access types (cannot have size smaller than System.Address) elsif Is_Access_Type (T) then - if OpenVMS_On_Target then - return 0; - else - return System_Address_Size; - end if; + return System_Address_Size; -- Floating-point types @@ -12588,13 +12579,10 @@ package body Sem_Ch13 is and then Convention (Target) /= Convention (Source) and then Warn_On_Unchecked_Conversion then - -- Give warnings for subprogram pointers only on most targets. The - -- exception is VMS, where data pointers can have different lengths - -- depending on the pointer convention. + -- Give warnings for subprogram pointers only on most targets if Is_Access_Subprogram_Type (Target) or else Is_Access_Subprogram_Type (Source) - or else OpenVMS_On_Target then Error_Msg_N ("?z?conversion between pointers with different conventions!", diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 6d93a29..cfda659 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -16004,15 +16004,6 @@ package body Sem_Ch3 is return False; end if; - -- Avoid types not matching pragma Float_Representation, if present - - if (Opt.Float_Format = 'I' and then Float_Rep (E) /= IEEE_Binary) - or else - (Opt.Float_Format = 'V' and then Float_Rep (E) /= VAX_Native) - then - return False; - end if; - -- Check for matching range, if specified if Present (Spec) then diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 03e59d6..cb0faca 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -3388,12 +3388,11 @@ package body Sem_Ch8 is -- This procedure is called in the context of subprogram renaming, and -- thus the attribute must be one that is a subprogram. All of those - -- have at least one formal parameter, with the exceptions of AST_Entry - -- (which is a real oddity, it is odd that this can be renamed at all) - -- and the GNAT attribute 'Img, which GNAT treats as renameable. + -- have at least one formal parameter, with the exceptions of the GNAT + -- attribute 'Img, which GNAT treats as renameable. if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then - if Aname /= Name_AST_Entry and then Aname /= Name_Img then + if Aname /= Name_Img then Error_Msg_N ("subprogram renaming an attribute must have formals", N); return; @@ -3463,46 +3462,18 @@ package body Sem_Ch8 is end if; end if; - -- AST_Entry is an odd case. It doesn't really make much sense to allow - -- it to be renamed, but that's the DEC rule, so we have to do it right. - -- The point is that the AST_Entry call should be made now, and what the - -- function will return is the returned value. + -- Rewrite attribute node to have a list of expressions corresponding to + -- the subprogram formals. A renaming declaration is not a freeze point, + -- and the analysis of the attribute reference should not freeze the + -- type of the prefix. We use the original node in the renaming so that + -- its source location is preserved, and checks on stream attributes are + -- properly applied. - -- Note that there is no Expr_List in this case anyway + Attr_Node := Relocate_Node (Nam); + Set_Expressions (Attr_Node, Expr_List); - if Aname = Name_AST_Entry then - declare - Ent : constant Entity_Id := Make_Temporary (Loc, 'R', Nam); - Decl : Node_Id; - - begin - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Ent, - Object_Definition => - New_Occurrence_Of (RTE (RE_AST_Handler), Loc), - Expression => Nam, - Constant_Present => True); - - Set_Assignment_OK (Decl, True); - Insert_Action (N, Decl); - Attr_Node := Make_Identifier (Loc, Chars (Ent)); - end; - - -- For all other attributes, we rewrite the attribute node to have - -- a list of expressions corresponding to the subprogram formals. - -- A renaming declaration is not a freeze point, and the analysis of - -- the attribute reference should not freeze the type of the prefix. - -- We use the original node in the renaming so that its source location - -- is preserved, and checks on stream attributes are properly applied. - - else - Attr_Node := Relocate_Node (Nam); - Set_Expressions (Attr_Node, Expr_List); - - Set_Must_Not_Freeze (Attr_Node); - Set_Must_Not_Freeze (Prefix (Nam)); - end if; + Set_Must_Not_Freeze (Attr_Node); + Set_Must_Not_Freeze (Prefix (Nam)); -- Case of renaming a function @@ -3547,7 +3518,7 @@ package body Sem_Ch8 is -- In case of tagged types we add the body of the generated function to -- the freezing actions of the type (because in the general case such -- type is still not frozen). We exclude from this processing generic - -- formal subprograms found in instantiations and AST_Entry renamings. + -- formal subprograms found in instantiations. -- We must exclude VM targets and restricted run-time libraries because -- entity AST_Handler is defined in package System.Aux_Dec which is not diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 87695e7..ac5d494 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -68,7 +68,6 @@ with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; -with Sem_VFpt; use Sem_VFpt; with Sem_Warn; use Sem_Warn; with Stand; use Stand; with Sinfo; use Sinfo; @@ -125,8 +124,7 @@ package body Sem_Prag is -- If the External parameter is given as an identifier (or there is no -- External parameter, so that the Internal identifier is used), then -- the external name is the characters of the identifier, translated - -- to all upper case letters for OpenVMS versions of GNAT, and to all - -- lower case letters for all other versions + -- to all lower case letters. -- Note: the external name specified or implied by any of these special -- Import_xxx or Export_xxx pragmas override an external or link name @@ -3227,16 +3225,6 @@ package body Sem_Prag is -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is -- Name_Suppress for Disable and Name_Unsuppress for Enable. - 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. - procedure Process_Extended_Import_Export_Object_Pragma (Arg_Internal : Node_Id; Arg_External : Node_Id; @@ -6880,14 +6868,10 @@ package body Sem_Prag is elsif Is_Convention_Name (Cname) then C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1))); - -- In DEC VMS, it seems that there is an undocumented feature that - -- any unrecognized convention is treated as the default, which for - -- us is convention C. It does not seem so terrible to do this - -- unconditionally, silently in the VMS case, and with a warning - -- in the non-VMS case. + -- Otherwise warn on unrecognized convention else - if Warn_On_Export_Import and not OpenVMS_On_Target then + if Warn_On_Export_Import then Error_Msg_N ("??unrecognized convention name, C assumed", Get_Pragma_Arg (Arg1)); @@ -7168,69 +7152,6 @@ package body Sem_Prag is Analyze (N); end Process_Disable_Enable_Atomic_Sync; - ----------------------------------------------------- - -- Process_Extended_Import_Export_Exception_Pragma -- - ----------------------------------------------------- - - procedure Process_Extended_Import_Export_Exception_Pragma - (Arg_Internal : Node_Id; - Arg_External : Node_Id; - Arg_Form : Node_Id; - Arg_Code : Node_Id) - is - Def_Id : Entity_Id; - Code_Val : Uint; - - begin - if not OpenVMS_On_Target then - Error_Pragma - ("??pragma% ignored (applies only to Open'V'M'S)"); - end if; - - Process_Extended_Import_Export_Internal_Arg (Arg_Internal); - Def_Id := Entity (Arg_Internal); - - if Ekind (Def_Id) /= E_Exception then - Error_Pragma_Arg - ("pragma% must refer to declared exception", Arg_Internal); - end if; - - Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); - - if Present (Arg_Form) then - Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS); - end if; - - if Present (Arg_Form) - and then Chars (Arg_Form) = Name_Ada - then - null; - else - Set_Is_VMS_Exception (Def_Id); - Set_Exception_Code (Def_Id, No_Uint); - end if; - - if Present (Arg_Code) then - if not Is_VMS_Exception (Def_Id) then - Error_Pragma_Arg - ("Code option for pragma% not allowed for Ada case", - Arg_Code); - end if; - - Check_Arg_Is_OK_Static_Expression (Arg_Code, Any_Integer); - Code_Val := Expr_Value (Arg_Code); - - if not UI_Is_In_Int_Range (Code_Val) then - Error_Pragma_Arg - ("Code option for pragma% must be in 32-bit range", - Arg_Code); - - else - Set_Exception_Code (Def_Id, Code_Val); - end if; - end if; - end Process_Extended_Import_Export_Exception_Pragma; - ------------------------------------------------- -- Process_Extended_Import_Export_Internal_Arg -- ------------------------------------------------- @@ -9445,13 +9366,15 @@ 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 if Warn_On_Export_Import + + -- Only do this for something that was in the source. Not + -- clear if this can be False now (there used for sure to + -- be cases on VMS where it was False), but anyway the test + -- is harmless if not needed, so it is retained. + and then Comes_From_Source (Arg) then Error_Msg_NE @@ -9645,27 +9568,10 @@ package body Sem_Prag is -- form created by the parser. procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is - Class : Node_Id; - Param : Node_Id; - Mech_Name_Id : Name_Id; - - procedure Bad_Class; - pragma No_Return (Bad_Class); - -- Signal bad descriptor class name - procedure Bad_Mechanism; pragma No_Return (Bad_Mechanism); -- Signal bad mechanism name - --------------- - -- Bad_Class -- - --------------- - - procedure Bad_Class is - begin - Error_Pragma_Arg ("unrecognized descriptor class name", Class); - end Bad_Class; - ------------------------- -- Bad_Mechanism_Value -- ------------------------- @@ -9683,8 +9589,7 @@ package body Sem_Prag is ("mechanism for & has already been set", Mech_Name, Ent); end if; - -- MECHANISM_NAME ::= value | reference | descriptor | - -- short_descriptor + -- MECHANISM_NAME ::= value | reference if Nkind (Mech_Name) = N_Identifier then if Chars (Mech_Name) = Name_Value then @@ -9695,24 +9600,6 @@ package body Sem_Prag is Set_Mechanism (Ent, By_Reference); return; - elsif Chars (Mech_Name) = Name_Descriptor then - Check_VMS (Mech_Name); - - -- Descriptor => Short_Descriptor if pragma was given - - if Short_Descriptors then - Set_Mechanism (Ent, By_Short_Descriptor); - else - Set_Mechanism (Ent, By_Descriptor); - end if; - - return; - - elsif Chars (Mech_Name) = Name_Short_Descriptor then - Check_VMS (Mech_Name); - Set_Mechanism (Ent, By_Short_Descriptor); - return; - elsif Chars (Mech_Name) = Name_Copy then Error_Pragma_Arg ("bad mechanism name, Value assumed", Mech_Name); @@ -9721,141 +9608,9 @@ package body Sem_Prag is Bad_Mechanism; end if; - -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | - -- short_descriptor (CLASS_NAME) - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca - - -- Note: this form is parsed as an indexed component - - elsif Nkind (Mech_Name) = N_Indexed_Component then - Class := First (Expressions (Mech_Name)); - - if Nkind (Prefix (Mech_Name)) /= N_Identifier - or else - not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor, - Name_Short_Descriptor) - or else Present (Next (Class)) - then - Bad_Mechanism; - else - Mech_Name_Id := Chars (Prefix (Mech_Name)); - - -- Change Descriptor => Short_Descriptor if pragma was given - - if Mech_Name_Id = Name_Descriptor - and then Short_Descriptors - then - Mech_Name_Id := Name_Short_Descriptor; - end if; - end if; - - -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | - -- short_descriptor (Class => CLASS_NAME) - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca - - -- Note: this form is parsed as a function call - - elsif Nkind (Mech_Name) = N_Function_Call then - Param := First (Parameter_Associations (Mech_Name)); - - if Nkind (Name (Mech_Name)) /= N_Identifier - or else - not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor, - Name_Short_Descriptor) - or else Present (Next (Param)) - or else No (Selector_Name (Param)) - or else Chars (Selector_Name (Param)) /= Name_Class - then - Bad_Mechanism; - else - Class := Explicit_Actual_Parameter (Param); - Mech_Name_Id := Chars (Name (Mech_Name)); - end if; - else Bad_Mechanism; end if; - - -- Fall through here with Class set to descriptor class name - - Check_VMS (Mech_Name); - - if Nkind (Class) /= N_Identifier then - Bad_Class; - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_UBS - then - Set_Mechanism (Ent, By_Descriptor_UBS); - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_UBSB - then - Set_Mechanism (Ent, By_Descriptor_UBSB); - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_UBA - then - Set_Mechanism (Ent, By_Descriptor_UBA); - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_S - then - Set_Mechanism (Ent, By_Descriptor_S); - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_SB - then - Set_Mechanism (Ent, By_Descriptor_SB); - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_A - then - Set_Mechanism (Ent, By_Descriptor_A); - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_NCA - then - Set_Mechanism (Ent, By_Descriptor_NCA); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_UBS - then - Set_Mechanism (Ent, By_Short_Descriptor_UBS); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_UBSB - then - Set_Mechanism (Ent, By_Short_Descriptor_UBSB); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_UBA - then - Set_Mechanism (Ent, By_Short_Descriptor_UBA); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_S - then - Set_Mechanism (Ent, By_Short_Descriptor_S); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_SB - then - Set_Mechanism (Ent, By_Short_Descriptor_SB); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_A - then - Set_Mechanism (Ent, By_Short_Descriptor_A); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_NCA - then - Set_Mechanism (Ent, By_Short_Descriptor_NCA); - - else - Bad_Class; - end if; end Set_Mechanism_Value; -------------------------- @@ -11092,9 +10847,10 @@ package body Sem_Prag is Check_Arg_Count (0); -- If Address is a private type, then set the flag to allow - -- integer address values. If Address is not private (e.g. on - -- VMS, where it is an integer type), then this pragma has no - -- purpose, so it is simply ignored. + -- integer address values. If Address is not private, then + -- this pragma has no purpose, so it is simply ignored. Not + -- clear if there are any such targets now (VMS used to be + -- one such, but leave test in for the future anyway). if Opt.Address_Is_Private then Opt.Allow_Integer_Address := True; @@ -11566,63 +11322,6 @@ package body Sem_Prag is Analyze (N); end Attribute_Definition; - --------------- - -- AST_Entry -- - --------------- - - -- pragma AST_Entry (entry_IDENTIFIER); - - when Pragma_AST_Entry => AST_Entry : declare - Ent : Node_Id; - - begin - GNAT_Pragma; - Check_VMS (N); - Check_Arg_Count (1); - Check_No_Identifiers; - Check_Arg_Is_Local_Name (Arg1); - Ent := Entity (Get_Pragma_Arg (Arg1)); - - -- Note: the implementation of the AST_Entry pragma could handle - -- the entry family case fine, but for now we are consistent with - -- the DEC rules, and do not allow the pragma, which of course - -- has the effect of also forbidding the attribute. - - if Ekind (Ent) /= E_Entry then - Error_Pragma_Arg - ("pragma% argument must be simple entry name", Arg1); - - elsif Is_AST_Entry (Ent) then - Error_Pragma_Arg - ("duplicate % pragma for entry", Arg1); - - elsif Has_Homonym (Ent) then - Error_Pragma_Arg - ("pragma% argument cannot specify overloaded entry", Arg1); - - else - declare - FF : constant Entity_Id := First_Formal (Ent); - - begin - if Present (FF) then - if Present (Next_Formal (FF)) then - Error_Pragma_Arg - ("entry for pragma% can have only one argument", - Arg1); - - elsif Parameter_Mode (FF) /= E_In_Parameter then - Error_Pragma_Arg - ("entry parameter for pragma% must have mode IN", - Arg1); - end if; - end if; - end; - - Set_Is_AST_Entry (Ent); - end if; - end AST_Entry; - ------------------------------------------------------------------ -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes -- ------------------------------------------------------------------ @@ -13857,48 +13556,6 @@ package body Sem_Prag is end if; end Export; - ---------------------- - -- Export_Exception -- - ---------------------- - - -- pragma Export_Exception ( - -- [Internal =>] LOCAL_NAME - -- [, [External =>] EXTERNAL_SYMBOL] - -- [, [Form =>] Ada | VMS] - -- [, [Code =>] static_integer_EXPRESSION]); - - when Pragma_Export_Exception => Export_Exception : declare - Args : Args_List (1 .. 4); - Names : constant Name_List (1 .. 4) := ( - Name_Internal, - Name_External, - Name_Form, - Name_Code); - - Internal : Node_Id renames Args (1); - External : Node_Id renames Args (2); - Form : Node_Id renames Args (3); - Code : Node_Id renames Args (4); - - begin - GNAT_Pragma; - - if Inside_A_Generic then - Error_Pragma ("pragma% cannot be used for generic entities"); - end if; - - Gather_Associations (Names, Args); - Process_Extended_Import_Export_Exception_Pragma ( - Arg_Internal => Internal, - Arg_External => External, - Arg_Form => Form, - Arg_Code => Code); - - if not Is_VMS_Exception (Entity (Internal)) then - Set_Exported (Entity (Internal), Internal); - end if; - end Export_Exception; - --------------------- -- Export_Function -- --------------------- @@ -14388,106 +14045,6 @@ package body Sem_Prag is end if; end Finalize_Storage; - -------------------------- - -- Float_Representation -- - -------------------------- - - -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]); - - -- FLOAT_REP ::= VAX_Float | IEEE_Float - - when Pragma_Float_Representation => Float_Representation : declare - Argx : Node_Id; - Digs : Nat; - Ent : Entity_Id; - - begin - GNAT_Pragma; - - if Arg_Count = 1 then - Check_Valid_Configuration_Pragma; - else - Check_Arg_Count (2); - Check_Optional_Identifier (Arg2, Name_Entity); - Check_Arg_Is_Local_Name (Arg2); - end if; - - Check_No_Identifier (Arg1); - Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float); - - if not OpenVMS_On_Target then - if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then - Error_Pragma - ("??pragma% ignored (applies only to Open'V'M'S)"); - end if; - - return; - end if; - - -- One argument case - - if Arg_Count = 1 then - if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then - if Opt.Float_Format = 'I' then - Error_Pragma ("'I'E'E'E format previously specified"); - end if; - - Opt.Float_Format := 'V'; - - else - if Opt.Float_Format = 'V' then - Error_Pragma ("'V'A'X format previously specified"); - end if; - - Opt.Float_Format := 'I'; - end if; - - Set_Standard_Fpt_Formats; - - -- Two argument case - - else - Argx := Get_Pragma_Arg (Arg2); - - if not Is_Entity_Name (Argx) - or else not Is_Floating_Point_Type (Entity (Argx)) - then - Error_Pragma_Arg - ("second argument of% pragma must be floating-point type", - Arg2); - end if; - - Ent := Entity (Argx); - Digs := UI_To_Int (Digits_Value (Ent)); - - -- Two arguments, VAX_Float case - - if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then - case Digs is - when 6 => Set_F_Float (Ent); - when 9 => Set_D_Float (Ent); - when 15 => Set_G_Float (Ent); - - when others => - Error_Pragma_Arg - ("wrong digits value, must be 6,9 or 15", Arg2); - end case; - - -- Two arguments, IEEE_Float case - - else - case Digs is - when 6 => Set_IEEE_Short (Ent); - when 15 => Set_IEEE_Long (Ent); - - when others => - Error_Pragma_Arg - ("wrong digits value, must be 6 or 15", Arg2); - end case; - end if; - end if; - end Float_Representation; - ------------ -- Global -- ------------ @@ -14630,25 +14187,6 @@ package body Sem_Prag is end if; else - -- In VMS, the effect of IDENT is achieved by passing - -- --identification=name as a --for-linker switch. - - if OpenVMS_On_Target then - Start_String; - Store_String_Chars - ("--for-linker=--identification="); - String_To_Name_Buffer (Strval (Str)); - Store_String_Chars (Name_Buffer (1 .. Name_Len)); - - -- Only the last processed IDENT is saved. The main - -- purpose is so an IDENT associated with a main - -- procedure will be used in preference to an IDENT - -- associated with a with'd package. - - Replace_Linker_Option_String - (End_String, "--for-linker=--identification="); - end if; - Set_Ident_String (Current_Sem_Unit, Str); end if; @@ -14845,49 +14383,6 @@ package body Sem_Prag is Check_At_Most_N_Arguments (4); Process_Import_Or_Interface; - ---------------------- - -- Import_Exception -- - ---------------------- - - -- pragma Import_Exception ( - -- [Internal =>] LOCAL_NAME - -- [, [External =>] EXTERNAL_SYMBOL] - -- [, [Form =>] Ada | VMS] - -- [, [Code =>] static_integer_EXPRESSION]); - - when Pragma_Import_Exception => Import_Exception : declare - Args : Args_List (1 .. 4); - Names : constant Name_List (1 .. 4) := ( - Name_Internal, - Name_External, - Name_Form, - Name_Code); - - Internal : Node_Id renames Args (1); - External : Node_Id renames Args (2); - Form : Node_Id renames Args (3); - Code : Node_Id renames Args (4); - - begin - GNAT_Pragma; - Gather_Associations (Names, Args); - - if Present (External) and then Present (Code) then - Error_Pragma - ("cannot give both External and Code options for pragma%"); - end if; - - Process_Extended_Import_Export_Exception_Pragma ( - Arg_Internal => Internal, - Arg_External => External, - Arg_Form => Form, - Arg_Code => Code); - - if not Is_VMS_Exception (Entity (Internal)) then - Set_Imported (Entity (Internal)); - end if; - end Import_Exception; - --------------------- -- Import_Function -- --------------------- @@ -16692,65 +16187,6 @@ package body Sem_Prag is end if; end; - ---------------- - -- Long_Float -- - ---------------- - - -- pragma Long_Float (D_Float | G_Float); - - when Pragma_Long_Float => Long_Float : declare - begin - GNAT_Pragma; - Check_Valid_Configuration_Pragma; - Check_Arg_Count (1); - Check_No_Identifier (Arg1); - Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float); - - if not OpenVMS_On_Target then - Error_Pragma ("??pragma% ignored (applies only to Open'V'M'S)"); - end if; - - -- D_Float case - - if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then - if Opt.Float_Format_Long = 'G' then - Error_Pragma_Arg - ("G_Float previously specified", Arg1); - - elsif Current_Sem_Unit /= Main_Unit - and then Opt.Float_Format_Long /= 'D' - then - Error_Pragma_Arg - ("main unit not compiled with pragma Long_Float (D_Float)", - "\pragma% must be used consistently for whole partition", - Arg1); - - else - Opt.Float_Format_Long := 'D'; - end if; - - -- G_Float case (this is the default, does not need overriding) - - else - if Opt.Float_Format_Long = 'D' then - Error_Pragma ("D_Float previously specified"); - - elsif Current_Sem_Unit /= Main_Unit - and then Opt.Float_Format_Long /= 'G' - then - Error_Pragma_Arg - ("main unit not compiled with pragma Long_Float (G_Float)", - "\pragma% must be used consistently for whole partition", - Arg1); - - else - Opt.Float_Format_Long := 'G'; - end if; - end if; - - Set_Standard_Fpt_Formats; - end Long_Float; - ------------------- -- Loop_Optimize -- ------------------- @@ -18807,37 +18243,24 @@ package body Sem_Prag is Def_Id : Entity_Id; - procedure Check_Too_Long (Arg : Node_Id); - -- Posts message if the argument is an identifier with more - -- than 31 characters, or a string literal with more than - -- 31 characters, and we are operating under VMS - - -------------------- - -- Check_Too_Long -- - -------------------- + procedure Check_Arg (Arg : Node_Id); + -- Checks that argument is either a string literal or an + -- identifier, and posts error message if not. - procedure Check_Too_Long (Arg : Node_Id) is - X : constant Node_Id := Original_Node (Arg); + --------------- + -- Check_Arg -- + --------------- + procedure Check_Arg (Arg : Node_Id) is begin - if not Nkind_In (X, N_String_Literal, N_Identifier) then + if not Nkind_In (Original_Node (Arg), + N_String_Literal, + N_Identifier) + then Error_Pragma_Arg ("inappropriate argument for pragma %", Arg); end if; - - if OpenVMS_On_Target then - if (Nkind (X) = N_String_Literal - and then String_Length (Strval (X)) > 31) - or else - (Nkind (X) = N_Identifier - and then Length_Of_Name (Chars (X)) > 31) - then - Error_Pragma_Arg - ("argument for pragma % is longer than 31 characters", - Arg); - end if; - end if; - end Check_Too_Long; + end Check_Arg; -- Start of processing for Common_Object/Psect_Object @@ -18853,7 +18276,7 @@ package body Sem_Prag is ("pragma% must designate an object", Internal); end if; - Check_Too_Long (Internal); + Check_Arg (Internal); if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then Error_Pragma_Arg @@ -18906,12 +18329,11 @@ package body Sem_Prag is end if; if Present (Size) then - Check_Too_Long (Size); + Check_Arg (Size); end if; if Present (External) then Check_Arg_Is_External_Name (External); - Check_Too_Long (External); end if; -- If all error tests pass, link pragma on to the rep item chain @@ -25350,8 +24772,7 @@ package body Sem_Prag is -- 99 special processing required (e.g. for pragma Check) Sig_Flags : constant array (Pragma_Id) of Int := - (Pragma_AST_Entry => -1, - Pragma_Abort_Defer => -1, + (Pragma_Abort_Defer => -1, Pragma_Abstract_State => -1, Pragma_Ada_83 => -1, Pragma_Ada_95 => -1, @@ -25416,7 +24837,6 @@ package body Sem_Prag is Pragma_Eliminate => -1, Pragma_Enable_Atomic_Synchronization => -1, Pragma_Export => -1, - Pragma_Export_Exception => -1, Pragma_Export_Function => -1, Pragma_Export_Object => -1, Pragma_Export_Procedure => -1, @@ -25429,14 +24849,12 @@ package body Sem_Prag is Pragma_External_Name_Casing => -1, Pragma_Fast_Math => -1, Pragma_Finalize_Storage_Only => 0, - Pragma_Float_Representation => 0, Pragma_Global => -1, Pragma_Ident => -1, Pragma_Implementation_Defined => -1, Pragma_Implemented => -1, Pragma_Implicit_Packing => 0, Pragma_Import => +2, - Pragma_Import_Exception => 0, Pragma_Import_Function => 0, Pragma_Import_Object => 0, Pragma_Import_Procedure => 0, @@ -25469,7 +24887,6 @@ package body Sem_Prag is Pragma_List => -1, Pragma_Lock_Free => -1, Pragma_Locking_Policy => -1, - Pragma_Long_Float => -1, Pragma_Loop_Invariant => -1, Pragma_Loop_Optimize => -1, Pragma_Loop_Variant => -1, diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index 5a6cfba..aafa072 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -217,33 +217,30 @@ package body Snames is function Get_Pragma_Id (N : Name_Id) return Pragma_Id is begin - if N = Name_AST_Entry then - return Pragma_AST_Entry; - elsif N = Name_CPU then - return Pragma_CPU; - elsif N = Name_Dispatching_Domain then - return Pragma_Dispatching_Domain; - elsif N = Name_Fast_Math then - return Pragma_Fast_Math; - elsif N = Name_Interface then - return Pragma_Interface; - elsif N = Name_Interrupt_Priority then - return Pragma_Interrupt_Priority; - elsif N = Name_Lock_Free then - return Pragma_Lock_Free; - elsif N = Name_Priority then - return Pragma_Priority; - elsif N = Name_Relative_Deadline then - return Pragma_Relative_Deadline; - elsif N = Name_Storage_Size then - return Pragma_Storage_Size; - elsif N = Name_Storage_Unit then - return Pragma_Storage_Unit; - elsif N not in First_Pragma_Name .. Last_Pragma_Name then - return Unknown_Pragma; - else - return Pragma_Id'Val (N - First_Pragma_Name); - end if; + case N is + when Name_CPU => + return Pragma_CPU; + when Name_Dispatching_Domain => + return Pragma_Dispatching_Domain; + when Name_Fast_Math => + return Pragma_Fast_Math; + when Name_Interface => + return Pragma_Interface; + when Name_Interrupt_Priority => + return Pragma_Interrupt_Priority; + when Name_Lock_Free => + return Pragma_Lock_Free; + when Name_Priority => + return Pragma_Priority; + when Name_Storage_Size => + return Pragma_Storage_Size; + when Name_Storage_Unit => + return Pragma_Storage_Unit; + when First_Pragma_Name .. Last_Pragma_Name => + return Pragma_Id'Val (N - First_Pragma_Name); + when others => + return Unknown_Pragma; + end case; end Get_Pragma_Id; --------------------------- @@ -449,7 +446,6 @@ package body Snames is function Is_Pragma_Name (N : Name_Id) return Boolean is begin return N in First_Pragma_Name .. Last_Pragma_Name - or else N = Name_AST_Entry or else N = Name_CPU or else N = Name_Dispatching_Domain or else N = Name_Fast_Math diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index c8e555a..1488ce5 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -405,13 +405,11 @@ package Snames is -- Fast_Math. Name_Favor_Top_Level : constant Name_Id := N + $; -- GNAT - Name_Float_Representation : constant Name_Id := N + $; -- GNAT Name_Implicit_Packing : constant Name_Id := N + $; -- GNAT Name_Initialize_Scalars : constant Name_Id := N + $; -- GNAT Name_Interrupt_State : constant Name_Id := N + $; -- GNAT Name_License : constant Name_Id := N + $; -- GNAT Name_Locking_Policy : constant Name_Id := N + $; - Name_Long_Float : constant Name_Id := N + $; -- VMS Name_Loop_Optimize : constant Name_Id := N + $; -- GNAT Name_No_Run_Time : constant Name_Id := N + $; -- GNAT Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT @@ -457,12 +455,6 @@ package Snames is Name_Abort_Defer : constant Name_Id := N + $; -- GNAT Name_Abstract_State : constant Name_Id := N + $; -- GNAT Name_All_Calls_Remote : constant Name_Id := N + $; - - -- Note: AST_Entry is not in this list because its name matches the name of - -- the corresponding attribute. However, it is included in the definition - -- of the type Pragma_Id, and the functions Get_Pragma_Id and Is_Pragma_Id - -- correctly recognize and process Name_AST_Entry. - Name_Assert : constant Name_Id := N + $; -- Ada 05 Name_Assert_And_Cut : constant Name_Id := N + $; -- GNAT Name_Async_Readers : constant Name_Id := N + $; -- GNAT @@ -499,7 +491,6 @@ package Snames is Name_Elaborate_All : constant Name_Id := N + $; Name_Elaborate_Body : constant Name_Id := N + $; Name_Export : constant Name_Id := N + $; - Name_Export_Exception : constant Name_Id := N + $; -- VMS Name_Export_Function : constant Name_Id := N + $; -- GNAT Name_Export_Object : constant Name_Id := N + $; -- GNAT Name_Export_Procedure : constant Name_Id := N + $; -- GNAT @@ -512,7 +503,6 @@ package Snames is Name_Implementation_Defined : constant Name_Id := N + $; -- GNAT Name_Implemented : constant Name_Id := N + $; -- Ada 12 Name_Import : constant Name_Id := N + $; - Name_Import_Exception : constant Name_Id := N + $; -- VMS Name_Import_Function : constant Name_Id := N + $; -- GNAT Name_Import_Object : constant Name_Id := N + $; -- GNAT Name_Import_Procedure : constant Name_Id := N + $; -- GNAT @@ -838,7 +828,6 @@ package Snames is Name_Alignment : constant Name_Id := N + $; Name_Asm_Input : constant Name_Id := N + $; -- GNAT Name_Asm_Output : constant Name_Id := N + $; -- GNAT - Name_AST_Entry : constant Name_Id := N + $; -- VMS Name_Atomic_Always_Lock_Free : constant Name_Id := N + $; -- GNAT Name_Bit : constant Name_Id := N + $; -- GNAT Name_Bit_Order : constant Name_Id := N + $; @@ -1468,7 +1457,6 @@ package Snames is Attribute_Alignment, Attribute_Asm_Input, Attribute_Asm_Output, - Attribute_AST_Entry, Attribute_Atomic_Always_Lock_Free, Attribute_Bit, Attribute_Bit_Order, @@ -1761,13 +1749,11 @@ package Snames is Pragma_Extensions_Allowed, Pragma_External_Name_Casing, Pragma_Favor_Top_Level, - Pragma_Float_Representation, Pragma_Implicit_Packing, Pragma_Initialize_Scalars, Pragma_Interrupt_State, Pragma_License, Pragma_Locking_Policy, - Pragma_Long_Float, Pragma_Loop_Optimize, Pragma_No_Run_Time, Pragma_No_Strict_Aliasing, @@ -1841,7 +1827,6 @@ package Snames is Pragma_Elaborate_All, Pragma_Elaborate_Body, Pragma_Export, - Pragma_Export_Exception, Pragma_Export_Function, Pragma_Export_Object, Pragma_Export_Procedure, @@ -1854,7 +1839,6 @@ package Snames is Pragma_Implementation_Defined, Pragma_Implemented, Pragma_Import, - Pragma_Import_Exception, Pragma_Import_Function, Pragma_Import_Object, Pragma_Import_Procedure, @@ -1953,7 +1937,6 @@ package Snames is -- special processing required to deal with the fact that their names -- match existing attribute names. - Pragma_AST_Entry, Pragma_CPU, Pragma_Dispatching_Domain, Pragma_Fast_Math, @@ -2046,12 +2029,12 @@ package Snames is -- Test to see if the name N is the name of an operator symbol function Is_Pragma_Name (N : Name_Id) return Boolean; - -- Test to see if the name N is the name of a recognized pragma. Note that - -- pragmas AST_Entry, CPU, Dispatching_Domain, Fast_Math, - -- Interrupt_Priority, Lock_Free, Priority, Storage_Size, and Storage_Unit - -- are recognized as pragmas by this function even though their names are - -- separate from the other pragma names. For this reason, clients should - -- always use this function, rather than do range tests on Name_Id values. + -- Test to see if the name N is the name of a recognized pragma. Note + -- that pragmas CPU, Dispatching_Domain, Fast_Math, Interrupt_Priority, + -- Lock_Free, Priority, Storage_Size, and Storage_Unit are recognized + -- as pragmas by this function even though their names are separate from + -- the other pragma names. For this reason, clients should always use + -- this function, rather than do range tests on Name_Id values. function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean; -- Test to see if the name N is the name of a recognized configuration @@ -2091,10 +2074,8 @@ package Snames is -- Returns Id of pragma corresponding to given name. Returns Unknown_Pragma -- if N is not a name of a known (Ada defined or GNAT-specific) pragma. -- Note that the function also works correctly for names of pragmas that - -- are not included in the main list of pragma Names (AST_Entry, CPU, - -- Dispatching_Domain, Interrupt_Priority, Lock_Free, Priority, - -- Storage_Size, and Storage_Unit (e.g. Name_Storage_Size returns - -- Pragma_Storage_Size). + -- are not included in the main list of pragma Names (e.g. Name_CPU returns + -- Pragma_CPU). function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id; -- Returns Id of queuing policy corresponding to given name. It is an error -- 2.7.4