From c986420eb0a0d4a31192dc483dee3ced6edf513b Mon Sep 17 00:00:00 2001 From: Doug Rupp Date: Mon, 26 May 2008 17:15:05 +0200 Subject: [PATCH] 2008-05-26 Doug Rupp * s-vaflop.adb: (Return_D, Return_F, Return_G): New functions. * s-vaflop.ads: (Return_D, Return_F, Return_G): New functions. * exp_vfpt.adb: (Expand_Vax_Foreign_Return): New procedure * exp_vfpt.ads: (Expand_Vax_Foreign_Return): New procedure * rtsfind.ads: (RE_Return_D, RE_Return_F, RE_Return_G): New RE_Ids (RE_Return_D, RE_Return_F, RE_Return_G): New RE_Unit_Table elements * exp_ch6.adb: Import Exp_Vfpt (Expand_N_Function_Call): Call Expand_Vax_Foreign_Return. * s-vaflop-vms-alpha.adb: (Return_D, Return_F, Return_G): New functions. From-SVN: r135937 --- gcc/ada/exp_ch6.adb | 14 ++++++ gcc/ada/exp_vfpt.adb | 37 +++++++++++++- gcc/ada/exp_vfpt.ads | 6 ++- gcc/ada/rtsfind.ads | 6 +++ gcc/ada/s-vaflop-vms-alpha.adb | 45 ++++++++++++++++- gcc/ada/s-vaflop.adb | 41 +++++++++++++--- gcc/ada/s-vaflop.ads | 88 +++++++++++++++++++--------------- 7 files changed, 189 insertions(+), 48 deletions(-) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 9b471853552..804fcd6ba36 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -41,6 +41,7 @@ with Exp_Intr; use Exp_Intr; 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 Fname; use Fname; with Freeze; use Freeze; with Inline; use Inline; @@ -3963,6 +3964,19 @@ package body Exp_Ch6 is procedure Expand_N_Function_Call (N : Node_Id) is begin Expand_Call (N); + + -- Handle VAX Float return values from foreign compiled + -- functions. + if Vax_Float (Etype (N)) + and then Nkind (N) = N_Function_Call + and then not (Nkind (Parent (N)) = N_Type_Conversion + and then not Comes_From_Source (Parent (N))) + and then Present (Name (N)) + and then Present (Entity (Name (N))) + and then Has_Foreign_Convention (Entity (Name (N))) + then + Expand_Vax_Foreign_Return (N); + end if; end Expand_N_Function_Call; --------------------------------------- diff --git a/gcc/ada/exp_vfpt.adb b/gcc/ada/exp_vfpt.adb index 0537cf089d0..612842952f5 100644 --- a/gcc/ada/exp_vfpt.adb +++ b/gcc/ada/exp_vfpt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2008, 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- -- @@ -443,6 +443,41 @@ package body Exp_VFpt is Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks); end Expand_Vax_Conversion; + ------------------------------- + -- Expand_Vax_Foreign_Return -- + ------------------------------- + + procedure Expand_Vax_Foreign_Return (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Base_Type (Etype (N)); + Func : RE_Id; + Args : List_Id; + Atyp : Entity_Id; + Rtyp : constant Entity_Id := Etype (N); + begin + if Digits_Value (Typ) = VAXFF_Digits then + Func := RE_Return_F; + Atyp := RTE (RE_F); + elsif Digits_Value (Typ) = VAXDF_Digits then + Func := RE_Return_D; + Atyp := RTE (RE_D); + else pragma Assert (Digits_Value (Typ) = VAXGF_Digits); + Func := RE_Return_G; + Atyp := RTE (RE_G); + end if; + + Args := New_List (Convert_To (Atyp, N)); + + Rewrite (N, + Convert_To (Rtyp, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Func), Loc), + Parameter_Associations => Args))); + + Analyze_And_Resolve (N, Typ, Suppress => All_Checks); + + end Expand_Vax_Foreign_Return; + ----------------------------- -- Expand_Vax_Real_Literal -- ----------------------------- diff --git a/gcc/ada/exp_vfpt.ads b/gcc/ada/exp_vfpt.ads index 1652ad84ab5..8bf02e79fd8 100644 --- a/gcc/ada/exp_vfpt.ads +++ b/gcc/ada/exp_vfpt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -45,6 +45,10 @@ package Exp_VFpt is -- The node N is a type conversion node where either the source or the -- target type, or both, are Vax floating-point type. + procedure Expand_Vax_Foreign_Return (N : Node_Id); + -- The node N is a call to a foreign function that returns a Vax + -- float value in a floating point register. + procedure Expand_Vax_Real_Literal (N : Node_Id); -- The node N is a real literal node where the type is a Vax floating-point -- type. This procedure rewrites the node to eliminate the occurrence of diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 6fbfd9de895..76110c036ef 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1452,6 +1452,9 @@ package Rtsfind is RE_Mul_G, -- System.Vax_Float_Operations RE_Neg_F, -- System.Vax_Float_Operations RE_Neg_G, -- System.Vax_Float_Operations + RE_Return_D, -- System.Vax_Float_Operations + RE_Return_F, -- System.Vax_Float_Operations + RE_Return_G, -- System.Vax_Float_Operations RE_Sub_F, -- System.Vax_Float_Operations RE_Sub_G, -- System.Vax_Float_Operations @@ -2584,6 +2587,9 @@ package Rtsfind is RE_Mul_G => System_Vax_Float_Operations, RE_Neg_F => System_Vax_Float_Operations, RE_Neg_G => System_Vax_Float_Operations, + RE_Return_D => System_Vax_Float_Operations, + RE_Return_F => System_Vax_Float_Operations, + RE_Return_G => System_Vax_Float_Operations, RE_Sub_F => System_Vax_Float_Operations, RE_Sub_G => System_Vax_Float_Operations, diff --git a/gcc/ada/s-vaflop-vms-alpha.adb b/gcc/ada/s-vaflop-vms-alpha.adb index e7d561bed16..24c4b53829f 100644 --- a/gcc/ada/s-vaflop-vms-alpha.adb +++ b/gcc/ada/s-vaflop-vms-alpha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2008, Free Software Foundation, Inc. -- -- (Version for Alpha OpenVMS) -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- @@ -648,6 +648,49 @@ package body System.Vax_Float_Operations is Put_Line (G'Image (Arg)); end pg; + -------------- + -- Return_D -- + -------------- + + function Return_D (X : D) return D is + R : D; + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + Asm ("cvtdg $f0,$f0", Inputs => D'Asm_Input ("g", X), Clobber => "$f0", + Volatile => True); + Asm ("stg $f0,%0", D'Asm_Output ("=m", R), Volatile => True); + return R; + end Return_D; + + -------------- + -- Return_F -- + -------------- + + function Return_F (X : F) return F is + R : F; + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + Asm ("stf $f0,%0", F'Asm_Output ("=m", R), F'Asm_Input ("g", X), + Clobber => "$f0", Volatile => True); + return R; + end Return_F; + + -------------- + -- Return_G -- + -------------- + + function Return_G (X : G) return G is + R : G; + begin + -- The return value is already in $f0 so we need to trick the compiler + -- into thinking that we're moving X to $f0. + Asm ("stg $f0,%0", G'Asm_Output ("=m", R), G'Asm_Input ("g", X), + Clobber => "$f0", Volatile => True); + return R; + end Return_G; + ----------- -- Sub_F -- ----------- diff --git a/gcc/ada/s-vaflop.adb b/gcc/ada/s-vaflop.adb index 0741664082b..79e295f94c1 100644 --- a/gcc/ada/s-vaflop.adb +++ b/gcc/ada/s-vaflop.adb @@ -37,7 +37,7 @@ -- case where the -gnatdm switch is used to force testing of VMS features -- on non-VMS systems. -with System.IO; use System.IO; +with System.IO; package body System.Vax_Float_Operations is pragma Warnings (Off); @@ -94,7 +94,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_D (Arg : D) is begin - Put (D'Image (Arg)); + System.IO.Put (D'Image (Arg)); end Debug_Output_D; -------------------- @@ -103,7 +103,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_F (Arg : F) is begin - Put (F'Image (Arg)); + System.IO.Put (F'Image (Arg)); end Debug_Output_F; -------------------- @@ -112,7 +112,7 @@ package body System.Vax_Float_Operations is procedure Debug_Output_G (Arg : G) is begin - Put (G'Image (Arg)); + System.IO.Put (G'Image (Arg)); end Debug_Output_G; -------------------- @@ -352,7 +352,7 @@ package body System.Vax_Float_Operations is procedure pd (Arg : D) is begin - Put_Line (D'Image (Arg)); + System.IO.Put_Line (D'Image (Arg)); end pd; -------- @@ -361,7 +361,7 @@ package body System.Vax_Float_Operations is procedure pf (Arg : F) is begin - Put_Line (F'Image (Arg)); + System.IO.Put_Line (F'Image (Arg)); end pf; -------- @@ -370,7 +370,7 @@ package body System.Vax_Float_Operations is procedure pg (Arg : G) is begin - Put_Line (G'Image (Arg)); + System.IO.Put_Line (G'Image (Arg)); end pg; ------------ @@ -400,6 +400,33 @@ package body System.Vax_Float_Operations is return F (X); end S_To_F; + -------------- + -- Return_D -- + -------------- + + function Return_D (X : D) return D is + begin + return X; + end Return_D; + + -------------- + -- Return_F -- + -------------- + + function Return_F (X : F) return F is + begin + return X; + end Return_F; + + -------------- + -- Return_G -- + -------------- + + function Return_G (X : G) return G is + begin + return X; + end Return_G; + ----------- -- Sub_F -- ----------- diff --git a/gcc/ada/s-vaflop.ads b/gcc/ada/s-vaflop.ads index 47e991a3b33..d32fe9cb479 100644 --- a/gcc/ada/s-vaflop.ads +++ b/gcc/ada/s-vaflop.ads @@ -143,6 +143,15 @@ package System.Vax_Float_Operations is function Ne_G (X, Y : G) return Boolean; -- Compares for X /= Y + ---------------------- + -- Return Functions -- + ---------------------- + + function Return_D (X : D) return D; + function Return_F (X : F) return F; + function Return_G (X : G) return G; + -- Adjust the return register of an imported function + ---------------------------------- -- Routines for Valid Attribute -- ---------------------------------- @@ -190,43 +199,46 @@ package System.Vax_Float_Operations is -- types, and are retained for backwards compatibility. private - pragma Inline (D_To_G); - pragma Inline (F_To_G); - pragma Inline (F_To_Q); - pragma Inline (F_To_S); - pragma Inline (G_To_D); - pragma Inline (G_To_F); - pragma Inline (G_To_Q); - pragma Inline (G_To_T); - pragma Inline (Q_To_F); - pragma Inline (Q_To_G); - pragma Inline (S_To_F); - pragma Inline (T_To_G); - - pragma Inline (Abs_F); - pragma Inline (Abs_G); - pragma Inline (Add_F); - pragma Inline (Add_G); - pragma Inline (Div_G); - pragma Inline (Div_F); - pragma Inline (Mul_F); - pragma Inline (Mul_G); - pragma Inline (Neg_G); - pragma Inline (Neg_F); - pragma Inline (Sub_F); - pragma Inline (Sub_G); - - pragma Inline (Eq_F); - pragma Inline (Eq_G); - pragma Inline (Le_F); - pragma Inline (Le_G); - pragma Inline (Lt_F); - pragma Inline (Lt_G); - pragma Inline (Ne_F); - pragma Inline (Ne_G); - - pragma Inline (Valid_D); - pragma Inline (Valid_F); - pragma Inline (Valid_G); + pragma Inline_Always (D_To_G); + pragma Inline_Always (F_To_G); + pragma Inline_Always (F_To_Q); + pragma Inline_Always (F_To_S); + pragma Inline_Always (G_To_D); + pragma Inline_Always (G_To_F); + pragma Inline_Always (G_To_Q); + pragma Inline_Always (G_To_T); + pragma Inline_Always (Q_To_F); + pragma Inline_Always (Q_To_G); + pragma Inline_Always (S_To_F); + pragma Inline_Always (T_To_G); + + pragma Inline_Always (Abs_F); + pragma Inline_Always (Abs_G); + pragma Inline_Always (Add_F); + pragma Inline_Always (Add_G); + pragma Inline_Always (Div_G); + pragma Inline_Always (Div_F); + pragma Inline_Always (Mul_F); + pragma Inline_Always (Mul_G); + pragma Inline_Always (Neg_G); + pragma Inline_Always (Neg_F); + pragma Inline_Always (Return_D); + pragma Inline_Always (Return_F); + pragma Inline_Always (Return_G); + pragma Inline_Always (Sub_F); + pragma Inline_Always (Sub_G); + + pragma Inline_Always (Eq_F); + pragma Inline_Always (Eq_G); + pragma Inline_Always (Le_F); + pragma Inline_Always (Le_G); + pragma Inline_Always (Lt_F); + pragma Inline_Always (Lt_G); + pragma Inline_Always (Ne_F); + pragma Inline_Always (Ne_G); + + pragma Inline_Always (Valid_D); + pragma Inline_Always (Valid_F); + pragma Inline_Always (Valid_G); end System.Vax_Float_Operations; -- 2.30.2