1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2007, 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 Ttypef
; use Ttypef
;
36 with Uintp
; use Uintp
;
37 with Urealp
; use Urealp
;
39 package body Exp_VFpt
is
41 ----------------------
42 -- Expand_Vax_Arith --
43 ----------------------
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
));
54 -- Get arithmetic type, note that we do D stuff in G
56 if Digits_Value
(Typ
) = VAXFF_Digits
then
101 when N_Op_Subtract
=>
116 if Nkind
(N
) in N_Binary_Op
then
118 Convert_To
(Atyp
, Left_Opnd
(N
)));
122 Convert_To
(Atyp
, Right_Opnd
(N
)));
126 Make_Function_Call
(Loc
,
127 Name
=> New_Occurrence_Of
(RTE
(Func
), Loc
),
128 Parameter_Associations
=> Args
)));
130 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
131 end Expand_Vax_Arith
;
133 ---------------------------
134 -- Expand_Vax_Comparison --
135 ---------------------------
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
)));
143 Revrs
: Boolean := False;
147 -- Get arithmetic type, note that we do D stuff in G
149 if Digits_Value
(Typ
) = VAXFF_Digits
then
213 Convert_To
(Atyp
, Left_Opnd
(N
)),
214 Convert_To
(Atyp
, Right_Opnd
(N
)));
218 Convert_To
(Atyp
, Right_Opnd
(N
)),
219 Convert_To
(Atyp
, Left_Opnd
(N
)));
223 Make_Function_Call
(Loc
,
224 Name
=> New_Occurrence_Of
(RTE
(Func
), Loc
),
225 Parameter_Associations
=> Args
));
227 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
228 end Expand_Vax_Comparison
;
230 ---------------------------
231 -- Expand_Vax_Conversion --
232 ---------------------------
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
));
244 function Call_Type
(T
: Entity_Id
; Otyp
: Entity_Id
) return RE_Id
;
245 -- Given one of the two types T, determines the coresponding 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.
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.
259 function Call_Type
(T
: Entity_Id
; Otyp
: Entity_Id
) return RE_Id
is
263 if Vax_Float
(T
) then
264 if Digits_Value
(T
) = VAXFF_Digits
then
267 elsif Digits_Value
(T
) = VAXGF_Digits
then
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.
274 else pragma Assert
(Digits_Value
(T
) = VAXDF_Digits
);
277 and then Digits_Value
(Otyp
) = VAXGF_Digits
285 -- For all discrete types, use 64-bit integer
287 elsif Is_Discrete_Type
(T
) then
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).
294 else pragma Assert
(Is_Real_Type
(T
));
296 if Digits_Value
(Otyp
) = VAXFF_Digits
then
304 -------------------------------------------------
305 -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed --
306 -------------------------------------------------
308 function Equivalent_Integer_Type
(T
: Entity_Id
) return Entity_Id
is
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
;
315 return Standard_Integer
;
317 end Equivalent_Integer_Type
;
319 -- Start of processing for Expand_Vax_Conversion;
322 -- If input and output are the same Vax type, we change the
323 -- conversion to be an unchecked conversion and that's it.
325 if Vax_Float
(S_Typ
) and then Vax_Float
(T_Typ
)
326 and then Digits_Value
(S_Typ
) = Digits_Value
(T_Typ
)
329 Unchecked_Convert_To
(T_Typ
, Expr
));
331 -- Case of conversion of fixed-point type to Vax_Float type
333 elsif Is_Fixed_Point_Type
(S_Typ
) then
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.
339 if Conversion_OK
(N
) then
341 Convert_To
(T_Typ
, OK_Convert_To
(Universal_Real
, Expr
)));
343 -- Otherwise, convert the scaled integer value to the target type,
344 -- and multiply by 'Small of type.
348 Make_Op_Multiply
(Loc
,
350 Make_Type_Conversion
(Loc
,
351 Subtype_Mark
=> New_Occurrence_Of
(T_Typ
, Loc
),
353 Unchecked_Convert_To
(
354 Equivalent_Integer_Type
(S_Typ
), Expr
)),
356 Make_Real_Literal
(Loc
, Realval
=> Small_Value
(S_Typ
))));
359 -- Case of conversion of Vax_Float type to fixed-point type
361 elsif Is_Fixed_Point_Type
(T_Typ
) then
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.
367 if Conversion_OK
(N
) then
369 OK_Convert_To
(T_Typ
, Convert_To
(Universal_Real
, Expr
)));
371 -- Otherwise, multiply value by 'small of type, and convert to the
372 -- corresponding integer type.
376 Unchecked_Convert_To
(T_Typ
,
377 Make_Type_Conversion
(Loc
,
379 New_Occurrence_Of
(Equivalent_Integer_Type
(T_Typ
), Loc
),
381 Make_Op_Multiply
(Loc
,
384 Make_Real_Literal
(Loc
,
385 Realval
=> Ureal_1
/ Small_Value
(T_Typ
))))));
391 -- Compute types for call
393 CallS
:= Call_Type
(S_Typ
, T_Typ
);
394 CallT
:= Call_Type
(T_Typ
, S_Typ
);
396 -- Get function and its types
398 if CallS
= RE_D
and then CallT
= RE_G
then
401 elsif CallS
= RE_G
and then CallT
= RE_D
then
404 elsif CallS
= RE_G
and then CallT
= RE_F
then
407 elsif CallS
= RE_F
and then CallT
= RE_G
then
410 elsif CallS
= RE_F
and then CallT
= RE_S
then
413 elsif CallS
= RE_S
and then CallT
= RE_F
then
416 elsif CallS
= RE_G
and then CallT
= RE_T
then
419 elsif CallS
= RE_T
and then CallT
= RE_G
then
422 elsif CallS
= RE_F
and then CallT
= RE_Q
then
425 elsif CallS
= RE_Q
and then CallT
= RE_F
then
428 elsif CallS
= RE_G
and then CallT
= RE_Q
then
431 else pragma Assert
(CallS
= RE_Q
and then CallT
= RE_G
);
437 Make_Function_Call
(Loc
,
438 Name
=> New_Occurrence_Of
(RTE
(Func
), Loc
),
439 Parameter_Associations
=> New_List
(
440 Convert_To
(RTE
(CallS
), Expr
)))));
443 Analyze_And_Resolve
(N
, T_Typ
, Suppress
=> All_Checks
);
444 end Expand_Vax_Conversion
;
446 -----------------------------
447 -- Expand_Vax_Real_Literal --
448 -----------------------------
450 procedure Expand_Vax_Real_Literal
(N
: Node_Id
) is
451 Loc
: constant Source_Ptr
:= Sloc
(N
);
452 Typ
: constant Entity_Id
:= Etype
(N
);
453 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
454 Stat
: constant Boolean := Is_Static_Expression
(N
);
460 -- Entities for source, target and function call in conversion
463 -- We do not know how to convert Vax format real literals, so what
464 -- we do is to convert these to be IEEE literals, and introduce the
465 -- necessary conversion operation.
467 if Vax_Float
(Btyp
) then
468 -- What we want to construct here is
470 -- x!(y_to_z (1.0E0))
474 -- x is the base type of the literal (Btyp)
478 -- s_to_f for F_Float
479 -- t_to_g for G_Float
480 -- t_to_d for D_Float
482 -- The literal is typed as S (for F_Float) or T otherwise
484 -- We do all our own construction, analysis, and expansion here,
485 -- since things are at too low a level to use Analyze or Expand
486 -- to get this built (we get circularities and other strange
487 -- problems if we try!)
489 if Digits_Value
(Btyp
) = VAXFF_Digits
then
492 RE_Fncall
:= RE_S_To_F
;
494 elsif Digits_Value
(Btyp
) = VAXDF_Digits
then
497 RE_Fncall
:= RE_T_To_D
;
499 else pragma Assert
(Digits_Value
(Btyp
) = VAXGF_Digits
);
502 RE_Fncall
:= RE_T_To_G
;
505 Nod
:= Relocate_Node
(N
);
507 Set_Etype
(Nod
, RTE
(RE_Source
));
508 Set_Analyzed
(Nod
, True);
511 Make_Function_Call
(Loc
,
512 Name
=> New_Occurrence_Of
(RTE
(RE_Fncall
), Loc
),
513 Parameter_Associations
=> New_List
(Nod
));
515 Set_Etype
(Nod
, RTE
(RE_Target
));
516 Set_Analyzed
(Nod
, True);
519 Make_Unchecked_Type_Conversion
(Loc
,
520 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
523 Set_Etype
(Nod
, Typ
);
524 Set_Analyzed
(Nod
, True);
527 -- This odd expression is still a static expression. Note that
528 -- the routine Sem_Eval.Expr_Value_R understands this.
530 Set_Is_Static_Expression
(N
, Stat
);
532 end Expand_Vax_Real_Literal
;
534 ----------------------
535 -- Expand_Vax_Valid --
536 ----------------------
538 procedure Expand_Vax_Valid
(N
: Node_Id
) is
539 Loc
: constant Source_Ptr
:= Sloc
(N
);
540 Pref
: constant Node_Id
:= Prefix
(N
);
541 Ptyp
: constant Entity_Id
:= Root_Type
(Etype
(Pref
));
542 Rtyp
: constant Entity_Id
:= Etype
(N
);
547 if Digits_Value
(Ptyp
) = VAXFF_Digits
then
550 elsif Digits_Value
(Ptyp
) = VAXDF_Digits
then
553 else pragma Assert
(Digits_Value
(Ptyp
) = VAXGF_Digits
);
560 Make_Function_Call
(Loc
,
561 Name
=> New_Occurrence_Of
(RTE
(Func
), Loc
),
562 Parameter_Associations
=> New_List
(
563 Convert_To
(RTE
(Vtyp
), Pref
)))));
565 Analyze_And_Resolve
(N
);
566 end Expand_Vax_Valid
;