|
|
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: lam4.c,v 1.5 83/12/28 16:21:08 sklower Exp $";
4: #endif
5:
6: /* -[Sun Jun 19 22:25:48 1983 by jkf]-
7: * lam4.c $Locker: $
8: * lambda functions
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13:
14: #include "global.h"
15: lispval adbig(),subbig(),mulbig();
16: double Ifloat();
17: lispval
18: Ladd()
19: {
20: register lispval work;
21: register struct argent *result, *mynp, *oldnp;
22: long restype,prunep,hi,lo=0;
23: struct sdot dummybig;
24: double flacc;
25: Savestack(4);
26:
27: oldnp = result = np;
28: restype = INT; /* now start as integers */
29: protect(nil);
30:
31: for(mynp = lbot; mynp < oldnp; mynp++)
32: {
33: work = mynp->val;
34: switch(TYPE(work)) {
35: case INT:
36: switch(restype) {
37: case SDOT:
38: dmlad(result->val,1L,work->i);
39: prunep = TRUE;
40: /* In adding the fixnum to the sdot we may make it
41: possible for the bignum to be represented as a fixnum */
42: break;
43: case INT:
44: if(exarith(lo,1L,work->i,&hi,&lo)) {
45: work = result->val = newsdot();
46: work->s.I = lo;
47: work = work->s.CDR = newdot();
48: work->s.I = hi;
49: work->s.CDR = 0;
50: restype = SDOT; prunep = FALSE;
51: }
52: break;
53: case DOUB:
54: result->val->r += work->i;
55: break;
56: default: goto urk;
57: }
58: break;
59: case SDOT:
60: switch(restype) {
61: case INT:
62: dummybig.I = lo;
63: dummybig.CDR = 0;
64: work=adbig(work,(lispval)&dummybig);
65: goto code1;
66: case SDOT:
67: work=adbig(work,result->val);
68: /* previous result is no longer needed */
69: pruneb(result->val);
70: code1:
71: restype = TYPE(work); /* SDOT or INT */
72: if(restype==INT) {
73: lo = work->i;
74: prunei(work);
75: } else {
76: prunep = FALSE; /* sdot is cannonical */
77: result->val = work;
78: } break;
79: case DOUB:
80: result->val->r += Ifloat(work);
81: break;
82: default: goto urk;
83: }
84: break;
85: case DOUB:
86: switch(restype) {
87: case SDOT:
88: if(prunep) {
89: lispval handy;
90: dummybig.I = 0;
91: dummybig.CDR = (lispval) 0;
92: handy = adbig((lispval)&dummybig,result->val);
93: pruneb(result->val);
94: result->val = handy;
95: }
96: flacc = Ifloat(result->val) + work->r;
97: pruneb(result->val);
98: scrimp:
99: (result->val = newdoub())->r = flacc;
100: restype = DOUB;
101: break;
102: case INT:
103: flacc = work->r + lo;
104: goto scrimp;
105: case DOUB:
106: result->val->r += work->r;
107: break;
108: default: goto urk;
109: }
110: break;
111: default:
112: errorh1(Vermisc,"Non-number to add",nil,0,FALSE,work);
113: }
114: }
115: work = result->val;
116: switch(restype){
117: case DOUB:
118: break;
119: case INT:
120: work=inewint(lo);
121: break;
122: case SDOT:
123: if(prunep) {
124: /* wouldn't (copy result->val) be faster ? -dhl */
125: /* It might, but isn't guaranteed to canonicalize */
126:
127: dummybig.I = 0;
128: dummybig.CDR = (lispval) 0;
129: work = adbig((lispval)&dummybig,work);
130: }
131: break;
132: default:
133: urk:
134: error("Internal error in add ",FALSE);
135: }
136: Restorestack();
137: return(work);
138: }
139:
140: /* exarith(a,b,c,lo,hi)
141: * int a,b,c;
142: * int *lo, *hi;
143: * Exact arithmetic.
144: * a,b and c are 32 bit 2's complement integers
145: * calculates x=a*b+c to twice the precision of an int.
146: * In the vax version, the 30 low bits only are returned
147: * in *lo,and the next 32 bits of precision are returned in * hi.
148: * this works since exarith is used either for calculating the sum of
149: * two 32 bit numbers, (which is at most 33 bits), or
150: * multiplying a 30 bit number by a 32 bit numbers,
151: * which has a maximum precision of 62 bits.
152: * If *phi is 0 or -1 then
153: * x doesn't need any more than 31 bits plus sign to describe, so we
154: * place the sign in the high two bits of *plo and return 0 from this
155: * routine. A non zero return indicates that x requires more than 31 bits
156: * to describe.
157: *
158: * The definition has been moved to vax.c.
159: */
160:
161:
162: lispval
163: Lsub()
164: {
165: register lispval work;
166: register struct argent *result, *mynp, *oldnp;
167: long prunep,restype,hi,lo=0;
168: struct sdot dummybig;
169: double flacc;
170: lispval Lminus();
171: Savestack(4);
172:
173: oldnp = result = np;
174: mynp = lbot + 1;
175: restype = INT;
176: prunep = TRUE;
177: if(oldnp==lbot)
178: goto out;
179: if(oldnp==mynp) {
180: work = Lminus();
181: Restorestack();
182: return(work);
183: }
184: protect(nil);
185: work = lbot->val;
186:
187: /* examine the first argument and perhaps set restype to the
188: * correct type. If restype (result type) is INT, then the
189: * fixnum value is stored in lo. Otherwise, if restype is
190: * SDOT or DOUB, then the value is stored in result->val.
191: */
192: switch(TYPE(work)) {
193: case INT:
194: lo = work->i;
195: restype = INT;
196: break;
197: case SDOT:
198: /* we want to copy the sdot we are given as an argument since
199: * the bignum arithmetic routine dmlad clobbers the values it
200: * is given.
201: */
202: dummybig.I = 0; /* create a zero sdot */
203: dummybig.CDR = 0;
204: work = adbig(work,(lispval)&dummybig);
205: /* the resulting value may have been reduced from an
206: * sdot to a fixnum. This should never happen though
207: * but if it does, we simplify things.
208: */
209: restype = TYPE(work);
210: if(restype==INT) {
211: lo = work->i; /* has turned into an fixnum */
212: prunei(work); /* return fixnum cell */
213: } else {
214: prunep = FALSE; /* sdot is cannonical */
215: result->val = work;
216: }
217: break;
218:
219: case DOUB:
220: (result->val = newdoub())->r = work->r;
221: restype = DOUB;
222: }
223:
224: /* now loop through the rest of the arguments subtracting them
225: * from the running result in result or lo
226: */
227: for(; mynp < oldnp; mynp++)
228: {
229: work = mynp->val;
230: switch(TYPE(work)) {
231: case INT:
232: switch(restype) {
233: case SDOT:
234: /* subtracting a fixnum from an bignum
235: * use the distructive multiply (by 1)
236: * and add the negative of the work value.
237: * The result will still be pointed to
238: * by result->val
239: */
240: dmlad(result->val,1L, -work->i);
241: prunep = TRUE; /* check up on exiting */
242: break; /* that it didn't collapse */
243: case INT:
244: /* subtracting a fixnum from a fixnum,
245: * the result could turn into a bignum
246: */
247: if(exarith(lo,1L,-work->i,&hi,&lo)) {
248: work = result->val = newsdot();
249: work->s.I = lo;
250: work = work->s.CDR = newdot();
251: work->s.I = hi;
252: work->s.CDR = 0;
253: restype = SDOT; prunep = TRUE;
254: }
255: break;
256: case DOUB:
257: /* subtracting a fixnum from a flonum */
258: result->val->r -= work->i;
259: break;
260: default:
261: goto urk;
262: }
263: break;
264: case SDOT:
265: switch(restype) {
266: case INT:
267: /* subtracting a bignum from an integer
268: * first make a bignum of the integer and
269: * then fall into the next case
270: */
271: dummybig.I = lo;
272: dummybig.CDR = (lispval) 0;
273: work = subbig((lispval)&dummybig,work);
274: goto on1;
275:
276: case SDOT:
277: /* subtracting one bignum from another. The
278: * routine to do this ends up calling addbig
279: * and should probably be written specifically
280: * for subtraction.
281: */
282: work = subbig(result->val,work);
283: pruneb(result->val);
284: on1:
285: /* check if the result has turned into a fixnum */
286: restype = TYPE(work);
287: if(restype==INT) {
288: lo = work->i; /* it has */
289: prunei(work);
290: } else {
291: prunep = FALSE; /* sdot is cannonical */
292: result->val = work;
293: }
294: break;
295: case DOUB: /* Subtract bignum from float */
296: /* Death on overflow */
297: result->val->r -= Ifloat(work);
298: break;
299: default:
300: goto urk;
301: }
302: break;
303:
304: case DOUB:
305: switch(restype) {
306: case SDOT: /* subtracting a flonum from a bignum. */
307:
308: if(prunep) {
309: lispval handy;
310: dummybig.I = 0;
311: dummybig.CDR = (lispval) 0;
312: handy = adbig((lispval)&dummybig,result->val);
313: pruneb(result->val);
314: result->val = handy;
315: }
316: flacc = Ifloat(result->val) - work->r;
317: pruneb(result->val);
318: scrimp: (result->val = newdoub())->r = flacc;
319: restype = DOUB;
320: break;
321: case INT:
322: /* subtracting a flonum from an fixnum.
323: * The result will be an flonum.
324: */
325: flacc = lo - work->r;
326: goto scrimp;
327: case DOUB:
328: /* subtracting a flonum from a flonum, what
329: * could be easier?
330: */
331: result->val->r -= work->r;
332: break;
333: default:
334: goto urk;
335: }
336: break;
337: default:
338: errorh1(Vermisc,"Non-number to minus",nil,FALSE,0,work);
339: }
340: }
341: out:
342: work = result->val;
343: switch(restype){
344: case DOUB:
345: break;
346: case INT:
347: work = inewint(lo);
348: break;
349: case SDOT:
350: if(prunep) {
351: dummybig.I = 0;
352: dummybig.CDR = (lispval) 0;
353: work = adbig((lispval)&dummybig,work);
354: }
355: break;
356: default:
357: urk:
358: error("Internal error in difference",FALSE);
359: }
360: Restorestack();
361: return(work);
362: }
363:
364: lispval
365: Ltimes()
366: {
367: register lispval work;
368: register struct argent *result, *mynp, *oldnp;
369: long restype,prunep,hi,lo=1;
370: struct sdot dummybig;
371: double flacc;
372: Savestack(4);
373:
374: oldnp = result = np;
375: restype = INT; /* now start as integers */
376: prunep = TRUE;
377: protect(nil);
378:
379: for(mynp = lbot; mynp < oldnp; mynp++)
380: {
381: work = mynp->val;
382: switch(TYPE(work)) {
383: case INT:
384: switch(restype) {
385: case SDOT:
386: dmlad(result->val,work->i,0L);
387: prunep = TRUE;
388: /* In adding the fixnum to the sdot we may make it
389: possible for the bignum to be represented as a fixnum */
390: break;
391: case INT:
392: if(exarith(lo,work->i,0L,&hi,&lo)) {
393: work = result->val = newsdot();
394: work->s.I = lo;
395: work = work->s.CDR = newdot();
396: work->s.I = hi;
397: work->s.CDR = 0;
398: restype = SDOT; prunep = TRUE;
399: }
400: break;
401: case DOUB:
402: result->val->r *= work->i;
403: break;
404: default: goto urk;
405: }
406: break;
407: case SDOT:
408: switch(restype) {
409: case INT:
410: dummybig.I = lo;
411: dummybig.CDR = 0;
412: work=mulbig(work,(lispval)&dummybig);
413: goto code1;
414: case SDOT:
415: work=mulbig(work,result->val);
416: /* previous result is no longer needed */
417: pruneb(result->val);
418: code1:
419: restype = TYPE(work); /* SDOT or INT */
420: if(restype==INT) {
421: lo = work->i;
422: prunei(work);
423: } else {
424: prunep = FALSE; /* sdot is cannonical */
425: result->val = work;
426: } break;
427: case DOUB:
428: result->val->r *= Ifloat(work);
429: break;
430: default: goto urk;
431: }
432: break;
433: case DOUB:
434: switch(restype) {
435: case SDOT:
436: if(prunep) {
437: lispval handy;
438: dummybig.I = 0;
439: dummybig.CDR = (lispval) 0;
440: handy = adbig((lispval)&dummybig,result->val);
441: pruneb(result->val);
442: result->val = handy;
443: }
444: flacc = Ifloat(result->val) * work->r;
445: pruneb(result->val);
446: scrimp: (result->val = newdoub())->r = flacc;
447: restype = DOUB;
448: break;
449: case INT:
450: flacc = work->r * lo;
451: goto scrimp;
452: case DOUB:
453: result->val->r *= work->r;
454: break;
455: default: goto urk;
456: }
457: break;
458: default:
459: errorh1(Vermisc,"Non-number to add",nil,0,FALSE,work);
460: }
461: }
462: work = result->val;
463: switch(restype){
464: case DOUB:
465: break;
466: case INT:
467: work = inewint(lo);
468: break;
469: case SDOT:
470: if(prunep) {
471: dummybig.I = 0;
472: dummybig.CDR = (lispval) 0;
473: work = adbig((lispval)&dummybig,work);
474: }
475: break;
476: default:
477: urk:
478: error("Internal error in times",FALSE);
479: }
480: Restorestack();
481: return(work);
482: }
483:
484: lispval
485: Lquo()
486: {
487: register lispval work;
488: register struct argent *result, *mynp, *oldnp;
489: int restype; lispval quotient; double flacc;
490: struct sdot dummybig;
491: Savestack(4);
492:
493: oldnp = result = np;
494: protect(nil);
495: mynp = lbot + 1;
496: restype = INT;
497: dummybig.I = 1; dummybig.CDR = (lispval) 0;
498:
499: if(oldnp==lbot) goto out;
500: if(oldnp==mynp) mynp = lbot;
501: else {
502: /* examine the first argument and perhaps set restype to the
503: * correct type. If restype (result type) is INT, then the
504: * fixnum value is stored in lo. Otherwise, if restype is
505: * SDOT or DOUB, then the value is stored in result->val.
506: */
507: work = lbot->val;
508: switch(TYPE(work)) {
509: case INT:
510: dummybig.I = work->i;
511: break;
512: case SDOT:
513: /* we want to copy the sdot we are given as an argument since
514: * the bignum divide routine divbig expects an argument in
515: * canonical form.
516: */
517: dummybig.I = 0; /* create a zero sdot */
518: work = adbig(work,(lispval)&dummybig);
519: restype = TYPE(work);
520: if(restype==INT) { /* Either INT or SDOT */
521: dummybig.I=work->i; /* has turned into an fixnum */
522: prunei(work); /* return fixnum cell */
523: } else {
524: result->val = work;
525: }
526: break;
527: case DOUB:
528: (result->val = newdoub())->r = work->r;
529: restype = DOUB;
530: break;
531: default:
532: errorh1(Vermisc,"Internal quotient error #1: ",nil,FALSE,0,
533: work);
534: goto urk;
535: }
536: }
537:
538: /* now loop through the rest of the arguments dividing them
539: * into the running result in result or dummybig.I
540: */
541: for(; mynp < oldnp; mynp++)
542: {
543: work = mynp->val;
544: switch(TYPE(work)) {
545: case INT:
546: if (work->i==0)
547: kill(getpid(),8);
548: switch(restype) {
549: case SDOT: /* there is no fast routine to destructively
550: divide a bignum by an int, so do it the
551: hard way. */
552: dummybig.I = work->i;
553: divbig(result->val,(lispval)&dummybig,"ient,(lispval *)0);
554: pruneb(result->val);
555: on1:
556: /* check if the result has turned into a fixnum */
557: restype = TYPE(quotient);
558: if(restype==INT) { /* Either INT or SDOT */
559: dummybig.I=quotient->i; /* has turned into an fixnum */
560: prunei(quotient); /* return fixnum cell */
561: } else
562: result->val = quotient;
563: break;
564: case INT: /* divide int by int */
565: dummybig.I /= work->i;
566: break;
567: case DOUB:
568: result->val->r /= work->i;
569: break;
570: default:
571: errorh1(Vermisc,"Internal quotient error #2: ",nil,FALSE,0,
572: result->val);
573: goto urk;
574: }
575: break;
576: case SDOT:
577: switch(restype) {
578: case INT:
579: /* Although it seems that dividing an int
580: * by a bignum can only lead to zero, it is
581: * concievable that the bignum is improperly boxed,
582: * i.e. actually an int.
583: */
584: divbig((lispval)&dummybig,work,"ient,(lispval *)0);
585: goto on1;
586:
587: case SDOT:
588: /* dividing one bignum by another. */
589: divbig(result->val,work,"ient,(lispval *)0);
590: pruneb(result->val);
591: goto on1;
592: case DOUB:
593: /* dividing a bignum into a flonum.
594: */
595: result->val->r /= Ifloat(work);
596: break;
597: default:
598: errorh1(Vermisc,"Internal quotient error #3: ",nil,FALSE,0,
599: result->val);
600: goto urk;
601: }
602: break;
603:
604: case DOUB:
605: switch(restype) {
606: case SDOT: /* Divide bignum by flonum converting to flonum
607: * May die due to overflow */
608: flacc = Ifloat(result->val) / work->r;
609: pruneb(result->val);
610: scrimp:
611: (result->val = newdoub())->r = flacc;
612: restype = DOUB;
613: break;
614: case INT: /* dividing a flonum into a fixnum.
615: * The result will be a flonum. */
616:
617: flacc = ((double) dummybig.I) / work->r;
618: goto scrimp;
619: case DOUB: /* dividing a flonum into a flonum, what
620: * could be easier?
621: */
622: result->val->r /= work->r;
623: break;
624: default:
625: errorh1(Vermisc,"Internal quotient error #4: ",nil,
626: FALSE,0, result->val);
627: goto urk;
628: }
629: break;
630: default:
631: errorh1(Vermisc,"Non-number to quotient ",nil,FALSE,0,work);
632: }
633: }
634: out:
635: work = result->val;
636: switch(restype){
637: case SDOT:
638: case DOUB:
639: break;
640: case INT:
641: work = inewint(dummybig.I);
642: break;
643: default:
644: urk:
645: errorh1(Vermisc,"Internal quotient error #5: ",nil,FALSE,0,
646: work);
647: }
648: Restorestack();
649: return(work);
650: }
651:
652:
653: lispval Lfp()
654: {
655: register temp = 0;
656: register struct argent *argp;
657:
658: for(argp = lbot; argp < np; argp++)
659: if(TYPE(argp->val) != INT)
660: errorh1(Vermisc,"+: non fixnum argument ",
661: nil,FALSE,0,argp->val);
662: else
663: temp += argp->val->i;
664: return(inewint(temp));
665: }
666:
667: lispval Lfm()
668: {
669: register temp;
670: register struct argent *argp;
671:
672: if(lbot==np)return(inewint(0));
673: if(TYPE(lbot->val) != INT)
674: errorh1(Vermisc,"-: non fixnum argument ",
675: nil,FALSE,0,lbot->val);
676: else
677: temp = lbot->val->i;
678: if(lbot+1==np) return(inewint(-temp));
679: for(argp = lbot+1; argp < np; argp++)
680: if(TYPE(argp->val) != INT)
681: errorh1(Vermisc,"-: non fixnum argument ",
682: nil,FALSE,0,argp->val);
683: else
684: temp -= argp->val->i;
685: return(inewint(temp));
686: }
687:
688: lispval Lft()
689: {
690: register temp = 1;
691: register struct argent *argp;
692:
693: for(argp = lbot; argp < np; argp++)
694: if(TYPE(argp->val) != INT)
695: errorh1(Vermisc,"*: non fixnum argument ",
696: nil,FALSE,0,argp->val);
697: else
698: temp *= argp->val->i;
699: return(inewint(temp));
700: }
701:
702: lispval Lflessp()
703: {
704: register struct argent *argp = lbot;
705: register old, new;
706:
707: if(np < argp + 2) return(nil);
708: old = argp->val->i; argp++;
709: for(; argp < np; argp++)
710: if(TYPE(argp->val) != INT)
711: errorh1(Vermisc,"<: non fixnum argument ",
712: nil,FALSE,0,argp->val);
713: else {
714: new = argp->val->i;
715: if(!(old < new)) return(nil);
716: old = new;
717: }
718: return(tatom);
719: }
720:
721: lispval Lfd()
722: {
723: register temp = 0;
724: register struct argent *argp;
725:
726: if(lbot==np)return(inewint(1));
727: if(TYPE(lbot->val) != INT)
728: errorh1(Vermisc,"/: non fixnum argument ",
729: nil,FALSE,0,lbot->val);
730: temp = lbot->val->i;
731: if(lbot+1==np) return(inewint(1/temp));
732: for(argp = lbot+1; argp < np; argp++)
733: if(TYPE(argp->val) != INT)
734: errorh1(Vermisc,"/: non fixnum argument ",
735: nil,FALSE,0,argp->val);
736: else
737: temp /= argp->val->i;
738: return(inewint(temp));
739: }
740:
741: lispval Lfadd1()
742: {
743: chkarg(1,"1+");
744: if(TYPE(lbot->val) != INT)
745: errorh1(Vermisc,"1+: non fixnum argument ",
746: nil,FALSE,0,lbot->val);
747: return(inewint(lbot->val->i + 1));
748: }
749:
750: /*
751: * Lfexpt (^ 'x_a 'x_b)
752: * exponentiation of fixnums x_a and x_b returning a fixnum
753: * result
754: */
755: lispval Lfexpt()
756: {
757: register int base;
758: register int exp;
759: register int res;
760:
761: chkarg(2,"^");
762: if((TYPE(lbot[0].val) != INT ) || (TYPE(lbot[1].val) != INT))
763: errorh2(Vermisc,"^: non fixnum arguments", nil,0,
764: lbot[0].val,lbot[1].val);
765:
766: base = lbot[0].val->i;
767: exp = lbot[1].val->i;
768:
769: if(base == 0)
770: {
771: /* 0^0 == 1, 0 to any other power (even negative powers)
772: * is zero (according to Maclisp)
773: */
774: if(exp == 0) return(inewint(1));
775: else return(inewint(0));
776: }
777: else if(base == 1)
778: /*
779: * 1 to any power is 1
780: */
781: return(lbot[0].val); /* == 1 */
782: else if(exp == 0)
783: /*
784: * anything to the zero power is 1
785: */
786: return(inewint(1));
787: else if(base == -1)
788: {
789: /*
790: * -1 to an even power is 1, to an odd is -1
791: */
792: if(exp & 1) return(lbot[0].val);
793: else return(inewint(1));
794: }
795: else if(exp < 0)
796: /*
797: * anything not 0,-1,or 1 to a negative power is 0
798: *
799: */
800: return(inewint(0));
801:
802: /* compute exponentiation. This should check for overflows,
803: I suppose. --jkf
804: */
805: res = 1;
806: while( exp > 0)
807: {
808: if( exp & 1 )
809: { /* odd, just multiply by one */
810: res = res * base;
811: exp--;
812: }
813: else {
814: /* even, square base */
815: base = base * base;
816: exp = exp / 2;
817: }
818: }
819: return(inewint(res));
820: }
821:
822:
823:
824: lispval Lfsub1()
825: {
826: chkarg(1,"1-");
827: if(TYPE(lbot->val) != INT)
828: errorh1(Vermisc,"1-: non fixnum argument ",
829: nil,FALSE,0,lbot->val);
830: return(inewint(lbot->val->i - 1));
831: }
832:
833: lispval
834: Ldbtofl()
835: {
836: float x;
837: chkarg(1,"double-to-float");
838:
839: if(TYPE(lbot->val) != DOUB)
840: errorh1(Vermisc,"double-to-float: non flonum argument ",
841: nil,FALSE,0,lbot->val);
842: x = lbot->val->r;
843: return(inewint(*(long *)&x));
844: }
845:
846: lispval
847: Lfltodb()
848: {
849: register lispval handy;
850: chkarg(1,"float-to-double");
851:
852: if(TYPE(lbot->val) != INT)
853: errorh1(Vermisc,"float-to-double: non fixnum argument ",
854: nil,FALSE,0,lbot->val);
855: handy = newdoub();
856: handy->r = *(float *)lbot->val;
857: return(handy);
858: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.