2008-05-26 Doug Rupp <rupp@adacore.com>

	* 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

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 9b47185..804fcd6 100644 (file)
--- 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 0537cf0..6128429 100644 (file)
--- 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 1652ad8..8bf02e7 100644 (file)
--- 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 6fbfd9d..76110c0 100644 (file)
--- 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 e7d561b..24c4b53 100644 (file)
--- 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 0741664..79e295f 100644 (file)
--- 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 47e991a..d32fe9c 100644 (file)
--- 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;