OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [s-vaflop.adb] - Blame information for rev 826

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT RUN-TIME 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-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
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.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
--  This is a dummy body for use on non-Alpha systems so that the library
33
--  can compile. This dummy version uses ordinary conversions and other
34
--  arithmetic operations. It is used only for testing purposes in the
35
--  case where the -gnatdm switch is used to force testing of VMS features
36
--  on non-VMS systems.
37
 
38
with System.IO;
39
 
40
package body System.Vax_Float_Operations is
41
   pragma Warnings (Off);
42
   --  Warnings about infinite recursion when the -gnatdm switch is used
43
 
44
   -----------
45
   -- Abs_F --
46
   -----------
47
 
48
   function Abs_F (X : F) return F is
49
   begin
50
      return abs X;
51
   end Abs_F;
52
 
53
   -----------
54
   -- Abs_G --
55
   -----------
56
 
57
   function Abs_G (X : G) return G is
58
   begin
59
      return abs X;
60
   end Abs_G;
61
 
62
   -----------
63
   -- Add_F --
64
   -----------
65
 
66
   function Add_F (X, Y : F) return F is
67
   begin
68
      return X + Y;
69
   end Add_F;
70
 
71
   -----------
72
   -- Add_G --
73
   -----------
74
 
75
   function Add_G (X, Y : G) return G is
76
   begin
77
      return X + Y;
78
   end Add_G;
79
 
80
   ------------
81
   -- D_To_G --
82
   ------------
83
 
84
   function D_To_G (X : D) return G is
85
   begin
86
      return G (X);
87
   end D_To_G;
88
 
89
   --------------------
90
   -- Debug_Output_D --
91
   --------------------
92
 
93
   procedure Debug_Output_D (Arg : D) is
94
   begin
95
      System.IO.Put (D'Image (Arg));
96
   end Debug_Output_D;
97
 
98
   --------------------
99
   -- Debug_Output_F --
100
   --------------------
101
 
102
   procedure Debug_Output_F (Arg : F) is
103
   begin
104
      System.IO.Put (F'Image (Arg));
105
   end Debug_Output_F;
106
 
107
   --------------------
108
   -- Debug_Output_G --
109
   --------------------
110
 
111
   procedure Debug_Output_G (Arg : G) is
112
   begin
113
      System.IO.Put (G'Image (Arg));
114
   end Debug_Output_G;
115
 
116
   --------------------
117
   -- Debug_String_D --
118
   --------------------
119
 
120
   Debug_String_Buffer : String (1 .. 32);
121
   --  Buffer used by all Debug_String_x routines for returning result
122
 
123
   function Debug_String_D (Arg : D) return System.Address is
124
      Image_String : constant String := D'Image (Arg) & ASCII.NUL;
125
      Image_Size   : constant Integer := Image_String'Length;
126
 
127
   begin
128
      Debug_String_Buffer (1 .. Image_Size) := Image_String;
129
      return Debug_String_Buffer (1)'Address;
130
   end Debug_String_D;
131
 
132
   --------------------
133
   -- Debug_String_F --
134
   --------------------
135
 
136
   function Debug_String_F (Arg : F) return System.Address is
137
      Image_String : constant String := F'Image (Arg) & ASCII.NUL;
138
      Image_Size   : constant Integer := Image_String'Length;
139
 
140
   begin
141
      Debug_String_Buffer (1 .. Image_Size) := Image_String;
142
      return Debug_String_Buffer (1)'Address;
143
   end Debug_String_F;
144
 
145
   --------------------
146
   -- Debug_String_G --
147
   --------------------
148
 
149
   function Debug_String_G (Arg : G) return System.Address is
150
      Image_String : constant String := G'Image (Arg) & ASCII.NUL;
151
      Image_Size   : constant Integer := Image_String'Length;
152
 
153
   begin
154
      Debug_String_Buffer (1 .. Image_Size) := Image_String;
155
      return Debug_String_Buffer (1)'Address;
156
   end Debug_String_G;
157
 
158
   -----------
159
   -- Div_F --
160
   -----------
161
 
162
   function Div_F (X, Y : F) return F is
163
   begin
164
      return X / Y;
165
   end Div_F;
166
 
167
   -----------
168
   -- Div_G --
169
   -----------
170
 
171
   function Div_G (X, Y : G) return G is
172
   begin
173
      return X / Y;
174
   end Div_G;
175
 
176
   ----------
177
   -- Eq_F --
178
   ----------
179
 
180
   function Eq_F (X, Y : F) return Boolean is
181
   begin
182
      return X = Y;
183
   end Eq_F;
184
 
185
   ----------
186
   -- Eq_G --
187
   ----------
188
 
189
   function Eq_G (X, Y : G) return Boolean is
190
   begin
191
      return X = Y;
192
   end Eq_G;
193
 
194
   ------------
195
   -- F_To_G --
196
   ------------
197
 
198
   function F_To_G (X : F) return G is
199
   begin
200
      return G (X);
201
   end F_To_G;
202
 
203
   ------------
204
   -- F_To_Q --
205
   ------------
206
 
207
   function F_To_Q (X : F) return Q is
208
   begin
209
      return Q (X);
210
   end F_To_Q;
211
 
212
   ------------
213
   -- F_To_S --
214
   ------------
215
 
216
   function F_To_S (X : F) return S is
217
   begin
218
      return S (X);
219
   end F_To_S;
220
 
221
   ------------
222
   -- G_To_D --
223
   ------------
224
 
225
   function G_To_D (X : G) return D is
226
   begin
227
      return D (X);
228
   end G_To_D;
229
 
230
   ------------
231
   -- G_To_F --
232
   ------------
233
 
234
   function G_To_F (X : G) return F is
235
   begin
236
      return F (X);
237
   end G_To_F;
238
 
239
   ------------
240
   -- G_To_Q --
241
   ------------
242
 
243
   function G_To_Q (X : G) return Q is
244
   begin
245
      return Q (X);
246
   end G_To_Q;
247
 
248
   ------------
249
   -- G_To_T --
250
   ------------
251
 
252
   function G_To_T (X : G) return T is
253
   begin
254
      return T (X);
255
   end G_To_T;
256
 
257
   ----------
258
   -- Le_F --
259
   ----------
260
 
261
   function Le_F (X, Y : F) return Boolean is
262
   begin
263
      return X <= Y;
264
   end Le_F;
265
 
266
   ----------
267
   -- Le_G --
268
   ----------
269
 
270
   function Le_G (X, Y : G) return Boolean is
271
   begin
272
      return X <= Y;
273
   end Le_G;
274
 
275
   ----------
276
   -- Lt_F --
277
   ----------
278
 
279
   function Lt_F (X, Y : F) return Boolean is
280
   begin
281
      return X < Y;
282
   end Lt_F;
283
 
284
   ----------
285
   -- Lt_G --
286
   ----------
287
 
288
   function Lt_G (X, Y : G) return Boolean is
289
   begin
290
      return X < Y;
291
   end Lt_G;
292
 
293
   -----------
294
   -- Mul_F --
295
   -----------
296
 
297
   function Mul_F (X, Y : F) return F is
298
   begin
299
      return X * Y;
300
   end Mul_F;
301
 
302
   -----------
303
   -- Mul_G --
304
   -----------
305
 
306
   function Mul_G (X, Y : G) return G is
307
   begin
308
      return X * Y;
309
   end Mul_G;
310
 
311
   ----------
312
   -- Ne_F --
313
   ----------
314
 
315
   function Ne_F (X, Y : F) return Boolean is
316
   begin
317
      return X /= Y;
318
   end Ne_F;
319
 
320
   ----------
321
   -- Ne_G --
322
   ----------
323
 
324
   function Ne_G (X, Y : G) return Boolean is
325
   begin
326
      return X /= Y;
327
   end Ne_G;
328
 
329
   -----------
330
   -- Neg_F --
331
   -----------
332
 
333
   function Neg_F (X : F) return F is
334
   begin
335
      return -X;
336
   end Neg_F;
337
 
338
   -----------
339
   -- Neg_G --
340
   -----------
341
 
342
   function Neg_G (X : G) return G is
343
   begin
344
      return -X;
345
   end Neg_G;
346
 
347
   --------
348
   -- pd --
349
   --------
350
 
351
   procedure pd (Arg : D) is
352
   begin
353
      System.IO.Put_Line (D'Image (Arg));
354
   end pd;
355
 
356
   --------
357
   -- pf --
358
   --------
359
 
360
   procedure pf (Arg : F) is
361
   begin
362
      System.IO.Put_Line (F'Image (Arg));
363
   end pf;
364
 
365
   --------
366
   -- pg --
367
   --------
368
 
369
   procedure pg (Arg : G) is
370
   begin
371
      System.IO.Put_Line (G'Image (Arg));
372
   end pg;
373
 
374
   ------------
375
   -- Q_To_F --
376
   ------------
377
 
378
   function Q_To_F (X : Q) return F is
379
   begin
380
      return F (X);
381
   end Q_To_F;
382
 
383
   ------------
384
   -- Q_To_G --
385
   ------------
386
 
387
   function Q_To_G (X : Q) return G is
388
   begin
389
      return G (X);
390
   end Q_To_G;
391
 
392
   ------------
393
   -- S_To_F --
394
   ------------
395
 
396
   function S_To_F (X : S) return F is
397
   begin
398
      return F (X);
399
   end S_To_F;
400
 
401
   --------------
402
   -- Return_D --
403
   --------------
404
 
405
   function Return_D (X : D) return D is
406
   begin
407
      return X;
408
   end Return_D;
409
 
410
   --------------
411
   -- Return_F --
412
   --------------
413
 
414
   function Return_F (X : F) return F is
415
   begin
416
      return X;
417
   end Return_F;
418
 
419
   --------------
420
   -- Return_G --
421
   --------------
422
 
423
   function Return_G (X : G) return G is
424
   begin
425
      return X;
426
   end Return_G;
427
 
428
   -----------
429
   -- Sub_F --
430
   -----------
431
 
432
   function Sub_F (X, Y : F) return F is
433
   begin
434
      return X - Y;
435
   end Sub_F;
436
 
437
   -----------
438
   -- Sub_G --
439
   -----------
440
 
441
   function Sub_G (X, Y : G) return G is
442
   begin
443
      return X - Y;
444
   end Sub_G;
445
 
446
   ------------
447
   -- T_To_D --
448
   ------------
449
 
450
   function T_To_D (X : T) return D is
451
   begin
452
      return G_To_D (T_To_G (X));
453
   end T_To_D;
454
 
455
   ------------
456
   -- T_To_G --
457
   ------------
458
 
459
   function T_To_G (X : T) return G is
460
   begin
461
      return G (X);
462
   end T_To_G;
463
 
464
   -------------
465
   -- Valid_D --
466
   -------------
467
 
468
   --  For now, convert to IEEE and do Valid test on result. This is not quite
469
   --  accurate, but is good enough in practice.
470
 
471
   function Valid_D (Arg : D) return Boolean is
472
      Val : constant T := G_To_T (D_To_G (Arg));
473
   begin
474
      return Val'Valid;
475
   end Valid_D;
476
 
477
   -------------
478
   -- Valid_F --
479
   -------------
480
 
481
   --  For now, convert to IEEE and do Valid test on result. This is not quite
482
   --  accurate, but is good enough in practice.
483
 
484
   function Valid_F (Arg : F) return Boolean is
485
      Val : constant S := F_To_S (Arg);
486
   begin
487
      return Val'Valid;
488
   end Valid_F;
489
 
490
   -------------
491
   -- Valid_G --
492
   -------------
493
 
494
   --  For now, convert to IEEE and do Valid test on result. This is not quite
495
   --  accurate, but is good enough in practice.
496
 
497
   function Valid_G (Arg : G) return Boolean is
498
      Val : constant T := G_To_T (Arg);
499
   begin
500
      return Val'Valid;
501
   end Valid_G;
502
 
503
end System.Vax_Float_Operations;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.