1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S --
11 -- Copyright (C) 1997-2000 Free Software Foundation, Inc. --
12 -- (Version for Alpha OpenVMS) --
14 -- GNAT is free software; you can redistribute it and/or modify it under --
15 -- terms of the GNU General Public License as published by the Free Soft- --
16 -- ware Foundation; either version 2, or (at your option) any later ver- --
17 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
18 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
19 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
20 -- for more details. You should have received a copy of the GNU General --
21 -- Public License distributed with GNAT; see file COPYING. If not, write --
22 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
23 -- MA 02111-1307, USA. --
25 -- As a special exception, if other files instantiate generics from this --
26 -- unit, or you link this unit with other files to produce an executable, --
27 -- this unit does not by itself cause the resulting executable to be --
28 -- covered by the GNU General Public License. This exception does not --
29 -- however invalidate any other reasons why the executable file might be --
30 -- covered by the GNU Public License. --
32 -- GNAT was originally developed by the GNAT team at New York University. --
33 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
35 ------------------------------------------------------------------------------
37 with System
.IO
; use System
.IO
;
38 with System
.Machine_Code
; use System
.Machine_Code
;
40 package body System
.Vax_Float_Operations
is
42 -- Ensure this gets compiled with -O to avoid extra (and possibly
43 -- improper) memory stores.
45 pragma Optimize
(Time
);
47 -- Declare the functions that do the conversions between floating-point
48 -- formats. Call the operands IEEE float so they get passed in
51 function Cvt_G_T
(X
: T
) return T
;
52 function Cvt_T_G
(X
: T
) return T
;
53 function Cvt_T_F
(X
: T
) return S
;
55 pragma Import
(C
, Cvt_G_T
, "OTS$CVT_FLOAT_G_T");
56 pragma Import
(C
, Cvt_T_G
, "OTS$CVT_FLOAT_T_G");
57 pragma Import
(C
, Cvt_T_F
, "OTS$CVT_FLOAT_T_F");
59 -- In each of the conversion routines that are done with OTS calls,
60 -- we define variables of the corresponding IEEE type so that they are
61 -- passed and kept in the proper register class.
67 function D_To_G
(X
: D
) return G
is
72 Asm
("ldg %0,%1", T
'Asm_Output ("=f", A
), D
'Asm_Input ("m", X
));
73 Asm
("cvtdg %1,%0", T
'Asm_Output ("=f", B
), T
'Asm_Input ("f", A
));
74 Asm
("stg %1,%0", G
'Asm_Output ("=m", C
), T
'Asm_Input ("f", B
));
82 function F_To_G
(X
: F
) return G
is
87 Asm
("ldf %0,%1", T
'Asm_Output ("=f", A
), F
'Asm_Input ("m", X
));
88 Asm
("stg %1,%0", G
'Asm_Output ("=m", B
), T
'Asm_Input ("f", A
));
96 function F_To_S
(X
: F
) return S
is
101 -- Because converting to a wider FP format is a no-op, we say
102 -- A is 64-bit even though we are loading 32 bits into it.
103 Asm
("ldf %0,%1", T
'Asm_Output ("=f", A
), F
'Asm_Input ("m", X
));
105 B
:= S
(Cvt_G_T
(A
));
113 function G_To_D
(X
: G
) return D
is
118 Asm
("ldg %0,%1", T
'Asm_Output ("=f", A
), G
'Asm_Input ("m", X
));
119 Asm
("cvtgd %1,%0", T
'Asm_Output ("=f", B
), T
'Asm_Input ("f", A
));
120 Asm
("stg %1,%0", D
'Asm_Output ("=m", C
), T
'Asm_Input ("f", B
));
128 function G_To_F
(X
: G
) return F
is
134 Asm
("ldg %0,%1", T
'Asm_Output ("=f", A
), G
'Asm_Input ("m", X
));
135 Asm
("cvtgf %1,%0", S
'Asm_Output ("=f", B
), T
'Asm_Input ("f", A
));
136 Asm
("stf %1,%0", F
'Asm_Output ("=m", C
), S
'Asm_Input ("f", B
));
144 function G_To_Q
(X
: G
) return Q
is
149 Asm
("ldg %0,%1", T
'Asm_Output ("=f", A
), G
'Asm_Input ("m", X
));
150 Asm
("cvtgq %1,%0", Q
'Asm_Output ("=f", B
), T
'Asm_Input ("f", A
));
158 function G_To_T
(X
: G
) return T
is
162 Asm
("ldg %0,%1", T
'Asm_Output ("=f", A
), G
'Asm_Input ("m", X
));
171 function F_To_Q
(X
: F
) return Q
is
173 return G_To_Q
(F_To_G
(X
));
180 function Q_To_F
(X
: Q
) return F
is
185 Asm
("cvtqf %1,%0", S
'Asm_Output ("=f", A
), Q
'Asm_Input ("f", X
));
186 Asm
("stf %1,%0", F
'Asm_Output ("=m", B
), S
'Asm_Input ("f", A
));
194 function Q_To_G
(X
: Q
) return G
is
199 Asm
("cvtqg %1,%0", T
'Asm_Output ("=f", A
), Q
'Asm_Input ("f", X
));
200 Asm
("stg %1,%0", G
'Asm_Output ("=m", B
), T
'Asm_Input ("f", A
));
208 function S_To_F
(X
: S
) return F
is
213 A
:= Cvt_T_F
(T
(X
));
214 Asm
("stf %1,%0", F
'Asm_Output ("=m", B
), S
'Asm_Input ("f", A
));
222 function T_To_D
(X
: T
) return D
is
224 return G_To_D
(T_To_G
(X
));
231 function T_To_G
(X
: T
) return G
is
237 Asm
("stg %1,%0", G
'Asm_Output ("=m", B
), T
'Asm_Input ("f", A
));
245 function Abs_F
(X
: F
) return F
is
250 Asm
("ldf %0,%1", S
'Asm_Output ("=f", A
), F
'Asm_Input ("m", X
));
251 Asm
("cpys $f31,%1,%0", S
'Asm_Output ("=f", B
), S
'Asm_Input ("f", A
));
252 Asm
("stf %1,%0", F
'Asm_Output ("=m", C
), S
'Asm_Input ("f", B
));
260 function Abs_G
(X
: G
) return G
is
265 Asm
("ldg %0,%1", T
'Asm_Output ("=f", A
), G
'Asm_Input ("m", X
));
266 Asm
("cpys $f31,%1,%0", T
'Asm_Output ("=f", B
), T
'Asm_Input ("f", A
));
267 Asm
("stg %1,%0", G
'Asm_Output ("=m", C
), T
'Asm_Input ("f", B
));
275 function Add_F
(X
, Y
: F
) return F
is
280 Asm
("ldf %0,%1", S
'Asm_Output ("=f", X1
), F
'Asm_Input ("m", X
));
281 Asm
("ldf %0,%1", S
'Asm_Output ("=f", Y1
), F
'Asm_Input ("m", Y
));
282 Asm
("addf %1,%2,%0", S
'Asm_Output ("=f", R
),
283 (S
'Asm_Input ("f", X1
), S
'Asm_Input ("f", Y1
)));
284 Asm
("stf %1,%0", F
'Asm_Output ("=m", R1
), S
'Asm_Input ("f", R
));
292 function Add_G
(X
, Y
: G
) return G
is
297 Asm
("ldg %0,%1", T
'Asm_Output ("=f", X1
), G
'Asm_Input ("m", X
));
298 Asm
("ldg %0,%1", T
'Asm_Output ("=f", Y1
), G
'Asm_Input ("m", Y
));
299 Asm
("addg %1,%2,%0", T
'Asm_Output ("=f", R
),
300 (T
'Asm_Input ("f", X1
), T
'Asm_Input ("f", Y1
)));
301 Asm
("stg %1,%0", G
'Asm_Output ("=m", R1
), T
'Asm_Input ("f", R
));
309 procedure Debug_Output_D
(Arg
: D
) is
318 procedure Debug_Output_F
(Arg
: F
) is
327 procedure Debug_Output_G
(Arg
: G
) is
336 Debug_String_Buffer
: String (1 .. 32);
337 -- Buffer used by all Debug_String_x routines for returning result
339 function Debug_String_D
(Arg
: D
) return System
.Address
is
340 Image_String
: constant String := D
'Image (Arg
) & ASCII
.NUL
;
341 Image_Size
: constant Integer := Image_String
'Length;
344 Debug_String_Buffer
(1 .. Image_Size
) := Image_String
;
345 return Debug_String_Buffer
(1)'Address;
352 function Debug_String_F
(Arg
: F
) return System
.Address
is
353 Image_String
: constant String := F
'Image (Arg
) & ASCII
.NUL
;
354 Image_Size
: constant Integer := Image_String
'Length;
357 Debug_String_Buffer
(1 .. Image_Size
) := Image_String
;
358 return Debug_String_Buffer
(1)'Address;
365 function Debug_String_G
(Arg
: G
) return System
.Address
is
366 Image_String
: constant String := G
'Image (Arg
) & ASCII
.NUL
;
367 Image_Size
: constant Integer := Image_String
'Length;
370 Debug_String_Buffer
(1 .. Image_Size
) := Image_String
;
371 return Debug_String_Buffer
(1)'Address;
378 function Div_F
(X
, Y
: F
) return F
is
383 Asm
("ldf %0,%1", S
'Asm_Output ("=f", X1
), F
'Asm_Input ("m", X
));
384 Asm
("ldf %0,%1", S
'Asm_Output ("=f", Y1
), F
'Asm_Input ("m", Y
));
385 Asm
("divf %1,%2,%0", S
'Asm_Output ("=f", R
),
386 (S
'Asm_Input ("f", X1
), S
'Asm_Input ("f", Y1
)));
387 Asm
("stf %1,%0", F
'Asm_Output ("=m", R1
), S
'Asm_Input ("f", R
));
395 function Div_G
(X
, Y
: G
) return G
is
400 Asm
("ldg %0,%1", T
'Asm_Output ("=f", X1
), G
'Asm_Input ("m", X
));
401 Asm
("ldg %0,%1", T
'Asm_Output ("=f", Y1
), G
'Asm_Input ("m", Y
));
402 Asm
("divg %1,%2,%0", T
'Asm_Output ("=f", R
),
403 (T
'Asm_Input ("f", X1
), T
'Asm_Input ("f", Y1
)));
404 Asm
("stg %1,%0", G
'Asm_Output ("=m", R1
), T
'Asm_Input ("f", R
));
412 function Eq_F
(X
, Y
: F
) return Boolean is
416 Asm
("ldf %0,%1", S
'Asm_Output ("=f", X1
), F
'Asm_Input ("m", X
));
417 Asm
("ldf %0,%1", S
'Asm_Output ("=f", Y1
), F
'Asm_Input ("m", Y
));
418 Asm
("cmpgeq %1,%2,%0", S
'Asm_Output ("=f", R
),
419 (S
'Asm_Input ("f", X1
), S
'Asm_Input ("f", Y1
)));
427 function Eq_G
(X
, Y
: G
) return Boolean is
431 Asm
("ldg %0,%1", T
'Asm_Output ("=f", X1
), G
'Asm_Input ("m", X
));
432 Asm
("ldg %0,%1", T
'Asm_Output ("=f", Y1
), G
'Asm_Input ("m", Y
));
433 Asm
("cmpgeq %1,%2,%0", T
'Asm_Output ("=f", R
),
434 (T
'Asm_Input ("f", X1
), T
'Asm_Input ("f", Y1
)));
442 function Le_F
(X
, Y
: F
) return Boolean is
446 Asm
("ldf %0,%1", S
'Asm_Output ("=f", X1
), F
'Asm_Input ("m", X
));
447 Asm
("ldf %0,%1", S
'Asm_Output ("=f", Y1
), F
'Asm_Input ("m", Y
));
448 Asm
("cmpgle %1,%2,%0", S
'Asm_Output ("=f", R
),
449 (S
'Asm_Input ("f", X1
), S
'Asm_Input ("f", Y1
)));
457 function Le_G
(X
, Y
: G
) return Boolean is
461 Asm
("ldg %0,%1", T
'Asm_Output ("=f", X1
), G
'Asm_Input ("m", X
));
462 Asm
("ldg %0,%1", T
'Asm_Output ("=f", Y1
), G
'Asm_Input ("m", Y
));
463 Asm
("cmpgle %1,%2,%0", T
'Asm_Output ("=f", R
),
464 (T
'Asm_Input ("f", X1
), T
'Asm_Input ("f", Y1
)));
472 function Lt_F
(X
, Y
: F
) return Boolean is
476 Asm
("ldf %0,%1", S
'Asm_Output ("=f", X1
), F
'Asm_Input ("m", X
));
477 Asm
("ldf %0,%1", S
'Asm_Output ("=f", Y1
), F
'Asm_Input ("m", Y
));
478 Asm
("cmpglt %1,%2,%0", S
'Asm_Output ("=f", R
),
479 (S
'Asm_Input ("f", X1
), S
'Asm_Input ("f", Y1
)));
487 function Lt_G
(X
, Y
: G
) return Boolean is
491 Asm
("ldg %0,%1", T
'Asm_Output ("=f", X1
), G
'Asm_Input ("m", X
));
492 Asm
("ldg %0,%1", T
'Asm_Output ("=f", Y1
), G
'Asm_Input ("m", Y
));
493 Asm
("cmpglt %1,%2,%0", T
'Asm_Output ("=f", R
),
494 (T
'Asm_Input ("f", X1
), T
'Asm_Input ("f", Y1
)));
502 function Mul_F
(X
, Y
: F
) return F
is
507 Asm
("ldf %0,%1", S
'Asm_Output ("=f", X1
), F
'Asm_Input ("m", X
));
508 Asm
("ldf %0,%1", S
'Asm_Output ("=f", Y1
), F
'Asm_Input ("m", Y
));
509 Asm
("mulf %1,%2,%0", S
'Asm_Output ("=f", R
),
510 (S
'Asm_Input ("f", X1
), S
'Asm_Input ("f", Y1
)));
511 Asm
("stf %1,%0", F
'Asm_Output ("=m", R1
), S
'Asm_Input ("f", R
));
519 function Mul_G
(X
, Y
: G
) return G
is
524 Asm
("ldg %0,%1", T
'Asm_Output ("=f", X1
), G
'Asm_Input ("m", X
));
525 Asm
("ldg %0,%1", T
'Asm_Output ("=f", Y1
), G
'Asm_Input ("m", Y
));
526 Asm
("mulg %1,%2,%0", T
'Asm_Output ("=f", R
),
527 (T
'Asm_Input ("f", X1
), T
'Asm_Input ("f", Y1
)));
528 Asm
("stg %1,%0", G
'Asm_Output ("=m", R1
), T
'Asm_Input ("f", R
));
536 function Neg_F
(X
: F
) return F
is
541 Asm
("ldf %0,%1", S
'Asm_Output ("=f", A
), F
'Asm_Input ("m", X
));
542 Asm
("cpysn %1,%1,%0", S
'Asm_Output ("=f", B
), S
'Asm_Input ("f", A
));
543 Asm
("stf %1,%0", F
'Asm_Output ("=m", C
), S
'Asm_Input ("f", B
));
551 function Neg_G
(X
: G
) return G
is
556 Asm
("ldg %0,%1", T
'Asm_Output ("=f", A
), G
'Asm_Input ("m", X
));
557 Asm
("cpysn %1,%1,%0", T
'Asm_Output ("=f", B
), T
'Asm_Input ("f", A
));
558 Asm
("stg %1,%0", G
'Asm_Output ("=m", C
), T
'Asm_Input ("f", B
));
566 procedure pd
(Arg
: D
) is
568 Put_Line
(D
'Image (Arg
));
575 procedure pf
(Arg
: F
) is
577 Put_Line
(F
'Image (Arg
));
584 procedure pg
(Arg
: G
) is
586 Put_Line
(G
'Image (Arg
));
593 function Sub_F
(X
, Y
: F
) return F
is
598 Asm
("ldf %0,%1", S
'Asm_Output ("=f", X1
), F
'Asm_Input ("m", X
));
599 Asm
("ldf %0,%1", S
'Asm_Output ("=f", Y1
), F
'Asm_Input ("m", Y
));
600 Asm
("subf %1,%2,%0", S
'Asm_Output ("=f", R
),
601 (S
'Asm_Input ("f", X1
), S
'Asm_Input ("f", Y1
)));
602 Asm
("stf %1,%0", F
'Asm_Output ("=m", R1
), S
'Asm_Input ("f", R
));
610 function Sub_G
(X
, Y
: G
) return G
is
615 Asm
("ldg %0,%1", T
'Asm_Output ("=f", X1
), G
'Asm_Input ("m", X
));
616 Asm
("ldg %0,%1", T
'Asm_Output ("=f", Y1
), G
'Asm_Input ("m", Y
));
617 Asm
("subg %1,%2,%0", T
'Asm_Output ("=f", R
),
618 (T
'Asm_Input ("f", X1
), T
'Asm_Input ("f", Y1
)));
619 Asm
("stg %1,%0", G
'Asm_Output ("=m", R1
), T
'Asm_Input ("f", R
));
623 end System
.Vax_Float_Operations
;