1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2002 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 Snames
; use Snames
;
35 with Stand
; use Stand
;
36 with Tbuild
; use Tbuild
;
37 with Ttypef
; use Ttypef
;
38 with Uintp
; use Uintp
;
39 with Urealp
; use Urealp
;
41 package body Exp_VFpt
is
43 ----------------------
44 -- Expand_Vax_Arith --
45 ----------------------
47 procedure Expand_Vax_Arith
(N
: Node_Id
) is
48 Loc
: constant Source_Ptr
:= Sloc
(N
);
49 Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
56 -- Get arithmetic type, note that we do D stuff in G
58 if Digits_Value
(Typ
) = VAXFF_Digits
then
103 when N_Op_Subtract
=>
118 if Nkind
(N
) in N_Binary_Op
then
120 Convert_To
(Atyp
, Left_Opnd
(N
)));
124 Convert_To
(Atyp
, Right_Opnd
(N
)));
128 Make_Function_Call
(Loc
,
129 Name
=> New_Occurrence_Of
(RTE
(Func
), Loc
),
130 Parameter_Associations
=> Args
)));
132 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
133 end Expand_Vax_Arith
;
135 ---------------------------
136 -- Expand_Vax_Comparison --
137 ---------------------------
139 procedure Expand_Vax_Comparison
(N
: Node_Id
) is
140 Loc
: constant Source_Ptr
:= Sloc
(N
);
141 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Left_Opnd
(N
)));
145 Revrs
: Boolean := False;
149 -- Get arithmetic type, note that we do D stuff in G
151 if Digits_Value
(Typ
) = VAXFF_Digits
then
208 Convert_To
(Atyp
, Left_Opnd
(N
)),
209 Convert_To
(Atyp
, Right_Opnd
(N
)));
213 Convert_To
(Atyp
, Right_Opnd
(N
)),
214 Convert_To
(Atyp
, Left_Opnd
(N
)));
218 Make_Function_Call
(Loc
,
219 Name
=> New_Occurrence_Of
(RTE
(Func
), Loc
),
220 Parameter_Associations
=> Args
));
222 Analyze_And_Resolve
(N
, Standard_Boolean
, Suppress
=> All_Checks
);
223 end Expand_Vax_Comparison
;
225 ---------------------------
226 -- Expand_Vax_Conversion --
227 ---------------------------
229 procedure Expand_Vax_Conversion
(N
: Node_Id
) is
230 Loc
: constant Source_Ptr
:= Sloc
(N
);
231 Expr
: constant Node_Id
:= Expression
(N
);
232 S_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Expr
));
233 T_Typ
: constant Entity_Id
:= Base_Type
(Etype
(N
));
239 function Call_Type
(T
: Entity_Id
; Otyp
: Entity_Id
) return RE_Id
;
240 -- Given one of the two types T, determines the coresponding call
241 -- type, i.e. the type to be used for the call (or the result of
242 -- the call). The actual operand is converted to (or from) this type.
243 -- Otyp is the other type, which is useful in figuring out the result.
244 -- The result returned is the RE_Id value for the type entity.
246 function Equivalent_Integer_Type
(T
: Entity_Id
) return Entity_Id
;
247 -- Find the predefined integer type that has the same size as the
248 -- fixed-point type T, for use in fixed/float conversions.
254 function Call_Type
(T
: Entity_Id
; Otyp
: Entity_Id
) return RE_Id
is
258 if Vax_Float
(T
) then
259 if Digits_Value
(T
) = VAXFF_Digits
then
262 elsif Digits_Value
(T
) = VAXGF_Digits
then
265 -- For D_Float, leave it as D float if the other operand is
266 -- G_Float, since this is the one conversion that is properly
267 -- supported for D_Float, but otherwise, use G_Float.
269 else pragma Assert
(Digits_Value
(T
) = VAXDF_Digits
);
272 and then Digits_Value
(Otyp
) = VAXGF_Digits
280 -- For all discrete types, use 64-bit integer
282 elsif Is_Discrete_Type
(T
) then
285 -- For all real types (other than Vax float format), we use the
286 -- IEEE float-type which corresponds in length to the other type
287 -- (which is Vax Float).
289 else pragma Assert
(Is_Real_Type
(T
));
291 if Digits_Value
(Otyp
) = VAXFF_Digits
then
299 function Equivalent_Integer_Type
(T
: Entity_Id
) return Entity_Id
is
301 if Esize
(T
) = Esize
(Standard_Long_Long_Integer
) then
302 return Standard_Long_Long_Integer
;
304 elsif Esize
(T
) = Esize
(Standard_Long_Integer
) then
305 return Standard_Long_Integer
;
308 return Standard_Integer
;
310 end Equivalent_Integer_Type
;
312 -- Start of processing for Expand_Vax_Conversion;
315 -- If input and output are the same Vax type, we change the
316 -- conversion to be an unchecked conversion and that's it.
318 if Vax_Float
(S_Typ
) and then Vax_Float
(T_Typ
)
319 and then Digits_Value
(S_Typ
) = Digits_Value
(T_Typ
)
322 Unchecked_Convert_To
(T_Typ
, Expr
));
324 elsif Is_Fixed_Point_Type
(S_Typ
) then
326 -- convert the scaled integer value to the target type, and multiply
327 -- by 'Small of type.
330 Make_Op_Multiply
(Loc
,
332 Make_Type_Conversion
(Loc
,
333 Subtype_Mark
=> New_Occurrence_Of
(T_Typ
, Loc
),
335 Unchecked_Convert_To
(
336 Equivalent_Integer_Type
(S_Typ
), Expr
)),
338 Make_Real_Literal
(Loc
, Realval
=> Small_Value
(S_Typ
))));
340 elsif Is_Fixed_Point_Type
(T_Typ
) then
342 -- multiply value by 'small of type, and convert to the corresponding
346 Unchecked_Convert_To
(T_Typ
,
347 Make_Type_Conversion
(Loc
,
349 New_Occurrence_Of
(Equivalent_Integer_Type
(T_Typ
), Loc
),
351 Make_Op_Multiply
(Loc
,
354 Make_Real_Literal
(Loc
,
355 Realval
=> Ureal_1
/ Small_Value
(T_Typ
))))));
360 -- Compute types for call
362 CallS
:= Call_Type
(S_Typ
, T_Typ
);
363 CallT
:= Call_Type
(T_Typ
, S_Typ
);
365 -- Get function and its types
367 if CallS
= RE_D
and then CallT
= RE_G
then
370 elsif CallS
= RE_G
and then CallT
= RE_D
then
373 elsif CallS
= RE_G
and then CallT
= RE_F
then
376 elsif CallS
= RE_F
and then CallT
= RE_G
then
379 elsif CallS
= RE_F
and then CallT
= RE_S
then
382 elsif CallS
= RE_S
and then CallT
= RE_F
then
385 elsif CallS
= RE_G
and then CallT
= RE_T
then
388 elsif CallS
= RE_T
and then CallT
= RE_G
then
391 elsif CallS
= RE_F
and then CallT
= RE_Q
then
394 elsif CallS
= RE_Q
and then CallT
= RE_F
then
397 elsif CallS
= RE_G
and then CallT
= RE_Q
then
400 else pragma Assert
(CallS
= RE_Q
and then CallT
= RE_G
);
406 Make_Function_Call
(Loc
,
407 Name
=> New_Occurrence_Of
(RTE
(Func
), Loc
),
408 Parameter_Associations
=> New_List
(
409 Convert_To
(RTE
(CallS
), Expr
)))));
412 Analyze_And_Resolve
(N
, T_Typ
, Suppress
=> All_Checks
);
413 end Expand_Vax_Conversion
;
415 -----------------------------
416 -- Expand_Vax_Real_Literal --
417 -----------------------------
419 procedure Expand_Vax_Real_Literal
(N
: Node_Id
) is
420 Loc
: constant Source_Ptr
:= Sloc
(N
);
421 Typ
: constant Entity_Id
:= Etype
(N
);
422 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
423 Stat
: constant Boolean := Is_Static_Expression
(N
);
429 -- Entities for source, target and function call in conversion
432 -- We do not know how to convert Vax format real literals, so what
433 -- we do is to convert these to be IEEE literals, and introduce the
434 -- necessary conversion operation.
436 if Vax_Float
(Btyp
) then
437 -- What we want to construct here is
439 -- x!(y_to_z (1.0E0))
443 -- x is the base type of the literal (Btyp)
447 -- s_to_f for F_Float
448 -- t_to_g for G_Float
449 -- t_to_d for D_Float
451 -- The literal is typed as S (for F_Float) or T otherwise
453 -- We do all our own construction, analysis, and expansion here,
454 -- since things are at too low a level to use Analyze or Expand
455 -- to get this built (we get circularities and other strange
456 -- problems if we try!)
458 if Digits_Value
(Btyp
) = VAXFF_Digits
then
461 RE_Fncall
:= RE_S_To_F
;
463 elsif Digits_Value
(Btyp
) = VAXDF_Digits
then
466 RE_Fncall
:= RE_T_To_D
;
468 else pragma Assert
(Digits_Value
(Btyp
) = VAXGF_Digits
);
471 RE_Fncall
:= RE_T_To_G
;
474 Nod
:= Relocate_Node
(N
);
476 Set_Etype
(Nod
, RTE
(RE_Source
));
477 Set_Analyzed
(Nod
, True);
480 Make_Function_Call
(Loc
,
481 Name
=> New_Occurrence_Of
(RTE
(RE_Fncall
), Loc
),
482 Parameter_Associations
=> New_List
(Nod
));
484 Set_Etype
(Nod
, RTE
(RE_Target
));
485 Set_Analyzed
(Nod
, True);
488 Make_Unchecked_Type_Conversion
(Loc
,
489 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
492 Set_Etype
(Nod
, Typ
);
493 Set_Analyzed
(Nod
, True);
496 -- This odd expression is still a static expression. Note that
497 -- the routine Sem_Eval.Expr_Value_R understands this.
499 Set_Is_Static_Expression
(N
, Stat
);
501 end Expand_Vax_Real_Literal
;