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

Subversion Repositories eco32

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

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.