4.3BSD - /usr/src/ucb/lisp/franz/lam4.c

   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,&quotient,(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,&quotient,(lispval *)0);
 585:             goto on1;
 586: 
 587:         case SDOT:
 588:             /* dividing one bignum by another. */
 589:             divbig(result->val,work,&quotient,(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: }

Defined functions

Defined variables