Merge with main truk.
[official-gcc.git] / gcc / ada / exp_vfpt.adb
blob82d2fe16e7df4745eedcb3f1e2bdf9109218eb79
1 ------------------------------------------------------------------------------
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-2012, 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 ------------------------------------------------------------------------------
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 Urealp; use Urealp;
36 with Eval_Fat; use Eval_Fat;
38 package body Exp_VFpt is
40 -- Vax floating point format (from Vax Architecture Reference Manual
41 -- version 6):
43 -- Float F:
44 -- --------
46 -- 1 1
47 -- 5 4 7 6 0
48 -- +-+---------------+--------------+
49 -- |S| exp | fraction | A
50 -- +-+---------------+--------------+
51 -- | fraction | A + 2
52 -- +--------------------------------+
54 -- bit 15 is the sign bit,
55 -- bits 14:7 is the excess 128 binary exponent,
56 -- bits 6:0 and 31:16 the normalized 24-bit fraction with the redundant
57 -- most significant fraction bit not represented.
59 -- An exponent value of 0 together with a sign bit of 0, is taken to
60 -- indicate that the datum has a value of 0. Exponent values of 1 through
61 -- 255 indicate true binary exponents of -127 to +127. An exponent value
62 -- of 0, together with a sign bit of 1, is taken as reserved.
64 -- Note that fraction bits are not continuous in memory, VAX is little
65 -- endian (LSB first).
67 -- Float D:
68 -- --------
70 -- 1 1
71 -- 5 4 7 6 0
72 -- +-+---------------+--------------+
73 -- |S| exp | fraction | A
74 -- +-+---------------+--------------+
75 -- | fraction | A + 2
76 -- +--------------------------------+
77 -- | fraction | A + 4
78 -- +--------------------------------+
79 -- | fraction (low) | A + 6
80 -- +--------------------------------+
82 -- Note that the fraction bits are not continuous in memory. Bytes in a
83 -- words are stored in little endian format, but words are stored using
84 -- big endian format (PDP endian).
86 -- Like Float F but with 55 bits for the fraction.
88 -- Float G:
89 -- --------
91 -- 1 1
92 -- 5 4 4 3 0
93 -- +-+---------------------+--------+
94 -- |S| exp | fract | A
95 -- +-+---------------------+--------+
96 -- | fraction | A + 2
97 -- +--------------------------------+
98 -- | fraction | A + 4
99 -- +--------------------------------+
100 -- | fraction (low) | A + 6
101 -- +--------------------------------+
103 -- Exponent values of 1 through 2047 indicate true binary exponents of
104 -- -1023 to +1023.
106 -- Main differences compared to IEEE 754:
108 -- * No denormalized numbers
109 -- * No infinity
110 -- * No NaN
111 -- * No -0.0
112 -- * Reserved values (exp = 0, sign = 1)
113 -- * Vax mantissa represent values [0.5, 1)
114 -- * Bias is shifted by 1 (for single float: 128 on Vax, 127 on IEEE)
116 VAXFF_Digits : constant := 6;
117 VAXDF_Digits : constant := 9;
118 VAXGF_Digits : constant := 15;
120 ----------------------
121 -- Expand_Vax_Arith --
122 ----------------------
124 procedure Expand_Vax_Arith (N : Node_Id) is
125 Loc : constant Source_Ptr := Sloc (N);
126 Typ : constant Entity_Id := Base_Type (Etype (N));
127 Typc : Character;
128 Atyp : Entity_Id;
129 Func : RE_Id;
130 Args : List_Id;
132 begin
133 -- Get arithmetic type, note that we do D stuff in G
135 if Digits_Value (Typ) = VAXFF_Digits then
136 Typc := 'F';
137 Atyp := RTE (RE_F);
138 else
139 Typc := 'G';
140 Atyp := RTE (RE_G);
141 end if;
143 case Nkind (N) is
145 when N_Op_Abs =>
146 if Typc = 'F' then
147 Func := RE_Abs_F;
148 else
149 Func := RE_Abs_G;
150 end if;
152 when N_Op_Add =>
153 if Typc = 'F' then
154 Func := RE_Add_F;
155 else
156 Func := RE_Add_G;
157 end if;
159 when N_Op_Divide =>
160 if Typc = 'F' then
161 Func := RE_Div_F;
162 else
163 Func := RE_Div_G;
164 end if;
166 when N_Op_Multiply =>
167 if Typc = 'F' then
168 Func := RE_Mul_F;
169 else
170 Func := RE_Mul_G;
171 end if;
173 when N_Op_Minus =>
174 if Typc = 'F' then
175 Func := RE_Neg_F;
176 else
177 Func := RE_Neg_G;
178 end if;
180 when N_Op_Subtract =>
181 if Typc = 'F' then
182 Func := RE_Sub_F;
183 else
184 Func := RE_Sub_G;
185 end if;
187 when others =>
188 Func := RE_Null;
189 raise Program_Error;
191 end case;
193 Args := New_List;
195 if Nkind (N) in N_Binary_Op then
196 Append_To (Args,
197 Convert_To (Atyp, Left_Opnd (N)));
198 end if;
200 Append_To (Args,
201 Convert_To (Atyp, Right_Opnd (N)));
203 Rewrite (N,
204 Convert_To (Typ,
205 Make_Function_Call (Loc,
206 Name => New_Occurrence_Of (RTE (Func), Loc),
207 Parameter_Associations => Args)));
209 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
210 end Expand_Vax_Arith;
212 ---------------------------
213 -- Expand_Vax_Comparison --
214 ---------------------------
216 procedure Expand_Vax_Comparison (N : Node_Id) is
217 Loc : constant Source_Ptr := Sloc (N);
218 Typ : constant Entity_Id := Base_Type (Etype (Left_Opnd (N)));
219 Typc : Character;
220 Func : RE_Id;
221 Atyp : Entity_Id;
222 Revrs : Boolean := False;
223 Args : List_Id;
225 begin
226 -- Get arithmetic type, note that we do D stuff in G
228 if Digits_Value (Typ) = VAXFF_Digits then
229 Typc := 'F';
230 Atyp := RTE (RE_F);
231 else
232 Typc := 'G';
233 Atyp := RTE (RE_G);
234 end if;
236 case Nkind (N) is
238 when N_Op_Eq =>
239 if Typc = 'F' then
240 Func := RE_Eq_F;
241 else
242 Func := RE_Eq_G;
243 end if;
245 when N_Op_Ge =>
246 if Typc = 'F' then
247 Func := RE_Le_F;
248 else
249 Func := RE_Le_G;
250 end if;
252 Revrs := True;
254 when N_Op_Gt =>
255 if Typc = 'F' then
256 Func := RE_Lt_F;
257 else
258 Func := RE_Lt_G;
259 end if;
261 Revrs := True;
263 when N_Op_Le =>
264 if Typc = 'F' then
265 Func := RE_Le_F;
266 else
267 Func := RE_Le_G;
268 end if;
270 when N_Op_Lt =>
271 if Typc = 'F' then
272 Func := RE_Lt_F;
273 else
274 Func := RE_Lt_G;
275 end if;
277 when N_Op_Ne =>
278 if Typc = 'F' then
279 Func := RE_Ne_F;
280 else
281 Func := RE_Ne_G;
282 end if;
284 when others =>
285 Func := RE_Null;
286 raise Program_Error;
288 end case;
290 if not Revrs then
291 Args := New_List (
292 Convert_To (Atyp, Left_Opnd (N)),
293 Convert_To (Atyp, Right_Opnd (N)));
295 else
296 Args := New_List (
297 Convert_To (Atyp, Right_Opnd (N)),
298 Convert_To (Atyp, Left_Opnd (N)));
299 end if;
301 Rewrite (N,
302 Make_Function_Call (Loc,
303 Name => New_Occurrence_Of (RTE (Func), Loc),
304 Parameter_Associations => Args));
306 Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
307 end Expand_Vax_Comparison;
309 ---------------------------
310 -- Expand_Vax_Conversion --
311 ---------------------------
313 procedure Expand_Vax_Conversion (N : Node_Id) is
314 Loc : constant Source_Ptr := Sloc (N);
315 Expr : constant Node_Id := Expression (N);
316 S_Typ : constant Entity_Id := Base_Type (Etype (Expr));
317 T_Typ : constant Entity_Id := Base_Type (Etype (N));
319 CallS : RE_Id;
320 CallT : RE_Id;
321 Func : RE_Id;
323 function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id;
324 -- Given one of the two types T, determines the corresponding call
325 -- type, i.e. the type to be used for the call (or the result of
326 -- the call). The actual operand is converted to (or from) this type.
327 -- Otyp is the other type, which is useful in figuring out the result.
328 -- The result returned is the RE_Id value for the type entity.
330 function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id;
331 -- Find the predefined integer type that has the same size as the
332 -- fixed-point type T, for use in fixed/float conversions.
334 ---------------
335 -- Call_Type --
336 ---------------
338 function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is
339 begin
340 -- Vax float formats
342 if Vax_Float (T) then
343 if Digits_Value (T) = VAXFF_Digits then
344 return RE_F;
346 elsif Digits_Value (T) = VAXGF_Digits then
347 return RE_G;
349 -- For D_Float, leave it as D float if the other operand is
350 -- G_Float, since this is the one conversion that is properly
351 -- supported for D_Float, but otherwise, use G_Float.
353 else pragma Assert (Digits_Value (T) = VAXDF_Digits);
355 if Vax_Float (Otyp)
356 and then Digits_Value (Otyp) = VAXGF_Digits
357 then
358 return RE_D;
359 else
360 return RE_G;
361 end if;
362 end if;
364 -- For all discrete types, use 64-bit integer
366 elsif Is_Discrete_Type (T) then
367 return RE_Q;
369 -- For all real types (other than Vax float format), we use the
370 -- IEEE float-type which corresponds in length to the other type
371 -- (which is Vax Float).
373 else pragma Assert (Is_Real_Type (T));
375 if Digits_Value (Otyp) = VAXFF_Digits then
376 return RE_S;
377 else
378 return RE_T;
379 end if;
380 end if;
381 end Call_Type;
383 -------------------------------------------------
384 -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed --
385 -------------------------------------------------
387 function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is
388 begin
389 if Esize (T) = Esize (Standard_Long_Long_Integer) then
390 return Standard_Long_Long_Integer;
391 elsif Esize (T) = Esize (Standard_Long_Integer) then
392 return Standard_Long_Integer;
393 else
394 return Standard_Integer;
395 end if;
396 end Equivalent_Integer_Type;
398 -- Start of processing for Expand_Vax_Conversion;
400 begin
401 -- If input and output are the same Vax type, we change the
402 -- conversion to be an unchecked conversion and that's it.
404 if Vax_Float (S_Typ) and then Vax_Float (T_Typ)
405 and then Digits_Value (S_Typ) = Digits_Value (T_Typ)
406 then
407 Rewrite (N,
408 Unchecked_Convert_To (T_Typ, Expr));
410 -- Case of conversion of fixed-point type to Vax_Float type
412 elsif Is_Fixed_Point_Type (S_Typ) then
414 -- If Conversion_OK set, then we introduce an intermediate IEEE
415 -- target type since we are expecting the code generator to handle
416 -- the case of integer to IEEE float.
418 if Conversion_OK (N) then
419 Rewrite (N,
420 Convert_To (T_Typ, OK_Convert_To (Universal_Real, Expr)));
422 -- Otherwise, convert the scaled integer value to the target type,
423 -- and multiply by 'Small of type.
425 else
426 Rewrite (N,
427 Make_Op_Multiply (Loc,
428 Left_Opnd =>
429 Make_Type_Conversion (Loc,
430 Subtype_Mark => New_Occurrence_Of (T_Typ, Loc),
431 Expression =>
432 Unchecked_Convert_To (
433 Equivalent_Integer_Type (S_Typ), Expr)),
434 Right_Opnd =>
435 Make_Real_Literal (Loc, Realval => Small_Value (S_Typ))));
436 end if;
438 -- Case of conversion of Vax_Float type to fixed-point type
440 elsif Is_Fixed_Point_Type (T_Typ) then
442 -- If Conversion_OK set, then we introduce an intermediate IEEE
443 -- target type, since we are expecting the code generator to handle
444 -- the case of IEEE float to integer.
446 if Conversion_OK (N) then
447 Rewrite (N,
448 OK_Convert_To (T_Typ, Convert_To (Universal_Real, Expr)));
450 -- Otherwise, multiply value by 'small of type, and convert to the
451 -- corresponding integer type.
453 else
454 Rewrite (N,
455 Unchecked_Convert_To (T_Typ,
456 Make_Type_Conversion (Loc,
457 Subtype_Mark =>
458 New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc),
459 Expression =>
460 Make_Op_Multiply (Loc,
461 Left_Opnd => Expr,
462 Right_Opnd =>
463 Make_Real_Literal (Loc,
464 Realval => Ureal_1 / Small_Value (T_Typ))))));
465 end if;
467 -- All other cases
469 else
470 -- Compute types for call
472 CallS := Call_Type (S_Typ, T_Typ);
473 CallT := Call_Type (T_Typ, S_Typ);
475 -- Get function and its types
477 if CallS = RE_D and then CallT = RE_G then
478 Func := RE_D_To_G;
480 elsif CallS = RE_G and then CallT = RE_D then
481 Func := RE_G_To_D;
483 elsif CallS = RE_G and then CallT = RE_F then
484 Func := RE_G_To_F;
486 elsif CallS = RE_F and then CallT = RE_G then
487 Func := RE_F_To_G;
489 elsif CallS = RE_F and then CallT = RE_S then
490 Func := RE_F_To_S;
492 elsif CallS = RE_S and then CallT = RE_F then
493 Func := RE_S_To_F;
495 elsif CallS = RE_G and then CallT = RE_T then
496 Func := RE_G_To_T;
498 elsif CallS = RE_T and then CallT = RE_G then
499 Func := RE_T_To_G;
501 elsif CallS = RE_F and then CallT = RE_Q then
502 Func := RE_F_To_Q;
504 elsif CallS = RE_Q and then CallT = RE_F then
505 Func := RE_Q_To_F;
507 elsif CallS = RE_G and then CallT = RE_Q then
508 Func := RE_G_To_Q;
510 else pragma Assert (CallS = RE_Q and then CallT = RE_G);
511 Func := RE_Q_To_G;
512 end if;
514 Rewrite (N,
515 Convert_To (T_Typ,
516 Make_Function_Call (Loc,
517 Name => New_Occurrence_Of (RTE (Func), Loc),
518 Parameter_Associations => New_List (
519 Convert_To (RTE (CallS), Expr)))));
520 end if;
522 Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks);
523 end Expand_Vax_Conversion;
525 -------------------------------
526 -- Expand_Vax_Foreign_Return --
527 -------------------------------
529 procedure Expand_Vax_Foreign_Return (N : Node_Id) is
530 Loc : constant Source_Ptr := Sloc (N);
531 Typ : constant Entity_Id := Base_Type (Etype (N));
532 Func : RE_Id;
533 Args : List_Id;
534 Atyp : Entity_Id;
535 Rtyp : constant Entity_Id := Etype (N);
537 begin
538 if Digits_Value (Typ) = VAXFF_Digits then
539 Func := RE_Return_F;
540 Atyp := RTE (RE_F);
541 elsif Digits_Value (Typ) = VAXDF_Digits then
542 Func := RE_Return_D;
543 Atyp := RTE (RE_D);
544 else pragma Assert (Digits_Value (Typ) = VAXGF_Digits);
545 Func := RE_Return_G;
546 Atyp := RTE (RE_G);
547 end if;
549 Args := New_List (Convert_To (Atyp, N));
551 Rewrite (N,
552 Convert_To (Rtyp,
553 Make_Function_Call (Loc,
554 Name => New_Occurrence_Of (RTE (Func), Loc),
555 Parameter_Associations => Args)));
557 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
558 end Expand_Vax_Foreign_Return;
560 --------------------------------
561 -- Vax_Real_Literal_As_Signed --
562 --------------------------------
564 function Get_Vax_Real_Literal_As_Signed (N : Node_Id) return Uint is
565 Btyp : constant Entity_Id :=
566 Base_Type (Underlying_Type (Etype (N)));
568 Value : constant Ureal := Realval (N);
569 Negative : Boolean;
570 Fraction : UI;
571 Exponent : UI;
572 Res : UI;
574 Exponent_Size : Uint;
575 -- Number of bits for the exponent
577 Fraction_Size : Uint;
578 -- Number of bits for the fraction
580 Uintp_Mark : constant Uintp.Save_Mark := Mark;
581 -- Use the mark & release feature to delete temporaries
582 begin
583 -- Extract the sign now
585 Negative := UR_Is_Negative (Value);
587 -- Decompose the number
589 Decompose_Int (Btyp, abs Value, Fraction, Exponent, Round_Even);
591 -- Number of bits for the fraction, leading fraction bit is implicit
593 Fraction_Size := Machine_Mantissa_Value (Btyp) - Int'(1);
595 -- Number of bits for the exponent (one bit for the sign)
597 Exponent_Size := RM_Size (Btyp) - Fraction_Size - Int'(1);
599 if Fraction = Uint_0 then
600 -- Handle zero
602 Res := Uint_0;
604 elsif Exponent <= -(Uint_2 ** (Exponent_Size - 1)) then
605 -- Underflow
607 Res := Uint_0;
608 else
609 -- Check for overflow
611 pragma Assert (Exponent < Uint_2 ** (Exponent_Size - 1));
613 -- MSB of the fraction must be 1
615 pragma Assert (Fraction / Uint_2 ** Fraction_Size = Uint_1);
617 -- Remove the redudant most significant fraction bit
619 Fraction := Fraction - Uint_2 ** Fraction_Size;
621 -- Build the fraction part. Note that this field is in mixed
622 -- endianness: words are stored using little endianness, while bytes
623 -- in words are stored using big endianness.
625 Res := Uint_0;
626 for I in 1 .. UI_To_Int (RM_Size (Btyp)) / 16 loop
627 Res := (Res * (Uint_2 ** 16)) + (Fraction mod (Uint_2 ** 16));
628 Fraction := Fraction / (Uint_2 ** 16);
629 end loop;
631 -- The sign bit
633 if Negative then
634 Res := Res + Int (2**15);
635 end if;
637 -- The exponent
639 Res := Res + (Exponent + Uint_2 ** (Exponent_Size - 1))
640 * Uint_2 ** (15 - Exponent_Size);
642 -- Until now, we have created an unsigned number, but an underlying
643 -- type is a signed type. Convert to a signed number to avoid
644 -- overflow in gigi.
646 if Res >= Uint_2 ** (Exponent_Size + Fraction_Size) then
647 Res := Res - Uint_2 ** (Exponent_Size + Fraction_Size + 1);
648 end if;
649 end if;
651 Release_And_Save (Uintp_Mark, Res);
653 return Res;
654 end Get_Vax_Real_Literal_As_Signed;
656 ----------------------
657 -- Expand_Vax_Valid --
658 ----------------------
660 procedure Expand_Vax_Valid (N : Node_Id) is
661 Loc : constant Source_Ptr := Sloc (N);
662 Pref : constant Node_Id := Prefix (N);
663 Ptyp : constant Entity_Id := Root_Type (Etype (Pref));
664 Rtyp : constant Entity_Id := Etype (N);
665 Vtyp : RE_Id;
666 Func : RE_Id;
668 begin
669 if Digits_Value (Ptyp) = VAXFF_Digits then
670 Func := RE_Valid_F;
671 Vtyp := RE_F;
672 elsif Digits_Value (Ptyp) = VAXDF_Digits then
673 Func := RE_Valid_D;
674 Vtyp := RE_D;
675 else pragma Assert (Digits_Value (Ptyp) = VAXGF_Digits);
676 Func := RE_Valid_G;
677 Vtyp := RE_G;
678 end if;
680 Rewrite (N,
681 Convert_To (Rtyp,
682 Make_Function_Call (Loc,
683 Name => New_Occurrence_Of (RTE (Func), Loc),
684 Parameter_Associations => New_List (
685 Convert_To (RTE (Vtyp), Pref)))));
687 Analyze_And_Resolve (N);
688 end Expand_Vax_Valid;
690 end Exp_VFpt;