1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2012, 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 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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
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
48 -- +-+---------------+--------------+
49 -- |S| exp | fraction | A
50 -- +-+---------------+--------------+
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).
72 -- +-+---------------+--------------+
73 -- |S| exp | fraction | A
74 -- +-+---------------+--------------+
76 -- +--------------------------------+
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.
93 -- +-+---------------------+--------+
94 -- |S| exp | fract | A
95 -- +-+---------------------+--------+
97 -- +--------------------------------+
99 -- +--------------------------------+
100 -- | fraction (low) | A + 6
101 -- +--------------------------------+
103 -- Exponent values of 1 through 2047 indicate true binary exponents of
106 -- Main differences compared to IEEE 754:
108 -- * No denormalized numbers
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
));
133 -- Get arithmetic type, note that we do D stuff in G
135 if Digits_Value
(Typ
) = VAXFF_Digits
then
166 when N_Op_Multiply
=>
180 when N_Op_Subtract
=>
195 if Nkind
(N
) in N_Binary_Op
then
197 Convert_To
(Atyp
, Left_Opnd
(N
)));
201 Convert_To
(Atyp
, Right_Opnd
(N
)));
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
)));
222 Revrs
: Boolean := False;
226 -- Get arithmetic type, note that we do D stuff in G
228 if Digits_Value
(Typ
) = VAXFF_Digits
then
292 Convert_To
(Atyp
, Left_Opnd
(N
)),
293 Convert_To
(Atyp
, Right_Opnd
(N
)));
297 Convert_To
(Atyp
, Right_Opnd
(N
)),
298 Convert_To
(Atyp
, Left_Opnd
(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
));
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.
338 function Call_Type
(T
: Entity_Id
; Otyp
: Entity_Id
) return RE_Id
is
342 if Vax_Float
(T
) then
343 if Digits_Value
(T
) = VAXFF_Digits
then
346 elsif Digits_Value
(T
) = VAXGF_Digits
then
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
);
356 and then Digits_Value
(Otyp
) = VAXGF_Digits
364 -- For all discrete types, use 64-bit integer
366 elsif Is_Discrete_Type
(T
) then
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
383 -------------------------------------------------
384 -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed --
385 -------------------------------------------------
387 function Equivalent_Integer_Type
(T
: Entity_Id
) return Entity_Id
is
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
;
394 return Standard_Integer
;
396 end Equivalent_Integer_Type
;
398 -- Start of processing for Expand_Vax_Conversion;
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
)
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
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.
427 Make_Op_Multiply
(Loc
,
429 Make_Type_Conversion
(Loc
,
430 Subtype_Mark
=> New_Occurrence_Of
(T_Typ
, Loc
),
432 Unchecked_Convert_To
(
433 Equivalent_Integer_Type
(S_Typ
), Expr
)),
435 Make_Real_Literal
(Loc
, Realval
=> Small_Value
(S_Typ
))));
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
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.
455 Unchecked_Convert_To
(T_Typ
,
456 Make_Type_Conversion
(Loc
,
458 New_Occurrence_Of
(Equivalent_Integer_Type
(T_Typ
), Loc
),
460 Make_Op_Multiply
(Loc
,
463 Make_Real_Literal
(Loc
,
464 Realval
=> Ureal_1
/ Small_Value
(T_Typ
))))));
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
480 elsif CallS
= RE_G
and then CallT
= RE_D
then
483 elsif CallS
= RE_G
and then CallT
= RE_F
then
486 elsif CallS
= RE_F
and then CallT
= RE_G
then
489 elsif CallS
= RE_F
and then CallT
= RE_S
then
492 elsif CallS
= RE_S
and then CallT
= RE_F
then
495 elsif CallS
= RE_G
and then CallT
= RE_T
then
498 elsif CallS
= RE_T
and then CallT
= RE_G
then
501 elsif CallS
= RE_F
and then CallT
= RE_Q
then
504 elsif CallS
= RE_Q
and then CallT
= RE_F
then
507 elsif CallS
= RE_G
and then CallT
= RE_Q
then
510 else pragma Assert
(CallS
= RE_Q
and then CallT
= RE_G
);
516 Make_Function_Call
(Loc
,
517 Name
=> New_Occurrence_Of
(RTE
(Func
), Loc
),
518 Parameter_Associations
=> New_List
(
519 Convert_To
(RTE
(CallS
), Expr
)))));
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
));
535 Rtyp
: constant Entity_Id
:= Etype
(N
);
538 if Digits_Value
(Typ
) = VAXFF_Digits
then
541 elsif Digits_Value
(Typ
) = VAXDF_Digits
then
544 else pragma Assert
(Digits_Value
(Typ
) = VAXGF_Digits
);
549 Args
:= New_List
(Convert_To
(Atyp
, N
));
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
);
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
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
604 elsif Exponent
<= -(Uint_2
** (Exponent_Size
- 1)) then
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.
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);
634 Res
:= Res
+ Int
(2**15);
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
646 if Res
>= Uint_2
** (Exponent_Size
+ Fraction_Size
) then
647 Res
:= Res
- Uint_2
** (Exponent_Size
+ Fraction_Size
+ 1);
651 Release_And_Save
(Uintp_Mark
, 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
);
669 if Digits_Value
(Ptyp
) = VAXFF_Digits
then
672 elsif Digits_Value
(Ptyp
) = VAXDF_Digits
then
675 else pragma Assert
(Digits_Value
(Ptyp
) = VAXGF_Digits
);
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
;