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

Subversion Repositories eco32

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

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{false,true}bool;
47
/*3:*/
48
#line 60 "./mmix-arith.w"
49
 
50
typedef unsigned int tetra;
51
 
52
typedef struct{tetra h,l;}octa;
53
 
54
/*:3*/
55
#line 38 "./mmix-arith.w"
56
 
57
/*36:*/
58
#line 605 "./mmix-arith.w"
59
 
60
typedef enum{zro,num,inf,nan}ftype;
61
 
62
/*:36*//*59:*/
63
#line 1110 "./mmix-arith.w"
64
 
65
typedef struct{
66
int a;
67
int b;
68
tetra dat[bignum_prec];
69
}bignum;
70
 
71
/*:59*/
72
#line 39 "./mmix-arith.w"
73
 
74
/*4:*/
75
#line 67 "./mmix-arith.w"
76
 
77
octa zero_octa;
78
octa neg_one= {-1,-1};
79
octa inf_octa= {0x7ff00000,0};
80
octa standard_NaN= {0x7ff80000,0};
81
octa aux;
82
bool overflow;
83
 
84
/*:4*//*9:*/
85
#line 174 "./mmix-arith.w"
86
 
87
extern octa aux;
88
extern bool overflow;
89
 
90
/*:9*//*30:*/
91
#line 464 "./mmix-arith.w"
92
 
93
int cur_round;
94
 
95
/*:30*//*32:*/
96
#line 528 "./mmix-arith.w"
97
 
98
int exceptions;
99
 
100
/*:32*//*69:*/
101
#line 1359 "./mmix-arith.w"
102
 
103
octa val;
104
char*next_char;
105
 
106
/*:69*//*75:*/
107
#line 1432 "./mmix-arith.w"
108
 
109
static char buf[785]= "00000000";
110
 
111
/*:75*/
112
#line 40 "./mmix-arith.w"
113
 
114
/*5:*/
115
#line 78 "./mmix-arith.w"
116
 
117
octa oplus ARGS((octa,octa));
118
octa oplus(y,z)
119
octa y,z;
120
{octa x;
121
x.h= y.h+z.h;
122
x.l= y.l+z.l;
123
if(x.l<y.l)x.h++;
124
return x;
125
}
126
 
127
octa ominus ARGS((octa,octa));
128
octa ominus(y,z)
129
octa y,z;
130
{octa x;
131
x.h= y.h-z.h;
132
x.l= y.l-z.l;
133
if(x.l> y.l)x.h--;
134
return x;
135
}
136
 
137
/*:5*//*6:*/
138
#line 102 "./mmix-arith.w"
139
 
140
octa incr ARGS((octa,int));
141
octa incr(y,delta)
142
octa y;
143
int delta;
144
{octa x;
145
x.h= y.h;x.l= y.l+delta;
146
if(delta>=0){
147
if(x.l<y.l)x.h++;
148
}else if(x.l> y.l)x.h--;
149
return x;
150
}
151
 
152
/*:6*//*7:*/
153
#line 117 "./mmix-arith.w"
154
 
155
octa shift_left ARGS((octa,int));
156
octa shift_left(y,s)
157
octa y;
158
int s;
159
{
160
while(s>=32)y.h= y.l,y.l= 0,s-= 32;
161
if(s){register tetra yhl= y.h<<s,ylh= y.l>>(32-s);
162
y.h= yhl+ylh;y.l<<= s;
163
}
164
return y;
165
}
166
 
167
octa shift_right ARGS((octa,int,int));
168
octa shift_right(y,s,u)
169
octa y;
170
int s,u;
171
{
172
while(s>=32)y.l= y.h,y.h= (u?0:-(y.h>>31)),s-= 32;
173
if(s){register tetra yhl= y.h<<(32-s),ylh= y.l>>s;
174
y.h= (u?0:(-(y.h>>31))<<(32-s))+(y.h>>s);y.l= yhl+ylh;
175
}
176
return y;
177
}
178
 
179
/*:7*//*8:*/
180
#line 150 "./mmix-arith.w"
181
 
182
octa omult ARGS((octa,octa));
183
octa omult(y,z)
184
octa y,z;
185
{
186
register int i,j,k;
187
tetra u[4],v[4],w[8];
188
register tetra t;
189
octa acc;
190
/*10:*/
191
#line 178 "./mmix-arith.w"
192
 
193
u[3]= y.h>>16,u[2]= y.h&0xffff,u[1]= y.l>>16,u[0]= y.l&0xffff;
194
v[3]= z.h>>16,v[2]= z.h&0xffff,v[1]= z.l>>16,v[0]= z.l&0xffff;
195
 
196
/*:10*/
197
#line 159 "./mmix-arith.w"
198
;
199
for(j= 0;j<4;j++)w[j]= 0;
200
for(j= 0;j<4;j++)
201
if(!v[j])w[j+4]= 0;
202
else{
203
for(i= k= 0;i<4;i++){
204
t= u[i]*v[j]+w[i+j]+k;
205
w[i+j]= t&0xffff,k= t>>16;
206
}
207
w[j+4]= k;
208
}
209
/*11:*/
210
#line 182 "./mmix-arith.w"
211
 
212
aux.h= (w[7]<<16)+w[6],aux.l= (w[5]<<16)+w[4];
213
acc.h= (w[3]<<16)+w[2],acc.l= (w[1]<<16)+w[0];
214
 
215
/*:11*/
216
#line 170 "./mmix-arith.w"
217
;
218
return acc;
219
}
220
 
221
/*:8*//*12:*/
222
#line 191 "./mmix-arith.w"
223
 
224
octa signed_omult ARGS((octa,octa));
225
octa signed_omult(y,z)
226
octa y,z;
227
{
228
octa acc;
229
acc= omult(y,z);
230
if(y.h&sign_bit)aux= ominus(aux,z);
231
if(z.h&sign_bit)aux= ominus(aux,y);
232
overflow= (aux.h!=aux.l||(aux.h^(aux.h>>1)^(acc.h&sign_bit)));
233
return acc;
234
}
235
 
236
/*:12*//*13:*/
237
#line 215 "./mmix-arith.w"
238
 
239
octa odiv ARGS((octa,octa,octa));
240
octa odiv(x,y,z)
241
octa x,y,z;
242
{
243
register int i,j,k,n,d;
244
tetra u[8],v[4],q[4],mask,qhat,rhat,vh,vmh;
245
register tetra t;
246
octa acc;
247
/*14:*/
248
#line 234 "./mmix-arith.w"
249
 
250
if(x.h> z.h||(x.h==z.h&&x.l>=z.l)){
251
aux= y;return x;
252
}
253
 
254
/*:14*/
255
#line 224 "./mmix-arith.w"
256
;
257
/*15:*/
258
#line 239 "./mmix-arith.w"
259
 
260
u[7]= x.h>>16,u[6]= x.h&0xffff,u[5]= x.l>>16,u[4]= x.l&0xffff;
261
u[3]= y.h>>16,u[2]= y.h&0xffff,u[1]= y.l>>16,u[0]= y.l&0xffff;
262
v[3]= z.h>>16,v[2]= z.h&0xffff,v[1]= z.l>>16,v[0]= z.l&0xffff;
263
 
264
/*:15*/
265
#line 225 "./mmix-arith.w"
266
;
267
/*16:*/
268
#line 244 "./mmix-arith.w"
269
 
270
for(n= 4;v[n-1]==0;n--);
271
 
272
/*:16*/
273
#line 226 "./mmix-arith.w"
274
;
275
/*17:*/
276
#line 250 "./mmix-arith.w"
277
 
278
vh= v[n-1];
279
for(d= 0;vh<0x8000;d++,vh<<= 1);
280
for(j= k= 0;j<n+4;j++){
281
t= (u[j]<<d)+k;
282
u[j]= t&0xffff,k= t>>16;
283
}
284
for(j= k= 0;j<n;j++){
285
t= (v[j]<<d)+k;
286
v[j]= t&0xffff,k= t>>16;
287
}
288
vh= v[n-1];
289
vmh= (n> 1?v[n-2]:0);
290
 
291
/*:17*/
292
#line 227 "./mmix-arith.w"
293
;
294
for(j= 3;j>=0;j--)/*20:*/
295
#line 276 "./mmix-arith.w"
296
 
297
{
298
/*21:*/
299
#line 284 "./mmix-arith.w"
300
 
301
t= (u[j+n]<<16)+u[j+n-1];
302
qhat= t/vh,rhat= t-vh*qhat;
303
if(n> 1)while(qhat==0x10000||qhat*vmh> (rhat<<16)+u[j+n-2]){
304
qhat--,rhat+= vh;
305
if(rhat>=0x10000)break;
306
}
307
 
308
/*:21*/
309
#line 278 "./mmix-arith.w"
310
;
311
/*22:*/
312
#line 296 "./mmix-arith.w"
313
 
314
for(i= k= 0;i<n;i++){
315
t= u[i+j]+0xffff0000-k-qhat*v[i];
316
u[i+j]= t&0xffff,k= 0xffff-(t>>16);
317
}
318
 
319
/*:22*/
320
#line 279 "./mmix-arith.w"
321
;
322
/*23:*/
323
#line 305 "./mmix-arith.w"
324
 
325
if(u[j+n]!=k){
326
qhat--;
327
for(i= k= 0;i<n;i++){
328
t= u[i+j]+v[i]+k;
329
u[i+j]= t&0xffff,k= t>>16;
330
}
331
}
332
 
333
/*:23*/
334
#line 280 "./mmix-arith.w"
335
;
336
q[j]= qhat;
337
}
338
 
339
/*:20*/
340
#line 228 "./mmix-arith.w"
341
;
342
/*18:*/
343
#line 264 "./mmix-arith.w"
344
 
345
mask= (1<<d)-1;
346
for(j= 3;j>=n;j--)u[j]= 0;
347
for(k= 0;j>=0;j--){
348
t= (k<<16)+u[j];
349
u[j]= t>>d,k= t&mask;
350
}
351
 
352
/*:18*/
353
#line 229 "./mmix-arith.w"
354
;
355
/*19:*/
356
#line 272 "./mmix-arith.w"
357
 
358
acc.h= (q[3]<<16)+q[2],acc.l= (q[1]<<16)+q[0];
359
aux.h= (u[3]<<16)+u[2],aux.l= (u[1]<<16)+u[0];
360
 
361
/*:19*/
362
#line 230 "./mmix-arith.w"
363
;
364
return acc;
365
}
366
 
367
/*:13*//*24:*/
368
#line 317 "./mmix-arith.w"
369
 
370
octa signed_odiv ARGS((octa,octa));
371
octa signed_odiv(y,z)
372
octa y,z;
373
{
374
octa yy,zz,q;
375
register int sy,sz;
376
if(y.h&sign_bit)sy= 2,yy= ominus(zero_octa,y);
377
else sy= 0,yy= y;
378
if(z.h&sign_bit)sz= 1,zz= ominus(zero_octa,z);
379
else sz= 0,zz= z;
380
q= odiv(zero_octa,yy,zz);
381
overflow= false;
382
switch(sy+sz){
383
case 2+1:aux= ominus(zero_octa,aux);
384
if(q.h==sign_bit)overflow= true;
385
case 0+0:return q;
386
case 2+0:if(aux.h||aux.l)aux= ominus(zz,aux);
387
goto negate_q;
388
case 0+1:if(aux.h||aux.l)aux= ominus(aux,zz);
389
negate_q:if(aux.h||aux.l)return ominus(neg_one,q);
390
else return ominus(zero_octa,q);
391
}
392
}
393
 
394
/*:24*//*25:*/
395
#line 346 "./mmix-arith.w"
396
 
397
octa oand ARGS((octa,octa));
398
octa oand(y,z)
399
octa y,z;
400
{octa x;
401
x.h= y.h&z.h;x.l= y.l&z.l;
402
return x;
403
}
404
 
405
octa oandn ARGS((octa,octa));
406
octa oandn(y,z)
407
octa y,z;
408
{octa x;
409
x.h= y.h&~z.h;x.l= y.l&~z.l;
410
return x;
411
}
412
 
413
octa oxor ARGS((octa,octa));
414
octa oxor(y,z)
415
octa y,z;
416
{octa x;
417
x.h= y.h^z.h;x.l= y.l^z.l;
418
return x;
419
}
420
 
421
/*:25*//*26:*/
422
#line 387 "./mmix-arith.w"
423
 
424
int count_bits ARGS((tetra));
425
int count_bits(x)
426
tetra x;
427
{
428
register int xx= x;
429
xx= xx-((xx>>1)&0x55555555);
430
xx= (xx&0x33333333)+((xx>>2)&0x33333333);
431
xx= (xx+(xx>>4))&0x0f0f0f0f;
432
xx= xx+(xx>>8);
433
return(xx+(xx>>16))&0xff;
434
}
435
 
436
/*:26*//*27:*/
437
#line 403 "./mmix-arith.w"
438
 
439
tetra byte_diff ARGS((tetra,tetra));
440
tetra byte_diff(y,z)
441
tetra y,z;
442
{
443
register tetra d= (y&0x00ff00ff)+0x01000100-(z&0x00ff00ff);
444
register tetra m= d&0x01000100;
445
register tetra x= d&(m-(m>>8));
446
d= ((y>>8)&0x00ff00ff)+0x01000100-((z>>8)&0x00ff00ff);
447
m= d&0x01000100;
448
return x+((d&(m-(m>>8)))<<8);
449
}
450
 
451
/*:27*//*28:*/
452
#line 421 "./mmix-arith.w"
453
 
454
tetra wyde_diff ARGS((tetra,tetra));
455
tetra wyde_diff(y,z)
456
tetra y,z;
457
{
458
register tetra a= ((y>>16)-(z>>16))&0x10000;
459
register tetra b= ((y&0xffff)-(z&0xffff))&0x10000;
460
return y-(z^((y^z)&(b-a-(b>>16))));
461
}
462
 
463
/*:28*//*29:*/
464
#line 434 "./mmix-arith.w"
465
 
466
octa bool_mult ARGS((octa,octa,bool));
467
octa bool_mult(y,z,xor)
468
octa y,z;
469
bool xor;
470
{
471
octa o,x;
472
register tetra a,b,c;
473
register int k;
474
for(k= 0,o= y,x= zero_octa;o.h||o.l;k++,o= shift_right(o,8,1))
475
if(o.l&0xff){
476
a= ((z.h>>k)&0x01010101)*0xff;
477
b= ((z.l>>k)&0x01010101)*0xff;
478
c= (o.l&0xff)*0x01010101;
479
if(xor)x.h^= a&c,x.l^= b&c;
480
else x.h|= a&c,x.l|= b&c;
481
}
482
return x;
483
}
484
 
485
/*:29*//*31:*/
486
#line 503 "./mmix-arith.w"
487
 
488
octa fpack ARGS((octa,int,char,int));
489
octa fpack(f,e,s,r)
490
octa f;
491
int e;
492
char s;
493
int r;
494
{
495
octa o;
496
if(e> 0x7fd)e= 0x7ff,o= zero_octa;
497
else{
498
if(e<0){
499
if(e<-54)o.h= 0,o.l= 1;
500
else{octa oo;
501
o= shift_right(f,-e,1);
502
oo= shift_left(o,-e);
503
if(oo.l!=f.l||oo.h!=f.h)o.l|= 1;
504
 
505
}
506
e= 0;
507
}else o= f;
508
}
509
/*33:*/
510
#line 533 "./mmix-arith.w"
511
 
512
if(o.l&3)exceptions|= X_BIT;
513
switch(r){
514
case ROUND_DOWN:if(s=='-')o= incr(o,3);break;
515
case ROUND_UP:if(s!='-')o= incr(o,3);
516
case ROUND_OFF:break;
517
case ROUND_NEAR:o= incr(o,o.l&4?2:1);break;
518
}
519
o= shift_right(o,2,1);
520
o.h+= e<<20;
521
if(o.h>=0x7ff00000)exceptions|= O_BIT+X_BIT;
522
else if(o.h<0x100000)exceptions|= U_BIT;
523
if(s=='-')o.h|= sign_bit;
524
return o;
525
 
526
/*:33*/
527
#line 525 "./mmix-arith.w"
528
;
529
}
530
 
531
/*:31*//*34:*/
532
#line 551 "./mmix-arith.w"
533
 
534
tetra sfpack ARGS((octa,int,char,int));
535
tetra sfpack(f,e,s,r)
536
octa f;
537
int e;
538
char s;
539
int r;
540
{
541
register tetra o;
542
if(e> 0x47d)e= 0x47f,o= 0;
543
else{
544
o= shift_left(f,3).h;
545
if(f.l&0x1fffffff)o|= 1;
546
if(e<0x380){
547
if(e<0x380-25)o= 1;
548
else{register tetra o0,oo;
549
o0= o;
550
o= o>>(0x380-e);
551
oo= o<<(0x380-e);
552
if(oo!=o0)o|= 1;
553
 
554
}
555
e= 0x380;
556
}
557
}
558
/*35:*/
559
#line 579 "./mmix-arith.w"
560
 
561
if(o&3)exceptions|= X_BIT;
562
switch(r){
563
case ROUND_DOWN:if(s=='-')o+= 3;break;
564
case ROUND_UP:if(s!='-')o+= 3;
565
case ROUND_OFF:break;
566
case ROUND_NEAR:o+= (o&4?2:1);break;
567
}
568
o= o>>2;
569
o+= (e-0x380)<<23;
570
if(o>=0x7f800000)exceptions|= O_BIT+X_BIT;
571
else if(o<0x100000)exceptions|= U_BIT;
572
if(s=='-')o|= sign_bit;
573
return o;
574
 
575
/*:35*/
576
#line 576 "./mmix-arith.w"
577
;
578
}
579
 
580
/*:34*//*37:*/
581
#line 608 "./mmix-arith.w"
582
 
583
ftype funpack ARGS((octa,octa*,int*,char*));
584
ftype funpack(x,f,e,s)
585
octa x;
586
octa*f;
587
int*e;
588
char*s;
589
{
590
register int ee;
591
exceptions= 0;
592
*s= (x.h&sign_bit?'-':'+');
593
*f= shift_left(x,2);
594
f->h&= 0x3fffff;
595
ee= (x.h>>20)&0x7ff;
596
if(ee){
597
*e= ee-1;
598
f->h|= 0x400000;
599
return(ee<0x7ff?num:f->h==0x400000&&!f->l?inf:nan);
600
}
601
if(!x.l&&!f->h){
602
*e= zero_exponent;return zro;
603
}
604
do{ee--;*f= shift_left(*f,1);}while(!(f->h&0x400000));
605
*e= ee;return num;
606
}
607
 
608
/*:37*//*38:*/
609
#line 634 "./mmix-arith.w"
610
 
611
ftype sfunpack ARGS((tetra,octa*,int*,char*));
612
ftype sfunpack(x,f,e,s)
613
tetra x;
614
octa*f;
615
int*e;
616
char*s;
617
{
618
register int ee;
619
exceptions= 0;
620
*s= (x&sign_bit?'-':'+');
621
f->h= (x>>1)&0x3fffff,f->l= x<<31;
622
ee= (x>>23)&0xff;
623
if(ee){
624
*e= ee+0x380-1;
625
f->h|= 0x400000;
626
return(ee<0xff?num:(x&0x7fffffff)==0x7f800000?inf:nan);
627
}
628
if(!(x&0x7fffffff)){
629
*e= zero_exponent;return zro;
630
}
631
do{ee--;*f= shift_left(*f,1);}while(!(f->h&0x400000));
632
*e= ee+0x380;return num;
633
}
634
 
635
/*:38*//*39:*/
636
#line 663 "./mmix-arith.w"
637
 
638
octa load_sf ARGS((tetra));
639
octa load_sf(z)
640
tetra z;
641
{
642
octa f,x;int e;char s;ftype t;
643
t= sfunpack(z,&f,&e,&s);
644
switch(t){
645
case zro:x= zero_octa;break;
646
case num:return fpack(f,e,s,ROUND_OFF);
647
case inf:x= inf_octa;break;
648
case nan:x= shift_right(f,2,1);x.h|= 0x7ff00000;break;
649
}
650
if(s=='-')x.h|= sign_bit;
651
return x;
652
}
653
 
654
/*:39*//*40:*/
655
#line 680 "./mmix-arith.w"
656
 
657
tetra store_sf ARGS((octa));
658
tetra store_sf(x)
659
octa x;
660
{
661
octa f;tetra z;int e;char s;ftype t;
662
t= funpack(x,&f,&e,&s);
663
switch(t){
664
case zro:z= 0;break;
665
case num:return sfpack(f,e,s,cur_round);
666
case inf:z= 0x7f800000;break;
667
case nan:if(!(f.h&0x200000)){
668
f.h|= 0x200000;exceptions|= I_BIT;
669
}
670
z= 0x7f800000|(f.h<<1)|(f.l>>31);break;
671
}
672
if(s=='-')z|= sign_bit;
673
return z;
674
}
675
 
676
/*:40*//*41:*/
677
#line 705 "./mmix-arith.w"
678
 
679
octa fmult ARGS((octa,octa));
680
octa fmult(y,z)
681
octa y,z;
682
{
683
ftype yt,zt;
684
int ye,ze;
685
char ys,zs;
686
octa x,xf,yf,zf;
687
register int xe;
688
register char xs;
689
yt= funpack(y,&yf,&ye,&ys);
690
zt= funpack(z,&zf,&ze,&zs);
691
xs= ys+zs-'+';
692
switch(4*yt+zt){
693
/*42:*/
694
#line 731 "./mmix-arith.w"
695
 
696
case 4*nan+nan:if(!(y.h&0x80000))exceptions|= I_BIT;
697
case 4*zro+nan:case 4*num+nan:case 4*inf+nan:
698
if(!(z.h&0x80000))exceptions|= I_BIT,z.h|= 0x80000;
699
return z;
700
case 4*nan+zro:case 4*nan+num:case 4*nan+inf:
701
if(!(y.h&0x80000))exceptions|= I_BIT,y.h|= 0x80000;
702
return y;
703
 
704
/*:42*/
705
#line 720 "./mmix-arith.w"
706
;
707
case 4*zro+zro:case 4*zro+num:case 4*num+zro:x= zero_octa;break;
708
case 4*num+inf:case 4*inf+num:case 4*inf+inf:x= inf_octa;break;
709
case 4*zro+inf:case 4*inf+zro:x= standard_NaN;
710
exceptions|= I_BIT;break;
711
case 4*num+num:/*43:*/
712
#line 740 "./mmix-arith.w"
713
 
714
xe= ye+ze-0x3fd;
715
x= omult(yf,shift_left(zf,9));
716
if(aux.h>=0x400000)xf= aux;
717
else xf= shift_left(aux,1),xe--;
718
if(x.h||x.l)xf.l|= 1;
719
return fpack(xf,xe,xs,cur_round);
720
 
721
/*:43*/
722
#line 725 "./mmix-arith.w"
723
;
724
}
725
if(xs=='-')x.h|= sign_bit;
726
return x;
727
}
728
 
729
/*:41*//*44:*/
730
#line 748 "./mmix-arith.w"
731
 
732
octa fdivide ARGS((octa,octa));
733
octa fdivide(y,z)
734
octa y,z;
735
{
736
ftype yt,zt;
737
int ye,ze;
738
char ys,zs;
739
octa x,xf,yf,zf;
740
register int xe;
741
register char xs;
742
yt= funpack(y,&yf,&ye,&ys);
743
zt= funpack(z,&zf,&ze,&zs);
744
xs= ys+zs-'+';
745
switch(4*yt+zt){
746
/*42:*/
747
#line 731 "./mmix-arith.w"
748
 
749
case 4*nan+nan:if(!(y.h&0x80000))exceptions|= I_BIT;
750
case 4*zro+nan:case 4*num+nan:case 4*inf+nan:
751
if(!(z.h&0x80000))exceptions|= I_BIT,z.h|= 0x80000;
752
return z;
753
case 4*nan+zro:case 4*nan+num:case 4*nan+inf:
754
if(!(y.h&0x80000))exceptions|= I_BIT,y.h|= 0x80000;
755
return y;
756
 
757
/*:42*/
758
#line 763 "./mmix-arith.w"
759
;
760
case 4*zro+inf:case 4*zro+num:case 4*num+inf:x= zero_octa;break;
761
case 4*num+zro:exceptions|= Z_BIT;
762
case 4*inf+num:case 4*inf+zro:x= inf_octa;break;
763
case 4*zro+zro:case 4*inf+inf:x= standard_NaN;
764
exceptions|= I_BIT;break;
765
case 4*num+num:/*45:*/
766
#line 775 "./mmix-arith.w"
767
 
768
xe= ye-ze+0x3fd;
769
xf= odiv(yf,zero_octa,shift_left(zf,9));
770
if(xf.h>=0x800000){
771
aux.l|= xf.l&1;
772
xf= shift_right(xf,1,1);
773
xe++;
774
}
775
if(aux.h||aux.l)xf.l|= 1;
776
return fpack(xf,xe,xs,cur_round);
777
 
778
/*:45*/
779
#line 769 "./mmix-arith.w"
780
;
781
}
782
if(xs=='-')x.h|= sign_bit;
783
return x;
784
}
785
 
786
/*:44*//*46:*/
787
#line 790 "./mmix-arith.w"
788
 
789
octa fplus ARGS((octa,octa));
790
octa fplus(y,z)
791
octa y,z;
792
{
793
ftype yt,zt;
794
int ye,ze;
795
char ys,zs;
796
octa x,xf,yf,zf;
797
register int xe,d;
798
register char xs;
799
yt= funpack(y,&yf,&ye,&ys);
800
zt= funpack(z,&zf,&ze,&zs);
801
switch(4*yt+zt){
802
/*42:*/
803
#line 731 "./mmix-arith.w"
804
 
805
case 4*nan+nan:if(!(y.h&0x80000))exceptions|= I_BIT;
806
case 4*zro+nan:case 4*num+nan:case 4*inf+nan:
807
if(!(z.h&0x80000))exceptions|= I_BIT,z.h|= 0x80000;
808
return z;
809
case 4*nan+zro:case 4*nan+num:case 4*nan+inf:
810
if(!(y.h&0x80000))exceptions|= I_BIT,y.h|= 0x80000;
811
return y;
812
 
813
/*:42*/
814
#line 804 "./mmix-arith.w"
815
;
816
case 4*zro+num:return fpack(zf,ze,zs,ROUND_OFF);break;
817
case 4*num+zro:return fpack(yf,ye,ys,ROUND_OFF);break;
818
case 4*inf+inf:if(ys!=zs){
819
exceptions|= I_BIT;x= standard_NaN;xs= zs;break;
820
}
821
case 4*num+inf:case 4*zro+inf:x= inf_octa;xs= zs;break;
822
case 4*inf+num:case 4*inf+zro:x= inf_octa;xs= ys;break;
823
case 4*num+num:if(y.h!=(z.h^0x80000000)||y.l!=z.l)
824
/*47:*/
825
#line 821 "./mmix-arith.w"
826
 
827
{octa o,oo;
828
if(ye<ze||(ye==ze&&(yf.h<zf.h||(yf.h==zf.h&&yf.l<zf.l))))
829
/*48:*/
830
#line 839 "./mmix-arith.w"
831
 
832
{
833
o= yf,yf= zf,zf= o;
834
d= ye,ye= ze,ze= d;
835
d= ys,ys= zs,zs= d;
836
}
837
 
838
/*:48*/
839
#line 824 "./mmix-arith.w"
840
;
841
d= ye-ze;
842
xs= ys,xe= ye;
843
if(d)/*49:*/
844
#line 859 "./mmix-arith.w"
845
 
846
{
847
if(d<=2)zf= shift_right(zf,d,1);
848
else if(d> 53)zf.h= 0,zf.l= 1;
849
else{
850
if(ys!=zs)d--,xe--,yf= shift_left(yf,1);
851
o= zf;
852
zf= shift_right(o,d,1);
853
oo= shift_left(zf,d);
854
if(oo.l!=o.l||oo.h!=o.h)zf.l|= 1;
855
}
856
}
857
 
858
/*:49*/
859
#line 827 "./mmix-arith.w"
860
;
861
if(ys==zs){
862
xf= oplus(yf,zf);
863
if(xf.h>=0x800000)xe++,d= xf.l&1,xf= shift_right(xf,1,1),xf.l|= d;
864
}else{
865
xf= ominus(yf,zf);
866
if(xf.h>=0x800000)xe++,d= xf.l&1,xf= shift_right(xf,1,1),xf.l|= d;
867
else while(xf.h<0x400000)xe--,xf= shift_left(xf,1);
868
}
869
return fpack(xf,xe,xs,cur_round);
870
}
871
 
872
/*:47*/
873
#line 813 "./mmix-arith.w"
874
;
875
case 4*zro+zro:x= zero_octa;
876
xs= (ys==zs?ys:cur_round==ROUND_DOWN?'-':'+');break;
877
}
878
if(xs=='-')x.h|= sign_bit;
879
return x;
880
}
881
 
882
/*:46*//*50:*/
883
#line 883 "./mmix-arith.w"
884
 
885
int fepscomp ARGS((octa,octa,octa,int));
886
int fepscomp(y,z,e,s)
887
octa y,z,e;
888
int s;
889
{
890
octa yf,zf,ef,o,oo;
891
int ye,ze,ee;
892
char ys,zs,es;
893
register int yt,zt,et,d;
894
et= funpack(e,&ef,&ee,&es);
895
if(es=='-')return 2;
896
switch(et){
897
case nan:return 2;
898
case inf:ee= 10000;
899
case num:case zro:break;
900
}
901
yt= funpack(y,&yf,&ye,&ys);
902
zt= funpack(z,&zf,&ze,&zs);
903
switch(4*yt+zt){
904
case 4*nan+nan:case 4*nan+inf:case 4*nan+num:case 4*nan+zro:
905
case 4*inf+nan:case 4*num+nan:case 4*zro+nan:return 2;
906
case 4*inf+inf:return(ys==zs||ee>=1023);
907
case 4*inf+num:case 4*inf+zro:case 4*num+inf:case 4*zro+inf:
908
return(s&&ee>=1022);
909
case 4*zro+zro:return 1;
910
case 4*zro+num:case 4*num+zro:if(!s)return 0;
911
case 4*num+num:break;
912
}
913
/*51:*/
914
#line 919 "./mmix-arith.w"
915
 
916
/*52:*/
917
#line 934 "./mmix-arith.w"
918
 
919
if(ye<0&&yt!=zro)yf= shift_left(y,2),ye= 0;
920
if(ze<0&&zt!=zro)zf= shift_left(z,2),ze= 0;
921
 
922
/*:52*/
923
#line 920 "./mmix-arith.w"
924
;
925
if(ye<ze||(ye==ze&&(yf.h<zf.h||(yf.h==zf.h&&yf.l<zf.l))))
926
/*48:*/
927
#line 839 "./mmix-arith.w"
928
 
929
{
930
o= yf,yf= zf,zf= o;
931
d= ye,ye= ze,ze= d;
932
d= ys,ys= zs,zs= d;
933
}
934
 
935
/*:48*/
936
#line 922 "./mmix-arith.w"
937
;
938
if(ze==zero_exponent)ze= ye;
939
d= ye-ze;
940
if(!s)ee-= d;
941
if(ee>=1023)return 1;
942
/*53:*/
943
#line 956 "./mmix-arith.w"
944
 
945
if(d> 54)o= zero_octa,oo= zf;
946
else o= shift_right(zf,d,1),oo= shift_left(o,d);
947
if(oo.h!=zf.h||oo.l!=zf.l){
948
if(ee<1020)return 0;
949
o= incr(o,ys==zs?0:1);
950
}
951
o= (ys==zs?ominus(yf,o):oplus(yf,o));
952
 
953
/*:53*/
954
#line 927 "./mmix-arith.w"
955
;
956
if(!o.h&&!o.l)return 1;
957
if(ee<968)return 0;
958
if(ee>=1021)ef= shift_left(ef,ee-1021);
959
else ef= shift_right(ef,1021-ee,1);
960
return o.h<ef.h||(o.h==ef.h&&o.l<=ef.l);
961
 
962
/*:51*/
963
#line 912 "./mmix-arith.w"
964
;
965
}
966
 
967
/*:50*//*54:*/
968
#line 972 "./mmix-arith.w"
969
 
970
static void bignum_times_ten ARGS((bignum*));
971
static void bignum_dec ARGS((bignum*,bignum*,tetra));
972
static int bignum_compare ARGS((bignum*,bignum*));
973
void print_float ARGS((octa));
974
void print_float(x)
975
octa x;
976
{
977
/*56:*/
978
#line 1035 "./mmix-arith.w"
979
 
980
octa f,g;
981
register int e;
982
register int j,k;
983
 
984
/*:56*//*66:*/
985
#line 1281 "./mmix-arith.w"
986
 
987
bignum ff,gg;
988
bignum tt;
989
char s[18];
990
register char*p;
991
 
992
/*:66*/
993
#line 980 "./mmix-arith.w"
994
;
995
if(x.h&sign_bit)printf("-");
996
/*55:*/
997
#line 1019 "./mmix-arith.w"
998
 
999
f= shift_left(x,1);
1000
e= f.h>>21;
1001
f.h&= 0x1fffff;
1002
if(!f.h&&!f.l)/*57:*/
1003
#line 1045 "./mmix-arith.w"
1004
 
1005
{
1006
if(!e){
1007
printf("0.");return;
1008
}
1009
if(e==0x7ff){
1010
printf("Inf");return;
1011
}
1012
e--;
1013
f.h= 0x3fffff,f.l= 0xffffffff;
1014
g.h= 0x400000,g.l= 2;
1015
}
1016
 
1017
/*:57*/
1018
#line 1023 "./mmix-arith.w"
1019
 
1020
else{
1021
g= incr(f,1);
1022
f= incr(f,-1);
1023
if(!e)e= 1;
1024
else if(e==0x7ff){
1025
printf("NaN");
1026
if(g.h==0x100000&&g.l==1)return;
1027
e= 0x3ff;
1028
}else f.h|= 0x200000,g.h|= 0x200000;
1029
}
1030
 
1031
/*:55*/
1032
#line 983 "./mmix-arith.w"
1033
;
1034
/*63:*/
1035
#line 1195 "./mmix-arith.w"
1036
 
1037
k= (magic_offset-e)/28;
1038
ff.dat[k-1]= shift_right(f,magic_offset+28-e-28*k,1).l&0xfffffff;
1039
gg.dat[k-1]= shift_right(g,magic_offset+28-e-28*k,1).l&0xfffffff;
1040
ff.dat[k]= shift_right(f,magic_offset-e-28*k,1).l&0xfffffff;
1041
gg.dat[k]= shift_right(g,magic_offset-e-28*k,1).l&0xfffffff;
1042
ff.dat[k+1]= shift_left(f,e+28*k-(magic_offset-28)).l&0xfffffff;
1043
gg.dat[k+1]= shift_left(g,e+28*k-(magic_offset-28)).l&0xfffffff;
1044
ff.a= (ff.dat[k-1]?k-1:k);
1045
ff.b= (ff.dat[k+1]?k+1:k);
1046
gg.a= (gg.dat[k-1]?k-1:k);
1047
gg.b= (gg.dat[k+1]?k+1:k);
1048
 
1049
/*:63*/
1050
#line 984 "./mmix-arith.w"
1051
;
1052
/*64:*/
1053
#line 1223 "./mmix-arith.w"
1054
 
1055
if(e> 0x401)/*65:*/
1056
#line 1254 "./mmix-arith.w"
1057
 
1058
{register int open= x.l&1;
1059
tt.dat[origin]= 10;
1060
tt.a= tt.b= origin;
1061
for(e= 1;bignum_compare(&gg,&tt)>=open;e++)
1062
bignum_times_ten(&tt);
1063
p= s;
1064
while(1){
1065
bignum_times_ten(&ff);
1066
bignum_times_ten(&gg);
1067
for(j= '0';bignum_compare(&ff,&tt)>=0;j++)
1068
bignum_dec(&ff,&tt,0x10000000),bignum_dec(&gg,&tt,0x10000000);
1069
if(bignum_compare(&gg,&tt)>=open)break;
1070
*p++= j;
1071
if(ff.a==bignum_prec-1&&!open)
1072
goto done;
1073
}
1074
for(k= j;bignum_compare(&gg,&tt)>=open;k++)bignum_dec(&gg,&tt,0x10000000);
1075
*p++= (j+1+k)>>1;
1076
done:;
1077
}
1078
 
1079
/*:65*/
1080
#line 1224 "./mmix-arith.w"
1081
 
1082
else{
1083
if(ff.a> origin)ff.dat[origin]= 0;
1084
for(e= 1,p= s;gg.a> origin||ff.dat[origin]==gg.dat[origin];){
1085
if(gg.a> origin)e--;
1086
else*p++= ff.dat[origin]+'0',ff.dat[origin]= 0,gg.dat[origin]= 0;
1087
bignum_times_ten(&ff);
1088
bignum_times_ten(&gg);
1089
}
1090
*p++= ((ff.dat[origin]+1+gg.dat[origin])>>1)+'0';
1091
}
1092
*p= '\0';
1093
 
1094
/*:64*/
1095
#line 985 "./mmix-arith.w"
1096
;
1097
/*67:*/
1098
#line 1296 "./mmix-arith.w"
1099
 
1100
if(e> 17||e<(int)strlen(s)-17)
1101
printf("%c%s%se%d",s[0],(s[1]?".":""),s+1,e-1);
1102
else if(e<0)printf(".%0*d%s",-e,0,s);
1103
else if(strlen(s)>=e)printf("%.*s.%s",e,s,s+e);
1104
else printf("%s%0*d.",s,e-(int)strlen(s),0);
1105
 
1106
/*:67*/
1107
#line 986 "./mmix-arith.w"
1108
;
1109
}
1110
 
1111
/*:54*//*60:*/
1112
#line 1120 "./mmix-arith.w"
1113
 
1114
static void bignum_times_ten(f)
1115
bignum*f;
1116
{
1117
register tetra*p,*q;register tetra x,carry;
1118
for(p= &f->dat[f->b],q= &f->dat[f->a],carry= 0;p>=q;p--){
1119
x= *p*10+carry;
1120
*p= x&0xfffffff;
1121
carry= x>>28;
1122
}
1123
*p= carry;
1124
if(carry)f->a--;
1125
if(f->dat[f->b]==0&&f->b> f->a)f->b--;
1126
}
1127
 
1128
/*:60*//*61:*/
1129
#line 1138 "./mmix-arith.w"
1130
 
1131
static int bignum_compare(f,g)
1132
bignum*f,*g;
1133
{
1134
register tetra*p,*pp,*q,*qq;
1135
if(f->a!=g->a)return f->a> g->a?-1:1;
1136
pp= &f->dat[f->b],qq= &g->dat[g->b];
1137
for(p= &f->dat[f->a],q= &g->dat[g->a];p<=pp;p++,q++){
1138
if(*p!=*q)return*p<*q?-1:1;
1139
if(q==qq)return p<pp;
1140
}
1141
return-1;
1142
}
1143
 
1144
/*:61*//*62:*/
1145
#line 1155 "./mmix-arith.w"
1146
 
1147
static void bignum_dec(f,g,r)
1148
bignum*f,*g;
1149
tetra r;
1150
{
1151
register tetra*p,*q,*qq;
1152
register int x,borrow;
1153
while(g->b> f->b)f->dat[++f->b]= 0;
1154
qq= &g->dat[g->a];
1155
for(p= &f->dat[g->b],q= &g->dat[g->b],borrow= 0;q>=qq;p--,q--){
1156
x= *p-*q-borrow;
1157
if(x>=0)borrow= 0,*p= x;
1158
else borrow= 1,*p= x+r;
1159
}
1160
for(;borrow;p--)
1161
if(*p)borrow= 0,*p= *p-1;
1162
else*p= r-1;
1163
while(f->dat[f->a]==0){
1164
if(f->a==f->b){
1165
f->a= f->b= bignum_prec-1,f->dat[bignum_prec-1]= 0;
1166
return;
1167
}
1168
f->a++;
1169
}
1170
while(f->dat[f->b]==0)f->b--;
1171
}
1172
 
1173
/*:62*//*68:*/
1174
#line 1340 "./mmix-arith.w"
1175
 
1176
static void bignum_double ARGS((bignum*));
1177
int scan_const ARGS((char*));
1178
int scan_const(s)
1179
char*s;
1180
{
1181
/*70:*/
1182
#line 1363 "./mmix-arith.w"
1183
 
1184
register char*p,*q;
1185
register bool NaN;
1186
int sign;
1187
 
1188
/*:70*//*76:*/
1189
#line 1435 "./mmix-arith.w"
1190
 
1191
register char*dec_pt;
1192
register int exp;
1193
register int zeros;
1194
 
1195
/*:76*//*81:*/
1196
#line 1503 "./mmix-arith.w"
1197
 
1198
register int k,x;
1199
register char*pp;
1200
bignum ff,tt;
1201
 
1202
/*:81*/
1203
#line 1346 "./mmix-arith.w"
1204
;
1205
val.h= val.l= 0;
1206
p= s;
1207
if(*p=='+'||*p=='-')sign= *p++;else sign= '+';
1208
if(strncmp(p,"NaN",3)==0)NaN= true,p+= 3;
1209
else NaN= false;
1210
if((isdigit(*p)&&!NaN)||(*p=='.'&&isdigit(*(p+1))))
1211
/*73:*/
1212
#line 1396 "./mmix-arith.w"
1213
 
1214
{
1215
for(q= buf0,dec_pt= (char*)0;isdigit(*p);p++){
1216
val= oplus(val,shift_left(val,2));
1217
val= incr(shift_left(val,1),*p-'0');
1218
if(q> buf0||*p!='0')
1219
if(q<buf_max)*q++= *p;
1220
else if(*(q-1)=='0')*(q-1)= *p;
1221
}
1222
if(NaN)*q++= '1';
1223
if(*p=='.')/*74:*/
1224
#line 1415 "./mmix-arith.w"
1225
 
1226
{
1227
dec_pt= q;
1228
p++;
1229
for(zeros= 0;isdigit(*p);p++)
1230
if(*p=='0'&&q==buf0)zeros++;
1231
else if(q<buf_max)*q++= *p;
1232
else if(*(q-1)=='0')*(q-1)= *p;
1233
}
1234
 
1235
/*:74*/
1236
#line 1406 "./mmix-arith.w"
1237
;
1238
next_char= p;
1239
if(*p=='e'&&!NaN)/*77:*/
1240
#line 1447 "./mmix-arith.w"
1241
 
1242
{register char exp_sign;
1243
p++;
1244
if(*p=='+'||*p=='-')exp_sign= *p++;else exp_sign= '+';
1245
if(isdigit(*p)){
1246
for(exp= *p++-'0';isdigit(*p);p++)
1247
if(exp<1000)exp= 10*exp+*p-'0';
1248
if(!dec_pt)dec_pt= q,zeros= 0;
1249
if(exp_sign=='-')exp= -exp;
1250
next_char= p;
1251
}
1252
}
1253
 
1254
/*:77*/
1255
#line 1408 "./mmix-arith.w"
1256
 
1257
else exp= 0;
1258
if(dec_pt)/*78:*/
1259
#line 1460 "./mmix-arith.w"
1260
 
1261
{
1262
/*79:*/
1263
#line 1477 "./mmix-arith.w"
1264
 
1265
x= buf+341+zeros-dec_pt-exp;
1266
if(q==buf0||x>=1413){
1267
make_it_zero:exp= -99999;goto packit;
1268
}
1269
if(x<0){
1270
make_it_infinite:exp= 99999;goto packit;
1271
}
1272
ff.a= x/9;
1273
for(p= q;p<q+8;p++)*p= '0';
1274
q= q-1-(q+341+zeros-dec_pt-exp)%9;
1275
for(p= buf0-x%9,k= ff.a;p<=q&&k<=156;p+= 9,k++)
1276
/*80:*/
1277
#line 1497 "./mmix-arith.w"
1278
 
1279
{
1280
for(x= *p-'0',pp= p+1;pp<p+9;pp++)x= 10*x+*pp-'0';
1281
ff.dat[k]= x;
1282
}
1283
 
1284
/*:80*/
1285
#line 1490 "./mmix-arith.w"
1286
;
1287
ff.b= k-1;
1288
for(x= 0;p<=q;p+= 9)if(strncmp(p,"000000000",9)!=0)x= 1;
1289
ff.dat[156]+= x;
1290
 
1291
while(ff.dat[ff.b]==0)ff.b--;
1292
 
1293
/*:79*/
1294
#line 1462 "./mmix-arith.w"
1295
;
1296
/*83:*/
1297
#line 1526 "./mmix-arith.w"
1298
 
1299
val= zero_octa;
1300
if(ff.a> 36){
1301
for(exp= 0x3fe;ff.a> 36;exp--)bignum_double(&ff);
1302
for(k= 54;k;k--){
1303
if(ff.dat[36]){
1304
if(k>=32)val.h|= 1<<(k-32);else val.l|= 1<<k;
1305
ff.dat[36]= 0;
1306
if(ff.b==36)break;
1307
}
1308
bignum_double(&ff);
1309
}
1310
}else{
1311
tt.a= tt.b= 36,tt.dat[36]= 2;
1312
for(exp= 0x3fe;bignum_compare(&ff,&tt)>=0;exp++)bignum_double(&tt);
1313
for(k= 54;k;k--){
1314
bignum_double(&ff);
1315
if(bignum_compare(&ff,&tt)>=0){
1316
if(k>=32)val.h|= 1<<(k-32);else val.l|= 1<<k;
1317
bignum_dec(&ff,&tt,1000000000);
1318
if(ff.a==bignum_prec-1)break;
1319
}
1320
}
1321
}
1322
if(k==0)val.l|= 1;
1323
 
1324
/*:83*/
1325
#line 1463 "./mmix-arith.w"
1326
;
1327
packit:/*84:*/
1328
#line 1559 "./mmix-arith.w"
1329
 
1330
val= fpack(val,exp,sign,ROUND_NEAR);
1331
if(NaN){
1332
if((val.h&0x7fffffff)==0x40000000)val.h|= 0x7fffffff,val.l= 0xffffffff;
1333
else if((val.h&0x7fffffff)==0x3ff00000&&!val.l)val.h|= 0x40000000,val.l= 1;
1334
else val.h|= 0x40000000;
1335
}
1336
 
1337
/*:84*/
1338
#line 1464 "./mmix-arith.w"
1339
;
1340
return 1;
1341
}
1342
 
1343
/*:78*/
1344
#line 1410 "./mmix-arith.w"
1345
;
1346
if(sign=='-')val= ominus(zero_octa,val);
1347
return 0;
1348
}
1349
 
1350
/*:73*/
1351
#line 1353 "./mmix-arith.w"
1352
;
1353
if(NaN)/*71:*/
1354
#line 1368 "./mmix-arith.w"
1355
 
1356
{
1357
next_char= p;
1358
val.h= 0x600000,exp= 0x3fe;
1359
goto packit;
1360
}
1361
 
1362
/*:71*/
1363
#line 1354 "./mmix-arith.w"
1364
;
1365
if(strncmp(p,"Inf",3)==0)/*72:*/
1366
#line 1375 "./mmix-arith.w"
1367
 
1368
{
1369
next_char= p+3;
1370
goto make_it_infinite;
1371
}
1372
 
1373
/*:72*/
1374
#line 1355 "./mmix-arith.w"
1375
;
1376
no_const_found:next_char= s;return-1;
1377
}
1378
 
1379
/*:68*//*82:*/
1380
#line 1511 "./mmix-arith.w"
1381
 
1382
static void bignum_double(f)
1383
bignum*f;
1384
{
1385
register tetra*p,*q;register int x,carry;
1386
for(p= &f->dat[f->b],q= &f->dat[f->a],carry= 0;p>=q;p--){
1387
x= *p+*p+carry;
1388
if(x>=1000000000)carry= 1,*p= x-1000000000;
1389
else carry= 0,*p= x;
1390
}
1391
*p= carry;
1392
if(carry)f->a--;
1393
if(f->dat[f->b]==0&&f->b> f->a)f->b--;
1394
}
1395
 
1396
/*:82*//*85:*/
1397
#line 1575 "./mmix-arith.w"
1398
 
1399
int fcomp ARGS((octa,octa));
1400
int fcomp(y,z)
1401
octa y,z;
1402
{
1403
ftype yt,zt;
1404
int ye,ze;
1405
char ys,zs;
1406
octa yf,zf;
1407
register int x;
1408
yt= funpack(y,&yf,&ye,&ys);
1409
zt= funpack(z,&zf,&ze,&zs);
1410
switch(4*yt+zt){
1411
case 4*nan+nan:case 4*zro+nan:case 4*num+nan:case 4*inf+nan:
1412
case 4*nan+zro:case 4*nan+num:case 4*nan+inf:return 2;
1413
case 4*zro+zro:return 0;
1414
case 4*zro+num:case 4*num+zro:case 4*zro+inf:case 4*inf+zro:
1415
case 4*num+num:case 4*num+inf:case 4*inf+num:case 4*inf+inf:
1416
if(ys!=zs)x= 1;
1417
else if(y.h> z.h)x= 1;
1418
else if(y.h<z.h)x= -1;
1419
else if(y.l> z.l)x= 1;
1420
else if(y.l<z.l)x= -1;
1421
else return 0;
1422
break;
1423
}
1424
return(ys=='-'?-x:x);
1425
}
1426
 
1427
/*:85*//*86:*/
1428
#line 1608 "./mmix-arith.w"
1429
 
1430
octa fintegerize ARGS((octa,int));
1431
octa fintegerize(z,r)
1432
octa z;
1433
int r;
1434
{
1435
ftype zt;
1436
int ze;
1437
char zs;
1438
octa xf,zf;
1439
zt= funpack(z,&zf,&ze,&zs);
1440
if(!r)r= cur_round;
1441
switch(zt){
1442
case nan:if(!(z.h&0x80000)){exceptions|= I_BIT;z.h|= 0x80000;}
1443
case inf:case zro:return z;
1444
case num:/*87:*/
1445
#line 1627 "./mmix-arith.w"
1446
 
1447
if(ze>=1074)return fpack(zf,ze,zs,ROUND_OFF);
1448
if(ze<=1020)xf.h= 0,xf.l= 1;
1449
else{octa oo;
1450
xf= shift_right(zf,1074-ze,1);
1451
oo= shift_left(xf,1074-ze);
1452
if(oo.l!=zf.l||oo.h!=zf.h)xf.l|= 1;
1453
 
1454
}
1455
switch(r){
1456
case ROUND_DOWN:if(zs=='-')xf= incr(xf,3);break;
1457
case ROUND_UP:if(zs!='-')xf= incr(xf,3);
1458
case ROUND_OFF:break;
1459
case ROUND_NEAR:xf= incr(xf,xf.l&4?2:1);break;
1460
}
1461
xf.l&= 0xfffffffc;
1462
if(ze>=1022)return fpack(shift_left(xf,1074-ze),ze,zs,ROUND_OFF);
1463
if(xf.l)xf.h= 0x3ff00000,xf.l= 0;
1464
if(zs=='-')xf.h|= sign_bit;
1465
return xf;
1466
 
1467
/*:87*/
1468
#line 1623 "./mmix-arith.w"
1469
;
1470
}
1471
}
1472
 
1473
/*:86*//*88:*/
1474
#line 1650 "./mmix-arith.w"
1475
 
1476
octa fixit ARGS((octa,int));
1477
octa fixit(z,r)
1478
octa z;
1479
int r;
1480
{
1481
ftype zt;
1482
int ze;
1483
char zs;
1484
octa zf,o;
1485
zt= funpack(z,&zf,&ze,&zs);
1486
if(!r)r= cur_round;
1487
switch(zt){
1488
case nan:case inf:exceptions|= I_BIT;return z;
1489
case zro:return zero_octa;
1490
case num:if(funpack(fintegerize(z,r),&zf,&ze,&zs)==zro)return zero_octa;
1491
if(ze<=1076)o= shift_right(zf,1076-ze,1);
1492
else{
1493
if(ze> 1085||(ze==1085&&(zf.h> 0x400000||
1494
(zf.h==0x400000&&(zf.l||zs!='-')))))exceptions|= W_BIT;
1495
if(ze>=1140)return zero_octa;
1496
o= shift_left(zf,ze-1076);
1497
}
1498
return(zs=='-'?ominus(zero_octa,o):o);
1499
}
1500
}
1501
 
1502
/*:88*//*89:*/
1503
#line 1681 "./mmix-arith.w"
1504
 
1505
octa floatit ARGS((octa,int,int,int));
1506
octa floatit(z,r,u,p)
1507
octa z;
1508
int r;
1509
int u;
1510
int p;
1511
{
1512
int e;char s;
1513
register int t;
1514
exceptions= 0;
1515
if(!z.h&&!z.l)return zero_octa;
1516
if(!r)r= cur_round;
1517
if(!u&&(z.h&sign_bit))s= '-',z= ominus(zero_octa,z);else s= '+';
1518
e= 1076;
1519
while(z.h<0x400000)e--,z= shift_left(z,1);
1520
while(z.h>=0x800000){
1521
e++;
1522
t= z.l&1;
1523
z= shift_right(z,1,1);
1524
z.l|= t;
1525
}
1526
if(p)/*90:*/
1527
#line 1707 "./mmix-arith.w"
1528
 
1529
{
1530
register int ex;register tetra t;
1531
t= sfpack(z,e,s,r);
1532
ex= exceptions;
1533
sfunpack(t,&z,&e,&s);
1534
exceptions= ex;
1535
}
1536
 
1537
/*:90*/
1538
#line 1703 "./mmix-arith.w"
1539
;
1540
return fpack(z,e,s,r);
1541
}
1542
 
1543
/*:89*//*91:*/
1544
#line 1718 "./mmix-arith.w"
1545
 
1546
octa froot ARGS((octa,int));
1547
octa froot(z,r)
1548
octa z;
1549
int r;
1550
{
1551
ftype zt;
1552
int ze;
1553
char zs;
1554
octa x,xf,rf,zf;
1555
register int xe,k;
1556
if(!r)r= cur_round;
1557
zt= funpack(z,&zf,&ze,&zs);
1558
if(zs=='-'&&zt!=zro)exceptions|= I_BIT,x= standard_NaN;
1559
else switch(zt){
1560
case nan:if(!(z.h&0x80000))exceptions|= I_BIT,z.h|= 0x80000;
1561
return z;
1562
case inf:case zro:x= z;break;
1563
case num:/*92:*/
1564
#line 1750 "./mmix-arith.w"
1565
 
1566
xf.h= 0,xf.l= 2;
1567
xe= (ze+0x3fe)>>1;
1568
if(ze&1)zf= shift_left(zf,1);
1569
rf.h= 0,rf.l= (zf.h>>22)-1;
1570
for(k= 53;k;k--){
1571
rf= shift_left(rf,2);xf= shift_left(xf,1);
1572
if(k>=43)rf= incr(rf,(zf.h>>(2*(k-43)))&3);
1573
else if(k>=27)rf= incr(rf,(zf.l>>(2*(k-27)))&3);
1574
if((rf.l> xf.l&&rf.h>=xf.h)||rf.h> xf.h){
1575
xf.l++;rf= ominus(rf,xf);xf.l++;
1576
}
1577
}
1578
if(rf.h||rf.l)xf.l++;
1579
return fpack(xf,xe,'+',r);
1580
 
1581
/*:92*/
1582
#line 1736 "./mmix-arith.w"
1583
;
1584
}
1585
if(zs=='-')x.h|= sign_bit;
1586
return x;
1587
}
1588
 
1589
/*:91*//*93:*/
1590
#line 1774 "./mmix-arith.w"
1591
 
1592
octa fremstep ARGS((octa,octa,int));
1593
octa fremstep(y,z,delta)
1594
octa y,z;
1595
int delta;
1596
{
1597
ftype yt,zt;
1598
int ye,ze;
1599
char xs,ys,zs;
1600
octa x,xf,yf,zf;
1601
register int xe,thresh,odd;
1602
yt= funpack(y,&yf,&ye,&ys);
1603
zt= funpack(z,&zf,&ze,&zs);
1604
switch(4*yt+zt){
1605
/*42:*/
1606
#line 731 "./mmix-arith.w"
1607
 
1608
case 4*nan+nan:if(!(y.h&0x80000))exceptions|= I_BIT;
1609
case 4*zro+nan:case 4*num+nan:case 4*inf+nan:
1610
if(!(z.h&0x80000))exceptions|= I_BIT,z.h|= 0x80000;
1611
return z;
1612
case 4*nan+zro:case 4*nan+num:case 4*nan+inf:
1613
if(!(y.h&0x80000))exceptions|= I_BIT,y.h|= 0x80000;
1614
return y;
1615
 
1616
/*:42*/
1617
#line 1788 "./mmix-arith.w"
1618
;
1619
case 4*zro+zro:case 4*num+zro:case 4*inf+zro:
1620
case 4*inf+num:case 4*inf+inf:x= standard_NaN;
1621
exceptions|= I_BIT;break;
1622
case 4*zro+num:case 4*zro+inf:case 4*num+inf:return y;
1623
case 4*num+num:/*94:*/
1624
#line 1809 "./mmix-arith.w"
1625
 
1626
odd= 0;
1627
thresh= ye-delta;
1628
if(thresh<ze)thresh= ze;
1629
while(ye>=thresh)/*95:*/
1630
#line 1830 "./mmix-arith.w"
1631
 
1632
{
1633
if(yf.h==zf.h&&yf.l==zf.l)goto zero_out;
1634
if(yf.h<zf.h||(yf.h==zf.h&&yf.l<zf.l)){
1635
if(ye==ze)goto try_complement;
1636
ye--,yf= shift_left(yf,1);
1637
}
1638
yf= ominus(yf,zf);
1639
if(ye==ze)odd= 1;
1640
while(yf.h<0x400000)ye--,yf= shift_left(yf,1);
1641
}
1642
 
1643
/*:95*/
1644
#line 1815 "./mmix-arith.w"
1645
;
1646
if(ye>=ze){
1647
exceptions|= E_BIT;return fpack(yf,ye,ys,ROUND_OFF);
1648
}
1649
if(ye<ze-1)return fpack(yf,ye,ys,ROUND_OFF);
1650
yf= shift_right(yf,1,1);
1651
try_complement:xf= ominus(zf,yf),xe= ze,xs= '+'+'-'-ys;
1652
if(xf.h> yf.h||(xf.h==yf.h&&(xf.l> yf.l||(xf.l==yf.l&&!odd))))
1653
xf= yf,xs= ys;
1654
while(xf.h<0x400000)xe--,xf= shift_left(xf,1);
1655
return fpack(xf,xe,xs,ROUND_OFF);
1656
 
1657
/*:94*/
1658
#line 1793 "./mmix-arith.w"
1659
;
1660
zero_out:x= zero_octa;
1661
}
1662
if(ys=='-')x.h|= sign_bit;
1663
return x;
1664
}
1665
 
1666
/*:93*/
1667
#line 41 "./mmix-arith.w"
1668
 
1669
 
1670
/*:1*/

powered by: WebSVN 2.1.0

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