1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2005, Free Software Foundation, Inc. --
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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Nlists; use Nlists;
30 with Nmake; use Nmake;
31 with Rtsfind; use Rtsfind;
32 with Sem_Res; use Sem_Res;
33 with Sinfo; use Sinfo;
34 with Stand; use Stand;
35 with Tbuild; use Tbuild;
36 with Ttypef; use Ttypef;
37 with Uintp; use Uintp;
38 with Urealp; use Urealp;
40 package body Exp_VFpt is
42 ----------------------
43 -- Expand_Vax_Arith --
44 ----------------------
46 procedure Expand_Vax_Arith (N : Node_Id) is
47 Loc : constant Source_Ptr := Sloc (N);
48 Typ : constant Entity_Id := Base_Type (Etype (N));
55 -- Get arithmetic type, note that we do D stuff in G
57 if Digits_Value (Typ) = VAXFF_Digits then
102 when N_Op_Subtract =>
117 if Nkind (N) in N_Binary_Op then
119 Convert_To (Atyp, Left_Opnd (N)));
123 Convert_To (Atyp, Right_Opnd (N)));
127 Make_Function_Call (Loc,
128 Name => New_Occurrence_Of (RTE (Func), Loc),
129 Parameter_Associations => Args)));
131 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
132 end Expand_Vax_Arith;
134 ---------------------------
135 -- Expand_Vax_Comparison --
136 ---------------------------
138 procedure Expand_Vax_Comparison (N : Node_Id) is
139 Loc : constant Source_Ptr := Sloc (N);
140 Typ : constant Entity_Id := Base_Type (Etype (Left_Opnd (N)));
144 Revrs : Boolean := False;
148 -- Get arithmetic type, note that we do D stuff in G
150 if Digits_Value (Typ) = VAXFF_Digits then
214 Convert_To (Atyp, Left_Opnd (N)),
215 Convert_To (Atyp, Right_Opnd (N)));
219 Convert_To (Atyp, Right_Opnd (N)),
220 Convert_To (Atyp, Left_Opnd (N)));
224 Make_Function_Call (Loc,
225 Name => New_Occurrence_Of (RTE (Func), Loc),
226 Parameter_Associations => Args));
228 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
229 end Expand_Vax_Comparison;
231 ---------------------------
232 -- Expand_Vax_Conversion --
233 ---------------------------
235 procedure Expand_Vax_Conversion (N : Node_Id) is
236 Loc : constant Source_Ptr := Sloc (N);
237 Expr : constant Node_Id := Expression (N);
238 S_Typ : constant Entity_Id := Base_Type (Etype (Expr));
239 T_Typ : constant Entity_Id := Base_Type (Etype (N));
245 function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id;
246 -- Given one of the two types T, determines the coresponding call
247 -- type, i.e. the type to be used for the call (or the result of
248 -- the call). The actual operand is converted to (or from) this type.
249 -- Otyp is the other type, which is useful in figuring out the result.
250 -- The result returned is the RE_Id value for the type entity.
252 function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id;
253 -- Find the predefined integer type that has the same size as the
254 -- fixed-point type T, for use in fixed/float conversions.
260 function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is
264 if Vax_Float (T) then
265 if Digits_Value (T) = VAXFF_Digits then
268 elsif Digits_Value (T) = VAXGF_Digits then
271 -- For D_Float, leave it as D float if the other operand is
272 -- G_Float, since this is the one conversion that is properly
273 -- supported for D_Float, but otherwise, use G_Float.
275 else pragma Assert (Digits_Value (T) = VAXDF_Digits);
278 and then Digits_Value (Otyp) = VAXGF_Digits
286 -- For all discrete types, use 64-bit integer
288 elsif Is_Discrete_Type (T) then
291 -- For all real types (other than Vax float format), we use the
292 -- IEEE float-type which corresponds in length to the other type
293 -- (which is Vax Float).
295 else pragma Assert (Is_Real_Type (T));
297 if Digits_Value (Otyp) = VAXFF_Digits then
305 -------------------------------------------------
306 -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed --
307 -------------------------------------------------
309 function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is
311 if Esize (T) = Esize (Standard_Long_Long_Integer) then
312 return Standard_Long_Long_Integer;
313 elsif Esize (T) = Esize (Standard_Long_Integer) then
314 return Standard_Long_Integer;
316 return Standard_Integer;
318 end Equivalent_Integer_Type;
320 -- Start of processing for Expand_Vax_Conversion;
323 -- If input and output are the same Vax type, we change the
324 -- conversion to be an unchecked conversion and that's it.
326 if Vax_Float (S_Typ) and then Vax_Float (T_Typ)
327 and then Digits_Value (S_Typ) = Digits_Value (T_Typ)
330 Unchecked_Convert_To (T_Typ, Expr));
332 -- Case of conversion of fixed-point type to Vax_Float type
334 elsif Is_Fixed_Point_Type (S_Typ) then
336 -- If Conversion_OK set, then we introduce an intermediate IEEE
337 -- target type since we are expecting the code generator to handle
338 -- the case of integer to IEEE float.
340 if Conversion_OK (N) then
342 Convert_To (T_Typ, OK_Convert_To (Universal_Real, Expr)));
344 -- Otherwise, convert the scaled integer value to the target type,
345 -- and multiply by 'Small of type.
349 Make_Op_Multiply (Loc,
351 Make_Type_Conversion (Loc,
352 Subtype_Mark => New_Occurrence_Of (T_Typ, Loc),
354 Unchecked_Convert_To (
355 Equivalent_Integer_Type (S_Typ), Expr)),
357 Make_Real_Literal (Loc, Realval => Small_Value (S_Typ))));
360 -- Case of conversion of Vax_Float type to fixed-point type
362 elsif Is_Fixed_Point_Type (T_Typ) then
364 -- If Conversion_OK set, then we introduce an intermediate IEEE
365 -- target type, since we are expecting the code generator to handle
366 -- the case of IEEE float to integer.
368 if Conversion_OK (N) then
370 OK_Convert_To (T_Typ, Convert_To (Universal_Real, Expr)));
372 -- Otherwise, multiply value by 'small of type, and convert to the
373 -- corresponding integer type.
377 Unchecked_Convert_To (T_Typ,
378 Make_Type_Conversion (Loc,
380 New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc),
382 Make_Op_Multiply (Loc,
385 Make_Real_Literal (Loc,
386 Realval => Ureal_1 / Small_Value (T_Typ))))));
392 -- Compute types for call
394 CallS := Call_Type (S_Typ, T_Typ);
395 CallT := Call_Type (T_Typ, S_Typ);
397 -- Get function and its types
399 if CallS = RE_D and then CallT = RE_G then
402 elsif CallS = RE_G and then CallT = RE_D then
405 elsif CallS = RE_G and then CallT = RE_F then
408 elsif CallS = RE_F and then CallT = RE_G then
411 elsif CallS = RE_F and then CallT = RE_S then
414 elsif CallS = RE_S and then CallT = RE_F then
417 elsif CallS = RE_G and then CallT = RE_T then
420 elsif CallS = RE_T and then CallT = RE_G then
423 elsif CallS = RE_F and then CallT = RE_Q then
426 elsif CallS = RE_Q and then CallT = RE_F then
429 elsif CallS = RE_G and then CallT = RE_Q then
432 else pragma Assert (CallS = RE_Q and then CallT = RE_G);
438 Make_Function_Call (Loc,
439 Name => New_Occurrence_Of (RTE (Func), Loc),
440 Parameter_Associations => New_List (
441 Convert_To (RTE (CallS), Expr)))));
444 Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks);
445 end Expand_Vax_Conversion;
447 -----------------------------
448 -- Expand_Vax_Real_Literal --
449 -----------------------------
451 procedure Expand_Vax_Real_Literal (N : Node_Id) is
452 Loc : constant Source_Ptr := Sloc (N);
453 Typ : constant Entity_Id := Etype (N);
454 Btyp : constant Entity_Id := Base_Type (Typ);
455 Stat : constant Boolean := Is_Static_Expression (N);
461 -- Entities for source, target and function call in conversion
464 -- We do not know how to convert Vax format real literals, so what
465 -- we do is to convert these to be IEEE literals, and introduce the
466 -- necessary conversion operation.
468 if Vax_Float (Btyp) then
469 -- What we want to construct here is
471 -- x!(y_to_z (1.0E0))
475 -- x is the base type of the literal (Btyp)
479 -- s_to_f for F_Float
480 -- t_to_g for G_Float
481 -- t_to_d for D_Float
483 -- The literal is typed as S (for F_Float) or T otherwise
485 -- We do all our own construction, analysis, and expansion here,
486 -- since things are at too low a level to use Analyze or Expand
487 -- to get this built (we get circularities and other strange
488 -- problems if we try!)
490 if Digits_Value (Btyp) = VAXFF_Digits then
493 RE_Fncall := RE_S_To_F;
495 elsif Digits_Value (Btyp) = VAXDF_Digits then
498 RE_Fncall := RE_T_To_D;
500 else pragma Assert (Digits_Value (Btyp) = VAXGF_Digits);
503 RE_Fncall := RE_T_To_G;
506 Nod := Relocate_Node (N);
508 Set_Etype (Nod, RTE (RE_Source));
509 Set_Analyzed (Nod, True);
512 Make_Function_Call (Loc,
513 Name => New_Occurrence_Of (RTE (RE_Fncall), Loc),
514 Parameter_Associations => New_List (Nod));
516 Set_Etype (Nod, RTE (RE_Target));
517 Set_Analyzed (Nod, True);
520 Make_Unchecked_Type_Conversion (Loc,
521 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
524 Set_Etype (Nod, Typ);
525 Set_Analyzed (Nod, True);
528 -- This odd expression is still a static expression. Note that
529 -- the routine Sem_Eval.Expr_Value_R understands this.
531 Set_Is_Static_Expression (N, Stat);
533 end Expand_Vax_Real_Literal;
535 ----------------------
536 -- Expand_Vax_Valid --
537 ----------------------
539 procedure Expand_Vax_Valid (N : Node_Id) is
540 Loc : constant Source_Ptr := Sloc (N);
541 Pref : constant Node_Id := Prefix (N);
542 Ptyp : constant Entity_Id := Root_Type (Etype (Pref));
543 Rtyp : constant Entity_Id := Etype (N);
548 if Digits_Value (Ptyp) = VAXFF_Digits then
551 elsif Digits_Value (Ptyp) = VAXDF_Digits then
554 else pragma Assert (Digits_Value (Ptyp) = VAXGF_Digits);
561 Make_Function_Call (Loc,
562 Name => New_Occurrence_Of (RTE (Func), Loc),
563 Parameter_Associations => New_List (
564 Convert_To (RTE (Vtyp), Pref)))));
566 Analyze_And_Resolve (N);
567 end Expand_Vax_Valid;