1 /* SYMMETRICA file:lo.c */
2 #include "def.h"
3 #include "macro.h"
4 #include <string.h> /*strcat */
5
6
7 #define EXP 15
8 #define LO_B 32768 /* 1000000000000000*/
9 #define BMINUSEINS 32767 /* 111111111111111*/
10 #define LO_B1 (INT)2147450880/*111111111111111000000000000000*/
11 #define B2MINUSEINS (INT)2147483647 /*1000000000000000000000000000000 - 1*/
12 #define Basis 45
13 #define MSB 16384
14 #define MAXNEG (INT)(-2147483647-1) /*1000000000000000000000000000000 */
15
16 #ifdef LONGINTTRUE
17 struct ganzdaten gd; /* a global datastructure */
18 static OP rl_o=NULL; /* obere grenze */
19 static OP rl_m=NULL; /* modulo */
20 static OP rl_x=NULL; /* ergebnis */
21 static OP rl_a=NULL; /* multiplier */
22
23
24 #endif
25
26 INT mult_longint_integer_via_ganzsmul();
27
28 static struct longint * calloclongint();
29 static INT longint_speicher_ende();
30
31 static INT nofolgezeichen=0;
32
set_lo_nopoint(para)33 INT set_lo_nopoint(para) INT para; { nofolgezeichen=para; }
34
35 static INT ganzadd();
36 static INT ganzanfang();
37 static INT ganzaus();
38 static INT ganzdefiniere();
39 static INT ganzein();
40 static INT ganzeven();
41 static INT ganzfziffer();
42 /* static INT ganzganzdiv(); */
43 /* static INT ganzhalf(); */
44 static INT ganzint();
45 static INT ganzkopiere();
46 /* static INT ganzloesche(); */
47 /* static INT ganzmod(); */
48 static INT ganzmul();
49 /* static INT ganzneg(); */
50 static INT ganzodd();
51 static INT ganzparam();
52 static INT ganzquores();
53 /* static INT ganzsignum(); */
54 static INT ganzsadd();
55 static INT ganzsmul();
56 static INT ganzsquores();
57 static INT ganzvergleich();
58 static INT ganz1ziffer();
59 static INT intganz();
60 static INT locadd();
61 static INT locdiv();
62 static INT lochole();
63 static INT locint();
64 static INT loclisterette();
65 static INT locms1();
66 /* static INT locmul(); */
67 static INT locneg();
68 /* static INT locnull(); */
69 static INT locodd();
70 static INT locrette();
71 static INT locrezliste();
72 static INT locpsl();
73 static INT locpsr();
74 static INT locsadd();
75 static INT locsdiv();
76 /* static INT locsgn(); */
77 static INT locsmul();
78 static INT locssub();
79 static INT locsub();
80 static INT locvgl();
81 static INT retteziffer();
82
83 struct loc **loc_speicher = NULL;
84 INT loc_index = -1;
85 INT loc_size = 0;
86 INT loc_counter = 0;
87
88 INT mem_counter_loc=0;
89 INT longint_speicherindex=-1; /* AK 301001 */
90 INT longint_speichersize=0; /* AK 301001 */
91 struct longint **longint_speicher=NULL; /* AK 301001 */
92
93
94 #define FREE_LONGINT(v)\
95 FREE_MEMMANAGER(struct longint *,longint_speicher,longint_speicherindex,\
96 longint_speichersize,mem_counter_loc,v)
97 #ifdef UNDEF
98 do {\
99 mem_counter_loc--;\
100 if (longint_speicherindex+1 == longint_speichersize) {\
101 if (longint_speichersize == 0) {\
102 longint_speicher = (struct longint **) \
103 SYM_MALLOC(100 * sizeof(struct longint *));\
104 SYMCHECK(longint_speicher == NULL,"no memory");\
105 longint_speichersize = 100;\
106 }\
107 else {\
108 longint_speicher = (struct longint **) SYM_realloc (longint_speicher,\
109 2 * longint_speichersize * sizeof(struct longint *));\
110 SYMCHECK(longint_speicher == NULL,"no memory");\
111 longint_speichersize = 2 * longint_speichersize;\
112 }\
113 }\
114 longint_speicher[++longint_speicherindex] = v;\
115 } while(0)
116 #endif
117
118
119
120 /* dieser Teil wurde von Peter Hain in Karlsruhe
121 entworfen. Er schrieb diese Langzahl arithmetik in Pascal und
122 Assembler. In Bayreuth wurden in Form eines Seminars die
123 Assemblerteile in C geschrieben und spaeter wurde von
124 Axel Kohnert die restlichen Pascalteile in C uebersetzt.
125 Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth
126 entworfen */
127
128 #ifdef LONGINTTRUE
locadd(lx,ly,cy)129 static INT locadd(lx,ly,cy) struct loc *lx,*ly; INT cy;
130 /* AK 130789 V1.0 */ /* AK 270390 V1.1 */ /* AK 210891 V1.3 */
131 {
132 static INT hh;
133 hh=ly->w0+cy+lx->w0;
134 lx->w0=(hh&BMINUSEINS);
135 cy = hh >>EXP;
136 hh=ly->w1+cy+lx->w1;
137 lx->w1=(hh&BMINUSEINS);
138 cy = hh >>EXP;
139 hh=ly->w2+cy+lx->w2;
140 lx->w2=(hh&BMINUSEINS);
141 cy = hh >>EXP;
142 return((INT)cy);
143 }
144 #endif /* LONGINTTRUE */
145
146 #define LOCADD(lx,ly,cy)\
147 hh=(ly)->w0+cy+(lx)->w0, (lx)->w0=(hh&BMINUSEINS), cy = hh >>EXP,\
148 hh=(ly)->w1+cy+(lx)->w1, (lx)->w1=(hh&BMINUSEINS), cy = hh >>EXP,\
149 hh=(ly)->w2+cy+(lx)->w2, (lx)->w2=(hh&BMINUSEINS), cy = hh >>EXP,cy
150
151
152 #define LOCBAS2() Basis
153
154
155 #define LOCASS(lx,ly) ((lx)->w2=(ly)->w2,(lx)->w1=(ly)->w1,(lx)->w0=(ly)->w0)
156
157 #ifdef LONGINTTRUE
locdiv(qu,rest,dd,dv)158 static INT locdiv(qu,rest,dd,dv) struct loc *qu,*rest,*dd,*dv;
159 /* Division. Bei Eingabe muss gelten: rest<dv. */
160 /* (qu,rest) := ((rest*LO_B+dd) DIV dv, (rest*LO_B+dd) MOD dv). */
161 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */
162 /* AK 210891 V1.3 */
163 {
164 INT d6,d5,d4,d3,d2,d1,
165 h6,h5,h4,h3,h2,h1,
166 m2,m1,m0;
167
168
169 /* d=rest*B+dd */
170 d6=rest->w2;
171 d5=rest->w1;
172 d4=rest->w0;
173 d3=dd->w2;
174 d2=dd->w1;
175 d1=dd->w0;
176
177 /* h=dv */
178 h6=0;
179 h5=0;
180 h4=0;
181 h3=dv->w2;
182 h2=dv->w1;
183 h1=dv->w0;
184
185 /* qu=0 */
186 qu->w2=0;
187 qu->w1=0;
188 qu->w0=0;
189
190 /* m=1 */
191 m2=0;
192 m1=0;
193 m0=1;
194
195 while /* h<=d */
196 (
197 /* alt
198 h6 <d6 ||
199 (h6==d6 && h5<d5 ) ||
200 (h6==d6 && h5==d5 && h4<d4 ) ||
201 (h6==d6 && h5==d5 && h4==d4 && h3<d3 ) ||
202 (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2<d2 ) ||
203 (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2==d2 && h1<d1 ) ||
204 (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2==d2 && h1==d1 )
205 */
206 h6 < d6
207 ||
208 (h6 == d6 && (
209 h5 < d5 ||
210 (h5 == d5 && (
211 h4 < d4 ||
212 (h4 == d4 && (
213 h3 < d3 ||
214 (h3 == d3 && (
215 h2 < d2 ||
216 (h2 == d2 && h1 <= d1)
217 )
218 ))
219 ))
220 ))
221 )
222 )
223 {
224 /* h=h*2 */
225 /* alt
226 h6=h6<<1;
227 h5=h5<<1;
228 h4=h4<<1;
229 h3=h3<<1;
230 h2=h2<<1;
231 h1=h1<<1;
232 */
233 h6 <<= 1;
234 h5 <<= 1;
235 h4 <<= 1;
236 h3 <<= 1;
237 h2 <<= 1;
238 h1 <<= 1;
239
240
241 if (h1&LO_B1) {h1&=BMINUSEINS; h2++; };
242 if (h2&LO_B1) {h2&=BMINUSEINS; h3++; };
243 if (h3&LO_B1) {h3&=BMINUSEINS; h4++; };
244 if (h4&LO_B1) {h4&=BMINUSEINS; h5++; };
245 if (h5&LO_B1) {h5&=BMINUSEINS; h6++; };
246
247 /* m=m*2 */
248 /*alt
249 m2=m2<<1;
250 m1=m1<<1;
251 m0=m0<<1;
252 */
253 m2 <<= 1;
254 m1 <<= 1;
255 m0 <<= 1;
256
257 if (m0&LO_B1) {m0&=BMINUSEINS; m1++; };
258 if (m1&LO_B1) {m1&=BMINUSEINS; m2++; };
259 }
260 while /* d>=dv */
261 (
262 /* alt
263 d6 >0 || d5>0 || d4>0 ||
264 (d6==0 && d5==0 && d4==0 && d3>dv->w2 ) ||
265 (d6==0 && d5==0 && d4==0 && d3==dv->w2 && d2>dv->w1 ) ||
266 (d6==0 && d5==0 && d4==0 && d3==dv->w2 && d2==dv->w1 && d1>dv->w0 ) ||
267 (d6==0 && d5==0 && d4==0 && d3==dv->w2 && d2==dv->w1 && d1==dv->w0 )
268 */
269 d6 >0 || d5>0 || d4>0 || (
270 d6==0 && d5==0 && d4==0 && ( d3>dv->w2 ||
271 (d3==dv->w2 && (
272 d2 > dv->w1 ||
273 (d2 ==dv->w1 && d1 >= dv->w0)
274 )
275 )
276 )
277 )
278 )
279 {
280 while /*h>d */
281 (
282 /* alt
283 h6 >d6 ||
284 (h6==d6 && h5>d5) ||
285 (h6==d6 && h5==d5 && h4>d4) ||
286 (h6==d6 && h5==d5 && h4==d4 && h3>d3) ||
287 (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2>d2) ||
288 (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2==d2 && h1>d1 )
289 */
290 h6 > d6
291 ||
292 (h6 == d6 && (
293 h5 > d5 ||
294 (h5 == d5 && (
295 h4 > d4 ||
296 (h4 == d4 && (
297 h3 > d3 ||
298 (h3 == d3 && (
299 h2 > d2 ||
300 (h2 == d2 && h1 > d1)
301 )
302 ))
303 ))
304 ))
305 )
306 )
307 {
308 /* h=h/2 */
309 if (h6&1) { h6--; h5=h5|LO_B; };
310 if (h5&1) { h5--; h4=h4|LO_B; };
311 if (h4&1) { h4--; h3=h3|LO_B; };
312 if (h3&1) { h3--; h2=h2|LO_B; };
313 if (h2&1) { h2--; h1=h1|LO_B; };
314
315 /* alt
316 h6=h6>>1;
317 h5=h5>>1;
318 h4=h4>>1;
319 h3=h3>>1;
320 h2=h2>>1;
321 h1=h1>>1;
322 */
323 h6 >>= 1;
324 h5 >>= 1;
325 h4 >>= 1;
326 h3 >>= 1;
327 h2 >>= 1;
328 h1 >>= 1;
329
330
331
332 /* m=m/2 */
333 if (m2&1) { m2--; m1|=LO_B; };
334 if (m1&1) { m1--; m0|=LO_B; };
335
336 /* alt
337 m2=m2>>1;
338 m1=m1>>1;
339 m0=m0>>1;
340 */
341 m2 >>= 1;
342 m1 >>= 1;
343 m0 >>= 1;
344
345 }
346
347 /* d=d-h */
348 if (h1>d1) { d1+=LO_B; d2--; }; d1-=h1;
349 if (h2>d2) { d2+=LO_B; d3--; }; d2-=h2;
350 if (h3>d3) { d3+=LO_B; d4--; }; d3-=h3;
351 if (h4>d4) { d4+=LO_B; d5--; }; d4-=h4;
352 if (h5>d5) { d5+=LO_B; d6--; }; d5-=h5;
353 d6-=h6;
354
355 /* qu=qu+m */
356 qu->w0|=m0; qu->w1|=m1; qu->w2|=m2;
357 }
358 rest->w2=d3; rest->w1=d2; rest->w0=d1;
359 return(OK);
360 }
361
362
363
locint(lx,i)364 static INT locint(lx,i) struct loc *lx; INT i;
365 /* Umwandlung Integer in loc: lx:=abs(i); locint:=sgn(i) */
366 /* AK 130789 V1.0 */ /* AK 150290 V1.1 */
367 /* AK 210891 V1.3 */
368 {
369 INT s;
370
371 if (i<(INT)0)
372 {
373 s=(INT)-1;
374 i=0-i;
375 }
376 else if (i>(INT)0)
377 s=(INT)1;
378 else
379 s=(INT)0;
380
381 lx->w0 = i;
382 lx->w0 &= BMINUSEINS;
383 lx->w1 = i>>EXP;
384 lx->w2 = lx->w1 >>EXP;
385 lx->w1 &= BMINUSEINS;
386 lx->w2 &= BMINUSEINS;
387 return(s);
388 }
389
390
391
392 #define LOCMAX(lx) ((lx)->w0=BMINUSEINS,\
393 (lx)->w1=BMINUSEINS,(lx)->w2=BMINUSEINS)
394
395
locms1(lx)396 static INT locms1(lx) struct loc *lx;
397 /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
398 {
399 INT j,c,cc;
400
401 c=Basis; cc=(INT)1;
402 for (j=(INT)14; (j >=(INT)0) && cc ; j--)
403 {
404 if ( lx->w2 & ( (INT)1 << j ))
405 cc=(INT)0;
406 c--;
407 }
408 if (cc)
409 for (j=(INT)14; (j >=(INT)0) && cc ; j--)
410 {
411 if ( lx->w1 & ( (INT)1 << j ))
412 cc=(INT)0;
413 c--;
414 }
415 if (cc)
416 for (j=(INT)14; (j >=(INT)0) && cc ; j--)
417 {
418 if ( lx->w0 & ( (INT)1 << j ))
419 cc=(INT)0;
420 c--;
421 }
422 if (cc)
423 {
424 fprintf(stderr, "cc=%" PRIINT " %" PRIINT " %" PRIINT " %" PRIINT " \n" ,cc,lx->w0,lx->w1,lx->w2);
425 error("internal error:LO7");
426 }
427 return(c);
428 }
429
430
431
432 #define teile(z) (hh=(z)>>EXP, (z) &= BMINUSEINS, hh)
433
434 #ifdef UNDEF
locmul(ly,lx,la,lb)435 static INT locmul(ly,lx,la,lb) struct loc *lx,*ly,*la,*lb;
436 /* AK 130789 V1.0 */ /* AK 260390 V1.1 */ /* AK 210891 V1.3 */
437 {
438 static INT hh;
439 /* AK 260390 */
440
441 lx->w0 = la->w0 * lb->w0;
442 lx->w1 = teile(lx->w0) + la->w1 * lb->w0;
443 lx->w2 = teile(lx->w1) + la->w2 * lb->w0;
444 ly->w0 = teile(lx->w2) ;
445 lx->w1 += la->w0 * lb->w1;
446 lx->w2 += teile(lx->w1) + la->w1 * lb->w1;
447 ly->w0 += teile(lx->w2) + la->w2 * lb->w1;
448 ly->w1 = teile(ly->w0) ;
449 lx->w2 += la->w0 * lb->w2;
450 ly->w0 += teile(lx->w2) + la->w1 * lb->w2;
451 ly->w1 += teile(ly->w0) + la->w2 * lb->w2;
452 ly->w2 = teile(ly->w1) ;
453 return OK;
454 }
455 #endif
456
457
458 #define LOCMUL(ly,lx,la,lb) /* hh ist noetig */\
459 (lx)->w0 = (la)->w0 * (lb)->w0,\
460 (lx)->w1 = teile((lx)->w0) + (la)->w1 * (lb)->w0,\
461 (lx)->w2 = teile((lx)->w1) + (la)->w2 * (lb)->w0,\
462 (ly)->w0 = teile((lx)->w2) ,\
463 (lx)->w1 += (la)->w0 * (lb)->w1,\
464 (lx)->w2 += teile((lx)->w1) + (la)->w1 * (lb)->w1,\
465 (ly)->w0 += teile((lx)->w2) + (la)->w2 * (lb)->w1,\
466 (ly)->w1 = teile((ly)->w0) ,\
467 (lx)->w2 += (la)->w0 * (lb)->w2,\
468 (ly)->w0 += teile((lx)->w2) + (la)->w1 * (lb)->w2,\
469 (ly)->w1 += teile((ly)->w0) + (la)->w2 * (lb)->w2,\
470 (ly)->w2 = teile((ly)->w1)
471
472
locneg(lx,cy)473 static INT locneg(lx,cy) struct loc *lx; INT cy;
474 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
475 {
476 if ((cy==0)&&(lx->w0==0)&&(lx->w1==0)&&(lx->w2==0))
477 {
478 return((INT)0);
479 }
480 else
481 {
482 lx->w0 ^= BMINUSEINS;
483 lx->w1 ^= BMINUSEINS;
484 lx->w2 ^= BMINUSEINS;
485 if (cy == 0 )
486 {
487 ++lx->w0;
488 if (lx->w0 & LO_B)
489 {
490 ++lx->w1;
491 lx->w0 &= BMINUSEINS;
492 if (lx->w1 & LO_B)
493 {
494 ++lx->w2;
495 lx->w1 &= BMINUSEINS;
496 }
497 }
498 }
499 return(1);
500 }
501 } /* locneg */
502
503
504
505 #ifdef UNDEF
locnull(lx)506 static INT locnull(lx) struct loc *lx;
507 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */
508 /* AK 210891 V1.3 */
509 {
510 lx->w2 =(INT)0; lx->w1 =(INT)0; lx->w0 =(INT)0;
511 return OK;
512 } /* Ende von locnull */
513 #endif
514
515
516
517
locodd(lx)518 static INT locodd(lx) struct loc *lx;
519 /*locodd:=lx ist ungerade */
520 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
521 {
522 return (INT) (lx->w0 & 1);
523 }
524
bit_longint(a,i)525 INT bit_longint(a,i) OP a; INT i;
526 /* AK 180902 */
527 /* return bit number i, i=0 lsb,
528 */
529 {
530 INT erg = OK;
531 CTO(LONGINT,"bit_longint(1)",a);
532 SYMCHECK(i<0,"bit_longint: neg index");
533 {
534 struct loc *x;
535 x = S_O_S(a).ob_longint->floc;
536 again:
537 if (x == NULL) return 0;
538 if (i>=45)
539 {
540 x = x->nloc;
541 i = i-45;
542 goto again;
543 }
544 if (i>=30)
545 {
546 i = i -30;
547 return (x->w2 >> i) & 1;
548 }
549 if (i>=15)
550 {
551 i = i -15;
552 return (x->w1 >> i) & 1;
553 }
554 if (i>=0)
555 {
556 return (x->w0 >> i) & 1;
557 }
558 }
559 ENDR("bit_longint");
560 }
561
locpsl(lx,ly,a)562 static INT locpsl(lx,ly,a) struct loc *lx,*ly; INT a;
563 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
564 {
565 INT s1,s2,s3,s4,s5,i;
566 static struct loc lyy;
567
568 if (a >= 30) {
569 lx->w2 = lx->w0;
570 lx->w1 = ly->w2;
571 lx->w0 = ly->w1;
572 lyy.w2 = ly->w0;
573 a = a - 30;
574 }
575 else if (a>=15) {
576 lx->w2 = lx->w1;
577 lx->w1 = lx->w0;
578 lx->w0 = ly->w2;
579 lyy.w2 = ly->w1;
580 a = a - 15;
581 }
582 else {
583 lyy.w2 = ly->w2;
584 }
585 /* lyy = *ly; */
586
587 if ( a >= Basis) error("internal error:LO8");
588 for (i=(INT)1; i <= a;i++)
589 {
590 s1= (lyy.w0 & MSB) >> 14;
591 s2= (lyy.w1 & MSB) >> 14;
592 s3= (lyy.w2 & MSB) >> 14;
593 s4= (lx->w0 & MSB) >> 14;
594 s5= (lx->w1 & MSB) >> 14;
595 lyy.w0 <<= 1;
596 lyy.w1 = (lyy.w1 << 1) | s1;
597 lyy.w2 = (lyy.w2 << 1) | s2;
598 lx->w0 = (lx->w0 << 1) | s3;
599 lx->w1 = (lx->w1 << 1) | s4;
600 lx->w2 = (lx->w2 << 1) | s5;
601 }
602 lx->w0 &= BMINUSEINS;
603 lx->w1 &= BMINUSEINS;
604 lx->w2 &= BMINUSEINS;
605 return OK;
606 } /* Ende von locpsl */
607
608
609
locpsr(lx,ly,a)610 static INT locpsr(lx,ly,a) struct loc *lx,*ly; INT a;
611 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
612 {
613 INT s1,s2,s3,s4,s5,i;
614 static struct loc lxx;
615
616 if (a >= 30) {
617 ly->w0 = ly->w2;
618 ly->w1 = lx->w0;
619 ly->w2 = lx->w1;
620 lxx.w0 = lx->w2;
621 a = a -30;
622 }
623 else if (a >= 15) {
624 ly->w0 = ly->w1;
625 ly->w1 = ly->w2;
626 ly->w2 = lx->w0;
627 lxx.w0 = lx->w1;
628 a = a -15;
629 }
630 else {
631 lxx.w0 = lx->w0;
632 }
633
634 /* lxx = *lx; */
635
636
637 if ( a >= Basis) error("internal error:LO9");
638 for (i=(INT)1; i <= a;i++)
639 {
640 s1= (ly->w1 & 1) << 14;
641 s2= (ly->w2 & 1) << 14;
642 s3= (lxx.w0 & 1) << 14;
643 s4= (lxx.w1 & 1) << 14;
644 s5= (lxx.w2 & 1) << 14;
645 ly->w0 = (ly->w0 >> 1) | s1;
646 ly->w1 = (ly->w1 >> 1) | s2;
647 ly->w2 = (ly->w2 >> 1) | s3;
648 lxx.w0 = (lxx.w0 >> 1) | s4;
649 lxx.w1 = (lxx.w1 >> 1) | s5;
650 lxx.w2 = (lxx.w2 >> 1);
651 }
652 return OK;
653 } /* Ende von locpsr */
654
655
656
locsadd(lx,i)657 static INT locsadd(lx,i) struct loc *lx; INT i;
658 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
659 {
660 INT cy,hh;
661 if (i<(INT)0) i=(-i);
662 hh=lx->w0+(i%LO_B);
663 lx->w0=(hh & BMINUSEINS);
664 cy = hh >>EXP;
665 hh=lx->w1+(i/LO_B)+cy;
666 lx->w1=(hh & BMINUSEINS);
667 cy = hh >>EXP;
668 hh=lx->w2+cy;
669 lx->w2=(hh & BMINUSEINS);
670 cy = hh >>EXP;
671 return(cy);
672 }
673
674
675
locsdiv(qu,di,dd,dv)676 static INT locsdiv(qu,di,dd,dv) struct loc *qu,*dd; INT di,dv;
677 /* Division. Bei Eingabe muss gelten: di<dv. */
678 /* (locsdiv,qu) := ((di*B+dd) MOD dv, (di*B+dd) DIV dv). */
679 /* AK 130789 V1.0 */ /* AK 030790 V1.1 */ /* AK 210891 V1.3 */
680 {
681 INT d6,d5,d4,d3,d2,d1,
682 h6,h5,h4,h3,h2,h1,
683 m2,m1,m0,
684 dv2,dv1,dv0;
685
686 /* di umwandeln */
687 if (di<(INT)0)
688 return error("internal error:LO10");
689 d4=di & BMINUSEINS;
690 d5=(di & LO_B1)>>EXP;
691 d6=(d5 & LO_B1)>>EXP;
692 d5 &= BMINUSEINS;
693
694 /* dv umwandeln */
695 if (dv<(INT)0)
696 return error("internal error:LO11");
697 dv0=dv & BMINUSEINS;
698 dv1=(dv & LO_B1)>>EXP;
699 dv2=(dv1 & LO_B1)>>EXP;
700 dv1 &= BMINUSEINS;
701
702 /* d=di*B+dd */
703 d3=dd->w2;
704 d2=dd->w1;
705 d1=dd->w0;
706
707 /* h=dv */
708 h6=0;
709 h5=0;
710 h4=0;
711 h3=dv2;
712 h2=dv1;
713 h1=dv0;
714
715 /* qu=0 */
716 qu->w2=0;
717 qu->w1=0;
718 qu->w0=0;
719
720 /* m=1 */
721 m2=0;
722 m1=0;
723 m0=1;
724
725 while /* h<=d */
726 (
727 /* alt
728 h6 <d6 ||
729 (h6==d6 && h5<d5 ) ||
730 (h6==d6 && h5==d5 && h4<d4 ) ||
731 (h6==d6 && h5==d5 && h4==d4 && h3<d3 ) ||
732 (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2<d2 ) ||
733 (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2==d2 && h1<d1 ) ||
734 (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2==d2 && h1==d1)
735 */
736 h6 < d6
737 ||
738 (h6 == d6 && (
739 h5 < d5 ||
740 (h5 == d5 && (
741 h4 < d4 ||
742 (h4 == d4 && (
743 h3 < d3 ||
744 (h3 == d3 && (
745 h2 < d2 ||
746 (h2 == d2 && h1 <= d1)
747 )
748 ))
749 ))
750 ))
751 )
752 )
753 {
754 /* h=h*2 */
755
756 h6 <<= 1;
757 h5 <<= 1;
758 h4 <<= 1;
759 h3 <<= 1;
760 h2 <<= 1;
761 h1 <<= 1;
762
763 if (h1&LO_B1) {h1&=BMINUSEINS; h2++; };
764 if (h2&LO_B1) {h2&=BMINUSEINS; h3++; };
765 if (h3&LO_B1) {h3&=BMINUSEINS; h4++; };
766 if (h4&LO_B1) {h4&=BMINUSEINS; h5++; };
767 if (h5&LO_B1) {h5&=BMINUSEINS; h6++; };
768
769 /* m=m*2 */
770 m2 <<= 1;
771 m1 <<= 1;
772 m0 <<= 1;
773
774 if (m0&LO_B1) {m0&=BMINUSEINS; m1++; };
775 if (m1&LO_B1) {m1&=BMINUSEINS; m2++; };
776 }
777
778 while /* d>=dv */
779 (
780 /* alt
781 d6 >0 || d5>0 || d4>0 ||
782 (d6==0 && d5==0 && d4==0 && d3>dv2 ) ||
783 (d6==0 && d5==0 && d4==0 && d3==dv2 && d2>dv1 ) ||
784 (d6==0 && d5==0 && d4==0 && d3==dv2 && d2==dv1 && d1>dv0 ) ||
785 (d6==0 && d5==0 && d4==0 && d3==dv2 && d2==dv1 && d1==dv0 )
786 */
787 d6 >0 || d5>0 || d4>0 || (
788 d6==0 && d5==0 && d4==0 && ( d3>dv2 ||
789 (d3==dv2 && (
790 d2 > dv1 ||
791 (d2 ==dv1 && d1 >= dv0)
792 )
793 )
794 )
795 )
796 )
797 {
798 while /* h>d */
799 (
800 /* alt
801 h6 >d6 ||
802 (h6==d6 && h5>d5) ||
803 (h6==d6 && h5==d5 && h4>d4) ||
804 (h6==d6 && h5==d5 && h4==d4 && h3>d3) ||
805 (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2>d2) ||
806 (h6==d6 && h5==d5 && h4==d4 && h3==d3 && h2==d2 && h1>d1 )
807 */
808 h6 > d6
809 ||
810 (h6 == d6 && (
811 h5 > d5 ||
812 (h5 == d5 && (
813 h4 > d4 ||
814 (h4 == d4 && (
815 h3 > d3 ||
816 (h3 == d3 && (
817 h2 > d2 ||
818 (h2 == d2 && h1 > d1)
819 )
820 ))
821 ))
822 ))
823 ))
824 {
825 /* h=h/2 */
826 if (h6&1) { h6--; h5|=LO_B; };
827 if (h5&1) { h5--; h4|=LO_B; };
828 if (h4&1) { h4--; h3|=LO_B; };
829 if (h3&1) { h3--; h2|=LO_B; };
830 if (h2&1) { h2--; h1|=LO_B; };
831
832 h6 >>= 1;
833 h5 >>= 1;
834 h4 >>= 1;
835 h3 >>= 1;
836 h2 >>= 1;
837 h1 >>= 1;
838
839 /* m=m/2 */
840 if (m2&1) { m2--; m1|=LO_B; };
841 if (m1&1) { m1--; m0|=LO_B; };
842
843 m2 >>= 1;
844 m1 >>= 1;
845 m0 >>= 1;
846 }
847
848 /* d=d-h */
849 if (h1>d1) { d1+=LO_B; d2--; }; d1-=h1;
850 if (h2>d2) { d2+=LO_B; d3--; }; d2-=h2;
851 if (h3>d3) { d3+=LO_B; d4--; }; d3-=h3;
852 if (h4>d4) { d4+=LO_B; d5--; }; d4-=h4;
853 if (h5>d5) { d5+=LO_B; d6--; }; d5-=h5;
854 d6-=h6;
855
856 /* qu=qu+m */
857 qu->w0|=m0; qu->w1|=m1; qu->w2|=m2;
858 }
859
860 d3=d3<<EXP|d2;
861 d3=d3<<EXP|d1;
862 return(d3);
863 }
864
865
866
867 #ifdef UNDEF
locsgn(lx)868 static INT locsgn(lx) struct loc *lx;
869 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
870 {
871 if (lx->w2 || lx->w1 || lx->w0 )
872 return (INT) 1;
873 else return (INT) 0;
874 } /* Ende locsgn */
875 #endif
876
877
878
locsmul(lx,i,ue)879 static INT locsmul(lx,i,ue) struct loc *lx; INT i,ue;
880 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
881 /* AK 040398 V2.0 */
882 {
883 INT cy,h0,h1,h2,i0,i1,i2,u0,u1,u2;
884
885 if (i<0) {i=~i;++i;}
886 if (ue<0) {ue=~ue;++ue;}
887
888 i0 = i;
889 i0 &= BMINUSEINS;
890 i1 = (i>>15);
891 i1 &= BMINUSEINS;
892 i2 = (i>>30);
893 i2 &= BMINUSEINS;
894
895 u0 = ue;
896 u0 &= BMINUSEINS;
897 u1 = (ue>>15);
898 u1 &= BMINUSEINS;
899 u2 = (ue>>30);
900 u2 &= BMINUSEINS;
901
902
903 h0=(lx->w0)*i0;
904 h0 += u0;
905 cy = (h0 >> 15);
906 h0 &= BMINUSEINS;
907
908 h1 = (lx->w0)*i1;
909 h1 += (lx->w1)*i0;
910 h1 += cy;
911 h1 += u1;
912 cy = (h1 >> 15);
913 h1 &= BMINUSEINS;
914
915 h2 = (lx->w0)*i2;
916 h2 += (lx->w1)*i1;
917 h2 += (lx->w2)*i0;
918 h2 += cy;
919 h2 += u2;
920 cy = (h2 >> 15);
921 h2 &= BMINUSEINS;
922
923 cy += (lx->w1)*i2;
924 cy += (lx->w2)*i1;
925 cy += (((lx->w2)*i2)<<15);
926
927 lx->w0 = h0 ;
928 lx->w1 = h1 ;
929 lx->w2 = h2 ;
930
931
932 return(cy);
933 }
934
935
936
locssub(lx,i)937 static INT locssub(lx,i) struct loc *lx; INT i;
938 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
939 /* AK 040398 V2.0 */
940 {
941 INT cy;
942 if (i<0) i=(-i);
943 lx->w0 -= (i%LO_B);
944 if (lx->w0 < 0) {
945 lx->w0 += LO_B;
946 cy = (INT)1;
947 }
948 else cy =(INT)0;
949 lx->w1=lx->w1-((i/LO_B)%LO_B)-cy;
950 if (lx->w1 < 0) {
951 lx->w1 += LO_B;
952 cy = (INT)1;
953 }
954 else cy =(INT)0;
955 lx->w2=lx->w2-((i/LO_B)/LO_B) - cy;
956 if (lx->w2 < 0) {
957 lx->w2 += LO_B;
958 cy = (INT)1;
959 }
960 else cy = (INT)0;
961 return(cy);
962 }
963
964
965
locsub(lx,ly,cy)966 static INT locsub(lx,ly,cy) struct loc *lx,*ly; INT cy;
967 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
968 /* AK 040398 V2.0 */
969 {
970 lx->w0=lx->w0- ly->w0 -cy;
971 if (lx->w0 <(INT)0) { lx->w0 += LO_B;
972 cy = (INT)1; }
973 else cy =(INT)0;
974 lx->w1=lx->w1- ly->w1- cy;
975 if (lx->w1 <(INT)0) { lx->w1 += LO_B;
976 cy = (INT)1; }
977 else cy =(INT)0;
978 lx->w2=lx->w2- ly->w2- cy;
979 if (lx->w2 <(INT)0) { lx->w2 += LO_B;
980 cy = (INT)1; }
981 else cy =(INT)0;
982 return(cy);
983 }
984
985 static INT locsub_cy;
986 #define LOCSUB(lx,ly,cy) \
987 (lx->w0 -= ly->w0 , lx->w0 -= cy ,\
988 locsub_cy = (lx->w0 < 0 ? lx->w0 += LO_B, 1 : 0 ),\
989 lx->w1 -= ly->w1 , lx->w1 -= locsub_cy,\
990 locsub_cy = (lx->w1 < 0 ? lx->w1 += LO_B, 1 : 0 ),\
991 lx->w2 -= ly->w2 , lx->w2 -= locsub_cy,\
992 locsub_cy = (lx->w2 < 0 ? lx->w2 += LO_B, 1 : 0 )\
993 )
994
locvgl(lx,ly)995 static INT locvgl(lx,ly) struct loc *lx,*ly;
996 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
997 /* AK 040398 V2.0 */
998 {
999 if (lx->w2 > ly->w2) return((INT)1);
1000 else if (lx->w2 < ly->w2 ) return (INT)-1;
1001 else if (lx->w1 > ly->w1) return((INT)1);
1002 else if (lx->w1 < ly->w1) return (INT)-1;
1003 else if (lx->w0 > ly->w0) return((INT)1);
1004 else if (lx->w0 < ly->w0) return (INT)-1;
1005 else return((INT)0);
1006 } /* Ende locvgl */
1007
1008
1009
ganzadd(x,y)1010 static INT ganzadd(x,y) struct longint *x,*y;
1011 /* AK: Fri Jan 13 07:24:17 MEZ 1989 */
1012 /* dieser Teil wurde von Peter Hain in Karlsruhe
1013 entworfen. Er schrieb diese Langzahl arithmetik in Pascal und
1014 Assembler. In Bayreuth wurden in Form eines Seminars die
1015 Assemblerteile in C geschrieben und spaeter wurde von
1016 Axel Kohnert die restlichen Pascalteile in C uebersetzt.
1017 Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth
1018 entworfen */
1019 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
1020 /* AK 040398 V2.0 */
1021 {
1022 INT erg =OK;
1023 struct loc *alocx, *alocy, *lloc, *plocx, *plocy;
1024 INT cy,xl,ll;
1025 signed char xs,ys;
1026 INT hh; /* fuer LOCADD */
1027
1028 xs = x->signum;
1029 ys = y->signum;
1030 xl = x->laenge;
1031 if (((xs>=(signed char)0) && (ys>=(signed char)0)) ||
1032 ((xs<(signed char)0) && (ys<(signed char)0)))
1033 { alocx = x->floc; alocy = y->floc; cy = 0;
1034 do {
1035 cy = LOCADD(alocx,alocy,cy);
1036 plocx = alocx;
1037 plocy = alocy;
1038 alocx = alocx->nloc;
1039 alocy = alocy->nloc;
1040 }
1041 while ((alocx != NULL) && (alocy != NULL));
1042
1043 /* fuege rest an */
1044 if (alocy != NULL)
1045 { do
1046 {
1047 LOCHOLE(&alocx);
1048 plocx->nloc = alocx;
1049 xl++; cy = LOCADD(alocx,alocy,cy);
1050 plocx = alocx;
1051 alocx = NULL;
1052 plocy = alocy;
1053 alocy = alocy->nloc;
1054 }
1055 while (alocy != NULL);
1056 }
1057 else { while ((alocx != NULL) && (cy != 0))
1058 { cy = locsadd(alocx,cy); plocx = alocx;
1059 alocx = alocx->nloc; }
1060 }
1061
1062 /* noch ein cy? */
1063 if (cy != 0)
1064 { LOCHOLE(&alocx);
1065 plocx->nloc = alocx; locint(alocx,cy); xl++; }
1066 if (xs == 0) xs = ys;
1067 } /* end of first if */
1068 else {
1069 alocx = x->floc; alocy = y->floc; cy = 0;
1070 /* subtract y from x */
1071 do { cy = LOCSUB(alocx,alocy,cy); plocx = alocx;
1072 alocx = alocx->nloc; plocy = alocy; alocy = alocy->nloc;
1073 }
1074 while ((alocx != NULL) && (alocy != NULL));
1075
1076 /* append the remaining part */
1077 if (alocy != NULL)
1078 {
1079 do { LOCHOLE(&alocx); plocx->nloc = alocx; xl++;
1080 cy = LOCSUB(alocx,alocy,cy); plocx = alocx;
1081 alocx = NULL;plocy = alocy;alocy = alocy->nloc;
1082 }
1083 while (alocy != NULL);
1084 }
1085 else {
1086 while ((alocx != NULL) && (cy != 0))
1087 {
1088 cy = locssub(alocx,cy);
1089 plocx = alocx;
1090 alocx = alocx->nloc;
1091 }
1092 };
1093
1094 /* normieren von x */
1095 if (cy != 0)
1096 {
1097 alocx = x->floc; lloc = NULL; ll = 1; cy = 0;
1098 do { cy = locneg(alocx,cy);
1099 if (LOCSGN(alocx) != 0)
1100 { lloc = alocx; xl = ll; }
1101 alocx = alocx->nloc; ll++;
1102 }
1103 while (alocx != NULL);
1104 loclisterette(&(lloc->nloc)); xs = -xs;
1105 if (xs == 0) xs = -1;
1106 }
1107 else {
1108 alocx = x->floc; lloc = NULL; ll = 1;
1109 do {
1110 if (LOCSGN(alocx) != 0)
1111 { lloc = alocx; xl = ll; }
1112 alocx = alocx->nloc; ll++;
1113 }
1114 while (alocx != NULL);
1115 if (lloc == NULL)
1116 /* das ergebnis der addition ist null */
1117 { loclisterette(&(x->floc->nloc));
1118 xs = 0; xl =1; }
1119 else loclisterette(&(lloc->nloc));
1120 }
1121 }
1122 x->laenge = xl; x->signum = xs;
1123 ENDR("ganzadd");
1124 }
1125
1126
1127
ganzsquores(x,rest,y)1128 static INT ganzsquores(x,rest,y) struct longint *x; INT *rest,y;
1129 /* AK Tue Jan 31 07:48:38 MEZ 1989 */
1130 /* dieser Teil wurde von Peter Hain in Karlsruhe
1131 entworfen. Er schrieb diese Langzahl arithmetik in Pascal und
1132 Assembler. In Bayreuth wurden in Form eines Seminars die
1133 Assemblerteile in C geschrieben und spaeter wurde von
1134 Axel Kohnert die restlichen Pascalteile in C uebersetzt.
1135 Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth
1136 entworfen */
1137 /* AK 130789 V1.0 */ /* AK 200290 V1.1 */ /* AK 210891 V1.3 */
1138 {
1139
1140 struct loc *alocx, *blocx, *slocx;
1141 INT r;
1142 signed char sx,sy;
1143
1144 sx = x->signum;
1145 if (y>(INT)0) sy=(signed char)1;
1146 else if (y<(INT)0) sy = (signed char)-1;
1147 else sy=(signed char)0;
1148 if (y<(INT)0) y = -y;
1149 blocx = x->floc; x->floc = NULL; locrezliste(&blocx);
1150 alocx = blocx; slocx = alocx->nloc; r=(INT)0;
1151 while (slocx != NULL)
1152 {
1153 r = locsdiv(alocx,r,alocx,y);
1154 alocx = slocx;
1155 slocx = alocx->nloc;
1156 }
1157
1158
1159 r = locsdiv(alocx,r,alocx,y);
1160 *rest = r * sx;
1161 if (LOCSGN(blocx) !=(INT)0) x->signum = sx*sy;
1162 else if (x->laenge == (INT)1) x->signum = (signed char)0;
1163 else {
1164 alocx = blocx;
1165 blocx = blocx->nloc;
1166 alocx->nloc = NULL;
1167 locrette(&alocx);
1168 x->laenge --;
1169 x->signum = sx*sy;
1170 };
1171
1172 locrezliste(&blocx);
1173 x->floc = blocx;
1174 return(OK);
1175 }
1176
1177
1178
1179 #ifdef UNDEF
ganzhalf(x)1180 static INT ganzhalf(x) struct longint *x;
1181 /* AK 021294 */
1182 {
1183 struct loc *alocx, *plocx;
1184 INT erg = OK;
1185 alocx = x->floc;
1186 plocx = NULL;
1187 while (alocx != NULL)
1188 {
1189 alocx->w0 >>= 1;
1190 alocx->w0 |= ( (alocx->w1 & 1) << 14);
1191 alocx->w1 >>= 1;
1192 alocx->w1 |= ( (alocx->w2 & 1) << 14);
1193 alocx->w2 >>= 1;
1194 if (alocx->nloc != NULL)
1195 alocx->w2 |= ( (alocx->nloc->w0 & 1) << 14);
1196 if (alocx->nloc == NULL)
1197 {
1198 if (plocx != NULL)
1199 if ((alocx->w0 == 0) &&
1200 (alocx->w1 == 0)&&
1201 (alocx->w2 == 0))
1202 {
1203 FREE_LOC(alocx);
1204 plocx->nloc = NULL;
1205 x->laenge --;
1206 goto ende;
1207 }
1208 }
1209
1210 plocx = alocx;
1211 alocx = alocx->nloc;
1212 }
1213 ende:
1214 ENDR("internal function:ganzhalf");
1215 }
1216 #endif
1217
ganzquores(x,rest,y)1218 static INT ganzquores(x,rest,y) struct longint *x, *rest, *y;
1219 /* AK Mon Mar 13 10:58:11 MEZ 1989 */
1220 /* dieser Teil wurde von Peter Hain in Karlsruhe
1221 entworfen. Er schrieb diese Langzahl arithmetik in Pascal und
1222 Assembler. In Bayreuth wurden in Form eines Seminars die
1223 Assemblerteile in C geschrieben und spaeter wurde von
1224 Axel Kohnert die restlichen Pascalteile in C uebersetzt.
1225 Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth
1226 entworfen */
1227 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
1228 /* x = x/y
1229 rest = rest */
1230 {
1231 INT vgl,cy,cyn,a,i,rl=(INT)0,ql;
1232 INT erg =OK;
1233 signed char sx,sy;
1234 struct loc *alocx, *plocx,*slocx,*blocx,*rlocx,*llocx,
1235 *alocy,*plocy,*blocy,*blocq,
1236 *locx2,*locx1,*locx0,*locy1,*locy0;
1237
1238 struct loc null,q,r,ov,hi,lo;
1239 INT fertig;
1240 INT hh; /* fuer LOCMUL */
1241
1242
1243 if ((x->floc == y->floc) || (x->floc == rest->floc) || (y->floc == rest->floc))
1244 error("internal error:LO1");
1245
1246 loclisterette(&rest->floc);
1247 sx = x->signum;
1248 sy = y->signum;
1249 if (y->laenge == (INT)1) /* einfache divison */
1250 {
1251 LOCNULL(&null);
1252 LOCASS(&lo,y->floc);
1253 blocx = x->floc;
1254 x->floc = NULL;
1255 locrezliste(&blocx);
1256 alocx = blocx;
1257 slocx = alocx->nloc;
1258 LOCASS(&r,&null);
1259 while (slocx != NULL)
1260 {
1261 locdiv(alocx,&r,alocx,&lo);
1262 alocx = slocx;
1263 slocx = slocx->nloc;
1264 }
1265 locdiv(alocx,&r,alocx,&lo);
1266
1267 if (LOCSGN(&r) ==(INT)0) rest->signum = (signed char)0;
1268 else rest->signum = sx;
1269 LOCHOLE(&rest->floc);
1270 LOCASS(rest->floc,&r);
1271 rest->laenge = (INT)1;
1272 if (LOCSGN(blocx) !=(INT)0) x->signum = sx * sy;
1273 else if (x->laenge == (INT)1) x->signum = (signed char)0;
1274 else { alocx = blocx; blocx = blocx->nloc; alocx->nloc = NULL;
1275 locrette(&alocx); x->laenge --; x->signum = sx * sy;
1276 }
1277 locrezliste(&blocx);
1278 x->floc = blocx;
1279 } /* ende der einfachen division */
1280 else if (x->laenge < y->laenge) /* trivial */
1281 {
1282 *rest = *x; x->floc = NULL; LOCHOLE(&x->floc);
1283 x->signum = (signed char)0; x->laenge = (INT)1;
1284 } /* ende des trivialfalles */
1285 else { /* normalfall x->laenge >= y->laenge >= 2 */
1286 /* lange division */
1287 LOCNULL(&null);
1288 blocy = y->floc;
1289 y->floc = NULL;
1290 locrezliste(&blocy);
1291 locy1 = blocy;
1292 locy0 = blocy->nloc;
1293 a = LOCBAS2() - (INT)1 - locms1(locy1);
1294 locx1 = x->floc; x->floc = NULL; locrezliste(&locx1);
1295 locx2 = NULL; LOCHOLE(&locx2); locx2->nloc = locx1;
1296 locx0 = locx1->nloc;
1297
1298 /* dividend und divisor normieren. dividend zerlegen */
1299 locpsl(locx2,locx1,a);
1300 alocy = locy0; plocy = locy1; alocx = locx0; plocx = locx1;
1301 do {
1302 locpsl(plocy,alocy,a);
1303 locpsl(plocx,alocx,a);
1304 plocy = alocy; alocy = alocy->nloc;
1305 plocx = alocx; alocx = alocx->nloc;
1306 }
1307 while (alocy != NULL);
1308 locpsl(plocy,&null,a);
1309
1310 llocx = plocx;
1311 rlocx = alocx;
1312
1313 while (alocx != NULL) /* rest des dividenden normieren */
1314 {
1315 locpsl(plocx,alocx,a);
1316 plocx = alocx; alocx = alocx->nloc;
1317 }
1318 locpsl(plocx,&null,a);
1319
1320 llocx->nloc = NULL; /* dividend getrennt */
1321
1322 /* listen fuer teildividend und divisor umkehren */
1323 blocx = locx2; locrezliste(&blocx); locrezliste(&blocy);
1324
1325 /* quotientenliste mit laenge */
1326 blocq = NULL; ql =(INT)0;
1327
1328 do { /* divisionsschritt */
1329 if (locvgl(locx2,locy1) ==(INT)0) LOCMAX(&q);
1330 else {
1331 LOCASS(&r,locx2);
1332 locdiv(&q,&r,locx1,locy1);
1333 LOCMUL(&hi,&lo,&q,locy0);
1334 /* falls (hi,lo) <= (r,locx0):fertig */
1335 vgl = locvgl(&hi,&r);
1336 if ((vgl >0) || ((vgl ==(INT)0) &&
1337 (locvgl(&lo,locx0) >(INT)0)))
1338 {
1339 locssub(&q,(INT)1);
1340 cy = locadd(&r,locy1,(INT)0);
1341 if (cy ==(INT)0)
1342 {
1343 cy = locsub(&lo,locy0,(INT)0);
1344 if (cy == (INT)1) cy = locssub(&hi,(INT)1);
1345 vgl = locvgl(&hi,&r);
1346 if (
1347 (vgl >(INT)0) ||
1348 ((vgl ==(INT)0)
1349 &&
1350 /* bug 050790 */ (locvgl(&lo,locx0) >(INT)0 )))
1351 cy = locssub(&q,(INT)1);
1352 }
1353 }
1354 };
1355
1356 /* subtrahiere q*divisor von teildivdend llocx = vorgaenger locx0 */
1357 alocy = blocy; alocx = blocx; cy = 0; cyn = 0;
1358 LOCNULL(&ov);
1359 llocx = NULL; plocx = NULL;
1360 do {
1361 LOCMUL(&hi,&lo,alocy,&q);
1362 cy = locadd(&lo,&ov,cy);
1363 LOCASS(&ov,&hi);
1364 cyn = locsub(alocx,&lo,cyn);
1365 plocx = alocx; alocx = alocx->nloc; alocy = alocy->nloc;
1366 if (alocx == locx0) llocx = plocx;
1367 }
1368 while (alocy != NULL);
1369 cy = locsadd(&ov,cy); cyn = locsub(alocx,&ov,cyn);
1370 if (cy !=(INT)0)
1371 return error("internal error:LO12");
1372
1373 /* falls differenz negativ, q war um 1zu gross. korrektur */
1374
1375 if (cyn == (INT)1)
1376 {
1377 cyn = locssub(&q,(INT)1);
1378 alocx = blocx; alocy = blocy; cy =(INT)0;
1379 do {
1380 cy = locadd(alocx,alocy,cy);
1381 alocx = alocx->nloc; alocy = alocy->nloc;
1382 }
1383 while (alocy != NULL);
1384 cy = locsadd(alocx,cy);
1385 if (cy != (INT)1)
1386 return error("internal error:LO13");
1387 }
1388
1389 /* quotientenziffer q abspeichern . locx2 ist frei dafuer */
1390 locx1->nloc = NULL;
1391 if ((blocq == NULL) && (LOCSGN(&q) ==(INT)0)) locrette(&locx2);
1392 else {
1393 locx2->nloc = blocq; blocq = locx2; locx2 = NULL;
1394 LOCASS(blocq,&q); ql ++;
1395 };
1396
1397 /* neuer teildividend */
1398 fertig = (rlocx == NULL);
1399 if (! fertig)
1400 {
1401 alocx = blocx; blocx = rlocx; rlocx = rlocx->nloc;
1402 blocx->nloc = alocx;
1403 locx2 = locx1; locx1 = locx0; locx0 = llocx;
1404 if (locx0 == NULL) locx0 = blocx;
1405 }
1406 }
1407 while (! fertig); /* ende divisionsschritt */
1408
1409 /* quotient */
1410 if (blocq == NULL)
1411 {
1412 LOCHOLE (&x->floc); x->signum = (signed char)0;
1413 x->laenge = (INT)1;
1414 }
1415 else {
1416 x->floc = blocq; blocq = NULL;
1417 x->signum = sx * sy; x->laenge = ql;
1418 }
1419
1420 /* rest normierung rueckgaengig machen fuehrende nullen entfernen */
1421 i =(INT)0; llocx = NULL;
1422 plocx = blocx; alocx = plocx->nloc;
1423 do {
1424 i++;
1425 /* Seite 8 von test.p */
1426 locpsr(alocx,plocx,a);
1427 if (LOCSGN(plocx) !=(INT)0)
1428 {
1429 llocx = plocx; rl = i;
1430 }
1431 plocx = alocx; alocx = alocx->nloc;
1432 }
1433 while (alocx != NULL);
1434 locpsr(&null,plocx,a);
1435 if (LOCSGN(plocx) !=(INT)0) { llocx = plocx; rl = i+ (INT)1; }
1436
1437 if (llocx == NULL) /* rest 0 */
1438 {
1439 loclisterette(&blocx->nloc); rest->floc = blocx;
1440 blocx = NULL; rest->signum = (signed char)0; rest->laenge = (INT)1;
1441 }
1442 else {
1443 loclisterette(&llocx->nloc); rest->floc = blocx;
1444 blocx = NULL; rest->signum = sx; rest->laenge = rl;
1445 }
1446
1447 /* divisor. normierung rueckgaengig machen */
1448 plocy = blocy; alocy = plocy->nloc;
1449 do
1450 {
1451 locpsr(alocy,plocy,a);
1452 plocy = alocy;
1453 alocy = alocy->nloc;
1454 }
1455 while (alocy != NULL);
1456
1457 locpsr(&null,plocy,a);
1458 y->floc = blocy;
1459 blocy = NULL;
1460 } /* lange divison */
1461 ENDR("ganzquores");
1462 } /* ende ganzquores */
1463
1464
1465
1466 #ifdef UNDEF
ganzganzdiv(x,y)1467 static INT ganzganzdiv(x,y) struct longint *x,*y;
1468 /* AK: Tue Mar 14 09:03:44 MEZ 1989 */
1469 /* dieser Teil wurde von Peter Hain in Karlsruhe
1470 entworfen. Er schrieb diese Langzahl arithmetik in Pascal und
1471 Assembler. In Bayreuth wurden in Form eines Seminars die
1472 Assemblerteile in C geschrieben und spaeter wurde von
1473 Axel Kohnert die restlichen Pascalteile in C uebersetzt.
1474 Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth
1475 entworfen */
1476 /* AK 130789 V1.0 */ /* AK 210891 V1.3 */
1477 {
1478 struct longint rest;
1479
1480 rest.floc = NULL;
1481 ganzquores(x,&rest,y);
1482 ganzloesche(&rest);
1483 return OK;
1484 }
1485 #endif
1486
1487 #ifdef UNDEF
ganzmod(x,rest,y)1488 static INT ganzmod(x,rest,y) struct longint *x,*y,*rest;
1489 /* AK Tue Mar 14 09:05:54 MEZ 1989 */
1490 /* dieser Teil wurde von Peter Hain in Karlsruhe
1491 entworfen. Er schrieb diese Langzahl arithmetik in Pascal und
1492 Assembler. In Bayreuth wurden in Form eines Seminars die
1493 Assemblerteile in C geschrieben und spaeter wurde von
1494 Axel Kohnert die restlichen Pascalteile in C uebersetzt.
1495 Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth
1496 entworfen */
1497
1498 /* AK 130789 V1.0 *//* AK 250790 V1.1 */ /* AK 210891 V1.3 */
1499 {
1500 return ganzquores(x,rest,y);
1501 }
1502 #endif
1503
1504
1505
ganzein(fp,x)1506 static INT ganzein(fp,x) FILE *fp; struct longint *x;
1507 /* AK 130789 V1.0 *//* AK 250790 V1.1 */ /* AK 270391 V1.2 */
1508 /* AK 210891 V1.3 */
1509 {
1510 INT i;
1511 signed char sgn=(signed char)1;
1512 char c;
1513
1514
1515 fscanf(fp, "%" SCNINT ,&i);
1516 if (i <(INT)0)
1517 {
1518 sgn = (signed char)-1;
1519 i = i *(INT)-1;
1520 }
1521 ganzint(x, i % gd.basis);
1522 while ((c=getc(fp)) == (char) gd.folgezeichen)
1523 {
1524 fscanf(fp, "%" SCNINT ,&i);
1525 if (i <(INT)0)
1526 {
1527 return error("internal error LO14");
1528 }
1529 ganzsmul(x,gd.basis);
1530 ganzsadd(x,i % gd.basis);
1531 }
1532
1533 x->signum = sgn;
1534 return OK;
1535 }
1536
1537
1538
1539
holeziffer(zd)1540 static INT holeziffer(zd) struct zahldaten *zd;
1541 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
1542 {
1543 struct loc *adez;
1544 INT zzmod3,erg = OK;
1545
1546 zd->ziffernzahl --;
1547 zzmod3 = zd->ziffernzahl % (INT)3;
1548
1549 if (zzmod3 ==(INT)0) erg=zd->fdez->w0;
1550 if (zzmod3 ==(INT)1) erg=zd->fdez->w1;
1551 if (zzmod3 ==(INT)2) erg=zd->fdez->w2;
1552
1553 if (zzmod3 ==(INT)0)
1554 { adez = zd->fdez; zd->fdez = zd->fdez->nloc;
1555 adez->nloc = NULL; locrette(&adez); }
1556
1557 return(erg);
1558 }
1559
1560
1561
ganzfziffer(zd)1562 static INT ganzfziffer(zd) struct zahldaten *zd;
1563 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
1564 {
1565 INT z,f0;
1566 char buffer[200];
1567
1568 if (zd->ziffernzahl == 0)
1569 { zd->mehr = FALSE;
1570 //strcpy(zd->ziffer," ");
1571 }
1572 else {
1573 z = holeziffer(zd);
1574 if (zd->ziffernzahl > 0) zd->mehr=TRUE; else zd->mehr=FALSE;
1575 sprintf(buffer, "%" PRIINT ,z);
1576 f0 = gd.basislaenge-strlen(buffer);
1577 sprintf(zd->ziffer,"%s","000000000000");
1578 /* max. 12 Nullen */
1579 sprintf(zd->ziffer + f0, "%" PRIINT ,z);
1580 if (zd->mehr == TRUE)
1581 {
1582 if (nofolgezeichen)
1583 sprintf(zd->ziffer,"%s", zd->ziffer);
1584 else
1585 sprintf(zd->ziffer,"%s%c", zd->ziffer,gd.folgezeichen);
1586 }
1587 else
1588 {
1589 if (nofolgezeichen)
1590 sprintf(zd->ziffer,"%s",zd->ziffer);
1591 else
1592 sprintf(zd->ziffer,"%s%c",zd->ziffer,' ');
1593 }
1594 }
1595 return(OK);
1596 }
1597
1598
1599
retteziffer(z,zd)1600 static INT retteziffer(z,zd) INT z; struct zahldaten *zd;
1601 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
1602 {
1603 struct loc *adez;
1604 INT zzmod3;
1605 INT erg =OK;
1606
1607 zzmod3 = zd->ziffernzahl % (INT)3;
1608
1609 if (zzmod3 ==(INT)0) {
1610 adez = NULL;
1611 LOCHOLE(&adez);
1612 adez ->nloc = zd->fdez;
1613 zd->fdez = adez;
1614 }
1615 if (zzmod3 ==(INT)0) zd->fdez->w0 = z;
1616 if (zzmod3 ==(INT)1) zd->fdez->w1 = z;
1617 if (zzmod3 ==(INT)2) zd->fdez->w2 = z;
1618
1619 zd->ziffernzahl ++;
1620 ENDR("retteziffer");
1621 }
1622
1623
1624
ganz1ziffer(zd,x)1625 static INT ganz1ziffer(zd,x) struct zahldaten *zd; struct longint *x;
1626 /* AK 130789 V1.0 */ /* AK 030790 V1.1 */ /* AK 210891 V1.3 */
1627 {
1628 INT z;
1629 signed char sgn;
1630 struct longint xx;
1631
1632 zd->fdez = NULL; zd->ziffernzahl =(INT)0; xx.floc = NULL;
1633 (zd->ziffer)[0] = '\0';
1634 lochole(&xx.floc);
1635 ganzkopiere(&xx,x);
1636 sgn = xx.signum;
1637 if (xx.signum < (signed char)0) xx.signum = -xx.signum;
1638
1639 while (xx.signum > (signed char)0)
1640 { ganzsquores(&xx,&z,gd.basis); retteziffer(z,zd); }
1641 if (zd->ziffernzahl ==(INT)0)
1642 { zd->mehr = FALSE;
1643 // strcpy(zd->ziffer," ");
1644 }
1645 else {
1646 z = holeziffer(zd); z = sgn * z;
1647 zd->mehr = (zd->ziffernzahl >(INT)0);
1648 if (zd->mehr == TRUE)
1649 {
1650 if (nofolgezeichen)
1651 sprintf(zd->ziffer, "%s%" PRIINT ,zd->ziffer,z);
1652 else
1653 sprintf(zd->ziffer, "%s%" PRIINT "%c" ,zd->ziffer,z,gd.folgezeichen);
1654 }
1655 else
1656 sprintf(zd->ziffer, "%s%" PRIINT ,zd->ziffer,z);
1657 }
1658 locrette(& xx.floc);
1659 return(OK);
1660 }
1661
1662
ganzaus_str(string,x)1663 static INT ganzaus_str(string,x) char *string; struct longint *x;
1664 /* AK 020295 */
1665 {
1666 struct zahldaten zd;
1667 int i,k;
1668 string[0]='\0';
1669 if (x->signum == 0) /* AK 060502 */
1670 {
1671 strcat(string," 0 ");
1672 goto ende;
1673 }
1674 ganz1ziffer(&zd,x);
1675 k = strlen(zd.ziffer);
1676 if (zd.ziffer[k-1] == gd.folgezeichen)
1677 {
1678 zd.ziffer[k-1] = '\0';
1679 k--;
1680 }
1681 strcat(string,zd.ziffer);
1682 i = k;
1683 while (zd.mehr == TRUE)
1684 {
1685 ganzfziffer(&zd);
1686 k = strlen(zd.ziffer);
1687 if (zd.ziffer[k-1] == gd.folgezeichen)
1688 {
1689 zd.ziffer[k-1] = '\0';
1690 k--;
1691 }
1692 strcat(string,zd.ziffer);
1693 i+=k;
1694 }
1695 ende:
1696 return OK;
1697 }
1698
mem_size_longint(a)1699 INT mem_size_longint(a) OP a;
1700 /* AK V2.0 080903 */
1701 {
1702 INT erg = OK, res = 0;
1703 struct longint *x;
1704 CTO(LONGINT,"mem_size_longint(1)",a);
1705 res = sizeof(struct object);
1706 res += sizeof(struct longint);
1707 x = S_O_S(a).ob_longint;
1708 res += ((x->laenge)*sizeof(struct loc));
1709 return res;
1710 ENDR("mem_size_longint");
1711 }
1712
ganzaus(fp,x)1713 static INT ganzaus(fp,x) FILE *fp; struct longint *x;
1714 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
1715 {
1716 struct zahldaten zd;
1717 char *blanks = (char *) SYM_calloc(201,sizeof(char));
1718 char *zeile = (char *) SYM_calloc(201,sizeof(char));
1719 INT i;
1720
1721 if (x->signum == 0) /* AK 060502 */
1722 {
1723 fprintf(fp," 0 ");
1724 if (fp == stdout)
1725 zeilenposition += 3;
1726 else if (fp == texout)
1727 texposition += 3;
1728 goto ende;
1729 }
1730
1731 for (i=1;i<gd.auspos;i++) blanks[i-1]=' ';
1732 blanks[(gd.auspos)-1]='\0';
1733
1734 zd.ziffer[0] = '\0';
1735
1736 zeile[0]='\0';
1737 gd.auszz = 0;
1738
1739 ganz1ziffer(&zd,x);
1740 strcat(zeile,zd.ziffer);
1741
1742 while (zd.mehr == TRUE)
1743 {
1744 ganzfziffer(&zd);
1745 if ((INT)strlen(zeile) + (INT)strlen(zd.ziffer) > gd.auslaenge)
1746 {
1747 if (nofolgezeichen)
1748 fprintf(fp,"%s",zeile);
1749 else
1750 fprintf(fp,"%s%s\n",blanks,zeile);
1751 strcpy(zeile,zd.ziffer); gd.auszz++;
1752 }
1753 else strcat(zeile,zd.ziffer);
1754
1755 }
1756
1757 if (fp == stdout) {
1758 zeilenposition += strlen(zeile);
1759 zeilenposition += strlen(blanks);
1760 }
1761 else if (fp == texout)
1762 {
1763 texposition += strlen(zeile);
1764 texposition += strlen(blanks);
1765 }
1766
1767 if (nofolgezeichen)
1768 fprintf(fp,"%s",zeile);
1769 else
1770 fprintf(fp,"%s%s",blanks,zeile);
1771 if (fp == stdout)
1772 if (zeilenposition >(INT)70)
1773 { fprintf(fp,"\n"); zeilenposition =(INT)0; }
1774 if (fp == texout)
1775 if (texposition >(INT)70)
1776 { fprintf(fp,"\n"); texposition =(INT)0; }
1777
1778
1779 gd.auszz++;
1780 SYM_free(blanks);
1781 SYM_free(zeile);
1782 ende:
1783 return(OK);
1784 }
1785
1786
1787
ganzmul(x,y)1788 static INT ganzmul(x,y) struct longint *x,*y;
1789 /* AK Mon Jan 16 09:26:56 MEZ 1989 */
1790 /* x = x * y */
1791 /* AK 180789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
1792 {
1793 struct loc *alocx, *alocy, *ploca, *floca, *bloca, *aloca;
1794 struct loc hi,lo,ov;
1795 INT cy,cya;
1796 INT hh; /* fuer LOCADD,LOCMUL */
1797 INT erg =OK;
1798
1799
1800
1801 x->signum = x->signum * y ->signum;
1802 if (x->signum == (signed char)0)
1803 {
1804 loclisterette(& (x->floc->nloc));
1805 LOCNULL(x->floc);
1806 x->laenge =(INT)1;
1807 return OK;
1808 /* das ergebnis ist null */
1809 }
1810
1811 /* das ergebnis ist nicht null */
1812 x->laenge = x->laenge + y->laenge;
1813 floca = NULL; LOCHOLE(&floca); bloca = floca; alocx = x->floc->nloc;
1814 ploca = floca; aloca = NULL;
1815 while (alocx != NULL)
1816 { LOCHOLE(&aloca); ploca->nloc = aloca;
1817 ploca = aloca; aloca = NULL; alocx = alocx->nloc; }
1818
1819 alocy = y->floc;
1820
1821 do {
1822 cya =(INT)0;
1823 LOCNULL(&ov); cy =(INT)0; alocx = x->floc; aloca = bloca;
1824 do { LOCMUL(&hi,&lo,alocx,alocy);
1825 cy = LOCADD(&lo,&ov, cy);
1826 ov = hi; cya = LOCADD(aloca,&lo,cya);
1827 alocx=alocx->nloc; ploca=aloca; aloca = aloca->nloc; }
1828 while (alocx != NULL);
1829 cy = locsadd(&ov, cy+cya);
1830 /* cy ist jetzt 0 */
1831 if (cy !=(INT)0)
1832 return error("internal error:LO2");
1833 LOCHOLE(&aloca);
1834 ploca->nloc = aloca;
1835 LOCASS(aloca,&ov);
1836 bloca = bloca->nloc;
1837 alocy = alocy->nloc;
1838 }
1839 while (alocy != NULL);
1840
1841 if (LOCSGN(aloca ) ==(INT)0)
1842 {
1843 locrette(&(ploca->nloc));
1844 x->laenge --;
1845 }
1846 loclisterette(&x->floc);
1847 x->floc = floca;
1848 ENDR("ganzmul");
1849 }
1850
1851
1852
ganzsmul(x,a)1853 static INT ganzsmul(x,a) struct longint *x; INT a;
1854 /* AK Mon Mar 13 10:08:51 MEZ 1989 */ /* AK 050790 V1.1 */
1855 /* AK 210891 V1.3 */
1856 {
1857 struct loc *alocx, *plocx;
1858 INT ue,erg =OK;
1859
1860 if (a==(INT)0)
1861 {
1862 loclisterette(&(x->floc->nloc));
1863 x->signum = (signed char)locint(x->floc,(INT)0);
1864 x->laenge =(INT)1;
1865 }
1866 else if (a ==(INT)1) ;
1867 else if (a ==(INT)-1) x->signum = - x->signum;
1868 else {
1869 if (a<(INT)0) x->signum = - x->signum;
1870 alocx = x->floc;
1871 plocx = NULL;
1872 if (a<(INT)0) a = -a;
1873 ue =(INT)0;
1874 do {
1875 ue = locsmul(alocx,a,ue);
1876 plocx = alocx;
1877 alocx = alocx ->nloc;
1878 }
1879 while (alocx != NULL);
1880 if (ue !=(INT)0)
1881 {
1882 LOCHOLE(&alocx);
1883 plocx->nloc = alocx;
1884 x->laenge ++;
1885 ue = locint(alocx,ue);
1886 }
1887 }
1888 ENDR("ganzsmul");
1889 }
1890
1891
1892
1893
ganzsadd(x,y)1894 static INT ganzsadd(x,y) struct longint *x; INT y;
1895 /* AK 180789 V1.0 */ /* AK 070390 V1.1 */ /* AK 210891 V1.3 */
1896 {
1897 INT cy,xl,ll;
1898 INT erg =OK;
1899 signed char xs,ys;
1900 struct loc *lloc,*alocx,*plocx=NULL;
1901
1902 xl = x->laenge;
1903 xs = x->signum;
1904 if (y>(INT)0)
1905 ys=(signed char)1;
1906 else if (y<(INT)0)
1907 ys = (signed char)-1;
1908 else
1909 ys=(signed char)0;
1910 if (y<(INT)0) y = -y;
1911
1912 if ( ((xs>=(signed char)0)&&(ys>=(signed char)0))
1913 ||
1914 ((xs<(signed char)0)&&(ys < (signed char)0))
1915 )
1916 {
1917 alocx = x->floc;
1918 cy = y;
1919 while ((alocx != NULL)&&(cy !=(INT)0))
1920 {
1921 cy = locsadd(alocx,cy);
1922 plocx = alocx;
1923 alocx = alocx->nloc;
1924 }
1925 if (cy !=(INT)0)
1926 {
1927 LOCHOLE(&alocx);
1928 plocx->nloc = alocx;
1929 locint(alocx,cy);
1930 xl ++;
1931 }
1932 if (xs == (signed char)0)
1933 xs = ys;
1934 }
1935 else {
1936 alocx = x->floc;
1937 cy = y;
1938 while ((alocx != NULL) && (cy !=(INT)0))
1939 {
1940 cy = locssub(alocx,cy);
1941 plocx = alocx;
1942 alocx = alocx->nloc;
1943 }
1944 if (cy !=(INT)0)
1945 {
1946 alocx = x->floc;
1947 lloc = NULL;
1948 ll = (INT) 1;
1949 cy = (INT) 0;
1950 do {
1951 cy = locneg(alocx,cy);
1952 if (LOCSGN(alocx) != (INT) 0 )
1953 { lloc = alocx; xl = ll; }
1954 alocx = alocx->nloc;
1955 ll ++;
1956 }
1957 while (alocx != NULL);
1958 loclisterette(&(lloc->nloc));
1959 xs = -xs;
1960 if (xs == (signed char)0)
1961 xs = (signed char)-1;
1962 }
1963 else {
1964 alocx = x->floc;
1965 lloc = NULL;
1966 ll = (INT)1;
1967 do {
1968 if (LOCSGN(alocx) !=(INT)0)
1969 {
1970 lloc = alocx;
1971 xl = ll;
1972 }
1973 alocx = alocx->nloc;
1974 ll ++;
1975 }
1976 while (alocx != NULL);
1977 if (lloc == NULL)
1978 {
1979 loclisterette(&(x->floc->nloc));
1980 xs = (signed char)0;
1981 xl = (INT)1;
1982 }
1983 else loclisterette(&(lloc->nloc));
1984 }
1985 }
1986 x->laenge = xl;
1987 x->signum = xs;
1988 ENDR("ganzsadd");
1989 }
1990
1991
1992
ganzvergleich(x,y)1993 static INT ganzvergleich(x,y) struct longint *x,*y;
1994 /* AK Thu Jan 12 09:08:15 MEZ 1989 */
1995 /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
1996 {
1997 struct loc *alocx, *alocy;
1998 INT av,lv;
1999 signed char sx,sy;
2000
2001 sx = x->signum;
2002 sy = y->signum;
2003 if (sx>sy)
2004 return((INT)1);
2005 if (sx<sy)
2006 return (INT) -1;
2007 /* es gilt nun gleiches vorzeichen */
2008 if (sx==(signed char)0)
2009 return((INT)0);
2010 if (x->laenge > y->laenge)
2011 return((INT)sx);
2012 if (x->laenge < y->laenge)
2013 return((INT)-sy);
2014
2015 /* es gilt nicht nur gleiches vorzeichen sondern auch
2016 gleiche laenge */
2017 alocx = x->floc;
2018 alocy = y->floc;
2019 lv = 0;
2020 do
2021 {
2022 av = locvgl(alocx,alocy);
2023 if (av != 0) lv = av;
2024 alocx = alocx->nloc;
2025 alocy = alocy->nloc;
2026 }
2027 while (alocx != NULL);
2028
2029 if (sx>(signed char)0)
2030 return(lv);
2031 else
2032 return(-lv);
2033 }
2034
2035
2036
intganz(x)2037 static INT intganz(x) struct longint *x;
2038 /* AK 150290 V1.1 */ /* umwandlung longint to int falls moeglich sonst fehler */
2039 /* AK 210891 V1.3 */
2040 {
2041 if ( x->signum < 0)
2042 return - x->floc->w0 - x->floc->w1 * LO_B - x->floc->w2 * LO_B * LO_B ;
2043 else
2044 return (x->floc->w0&BMINUSEINS)
2045 +(x->floc->w1&BMINUSEINS) * LO_B
2046 +(x->floc->w2&BMINUSEINS) * LO_B * LO_B;
2047 }
2048
ganzint(x,i)2049 static INT ganzint(x,i) struct longint *x; INT i;
2050 /* AK Thu Jan 12 13:18:53 MEZ 1989 */
2051 /* AK 130789 V1.0 */ /* AK 150290 V1.1 */ /* AK 210891 V1.3 */
2052 {
2053 if (x->floc->nloc != NULL)
2054 loclisterette(& x->floc->nloc );
2055
2056 if (i == MAXNEG) {
2057 /* AK 251001 */
2058 /* sonst ist locint fehlerhaft */
2059 x->laenge = (INT)1;
2060 x->signum = (signed char)locint(x->floc,i+1);
2061 ganzsadd(x,(INT)-1);
2062 }
2063 else {
2064 x->laenge = (INT)1;
2065 x->signum = (signed char)locint(x->floc,i);
2066 }
2067 return(OK);
2068 }
2069
2070
ganzeven(x)2071 static INT ganzeven(x) struct longint *x;
2072 /* AK 061190 V1.1 */ /* AK 210891 V1.3 */
2073 {
2074 return not locodd(x->floc);
2075 }
2076
2077
2078
ganzodd(x)2079 static INT ganzodd(x) struct longint *x;
2080 /* AK 061190 V1.1 */ /* AK 210891 V1.3 */
2081 {
2082 return locodd(x->floc);
2083 }
2084
2085
2086
ganzkopiere(x,a)2087 static INT ganzkopiere(x,a) struct longint *x,*a;
2088 /* x:= a AK umgeschrieben in C Fri Jan 20 07:46:34 MEZ 1989 */
2089 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
2090 {
2091 INT erg = OK;
2092 struct loc *alocx, *plocx, *aloca;
2093 if (a->floc == NULL) { /* AK 060502 */
2094 /* a == 0 */
2095 if (x->floc != NULL) FREE_LOC(x->floc); /* was initialised in init_longint */
2096 x->laenge = 0;
2097 x->floc = NULL;
2098 goto ee;
2099 }
2100
2101 SYMCHECK( x->floc == a->floc, "internal error:LO4");
2102
2103 x->signum = a->signum;
2104 x->laenge = a->laenge;
2105 aloca = a->floc;
2106 alocx = x->floc;
2107 plocx = NULL;
2108
2109 do
2110 {
2111 if (alocx == NULL)
2112 {
2113 LOCHOLE(&alocx);
2114 plocx->nloc = alocx;
2115 }
2116 LOCASS(alocx,aloca);
2117 aloca = aloca->nloc;
2118 plocx = alocx;
2119 alocx = alocx->nloc;
2120 }
2121 while (aloca != NULL);
2122
2123 /* loclisterette(&(plocx->nloc)); */
2124 if (plocx->nloc != NULL) {
2125 FREE_LOC(plocx->nloc);
2126 plocx->nloc = NULL;
2127 }
2128 ee:
2129 ENDR("internal function:ganzkopiere");
2130 }
2131
2132
mult_longint_integer(a,b,c)2133 INT mult_longint_integer(a,b,c) OP a,b,c;
2134 {
2135 INT erg = OK,i,j,p,u,s,p2;
2136 static INT sp[14],sp2[14];
2137 struct longint *x;
2138 struct loc *alocx;
2139
2140 CTO(LONGINT,"mult_longint_integer(1)",a);
2141 CTO(INTEGER,"mult_longint_integer(2)",b);
2142 CTO(EMPTY,"mult_longint_integer(3)",c);
2143
2144 if (NULLP_INTEGER(b) || NULLP_LONGINT(a) ) {
2145 M_I_I(0,c);
2146 goto ende;
2147 }
2148
2149 x = S_O_S(a).ob_longint;
2150 if (x->laenge > 4) {
2151 erg += mult_longint_integer_via_ganzsmul(a,b,c);
2152 goto ende;
2153 }
2154 s = x->signum;
2155 if (S_I_I(b) < 0) { p = -S_I_I(b); s = -s; } else p = S_I_I(b);
2156
2157 if (p > 1073741824) {
2158 erg += mult_longint_integer_via_ganzsmul(a,b,c);
2159 goto ende;
2160 }
2161
2162
2163 i=0; alocx = x->floc;
2164 xx:
2165 sp[i++] = alocx->w0;
2166 sp[i++] = alocx->w1;
2167 sp[i++] = alocx->w2;
2168 if (alocx -> nloc) { alocx = alocx->nloc; goto xx; }
2169 sp[i] = 0; sp[i+1] = 0;
2170
2171 if (p <= 32768 ) {
2172 j = 0;u = 0;
2173 while (j <=i)
2174 {
2175 sp [j] *= p;
2176 sp [j] += u;
2177 u = sp[j] >> 15;
2178 sp [j] &= BMINUSEINS;
2179 j++;
2180 }
2181 }
2182 else {
2183 j = 0; u = 0;p2 = p >> 15;
2184 while (j <=i)
2185 {
2186 sp2 [j] = sp[j] * p2;
2187 sp2 [j] += u;
2188 u = sp2[j] >> 15;
2189 sp2 [j] &= BMINUSEINS;
2190 j++;
2191 }
2192 j = 0;u = 0; p &= BMINUSEINS;
2193 while (j <=i)
2194 {
2195 sp [j] *= p;
2196 sp [j] += u;
2197 if (j>0) sp[j] += sp2[j-1];
2198 u = sp[j] >> 15;
2199 sp [j] &= BMINUSEINS;
2200 j++;
2201 }
2202 sp[i+1] = sp2[i]+u; /* AK 030502 +u was missing */
2203 }
2204
2205 INIT_LONGINT(c);
2206 x = S_O_S(c).ob_longint;
2207 alocx = x->floc; j = 0;u=0;
2208 x ->signum = s;
2209
2210 again:
2211 alocx->w0 = sp[j++];
2212 alocx->w1 = sp[j++];
2213 alocx->w2 = sp[j++];
2214 if ((j==i) && ( (sp[j] != 0) || (sp[j+1] != 0)) ) {
2215 x->laenge ++;
2216 LOCHOLE(& alocx->nloc);
2217 alocx->nloc->w0 = sp[j];
2218 alocx->nloc->w1 = sp[j+1];
2219 }
2220 else if (j < i) {
2221 x->laenge ++;
2222 LOCHOLE(& alocx->nloc);
2223 alocx = alocx->nloc;
2224 goto again;
2225 }
2226
2227 ende:
2228 ENDR("mult_longint_integer");
2229
2230 }
2231
2232
2233
2234
2235
lochole(aloc)2236 static INT lochole(aloc) struct loc **aloc;
2237 /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
2238 {
2239 INT erg =OK;
2240 CALLOC_MEMMANAGER(struct loc,loc_speicher,loc_index,loc_counter,*aloc);
2241 LOCNULL(*aloc);
2242 (*aloc)->nloc = NULL;
2243 ENDR("lochole");
2244 }
2245
2246
2247
loclisterette(aloc)2248 static INT loclisterette(aloc) struct loc **aloc;
2249 /* AK 130789 V1.0 */ /* AK 010290 V1.1 */
2250 /* AK 210891 V1.3 */
2251 {
2252 INT erg = OK;
2253 struct loc *aloc1, *ploc1;
2254 if (*aloc != NULL)
2255 {
2256 aloc1= (*aloc);
2257 do {
2258 ploc1 = aloc1->nloc;
2259 FREE_LOC(aloc1);
2260 aloc1 = ploc1;
2261 }
2262 while (aloc1 != NULL);
2263 *aloc = NULL;
2264 }
2265 ENDR("intenal function:loclisterette");
2266 }
2267
2268
2269
locrette(aloc)2270 static INT locrette(aloc) struct loc **aloc;
2271 /* AK 130789 V1.0 */ /* AK 100190 V1.1 */ /* AK 210891 V1.3 */
2272 {
2273 INT erg = OK;
2274 if (*aloc != NULL)
2275 {
2276 FREE_LOC(*aloc);
2277 *aloc = NULL;
2278 }
2279 ENDR("internal function:locrette");
2280 }
2281
2282
2283
locrezliste(aloc)2284 static INT locrezliste(aloc) struct loc **aloc;
2285 /* AK Thu Jan 12 08:06:59 MEZ 1989 */
2286 /* dreht liste um */
2287 /* AK 100190 V1.1 */ /* AK 210891 V1.3 */
2288 {
2289 struct loc *lloc,*rloc,*hloc;
2290 if (*aloc != NULL)
2291 {
2292 lloc = NULL;
2293 rloc = *aloc;
2294 while (rloc != NULL)
2295 {
2296 hloc = rloc->nloc;
2297 rloc->nloc=lloc;
2298 lloc=rloc;
2299 rloc=hloc;
2300 }
2301 *aloc = lloc;
2302 }
2303 return(OK);
2304 }
2305
2306
2307
2308 static INT schon_da =(INT)0;
start_longint()2309 INT start_longint()
2310 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
2311 {
2312 OP a,b;
2313 INT erg = OK;
2314 INT i;
2315 SYMCHECK (schon_da == 1, "start_longint: already initialised");
2316
2317 schon_da = 1;
2318
2319 ANFANG_MEMMANAGER(loc_speicher,loc_index,loc_size,loc_counter);
2320
2321 ANFANG_MEMMANAGER(longint_speicher,longint_speicherindex,
2322 longint_speichersize,mem_counter_loc);
2323
2324 erg += ganzanfang();
2325 erg += ganzparam((INT)1000000,(INT)2,(INT)70,'.');
2326 a = callocobject();
2327 b = callocobject();
2328 M_I_I((INT)1000,b);
2329 for (i=(INT)0;i<(INT)100;i++)
2330 {
2331 erg += random_integer(a,NULL,NULL);
2332 if (S_I_I(a) !=(INT)0)
2333 MULT_APPLY_INTEGER(a,b);
2334 }
2335 erg += random_longint(a,b);
2336 FREEALL2(a,b);
2337 ENDR("start_longint");
2338 }
2339
2340
2341
longint_ende()2342 INT longint_ende()
2343 {
2344 INT erg = OK;
2345 schon_da = (INT)0;
2346 if (rl_o != NULL) { erg += freeall(rl_o); rl_o = NULL; }
2347 if (rl_m != NULL) { erg += freeall(rl_m); rl_m = NULL; }
2348 if (rl_a != NULL) { erg += freeall(rl_a); rl_a = NULL; }
2349 if (rl_x != NULL) { erg += freeall(rl_x); rl_x = NULL; }
2350
2351 ENDE_MEMMANAGER(loc_speicher,loc_index,
2352 loc_size,loc_counter,"loc_speicher not freed");
2353 ENDE_MEMMANAGER(longint_speicher,longint_speicherindex,
2354 longint_speichersize,mem_counter_loc,
2355 "longint_speicher not freed");
2356
2357 erg += longint_speicher_ende();
2358 ENDR("longint_ende");
2359 }
2360
2361
calloclongint()2362 static struct longint * calloclongint()
2363 /* AK 170888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */
2364 /* AK 210891 V1.3 */
2365 {
2366 INT erg =OK;
2367 struct longint *ergebnis;
2368 CALLOC_MEMMANAGER(struct longint,longint_speicher,
2369 longint_speicherindex,mem_counter_loc,ergebnis);
2370 return ergebnis;
2371 ENDTYP("calloclongint",struct longint *);
2372 }
2373
2374
2375
2376
2377
longint_speicher_ende()2378 static INT longint_speicher_ende()
2379 /* AK 230101 */
2380 {
2381 INT i;
2382
2383 for (i=0;i<=longint_speicherindex;i++)
2384 SYM_free(longint_speicher[i]);
2385 SYM_free(longint_speicher);
2386 longint_speicher=NULL;
2387 longint_speicherindex=-1;
2388 longint_speichersize=0;
2389 return OK;
2390 }
2391
2392
2393
ganzparam(basis,auspos,auslaenge,folgezeichen)2394 static INT ganzparam(basis,auspos,auslaenge,folgezeichen)
2395 INT basis,auspos,auslaenge;
2396 char folgezeichen;
2397 /* AK Mon Mar 13 10:24:35 MEZ 1989 */
2398 /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
2399 {
2400 if (basis>(INT)1) gd.basis=basis;
2401 else return error("internal error:LO5");
2402
2403 if (auspos>(INT)1) gd.auspos=auspos; else gd.auspos = 2;
2404 if (basis <= (INT)10) gd.basislaenge = 1; else
2405 if (basis <= (INT)100) gd.basislaenge = 2; else
2406 if (basis <= (INT)1000) gd.basislaenge = 3; else
2407 if (basis <= (INT)10000) gd.basislaenge = 4; else
2408 if (basis <= (INT)100000) gd.basislaenge = 5; else
2409 if (basis <= (INT)1000000) gd.basislaenge = 6; else
2410 if (basis <= (INT)10000000) gd.basislaenge = 7; else
2411 if (basis <= (INT)100000000) gd.basislaenge = 8; else
2412 if (basis <= (INT)1000000000) gd.basislaenge = 9; else
2413 gd.basislaenge = 10;
2414 if (auslaenge > gd.basislaenge) gd.auslaenge = auslaenge;
2415 else gd.auslaenge = gd.basislaenge+1;
2416 gd.folgezeichen = folgezeichen;return(OK);
2417 }
2418
2419
2420
ganzanfang()2421 static INT ganzanfang()
2422 /* AK: Tue Mar 14 08:43:55 MEZ 1989 */
2423 /* dieser Teil wurde von Peter Hain in Karlsruhe
2424 entworfen. Er schrieb diese Langzahl arithmetik in Pascal und
2425 Assembler. In Bayreuth wurden in Form eines Seminars die
2426 Assemblerteile in C geschrieben und spaeter wurde von
2427 Axel Kohnert die restlichen Pascalteile in C uebersetzt.
2428 Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth
2429 entworfen */
2430 /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
2431 {
2432 gd.auszz =(INT)0;
2433 gd.basis = (INT)1000000; gd.basislaenge = (INT)6;
2434 gd.folgezeichen = '.';
2435 gd.auspos =(INT)2; gd.auslaenge = (INT)78; return(OK);
2436 }
2437
2438
2439
ganzdefiniere(x)2440 static INT ganzdefiniere(x) struct longint *x;
2441 /* AK: Tue Mar 14 08:47:54 MEZ 1989 */
2442 /* dieser Teil wurde von Peter Hain in Karlsruhe
2443 entworfen. Er schrieb diese Langzahl arithmetik in Pascal und
2444 Assembler. In Bayreuth wurden in Form eines Seminars die
2445 Assemblerteile in C geschrieben und spaeter wurde von
2446 Axel Kohnert die restlichen Pascalteile in C uebersetzt.
2447 Die Ein und Ausgabe routinen wurden vollstaendig in Bayreuth
2448 entworfen */
2449 /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
2450 {
2451 x->signum = (signed char)0;
2452 x->laenge = (INT)1;
2453 x->floc = NULL;
2454 lochole(&x->floc);
2455 return(OK);
2456 }
2457
2458
2459
init_longint(l)2460 INT init_longint(l) OP l;
2461 /* AK 170888 */ /* AK 130789 V1.0 */ /* AK 040790 V1.1 */
2462 /* AK 210891 V1.3 */
2463 {
2464 INT erg = OK;
2465 OBJECTSELF c;
2466
2467 CTO(EMPTY,"init_longint",l);
2468
2469 c.ob_longint = calloclongint();
2470 B_KS_O(LONGINT,c,l);
2471 c = S_O_S(l);
2472 ganzdefiniere(c.ob_longint);
2473 ENDR("init_longint");
2474 }
2475
2476
2477
2478
sprint_longint(t,l)2479 INT sprint_longint(t,l) char *t; OP l;
2480 /* AK 020295 */
2481 /* AK 240398 V2.0 */
2482 {
2483 INT erg=OK;
2484 OBJECTSELF c;
2485 CTO(LONGINT,"sprint_longint",l);
2486 c = S_O_S(l);
2487 erg += ganzaus_str(t, c.ob_longint);
2488 ENDR("sprint_longint");
2489 }
2490
fprint_longint(f,l)2491 INT fprint_longint(f,l) FILE *f; OP l;
2492 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
2493 {
2494 INT erg = OK;
2495 OBJECTSELF c;
2496
2497 c = S_O_S(l);
2498 erg += ganzaus(f, c.ob_longint);
2499 ENDR("fprint_longint");
2500 }
2501
2502
2503
2504
2505
tex_longint(l)2506 INT tex_longint(l) OP l;
2507 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */
2508 /* AK 070291 V1.2 texout instaed of stdout for output */ /* AK 210891 V1.3 */
2509 {
2510 INT ts = texmath_yn;
2511 INT erg = OK;
2512 CTO(LONGINT,"tex_longint(1)",l);
2513
2514 if (ts == 0L) fprintf(texout," $ "); else fprintf(texout," ");
2515 erg += fprint_longint(texout,l);
2516 if (ts == 0L) fprintf(texout," $ "); else fprintf(texout," ");
2517 if (ts == 0L) texposition += (INT)6; else texposition += (INT)2;
2518 ENDR("tex_longint");
2519 }
2520
2521
2522
copy_longint(a,c)2523 INT copy_longint(a,c) OP a,c;
2524 /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 030790 V1.1 */
2525 /* AK 210891 V1.3 */
2526 /* AK 010399 V2.0 */
2527 {
2528 INT erg = OK;
2529 CTO(LONGINT,"copy_longint(1)",a);
2530 CTTO(INTEGER,EMPTY,"copy_longint(2)",c);
2531
2532 INIT_LONGINT(c);
2533 erg += ganzkopiere(S_O_S(c).ob_longint,S_O_S(a).ob_longint);
2534 ENDR("copy_longint");
2535 }
2536
2537
invers_longint(a,c)2538 INT invers_longint(a,c) OP a,c;
2539 /* AK 010399 V2.0 */
2540 {
2541 INT erg = OK;
2542 CTO(LONGINT,"invers_longint(1)",a);
2543 CTTO(INTEGER,EMPTY,"invers_longint(2)",c);
2544 erg += m_ou_b(cons_eins,a,c);
2545 C_B_I(c,GEKUERZT);
2546 ENDR("invers_longint");
2547 }
2548
2549
2550
2551
freeself_longint(a)2552 INT freeself_longint(a) OP a;
2553 /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 030790 V1.1 */ /* AK 210891 V1.3 */
2554 {
2555 INT erg = OK;
2556 struct longint *x;
2557 CTO(LONGINT,"freeself_longint(1)",a);
2558
2559 x = S_O_S(a).ob_longint;
2560 loclisterette(&x->floc);
2561 x->laenge =(INT)0;
2562 x->signum = (signed char)0;
2563 FREE_LONGINT(x);
2564
2565 C_O_K(a,EMPTY);
2566
2567 ENDR("freeself_longint");
2568 }
2569
2570
add_longint_longint(a,c,l)2571 INT add_longint_longint(a,c,l) OP a,c,l;
2572 /* AK 251001 */
2573 {
2574 INT erg = OK;
2575 CTO(LONGINT,"add_longint(1)",a);
2576 CTO(LONGINT,"add_longint(2)",c);
2577 CTO(EMPTY,"add_longint(3)",l);
2578
2579 erg += copy_longint(a,l);
2580 erg += ganzadd(S_O_S(l).ob_longint, S_O_S(c).ob_longint);
2581 erg += t_longint_int(l);
2582 ENDR("add_longint_longint");
2583 }
2584
intlog_longint(a)2585 INT intlog_longint(a) OP a;
2586 /* AK 170306 */
2587 {
2588 struct longint *as;
2589 as = S_O_S(a).ob_longint;
2590 return 45 * as->laenge;
2591 }
2592
add_longint(a,c,l)2593 INT add_longint(a,c,l) OP a,c,l;
2594 /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
2595 {
2596 INT erg = OK;
2597 CTO(LONGINT,"add_longint(1)",a);
2598 CTO(EMPTY,"add_longint(3)",l);
2599
2600 switch(S_O_K(c))
2601 {
2602 #ifdef BRUCHTRUE
2603 case BRUCH: erg += add_bruch_scalar(c,a,l);
2604 if (S_O_K(l) == LONGINT)
2605 erg += t_longint_int(l);
2606 goto al_ende;
2607 #endif /* BRUCHTRUE */
2608 case INTEGER:
2609 erg += add_longint_integer(a,c,l);
2610 goto al_ende;
2611 case LONGINT:
2612 {
2613 OBJECTSELF ls,cs;
2614
2615 erg += copy_longint(a,l);
2616 ls = S_O_S(l);
2617 cs = S_O_S(c);
2618 erg += ganzadd(ls.ob_longint,cs.ob_longint);
2619 /* longinteger-addition ist x:= x+y */
2620 erg += t_longint_int(l);
2621 };
2622 goto al_ende;
2623
2624 #ifdef SCHURTRUE /* AK 240102 */
2625 case SCHUR:
2626 erg += add_schur(c,a,l);
2627 goto al_ende;
2628 case HOMSYM:
2629 erg += add_homsym(c,a,l);
2630 goto al_ende;
2631 case POWSYM:
2632 erg += add_powsym(c,a,l);
2633 goto al_ende;
2634 case ELMSYM:
2635 erg += add_elmsym(c,a,l);
2636 goto al_ende;
2637 case MONOMIAL:
2638 erg += add_monomial(c,a,l);
2639 goto al_ende;
2640 #endif /* SCHURTRUE */
2641
2642 default:{
2643 erg += WTO("add_longint(2)",c);
2644 goto al_ende;
2645 }
2646 };
2647 al_ende:
2648 ENDR("add_longint");
2649 }
2650
2651
mult_longint(a,c,l)2652 INT mult_longint(a,c,l) OP a,c,l;
2653 /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
2654 {
2655 INT erg = OK;
2656 CTO(LONGINT,"mult_longint(1)",a);
2657 CTO(EMPTY,"mult_longint(3)",l);
2658
2659 switch (S_O_K(c))
2660 {
2661 #ifdef BRUCHTRUE
2662 case BRUCH:
2663 erg+=mult_bruch_longint(c,a,l);
2664 goto me;
2665 #endif /* BRUCHTRUE */
2666
2667 #ifdef INTEGERTRUE
2668 case INTEGER:
2669 erg+=mult_longint_integer(a,c,l);
2670 goto me;
2671 #endif /* INTEGERTRUE */
2672
2673 #ifdef MATRIXTRUE
2674 case MATRIX:
2675 erg+=mult_scalar_matrix(a,c,l);
2676 goto me;
2677 #endif /* MATRIXTRUE */
2678
2679 #ifdef MONOMTRUE
2680 case MONOM:
2681 erg+=mult_scalar_monom(a,c,l);
2682 goto me;
2683 #endif /* MONOMTRUE */
2684
2685 case LONGINT:
2686 erg+=mult_longint_longint(a,c,l);
2687 goto me;
2688
2689 case POLYNOM:
2690 erg+=mult_scalar_polynom(a,c,l);
2691 goto me;
2692
2693 #ifdef GRALTRUE
2694 case GRAL:
2695 erg+=mult_scalar_gral(a,c,l);
2696 goto me;
2697 #endif /* GRALTRUE */
2698
2699 #ifdef SCHUBERTTRUE
2700 case SCHUBERT:
2701 erg += mult_scalar_schubert(a,c,l);
2702 goto me;
2703 #endif /* SCHUBERT */
2704
2705 #ifdef SQRADTRUE
2706 case SQ_RADICAL:
2707 erg += mult_scalar_sqrad(a,c,l);
2708 goto me;
2709 #endif /* SQRADTRUE */
2710
2711 #ifdef SCHURTRUE
2712 case ELMSYM:
2713 erg+=mult_elmsym_scalar(c,a,l);
2714 goto me;
2715 case HOMSYM:
2716 erg+=mult_homsym_scalar(c,a,l);
2717 goto me;
2718 case POWSYM:
2719 erg+=mult_powsym_scalar(c,a,l);
2720 goto me;
2721 case MONOMIAL:
2722 erg+=mult_monomial_scalar(c,a,l);
2723 goto me;
2724 case SCHUR:
2725 erg+=mult_schur_scalar(c,a,l);
2726 goto me;
2727 #endif /* SCHURTRUE */
2728
2729 #ifdef CHARTRUE
2730 case SYMCHAR:
2731 erg+=mult_scalar_symchar(a,c,l);
2732 goto me;
2733 #endif /* CHARTRUE */
2734
2735 #ifdef VECTORTRUE
2736 case COMPOSITION:
2737 case WORD:
2738 case INTEGERVECTOR:
2739 case VECTOR:
2740 erg+=mult_scalar_vector(a,c,l);
2741 goto me;
2742 #endif /* VECTORTRUE */
2743
2744 default:
2745 {
2746 erg += WTO("mult_longint(2)",a);
2747 break;
2748 }
2749 };
2750 me:
2751 ENDR("mult_longint");
2752 }
2753
2754
2755
mult_longint_longint(a,c,l)2756 INT mult_longint_longint(a,c,l) OP a ,c,l;
2757 /* AK 310590 V1.1 */ /* AK 210891 V1.3 */
2758 {
2759 INT erg = OK;
2760 CTO(LONGINT,"mult_longint_longint(1)",a);
2761 CTO(LONGINT,"mult_longint_longint(2)",c);
2762 CTO(EMPTY,"mult_longint_longint(3)",l);
2763 erg += copy_longint(a,l);
2764 erg += ganzmul(S_O_S(l).ob_longint,S_O_S(c).ob_longint);
2765 /* longinteger-multiplikation ist x:= x*y */
2766 ENDR("mult_longint_longint");
2767 }
2768
2769
square_apply_longint(a)2770 INT square_apply_longint(a) OP a;
2771 /* AK 271101 */
2772 {
2773 INT erg = OK;
2774 OP c;
2775 CTO(LONGINT,"square_apply_longint(1)",a);
2776 c = CALLOCOBJECT();
2777 erg += copy_longint(a,c);
2778 erg += ganzmul(S_O_S(a).ob_longint,S_O_S(c).ob_longint);
2779 FREEALL(c);
2780 ENDR("square_apply_longint");
2781 }
2782
2783
absolute_longint(a,b)2784 INT absolute_longint(a,b) OP a,b;
2785 /* AK 150393 */
2786 {
2787 if (negp_longint(a))
2788 return addinvers_longint(a,b);
2789 return copy_longint(a,b);
2790 }
2791
2792
2793
addinvers_apply_longint(a)2794 INT addinvers_apply_longint(a) OP a;
2795 /* AK 201289 V1.1 */ /* AK 210891 V1.3 */
2796 {
2797 INT erg = OK;
2798 CTO(LONGINT,"addinvers_apply_longint(1)",a);
2799 GANZNEG(S_O_S(a).ob_longint);
2800 ENDR("addinvers_apply_longint");
2801 }
2802
2803
2804
ggt_longint_longint_sub(a,b,c)2805 INT ggt_longint_longint_sub(a,b,c) OP a,b,c;
2806 /* AK 021101
2807 fast als mit mod
2808 */
2809 /* ggt ist immer positiv */
2810 {
2811 INT erg = OK;
2812 INT t;
2813 OP d;
2814
2815 CTO(LONGINT,"ggt_longint_longint_sub(1)",a);
2816 CTO(LONGINT,"ggt_longint_longint_sub(2)",b);
2817 CTO(EMPTY,"ggt_longint_longint_sub(3)",c);
2818
2819 if (NULLP_LONGINT(a))
2820 {
2821 COPY(b,c);
2822 if (NEGP(c)) ADDINVERS_APPLY(c);
2823 goto endr_ende;
2824 }
2825 if (NULLP(b))
2826 {
2827 COPY(a,c);
2828 if (NEGP(c)) ADDINVERS_APPLY(c);
2829 goto endr_ende;
2830 }
2831
2832 d = CALLOCOBJECT();
2833 if (NEGP_LONGINT(a))
2834 erg += addinvers_longint(a,d);
2835 else
2836 COPY(a,d);
2837 if (NEGP(b))
2838 ADDINVERS(b,c);
2839 else
2840 COPY(b,c);
2841
2842
2843 while((t=COMP(d,c)) != 0) {
2844 if (t == 1) {
2845 ADDINVERS_APPLY(c);
2846 ADD_APPLY(c,d);
2847 ADDINVERS_APPLY(c);
2848 }
2849 else {
2850 ADDINVERS_APPLY(d);
2851 ADD_APPLY(d,c);
2852 ADDINVERS_APPLY(d);
2853 }
2854 }
2855 FREEALL(d);
2856 ENDR("ggt_longint_longint_sub");
2857 }
2858
ggt_longint(a,b,c)2859 INT ggt_longint(a,b,c) OP a,b,c;
2860 /* AK 191001 */
2861 /* ggt ist immer positiv */
2862 {
2863 INT erg = OK;
2864 CTO(LONGINT,"ggt_longint(1)",a);
2865 CTO(EMPTY,"ggt_longint(3)",c);
2866
2867 if (S_O_K(b) == INTEGER)
2868 erg += ggt_integer_longint(b,a,c);
2869 else if (S_O_K(b) == LONGINT)
2870 erg += ggt_longint_longint(a,b,c);
2871 else
2872 erg += WTO("ggt_longint(2)",b);
2873
2874 ENDR("ggt_longint");
2875 }
2876
ggt_longint_integer(a,b,c)2877 INT ggt_longint_integer(a,b,c) OP a,b,c;
2878 /* ggt ist immer positiv */
2879 {
2880 return ggt_integer_longint(b,a,c);
2881 }
2882
2883 INT oddify_longint();
2884
2885 #define ODDIFY(a)\
2886 /* a is even becomes odd */\
2887 /* a is not zero */\
2888 do { \
2889 if (S_O_K(a) == INTEGER) {\
2890 while (EVEN_INTEGER(a)) HALF_APPLY_INTEGER(a);\
2891 }\
2892 else if (S_O_K(a) == LONGINT) {\
2893 oddify_longint(a);\
2894 }\
2895 else {\
2896 do HALF_APPLY(a); while (EVEN(a));\
2897 } \
2898 } while(0)
2899
2900 #define ZEROBITS(a,b)\
2901 if (S_O_K(a) == INTEGER) { INT zbi=1;\
2902 b=0; while (not (zbi&S_I_I(a)) ) { b++; zbi <<=1; }\
2903 }\
2904 else /* LONGINT */ {\
2905 struct loc *alocx;\
2906 INT zbi=1;\
2907 b=0;\
2908 alocx = (S_O_S(a).ob_longint) -> floc;\
2909 do {\
2910 if (alocx -> w0 != 0) {\
2911 while (not (zbi&alocx -> w0) ) { b++; zbi <<=1; }\
2912 break;\
2913 }\
2914 else if (alocx -> w1 != 0) {\
2915 b+= 15;\
2916 while (not (zbi&alocx -> w1) ) { b++; zbi <<=1; }\
2917 break;\
2918 }\
2919 else if (alocx -> w2 != 0) {\
2920 b+= 30;\
2921 while (not (zbi&alocx -> w2) ) { b++; zbi <<=1; }\
2922 break;\
2923 }\
2924 else {\
2925 b += 45;\
2926 alocx = alocx->nloc;\
2927 }\
2928 } while(1); \
2929 }
2930
2931
ggt_longint_longint(a,b,d)2932 INT ggt_longint_longint(a,b,d) OP a,b,d;
2933 /* AK 010202 */
2934 /* always positive */
2935 {
2936 INT ah,bh,c,erg = OK;
2937 OP ac,bc;
2938 CTTO(LONGINT,INTEGER,"ggt_longint_longint(1)",a);
2939 CTTO(LONGINT,INTEGER,"ggt_longint_longint(2)",b);
2940 CTO(EMPTY,"ggt_longint_longint(3)",d);
2941
2942
2943 if (NULLP(a)) { COPY(b,d); goto ende; }
2944 if (NULLP(b)) { COPY(a,d); goto ende; }
2945
2946 ac = d;
2947 bc = CALLOCOBJECT();
2948 if (NEGP(a)) ADDINVERS(a,ac); else COPY(a,ac);
2949 if (NEGP(b)) ADDINVERS(b,bc); else COPY(b,bc);
2950
2951
2952 /*
2953 c =0;
2954 while (EVEN(ac) && EVEN(bc))
2955 {
2956 HALF_APPLY(ac);
2957 HALF_APPLY(bc);
2958 c++;
2959 }
2960 ODDIFY(ac);
2961 ODDIFY(bc);
2962 */
2963 ZEROBITS(ac,ah);
2964 ZEROBITS(bc,bh);
2965 c = ( ah >= bh ? bh : ah);
2966 if (S_O_K(ac) == INTEGER) psr_apply_i_integer(ac,ah);
2967 else psr_apply_i_longint(ac,ah);
2968 if (S_O_K(bc) == INTEGER) psr_apply_i_integer(bc,bh);
2969 else psr_apply_i_longint(bc,bh);
2970
2971 /* beide ungerade */
2972
2973 while (not EQ(ac,bc))
2974 if (GT(ac,bc))
2975 {
2976 sub_apply(bc,ac);
2977 ODDIFY(ac);
2978 }
2979 else
2980 {
2981 sub_apply(ac,bc);
2982 ODDIFY(bc);
2983 }
2984 /*
2985 while (c) { double_apply(ac) ; c--; }
2986 */
2987 if (S_O_K(ac) == INTEGER) psl_apply_i_integer(ac,c);
2988 else psl_apply_i_longint(ac,c);
2989
2990 FREEALL(bc);
2991
2992 ende:
2993 ENDR("ggt_longint_longint");
2994 }
2995
2996
mod_apply_integer_longint(a,b)2997 INT mod_apply_integer_longint(a,b) OP a,b;
2998 /* a is INTEGER
2999 b is longint
3000 a:= a mod b */
3001 {
3002 OP c,d;
3003 INT erg = OK;
3004 CTO(INTEGER,"mod_apply_integer_longint(1)",a);
3005 CTO(LONGINT,"mod_apply_integer_longint(2)",b);
3006
3007 c = CALLOCOBJECT();
3008 d = CALLOCOBJECT();
3009 SWAP(a,c);
3010 erg += quores_integer(c,b,d,a);
3011 FREEALL(c);
3012 FREEALL(d);
3013 ENDR("mod_apply_integer_longint");
3014 }
3015
mod_longint_integer_via_ganzsquores(a,b,c)3016 INT mod_longint_integer_via_ganzsquores(a,b,c) OP a,b,c;
3017 /* AK 300102 */
3018 /* c = a % b; */
3019 /* the result lies between zero and b , excluding b */
3020 {
3021 INT erg = OK;
3022 INT rest;
3023 OP ac;
3024 CTO(LONGINT,"mod_longint_integer(1)",a);
3025 CTO(INTEGER,"mod_longint_integer(2)",b);
3026 CTTO(INTEGER,EMPTY,"mod_longint_integer(3)",c);
3027 SYMCHECK(S_I_I(b) == 0,"mod_longint_integer:second parameter == 0");
3028 SYMCHECK(S_I_I(b) < 0,"mod_longint_integer:second parameter < 0");
3029 ac = CALLOCOBJECT();
3030 COPY(a,ac);
3031 erg += ganzsquores(S_O_S(ac).ob_longint,&rest,S_I_I(b));
3032 FREEALL(ac);
3033
3034 if (S_I_I(b) < 0)
3035 M_I_I(rest+S_I_I(b),c);
3036 else
3037 M_I_I(rest,c);
3038 CTO(INTEGER,"mod_longint_integer(e3)",c);
3039 ENDR("mod_longint_integer");
3040 }
3041
mod_longint_integer(a,b,c)3042 INT mod_longint_integer(a,b,c) OP a,b,c;
3043 /* AK 050202 */
3044 /* c = a % b; */
3045 /* the result lies between zero and b , excluding b */
3046 {
3047 INT erg = OK;
3048 INT rest,i;
3049 struct longint *x;
3050 struct loc *alocx;
3051 static int sp[12];
3052 CTO(LONGINT,"mod_longint_integer(1)",a);
3053 CTO(INTEGER,"mod_longint_integer(2)",b);
3054 CTTO(INTEGER,EMPTY,"mod_longint_integer(3)",c);
3055 SYMCHECK(S_I_I(b) == 0,"mod_longint_integer:second parameter == 0");
3056
3057 x = S_O_S(a).ob_longint;
3058 if (x->laenge > 4) {
3059 erg += mod_longint_integer_via_ganzsquores(a,b,c);
3060 goto ende;
3061 }
3062 if (S_I_I(b) >= 32768) {
3063 erg += mod_longint_integer_via_ganzsquores(a,b,c);
3064 goto ende;
3065 }
3066 if (S_I_I(b) <= -32768) {
3067 erg += mod_longint_integer_via_ganzsquores(a,b,c);
3068 goto ende;
3069 }
3070 i=0; alocx = x->floc;
3071 xx:
3072 sp[i++] = alocx->w0;
3073 sp[i++] = alocx->w1;
3074 sp[i++] = alocx->w2;
3075 if (alocx -> nloc) { alocx = alocx->nloc; goto xx; }
3076
3077 rest = 0;
3078 while (i--) rest = (rest * 32768 + sp[i]) % S_I_I(b);
3079
3080 if (S_I_I(b) < 0)
3081 M_I_I(rest+S_I_I(b),c);
3082 else
3083 M_I_I(rest,c);
3084
3085 ende:
3086 /* { OP d; d = CALLOCOBJECT();
3087 mod_longint_integer_via_ganzsquores(a,b,d);
3088 println(c);
3089 println(d);
3090 SYMCHECK(not EQ(c,d),"e2");
3091 FREEALL(d); } */
3092
3093 CTO(INTEGER,"mod_longint_integer(e3)",c);
3094 ENDR("mod_longint_integer");
3095 }
3096
3097
mod_apply_longint(a,b)3098 INT mod_apply_longint(a,b) OP a,b;
3099 /* a is of type LONGINT
3100 a = a mod b */
3101 /* AK 051001 */
3102 {
3103 INT erg = OK;
3104 CTO(LONGINT,"mod_apply_longint(1)",a);
3105
3106 if (S_O_K(b) == LONGINT)
3107 {
3108 OBJECTSELF as,bs,cs;
3109 OP c;
3110 c = CALLOCOBJECT();
3111 *c = *a;
3112 C_O_K(a,EMPTY);
3113 INIT_LONGINT(a);
3114 as = S_O_S(a);
3115 bs = S_O_S(b);
3116 cs = S_O_S(c);
3117 erg += ganzquores(cs.ob_longint, as.ob_longint, bs.ob_longint);
3118 if (NEGP_LONGINT(a))
3119 if (POSP_LONGINT(b))
3120 erg += ganzadd(as.ob_longint,bs.ob_longint);
3121 else
3122 {
3123 GANZNEG(bs.ob_longint);
3124 erg += ganzadd(as.ob_longint,bs.ob_longint);
3125 GANZNEG(bs.ob_longint);
3126 }
3127 /* now a is positiv */
3128 t_longint_int(a);
3129 FREEALL(c);
3130 }
3131 else if (S_O_K(b) == INTEGER)
3132 {
3133 OBJECTSELF as;
3134 INT rest;
3135 as = S_O_S(a);
3136 erg += ganzsquores(as.ob_longint,&rest,S_I_I(b));
3137 FREESELF(a);
3138 if (rest >= 0)
3139 M_I_I(rest,a);
3140 else if (S_I_I(b) > 0)
3141 M_I_I(rest+S_I_I(b),a);
3142 else
3143 M_I_I(rest-S_I_I(b),a);
3144 }
3145 else
3146 WTO("mod_apply_longint(2)",b);
3147 ENDR("mod_apply_longint");
3148 }
3149
ganzdiv_apply_longint_integer(a,b)3150 INT ganzdiv_apply_longint_integer(a,b) OP a,b;
3151 /* a = a/b
3152 a is of type longint */
3153 /* AK 081001 */
3154 {
3155 INT erg = OK;
3156 INT rest;
3157 CTO(LONGINT,"ganzdiv_apply_longint_integer(1)",a);
3158 CTO(INTEGER,"ganzdiv_apply_longint_integer(2)",b);
3159
3160 erg += ganzsquores(S_O_S(a).ob_longint,&rest,S_I_I(b));
3161 T_LONGINT_INT(a);
3162
3163 ENDR("ganzdiv_apply_longint_integer");
3164 }
3165
ganzdiv_apply_longint_longint(a,b)3166 INT ganzdiv_apply_longint_longint(a,b) OP a,b;
3167 /* a = a/b
3168 a is of type longint */
3169 /* AK 081001 */
3170 {
3171 INT erg = OK;
3172 OP c;
3173 CTO(LONGINT,"ganzdiv_apply_longint_longint(1)",a);
3174 CTO(LONGINT,"ganzdiv_apply_longint_longint(2)",b);
3175
3176 c = CALLOCOBJECT();
3177 INIT_LONGINT(c);
3178 erg += ganzquores(S_O_S(a).ob_longint, S_O_S(c).ob_longint, S_O_S(b).ob_longint);
3179 FREEALL(c);
3180 T_LONGINT_INT(a);
3181
3182 ENDR("ganzdiv_apply_longint_longint");
3183 }
3184
3185
ganzdiv_apply_longint(a,b)3186 INT ganzdiv_apply_longint(a,b) OP a,b;
3187 /* a = a/b
3188 a is of type longint */
3189 /* AK 081001 */
3190 {
3191 INT erg = OK;
3192 CTO(LONGINT,"ganzdiv_apply_longint(1)",a);
3193 if (S_O_K(b) == INTEGER)
3194 {
3195 erg += ganzdiv_apply_longint_integer(a,b);
3196 }
3197 else if (S_O_K(b) == LONGINT)
3198 {
3199 erg += ganzdiv_apply_longint_longint(a,b);
3200 }
3201 else
3202 WTO("ganzdiv_apply_longint",b);
3203 ee:
3204 ENDR("ganzdiv_apply_longint");
3205 }
3206
3207
ganzdiv_longint_longint(a,b,c)3208 INT ganzdiv_longint_longint(a,b,c) OP a,b,c;
3209 /* AK 291001 */
3210 {
3211 OP d;
3212 INT erg = OK;
3213 CTO(LONGINT,"ganzdiv_longint_longint(1)",a);
3214 CTO(LONGINT,"ganzdiv_longint_longint(2)",b);
3215 CTO(EMPTY,"ganzdiv_longint_longint(3)",c);
3216
3217 if (NULLP_LONGINT(a)) { /* AK 060502 */
3218 M_I_I(0,c);
3219 goto ee;
3220 }
3221
3222 erg += copy_longint(a,c);
3223 d = CALLOCOBJECT();
3224 INIT_LONGINT(d);
3225 erg += ganzquores(S_O_S(c).ob_longint,
3226 S_O_S(d).ob_longint,S_O_S(b).ob_longint);
3227 T_LONGINT_INT(c);
3228 FREEALL(d);
3229
3230 ee:
3231 ENDR("ganzdiv_longint_longint");
3232 }
3233
ganzdiv_longint_integer(a,b,c)3234 INT ganzdiv_longint_integer(a,b,c) OP a,b,c;
3235 /* AK 291001 */
3236 {
3237 INT d;
3238 INT erg = OK;
3239 CTO(LONGINT,"ganzdiv_longint_integer(1)",a);
3240 CTO(INTEGER,"ganzdiv_longint_integer(2)",b);
3241 CTO(EMPTY,"ganzdiv_longint_integer(3)",c);
3242
3243 if (NULLP_LONGINT(a)) { /* AK 060502 */
3244 M_I_I(0,c);
3245 goto ee;
3246 }
3247
3248 erg += copy_longint(a,c);
3249 erg += ganzsquores(S_O_S(c).ob_longint,&d, S_I_I(b));
3250 T_LONGINT_INT(c);
3251
3252 ee:
3253 ENDR("ganzdiv_longint_integer");
3254 }
3255
ganzdiv_integer_longint(a,b,c)3256 INT ganzdiv_integer_longint(a,b,c) OP a,b,c;
3257 /* AK 291001 */
3258 {
3259 OP d;
3260 INT erg = OK;
3261 CTO(LONGINT,"ganzdiv_longint_integer(2)",b);
3262 CTO(INTEGER,"ganzdiv_longint_integer(1)",a);
3263 CTO(EMPTY,"ganzdiv_longint_integer(3)",c);
3264 d = CALLOCOBJECT();
3265 erg += m_i_longint(S_I_I(a),d);
3266 CTO(LONGINT,"ganzdiv_integer_longint(id)",d);
3267 erg += ganzdiv_longint_longint(d,b,c);
3268 FREEALL(d);
3269
3270 ENDR("ganzdiv_integer_longint");
3271 }
3272
3273
3274
3275
addinvers_longint(a,l)3276 INT addinvers_longint(a,l) OP a,l;
3277 /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 201289 V1.1 */ /* AK 210891 V1.3 */
3278 {
3279 INT erg = OK;
3280 CTO(LONGINT,"addinvers_longint(1)",a);
3281 CTO(EMPTY,"addinvers_longint(2)",l);
3282
3283
3284 erg += copy_longint(a,l);
3285 GANZNEG(S_O_S(l).ob_longint);
3286 /* longinteger-addinvers ist x:= -x */
3287 ENDR("addinvers_longint");
3288 }
3289
invers_apply_longint(l)3290 INT invers_apply_longint(l) OP l;
3291 /* AK 040901 */
3292 {
3293 OP c;
3294 INT erg = OK;
3295 CTO(LONGINT,"invers_apply_longint(1)",l);
3296 if (einsp_longint(l))
3297 erg += m_i_i(1L,l);
3298 else {
3299 #ifdef BRUCHTRUE
3300 c = callocobject();
3301 erg += swap(l,c);
3302 erg += b_ou_b(callocobject(),c,l);
3303 M_I_I(1L,S_B_O(l));
3304 #endif /* BRUCHTRUE */
3305 }
3306 ENDR("invers_apply_longint");
3307 }
3308
3309
3310
add_apply_longint(a,b)3311 INT add_apply_longint(a,b) OP a,b;
3312 /* AK 120390 V1.1 */ /* AK 190291 V1.2 */ /* AK 210891 V1.3 */
3313 {
3314 INT erg = OK;
3315 CTO(LONGINT,"add_apply_longint(1)",a);
3316
3317 switch (S_O_K(b)) {
3318 #ifdef BRUCHTRUE
3319 case BRUCH:
3320 erg += add_apply_scalar_bruch(a,b);
3321 break;
3322 #endif /* BRUCHTRUE */
3323 case INTEGER:
3324 erg += add_apply_longint_integer(a,b);
3325 break;
3326 case LONGINT:
3327 erg += add_apply_longint_longint(a,b);
3328 break;
3329 default: /* AK 190291 */
3330 {
3331 OP c = callocobject();
3332 *c = *b;
3333 C_O_K(b,EMPTY);
3334 erg += add_longint(a,c,b);
3335 erg += freeall(c);
3336 }
3337 break;
3338 }
3339 ENDR("add_apply_longint");
3340 }
3341
3342
3343
3344 #ifdef MATRIXTRUE
mult_apply_longint_matrix(a,b)3345 INT mult_apply_longint_matrix(a,b) OP a,b;
3346 /* AK 220390 V1.1 */ /* AK 190291 V1.2 */ /* AK 210891 V1.3 */
3347 {
3348 OP z = S_M_S(b);
3349 INT i;
3350 INT erg=OK;
3351 CTO(LONGINT,"mult_apply_longint_matrix(1)",a);
3352 CTO(MATRIX,"mult_apply_longint_matrix(2)",b);
3353 i = S_M_HI(b)*S_M_LI(b);
3354 for(;i>0;i--,z++)
3355 erg += mult_apply_longint(a,z);
3356 ENDR("mult_apply_longint_matrix");
3357 }
3358 #endif /* MATRIXTRUE */
3359
3360
3361
mult_apply_longint(a,b)3362 INT mult_apply_longint(a,b) OP a,b;
3363 /* AK 080390 V1.1 */ /* AK 190291 V1.2 */ /* AK 210891 V1.3 */
3364 {
3365 INT erg = OK;
3366 CTO(LONGINT,"mult_apply_longint",a);
3367
3368 switch (S_O_K(b)) {
3369 #ifdef BRUCHTRUE
3370 case BRUCH:
3371 erg += mult_apply_longint_bruch(a,b);
3372 break;
3373 #endif /* BRUCHTRUE */
3374
3375 case INTEGER:
3376 erg += mult_apply_longint_integer(a,b);
3377 break;
3378
3379 case LONGINT:
3380 erg += mult_apply_longint_longint(a,b);
3381 break;
3382
3383 #ifdef MATRIXTRUE
3384 case KRANZTYPUS:
3385 case MATRIX:
3386 erg += mult_apply_longint_matrix(a,b);
3387 break;
3388 #endif /* MATRIXTRUE */
3389
3390 #ifdef CHARTRUE
3391 case SYMCHAR:
3392 erg += mult_apply_scalar_symchar(a,b);
3393 break;
3394 #endif /* CHARTRUE */
3395
3396 #ifdef POLYTRUE
3397 case MONOM:
3398 erg += mult_apply_scalar_monom(a,b);
3399 break;
3400 case SCHUR:
3401 case POW_SYM:
3402 case ELM_SYM:
3403 case HOM_SYM:
3404 case MONOMIAL:
3405 case SCHUBERT:
3406 case GRAL:
3407 case POLYNOM:
3408 case MONOPOLY:
3409 erg += mult_apply_longint_polynom(a,b);
3410 break;
3411 #endif /* POLYTRUE */
3412
3413 #ifdef NUMBERTRUE
3414 case SQ_RADICAL:
3415 erg += mult_apply_scalar_sqrad(a,b);
3416 break;
3417 case CYCLOTOMIC:
3418 erg += mult_apply_scalar_cyclo(a,b);
3419 break;
3420 #endif /* NUMBERTRUE */
3421 #ifdef VECTORTRUE
3422 case INTEGERVECTOR:
3423 case COMPOSITION:
3424 case WORD:
3425 case VECTOR:
3426 erg += mult_apply_scalar_vector(a,b);
3427 break;
3428 case HASHTABLE:
3429 erg += mult_apply_scalar_hashtable(a,b);
3430 break;
3431
3432 #endif /* VECTORTRUE */
3433
3434
3435 default: /* AK 190291 */
3436 {
3437 OP c = callocobject();
3438 INT erg=OK;
3439 *c = *b;
3440 C_O_K(b,EMPTY);
3441 erg += mult(a,c,b);
3442 erg += freeall(c);
3443 }
3444 }
3445 ENDR("mult_apply_longint");
3446 }
3447
3448
3449
add_apply_longint_longint(a,b)3450 INT add_apply_longint_longint(a,b) OP a,b;
3451 /* AK 120390 V1.1 */ /* AK 050791 V1.3 */ /* AK 210891 V1.3 */
3452 {
3453 INT erg = OK;
3454 CTO(LONGINT,"add_apply_longint_longint(1)",a);
3455 CTO(LONGINT,"add_apply_longint_longint(2)",b);
3456 if (GANZSIGNUM(S_O_S(a).ob_longint) == GANZSIGNUM(S_O_S(b).ob_longint))
3457 erg += ganzadd(S_O_S(b).ob_longint,S_O_S(a).ob_longint);
3458 else {
3459 erg += ganzadd(S_O_S(b).ob_longint,S_O_S(a).ob_longint);
3460 T_LONGINT_INT(b);
3461 }
3462 ENDR("add_apply_longint_longint");
3463 }
3464
3465
3466
mult_apply_longint_longint(a,b)3467 INT mult_apply_longint_longint(a,b) OP a,b;
3468 /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
3469 {
3470 INT erg = OK;
3471 OBJECTSELF as,bs;
3472 CTO(LONGINT,"mult_apply_longint_longint(1)",a);
3473 CTO(LONGINT,"mult_apply_longint_longint(2)",b);
3474 as = S_O_S(a);
3475 bs = S_O_S(b);
3476 erg += ganzmul(bs.ob_longint,as.ob_longint);
3477 ENDR("mult_apply_longint_longint");
3478 }
3479
3480
3481
3482
add_apply_longint_integer(a,b)3483 INT add_apply_longint_integer(a,b) OP a,b;
3484 /* AK 120390 V1.1 */ /* AK 050791 V1.3 */
3485 {
3486 INT erg = OK;
3487 OP c;
3488 CTO(LONGINT,"add_apply_longint_integer(1)",a);
3489 CTO(INTEGER,"add_apply_longint_integer(2)",b);
3490
3491 c = CALLOCOBJECT();
3492 *c = *b;
3493 C_O_K(b,EMPTY);
3494 erg += add_longint_integer(a,c,b);
3495 FREEALL(c);
3496 ENDR("add_apply_longint_integer");
3497 }
3498
3499
3500
mult_apply_longint_integer(a,b)3501 INT mult_apply_longint_integer(a,b) OP a,b;
3502 /* AK 080390 V1.1 */ /* AK 050791 V1.3 */
3503 {
3504 OP c;
3505 INT erg = OK;
3506 CTO(INTEGER,"mult_apply_longint_integer(2)",b);
3507 CTO(LONGINT,"mult_apply_longint_integer(1)",a);
3508
3509 c = CALLOCOBJECT();
3510 *c = *b;
3511 C_O_K(b,EMPTY);
3512 erg += mult_longint_integer(a,c,b);
3513 FREEALL(c);
3514
3515 CTTO(LONGINT,INTEGER,"mult_apply_longint_integer(e2)",b);
3516 /* INTEGER if b==0 */
3517 ENDR("mult_apply_longint_integer");
3518 }
3519
3520
3521
add_apply_integer_longint(a,b)3522 INT add_apply_integer_longint(a,b) OP a,b;
3523 /* b = a + b */ /* b ist LONGINT, a ist INTEGER */
3524 /* AK 120390 V1.1 */ /* AK 210891 V1.3 */
3525 {
3526 INT erg = OK;
3527 CTO(INTEGER,"add_apply_integer_longint(1)",a);
3528 CTO(LONGINT,"add_apply_integer_longint(2)",b);
3529
3530 erg += ganzsadd(S_O_S(b).ob_longint,S_I_I(a));
3531 T_LONGINT_INT(b);
3532
3533 ENDR("add_apply_integer_longint");
3534 }
3535
3536
mult_apply_integer_longint(a,b)3537 INT mult_apply_integer_longint(a,b) OP a,b;
3538 /* b = a * b */ /* b ist LONGINT, a ist INTEGER */
3539 /* AK 080290 V1.1 */ /* AK 210891 V1.3 */
3540 {
3541 INT erg = OK;
3542 CTO(INTEGER,"mult_apply_integer_longint(1)",a);
3543 CTO(LONGINT,"mult_apply_integer_longint(2)",b);
3544
3545 erg += ganzsmul(S_O_S(b).ob_longint,S_I_I(a));
3546
3547 ENDR("mult_apply_integer_longint");
3548 }
3549
3550
3551
mult_longint_integer_via_ganzsmul(a,c,l)3552 INT mult_longint_integer_via_ganzsmul(a,c,l) OP a,c,l;
3553 /* a ist LONINT c ist INTEGER */ /* AK 180888 */
3554 /* AK 130789 V1.0 */ /* AK 080290 V1.1 */ /* AK 210891 V1.3 */
3555 /* l = a+c */
3556 {
3557 INT erg = OK;
3558 OBJECTSELF ls;
3559 CTO(INTEGER,"mult_longint_integer(2)",c);
3560 CTO(LONGINT,"mult_longint_integer(1)",a);
3561 CTO(EMPTY,"mult_longint_integer(3)",l);
3562 erg += copy_longint(a,l);
3563 ls = S_O_S(l);
3564 erg += ganzsmul(ls.ob_longint,S_I_I(c));
3565 ENDR("mult_longint_integer");
3566 }
3567
3568
3569
add_longint_integer(a,c,l)3570 INT add_longint_integer(a,c,l) OP a,c,l;
3571 /* a is LONGINT c is INTEGER */ /* AK 180888 */
3572 /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
3573 {
3574 INT erg = OK;
3575 OBJECTSELF ls;
3576 CTO(LONGINT,"add_longint_integer(1)",a);
3577 CTO(INTEGER,"add_longint_integer(2)",c);
3578 CTO(EMPTY,"add_longint_integer(3)",l);
3579
3580 erg += copy_longint(a,l);
3581 ls = S_O_S(l);
3582 erg += ganzsadd(ls.ob_longint,S_I_I(c));
3583 /* longinteger-addition ist x:= x+y */
3584 erg += t_longint_int(l);
3585
3586 ENDR("add_longint_integer");
3587 }
3588
3589
dec_longint(a)3590 INT dec_longint(a) OP a;
3591 /* AK 230888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
3592 {
3593 OBJECTSELF as ;
3594 INT erg = OK;
3595 CTO(LONGINT,"dec_longint(1)",a);
3596 as = S_O_S(a);
3597 erg += ganzsadd(as.ob_longint,(INT)-1);
3598 ENDR("dec_longint");
3599 }
3600
3601
3602
inc_longint(a)3603 INT inc_longint(a) OP a;
3604 /* AK 230888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
3605 {
3606 OBJECTSELF as;
3607 INT erg = OK;
3608 CTO(LONGINT,"inc_longint(1)",a);
3609 as = S_O_S(a);
3610
3611 erg += ganzsadd(as.ob_longint,1);
3612 ENDR("inc_longint");
3613 }
3614
3615
3616
t_longint_int(a)3617 INT t_longint_int(a) OP a;
3618 /* AK 150290 V1.1 */ /* umwandlung in INTEGER falls moeglich */
3619 /* AK 210891 V1.3 */
3620 {
3621 OBJECTSELF cs;
3622 INT wert;
3623 INT erg = OK;
3624
3625 if (S_O_K(a) == INTEGER) return OK;
3626 CTO(LONGINT,"t_longint_int(1)",a);
3627
3628
3629 cs = S_O_S(a);
3630 if (cs.ob_longint ->laenge == (INT)1)
3631 if (cs.ob_longint ->floc ->w2 <= 1) /* AK 051101 */
3632 {
3633 wert = intganz(cs.ob_longint);
3634 FREESELF(a);
3635 M_I_I(wert,a);
3636 }
3637 ENDR("t_longint_int");
3638 }
3639
3640
3641
einsp_longint(a)3642 INT einsp_longint(a) OP a;
3643 /* AK 271190 V1.1 */ /* AK 250291 V1.2 */ /* AK 210891 V1.3 */
3644 {
3645 OBJECTSELF cs;
3646 cs = S_O_S(a);
3647 if (cs.ob_longint ->laenge == 1)
3648 if (cs.ob_longint ->signum == 1)
3649 if (cs.ob_longint ->floc ->w2 ==0)
3650 if (cs.ob_longint ->floc ->w1 ==0)
3651 if (cs.ob_longint ->floc ->w0 ==1)
3652 return TRUE;
3653 return FALSE;
3654 }
3655
negeinsp_longint(a)3656 INT negeinsp_longint(a) OP a;
3657 /* AK 070502 */
3658 {
3659 OBJECTSELF cs;
3660 cs = S_O_S(a);
3661 if (cs.ob_longint ->laenge == 1)
3662 if (cs.ob_longint ->signum == -1)
3663 if (cs.ob_longint ->floc ->w2 ==(INT)0)
3664 if (cs.ob_longint ->floc ->w1 ==(INT)0)
3665 if (cs.ob_longint ->floc ->w0 == (INT)1)
3666 return TRUE;
3667 return FALSE;
3668 }
3669
t_int_longint(a,c)3670 INT t_int_longint(a,c) OP a,c;
3671 /* umwandeln von INTEGER -> LONGINT AK 180888 */
3672 /* AK 130789 V1.0 */ /* AK 150290 V1.1 */ /* AK 250391 V1.2 */
3673 /* AK 210891 V1.3 */
3674 {
3675 /* it is possible a == c */
3676 INT erg = OK;
3677 INT av = S_I_I(a);
3678 struct longint *x;
3679
3680 CTO(INTEGER,"t_int_longint(1)",a);
3681
3682
3683 FREESELF(c);
3684 INIT_LONGINT(c);
3685 x = S_O_S(c).ob_longint;
3686 if (av==0) /* AK 060502 */
3687 {
3688 x->laenge = 0;
3689 x->signum = 0;
3690 FREE_LOC(x->floc);
3691 x->floc = NULL;
3692 goto ee;
3693 }
3694 x->laenge = 1;
3695
3696 if (av == MAXNEG) {
3697 x->signum = (signed char)locint(x->floc,av+1);
3698 ganzsadd(x,(INT)-1);
3699 }
3700 else
3701 x->signum = (signed char)locint(x->floc,av);
3702
3703 ee:
3704 CTO(LONGINT,"t_int_longint(e2)",c);
3705 ENDR("t_int_longint");
3706 }
3707
comp_longint_integer(a,c)3708 INT comp_longint_integer(a,c) OP a,c;
3709 /* AK 011101 */
3710 {
3711 INT erg = OK;
3712 CTO(LONGINT,"comp_longint(1)",a);
3713 CTO(INTEGER,"comp_longint(2)",c);
3714
3715
3716
3717 if (NEGP_LONGINT(a)) {
3718 if (not NEGP_INTEGER(c)) return -1;
3719 /* beide negativ */
3720 if (GANZLAENGE(S_O_S(a).ob_longint) > 1) return -1;
3721 if (GANZLAENGE(S_O_S(a).ob_longint) == 1)
3722 if ((S_O_S(a).ob_longint) -> floc -> w2 > 1 ) return -1;
3723 }
3724 else{
3725 if (NEGP_INTEGER(c)) return 1;
3726 /* beide positiv */
3727 if (GANZLAENGE(S_O_S(a).ob_longint) > 1) return 1;
3728 if (GANZLAENGE(S_O_S(a).ob_longint) == 1)
3729 if ((S_O_S(a).ob_longint) -> floc -> w2 > 1 ) return 1;
3730 }
3731
3732 T_LONGINT_INT(a);
3733 CTO(INTEGER,"comp_longint_integer(i1)",a);
3734 return COMP_INTEGER_INTEGER(a,c);
3735 ENDR("comp_longint_integer");
3736 }
3737
eq_longint_longint(a,b)3738 INT eq_longint_longint(a,b) OP a,b;
3739 /* AK 010202 */
3740 {
3741 INT erg = OK;
3742 struct longint *al, *bl;
3743 struct loc *locxa, *locxb;
3744
3745 CTO(LONGINT,"eq_longint_longint(1)",a);
3746 CTO(LONGINT,"eq_longint_longint(2)",b);
3747 al = S_O_S(a).ob_longint;
3748 bl = S_O_S(b).ob_longint;
3749 if (al -> signum != bl -> signum) return FALSE;
3750 if (al -> laenge != bl -> laenge) return FALSE;
3751 locxa = al->floc;
3752 locxb = bl->floc;
3753
3754
3755 while (locxa != NULL)
3756 {
3757 if ( (locxa->w0) != (locxb->w0)) return FALSE;
3758 if ( (locxa->w1) != (locxb->w1)) return FALSE;
3759 if ( (locxa->w2) != (locxb->w2)) return FALSE;
3760 locxa = locxa ->nloc;
3761 locxb = locxb ->nloc;
3762 }
3763
3764 return TRUE;
3765
3766
3767 ENDR("eq_longint_longint");
3768 }
3769
3770
comp_longint(a,c)3771 INT comp_longint(a,c) OP a,c;
3772 /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 050790 V1.1 */ /* AK 210891 V1.3 */
3773 {
3774 OP d;
3775 INT erg=OK;
3776 CTO(LONGINT,"comp_longint(1)",a);
3777
3778 switch(S_O_K(c))
3779 {
3780 case INTEGER: return comp_longint_integer(a,c);
3781 case LONGINT:
3782 {
3783 OBJECTSELF as,cs;
3784 as=S_O_S(a);
3785 cs=S_O_S(c);
3786 erg = ganzvergleich(as.ob_longint, cs.ob_longint);
3787 return(erg);
3788 }
3789 #ifdef BRUCHTRUE
3790 case BRUCH:
3791 {
3792 d = callocobject();
3793 m_scalar_bruch(a,d);
3794 erg = comp(d,c);
3795 freeall(d);
3796 return erg;
3797 }
3798 #endif /* BRUCHTRUE */
3799 default: {
3800 WTO("comp_longint(2)",c);
3801 break;
3802 }
3803 };
3804 ENDR("comp_longint");
3805 }
3806
3807
3808
check_longint(a)3809 INT check_longint(a) OP a;
3810 /* AK 071294 */
3811 /* test auf fuehrende Null */
3812 {
3813 OBJECTSELF cs;
3814 struct loc *alocx;
3815 if (S_O_K(a) != LONGINT) return OK;
3816
3817 cs = S_O_S(a);
3818 alocx = (cs.ob_longint)->floc;
3819 while (alocx != NULL)
3820 {
3821 if (alocx -> nloc == NULL)
3822 {
3823 if ((alocx->w0 == 0) &&
3824 (alocx->w1 == 0) &&
3825 (alocx->w2 == 0) )
3826
3827 error("internal error check_longint:");
3828 }
3829 alocx = alocx->nloc;
3830 }
3831 return OK;
3832 }
3833
half_apply_longint(a)3834 INT half_apply_longint(a) OP a;
3835 {
3836 INT erg = OK;
3837 CTO(LONGINT,"half_apply_longint(1)",a);
3838
3839 /* erg += ganzhalf(S_O_S(a).ob_longint); */
3840 psr_apply_i_longint(a,1);
3841
3842 ENDR("half_apply_longint");
3843 }
3844
psr_apply_i_integer(a,i)3845 INT psr_apply_i_integer(a,i) OP a; INT i;
3846 {
3847 INT erg = OK;
3848 CTO(INTEGER,"psr_apply_i_integer(1)",a);
3849 SYMCHECK(i<0,"psr_apply_i_integer:second parameter < 0");
3850 SYMCHECK(S_I_I(a)<0,"psr_apply_i_integer:first parameter < 0");
3851
3852 if (i >= 32) M_I_I(0,a);
3853 else M_I_I(S_I_I(a) >> i, a);
3854 CTO(INTEGER,"psr_apply_i_integer",a);
3855 ENDR("psr_apply_i_integer");
3856 }
3857
3858
psl_apply_i_integer(a,i)3859 INT psl_apply_i_integer(a,i) OP a; INT i;
3860 {
3861 INT erg = OK;
3862 CTO(INTEGER,"psl_apply_i_integer(1)",a);
3863 SYMCHECK(i<0,"psl_apply_i_integer:second parameter < 0");
3864 SYMCHECK(S_I_I(a)<0,"psl_apply_i_integer:first parameter < 0");
3865 if ( (S_I_I(a) < 32768) /* 2^15 */ && ( i < 16) )
3866 {
3867 M_I_I(S_I_I(a) << i, a);
3868 }
3869 else if ((S_I_I(a) < 8388608)/*2^23*/ && ( i < 8) ) {
3870 M_I_I(S_I_I(a) << i, a);
3871 }
3872 else if ((S_I_I(a) < 134217728)/*2^27*/ && ( i < 4) ) {
3873 M_I_I(S_I_I(a) << i, a);
3874 }
3875 else {
3876 erg += t_int_longint(a,a);
3877 erg += psl_apply_i_longint(a,i);
3878 }
3879 CTTO(INTEGER,LONGINT,"psl_apply_i_integer",a);
3880 ENDR("psl_apply_i_integer");
3881 }
3882
3883
psl_apply_i_longint(a,i)3884 INT psl_apply_i_longint(a,i) OP a; INT i;
3885 /* shift left i bits */
3886 /* multiplication by 2^i */
3887 {
3888 struct longint *l;
3889 struct loc *alocx;
3890 INT f,t,c,erg = OK;;
3891
3892 CTO(LONGINT,"psl_apply_i_longint(1)",a);
3893 SYMCHECK(i<0,"psl_apply_i_longint:second parameter < 0");
3894
3895 l = S_O_S(a).ob_longint;
3896
3897 again:
3898 alocx = l->floc;
3899 if (i >= 15) {
3900 t = 0;
3901 zz:
3902 f = alocx -> w2;
3903 alocx -> w2 = alocx -> w1;
3904 alocx -> w1 = alocx -> w0;
3905 alocx -> w0 = t;
3906 if (alocx -> nloc == NULL) {
3907 if ( f != 0 ) {
3908 LOCHOLE(& alocx -> nloc );
3909 alocx -> nloc -> w0 = f;
3910 l->laenge ++;
3911 }
3912 i -= 15;
3913 goto again;
3914 }
3915 alocx = alocx ->nloc;
3916 t = f;
3917 goto zz;
3918 }
3919 /* block shifted */
3920
3921 SYMCHECK(i >= 15,"psl_apply_i_longint(i1)");
3922 if (i==0) goto ende;
3923 c = 0;
3924 for (t=0;t<i;t++) { c>>=1; c|=16384;/* 2^15 */ }
3925 t=0;
3926
3927 xx:
3928 f = (alocx -> w2 & c) >> (15-i);;
3929
3930 alocx -> w2 <<=i;
3931 alocx -> w2 &= (BMINUSEINS);
3932 alocx -> w2 |= (alocx -> w1 & c ) >> (15-i);
3933 alocx -> w1 <<=i;
3934 alocx -> w1 &= (BMINUSEINS);
3935 alocx -> w1 |= (alocx -> w0 & c ) >> (15-i);
3936 alocx -> w0 <<=i;
3937 alocx -> w0 &= (BMINUSEINS);
3938 alocx -> w0 |= t;
3939 if (alocx ->nloc == NULL)
3940 {
3941 if ( f != 0 ) {
3942 LOCHOLE(& alocx -> nloc );
3943 alocx -> nloc -> w0 = f;
3944 l->laenge ++;
3945 }
3946 }
3947 else {
3948 t = f;
3949 alocx = alocx ->nloc;
3950 goto xx;
3951 }
3952 ende:
3953 CTO(LONGINT,"psl_apply_i_longint(e1)",a);
3954 ENDR("psl_apply_i_longint");
3955 }
3956
3957
psr_apply_i_longint(a,i)3958 INT psr_apply_i_longint(a,i) OP a; INT i;
3959 {
3960 struct longint *l;
3961 struct loc *alocx,*plocx;
3962 INT f,t,c,erg = OK;;
3963
3964 CTO(LONGINT,"psr_apply_i_longint(1)",a);
3965 SYMCHECK(i<0,"psr_apply_i_longint:second parameter < 0");
3966
3967 l = S_O_S(a).ob_longint;
3968
3969 again:
3970 alocx = l->floc;
3971 if (i >= 15) {
3972 zz:
3973 alocx -> w0 = alocx ->w1;
3974 alocx -> w1 = alocx ->w2;
3975 if (alocx -> nloc == NULL) {
3976 alocx ->w2 = 0;
3977 i -= 15;
3978 goto again;
3979 }
3980 else {
3981 alocx ->w2 = alocx -> nloc -> w0;
3982 if ( ( alocx -> nloc -> w1 == 0 ) && ( alocx -> nloc -> w2 == 0 )
3983 && ( alocx -> nloc -> nloc == NULL ) )
3984 {
3985 l -> laenge --;
3986 FREE_LOC(alocx -> nloc);
3987 alocx -> nloc = NULL;
3988 i -= 15;
3989 goto again;
3990 }
3991 alocx = alocx -> nloc;
3992 goto zz;
3993 }
3994 }
3995 /* block shifted */
3996
3997 SYMCHECK(i >= 15,"psr_apply_i_longint(i1)");
3998 if (i==0) goto ende;
3999 c = i; t=0; f = 15-i;
4000 while (i--) {t<<=1; t |= 1;}
4001
4002 /* now i bits shifted to the right */
4003 alocx -> w0 >>= c;
4004 alocx -> w0 |= ( ( alocx -> w1 & t ) << f );
4005 alocx -> w1 >>= c;
4006 alocx -> w1 |= ( ( alocx -> w2 & t ) << f );
4007 alocx -> w2 >>= c;
4008 if (alocx ->nloc != NULL)
4009 alocx -> w2 |= ( ( alocx ->nloc-> w0 & t ) << f );
4010
4011 plocx = alocx;
4012 alocx = alocx ->nloc;
4013 while (alocx != NULL) {
4014 alocx -> w0 >>= c;
4015 alocx -> w0 |= ( ( alocx -> w1 & t ) << f );
4016 alocx -> w1 >>= c;
4017 alocx -> w1 |= ( ( alocx -> w2 & t ) << f );
4018 alocx -> w2 >>= c;
4019 if (alocx ->nloc != NULL)
4020 alocx -> w2 |= ( ( alocx ->nloc-> w0 & t ) << f );
4021
4022
4023 if ( (alocx -> nloc == NULL) && (alocx->w0 == 0) &&
4024 (alocx->w1 == 0)&& (alocx->w2 == 0) )
4025 {
4026 l -> laenge --;
4027 FREE_LOC(alocx);
4028 plocx->nloc = NULL;
4029 goto ende;
4030 }
4031 plocx = alocx;
4032 alocx = alocx ->nloc;
4033 }
4034
4035 ende:
4036 T_LONGINT_INT(a);
4037 CTTO(INTEGER,LONGINT,"psr_apply_i_longint(e1)",a);
4038 ENDR("psr_apply_i_longint");
4039 }
4040
oddify_longint(a)4041 INT oddify_longint(a) OP a;
4042 {
4043 struct longint *l;
4044 struct loc *alocx,*plocx;
4045 INT f,t,c,erg = OK;;
4046 CTO(LONGINT,"oddify_longint(1)",a);
4047
4048 l = S_O_S(a).ob_longint;
4049
4050 again:
4051 alocx = l->floc;
4052
4053 if (alocx -> w0 == 0) {
4054 zz:
4055 alocx -> w0 = alocx ->w1;
4056 alocx -> w1 = alocx ->w2;
4057 if (alocx -> nloc == NULL) {
4058 alocx ->w2 = 0;
4059 goto again;
4060 }
4061 else {
4062 alocx ->w2 = alocx -> nloc -> w0;
4063 if ( ( alocx -> nloc -> w1 == 0 ) && ( alocx -> nloc -> w2 == 0 )
4064 && ( alocx -> nloc -> nloc == NULL ) )
4065 {
4066 l -> laenge --;
4067 FREE_LOC(alocx -> nloc);
4068 alocx -> nloc = NULL;
4069 goto again;
4070 }
4071 alocx = alocx -> nloc;
4072 goto zz;
4073 }
4074 }
4075
4076
4077 c = 0; t=0; f=15;
4078 /* max 14 bits */
4079 while ( not (alocx -> w0 & 1) ) { c++; alocx -> w0 >>= 1; t<<=1; t |= 1; f--;}
4080
4081 if (c == 0) goto ende;
4082
4083 alocx -> w0 |= ( ( alocx -> w1 & t ) << f );
4084 alocx -> w1 >>= c;
4085 alocx -> w1 |= ( ( alocx -> w2 & t ) << f );
4086 alocx -> w2 >>= c;
4087 if (alocx ->nloc != NULL)
4088 alocx -> w2 |= ( ( alocx ->nloc-> w0 & t ) << f );
4089
4090 plocx = alocx;
4091 alocx = alocx ->nloc;
4092 while (alocx != NULL) {
4093 alocx -> w0 >>= c;
4094 alocx -> w0 |= ( ( alocx -> w1 & t ) << f );
4095 alocx -> w1 >>= c;
4096 alocx -> w1 |= ( ( alocx -> w2 & t ) << f );
4097 alocx -> w2 >>= c;
4098 if (alocx ->nloc != NULL)
4099 alocx -> w2 |= ( ( alocx ->nloc-> w0 & t ) << f );
4100
4101 if ( (alocx -> nloc == NULL) && (alocx->w0 == 0) &&
4102 (alocx->w1 == 0)&& (alocx->w2 == 0) )
4103 {
4104 l -> laenge --;
4105 FREE_LOC(alocx);
4106 plocx->nloc = NULL;
4107 goto ende;
4108 }
4109 plocx = alocx;
4110 alocx = alocx ->nloc;
4111 }
4112
4113 ende:
4114 t_longint_int(a);
4115 SYMCHECK(EVEN(a),"oddify_longint(e1)");
4116 CTTO(INTEGER,LONGINT,"oddify_longint(e1)",a);
4117 ENDR("oddify_longint");
4118 }
4119
4120
psl_apply_longint(a)4121 INT psl_apply_longint(a) OP a; /* double */
4122 {
4123 INT erg = OK;
4124 CTO(LONGINT,"psl_apply_longint(1)",a);
4125 erg += psl_apply_i_longint(a,1);
4126 CTO(LONGINT,"psl_apply_longint(e1)",a);
4127 ENDR("psl_apply_longint");
4128 }
4129
4130
double_apply_longint(a)4131 INT double_apply_longint(a) OP a;
4132 /* AK 010202 */
4133 {
4134 INT erg = OK;
4135 CTO(LONGINT,"double_apply_longint(1)",a);
4136 erg += psl_apply_longint(a);
4137 ENDR("double_apply_longint");
4138 }
4139
4140
quores_longint(a,e,c,d)4141 INT quores_longint(a,e,c,d) OP a,e,c,d;
4142 /* ganzdiv AK 220888 */ /* c = a / e */
4143 /* d ist rest */
4144 /* AK 130789 V1.0 */ /* AK 150290 V1.1 */ /* AK 210891 V1.3 */
4145 {
4146 INT erg = OK;
4147 CTO(LONGINT,"quores_longint(1)",a);
4148 CTO(EMPTY,"quores_longint(3)",c);
4149 CTO(EMPTY,"quores_longint(4)",d);
4150 switch (S_O_K(e))
4151 {
4152 case INTEGER:
4153 {
4154 OBJECTSELF cs;
4155 INT rest;
4156 erg += copy_longint(a,c);
4157 cs = S_O_S(c);
4158 erg += ganzsquores(cs.ob_longint,&rest,S_I_I(e));
4159 erg += t_longint_int(c);
4160 M_I_I(rest,d);
4161 goto ql_040393;
4162 }
4163 case LONGINT:
4164 {
4165 OBJECTSELF es,cs,ds;
4166 erg += copy_longint(a,c);
4167 INIT_LONGINT(d);
4168 cs = S_O_S(c);
4169 es = S_O_S(e);
4170 ds = S_O_S(d);
4171 erg += ganzquores(cs.ob_longint,
4172 ds.ob_longint,es.ob_longint);
4173 erg += t_longint_int(c);
4174 erg += t_longint_int(d);
4175 goto ql_040393;
4176 }
4177 default:
4178 {
4179 WTO("quores_longint(2)",e);
4180 goto ende;
4181 }
4182 };
4183 ql_040393:
4184 if (negp(d))
4185 if (posp(e))
4186 {
4187 erg += add_apply(e,d);
4188 erg += dec(c);
4189 }
4190 else if (negp(e))
4191 {
4192 erg += sub(d,e,d);
4193 erg += inc(c);
4194 }
4195 ende:
4196 ENDR("quores_longint");
4197 }
4198
4199
4200
4201
scan_longint(a)4202 INT scan_longint(a) OP a;
4203 /* AK 180888 */ /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
4204 {
4205 OBJECTSELF as;
4206
4207 printeingabe("longint:");
4208 init(LONGINT,a);as=S_O_S(a);
4209 ganzein(stdin,as.ob_longint);
4210 if (nullp_longint(a) ) { /* AK 020889 V1.0 */
4211 M_I_I((INT)0,a);
4212 }
4213 return(OK);
4214 }
4215
4216
4217
posp_longint(a)4218 INT posp_longint(a) OP a;
4219 /* AK 190888 */ /* AK 280689 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
4220 /* true if a > 0 */
4221 {
4222 OBJECTSELF as;
4223 as=S_O_S(a);
4224 return GANZSIGNUM(as.ob_longint) == (INT)1;
4225 }
4226
4227
4228
odd_longint(a)4229 INT odd_longint(a) OP a;
4230 /* AK 061190 V1.1 */ /* AK 210891 V1.3 */
4231 {
4232 OBJECTSELF as;
4233 as=S_O_S(a);
4234 return ganzodd(as.ob_longint);
4235 }
4236
4237
4238
even_longint(a)4239 INT even_longint(a) OP a;
4240 /* AK 061190 V1.1 */ /* AK 210891 V1.3 */
4241 {
4242 OBJECTSELF as;
4243 as=S_O_S(a);
4244 return ganzeven(as.ob_longint);
4245 }
4246
4247
nullp_longint(a)4248 INT nullp_longint(a) OP a;
4249 /* AK 190888 */ /* AK 280689 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
4250 {
4251 INT s;
4252 INT erg = OK;
4253 OBJECTSELF as;
4254 CTO(LONGINT,"nullp_longint(1)",a);
4255 as=S_O_S(a);
4256 s = GANZSIGNUM(as.ob_longint);
4257 if (s != 0) return FALSE;
4258 SYMCHECK ((as.ob_longint)->laenge != 0,"nullp_longint:zero wioth wrong length");
4259 return TRUE;
4260 ENDR("nullp_longint");
4261 }
4262
4263
4264
4265
negp_longint(a)4266 INT negp_longint(a) OP a;
4267 /* AK 190888 */ /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
4268 {
4269 OBJECTSELF as;
4270 as=S_O_S(a);
4271 return(GANZSIGNUM(as.ob_longint) == -1);
4272 }
4273
4274
4275
objectread_longint(f,l)4276 INT objectread_longint(f,l) FILE *f; OP l;
4277 /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
4278 {
4279 OBJECTSELF ls;
4280 INT erg = OK;
4281 COP("objectread_longint(1)",f);
4282 CTO(EMPTY,"objectread_longint(2)",l);
4283
4284 erg += init(LONGINT,l);
4285 ls=S_O_S(l);
4286 erg += ganzein(f, ls.ob_longint);
4287 ENDR("objectread_longint");
4288 }
4289
4290
4291
objectwrite_longint(f,l)4292 INT objectwrite_longint(f,l) FILE *f; OP l;
4293 /* AK 130789 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
4294 {
4295 INT erg = OK;
4296 OBJECTSELF ls;
4297
4298 COP("objectwrite_longint(1)",f);
4299 CTO(LONGINT,"objectwrite_longint(2)",l);
4300
4301 if (nullp_longint(l)) { /* AK 020889 V1.0 */
4302 erg += m_i_i((INT)0,l);
4303 erg += objectwrite_integer(f,l);
4304 goto owlende;
4305 }
4306
4307 fprintf(f," %ld ",LONGINT);
4308 ls=S_O_S(l);
4309 erg += ganzaus(f, ls.ob_longint);
4310 fprintf(f,"\n");
4311 owlende:
4312 ENDR("objectwrite_longint");
4313 }
4314
4315
4316
m_i_longint(a,b)4317 INT m_i_longint(a,b) OP b;INT a;
4318 /* AK 180888 */ /* AK 270689 V1.0 */ /* AK 080390 V1.1 */ /* AK 210891 V1.3 */
4319 {
4320 OP c;
4321 INT erg = OK;
4322 COP("m_i_longint(2)",b);
4323 c = CALLOCOBJECT();
4324 M_I_I(a,c); /* make INT --> INTEGER */
4325 erg += t_int_longint(c,b); /* transform INTEGER --> LONGINT */
4326 FREEALL(c);
4327 CTO(LONGINT,"m_i_longint(e2)",b);
4328 ENDR("m_i_longint");
4329 }
4330
4331
4332
debugprint_longint(a)4333 INT debugprint_longint(a) OP a;
4334 /* AK 020390 V1.1 */ /* AK 210891 V1.3 */
4335 {
4336 OBJECTSELF c;
4337 INT k;
4338 struct loc *alocx;
4339 c = s_o_s(a);
4340 for (k=0L;k<doffset;k++) fprintf(stderr," ");
4341 fprintf(stderr,"kind:22=longint\n");
4342 for (k=0L;k<doffset;k++) fprintf(stderr," ");
4343 fprintf(stderr, "laenge = %" PRIINT "\n" ,
4344 c.ob_longint->laenge);
4345 for (k=0L;k<doffset;k++) fprintf(stderr," ");
4346 fprintf(stderr, "signum = %" PRIINT "\n" ,
4347 c.ob_longint->signum);
4348 alocx = c.ob_longint->floc; /* AK 071294 */
4349 while (alocx != NULL)
4350 {
4351 for (k=0L;k<doffset;k++) fprintf(stderr," ");
4352 fprintf(stderr, "%" PRIINT " %" PRIINT " %" PRIINT "\n" ,alocx->w0,alocx->w1,alocx->w2);
4353 alocx= alocx->nloc;
4354 }
4355 return(OK);
4356 }
4357
sscan_longint(t,a)4358 INT sscan_longint(t,a) char *t; OP a;
4359 {
4360 INT erg = OK;
4361 INT vz=(INT)1;
4362 char c;
4363 OP zehn, faktor;
4364 int SYM_isdigit();
4365
4366 COP("sscan_longint(1)",t);
4367 CTO(EMPTY,"sscan_longint(2)",a);
4368
4369 zehn = callocobject();
4370 M_I_I((INT)10,zehn);
4371 faktor = callocobject();
4372 m_i_i((INT)0,a);
4373 slagain:
4374 c = *t++;
4375 if (c == '\0')
4376 {
4377 erg = ERROR;
4378 goto sle;
4379 }
4380 if (c == ' ')
4381 goto slagain;
4382 if (c == '-')
4383 {
4384 if (vz == (INT)-1) { erg = ERROR; goto sle; }
4385 vz = (INT)-1;
4386 goto slagain;
4387 }
4388 if (not SYM_isdigit(c))
4389 {
4390 erg = ERROR;
4391 goto sle;
4392 }
4393 slb:
4394 erg += mult_apply(zehn,a);
4395 erg += m_i_i((INT)9-('9'-c),faktor);
4396 erg += add_apply(faktor,a);
4397 c = *t++;
4398 if (c == '\0')
4399 {
4400 goto sle;
4401 }
4402 if (not SYM_isdigit(c))
4403 {
4404 erg = ERROR;
4405 goto sle;
4406 }
4407 goto slb;
4408 sle:
4409 erg += freeall(zehn);
4410 erg += freeall(faktor);
4411 if (vz == (INT)-1)
4412 erg += addinvers_apply(a);
4413 ENDR("sscan_longint");
4414 }
4415
4416
4417
4418
test_longint()4419 INT test_longint() {
4420 /* AK 020390 V1.1 */ /* AK 210891 V1.3 */
4421 OP a = callocobject();
4422 OP b = callocobject();
4423 OP c = callocobject();
4424
4425 start_longint();
4426 printf("test_longint:scan(a)"); scan(LONGINT,a);println(a);
4427 printf("test_longint:add(a,a,b)"); add(a,a,b); println(b);
4428 printf("test_longint:mult(a,b,b)"); mult(a,b,b); println(b);
4429 printf("test_longint:m_i_i((INT)-1,c);mult(c,b,b)");
4430 m_i_i((INT)-1,c); mult(c,b,b); println(b);
4431 printf("test_longint:m_i_i((INT)-1,c);add(c,b,b)");
4432 m_i_i((INT)-1,c); add(c,b,b); println(b);
4433 #ifdef BRUCHTRUE
4434 printf("test_longint:invers(b,a)"); invers(b,a); println(a);
4435 #endif /* BRUCHTRUE */
4436 printf("test_longint:mult(b,a,a)"); mult(b,a,a); println(a);
4437
4438 printf("test_longint:m_i_i((INT)3,c);div(a,c,b)");
4439 m_i_i((INT)3,c); div(a,c,b); println(b);
4440 printf("test_longint:m_i_i((INT)100,c);fakul(c,b)");
4441 m_i_i((INT)100,c); fakul(c,b); println(b);
4442
4443 freeall(a);freeall(b);freeall(c);
4444 return(OK);
4445 }
4446
random_longint(res,ober)4447 INT random_longint(res,ober) OP res,ober;
4448 /* AK 080390 V1.1 */
4449 /* ober ist beim ersten aufruf die obere grenze, spater NULL */
4450 /* AK 210891 V1.3 */
4451 {
4452 INT l,i;
4453 INT erg = OK; /* AK 030893 */
4454 OP h1,h2,h3;
4455
4456 COP("random_longint(1)",res);
4457
4458 if (ober == NULL) {
4459 if (rl_o == NULL) return(
4460 error("random_longint: no initialisation"));
4461 }
4462 else {
4463 CTO(LONGINT,"random_longint(2)",ober);
4464 if (rl_o == NULL) {
4465 rl_o=callocobject();
4466 rl_a=callocobject();
4467 rl_x=callocobject();
4468 rl_m=callocobject();
4469 }
4470 else {
4471 erg += freeself(rl_o);
4472 erg += freeself(rl_a);
4473 erg += freeself(rl_x);
4474 erg += freeself(rl_m);
4475 }
4476 erg += copy(ober,rl_o);
4477 h1 = callocobject();
4478 h2 = callocobject();
4479 h3 = callocobject();
4480 l = (S_O_S(ober).ob_longint->laenge) * 3 ; /* laenge */
4481 erg += m_i_i((INT)10,rl_m);
4482 erg += m_i_i(l*(INT)6,h1);
4483 erg += hoch(rl_m,h1,rl_m);
4484 erg += m_i_i((INT)222222,rl_a);
4485 erg += m_i_i((INT)1000000,h2);
4486 erg += m_i_i((INT)222222,h1);
4487 erg += m_i_i((INT)0,rl_x);
4488 for (i=1;i<=l;i++)
4489 {
4490 MULT_APPLY(h2,rl_a);
4491 ADD_APPLY(h1,rl_a);
4492 erg += random_integer(h3,NULL,h2);
4493 MULT_APPLY(h2,rl_x);
4494 ADD_APPLY(h3,rl_x);
4495 }
4496 erg += mod(rl_x,rl_o,res);
4497 erg += freeall(h1);
4498 erg += freeall(h2);
4499 erg += freeall(h3);
4500 goto rl_ende;
4501 }
4502 /* dies ist der fall dass initialisiert ist */
4503 h1 = callocobject();
4504 erg += mult(rl_x,rl_a,h1);
4505 erg += mod(h1,rl_m,rl_x);
4506 erg += mod(rl_x,rl_o,res);
4507 FREEALL(h1);
4508 rl_ende:
4509 ENDR("random_longint");
4510 }
4511
4512 #endif /* LONGINTTRUE */
4513