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

Subversion Repositories eco32

[/] [eco32/] [trunk/] [fp/] [implementation/] [arith/] [fp.c] - Blame information for rev 301

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 15 hellwig
#define sign_bit ((unsigned) 0x80000000)  \
2
 
3
#define ROUND_OFF 1
4
#define ROUND_UP 2
5
#define ROUND_DOWN 3
6
#define ROUND_NEAR 4 \
7
 
8
#define X_BIT (1<<8)
9
#define Z_BIT (1<<9)
10
#define U_BIT (1<<10)
11
#define O_BIT (1<<11)
12
#define I_BIT (1<<12)
13
#define W_BIT (1<<13)
14
#define V_BIT (1<<14)
15
#define D_BIT (1<<15)
16
#define E_BIT (1<<18)  \
17
 
18
#define zero_exponent (-1000)  \
19
 
20
#define bignum_prec 157 \
21
 
22
#define magic_offset 2112
23
#define origin 37 \
24
 
25
#define buf0 (buf+8)
26
#define buf_max (buf+777)  \
27
 
28
/*1:*/
29
#line 32 "./mmix-arith.w"
30
 
31
#include <stdio.h>
32
#include <string.h>
33
#include <ctype.h>
34
/*2:*/
35
#line 49 "./mmix-arith.w"
36
 
37
#ifdef __STDC__
38
#define ARGS(list) list
39
#else
40
#define ARGS(list) ()
41
#endif
42
 
43
/*:2*/
44
#line 36 "./mmix-arith.w"
45
 
46
typedef enum
47
{ false, true } bool;
48
/*3:*/
49
#line 60 "./mmix-arith.w"
50
 
51
typedef unsigned int tetra;
52
 
53
typedef struct
54
{
55
  tetra h, l;
56
} octa;
57
 
58
/*:3*/
59
#line 38 "./mmix-arith.w"
60
 
61
/*36:*/
62
#line 605 "./mmix-arith.w"
63
 
64
typedef enum
65
{ zro, num, inf, nan } ftype;
66
 
67
       /*:36*//*59: */
68
#line 1110 "./mmix-arith.w"
69
 
70
typedef struct
71
{
72
  int a;
73
  int b;
74
  tetra dat[bignum_prec];
75
} bignum;
76
 
77
/*:59*/
78
#line 39 "./mmix-arith.w"
79
 
80
/*4:*/
81
#line 67 "./mmix-arith.w"
82
 
83
octa zero_octa;
84
octa neg_one = { -1, -1 };
85
octa inf_octa = { 0x7ff00000, 0 };
86
octa standard_NaN = { 0x7ff80000, 0 };
87
octa aux;
88
bool overflow;
89
 
90
      /*:4*//*9: */
91
#line 174 "./mmix-arith.w"
92
 
93
extern octa aux;
94
extern bool overflow;
95
 
96
      /*:9*//*30: */
97
#line 464 "./mmix-arith.w"
98
 
99
int cur_round;
100
 
101
       /*:30*//*32: */
102
#line 528 "./mmix-arith.w"
103
 
104
int exceptions;
105
 
106
       /*:32*//*69: */
107
#line 1359 "./mmix-arith.w"
108
 
109
octa val;
110
char *next_char;
111
 
112
       /*:69*//*75: */
113
#line 1432 "./mmix-arith.w"
114
 
115
static char buf[785] = "00000000";
116
 
117
/*:75*/
118
#line 40 "./mmix-arith.w"
119
 
120
/*5:*/
121
#line 78 "./mmix-arith.w"
122
 
123
octa oplus ARGS ((octa, octa));
124
octa
125
oplus (y, z)
126
     octa y, z;
127
{
128
  octa x;
129
  x.h = y.h + z.h;
130
  x.l = y.l + z.l;
131
  if (x.l < y.l)
132
    x.h++;
133
  return x;
134
}
135
 
136
octa ominus ARGS ((octa, octa));
137
octa
138
ominus (y, z)
139
     octa y, z;
140
{
141
  octa x;
142
  x.h = y.h - z.h;
143
  x.l = y.l - z.l;
144
  if (x.l > y.l)
145
    x.h--;
146
  return x;
147
}
148
 
149
      /*:5*//*6: */
150
#line 102 "./mmix-arith.w"
151
 
152
octa incr ARGS ((octa, int));
153
octa
154
incr (y, delta)
155
     octa y;
156
     int delta;
157
{
158
  octa x;
159
  x.h = y.h;
160
  x.l = y.l + delta;
161
  if (delta >= 0)
162
    {
163
      if (x.l < y.l)
164
        x.h++;
165
    }
166
  else if (x.l > y.l)
167
    x.h--;
168
  return x;
169
}
170
 
171
      /*:6*//*7: */
172
#line 117 "./mmix-arith.w"
173
 
174
octa shift_left ARGS ((octa, int));
175
octa
176
shift_left (y, s)
177
     octa y;
178
     int s;
179
{
180
  while (s >= 32)
181
    y.h = y.l, y.l = 0, s -= 32;
182
  if (s)
183
    {
184
      register tetra yhl = y.h << s, ylh = y.l >> (32 - s);
185
      y.h = yhl + ylh;
186
      y.l <<= s;
187
    }
188
  return y;
189
}
190
 
191
octa shift_right ARGS ((octa, int, int));
192
octa
193
shift_right (y, s, u)
194
     octa y;
195
     int s, u;
196
{
197
  while (s >= 32)
198
    y.l = y.h, y.h = (u ? 0 : -(y.h >> 31)), s -= 32;
199
  if (s)
200
    {
201
      register tetra yhl = y.h << (32 - s), ylh = y.l >> s;
202
      y.h = (u ? 0 : (-(y.h >> 31)) << (32 - s)) + (y.h >> s);
203
      y.l = yhl + ylh;
204
    }
205
  return y;
206
}
207
 
208
      /*:7*//*8: */
209
#line 150 "./mmix-arith.w"
210
 
211
octa omult ARGS ((octa, octa));
212
octa
213
omult (y, z)
214
     octa y, z;
215
{
216
  register int i, j, k;
217
  tetra u[4], v[4], w[8];
218
  register tetra t;
219
  octa acc;
220
/*10:*/
221
#line 178 "./mmix-arith.w"
222
 
223
  u[3] = y.h >> 16, u[2] = y.h & 0xffff, u[1] = y.l >> 16, u[0] =
224
    y.l & 0xffff;
225
  v[3] = z.h >> 16, v[2] = z.h & 0xffff, v[1] = z.l >> 16, v[0] =
226
    z.l & 0xffff;
227
 
228
/*:10*/
229
#line 159 "./mmix-arith.w"
230
  ;
231
  for (j = 0; j < 4; j++)
232
    w[j] = 0;
233
  for (j = 0; j < 4; j++)
234
    if (!v[j])
235
      w[j + 4] = 0;
236
    else
237
      {
238
        for (i = k = 0; i < 4; i++)
239
          {
240
            t = u[i] * v[j] + w[i + j] + k;
241
            w[i + j] = t & 0xffff, k = t >> 16;
242
          }
243
        w[j + 4] = k;
244
      }
245
/*11:*/
246
#line 182 "./mmix-arith.w"
247
 
248
  aux.h = (w[7] << 16) + w[6], aux.l = (w[5] << 16) + w[4];
249
  acc.h = (w[3] << 16) + w[2], acc.l = (w[1] << 16) + w[0];
250
 
251
/*:11*/
252
#line 170 "./mmix-arith.w"
253
  ;
254
  return acc;
255
}
256
 
257
      /*:8*//*12: */
258
#line 191 "./mmix-arith.w"
259
 
260
octa signed_omult ARGS ((octa, octa));
261
octa
262
signed_omult (y, z)
263
     octa y, z;
264
{
265
  octa acc;
266
  acc = omult (y, z);
267
  if (y.h & sign_bit)
268
    aux = ominus (aux, z);
269
  if (z.h & sign_bit)
270
    aux = ominus (aux, y);
271
  overflow = (aux.h != aux.l || (aux.h ^ (aux.h >> 1) ^ (acc.h & sign_bit)));
272
  return acc;
273
}
274
 
275
       /*:12*//*13: */
276
#line 215 "./mmix-arith.w"
277
 
278
octa odiv ARGS ((octa, octa, octa));
279
octa
280
odiv (x, y, z)
281
     octa x, y, z;
282
{
283
  register int i, j, k, n, d;
284
  tetra u[8], v[4], q[4], mask, qhat, rhat, vh, vmh;
285
  register tetra t;
286
  octa acc;
287
/*14:*/
288
#line 234 "./mmix-arith.w"
289
 
290
  if (x.h > z.h || (x.h == z.h && x.l >= z.l))
291
    {
292
      aux = y;
293
      return x;
294
    }
295
 
296
/*:14*/
297
#line 224 "./mmix-arith.w"
298
  ;
299
/*15:*/
300
#line 239 "./mmix-arith.w"
301
 
302
  u[7] = x.h >> 16, u[6] = x.h & 0xffff, u[5] = x.l >> 16, u[4] =
303
    x.l & 0xffff;
304
  u[3] = y.h >> 16, u[2] = y.h & 0xffff, u[1] = y.l >> 16, u[0] =
305
    y.l & 0xffff;
306
  v[3] = z.h >> 16, v[2] = z.h & 0xffff, v[1] = z.l >> 16, v[0] =
307
    z.l & 0xffff;
308
 
309
/*:15*/
310
#line 225 "./mmix-arith.w"
311
  ;
312
/*16:*/
313
#line 244 "./mmix-arith.w"
314
 
315
  for (n = 4; v[n - 1] == 0; n--);
316
 
317
/*:16*/
318
#line 226 "./mmix-arith.w"
319
  ;
320
/*17:*/
321
#line 250 "./mmix-arith.w"
322
 
323
  vh = v[n - 1];
324
  for (d = 0; vh < 0x8000; d++, vh <<= 1);
325
  for (j = k = 0; j < n + 4; j++)
326
    {
327
      t = (u[j] << d) + k;
328
      u[j] = t & 0xffff, k = t >> 16;
329
    }
330
  for (j = k = 0; j < n; j++)
331
    {
332
      t = (v[j] << d) + k;
333
      v[j] = t & 0xffff, k = t >> 16;
334
    }
335
  vh = v[n - 1];
336
  vmh = (n > 1 ? v[n - 2] : 0);
337
 
338
/*:17*/
339
#line 227 "./mmix-arith.w"
340
  ;
341
  for (j = 3; j >= 0; j--)       /*20: */
342
#line 276 "./mmix-arith.w"
343
 
344
    {
345
/*21:*/
346
#line 284 "./mmix-arith.w"
347
 
348
      t = (u[j + n] << 16) + u[j + n - 1];
349
      qhat = t / vh, rhat = t - vh * qhat;
350
      if (n > 1)
351
        while (qhat == 0x10000 || qhat * vmh > (rhat << 16) + u[j + n - 2])
352
          {
353
            qhat--, rhat += vh;
354
            if (rhat >= 0x10000)
355
              break;
356
          }
357
 
358
/*:21*/
359
#line 278 "./mmix-arith.w"
360
      ;
361
/*22:*/
362
#line 296 "./mmix-arith.w"
363
 
364
      for (i = k = 0; i < n; i++)
365
        {
366
          t = u[i + j] + 0xffff0000 - k - qhat * v[i];
367
          u[i + j] = t & 0xffff, k = 0xffff - (t >> 16);
368
        }
369
 
370
/*:22*/
371
#line 279 "./mmix-arith.w"
372
      ;
373
/*23:*/
374
#line 305 "./mmix-arith.w"
375
 
376
      if (u[j + n] != k)
377
        {
378
          qhat--;
379
          for (i = k = 0; i < n; i++)
380
            {
381
              t = u[i + j] + v[i] + k;
382
              u[i + j] = t & 0xffff, k = t >> 16;
383
            }
384
        }
385
 
386
/*:23*/
387
#line 280 "./mmix-arith.w"
388
      ;
389
      q[j] = qhat;
390
    }
391
 
392
/*:20*/
393
#line 228 "./mmix-arith.w"
394
  ;
395
/*18:*/
396
#line 264 "./mmix-arith.w"
397
 
398
  mask = (1 << d) - 1;
399
  for (j = 3; j >= n; j--)
400
    u[j] = 0;
401
  for (k = 0; j >= 0; j--)
402
    {
403
      t = (k << 16) + u[j];
404
      u[j] = t >> d, k = t & mask;
405
    }
406
 
407
/*:18*/
408
#line 229 "./mmix-arith.w"
409
  ;
410
/*19:*/
411
#line 272 "./mmix-arith.w"
412
 
413
  acc.h = (q[3] << 16) + q[2], acc.l = (q[1] << 16) + q[0];
414
  aux.h = (u[3] << 16) + u[2], aux.l = (u[1] << 16) + u[0];
415
 
416
/*:19*/
417
#line 230 "./mmix-arith.w"
418
  ;
419
  return acc;
420
}
421
 
422
       /*:13*//*24: */
423
#line 317 "./mmix-arith.w"
424
 
425
octa signed_odiv ARGS ((octa, octa));
426
octa
427
signed_odiv (y, z)
428
     octa y, z;
429
{
430
  octa yy, zz, q;
431
  register int sy, sz;
432
  if (y.h & sign_bit)
433
    sy = 2, yy = ominus (zero_octa, y);
434
  else
435
    sy = 0, yy = y;
436
  if (z.h & sign_bit)
437
    sz = 1, zz = ominus (zero_octa, z);
438
  else
439
    sz = 0, zz = z;
440
  q = odiv (zero_octa, yy, zz);
441
  overflow = false;
442
  switch (sy + sz)
443
    {
444
    case 2 + 1:
445
      aux = ominus (zero_octa, aux);
446
      if (q.h == sign_bit)
447
        overflow = true;
448
    case 0 + 0:
449
      return q;
450
    case 2 + 0:
451
      if (aux.h || aux.l)
452
        aux = ominus (zz, aux);
453
      goto negate_q;
454
    case 0 + 1:
455
      if (aux.h || aux.l)
456
        aux = ominus (aux, zz);
457
    negate_q:if (aux.h || aux.l)
458
        return ominus (neg_one, q);
459
      else
460
        return ominus (zero_octa, q);
461
    }
462
}
463
 
464
       /*:24*//*25: */
465
#line 346 "./mmix-arith.w"
466
 
467
octa oand ARGS ((octa, octa));
468
octa
469
oand (y, z)
470
     octa y, z;
471
{
472
  octa x;
473
  x.h = y.h & z.h;
474
  x.l = y.l & z.l;
475
  return x;
476
}
477
 
478
octa oandn ARGS ((octa, octa));
479
octa
480
oandn (y, z)
481
     octa y, z;
482
{
483
  octa x;
484
  x.h = y.h & ~z.h;
485
  x.l = y.l & ~z.l;
486
  return x;
487
}
488
 
489
octa oxor ARGS ((octa, octa));
490
octa
491
oxor (y, z)
492
     octa y, z;
493
{
494
  octa x;
495
  x.h = y.h ^ z.h;
496
  x.l = y.l ^ z.l;
497
  return x;
498
}
499
 
500
       /*:25*//*26: */
501
#line 387 "./mmix-arith.w"
502
 
503
int count_bits ARGS ((tetra));
504
int
505
count_bits (x)
506
     tetra x;
507
{
508
  register int xx = x;
509
  xx = xx - ((xx >> 1) & 0x55555555);
510
  xx = (xx & 0x33333333) + ((xx >> 2) & 0x33333333);
511
  xx = (xx + (xx >> 4)) & 0x0f0f0f0f;
512
  xx = xx + (xx >> 8);
513
  return (xx + (xx >> 16)) & 0xff;
514
}
515
 
516
       /*:26*//*27: */
517
#line 403 "./mmix-arith.w"
518
 
519
tetra byte_diff ARGS ((tetra, tetra));
520
tetra
521
byte_diff (y, z)
522
     tetra y, z;
523
{
524
  register tetra d = (y & 0x00ff00ff) + 0x01000100 - (z & 0x00ff00ff);
525
  register tetra m = d & 0x01000100;
526
  register tetra x = d & (m - (m >> 8));
527
  d = ((y >> 8) & 0x00ff00ff) + 0x01000100 - ((z >> 8) & 0x00ff00ff);
528
  m = d & 0x01000100;
529
  return x + ((d & (m - (m >> 8))) << 8);
530
}
531
 
532
       /*:27*//*28: */
533
#line 421 "./mmix-arith.w"
534
 
535
tetra wyde_diff ARGS ((tetra, tetra));
536
tetra
537
wyde_diff (y, z)
538
     tetra y, z;
539
{
540
  register tetra a = ((y >> 16) - (z >> 16)) & 0x10000;
541
  register tetra b = ((y & 0xffff) - (z & 0xffff)) & 0x10000;
542
  return y - (z ^ ((y ^ z) & (b - a - (b >> 16))));
543
}
544
 
545
       /*:28*//*29: */
546
#line 434 "./mmix-arith.w"
547
 
548
octa bool_mult ARGS ((octa, octa, bool));
549
octa
550
bool_mult (y, z, xor)
551
     octa y, z;
552
     bool xor;
553
{
554
  octa o, x;
555
  register tetra a, b, c;
556
  register int k;
557
  for (k = 0, o = y, x = zero_octa; o.h || o.l;
558
       k++, o = shift_right (o, 8, 1))
559
    if (o.l & 0xff)
560
      {
561
        a = ((z.h >> k) & 0x01010101) * 0xff;
562
        b = ((z.l >> k) & 0x01010101) * 0xff;
563
        c = (o.l & 0xff) * 0x01010101;
564
        if (xor)
565
          x.h ^= a & c, x.l ^= b & c;
566
        else
567
          x.h |= a & c, x.l |= b & c;
568
      }
569
  return x;
570
}
571
 
572
       /*:29*//*31: */
573
#line 503 "./mmix-arith.w"
574
 
575
octa fpack ARGS ((octa, int, char, int));
576
octa
577
fpack (f, e, s, r)
578
     octa f;
579
     int e;
580
     char s;
581
     int r;
582
{
583
  octa o;
584
  if (e > 0x7fd)
585
    e = 0x7ff, o = zero_octa;
586
  else
587
    {
588
      if (e < 0)
589
        {
590
          if (e < -54)
591
            o.h = 0, o.l = 1;
592
          else
593
            {
594
              octa oo;
595
              o = shift_right (f, -e, 1);
596
              oo = shift_left (o, -e);
597
              if (oo.l != f.l || oo.h != f.h)
598
                o.l |= 1;
599
 
600
            }
601
          e = 0;
602
        }
603
      else
604
        o = f;
605
    }
606
/*33:*/
607
#line 533 "./mmix-arith.w"
608
 
609
  if (o.l & 3)
610
    exceptions |= X_BIT;
611
  switch (r)
612
    {
613
    case ROUND_DOWN:
614
      if (s == '-')
615
        o = incr (o, 3);
616
      break;
617
    case ROUND_UP:
618
      if (s != '-')
619
        o = incr (o, 3);
620
    case ROUND_OFF:
621
      break;
622
    case ROUND_NEAR:
623
      o = incr (o, o.l & 4 ? 2 : 1);
624
      break;
625
    }
626
  o = shift_right (o, 2, 1);
627
  o.h += e << 20;
628
  if (o.h >= 0x7ff00000)
629
    exceptions |= O_BIT + X_BIT;
630
  else if (o.h < 0x100000)
631
    exceptions |= U_BIT;
632
  if (s == '-')
633
    o.h |= sign_bit;
634
  return o;
635
 
636
/*:33*/
637
#line 525 "./mmix-arith.w"
638
  ;
639
}
640
 
641
       /*:31*//*34: */
642
#line 551 "./mmix-arith.w"
643
 
644
tetra sfpack ARGS ((octa, int, char, int));
645
tetra
646
sfpack (f, e, s, r)
647
     octa f;
648
     int e;
649
     char s;
650
     int r;
651
{
652
  register tetra o;
653
  if (e > 0x47d)
654
    e = 0x47f, o = 0;
655
  else
656
    {
657
      o = shift_left (f, 3).h;
658
      if (f.l & 0x1fffffff)
659
        o |= 1;
660
      if (e < 0x380)
661
        {
662
          if (e < 0x380 - 25)
663
            o = 1;
664
          else
665
            {
666
              register tetra o0, oo;
667
              o0 = o;
668
              o = o >> (0x380 - e);
669
              oo = o << (0x380 - e);
670
              if (oo != o0)
671
                o |= 1;
672
 
673
            }
674
          e = 0x380;
675
        }
676
    }
677
/*35:*/
678
#line 579 "./mmix-arith.w"
679
 
680
  if (o & 3)
681
    exceptions |= X_BIT;
682
  switch (r)
683
    {
684
    case ROUND_DOWN:
685
      if (s == '-')
686
        o += 3;
687
      break;
688
    case ROUND_UP:
689
      if (s != '-')
690
        o += 3;
691
    case ROUND_OFF:
692
      break;
693
    case ROUND_NEAR:
694
      o += (o & 4 ? 2 : 1);
695
      break;
696
    }
697
  o = o >> 2;
698
  o += (e - 0x380) << 23;
699
  if (o >= 0x7f800000)
700
    exceptions |= O_BIT + X_BIT;
701
  else if (o < 0x100000)
702
    exceptions |= U_BIT;
703
  if (s == '-')
704
    o |= sign_bit;
705
  return o;
706
 
707
/*:35*/
708
#line 576 "./mmix-arith.w"
709
  ;
710
}
711
 
712
       /*:34*//*37: */
713
#line 608 "./mmix-arith.w"
714
 
715
ftype funpack ARGS ((octa, octa *, int *, char *));
716
ftype
717
funpack (x, f, e, s)
718
     octa x;
719
     octa *f;
720
     int *e;
721
     char *s;
722
{
723
  register int ee;
724
  exceptions = 0;
725
  *s = (x.h & sign_bit ? '-' : '+');
726
  *f = shift_left (x, 2);
727
  f->h &= 0x3fffff;
728
  ee = (x.h >> 20) & 0x7ff;
729
  if (ee)
730
    {
731
      *e = ee - 1;
732
      f->h |= 0x400000;
733
      return (ee < 0x7ff ? num : f->h == 0x400000 && !f->l ? inf : nan);
734
    }
735
  if (!x.l && !f->h)
736
    {
737
      *e = zero_exponent;
738
      return zro;
739
    }
740
  do
741
    {
742
      ee--;
743
      *f = shift_left (*f, 1);
744
    }
745
  while (!(f->h & 0x400000));
746
  *e = ee;
747
  return num;
748
}
749
 
750
       /*:37*//*38: */
751
#line 634 "./mmix-arith.w"
752
 
753
ftype sfunpack ARGS ((tetra, octa *, int *, char *));
754
ftype
755
sfunpack (x, f, e, s)
756
     tetra x;
757
     octa *f;
758
     int *e;
759
     char *s;
760
{
761
  register int ee;
762
  exceptions = 0;
763
  *s = (x & sign_bit ? '-' : '+');
764
  f->h = (x >> 1) & 0x3fffff, f->l = x << 31;
765
  ee = (x >> 23) & 0xff;
766
  if (ee)
767
    {
768
      *e = ee + 0x380 - 1;
769
      f->h |= 0x400000;
770
      return (ee < 0xff ? num : (x & 0x7fffffff) == 0x7f800000 ? inf : nan);
771
    }
772
  if (!(x & 0x7fffffff))
773
    {
774
      *e = zero_exponent;
775
      return zro;
776
    }
777
  do
778
    {
779
      ee--;
780
      *f = shift_left (*f, 1);
781
    }
782
  while (!(f->h & 0x400000));
783
  *e = ee + 0x380;
784
  return num;
785
}
786
 
787
       /*:38*//*39: */
788
#line 663 "./mmix-arith.w"
789
 
790
octa load_sf ARGS ((tetra));
791
octa
792
load_sf (z)
793
     tetra z;
794
{
795
  octa f, x;
796
  int e;
797
  char s;
798
  ftype t;
799
  t = sfunpack (z, &f, &e, &s);
800
  switch (t)
801
    {
802
    case zro:
803
      x = zero_octa;
804
      break;
805
    case num:
806
      return fpack (f, e, s, ROUND_OFF);
807
    case inf:
808
      x = inf_octa;
809
      break;
810
    case nan:
811
      x = shift_right (f, 2, 1);
812
      x.h |= 0x7ff00000;
813
      break;
814
    }
815
  if (s == '-')
816
    x.h |= sign_bit;
817
  return x;
818
}
819
 
820
       /*:39*//*40: */
821
#line 680 "./mmix-arith.w"
822
 
823
tetra store_sf ARGS ((octa));
824
tetra
825
store_sf (x)
826
     octa x;
827
{
828
  octa f;
829
  tetra z;
830
  int e;
831
  char s;
832
  ftype t;
833
  t = funpack (x, &f, &e, &s);
834
  switch (t)
835
    {
836
    case zro:
837
      z = 0;
838
      break;
839
    case num:
840
      return sfpack (f, e, s, cur_round);
841
    case inf:
842
      z = 0x7f800000;
843
      break;
844
    case nan:
845
      if (!(f.h & 0x200000))
846
        {
847
          f.h |= 0x200000;
848
          exceptions |= I_BIT;
849
        }
850
      z = 0x7f800000 | (f.h << 1) | (f.l >> 31);
851
      break;
852
    }
853
  if (s == '-')
854
    z |= sign_bit;
855
  return z;
856
}
857
 
858
       /*:40*//*41: */
859
#line 705 "./mmix-arith.w"
860
 
861
octa fmult ARGS ((octa, octa));
862
octa
863
fmult (y, z)
864
     octa y, z;
865
{
866
  ftype yt, zt;
867
  int ye, ze;
868
  char ys, zs;
869
  octa x, xf, yf, zf;
870
  register int xe;
871
  register char xs;
872
  yt = funpack (y, &yf, &ye, &ys);
873
  zt = funpack (z, &zf, &ze, &zs);
874
  xs = ys + zs - '+';
875
  switch (4 * yt + zt)
876
    {
877
/*42:*/
878
#line 731 "./mmix-arith.w"
879
 
880
    case 4 * nan + nan:
881
      if (!(y.h & 0x80000))
882
        exceptions |= I_BIT;
883
    case 4 * zro + nan:
884
    case 4 * num + nan:
885
    case 4 * inf + nan:
886
      if (!(z.h & 0x80000))
887
        exceptions |= I_BIT, z.h |= 0x80000;
888
      return z;
889
    case 4 * nan + zro:
890
    case 4 * nan + num:
891
    case 4 * nan + inf:
892
      if (!(y.h & 0x80000))
893
        exceptions |= I_BIT, y.h |= 0x80000;
894
      return y;
895
 
896
/*:42*/
897
#line 720 "./mmix-arith.w"
898
      ;
899
    case 4 * zro + zro:
900
    case 4 * zro + num:
901
    case 4 * num + zro:
902
      x = zero_octa;
903
      break;
904
    case 4 * num + inf:
905
    case 4 * inf + num:
906
    case 4 * inf + inf:
907
      x = inf_octa;
908
      break;
909
    case 4 * zro + inf:
910
    case 4 * inf + zro:
911
      x = standard_NaN;
912
      exceptions |= I_BIT;
913
      break;
914
    case 4 * num + num: /*43: */
915
#line 740 "./mmix-arith.w"
916
 
917
      xe = ye + ze - 0x3fd;
918
      x = omult (yf, shift_left (zf, 9));
919
      if (aux.h >= 0x400000)
920
        xf = aux;
921
      else
922
        xf = shift_left (aux, 1), xe--;
923
      if (x.h || x.l)
924
        xf.l |= 1;
925
      return fpack (xf, xe, xs, cur_round);
926
 
927
/*:43*/
928
#line 725 "./mmix-arith.w"
929
      ;
930
    }
931
  if (xs == '-')
932
    x.h |= sign_bit;
933
  return x;
934
}
935
 
936
       /*:41*//*44: */
937
#line 748 "./mmix-arith.w"
938
 
939
octa fdivide ARGS ((octa, octa));
940
octa
941
fdivide (y, z)
942
     octa y, z;
943
{
944
  ftype yt, zt;
945
  int ye, ze;
946
  char ys, zs;
947
  octa x, xf, yf, zf;
948
  register int xe;
949
  register char xs;
950
  yt = funpack (y, &yf, &ye, &ys);
951
  zt = funpack (z, &zf, &ze, &zs);
952
  xs = ys + zs - '+';
953
  switch (4 * yt + zt)
954
    {
955
/*42:*/
956
#line 731 "./mmix-arith.w"
957
 
958
    case 4 * nan + nan:
959
      if (!(y.h & 0x80000))
960
        exceptions |= I_BIT;
961
    case 4 * zro + nan:
962
    case 4 * num + nan:
963
    case 4 * inf + nan:
964
      if (!(z.h & 0x80000))
965
        exceptions |= I_BIT, z.h |= 0x80000;
966
      return z;
967
    case 4 * nan + zro:
968
    case 4 * nan + num:
969
    case 4 * nan + inf:
970
      if (!(y.h & 0x80000))
971
        exceptions |= I_BIT, y.h |= 0x80000;
972
      return y;
973
 
974
/*:42*/
975
#line 763 "./mmix-arith.w"
976
      ;
977
    case 4 * zro + inf:
978
    case 4 * zro + num:
979
    case 4 * num + inf:
980
      x = zero_octa;
981
      break;
982
    case 4 * num + zro:
983
      exceptions |= Z_BIT;
984
    case 4 * inf + num:
985
    case 4 * inf + zro:
986
      x = inf_octa;
987
      break;
988
    case 4 * zro + zro:
989
    case 4 * inf + inf:
990
      x = standard_NaN;
991
      exceptions |= I_BIT;
992
      break;
993
    case 4 * num + num: /*45: */
994
#line 775 "./mmix-arith.w"
995
 
996
      xe = ye - ze + 0x3fd;
997
      xf = odiv (yf, zero_octa, shift_left (zf, 9));
998
      if (xf.h >= 0x800000)
999
        {
1000
          aux.l |= xf.l & 1;
1001
          xf = shift_right (xf, 1, 1);
1002
          xe++;
1003
        }
1004
      if (aux.h || aux.l)
1005
        xf.l |= 1;
1006
      return fpack (xf, xe, xs, cur_round);
1007
 
1008
/*:45*/
1009
#line 769 "./mmix-arith.w"
1010
      ;
1011
    }
1012
  if (xs == '-')
1013
    x.h |= sign_bit;
1014
  return x;
1015
}
1016
 
1017
       /*:44*//*46: */
1018
#line 790 "./mmix-arith.w"
1019
 
1020
octa fplus ARGS ((octa, octa));
1021
octa
1022
fplus (y, z)
1023
     octa y, z;
1024
{
1025
  ftype yt, zt;
1026
  int ye, ze;
1027
  char ys, zs;
1028
  octa x, xf, yf, zf;
1029
  register int xe, d;
1030
  register char xs;
1031
  yt = funpack (y, &yf, &ye, &ys);
1032
  zt = funpack (z, &zf, &ze, &zs);
1033
  switch (4 * yt + zt)
1034
    {
1035
/*42:*/
1036
#line 731 "./mmix-arith.w"
1037
 
1038
    case 4 * nan + nan:
1039
      if (!(y.h & 0x80000))
1040
        exceptions |= I_BIT;
1041
    case 4 * zro + nan:
1042
    case 4 * num + nan:
1043
    case 4 * inf + nan:
1044
      if (!(z.h & 0x80000))
1045
        exceptions |= I_BIT, z.h |= 0x80000;
1046
      return z;
1047
    case 4 * nan + zro:
1048
    case 4 * nan + num:
1049
    case 4 * nan + inf:
1050
      if (!(y.h & 0x80000))
1051
        exceptions |= I_BIT, y.h |= 0x80000;
1052
      return y;
1053
 
1054
/*:42*/
1055
#line 804 "./mmix-arith.w"
1056
      ;
1057
    case 4 * zro + num:
1058
      return fpack (zf, ze, zs, ROUND_OFF);
1059
      break;
1060
    case 4 * num + zro:
1061
      return fpack (yf, ye, ys, ROUND_OFF);
1062
      break;
1063
    case 4 * inf + inf:
1064
      if (ys != zs)
1065
        {
1066
          exceptions |= I_BIT;
1067
          x = standard_NaN;
1068
          xs = zs;
1069
          break;
1070
        }
1071
    case 4 * num + inf:
1072
    case 4 * zro + inf:
1073
      x = inf_octa;
1074
      xs = zs;
1075
      break;
1076
    case 4 * inf + num:
1077
    case 4 * inf + zro:
1078
      x = inf_octa;
1079
      xs = ys;
1080
      break;
1081
    case 4 * num + num:
1082
      if (y.h != (z.h ^ 0x80000000) || y.l != z.l)
1083
/*47:*/
1084
#line 821 "./mmix-arith.w"
1085
 
1086
        {
1087
          octa o, oo;
1088
          if (ye < ze
1089
              || (ye == ze && (yf.h < zf.h || (yf.h == zf.h && yf.l < zf.l))))
1090
/*48:*/
1091
#line 839 "./mmix-arith.w"
1092
 
1093
            {
1094
              o = yf, yf = zf, zf = o;
1095
              d = ye, ye = ze, ze = d;
1096
              d = ys, ys = zs, zs = d;
1097
            }
1098
 
1099
/*:48*/
1100
#line 824 "./mmix-arith.w"
1101
          ;
1102
          d = ye - ze;
1103
          xs = ys, xe = ye;
1104
          if (d)                /*49: */
1105
#line 859 "./mmix-arith.w"
1106
 
1107
            {
1108
              if (d <= 2)
1109
                zf = shift_right (zf, d, 1);
1110
              else if (d > 53)
1111
                zf.h = 0, zf.l = 1;
1112
              else
1113
                {
1114
                  if (ys != zs)
1115
                    d--, xe--, yf = shift_left (yf, 1);
1116
                  o = zf;
1117
                  zf = shift_right (o, d, 1);
1118
                  oo = shift_left (zf, d);
1119
                  if (oo.l != o.l || oo.h != o.h)
1120
                    zf.l |= 1;
1121
                }
1122
            }
1123
 
1124
/*:49*/
1125
#line 827 "./mmix-arith.w"
1126
          ;
1127
          if (ys == zs)
1128
            {
1129
              xf = oplus (yf, zf);
1130
              if (xf.h >= 0x800000)
1131
                xe++, d = xf.l & 1, xf = shift_right (xf, 1, 1), xf.l |= d;
1132
            }
1133
          else
1134
            {
1135
              xf = ominus (yf, zf);
1136
              if (xf.h >= 0x800000)
1137
                xe++, d = xf.l & 1, xf = shift_right (xf, 1, 1), xf.l |= d;
1138
              else
1139
                while (xf.h < 0x400000)
1140
                  xe--, xf = shift_left (xf, 1);
1141
            }
1142
          return fpack (xf, xe, xs, cur_round);
1143
        }
1144
 
1145
/*:47*/
1146
#line 813 "./mmix-arith.w"
1147
      ;
1148
    case 4 * zro + zro:
1149
      x = zero_octa;
1150
      xs = (ys == zs ? ys : cur_round == ROUND_DOWN ? '-' : '+');
1151
      break;
1152
    }
1153
  if (xs == '-')
1154
    x.h |= sign_bit;
1155
  return x;
1156
}
1157
 
1158
       /*:46*//*50: */
1159
#line 883 "./mmix-arith.w"
1160
 
1161
int fepscomp ARGS ((octa, octa, octa, int));
1162
int
1163
fepscomp (y, z, e, s)
1164
     octa y, z, e;
1165
     int s;
1166
{
1167
  octa yf, zf, ef, o, oo;
1168
  int ye, ze, ee;
1169
  char ys, zs, es;
1170
  register int yt, zt, et, d;
1171
  et = funpack (e, &ef, &ee, &es);
1172
  if (es == '-')
1173
    return 2;
1174
  switch (et)
1175
    {
1176
    case nan:
1177
      return 2;
1178
    case inf:
1179
      ee = 10000;
1180
    case num:
1181
    case zro:
1182
      break;
1183
    }
1184
  yt = funpack (y, &yf, &ye, &ys);
1185
  zt = funpack (z, &zf, &ze, &zs);
1186
  switch (4 * yt + zt)
1187
    {
1188
    case 4 * nan + nan:
1189
    case 4 * nan + inf:
1190
    case 4 * nan + num:
1191
    case 4 * nan + zro:
1192
    case 4 * inf + nan:
1193
    case 4 * num + nan:
1194
    case 4 * zro + nan:
1195
      return 2;
1196
    case 4 * inf + inf:
1197
      return (ys == zs || ee >= 1023);
1198
    case 4 * inf + num:
1199
    case 4 * inf + zro:
1200
    case 4 * num + inf:
1201
    case 4 * zro + inf:
1202
      return (s && ee >= 1022);
1203
    case 4 * zro + zro:
1204
      return 1;
1205
    case 4 * zro + num:
1206
    case 4 * num + zro:
1207
      if (!s)
1208
        return 0;
1209
    case 4 * num + num:
1210
      break;
1211
    }
1212
/*51:*/
1213
#line 919 "./mmix-arith.w"
1214
 
1215
/*52:*/
1216
#line 934 "./mmix-arith.w"
1217
 
1218
  if (ye < 0 && yt != zro)
1219
    yf = shift_left (y, 2), ye = 0;
1220
  if (ze < 0 && zt != zro)
1221
    zf = shift_left (z, 2), ze = 0;
1222
 
1223
/*:52*/
1224
#line 920 "./mmix-arith.w"
1225
  ;
1226
  if (ye < ze || (ye == ze && (yf.h < zf.h || (yf.h == zf.h && yf.l < zf.l))))
1227
/*48:*/
1228
#line 839 "./mmix-arith.w"
1229
 
1230
    {
1231
      o = yf, yf = zf, zf = o;
1232
      d = ye, ye = ze, ze = d;
1233
      d = ys, ys = zs, zs = d;
1234
    }
1235
 
1236
/*:48*/
1237
#line 922 "./mmix-arith.w"
1238
  ;
1239
  if (ze == zero_exponent)
1240
    ze = ye;
1241
  d = ye - ze;
1242
  if (!s)
1243
    ee -= d;
1244
  if (ee >= 1023)
1245
    return 1;
1246
/*53:*/
1247
#line 956 "./mmix-arith.w"
1248
 
1249
  if (d > 54)
1250
    o = zero_octa, oo = zf;
1251
  else
1252
    o = shift_right (zf, d, 1), oo = shift_left (o, d);
1253
  if (oo.h != zf.h || oo.l != zf.l)
1254
    {
1255
      if (ee < 1020)
1256
        return 0;
1257
      o = incr (o, ys == zs ? 0 : 1);
1258
    }
1259
  o = (ys == zs ? ominus (yf, o) : oplus (yf, o));
1260
 
1261
/*:53*/
1262
#line 927 "./mmix-arith.w"
1263
  ;
1264
  if (!o.h && !o.l)
1265
    return 1;
1266
  if (ee < 968)
1267
    return 0;
1268
  if (ee >= 1021)
1269
    ef = shift_left (ef, ee - 1021);
1270
  else
1271
    ef = shift_right (ef, 1021 - ee, 1);
1272
  return o.h < ef.h || (o.h == ef.h && o.l <= ef.l);
1273
 
1274
/*:51*/
1275
#line 912 "./mmix-arith.w"
1276
  ;
1277
}
1278
 
1279
       /*:50*//*54: */
1280
#line 972 "./mmix-arith.w"
1281
 
1282
static void bignum_times_ten ARGS ((bignum *));
1283
static void bignum_dec ARGS ((bignum *, bignum *, tetra));
1284
static int bignum_compare ARGS ((bignum *, bignum *));
1285
void print_float ARGS ((octa));
1286
void
1287
print_float (x)
1288
     octa x;
1289
{
1290
/*56:*/
1291
#line 1035 "./mmix-arith.w"
1292
 
1293
  octa f, g;
1294
  register int e;
1295
  register int j, k;
1296
 
1297
  /*:56*//*66: */
1298
#line 1281 "./mmix-arith.w"
1299
 
1300
  bignum ff, gg;
1301
  bignum tt;
1302
  char s[18];
1303
  register char *p;
1304
 
1305
/*:66*/
1306
#line 980 "./mmix-arith.w"
1307
  ;
1308
  if (x.h & sign_bit)
1309
    printf ("-");
1310
/*55:*/
1311
#line 1019 "./mmix-arith.w"
1312
 
1313
  f = shift_left (x, 1);
1314
  e = f.h >> 21;
1315
  f.h &= 0x1fffff;
1316
  if (!f.h && !f.l)             /*57: */
1317
#line 1045 "./mmix-arith.w"
1318
 
1319
    {
1320
      if (!e)
1321
        {
1322
          printf ("0.");
1323
          return;
1324
        }
1325
      if (e == 0x7ff)
1326
        {
1327
          printf ("Inf");
1328
          return;
1329
        }
1330
      e--;
1331
      f.h = 0x3fffff, f.l = 0xffffffff;
1332
      g.h = 0x400000, g.l = 2;
1333
    }
1334
 
1335
/*:57*/
1336
#line 1023 "./mmix-arith.w"
1337
 
1338
  else
1339
    {
1340
      g = incr (f, 1);
1341
      f = incr (f, -1);
1342
      if (!e)
1343
        e = 1;
1344
      else if (e == 0x7ff)
1345
        {
1346
          printf ("NaN");
1347
          if (g.h == 0x100000 && g.l == 1)
1348
            return;
1349
          e = 0x3ff;
1350
        }
1351
      else
1352
        f.h |= 0x200000, g.h |= 0x200000;
1353
    }
1354
 
1355
/*:55*/
1356
#line 983 "./mmix-arith.w"
1357
  ;
1358
/*63:*/
1359
#line 1195 "./mmix-arith.w"
1360
 
1361
  k = (magic_offset - e) / 28;
1362
  ff.dat[k - 1] =
1363
    shift_right (f, magic_offset + 28 - e - 28 * k, 1).l & 0xfffffff;
1364
  gg.dat[k - 1] =
1365
    shift_right (g, magic_offset + 28 - e - 28 * k, 1).l & 0xfffffff;
1366
  ff.dat[k] = shift_right (f, magic_offset - e - 28 * k, 1).l & 0xfffffff;
1367
  gg.dat[k] = shift_right (g, magic_offset - e - 28 * k, 1).l & 0xfffffff;
1368
  ff.dat[k + 1] =
1369
    shift_left (f, e + 28 * k - (magic_offset - 28)).l & 0xfffffff;
1370
  gg.dat[k + 1] =
1371
    shift_left (g, e + 28 * k - (magic_offset - 28)).l & 0xfffffff;
1372
  ff.a = (ff.dat[k - 1] ? k - 1 : k);
1373
  ff.b = (ff.dat[k + 1] ? k + 1 : k);
1374
  gg.a = (gg.dat[k - 1] ? k - 1 : k);
1375
  gg.b = (gg.dat[k + 1] ? k + 1 : k);
1376
 
1377
/*:63*/
1378
#line 984 "./mmix-arith.w"
1379
  ;
1380
/*64:*/
1381
#line 1223 "./mmix-arith.w"
1382
 
1383
  if (e > 0x401)                /*65: */
1384
#line 1254 "./mmix-arith.w"
1385
 
1386
    {
1387
      register int open = x.l & 1;
1388
      tt.dat[origin] = 10;
1389
      tt.a = tt.b = origin;
1390
      for (e = 1; bignum_compare (&gg, &tt) >= open; e++)
1391
        bignum_times_ten (&tt);
1392
      p = s;
1393
      while (1)
1394
        {
1395
          bignum_times_ten (&ff);
1396
          bignum_times_ten (&gg);
1397
          for (j = '0'; bignum_compare (&ff, &tt) >= 0; j++)
1398
            bignum_dec (&ff, &tt, 0x10000000), bignum_dec (&gg, &tt,
1399
                                                           0x10000000);
1400
          if (bignum_compare (&gg, &tt) >= open)
1401
            break;
1402
          *p++ = j;
1403
          if (ff.a == bignum_prec - 1 && !open)
1404
            goto done;
1405
        }
1406
      for (k = j; bignum_compare (&gg, &tt) >= open; k++)
1407
        bignum_dec (&gg, &tt, 0x10000000);
1408
      *p++ = (j + 1 + k) >> 1;
1409
    done:;
1410
    }
1411
 
1412
/*:65*/
1413
#line 1224 "./mmix-arith.w"
1414
 
1415
  else
1416
    {
1417
      if (ff.a > origin)
1418
        ff.dat[origin] = 0;
1419
      for (e = 1, p = s; gg.a > origin || ff.dat[origin] == gg.dat[origin];)
1420
        {
1421
          if (gg.a > origin)
1422
            e--;
1423
          else
1424
            *p++ = ff.dat[origin] + '0', ff.dat[origin] = 0, gg.dat[origin] =
1425
              0;
1426
          bignum_times_ten (&ff);
1427
          bignum_times_ten (&gg);
1428
        }
1429
      *p++ = ((ff.dat[origin] + 1 + gg.dat[origin]) >> 1) + '0';
1430
    }
1431
  *p = '\0';
1432
 
1433
/*:64*/
1434
#line 985 "./mmix-arith.w"
1435
  ;
1436
/*67:*/
1437
#line 1296 "./mmix-arith.w"
1438
 
1439
  if (e > 17 || e < (int) strlen (s) - 17)
1440
    printf ("%c%s%se%d", s[0], (s[1] ? "." : ""), s + 1, e - 1);
1441
  else if (e < 0)
1442
    printf (".%0*d%s", -e, 0, s);
1443
  else if (strlen (s) >= e)
1444
    printf ("%.*s.%s", e, s, s + e);
1445
  else
1446
    printf ("%s%0*d.", s, e - (int) strlen (s), 0);
1447
 
1448
/*:67*/
1449
#line 986 "./mmix-arith.w"
1450
  ;
1451
}
1452
 
1453
       /*:54*//*60: */
1454
#line 1120 "./mmix-arith.w"
1455
 
1456
static void
1457
bignum_times_ten (f)
1458
     bignum *f;
1459
{
1460
  register tetra *p, *q;
1461
  register tetra x, carry;
1462
  for (p = &f->dat[f->b], q = &f->dat[f->a], carry = 0; p >= q; p--)
1463
    {
1464
      x = *p * 10 + carry;
1465
      *p = x & 0xfffffff;
1466
      carry = x >> 28;
1467
    }
1468
  *p = carry;
1469
  if (carry)
1470
    f->a--;
1471
  if (f->dat[f->b] == 0 && f->b > f->a)
1472
    f->b--;
1473
}
1474
 
1475
       /*:60*//*61: */
1476
#line 1138 "./mmix-arith.w"
1477
 
1478
static int
1479
bignum_compare (f, g)
1480
     bignum *f, *g;
1481
{
1482
  register tetra *p, *pp, *q, *qq;
1483
  if (f->a != g->a)
1484
    return f->a > g->a ? -1 : 1;
1485
  pp = &f->dat[f->b], qq = &g->dat[g->b];
1486
  for (p = &f->dat[f->a], q = &g->dat[g->a]; p <= pp; p++, q++)
1487
    {
1488
      if (*p != *q)
1489
        return *p < *q ? -1 : 1;
1490
      if (q == qq)
1491
        return p < pp;
1492
    }
1493
  return -1;
1494
}
1495
 
1496
       /*:61*//*62: */
1497
#line 1155 "./mmix-arith.w"
1498
 
1499
static void
1500
bignum_dec (f, g, r)
1501
     bignum *f, *g;
1502
     tetra r;
1503
{
1504
  register tetra *p, *q, *qq;
1505
  register int x, borrow;
1506
  while (g->b > f->b)
1507
    f->dat[++f->b] = 0;
1508
  qq = &g->dat[g->a];
1509
  for (p = &f->dat[g->b], q = &g->dat[g->b], borrow = 0; q >= qq; p--, q--)
1510
    {
1511
      x = *p - *q - borrow;
1512
      if (x >= 0)
1513
        borrow = 0, *p = x;
1514
      else
1515
        borrow = 1, *p = x + r;
1516
    }
1517
  for (; borrow; p--)
1518
    if (*p)
1519
      borrow = 0, *p = *p - 1;
1520
    else
1521
      *p = r - 1;
1522
  while (f->dat[f->a] == 0)
1523
    {
1524
      if (f->a == f->b)
1525
        {
1526
          f->a = f->b = bignum_prec - 1, f->dat[bignum_prec - 1] = 0;
1527
          return;
1528
        }
1529
      f->a++;
1530
    }
1531
  while (f->dat[f->b] == 0)
1532
    f->b--;
1533
}
1534
 
1535
       /*:62*//*68: */
1536
#line 1340 "./mmix-arith.w"
1537
 
1538
static void bignum_double ARGS ((bignum *));
1539
int scan_const ARGS ((char *));
1540
int
1541
scan_const (s)
1542
     char *s;
1543
{
1544
/*70:*/
1545
#line 1363 "./mmix-arith.w"
1546
 
1547
  register char *p, *q;
1548
  register bool NaN;
1549
  int sign;
1550
 
1551
  /*:70*//*76: */
1552
#line 1435 "./mmix-arith.w"
1553
 
1554
  register char *dec_pt;
1555
  register int exp;
1556
  register int zeros;
1557
 
1558
  /*:76*//*81: */
1559
#line 1503 "./mmix-arith.w"
1560
 
1561
  register int k, x;
1562
  register char *pp;
1563
  bignum ff, tt;
1564
 
1565
/*:81*/
1566
#line 1346 "./mmix-arith.w"
1567
  ;
1568
  val.h = val.l = 0;
1569
  p = s;
1570
  if (*p == '+' || *p == '-')
1571
    sign = *p++;
1572
  else
1573
    sign = '+';
1574
  if (strncmp (p, "NaN", 3) == 0)
1575
    NaN = true, p += 3;
1576
  else
1577
    NaN = false;
1578
  if ((isdigit (*p) && !NaN) || (*p == '.' && isdigit (*(p + 1))))
1579
/*73:*/
1580
#line 1396 "./mmix-arith.w"
1581
 
1582
    {
1583
      for (q = buf0, dec_pt = (char *) 0; isdigit (*p); p++)
1584
        {
1585
          val = oplus (val, shift_left (val, 2));
1586
          val = incr (shift_left (val, 1), *p - '0');
1587
          if (q > buf0 || *p != '0')
1588
            if (q < buf_max)
1589
              *q++ = *p;
1590
            else if (*(q - 1) == '0')
1591
              *(q - 1) = *p;
1592
        }
1593
      if (NaN)
1594
        *q++ = '1';
1595
      if (*p == '.')            /*74: */
1596
#line 1415 "./mmix-arith.w"
1597
 
1598
        {
1599
          dec_pt = q;
1600
          p++;
1601
          for (zeros = 0; isdigit (*p); p++)
1602
            if (*p == '0' && q == buf0)
1603
              zeros++;
1604
            else if (q < buf_max)
1605
              *q++ = *p;
1606
            else if (*(q - 1) == '0')
1607
              *(q - 1) = *p;
1608
        }
1609
 
1610
/*:74*/
1611
#line 1406 "./mmix-arith.w"
1612
      ;
1613
      next_char = p;
1614
      if (*p == 'e' && !NaN)    /*77: */
1615
#line 1447 "./mmix-arith.w"
1616
 
1617
        {
1618
          register char exp_sign;
1619
          p++;
1620
          if (*p == '+' || *p == '-')
1621
            exp_sign = *p++;
1622
          else
1623
            exp_sign = '+';
1624
          if (isdigit (*p))
1625
            {
1626
              for (exp = *p++ - '0'; isdigit (*p); p++)
1627
                if (exp < 1000)
1628
                  exp = 10 * exp + *p - '0';
1629
              if (!dec_pt)
1630
                dec_pt = q, zeros = 0;
1631
              if (exp_sign == '-')
1632
                exp = -exp;
1633
              next_char = p;
1634
            }
1635
        }
1636
 
1637
/*:77*/
1638
#line 1408 "./mmix-arith.w"
1639
 
1640
      else
1641
        exp = 0;
1642
      if (dec_pt)               /*78: */
1643
#line 1460 "./mmix-arith.w"
1644
 
1645
        {
1646
/*79:*/
1647
#line 1477 "./mmix-arith.w"
1648
 
1649
          x = buf + 341 + zeros - dec_pt - exp;
1650
          if (q == buf0 || x >= 1413)
1651
            {
1652
            make_it_zero:exp = -99999;
1653
              goto packit;
1654
            }
1655
          if (x < 0)
1656
            {
1657
            make_it_infinite:exp = 99999;
1658
              goto packit;
1659
            }
1660
          ff.a = x / 9;
1661
          for (p = q; p < q + 8; p++)
1662
            *p = '0';
1663
          q = q - 1 - (q + 341 + zeros - dec_pt - exp) % 9;
1664
          for (p = buf0 - x % 9, k = ff.a; p <= q && k <= 156; p += 9, k++)
1665
/*80:*/
1666
#line 1497 "./mmix-arith.w"
1667
 
1668
            {
1669
              for (x = *p - '0', pp = p + 1; pp < p + 9; pp++)
1670
                x = 10 * x + *pp - '0';
1671
              ff.dat[k] = x;
1672
            }
1673
 
1674
/*:80*/
1675
#line 1490 "./mmix-arith.w"
1676
          ;
1677
          ff.b = k - 1;
1678
          for (x = 0; p <= q; p += 9)
1679
            if (strncmp (p, "000000000", 9) != 0)
1680
              x = 1;
1681
          ff.dat[156] += x;
1682
 
1683
          while (ff.dat[ff.b] == 0)
1684
            ff.b--;
1685
 
1686
/*:79*/
1687
#line 1462 "./mmix-arith.w"
1688
          ;
1689
/*83:*/
1690
#line 1526 "./mmix-arith.w"
1691
 
1692
          val = zero_octa;
1693
          if (ff.a > 36)
1694
            {
1695
              for (exp = 0x3fe; ff.a > 36; exp--)
1696
                bignum_double (&ff);
1697
              for (k = 54; k; k--)
1698
                {
1699
                  if (ff.dat[36])
1700
                    {
1701
                      if (k >= 32)
1702
                        val.h |= 1 << (k - 32);
1703
                      else
1704
                        val.l |= 1 << k;
1705
                      ff.dat[36] = 0;
1706
                      if (ff.b == 36)
1707
                        break;
1708
                    }
1709
                  bignum_double (&ff);
1710
                }
1711
            }
1712
          else
1713
            {
1714
              tt.a = tt.b = 36, tt.dat[36] = 2;
1715
              for (exp = 0x3fe; bignum_compare (&ff, &tt) >= 0; exp++)
1716
                bignum_double (&tt);
1717
              for (k = 54; k; k--)
1718
                {
1719
                  bignum_double (&ff);
1720
                  if (bignum_compare (&ff, &tt) >= 0)
1721
                    {
1722
                      if (k >= 32)
1723
                        val.h |= 1 << (k - 32);
1724
                      else
1725
                        val.l |= 1 << k;
1726
                      bignum_dec (&ff, &tt, 1000000000);
1727
                      if (ff.a == bignum_prec - 1)
1728
                        break;
1729
                    }
1730
                }
1731
            }
1732
          if (k == 0)
1733
            val.l |= 1;
1734
 
1735
/*:83*/
1736
#line 1463 "./mmix-arith.w"
1737
          ;
1738
        packit:         /*84: */
1739
#line 1559 "./mmix-arith.w"
1740
 
1741
          val = fpack (val, exp, sign, ROUND_NEAR);
1742
          if (NaN)
1743
            {
1744
              if ((val.h & 0x7fffffff) == 0x40000000)
1745
                val.h |= 0x7fffffff, val.l = 0xffffffff;
1746
              else if ((val.h & 0x7fffffff) == 0x3ff00000 && !val.l)
1747
                val.h |= 0x40000000, val.l = 1;
1748
              else
1749
                val.h |= 0x40000000;
1750
            }
1751
 
1752
/*:84*/
1753
#line 1464 "./mmix-arith.w"
1754
          ;
1755
          return 1;
1756
        }
1757
 
1758
/*:78*/
1759
#line 1410 "./mmix-arith.w"
1760
      ;
1761
      if (sign == '-')
1762
        val = ominus (zero_octa, val);
1763
      return 0;
1764
    }
1765
 
1766
/*:73*/
1767
#line 1353 "./mmix-arith.w"
1768
  ;
1769
  if (NaN)                      /*71: */
1770
#line 1368 "./mmix-arith.w"
1771
 
1772
    {
1773
      next_char = p;
1774
      val.h = 0x600000, exp = 0x3fe;
1775
      goto packit;
1776
    }
1777
 
1778
/*:71*/
1779
#line 1354 "./mmix-arith.w"
1780
  ;
1781
  if (strncmp (p, "Inf", 3) == 0)        /*72: */
1782
#line 1375 "./mmix-arith.w"
1783
 
1784
    {
1785
      next_char = p + 3;
1786
      goto make_it_infinite;
1787
    }
1788
 
1789
/*:72*/
1790
#line 1355 "./mmix-arith.w"
1791
  ;
1792
no_const_found:next_char = s;
1793
  return -1;
1794
}
1795
 
1796
       /*:68*//*82: */
1797
#line 1511 "./mmix-arith.w"
1798
 
1799
static void
1800
bignum_double (f)
1801
     bignum *f;
1802
{
1803
  register tetra *p, *q;
1804
  register int x, carry;
1805
  for (p = &f->dat[f->b], q = &f->dat[f->a], carry = 0; p >= q; p--)
1806
    {
1807
      x = *p + *p + carry;
1808
      if (x >= 1000000000)
1809
        carry = 1, *p = x - 1000000000;
1810
      else
1811
        carry = 0, *p = x;
1812
    }
1813
  *p = carry;
1814
  if (carry)
1815
    f->a--;
1816
  if (f->dat[f->b] == 0 && f->b > f->a)
1817
    f->b--;
1818
}
1819
 
1820
       /*:82*//*85: */
1821
#line 1575 "./mmix-arith.w"
1822
 
1823
int fcomp ARGS ((octa, octa));
1824
int
1825
fcomp (y, z)
1826
     octa y, z;
1827
{
1828
  ftype yt, zt;
1829
  int ye, ze;
1830
  char ys, zs;
1831
  octa yf, zf;
1832
  register int x;
1833
  yt = funpack (y, &yf, &ye, &ys);
1834
  zt = funpack (z, &zf, &ze, &zs);
1835
  switch (4 * yt + zt)
1836
    {
1837
    case 4 * nan + nan:
1838
    case 4 * zro + nan:
1839
    case 4 * num + nan:
1840
    case 4 * inf + nan:
1841
    case 4 * nan + zro:
1842
    case 4 * nan + num:
1843
    case 4 * nan + inf:
1844
      return 2;
1845
    case 4 * zro + zro:
1846
      return 0;
1847
    case 4 * zro + num:
1848
    case 4 * num + zro:
1849
    case 4 * zro + inf:
1850
    case 4 * inf + zro:
1851
    case 4 * num + num:
1852
    case 4 * num + inf:
1853
    case 4 * inf + num:
1854
    case 4 * inf + inf:
1855
      if (ys != zs)
1856
        x = 1;
1857
      else if (y.h > z.h)
1858
        x = 1;
1859
      else if (y.h < z.h)
1860
        x = -1;
1861
      else if (y.l > z.l)
1862
        x = 1;
1863
      else if (y.l < z.l)
1864
        x = -1;
1865
      else
1866
        return 0;
1867
      break;
1868
    }
1869
  return (ys == '-' ? -x : x);
1870
}
1871
 
1872
       /*:85*//*86: */
1873
#line 1608 "./mmix-arith.w"
1874
 
1875
octa fintegerize ARGS ((octa, int));
1876
octa
1877
fintegerize (z, r)
1878
     octa z;
1879
     int r;
1880
{
1881
  ftype zt;
1882
  int ze;
1883
  char zs;
1884
  octa xf, zf;
1885
  zt = funpack (z, &zf, &ze, &zs);
1886
  if (!r)
1887
    r = cur_round;
1888
  switch (zt)
1889
    {
1890
    case nan:
1891
      if (!(z.h & 0x80000))
1892
        {
1893
          exceptions |= I_BIT;
1894
          z.h |= 0x80000;
1895
        }
1896
    case inf:
1897
    case zro:
1898
      return z;
1899
    case num:                   /*87: */
1900
#line 1627 "./mmix-arith.w"
1901
 
1902
      if (ze >= 1074)
1903
        return fpack (zf, ze, zs, ROUND_OFF);
1904
      if (ze <= 1020)
1905
        xf.h = 0, xf.l = 1;
1906
      else
1907
        {
1908
          octa oo;
1909
          xf = shift_right (zf, 1074 - ze, 1);
1910
          oo = shift_left (xf, 1074 - ze);
1911
          if (oo.l != zf.l || oo.h != zf.h)
1912
            xf.l |= 1;
1913
 
1914
        }
1915
      switch (r)
1916
        {
1917
        case ROUND_DOWN:
1918
          if (zs == '-')
1919
            xf = incr (xf, 3);
1920
          break;
1921
        case ROUND_UP:
1922
          if (zs != '-')
1923
            xf = incr (xf, 3);
1924
        case ROUND_OFF:
1925
          break;
1926
        case ROUND_NEAR:
1927
          xf = incr (xf, xf.l & 4 ? 2 : 1);
1928
          break;
1929
        }
1930
      xf.l &= 0xfffffffc;
1931
      if (ze >= 1022)
1932
        return fpack (shift_left (xf, 1074 - ze), ze, zs, ROUND_OFF);
1933
      if (xf.l)
1934
        xf.h = 0x3ff00000, xf.l = 0;
1935
      if (zs == '-')
1936
        xf.h |= sign_bit;
1937
      return xf;
1938
 
1939
/*:87*/
1940
#line 1623 "./mmix-arith.w"
1941
      ;
1942
    }
1943
}
1944
 
1945
       /*:86*//*88: */
1946
#line 1650 "./mmix-arith.w"
1947
 
1948
octa fixit ARGS ((octa, int));
1949
octa
1950
fixit (z, r)
1951
     octa z;
1952
     int r;
1953
{
1954
  ftype zt;
1955
  int ze;
1956
  char zs;
1957
  octa zf, o;
1958
  zt = funpack (z, &zf, &ze, &zs);
1959
  if (!r)
1960
    r = cur_round;
1961
  switch (zt)
1962
    {
1963
    case nan:
1964
    case inf:
1965
      exceptions |= I_BIT;
1966
      return z;
1967
    case zro:
1968
      return zero_octa;
1969
    case num:
1970
      if (funpack (fintegerize (z, r), &zf, &ze, &zs) == zro)
1971
        return zero_octa;
1972
      if (ze <= 1076)
1973
        o = shift_right (zf, 1076 - ze, 1);
1974
      else
1975
        {
1976
          if (ze > 1085 || (ze == 1085 && (zf.h > 0x400000 ||
1977
                                           (zf.h == 0x400000
1978
                                            && (zf.l || zs != '-')))))
1979
            exceptions |= W_BIT;
1980
          if (ze >= 1140)
1981
            return zero_octa;
1982
          o = shift_left (zf, ze - 1076);
1983
        }
1984
      return (zs == '-' ? ominus (zero_octa, o) : o);
1985
    }
1986
}
1987
 
1988
       /*:88*//*89: */
1989
#line 1681 "./mmix-arith.w"
1990
 
1991
octa floatit ARGS ((octa, int, int, int));
1992
octa
1993
floatit (z, r, u, p)
1994
     octa z;
1995
     int r;
1996
     int u;
1997
     int p;
1998
{
1999
  int e;
2000
  char s;
2001
  register int t;
2002
  exceptions = 0;
2003
  if (!z.h && !z.l)
2004
    return zero_octa;
2005
  if (!r)
2006
    r = cur_round;
2007
  if (!u && (z.h & sign_bit))
2008
    s = '-', z = ominus (zero_octa, z);
2009
  else
2010
    s = '+';
2011
  e = 1076;
2012
  while (z.h < 0x400000)
2013
    e--, z = shift_left (z, 1);
2014
  while (z.h >= 0x800000)
2015
    {
2016
      e++;
2017
      t = z.l & 1;
2018
      z = shift_right (z, 1, 1);
2019
      z.l |= t;
2020
    }
2021
  if (p)                        /*90: */
2022
#line 1707 "./mmix-arith.w"
2023
 
2024
    {
2025
      register int ex;
2026
      register tetra t;
2027
      t = sfpack (z, e, s, r);
2028
      ex = exceptions;
2029
      sfunpack (t, &z, &e, &s);
2030
      exceptions = ex;
2031
    }
2032
 
2033
/*:90*/
2034
#line 1703 "./mmix-arith.w"
2035
  ;
2036
  return fpack (z, e, s, r);
2037
}
2038
 
2039
       /*:89*//*91: */
2040
#line 1718 "./mmix-arith.w"
2041
 
2042
octa froot ARGS ((octa, int));
2043
octa
2044
froot (z, r)
2045
     octa z;
2046
     int r;
2047
{
2048
  ftype zt;
2049
  int ze;
2050
  char zs;
2051
  octa x, xf, rf, zf;
2052
  register int xe, k;
2053
  if (!r)
2054
    r = cur_round;
2055
  zt = funpack (z, &zf, &ze, &zs);
2056
  if (zs == '-' && zt != zro)
2057
    exceptions |= I_BIT, x = standard_NaN;
2058
  else
2059
    switch (zt)
2060
      {
2061
      case nan:
2062
        if (!(z.h & 0x80000))
2063
          exceptions |= I_BIT, z.h |= 0x80000;
2064
        return z;
2065
      case inf:
2066
      case zro:
2067
        x = z;
2068
        break;
2069
      case num:         /*92: */
2070
#line 1750 "./mmix-arith.w"
2071
 
2072
        xf.h = 0, xf.l = 2;
2073
        xe = (ze + 0x3fe) >> 1;
2074
        if (ze & 1)
2075
          zf = shift_left (zf, 1);
2076
        rf.h = 0, rf.l = (zf.h >> 22) - 1;
2077
        for (k = 53; k; k--)
2078
          {
2079
            rf = shift_left (rf, 2);
2080
            xf = shift_left (xf, 1);
2081
            if (k >= 43)
2082
              rf = incr (rf, (zf.h >> (2 * (k - 43))) & 3);
2083
            else if (k >= 27)
2084
              rf = incr (rf, (zf.l >> (2 * (k - 27))) & 3);
2085
            if ((rf.l > xf.l && rf.h >= xf.h) || rf.h > xf.h)
2086
              {
2087
                xf.l++;
2088
                rf = ominus (rf, xf);
2089
                xf.l++;
2090
              }
2091
          }
2092
        if (rf.h || rf.l)
2093
          xf.l++;
2094
        return fpack (xf, xe, '+', r);
2095
 
2096
/*:92*/
2097
#line 1736 "./mmix-arith.w"
2098
        ;
2099
      }
2100
  if (zs == '-')
2101
    x.h |= sign_bit;
2102
  return x;
2103
}
2104
 
2105
       /*:91*//*93: */
2106
#line 1774 "./mmix-arith.w"
2107
 
2108
octa fremstep ARGS ((octa, octa, int));
2109
octa
2110
fremstep (y, z, delta)
2111
     octa y, z;
2112
     int delta;
2113
{
2114
  ftype yt, zt;
2115
  int ye, ze;
2116
  char xs, ys, zs;
2117
  octa x, xf, yf, zf;
2118
  register int xe, thresh, odd;
2119
  yt = funpack (y, &yf, &ye, &ys);
2120
  zt = funpack (z, &zf, &ze, &zs);
2121
  switch (4 * yt + zt)
2122
    {
2123
/*42:*/
2124
#line 731 "./mmix-arith.w"
2125
 
2126
    case 4 * nan + nan:
2127
      if (!(y.h & 0x80000))
2128
        exceptions |= I_BIT;
2129
    case 4 * zro + nan:
2130
    case 4 * num + nan:
2131
    case 4 * inf + nan:
2132
      if (!(z.h & 0x80000))
2133
        exceptions |= I_BIT, z.h |= 0x80000;
2134
      return z;
2135
    case 4 * nan + zro:
2136
    case 4 * nan + num:
2137
    case 4 * nan + inf:
2138
      if (!(y.h & 0x80000))
2139
        exceptions |= I_BIT, y.h |= 0x80000;
2140
      return y;
2141
 
2142
/*:42*/
2143
#line 1788 "./mmix-arith.w"
2144
      ;
2145
    case 4 * zro + zro:
2146
    case 4 * num + zro:
2147
    case 4 * inf + zro:
2148
    case 4 * inf + num:
2149
    case 4 * inf + inf:
2150
      x = standard_NaN;
2151
      exceptions |= I_BIT;
2152
      break;
2153
    case 4 * zro + num:
2154
    case 4 * zro + inf:
2155
    case 4 * num + inf:
2156
      return y;
2157
    case 4 * num + num: /*94: */
2158
#line 1809 "./mmix-arith.w"
2159
 
2160
      odd = 0;
2161
      thresh = ye - delta;
2162
      if (thresh < ze)
2163
        thresh = ze;
2164
      while (ye >= thresh)      /*95: */
2165
#line 1830 "./mmix-arith.w"
2166
 
2167
        {
2168
          if (yf.h == zf.h && yf.l == zf.l)
2169
            goto zero_out;
2170
          if (yf.h < zf.h || (yf.h == zf.h && yf.l < zf.l))
2171
            {
2172
              if (ye == ze)
2173
                goto try_complement;
2174
              ye--, yf = shift_left (yf, 1);
2175
            }
2176
          yf = ominus (yf, zf);
2177
          if (ye == ze)
2178
            odd = 1;
2179
          while (yf.h < 0x400000)
2180
            ye--, yf = shift_left (yf, 1);
2181
        }
2182
 
2183
/*:95*/
2184
#line 1815 "./mmix-arith.w"
2185
      ;
2186
      if (ye >= ze)
2187
        {
2188
          exceptions |= E_BIT;
2189
          return fpack (yf, ye, ys, ROUND_OFF);
2190
        }
2191
      if (ye < ze - 1)
2192
        return fpack (yf, ye, ys, ROUND_OFF);
2193
      yf = shift_right (yf, 1, 1);
2194
    try_complement:xf = ominus (zf, yf), xe = ze, xs = '+' + '-' - ys;
2195
      if (xf.h > yf.h
2196
          || (xf.h == yf.h && (xf.l > yf.l || (xf.l == yf.l && !odd))))
2197
        xf = yf, xs = ys;
2198
      while (xf.h < 0x400000)
2199
        xe--, xf = shift_left (xf, 1);
2200
      return fpack (xf, xe, xs, ROUND_OFF);
2201
 
2202
/*:94*/
2203
#line 1793 "./mmix-arith.w"
2204
      ;
2205
    zero_out:x = zero_octa;
2206
    }
2207
  if (ys == '-')
2208
    x.h |= sign_bit;
2209
  return x;
2210
}
2211
 
2212
/*:93*/
2213
#line 41 "./mmix-arith.w"
2214
 
2215
 
2216
/*:1*/

powered by: WebSVN 2.1.0

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