1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
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          --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1997-2000 Free Software Foundation, Inc.          --
10--                       (Version for Alpha OpenVMS)                        --
11--                                                                          --
12-- GNAT is free software;  you can  redistribute it  and/or modify it under --
13-- terms of the  GNU General Public License as published  by the Free Soft- --
14-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
15-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
16-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
17-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
18-- for  more details.  You should have  received  a copy of the GNU General --
19-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
20-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
21-- MA 02111-1307, USA.                                                      --
22--                                                                          --
23-- As a special exception,  if other files  instantiate  generics from this --
24-- unit, or you link  this unit with other files  to produce an executable, --
25-- this  unit  does not  by itself cause  the resulting  executable  to  be --
26-- covered  by the  GNU  General  Public  License.  This exception does not --
27-- however invalidate  any other reasons why  the executable file  might be --
28-- covered by the  GNU Public License.                                      --
29--                                                                          --
30-- GNAT was originally developed  by the GNAT team at  New York University. --
31-- Extensive contributions were provided by Ada Core Technologies Inc.      --
32--                                                                          --
33------------------------------------------------------------------------------
34
35with System.IO;           use System.IO;
36with System.Machine_Code; use System.Machine_Code;
37
38package body System.Vax_Float_Operations is
39
40   --  Ensure this gets compiled with -O to avoid extra (and possibly
41   --  improper) memory stores.
42
43   pragma Optimize (Time);
44
45   --  Declare the functions that do the conversions between floating-point
46   --  formats.  Call the operands IEEE float so they get passed in
47   --  FP registers.
48
49   function Cvt_G_T (X : T) return T;
50   function Cvt_T_G (X : T) return T;
51   function Cvt_T_F (X : T) return S;
52
53   pragma Import (C, Cvt_G_T, "OTS$CVT_FLOAT_G_T");
54   pragma Import (C, Cvt_T_G, "OTS$CVT_FLOAT_T_G");
55   pragma Import (C, Cvt_T_F, "OTS$CVT_FLOAT_T_F");
56
57   --  In each of the conversion routines that are done with OTS calls,
58   --  we define variables of the corresponding IEEE type so that they are
59   --  passed and kept in the proper register class.
60
61   ------------
62   -- D_To_G --
63   ------------
64
65   function D_To_G (X : D) return G is
66      A, B : T;
67      C : G;
68
69   begin
70      Asm ("ldg %0,%1", T'Asm_Output ("=f", A), D'Asm_Input ("m", X));
71      Asm ("cvtdg %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
72      Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
73      return C;
74   end D_To_G;
75
76   ------------
77   -- F_To_G --
78   ------------
79
80   function F_To_G (X : F) return G is
81      A : T;
82      B : G;
83
84   begin
85      Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X));
86      Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
87      return B;
88   end F_To_G;
89
90   ------------
91   -- F_To_S --
92   ------------
93
94   function F_To_S (X : F) return S is
95      A : T;
96      B : S;
97
98   begin
99      --  Because converting to a wider FP format is a no-op, we say
100      --  A is 64-bit even though we are loading 32 bits into it.
101      Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X));
102
103      B := S (Cvt_G_T (A));
104      return B;
105   end F_To_S;
106
107   ------------
108   -- G_To_D --
109   ------------
110
111   function G_To_D (X : G) return D is
112      A, B : T;
113      C : D;
114
115   begin
116      Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
117      Asm ("cvtgd %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
118      Asm ("stg %1,%0", D'Asm_Output ("=m", C), T'Asm_Input ("f", B));
119      return C;
120   end G_To_D;
121
122   ------------
123   -- G_To_F --
124   ------------
125
126   function G_To_F (X : G) return F is
127      A : T;
128      B : S;
129      C : F;
130
131   begin
132      Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
133      Asm ("cvtgf %1,%0", S'Asm_Output ("=f", B), T'Asm_Input ("f", A));
134      Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
135      return C;
136   end G_To_F;
137
138   ------------
139   -- G_To_Q --
140   ------------
141
142   function G_To_Q (X : G) return Q is
143      A : T;
144      B : Q;
145
146   begin
147      Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
148      Asm ("cvtgq %1,%0", Q'Asm_Output ("=f", B), T'Asm_Input ("f", A));
149      return B;
150   end G_To_Q;
151
152   ------------
153   -- G_To_T --
154   ------------
155
156   function G_To_T (X : G) return T is
157      A, B : T;
158
159   begin
160      Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
161      B := Cvt_G_T (A);
162      return B;
163   end G_To_T;
164
165   ------------
166   -- F_To_Q --
167   ------------
168
169   function F_To_Q (X : F) return Q is
170   begin
171      return G_To_Q (F_To_G (X));
172   end F_To_Q;
173
174   ------------
175   -- Q_To_F --
176   ------------
177
178   function Q_To_F (X : Q) return F is
179      A : S;
180      B : F;
181
182   begin
183      Asm ("cvtqf %1,%0", S'Asm_Output ("=f", A), Q'Asm_Input ("f", X));
184      Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A));
185      return B;
186   end Q_To_F;
187
188   ------------
189   -- Q_To_G --
190   ------------
191
192   function Q_To_G (X : Q) return G is
193      A : T;
194      B : G;
195
196   begin
197      Asm ("cvtqg %1,%0", T'Asm_Output ("=f", A), Q'Asm_Input ("f", X));
198      Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
199      return B;
200   end Q_To_G;
201
202   ------------
203   -- S_To_F --
204   ------------
205
206   function S_To_F (X : S) return F is
207      A : S;
208      B : F;
209
210   begin
211      A := Cvt_T_F (T (X));
212      Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A));
213      return B;
214   end S_To_F;
215
216   ------------
217   -- T_To_D --
218   ------------
219
220   function T_To_D (X : T) return D is
221   begin
222      return G_To_D (T_To_G (X));
223   end T_To_D;
224
225   ------------
226   -- T_To_G --
227   ------------
228
229   function T_To_G (X : T) return G is
230      A : T;
231      B : G;
232
233   begin
234      A := Cvt_T_G (X);
235      Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
236      return B;
237   end T_To_G;
238
239   -----------
240   -- Abs_F --
241   -----------
242
243   function Abs_F (X : F) return F is
244      A, B : S;
245      C : F;
246
247   begin
248      Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
249      Asm ("cpys $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A));
250      Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
251      return C;
252   end Abs_F;
253
254   -----------
255   -- Abs_G --
256   -----------
257
258   function Abs_G (X : G) return G is
259      A, B : T;
260      C : G;
261
262   begin
263      Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
264      Asm ("cpys $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
265      Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
266      return C;
267   end Abs_G;
268
269   -----------
270   -- Add_F --
271   -----------
272
273   function Add_F (X, Y : F) return F is
274      X1, Y1, R : S;
275      R1 : F;
276
277   begin
278      Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
279      Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
280      Asm ("addf %1,%2,%0", S'Asm_Output ("=f", R),
281           (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
282      Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
283      return R1;
284   end Add_F;
285
286   -----------
287   -- Add_G --
288   -----------
289
290   function Add_G (X, Y : G) return G is
291      X1, Y1, R : T;
292      R1 : G;
293
294   begin
295      Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
296      Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
297      Asm ("addg %1,%2,%0", T'Asm_Output ("=f", R),
298           (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
299      Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
300      return R1;
301   end Add_G;
302
303   --------------------
304   -- Debug_Output_D --
305   --------------------
306
307   procedure Debug_Output_D (Arg : D) is
308   begin
309      Put (D'Image (Arg));
310   end Debug_Output_D;
311
312   --------------------
313   -- Debug_Output_F --
314   --------------------
315
316   procedure Debug_Output_F (Arg : F) is
317   begin
318      Put (F'Image (Arg));
319   end Debug_Output_F;
320
321   --------------------
322   -- Debug_Output_G --
323   --------------------
324
325   procedure Debug_Output_G (Arg : G) is
326   begin
327      Put (G'Image (Arg));
328   end Debug_Output_G;
329
330   --------------------
331   -- Debug_String_D --
332   --------------------
333
334   Debug_String_Buffer : String (1 .. 32);
335   --  Buffer used by all Debug_String_x routines for returning result
336
337   function Debug_String_D (Arg : D) return System.Address is
338      Image_String : constant String := D'Image (Arg) & ASCII.NUL;
339      Image_Size   : constant Integer := Image_String'Length;
340
341   begin
342      Debug_String_Buffer (1 .. Image_Size) := Image_String;
343      return Debug_String_Buffer (1)'Address;
344   end Debug_String_D;
345
346   --------------------
347   -- Debug_String_F --
348   --------------------
349
350   function Debug_String_F (Arg : F) return System.Address is
351      Image_String : constant String := F'Image (Arg) & ASCII.NUL;
352      Image_Size   : constant Integer := Image_String'Length;
353
354   begin
355      Debug_String_Buffer (1 .. Image_Size) := Image_String;
356      return Debug_String_Buffer (1)'Address;
357   end Debug_String_F;
358
359   --------------------
360   -- Debug_String_G --
361   --------------------
362
363   function Debug_String_G (Arg : G) return System.Address is
364      Image_String : constant String := G'Image (Arg) & ASCII.NUL;
365      Image_Size   : constant Integer := Image_String'Length;
366
367   begin
368      Debug_String_Buffer (1 .. Image_Size) := Image_String;
369      return Debug_String_Buffer (1)'Address;
370   end Debug_String_G;
371
372   -----------
373   -- Div_F --
374   -----------
375
376   function Div_F (X, Y : F) return F is
377      X1, Y1, R : S;
378
379      R1 : F;
380   begin
381      Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
382      Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
383      Asm ("divf %1,%2,%0", S'Asm_Output ("=f", R),
384           (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
385      Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
386      return R1;
387   end Div_F;
388
389   -----------
390   -- Div_G --
391   -----------
392
393   function Div_G (X, Y : G) return G is
394      X1, Y1, R : T;
395      R1 : G;
396
397   begin
398      Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
399      Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
400      Asm ("divg %1,%2,%0", T'Asm_Output ("=f", R),
401           (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
402      Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
403      return R1;
404   end Div_G;
405
406   ----------
407   -- Eq_F --
408   ----------
409
410   function Eq_F (X, Y : F) return Boolean is
411      X1, Y1, R : S;
412
413   begin
414      Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
415      Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
416      Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R),
417           (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
418      return R /= 0.0;
419   end Eq_F;
420
421   ----------
422   -- Eq_G --
423   ----------
424
425   function Eq_G (X, Y : G) return Boolean is
426      X1, Y1, R : T;
427
428   begin
429      Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
430      Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
431      Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R),
432           (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
433      return R /= 0.0;
434   end Eq_G;
435
436   ----------
437   -- Le_F --
438   ----------
439
440   function Le_F (X, Y : F) return Boolean is
441      X1, Y1, R : S;
442
443   begin
444      Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
445      Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
446      Asm ("cmpgle %1,%2,%0", S'Asm_Output ("=f", R),
447           (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
448      return R /= 0.0;
449   end Le_F;
450
451   ----------
452   -- Le_G --
453   ----------
454
455   function Le_G (X, Y : G) return Boolean is
456      X1, Y1, R : T;
457
458   begin
459      Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
460      Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
461      Asm ("cmpgle %1,%2,%0", T'Asm_Output ("=f", R),
462           (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
463      return R /= 0.0;
464   end Le_G;
465
466   ----------
467   -- Lt_F --
468   ----------
469
470   function Lt_F (X, Y : F) return Boolean is
471      X1, Y1, R : S;
472
473   begin
474      Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
475      Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
476      Asm ("cmpglt %1,%2,%0", S'Asm_Output ("=f", R),
477           (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
478      return R /= 0.0;
479   end Lt_F;
480
481   ----------
482   -- Lt_G --
483   ----------
484
485   function Lt_G (X, Y : G) return Boolean is
486      X1, Y1, R : T;
487
488   begin
489      Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
490      Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
491      Asm ("cmpglt %1,%2,%0", T'Asm_Output ("=f", R),
492           (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
493      return R /= 0.0;
494   end Lt_G;
495
496   -----------
497   -- Mul_F --
498   -----------
499
500   function Mul_F (X, Y : F) return F is
501      X1, Y1, R : S;
502      R1 : F;
503
504   begin
505      Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
506      Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
507      Asm ("mulf %1,%2,%0", S'Asm_Output ("=f", R),
508           (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
509      Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
510      return R1;
511   end Mul_F;
512
513   -----------
514   -- Mul_G --
515   -----------
516
517   function Mul_G (X, Y : G) return G is
518      X1, Y1, R : T;
519      R1 : G;
520
521   begin
522      Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
523      Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
524      Asm ("mulg %1,%2,%0", T'Asm_Output ("=f", R),
525           (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
526      Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
527      return R1;
528   end Mul_G;
529
530   -----------
531   -- Neg_F --
532   -----------
533
534   function Neg_F (X : F) return F is
535      A, B : S;
536      C : F;
537
538   begin
539      Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
540      Asm ("cpysn %1,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A));
541      Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
542      return C;
543   end Neg_F;
544
545   -----------
546   -- Neg_G --
547   -----------
548
549   function Neg_G (X : G) return G is
550      A, B : T;
551      C : G;
552
553   begin
554      Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
555      Asm ("cpysn %1,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
556      Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
557      return C;
558   end Neg_G;
559
560   --------
561   -- pd --
562   --------
563
564   procedure pd (Arg : D) is
565   begin
566      Put_Line (D'Image (Arg));
567   end pd;
568
569   --------
570   -- pf --
571   --------
572
573   procedure pf (Arg : F) is
574   begin
575      Put_Line (F'Image (Arg));
576   end pf;
577
578   --------
579   -- pg --
580   --------
581
582   procedure pg (Arg : G) is
583   begin
584      Put_Line (G'Image (Arg));
585   end pg;
586
587   -----------
588   -- Sub_F --
589   -----------
590
591   function Sub_F (X, Y : F) return F is
592      X1, Y1, R : S;
593      R1 : F;
594
595   begin
596      Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
597      Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
598      Asm ("subf %1,%2,%0", S'Asm_Output ("=f", R),
599           (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
600      Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
601      return R1;
602   end Sub_F;
603
604   -----------
605   -- Sub_G --
606   -----------
607
608   function Sub_G (X, Y : G) return G is
609      X1, Y1, R : T;
610      R1 : G;
611
612   begin
613      Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
614      Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
615      Asm ("subg %1,%2,%0", T'Asm_Output ("=f", R),
616           (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
617      Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
618      return R1;
619   end Sub_G;
620
621end System.Vax_Float_Operations;
622