+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- E X P _ V F P T --
--- --
--- B o d y --
--- --
--- $Revision: 1.1.16.2 $
--- --
--- Copyright (C) 1997-2001 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 2, 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- 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 Snames; use Snames;
-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 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 coresponding 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;
-
- 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));
-
-
- elsif Is_Fixed_Point_Type (S_Typ) then
-
- -- convert the scaled integer value to the target type, and multiply
- -- by 'Small of type.
-
- 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))));
-
- elsif Is_Fixed_Point_Type (T_Typ) then
-
- -- multiply value by 'small of type, and convert to the corresponding
- -- integer type.
-
- 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))))));
-
- -- 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_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;
-
-end Exp_VFpt;
projects / msp430-gcc.git / blobdiff