[Ada] More VMS clean ups

Message ID	20140801081728.GA24833@adacore.com
State	New
Headers	show Return-Path: <gcc-patches-return-373815-incoming=patchwork.ozlabs.org@gcc.gnu.org> DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=xc5K34Qjr/p8HKiMoWtWydkegHDXvhUkZRZyKG0WJYO80mA8sl /5gtOEJ2vNKAQxSYrtePum2iNcjhKs7lb4RHgYrfD5qoxNF++tiw8f3QoARnsVZl aHzn9mOApSsmB++EIADXdztWKyevTkhWOpExzQKPNN3778538ByimA2ko= Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk Sender: gcc-patches-owner@gcc.gnu.org Date: Fri, 1 Aug 2014 04:17:28 -0400 From: Arnaud Charlet <charlet@adacore.com> To: gcc-patches@gcc.gnu.org Cc: Robert Dewar <dewar@adacore.com> Subject: [Ada] More VMS clean ups Message-ID: <20140801081728.GA24833@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="wac7ysb48OaltWcw" Content-Disposition: inline User-Agent: Mutt/1.5.21 (2010-09-15)

Index: inline.adb =================================================================== --- inline.adb (revision 213373) +++ inline.adb (working copy) @@ -165,10 +165,10 @@ function Has_Single_Return (N : Node_Id) return Boolean; -- In general we cannot inline functions that return unconstrained type. - -- However, we can handle such functions if all return statements return - -- a local variable that is the only declaration in the body of the - -- function. In that case the call can be replaced by that local - -- variable as is done for other inlined calls. + -- However, we can handle such functions if all return statements return a + -- local variable that is the only declaration in the body of the function. + -- In that case the call can be replaced by that local variable as is done + -- for other inlined calls. function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean; -- Return True if E is in the main unit or its spec or in a subunit @@ -429,7 +429,7 @@ procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id); -- Append Subp to the list of subprograms that cannot be inlined by - -- the backend + -- the backend. ---------------------------- -- Back_End_Cannot_Inline -- @@ -3332,7 +3332,7 @@ -- expanded into a procedure call which must be added after the -- object declaration. - if Is_Unc_Decl and then Back_End_Inlining then + if Is_Unc_Decl and Back_End_Inlining then Insert_Action_After (Parent (N), Blk); else Set_Expression (Parent (N), Empty); @@ -4329,9 +4329,9 @@ return False; end Has_Initialized_Type; - ------------------------ - -- Has_Single_Return -- - ------------------------ + ----------------------- + -- Has_Single_Return -- + ----------------------- function Has_Single_Return (N : Node_Id) return Boolean is Return_Statement : Node_Id := Empty; @@ -4376,8 +4376,8 @@ return Abandon; end if; - -- We can only inline a build-in-place function if - -- it has a single extended return. + -- We can only inline a build-in-place function if it has a single + -- extended return. elsif Nkind (N) = N_Extended_Return_Statement then if No (Return_Statement) then @@ -4572,6 +4572,8 @@ -- Number_Of_Statements -- -------------------------- + -- Why not List_Length??? + function Number_Of_Statements (Stats : List_Id) return Natural is Stat_Count : Integer := 0; Stmt : Node_Id; Index: inline.ads =================================================================== --- inline.ads (revision 213373) +++ inline.ads (working copy) @@ -131,6 +131,9 @@ Table_Increment => Alloc.Pending_Instantiations_Increment, Table_Name => "Pending_Descriptor"); + -- The following should be initialized in an init call in Frontend, we + -- have thoughts of making the frontend reusable in future ??? + Inlined_Calls : Elist_Id := No_Elist; -- List of frontend inlined calls @@ -242,13 +245,14 @@ function Has_Excluded_Declaration (Subp : Entity_Id; Decls : List_Id) return Boolean; - -- Check for declarations that make inlining not worthwhile inlining Subp + -- Check a list of declarations, Decls, that make the inlining of Subp not + -- worthwhile function Has_Excluded_Statement (Subp : Entity_Id; Stats : List_Id) return Boolean; - -- Check for statements that make inlining not worthwhile: any tasking - -- statement, nested at any level. + -- Check a list of statements, Stats, that make inlining of Subp not + -- worthwhile, including any tasking statement, nested at any level. procedure Register_Backend_Call (N : Node_Id); -- Append N to the list Backend_Calls Index: fe.h =================================================================== --- fe.h (revision 213353) +++ fe.h (working copy) @@ -154,11 +154,6 @@ extern Boolean Is_Fully_Repped_Tagged_Type (Entity_Id); -/* exp_vfpt: */ - -#define Get_Vax_Real_Literal_As_Signed exp_vfpt__get_vax_real_literal_as_signed -extern Ureal Get_Vax_Real_Literal_As_Signed (Node_Id); - /* lib: */ #define Cunit lib__cunit Index: einfo.adb =================================================================== --- einfo.adb (revision 213371) +++ einfo.adb (working copy) @@ -195,7 +195,6 @@ -- Component_Size Uint22 -- Corresponding_Remote_Type Node22 -- Enumeration_Rep_Expr Node22 - -- Exception_Code Uint22 -- Original_Record_Component Node22 -- Private_View Node22 -- Protected_Formal Node22 @@ -412,8 +411,6 @@ -- Is_Generic_Instance Flag130 -- No_Pool_Assigned Flag131 - -- Is_AST_Entry Flag132 - -- Is_VMS_Exception Flag133 -- Is_Optional_Parameter Flag134 -- Has_Aliased_Components Flag135 -- No_Strict_Aliasing Flag136 @@ -574,6 +571,9 @@ -- (unused) Flag2 -- (unused) Flag3 + -- (unused) Flag132 + -- (unused) Flag133 + -- (unused) Flag275 -- (unused) Flag276 -- (unused) Flag277 @@ -1182,12 +1182,6 @@ return Uint12 (Id); end Esize; - function Exception_Code (Id : E) return Uint is - begin - pragma Assert (Ekind (Id) = E_Exception); - return Uint22 (Id); - end Exception_Code; - function Extra_Accessibility (Id : E) return E is begin pragma Assert @@ -1901,12 +1895,6 @@ return Flag15 (Id); end Is_Aliased; - function Is_AST_Entry (Id : E) return B is - begin - pragma Assert (Is_Entry (Id)); - return Flag132 (Id); - end Is_AST_Entry; - function Is_Asynchronous (Id : E) return B is begin pragma Assert (Ekind (Id) = E_Procedure or else Is_Type (Id)); @@ -2420,11 +2408,6 @@ return Flag116 (Id); end Is_Visible_Lib_Unit; - function Is_VMS_Exception (Id : E) return B is - begin - return Flag133 (Id); - end Is_VMS_Exception; - function Is_Volatile (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -3931,12 +3914,6 @@ Set_Uint12 (Id, V); end Set_Esize; - procedure Set_Exception_Code (Id : E; V : U) is - begin - pragma Assert (Ekind (Id) = E_Exception); - Set_Uint22 (Id, V); - end Set_Exception_Code; - procedure Set_Extra_Accessibility (Id : E; V : E) is begin pragma Assert @@ -4677,12 +4654,6 @@ Set_Flag15 (Id, V); end Set_Is_Aliased; - procedure Set_Is_AST_Entry (Id : E; V : B := True) is - begin - pragma Assert (Is_Entry (Id)); - Set_Flag132 (Id, V); - end Set_Is_AST_Entry; - procedure Set_Is_Asynchronous (Id : E; V : B := True) is begin pragma Assert @@ -5227,12 +5198,6 @@ Set_Flag116 (Id, V); end Set_Is_Visible_Lib_Unit; - procedure Set_Is_VMS_Exception (Id : E; V : B := True) is - begin - pragma Assert (Ekind (Id) = E_Exception); - Set_Flag133 (Id, V); - end Set_Is_VMS_Exception; - procedure Set_Is_Volatile (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -8353,7 +8318,6 @@ W ("In_Package_Body", Flag48 (Id)); W ("In_Private_Part", Flag45 (Id)); W ("In_Use", Flag8 (Id)); - W ("Is_AST_Entry", Flag132 (Id)); W ("Is_Abstract_Subprogram", Flag19 (Id)); W ("Is_Abstract_Type", Flag146 (Id)); W ("Is_Local_Anonymous_Access", Flag194 (Id)); @@ -8454,7 +8418,6 @@ W ("Is_Unchecked_Union", Flag117 (Id)); W ("Is_Underlying_Record_View", Flag246 (Id)); W ("Is_Unsigned_Type", Flag144 (Id)); - W ("Is_VMS_Exception", Flag133 (Id)); W ("Is_Valued_Procedure", Flag127 (Id)); W ("Is_Visible_Formal", Flag206 (Id)); W ("Is_Visible_Lib_Unit", Flag116 (Id)); @@ -9307,9 +9270,6 @@ when E_Enumeration_Literal => Write_Str ("Enumeration_Rep_Expr"); - when E_Exception => - Write_Str ("Exception_Code"); - when E_Record_Type_With_Private | E_Record_Subtype_With_Private | E_Private_Type | Index: einfo.ads =================================================================== --- einfo.ads (revision 213369) +++ einfo.ads (working copy) @@ -1148,13 +1148,6 @@ -- Note one obscure case: for pragma Default_Storage_Pool (null), the -- Etype of the N_Null node is Empty. --- Exception_Code (Uint22) --- Defined in exception entities. Set to zero unless either an --- Import_Exception or Export_Exception pragma applies to the --- pragma and specifies a Code value. See description of these --- pragmas for details. Note that this field is relevant only if --- Is_VMS_Exception is set. - -- Extra_Formal (Node15) -- Defined in formal parameters in the non-generic case. Certain -- parameters require extra implicit information to be passed (e.g. the @@ -2146,13 +2139,6 @@ -- carry the keyword aliased, and on record components that have the -- keyword. For Ada 2012, also applies to formal parameters. --- Is_AST_Entry (Flag132) --- Defined in entry entities. Set if a valid pragma AST_Entry applies --- to the entry. This flag can only be set in OpenVMS versions of GNAT. --- Note: we also allow the flag to appear in entry families, but given --- the current implementation of the pragma AST_Entry, this flag will --- always be False in entry families. - -- Is_Atomic (Flag85) -- Defined in all type entities, and also in constants, components and -- variables. Set if a pragma Atomic or Shared applies to the entity. @@ -3060,12 +3046,6 @@ -- a separate flag must be used to indicate whether the names are visible -- by selected notation, or not. --- Is_VMS_Exception (Flag133) --- Defined in all entities. Set only for exception entities where the --- exception was specified in an Import_Exception or Export_Exception --- pragma with the VMS option for Form. See description of these pragmas --- for details. This flag can only be set in OpenVMS versions of GNAT. - -- Is_Volatile (Flag16) -- Defined in all type entities, and also in constants, components and -- variables. Set if a pragma Volatile applies to the entity. Also set @@ -5193,7 +5173,6 @@ -- Is_Trivial_Subprogram (Flag235) -- Is_Unchecked_Union (Flag117) -- Is_Visible_Formal (Flag206) - -- Is_VMS_Exception (Flag133) -- Kill_Elaboration_Checks (Flag32) -- Kill_Range_Checks (Flag33) -- Low_Bound_Tested (Flag205) @@ -5552,7 +5531,6 @@ -- Contract (Node34) -- Default_Expressions_Processed (Flag108) -- Entry_Accepted (Flag152) - -- Is_AST_Entry (Flag132) (for entry only) -- Needs_No_Actuals (Flag22) -- Sec_Stack_Needed_For_Return (Flag167) -- Uses_Sec_Stack (Flag95) @@ -5598,9 +5576,7 @@ -- Renamed_Entity (Node18) -- Register_Exception_Call (Node20) -- Interface_Name (Node21) - -- Exception_Code (Uint22) -- Discard_Names (Flag88) - -- Is_VMS_Exception (Flag133) -- Is_Raised (Flag224) -- E_Exception_Type @@ -6532,7 +6508,6 @@ function Enumeration_Rep_Expr (Id : E) return N; function Equivalent_Type (Id : E) return E; function Esize (Id : E) return U; - function Exception_Code (Id : E) return U; function Extra_Accessibility (Id : E) return E; function Extra_Accessibility_Of_Result (Id : E) return E; function Extra_Constrained (Id : E) return E; @@ -6654,7 +6629,6 @@ function Interface_Alias (Id : E) return E; function Interface_Name (Id : E) return N; function Interfaces (Id : E) return L; - function Is_AST_Entry (Id : E) return B; function Is_Abstract_Subprogram (Id : E) return B; function Is_Abstract_Type (Id : E) return B; function Is_Access_Constant (Id : E) return B; @@ -6749,7 +6723,6 @@ function Is_Unchecked_Union (Id : E) return B; function Is_Underlying_Record_View (Id : E) return B; function Is_Unsigned_Type (Id : E) return B; - function Is_VMS_Exception (Id : E) return B; function Is_Valued_Procedure (Id : E) return B; function Is_Visible_Formal (Id : E) return B; function Is_Visible_Lib_Unit (Id : E) return B; @@ -7168,7 +7141,6 @@ procedure Set_Enumeration_Rep_Expr (Id : E; V : N); procedure Set_Equivalent_Type (Id : E; V : E); procedure Set_Esize (Id : E; V : U); - procedure Set_Exception_Code (Id : E; V : U); procedure Set_Extra_Accessibility (Id : E; V : E); procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E); procedure Set_Extra_Constrained (Id : E; V : E); @@ -7289,7 +7261,6 @@ procedure Set_Interface_Alias (Id : E; V : E); procedure Set_Interface_Name (Id : E; V : N); procedure Set_Interfaces (Id : E; V : L); - procedure Set_Is_AST_Entry (Id : E; V : B := True); procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True); procedure Set_Is_Abstract_Type (Id : E; V : B := True); procedure Set_Is_Access_Constant (Id : E; V : B := True); @@ -7390,7 +7361,6 @@ procedure Set_Is_Unchecked_Union (Id : E; V : B := True); procedure Set_Is_Underlying_Record_View (Id : E; V : B := True); procedure Set_Is_Unsigned_Type (Id : E; V : B := True); - procedure Set_Is_VMS_Exception (Id : E; V : B := True); procedure Set_Is_Valued_Procedure (Id : E; V : B := True); procedure Set_Is_Visible_Formal (Id : E; V : B := True); procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True); @@ -7918,7 +7888,6 @@ pragma Inline (Enumeration_Rep_Expr); pragma Inline (Equivalent_Type); pragma Inline (Esize); - pragma Inline (Exception_Code); pragma Inline (Extra_Accessibility); pragma Inline (Extra_Accessibility_Of_Result); pragma Inline (Extra_Constrained); @@ -8036,7 +8005,6 @@ pragma Inline (Interface_Alias); pragma Inline (Interface_Name); pragma Inline (Interfaces); - pragma Inline (Is_AST_Entry); pragma Inline (Is_Abstract_Subprogram); pragma Inline (Is_Abstract_Type); pragma Inline (Is_Access_Constant); @@ -8178,7 +8146,6 @@ pragma Inline (Is_Unchecked_Union); pragma Inline (Is_Underlying_Record_View); pragma Inline (Is_Unsigned_Type); - pragma Inline (Is_VMS_Exception); pragma Inline (Is_Valued_Procedure); pragma Inline (Is_Visible_Formal); pragma Inline (Is_Visible_Lib_Unit); @@ -8400,7 +8367,6 @@ pragma Inline (Set_Enumeration_Rep_Expr); pragma Inline (Set_Equivalent_Type); pragma Inline (Set_Esize); - pragma Inline (Set_Exception_Code); pragma Inline (Set_Extra_Accessibility); pragma Inline (Set_Extra_Accessibility_Of_Result); pragma Inline (Set_Extra_Constrained); @@ -8518,7 +8484,6 @@ pragma Inline (Set_Interface_Alias); pragma Inline (Set_Interface_Name); pragma Inline (Set_Interfaces); - pragma Inline (Set_Is_AST_Entry); pragma Inline (Set_Is_Abstract_Subprogram); pragma Inline (Set_Is_Abstract_Type); pragma Inline (Set_Is_Access_Constant); @@ -8619,7 +8584,6 @@ pragma Inline (Set_Is_Unchecked_Union); pragma Inline (Set_Is_Underlying_Record_View); pragma Inline (Set_Is_Unsigned_Type); - pragma Inline (Set_Is_VMS_Exception); pragma Inline (Set_Is_Valued_Procedure); pragma Inline (Set_Is_Visible_Formal); pragma Inline (Set_Is_Visible_Lib_Unit); Index: sem_util.adb =================================================================== --- sem_util.adb (revision 213353) +++ sem_util.adb (working copy) @@ -2986,18 +2986,6 @@ end if; end Check_Unprotected_Access; - --------------- - -- Check_VMS -- - --------------- - - procedure Check_VMS (Construct : Node_Id) is - begin - if not OpenVMS_On_Target then - Error_Msg_N - ("this construct is allowed only in Open'V'M'S", Construct); - end if; - end Check_VMS; - ------------------------ -- Collect_Interfaces -- ------------------------ Index: sem_util.ads =================================================================== --- sem_util.ads (revision 213352) +++ sem_util.ads (working copy) @@ -319,12 +319,6 @@ -- and the context is external to the protected operation, to warn against -- a possible unlocked access to data. - procedure Check_VMS (Construct : Node_Id); - -- Check that this the target is OpenVMS, and if so, return with no effect, - -- otherwise post an error noting this can only be used with OpenVMS ports. - -- The argument is the construct in question and is used to post the error - -- message. - procedure Collect_Interfaces (T : Entity_Id; Ifaces_List : out Elist_Id; Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 213345) +++ exp_ch4.adb (working copy) @@ -42,7 +42,6 @@ with Exp_Pakd; use Exp_Pakd; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; -with Exp_VFpt; use Exp_VFpt; with Freeze; use Freeze; with Inline; use Inline; with Lib; use Lib; @@ -6446,12 +6445,6 @@ Attribute_Name => Name_First)), Reason => CE_Overflow_Check_Failed)); end if; - - -- Vax floating-point types case - - if Vax_Float (Etype (N)) then - Expand_Vax_Arith (N); - end if; end Expand_N_Op_Abs; --------------------- @@ -6493,11 +6486,6 @@ if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then Apply_Arithmetic_Overflow_Check (N); return; - - -- Vax floating-point types case - - elsif Vax_Float (Typ) then - Expand_Vax_Arith (N); end if; end Expand_N_Op_Add; @@ -6706,12 +6694,6 @@ elsif Is_Integer_Type (Typ) then Apply_Divide_Checks (N); - - -- Deal with Vax_Float - - elsif Vax_Float (Typ) then - Expand_Vax_Arith (N); - return; end if; end Expand_N_Op_Divide; @@ -7432,13 +7414,6 @@ Rewrite_Comparison (N); - -- If we still have comparison for Vax_Float, process it - - if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare then - Expand_Vax_Comparison (N); - return; - end if; - Optimize_Length_Comparison (N); end Expand_N_Op_Eq; @@ -7843,13 +7818,6 @@ Rewrite_Comparison (N); - -- If we still have comparison, and Vax_Float type, process it - - if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then - Expand_Vax_Comparison (N); - return; - end if; - Optimize_Length_Comparison (N); end Expand_N_Op_Ge; @@ -7893,13 +7861,6 @@ Rewrite_Comparison (N); - -- If we still have comparison, and Vax_Float type, process it - - if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then - Expand_Vax_Comparison (N); - return; - end if; - Optimize_Length_Comparison (N); end Expand_N_Op_Gt; @@ -7943,13 +7904,6 @@ Rewrite_Comparison (N); - -- If we still have comparison, and Vax_Float type, process it - - if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then - Expand_Vax_Comparison (N); - return; - end if; - Optimize_Length_Comparison (N); end Expand_N_Op_Le; @@ -7993,13 +7947,6 @@ Rewrite_Comparison (N); - -- If we still have comparison, and Vax_Float type, process it - - if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then - Expand_Vax_Comparison (N); - return; - end if; - Optimize_Length_Comparison (N); end Expand_N_Op_Lt; @@ -8033,11 +7980,6 @@ Right_Opnd => Right_Opnd (N))); Analyze_And_Resolve (N, Typ); - - -- Vax floating-point types case - - elsif Vax_Float (Etype (N)) then - Expand_Vax_Arith (N); end if; end Expand_N_Op_Minus; @@ -8510,12 +8452,6 @@ elsif Is_Signed_Integer_Type (Etype (N)) then Apply_Arithmetic_Overflow_Check (N); - - -- Deal with VAX float case - - elsif Vax_Float (Typ) then - Expand_Vax_Arith (N); - return; end if; end Expand_N_Op_Multiply; @@ -8554,13 +8490,6 @@ Rewrite_Comparison (N); - -- If we still have comparison for Vax_Float, process it - - if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare then - Expand_Vax_Comparison (N); - return; - end if; - -- For all cases other than elementary types, we rewrite node as the -- negation of an equality operation, and reanalyze. The equality to be -- used is defined in the same scope and has the same signature. This @@ -9290,11 +9219,6 @@ if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then Apply_Arithmetic_Overflow_Check (N); - - -- VAX floating-point types case - - elsif Vax_Float (Typ) then - Expand_Vax_Arith (N); end if; end Expand_N_Op_Subtract; @@ -11009,16 +10933,6 @@ end; end if; - -- Final step, if the result is a type conversion involving Vax_Float - -- types, then it is subject for further special processing. - - if Nkind (N) = N_Type_Conversion - and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type)) - then - Expand_Vax_Conversion (N); - goto Done; - end if; - -- Here at end of processing <<Done>> Index: exp_ch11.adb =================================================================== --- exp_ch11.adb (revision 213371) +++ exp_ch11.adb (working copy) @@ -24,7 +24,6 @@ ------------------------------------------------------------------------------ with Atree; use Atree; -with Casing; use Casing; with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; @@ -1685,59 +1684,17 @@ Str := String_From_Name_Buffer; - -- For VMS exceptions, convert the raise into a call to - -- lib$stop so it will be handled by __gnat_error_handler. + -- Convert raise to call to the Raise_Exception routine - if Is_VMS_Exception (Id) then - declare - Excep_Image : String_Id; - Cond : Node_Id; - - begin - 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; - - if Exception_Code (Id) /= No_Uint then - Cond := - Make_Integer_Literal (Loc, Exception_Code (Id)); - else - Cond := - Unchecked_Convert_To (Standard_Integer, - Make_Function_Call (Loc, - Name => New_Occurrence_Of - (RTE (RE_Import_Value), Loc), - Parameter_Associations => New_List - (Make_String_Literal (Loc, - Strval => Excep_Image)))); - end if; - - Rewrite (N, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Lib_Stop), Loc), - Parameter_Associations => New_List (Cond))); - Analyze_And_Resolve (Cond, Standard_Integer); - end; - - -- Not VMS exception case, convert raise to call to the - -- Raise_Exception routine. - - else - Rewrite (N, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Name (N), - Attribute_Name => Name_Identity), - Make_String_Literal (Loc, - Strval => Str)))); - end if; + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Name (N), + Attribute_Name => Name_Identity), + Make_String_Literal (Loc, Strval => Str)))); end; -- Case of no name present (reraise). We rewrite the raise to: Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 213373) +++ exp_ch6.adb (working copy) @@ -43,7 +43,6 @@ with Exp_Prag; use Exp_Prag; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; -with Exp_VFpt; use Exp_VFpt; with Fname; use Fname; with Freeze; use Freeze; with Inline; use Inline; @@ -3926,19 +3925,19 @@ -- Back end inlining: let the back end handle it elsif No (Unit_Declaration_Node (Subp)) - or else - Nkind (Unit_Declaration_Node (Subp)) /= N_Subprogram_Declaration - or else - No (Body_To_Inline (Unit_Declaration_Node (Subp))) + or else Nkind (Unit_Declaration_Node (Subp)) /= + N_Subprogram_Declaration + or else No (Body_To_Inline (Unit_Declaration_Node (Subp))) then Add_Inlined_Body (Subp); Register_Backend_Call (Call_Node); - -- Frontend expansion of supported functions returning unconstrained - -- types + -- Frontend expands supported functions returning unconstrained types - else pragma Assert (Ekind (Subp) = E_Function - and then Returns_Unconstrained_Type (Subp)); + else + pragma Assert (Ekind (Subp) = E_Function + and then Returns_Unconstrained_Type (Subp)); + declare Spec : constant Node_Id := Unit_Declaration_Node (Subp); @@ -5201,21 +5200,6 @@ procedure Expand_N_Function_Call (N : Node_Id) is begin Expand_Call (N); - - -- If the return value of a foreign compiled function is VAX Float, then - -- expand the return (adjusts the location of the return value on - -- Alpha/VMS, no-op everywhere else). - -- Comes_From_Source intercepts recursive expansion. - - if Nkind (N) = N_Function_Call - and then Vax_Float (Etype (N)) - and then Present (Name (N)) - and then Present (Entity (Name (N))) - and then Has_Foreign_Convention (Entity (Name (N))) - and then Comes_From_Source (Parent (N)) - then - Expand_Vax_Foreign_Return (N); - end if; end Expand_N_Function_Call; --------------------------------------- Index: cstand.adb =================================================================== --- cstand.adb (revision 213369) +++ cstand.adb (working copy) @@ -467,10 +467,9 @@ procedure Build_Exception (S : Standard_Entity_Type) is begin - Set_Ekind (Standard_Entity (S), E_Exception); - Set_Etype (Standard_Entity (S), Standard_Exception_Type); - Set_Exception_Code (Standard_Entity (S), Uint_0); - Set_Is_Public (Standard_Entity (S), True); + Set_Ekind (Standard_Entity (S), E_Exception); + Set_Etype (Standard_Entity (S), Standard_Exception_Type); + Set_Is_Public (Standard_Entity (S), True); Decl := Make_Exception_Declaration (Stloc, @@ -1590,7 +1589,6 @@ E_Id := Standard_Entity (S_Numeric_Error); Set_Ekind (E_Id, E_Exception); - Set_Exception_Code (E_Id, Uint_0); Set_Etype (E_Id, Standard_Exception_Type); Set_Is_Public (E_Id); Set_Renamed_Entity (E_Id, Standard_Entity (S_Constraint_Error)); @@ -1607,12 +1605,11 @@ -- Abort_Signal is an entity that does not get made visible Abort_Signal := New_Standard_Entity; - Set_Chars (Abort_Signal, Name_uAbort_Signal); - Set_Ekind (Abort_Signal, E_Exception); - Set_Exception_Code (Abort_Signal, Uint_0); - Set_Etype (Abort_Signal, Standard_Exception_Type); - Set_Scope (Abort_Signal, Standard_Standard); - Set_Is_Public (Abort_Signal, True); + Set_Chars (Abort_Signal, Name_uAbort_Signal); + Set_Ekind (Abort_Signal, E_Exception); + Set_Etype (Abort_Signal, Standard_Exception_Type); + Set_Scope (Abort_Signal, Standard_Standard); + Set_Is_Public (Abort_Signal, True); Decl := Make_Exception_Declaration (Stloc, Defining_Identifier => Abort_Signal); Index: sem_mech.adb =================================================================== --- sem_mech.adb (revision 213263) +++ sem_mech.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-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- -- @@ -27,10 +27,8 @@ with Einfo; use Einfo; with Errout; use Errout; with Namet; use Namet; -with Nlists; use Nlists; with Sem; use Sem; with Sem_Aux; use Sem_Aux; -with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; @@ -43,19 +41,13 @@ ------------------------- procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is - Class : Node_Id; - Param : Node_Id; - procedure Bad_Class; - -- Signal bad descriptor class name - procedure Bad_Mechanism; -- Signal bad mechanism name - procedure Bad_Class is - begin - Error_Msg_N ("unrecognized descriptor class name", Class); - end Bad_Class; + ------------------- + -- Bad_Mechanism -- + ------------------- procedure Bad_Mechanism is begin @@ -70,166 +62,26 @@ ("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 Set_Mechanism_With_Checks (Ent, By_Copy, Mech_Name); - return; elsif Chars (Mech_Name) = Name_Reference then Set_Mechanism_With_Checks (Ent, By_Reference, Mech_Name); - return; - elsif Chars (Mech_Name) = Name_Descriptor then - Check_VMS (Mech_Name); - Set_Mechanism_With_Checks (Ent, By_Descriptor, Mech_Name); - return; - - elsif Chars (Mech_Name) = Name_Short_Descriptor then - Check_VMS (Mech_Name); - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor, Mech_Name); - return; - elsif Chars (Mech_Name) = Name_Copy then Error_Msg_N ("bad mechanism name, Value assumed", Mech_Name); Set_Mechanism (Ent, By_Copy); else Bad_Mechanism; - return; 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; - return; - 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; - return; - else - Class := Explicit_Actual_Parameter (Param); - end if; - else Bad_Mechanism; - return; end if; - - -- Fall through here with Class set to descriptor class name - - Check_VMS (Mech_Name); - - if Nkind (Class) /= N_Identifier then - Bad_Class; - return; - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_UBS - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_UBSB - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_UBA - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_S - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_S, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_SB - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_SB, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_A - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_A, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_NCA - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_UBS - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBS, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_UBSB - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBSB, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_UBA - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBA, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_S - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_S, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_SB - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_SB, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_A - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_A, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_NCA - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_NCA, Mech_Name); - - else - Bad_Class; - return; - end if; end Set_Mechanism_Value; ------------------------------- Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 213373) +++ sem_ch6.adb (working copy) @@ -3571,7 +3571,7 @@ if not Back_End_Inlining then if Has_Pragma_Inline_Always (Spec_Id) - or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining) + or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining) then Build_Body_To_Inline (N, Spec_Id); end if; Index: sem_ch8.adb =================================================================== --- sem_ch8.adb (revision 213369) +++ sem_ch8.adb (working copy) @@ -558,7 +558,6 @@ Analyze (Nam); Set_Ekind (Id, E_Exception); - Set_Exception_Code (Id, Uint_0); Set_Etype (Id, Standard_Exception_Type); Set_Is_Pure (Id, Is_Pure (Current_Scope)); Index: sem_ch11.adb =================================================================== --- sem_ch11.adb (revision 213263) +++ sem_ch11.adb (working copy) @@ -46,7 +46,6 @@ with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Stand; use Stand; -with Uintp; use Uintp; package body Sem_Ch11 is @@ -61,7 +60,6 @@ Generate_Definition (Id); Enter_Name (Id); Set_Ekind (Id, E_Exception); - Set_Exception_Code (Id, Uint_0); Set_Etype (Id, Standard_Exception_Type); Set_Is_Statically_Allocated (Id); Set_Is_Pure (Id, PF); Index: snames.ads-tmpl =================================================================== --- snames.ads-tmpl (revision 213369) +++ snames.ads-tmpl (working copy) @@ -697,7 +697,6 @@ Name_Copy : constant Name_Id := N + $; Name_D_Float : constant Name_Id := N + $; Name_Decreases : constant Name_Id := N + $; - Name_Descriptor : constant Name_Id := N + $; Name_Disable : constant Name_Id := N + $; Name_Dot_Replacement : constant Name_Id := N + $; Name_Dynamic : constant Name_Id := N + $; @@ -775,7 +774,6 @@ Name_Secondary_Stack_Size : constant Name_Id := N + $; Name_Section : constant Name_Id := N + $; Name_Semaphore : constant Name_Id := N + $; - Name_Short_Descriptor : constant Name_Id := N + $; Name_Simple_Barriers : constant Name_Id := N + $; Name_SPARK : constant Name_Id := N + $; Name_SPARK_05 : constant Name_Id := N + $;

[Ada] More VMS clean ups

Commit Message

Patch