URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [exp_vfpt.adb] - Blame information for rev 826

Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             E X P _ V F P T                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          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- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Atree;    use Atree;
with Einfo;    use Einfo;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Rtsfind;  use Rtsfind;
with Sem_Res;  use Sem_Res;
with Sinfo;    use Sinfo;
with Stand;    use Stand;
with Tbuild;   use Tbuild;
with Ttypef;   use Ttypef;
with Uintp;    use Uintp;
with Urealp;   use Urealp;
 
package body Exp_VFpt is
 
   ----------------------
   -- Expand_Vax_Arith --
   ----------------------
 
   procedure Expand_Vax_Arith (N : Node_Id) is
      Loc   : constant Source_Ptr := Sloc (N);
      Typ   : constant Entity_Id  := Base_Type (Etype (N));
      Typc  : Character;
      Atyp  : Entity_Id;
      Func  : RE_Id;
      Args  : List_Id;
 
   begin
      --  Get arithmetic type, note that we do D stuff in G
 
      if Digits_Value (Typ) = VAXFF_Digits then
         Typc := 'F';
         Atyp := RTE (RE_F);
      else
         Typc := 'G';
         Atyp := RTE (RE_G);
      end if;
 
      case Nkind (N) is
 
         when N_Op_Abs =>
            if Typc = 'F' then
               Func := RE_Abs_F;
            else
               Func := RE_Abs_G;
            end if;
 
         when N_Op_Add =>
            if Typc = 'F' then
               Func := RE_Add_F;
            else
               Func := RE_Add_G;
            end if;
 
         when N_Op_Divide =>
            if Typc = 'F' then
               Func := RE_Div_F;
            else
               Func := RE_Div_G;
            end if;
 
         when N_Op_Multiply =>
            if Typc = 'F' then
               Func := RE_Mul_F;
            else
               Func := RE_Mul_G;
            end if;
 
         when N_Op_Minus =>
            if Typc = 'F' then
               Func := RE_Neg_F;
            else
               Func := RE_Neg_G;
            end if;
 
         when N_Op_Subtract =>
            if Typc = 'F' then
               Func := RE_Sub_F;
            else
               Func := RE_Sub_G;
            end if;
 
         when others =>
            Func := RE_Null;
            raise Program_Error;
 
      end case;
 
      Args := New_List;
 
      if Nkind (N) in N_Binary_Op then
         Append_To (Args,
           Convert_To (Atyp, Left_Opnd (N)));
      end if;
 
      Append_To (Args,
        Convert_To (Atyp, Right_Opnd (N)));
 
      Rewrite (N,
        Convert_To (Typ,
          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_Arith;
 
   ---------------------------
   -- Expand_Vax_Comparison --
   ---------------------------
 
   procedure Expand_Vax_Comparison (N : Node_Id) is
      Loc   : constant Source_Ptr := Sloc (N);
      Typ   : constant Entity_Id  := Base_Type (Etype (Left_Opnd (N)));
      Typc  : Character;
      Func  : RE_Id;
      Atyp  : Entity_Id;
      Revrs : Boolean := False;
      Args  : List_Id;
 
   begin
      --  Get arithmetic type, note that we do D stuff in G
 
      if Digits_Value (Typ) = VAXFF_Digits then
         Typc := 'F';
         Atyp := RTE (RE_F);
      else
         Typc := 'G';
         Atyp := RTE (RE_G);
      end if;
 
      case Nkind (N) is
 
         when N_Op_Eq =>
            if Typc = 'F' then
               Func := RE_Eq_F;
            else
               Func := RE_Eq_G;
            end if;
 
         when N_Op_Ge =>
            if Typc = 'F' then
               Func := RE_Le_F;
            else
               Func := RE_Le_G;
            end if;
 
            Revrs := True;
 
         when N_Op_Gt =>
            if Typc = 'F' then
               Func := RE_Lt_F;
            else
               Func := RE_Lt_G;
            end if;
 
            Revrs := True;
 
         when N_Op_Le =>
            if Typc = 'F' then
               Func := RE_Le_F;
            else
               Func := RE_Le_G;
            end if;
 
         when N_Op_Lt =>
            if Typc = 'F' then
               Func := RE_Lt_F;
            else
               Func := RE_Lt_G;
            end if;
 
         when N_Op_Ne =>
            if Typc = 'F' then
               Func := RE_Ne_F;
            else
               Func := RE_Ne_G;
            end if;
 
         when others =>
            Func := RE_Null;
            raise Program_Error;
 
      end case;
 
      if not Revrs then
         Args := New_List (
           Convert_To (Atyp, Left_Opnd  (N)),
           Convert_To (Atyp, Right_Opnd (N)));
 
      else
         Args := New_List (
           Convert_To (Atyp, Right_Opnd (N)),
           Convert_To (Atyp, Left_Opnd  (N)));
      end if;
 
      Rewrite (N,
        Make_Function_Call (Loc,
          Name => New_Occurrence_Of (RTE (Func), Loc),
          Parameter_Associations => Args));
 
      Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
   end Expand_Vax_Comparison;
 
   ---------------------------
   -- Expand_Vax_Conversion --
   ---------------------------
 
   procedure Expand_Vax_Conversion (N : Node_Id) is
      Loc   : constant Source_Ptr := Sloc (N);
      Expr  : constant Node_Id    := Expression (N);
      S_Typ : constant Entity_Id  := Base_Type (Etype (Expr));
      T_Typ : constant Entity_Id  := Base_Type (Etype (N));
 
      CallS : RE_Id;
      CallT : RE_Id;
      Func  : RE_Id;
 
      function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id;
      --  Given one of the two types T, determines the corresponding call
      --  type, i.e. the type to be used for the call (or the result of
      --  the call). The actual operand is converted to (or from) this type.
      --  Otyp is the other type, which is useful in figuring out the result.
      --  The result returned is the RE_Id value for the type entity.
 
      function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id;
      --  Find the predefined integer type that has the same size as the
      --  fixed-point type T, for use in fixed/float conversions.
 
      ---------------
      -- Call_Type --
      ---------------
 
      function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is
      begin
         --  Vax float formats
 
         if Vax_Float (T) then
            if Digits_Value (T) = VAXFF_Digits then
               return RE_F;
 
            elsif Digits_Value (T) = VAXGF_Digits then
               return RE_G;
 
            --  For D_Float, leave it as D float if the other operand is
            --  G_Float, since this is the one conversion that is properly
            --  supported for D_Float, but otherwise, use G_Float.
 
            else pragma Assert (Digits_Value (T) = VAXDF_Digits);
 
               if Vax_Float (Otyp)
                 and then Digits_Value (Otyp) = VAXGF_Digits
               then
                  return RE_D;
               else
                  return RE_G;
               end if;
            end if;
 
         --  For all discrete types, use 64-bit integer
 
         elsif Is_Discrete_Type (T) then
            return RE_Q;
 
         --  For all real types (other than Vax float format), we use the
         --  IEEE float-type which corresponds in length to the other type
         --  (which is Vax Float).
 
         else pragma Assert (Is_Real_Type (T));
 
            if Digits_Value (Otyp) = VAXFF_Digits then
               return RE_S;
            else
               return RE_T;
            end if;
         end if;
      end Call_Type;
 
      -------------------------------------------------
      -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed --
      -------------------------------------------------
 
      function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is
      begin
         if Esize (T) = Esize (Standard_Long_Long_Integer) then
            return Standard_Long_Long_Integer;
         elsif Esize (T) = Esize (Standard_Long_Integer) then
            return  Standard_Long_Integer;
         else
            return Standard_Integer;
         end if;
      end Equivalent_Integer_Type;
 
   --  Start of processing for Expand_Vax_Conversion;
 
   begin
      --  If input and output are the same Vax type, we change the
      --  conversion to be an unchecked conversion and that's it.
 
      if Vax_Float (S_Typ) and then Vax_Float (T_Typ)
        and then Digits_Value (S_Typ) = Digits_Value (T_Typ)
      then
         Rewrite (N,
           Unchecked_Convert_To (T_Typ, Expr));
 
      --  Case of conversion of fixed-point type to Vax_Float type
 
      elsif Is_Fixed_Point_Type (S_Typ) then
 
         --  If Conversion_OK set, then we introduce an intermediate IEEE
         --  target type since we are expecting the code generator to handle
         --  the case of integer to IEEE float.
 
         if Conversion_OK (N) then
            Rewrite (N,
              Convert_To (T_Typ, OK_Convert_To (Universal_Real, Expr)));
 
         --  Otherwise, convert the scaled integer value to the target type,
         --  and multiply by 'Small of type.
 
         else
            Rewrite (N,
               Make_Op_Multiply (Loc,
                 Left_Opnd =>
                   Make_Type_Conversion (Loc,
                     Subtype_Mark => New_Occurrence_Of (T_Typ, Loc),
                     Expression   =>
                       Unchecked_Convert_To (
                         Equivalent_Integer_Type (S_Typ), Expr)),
                 Right_Opnd =>
                   Make_Real_Literal (Loc, Realval => Small_Value (S_Typ))));
         end if;
 
      --  Case of conversion of Vax_Float type to fixed-point type
 
      elsif Is_Fixed_Point_Type (T_Typ) then
 
         --  If Conversion_OK set, then we introduce an intermediate IEEE
         --  target type, since we are expecting the code generator to handle
         --  the case of IEEE float to integer.
 
         if Conversion_OK (N) then
            Rewrite (N,
              OK_Convert_To (T_Typ, Convert_To (Universal_Real, Expr)));
 
         --  Otherwise, multiply value by 'small of type, and convert to the
         --  corresponding integer type.
 
         else
            Rewrite (N,
              Unchecked_Convert_To (T_Typ,
                Make_Type_Conversion (Loc,
                  Subtype_Mark =>
                    New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc),
                  Expression =>
                    Make_Op_Multiply (Loc,
                      Left_Opnd => Expr,
                      Right_Opnd =>
                        Make_Real_Literal (Loc,
                          Realval => Ureal_1 / Small_Value (T_Typ))))));
         end if;
 
      --  All other cases
 
      else
         --  Compute types for call
 
         CallS := Call_Type (S_Typ, T_Typ);
         CallT := Call_Type (T_Typ, S_Typ);
 
         --  Get function and its types
 
         if CallS = RE_D and then CallT = RE_G then
            Func := RE_D_To_G;
 
         elsif CallS = RE_G and then CallT = RE_D then
            Func := RE_G_To_D;
 
         elsif CallS = RE_G and then CallT = RE_F then
            Func := RE_G_To_F;
 
         elsif CallS = RE_F and then CallT = RE_G then
            Func := RE_F_To_G;
 
         elsif CallS = RE_F and then CallT = RE_S then
            Func := RE_F_To_S;
 
         elsif CallS = RE_S and then CallT = RE_F then
            Func := RE_S_To_F;
 
         elsif CallS = RE_G and then CallT = RE_T then
            Func := RE_G_To_T;
 
         elsif CallS = RE_T and then CallT = RE_G then
            Func := RE_T_To_G;
 
         elsif CallS = RE_F and then CallT = RE_Q then
            Func := RE_F_To_Q;
 
         elsif CallS = RE_Q and then CallT = RE_F then
            Func := RE_Q_To_F;
 
         elsif CallS = RE_G and then CallT = RE_Q then
            Func := RE_G_To_Q;
 
         else pragma Assert (CallS = RE_Q and then CallT = RE_G);
            Func := RE_Q_To_G;
         end if;
 
         Rewrite (N,
           Convert_To (T_Typ,
             Make_Function_Call (Loc,
               Name => New_Occurrence_Of (RTE (Func), Loc),
               Parameter_Associations => New_List (
                 Convert_To (RTE (CallS), Expr)))));
      end if;
 
      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 --
   -----------------------------
 
   procedure Expand_Vax_Real_Literal (N : Node_Id) is
      Loc  : constant Source_Ptr := Sloc (N);
      Typ  : constant Entity_Id  := Etype (N);
      Btyp : constant Entity_Id  := Base_Type (Typ);
      Stat : constant Boolean    := Is_Static_Expression (N);
      Nod  : Node_Id;
 
      RE_Source : RE_Id;
      RE_Target : RE_Id;
      RE_Fncall : RE_Id;
      --  Entities for source, target and function call in conversion
 
   begin
      --  We do not know how to convert Vax format real literals, so what
      --  we do is to convert these to be IEEE literals, and introduce the
      --  necessary conversion operation.
 
      if Vax_Float (Btyp) then
         --  What we want to construct here is
 
         --    x!(y_to_z (1.0E0))
 
         --  where
 
         --    x is the base type of the literal (Btyp)
 
         --    y_to_z is
 
         --      s_to_f for F_Float
         --      t_to_g for G_Float
         --      t_to_d for D_Float
 
         --  The literal is typed as S (for F_Float) or T otherwise
 
         --  We do all our own construction, analysis, and expansion here,
         --  since things are at too low a level to use Analyze or Expand
         --  to get this built (we get circularities and other strange
         --  problems if we try!)
 
         if Digits_Value (Btyp) = VAXFF_Digits then
            RE_Source := RE_S;
            RE_Target := RE_F;
            RE_Fncall := RE_S_To_F;
 
         elsif Digits_Value (Btyp) = VAXDF_Digits then
            RE_Source := RE_T;
            RE_Target := RE_D;
            RE_Fncall := RE_T_To_D;
 
         else pragma Assert (Digits_Value (Btyp) = VAXGF_Digits);
            RE_Source := RE_T;
            RE_Target := RE_G;
            RE_Fncall := RE_T_To_G;
         end if;
 
         Nod := Relocate_Node (N);
 
         Set_Etype (Nod, RTE (RE_Source));
         Set_Analyzed (Nod, True);
 
         Nod :=
           Make_Function_Call (Loc,
             Name => New_Occurrence_Of (RTE (RE_Fncall), Loc),
             Parameter_Associations => New_List (Nod));
 
         Set_Etype (Nod, RTE (RE_Target));
         Set_Analyzed (Nod, True);
 
         Nod :=
           Make_Unchecked_Type_Conversion (Loc,
             Subtype_Mark => New_Occurrence_Of (Typ, Loc),
             Expression   => Nod);
 
         Set_Etype (Nod, Typ);
         Set_Analyzed (Nod, True);
         Rewrite (N, Nod);
 
         --  This odd expression is still a static expression. Note that
         --  the routine Sem_Eval.Expr_Value_R understands this.
 
         Set_Is_Static_Expression (N, Stat);
      end if;
   end Expand_Vax_Real_Literal;
 
   ----------------------
   -- Expand_Vax_Valid --
   ----------------------
 
   procedure Expand_Vax_Valid (N : Node_Id) is
      Loc  : constant Source_Ptr := Sloc (N);
      Pref : constant Node_Id    := Prefix (N);
      Ptyp : constant Entity_Id  := Root_Type (Etype (Pref));
      Rtyp : constant Entity_Id  := Etype (N);
      Vtyp : RE_Id;
      Func : RE_Id;
 
   begin
      if Digits_Value (Ptyp) = VAXFF_Digits then
         Func := RE_Valid_F;
         Vtyp := RE_F;
      elsif Digits_Value (Ptyp) = VAXDF_Digits then
         Func := RE_Valid_D;
         Vtyp := RE_D;
      else pragma Assert (Digits_Value (Ptyp) = VAXGF_Digits);
         Func := RE_Valid_G;
         Vtyp := RE_G;
      end if;
 
      Rewrite (N,
        Convert_To (Rtyp,
          Make_Function_Call (Loc,
            Name                   => New_Occurrence_Of (RTE (Func), Loc),
            Parameter_Associations => New_List (
              Convert_To (RTE (Vtyp), Pref)))));
 
      Analyze_And_Resolve (N);
   end Expand_Vax_Valid;
 
end Exp_VFpt;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [exp_vfpt.adb] - Blame information for rev 826

Line No.	Rev	Author	Line
1	281	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- E X P _ V F P T --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1997-2008, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING3. If not, go to --`
19			`-- http://www.gnu.org/licenses for a complete copy of the license. --`
20			`-- --`
21			`-- GNAT was originally developed by the GNAT team at New York University. --`
22			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
23			`-- --`
24			`------------------------------------------------------------------------------`
25
26			`with Atree; use Atree;`
27			`with Einfo; use Einfo;`
28			`with Nlists; use Nlists;`
29			`with Nmake; use Nmake;`
30			`with Rtsfind; use Rtsfind;`
31			`with Sem_Res; use Sem_Res;`
32			`with Sinfo; use Sinfo;`
33			`with Stand; use Stand;`
34			`with Tbuild; use Tbuild;`
35			`with Ttypef; use Ttypef;`
36			`with Uintp; use Uintp;`
37			`with Urealp; use Urealp;`
38
39			`package body Exp_VFpt is`
40
41			`----------------------`
42			`-- Expand_Vax_Arith --`
43			`----------------------`
44
45			`procedure Expand_Vax_Arith (N : Node_Id) is`
46			`Loc : constant Source_Ptr := Sloc (N);`
47			`Typ : constant Entity_Id := Base_Type (Etype (N));`
48			`Typc : Character;`
49			`Atyp : Entity_Id;`
50			`Func : RE_Id;`
51			`Args : List_Id;`
52
53			`begin`
54			`-- Get arithmetic type, note that we do D stuff in G`
55
56			`if Digits_Value (Typ) = VAXFF_Digits then`
57			`Typc := 'F';`
58			`Atyp := RTE (RE_F);`
59			`else`
60			`Typc := 'G';`
61			`Atyp := RTE (RE_G);`
62			`end if;`
63
64			`case Nkind (N) is`
65
66			`when N_Op_Abs =>`
67			`if Typc = 'F' then`
68			`Func := RE_Abs_F;`
69			`else`
70			`Func := RE_Abs_G;`
71			`end if;`
72
73			`when N_Op_Add =>`
74			`if Typc = 'F' then`
75			`Func := RE_Add_F;`
76			`else`
77			`Func := RE_Add_G;`
78			`end if;`
79
80			`when N_Op_Divide =>`
81			`if Typc = 'F' then`
82			`Func := RE_Div_F;`
83			`else`
84			`Func := RE_Div_G;`
85			`end if;`
86
87			`when N_Op_Multiply =>`
88			`if Typc = 'F' then`
89			`Func := RE_Mul_F;`
90			`else`
91			`Func := RE_Mul_G;`
92			`end if;`
93
94			`when N_Op_Minus =>`
95			`if Typc = 'F' then`
96			`Func := RE_Neg_F;`
97			`else`
98			`Func := RE_Neg_G;`
99			`end if;`
100
101			`when N_Op_Subtract =>`
102			`if Typc = 'F' then`
103			`Func := RE_Sub_F;`
104			`else`
105			`Func := RE_Sub_G;`
106			`end if;`
107
108			`when others =>`
109			`Func := RE_Null;`
110			`raise Program_Error;`
111
112			`end case;`
113
114			`Args := New_List;`
115
116			`if Nkind (N) in N_Binary_Op then`
117			`Append_To (Args,`
118			`Convert_To (Atyp, Left_Opnd (N)));`
119			`end if;`
120
121			`Append_To (Args,`
122			`Convert_To (Atyp, Right_Opnd (N)));`
123
124			`Rewrite (N,`
125			`Convert_To (Typ,`
126			`Make_Function_Call (Loc,`
127			`Name => New_Occurrence_Of (RTE (Func), Loc),`
128			`Parameter_Associations => Args)));`
129
130			`Analyze_And_Resolve (N, Typ, Suppress => All_Checks);`
131			`end Expand_Vax_Arith;`
132
133			`---------------------------`
134			`-- Expand_Vax_Comparison --`
135			`---------------------------`
136
137			`procedure Expand_Vax_Comparison (N : Node_Id) is`
138			`Loc : constant Source_Ptr := Sloc (N);`
139			`Typ : constant Entity_Id := Base_Type (Etype (Left_Opnd (N)));`
140			`Typc : Character;`
141			`Func : RE_Id;`
142			`Atyp : Entity_Id;`
143			`Revrs : Boolean := False;`
144			`Args : List_Id;`
145
146			`begin`
147			`-- Get arithmetic type, note that we do D stuff in G`
148
149			`if Digits_Value (Typ) = VAXFF_Digits then`
150			`Typc := 'F';`
151			`Atyp := RTE (RE_F);`
152			`else`
153			`Typc := 'G';`
154			`Atyp := RTE (RE_G);`
155			`end if;`
156
157			`case Nkind (N) is`
158
159			`when N_Op_Eq =>`
160			`if Typc = 'F' then`
161			`Func := RE_Eq_F;`
162			`else`
163			`Func := RE_Eq_G;`
164			`end if;`
165
166			`when N_Op_Ge =>`
167			`if Typc = 'F' then`
168			`Func := RE_Le_F;`
169			`else`
170			`Func := RE_Le_G;`
171			`end if;`
172
173			`Revrs := True;`
174
175			`when N_Op_Gt =>`
176			`if Typc = 'F' then`
177			`Func := RE_Lt_F;`
178			`else`
179			`Func := RE_Lt_G;`
180			`end if;`
181
182			`Revrs := True;`
183
184			`when N_Op_Le =>`
185			`if Typc = 'F' then`
186			`Func := RE_Le_F;`
187			`else`
188			`Func := RE_Le_G;`
189			`end if;`
190
191			`when N_Op_Lt =>`
192			`if Typc = 'F' then`
193			`Func := RE_Lt_F;`
194			`else`
195			`Func := RE_Lt_G;`
196			`end if;`
197
198			`when N_Op_Ne =>`
199			`if Typc = 'F' then`
200			`Func := RE_Ne_F;`
201			`else`
202			`Func := RE_Ne_G;`
203			`end if;`
204
205			`when others =>`
206			`Func := RE_Null;`
207			`raise Program_Error;`
208
209			`end case;`
210
211			`if not Revrs then`
212			`Args := New_List (`
213			`Convert_To (Atyp, Left_Opnd (N)),`
214			`Convert_To (Atyp, Right_Opnd (N)));`
215
216			`else`
217			`Args := New_List (`
218			`Convert_To (Atyp, Right_Opnd (N)),`
219			`Convert_To (Atyp, Left_Opnd (N)));`
220			`end if;`
221
222			`Rewrite (N,`
223			`Make_Function_Call (Loc,`
224			`Name => New_Occurrence_Of (RTE (Func), Loc),`
225			`Parameter_Associations => Args));`
226
227			`Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);`
228			`end Expand_Vax_Comparison;`
229
230			`---------------------------`
231			`-- Expand_Vax_Conversion --`
232			`---------------------------`
233
234			`procedure Expand_Vax_Conversion (N : Node_Id) is`
235			`Loc : constant Source_Ptr := Sloc (N);`
236			`Expr : constant Node_Id := Expression (N);`
237			`S_Typ : constant Entity_Id := Base_Type (Etype (Expr));`
238			`T_Typ : constant Entity_Id := Base_Type (Etype (N));`
239
240			`CallS : RE_Id;`
241			`CallT : RE_Id;`
242			`Func : RE_Id;`
243
244			`function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id;`
245			`-- Given one of the two types T, determines the corresponding call`
246			`-- type, i.e. the type to be used for the call (or the result of`
247			`-- the call). The actual operand is converted to (or from) this type.`
248			`-- Otyp is the other type, which is useful in figuring out the result.`
249			`-- The result returned is the RE_Id value for the type entity.`
250
251			`function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id;`
252			`-- Find the predefined integer type that has the same size as the`
253			`-- fixed-point type T, for use in fixed/float conversions.`
254
255			`---------------`
256			`-- Call_Type --`
257			`---------------`
258
259			`function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is`
260			`begin`
261			`-- Vax float formats`
262
263			`if Vax_Float (T) then`
264			`if Digits_Value (T) = VAXFF_Digits then`
265			`return RE_F;`
266
267			`elsif Digits_Value (T) = VAXGF_Digits then`
268			`return RE_G;`
269
270			`-- For D_Float, leave it as D float if the other operand is`
271			`-- G_Float, since this is the one conversion that is properly`
272			`-- supported for D_Float, but otherwise, use G_Float.`
273
274			`else pragma Assert (Digits_Value (T) = VAXDF_Digits);`
275
276			`if Vax_Float (Otyp)`
277			`and then Digits_Value (Otyp) = VAXGF_Digits`
278			`then`
279			`return RE_D;`
280			`else`
281			`return RE_G;`
282			`end if;`
283			`end if;`
284
285			`-- For all discrete types, use 64-bit integer`
286
287			`elsif Is_Discrete_Type (T) then`
288			`return RE_Q;`
289
290			`-- For all real types (other than Vax float format), we use the`
291			`-- IEEE float-type which corresponds in length to the other type`
292			`-- (which is Vax Float).`
293
294			`else pragma Assert (Is_Real_Type (T));`
295
296			`if Digits_Value (Otyp) = VAXFF_Digits then`
297			`return RE_S;`
298			`else`
299			`return RE_T;`
300			`end if;`
301			`end if;`
302			`end Call_Type;`
303
304			`-------------------------------------------------`
305			`-- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed --`
306			`-------------------------------------------------`
307
308			`function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is`
309			`begin`
310			`if Esize (T) = Esize (Standard_Long_Long_Integer) then`
311			`return Standard_Long_Long_Integer;`
312			`elsif Esize (T) = Esize (Standard_Long_Integer) then`
313			`return Standard_Long_Integer;`
314			`else`
315			`return Standard_Integer;`
316			`end if;`
317			`end Equivalent_Integer_Type;`
318
319			`-- Start of processing for Expand_Vax_Conversion;`
320
321			`begin`
322			`-- If input and output are the same Vax type, we change the`
323			`-- conversion to be an unchecked conversion and that's it.`
324
325			`if Vax_Float (S_Typ) and then Vax_Float (T_Typ)`
326			`and then Digits_Value (S_Typ) = Digits_Value (T_Typ)`
327			`then`
328			`Rewrite (N,`
329			`Unchecked_Convert_To (T_Typ, Expr));`
330
331			`-- Case of conversion of fixed-point type to Vax_Float type`
332
333			`elsif Is_Fixed_Point_Type (S_Typ) then`
334
335			`-- If Conversion_OK set, then we introduce an intermediate IEEE`
336			`-- target type since we are expecting the code generator to handle`
337			`-- the case of integer to IEEE float.`
338
339			`if Conversion_OK (N) then`
340			`Rewrite (N,`
341			`Convert_To (T_Typ, OK_Convert_To (Universal_Real, Expr)));`
342
343			`-- Otherwise, convert the scaled integer value to the target type,`
344			`-- and multiply by 'Small of type.`
345
346			`else`
347			`Rewrite (N,`
348			`Make_Op_Multiply (Loc,`
349			`Left_Opnd =>`
350			`Make_Type_Conversion (Loc,`
351			`Subtype_Mark => New_Occurrence_Of (T_Typ, Loc),`
352			`Expression =>`
353			`Unchecked_Convert_To (`
354			`Equivalent_Integer_Type (S_Typ), Expr)),`
355			`Right_Opnd =>`
356			`Make_Real_Literal (Loc, Realval => Small_Value (S_Typ))));`
357			`end if;`
358
359			`-- Case of conversion of Vax_Float type to fixed-point type`
360
361			`elsif Is_Fixed_Point_Type (T_Typ) then`
362
363			`-- If Conversion_OK set, then we introduce an intermediate IEEE`
364			`-- target type, since we are expecting the code generator to handle`
365			`-- the case of IEEE float to integer.`
366
367			`if Conversion_OK (N) then`
368			`Rewrite (N,`
369			`OK_Convert_To (T_Typ, Convert_To (Universal_Real, Expr)));`
370
371			`-- Otherwise, multiply value by 'small of type, and convert to the`
372			`-- corresponding integer type.`
373
374			`else`
375			`Rewrite (N,`
376			`Unchecked_Convert_To (T_Typ,`
377			`Make_Type_Conversion (Loc,`
378			`Subtype_Mark =>`
379			`New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc),`
380			`Expression =>`
381			`Make_Op_Multiply (Loc,`
382			`Left_Opnd => Expr,`
383			`Right_Opnd =>`
384			`Make_Real_Literal (Loc,`
385			`Realval => Ureal_1 / Small_Value (T_Typ))))));`
386			`end if;`
387
388			`-- All other cases`
389
390			`else`
391			`-- Compute types for call`
392
393			`CallS := Call_Type (S_Typ, T_Typ);`
394			`CallT := Call_Type (T_Typ, S_Typ);`
395
396			`-- Get function and its types`
397
398			`if CallS = RE_D and then CallT = RE_G then`
399			`Func := RE_D_To_G;`
400
401			`elsif CallS = RE_G and then CallT = RE_D then`
402			`Func := RE_G_To_D;`
403
404			`elsif CallS = RE_G and then CallT = RE_F then`
405			`Func := RE_G_To_F;`
406
407			`elsif CallS = RE_F and then CallT = RE_G then`
408			`Func := RE_F_To_G;`
409
410			`elsif CallS = RE_F and then CallT = RE_S then`
411			`Func := RE_F_To_S;`
412
413			`elsif CallS = RE_S and then CallT = RE_F then`
414			`Func := RE_S_To_F;`
415
416			`elsif CallS = RE_G and then CallT = RE_T then`
417			`Func := RE_G_To_T;`
418
419			`elsif CallS = RE_T and then CallT = RE_G then`
420			`Func := RE_T_To_G;`
421
422			`elsif CallS = RE_F and then CallT = RE_Q then`
423			`Func := RE_F_To_Q;`
424
425			`elsif CallS = RE_Q and then CallT = RE_F then`
426			`Func := RE_Q_To_F;`
427
428			`elsif CallS = RE_G and then CallT = RE_Q then`
429			`Func := RE_G_To_Q;`
430
431			`else pragma Assert (CallS = RE_Q and then CallT = RE_G);`
432			`Func := RE_Q_To_G;`
433			`end if;`
434
435			`Rewrite (N,`
436			`Convert_To (T_Typ,`
437			`Make_Function_Call (Loc,`
438			`Name => New_Occurrence_Of (RTE (Func), Loc),`
439			`Parameter_Associations => New_List (`
440			`Convert_To (RTE (CallS), Expr)))));`
441			`end if;`
442
443			`Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks);`
444			`end Expand_Vax_Conversion;`
445
446			`-------------------------------`
447			`-- Expand_Vax_Foreign_Return --`
448			`-------------------------------`
449
450			`procedure Expand_Vax_Foreign_Return (N : Node_Id) is`
451			`Loc : constant Source_Ptr := Sloc (N);`
452			`Typ : constant Entity_Id := Base_Type (Etype (N));`
453			`Func : RE_Id;`
454			`Args : List_Id;`
455			`Atyp : Entity_Id;`
456			`Rtyp : constant Entity_Id := Etype (N);`
457
458			`begin`
459			`if Digits_Value (Typ) = VAXFF_Digits then`
460			`Func := RE_Return_F;`
461			`Atyp := RTE (RE_F);`
462			`elsif Digits_Value (Typ) = VAXDF_Digits then`
463			`Func := RE_Return_D;`
464			`Atyp := RTE (RE_D);`
465			`else pragma Assert (Digits_Value (Typ) = VAXGF_Digits);`
466			`Func := RE_Return_G;`
467			`Atyp := RTE (RE_G);`
468			`end if;`
469
470			`Args := New_List (Convert_To (Atyp, N));`
471
472			`Rewrite (N,`
473			`Convert_To (Rtyp,`
474			`Make_Function_Call (Loc,`
475			`Name => New_Occurrence_Of (RTE (Func), Loc),`
476			`Parameter_Associations => Args)));`
477
478			`Analyze_And_Resolve (N, Typ, Suppress => All_Checks);`
479			`end Expand_Vax_Foreign_Return;`
480
481			`-----------------------------`
482			`-- Expand_Vax_Real_Literal --`
483			`-----------------------------`
484
485			`procedure Expand_Vax_Real_Literal (N : Node_Id) is`
486			`Loc : constant Source_Ptr := Sloc (N);`
487			`Typ : constant Entity_Id := Etype (N);`
488			`Btyp : constant Entity_Id := Base_Type (Typ);`
489			`Stat : constant Boolean := Is_Static_Expression (N);`
490			`Nod : Node_Id;`
491
492			`RE_Source : RE_Id;`
493			`RE_Target : RE_Id;`
494			`RE_Fncall : RE_Id;`
495			`-- Entities for source, target and function call in conversion`
496
497			`begin`
498			`-- We do not know how to convert Vax format real literals, so what`
499			`-- we do is to convert these to be IEEE literals, and introduce the`
500			`-- necessary conversion operation.`
501
502			`if Vax_Float (Btyp) then`
503			`-- What we want to construct here is`
504
505			`-- x!(y_to_z (1.0E0))`
506
507			`-- where`
508
509			`-- x is the base type of the literal (Btyp)`
510
511			`-- y_to_z is`
512
513			`-- s_to_f for F_Float`
514			`-- t_to_g for G_Float`
515			`-- t_to_d for D_Float`
516
517			`-- The literal is typed as S (for F_Float) or T otherwise`
518
519			`-- We do all our own construction, analysis, and expansion here,`
520			`-- since things are at too low a level to use Analyze or Expand`
521			`-- to get this built (we get circularities and other strange`
522			`-- problems if we try!)`
523
524			`if Digits_Value (Btyp) = VAXFF_Digits then`
525			`RE_Source := RE_S;`
526			`RE_Target := RE_F;`
527			`RE_Fncall := RE_S_To_F;`
528
529			`elsif Digits_Value (Btyp) = VAXDF_Digits then`
530			`RE_Source := RE_T;`
531			`RE_Target := RE_D;`
532			`RE_Fncall := RE_T_To_D;`
533
534			`else pragma Assert (Digits_Value (Btyp) = VAXGF_Digits);`
535			`RE_Source := RE_T;`
536			`RE_Target := RE_G;`
537			`RE_Fncall := RE_T_To_G;`
538			`end if;`
539
540			`Nod := Relocate_Node (N);`
541
542			`Set_Etype (Nod, RTE (RE_Source));`
543			`Set_Analyzed (Nod, True);`
544
545			`Nod :=`
546			`Make_Function_Call (Loc,`
547			`Name => New_Occurrence_Of (RTE (RE_Fncall), Loc),`
548			`Parameter_Associations => New_List (Nod));`
549
550			`Set_Etype (Nod, RTE (RE_Target));`
551			`Set_Analyzed (Nod, True);`
552
553			`Nod :=`
554			`Make_Unchecked_Type_Conversion (Loc,`
555			`Subtype_Mark => New_Occurrence_Of (Typ, Loc),`
556			`Expression => Nod);`
557
558			`Set_Etype (Nod, Typ);`
559			`Set_Analyzed (Nod, True);`
560			`Rewrite (N, Nod);`
561
562			`-- This odd expression is still a static expression. Note that`
563			`-- the routine Sem_Eval.Expr_Value_R understands this.`
564
565			`Set_Is_Static_Expression (N, Stat);`
566			`end if;`
567			`end Expand_Vax_Real_Literal;`
568
569			`----------------------`
570			`-- Expand_Vax_Valid --`
571			`----------------------`
572
573			`procedure Expand_Vax_Valid (N : Node_Id) is`
574			`Loc : constant Source_Ptr := Sloc (N);`
575			`Pref : constant Node_Id := Prefix (N);`
576			`Ptyp : constant Entity_Id := Root_Type (Etype (Pref));`
577			`Rtyp : constant Entity_Id := Etype (N);`
578			`Vtyp : RE_Id;`
579			`Func : RE_Id;`
580
581			`begin`
582			`if Digits_Value (Ptyp) = VAXFF_Digits then`
583			`Func := RE_Valid_F;`
584			`Vtyp := RE_F;`
585			`elsif Digits_Value (Ptyp) = VAXDF_Digits then`
586			`Func := RE_Valid_D;`
587			`Vtyp := RE_D;`
588			`else pragma Assert (Digits_Value (Ptyp) = VAXGF_Digits);`
589			`Func := RE_Valid_G;`
590			`Vtyp := RE_G;`
591			`end if;`
592
593			`Rewrite (N,`
594			`Convert_To (Rtyp,`
595			`Make_Function_Call (Loc,`
596			`Name => New_Occurrence_Of (RTE (Func), Loc),`
597			`Parameter_Associations => New_List (`
598			`Convert_To (RTE (Vtyp), Pref)))));`
599
600			`Analyze_And_Resolve (N);`
601			`end Expand_Vax_Valid;`
602
603			`end Exp_VFpt;`