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

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: lam5.c,v 1.7 83/12/09 16:36:12 sklower Exp $";
   4: #endif
   5: 
   6: /*					-[Fri Aug  5 12:49:06 1983 by jkf]-
   7:  * 	lam5.c				$Locker:  $
   8:  * lambda functions
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: #include "global.h"
  14: #include "chkrtab.h"
  15: #include <ctype.h>
  16: char *strcpy(), *sprintf();
  17: 
  18: /*===========================================
  19: -
  20: -	explode functions: aexplode , aexplodec, aexploden
  21: - The following function partially implement the explode functions for atoms.
  22: -  The full explode functions are written in lisp and call these for atom args.
  23: -
  24: -===========================================*/
  25: 
  26: #include "chars.h"
  27: lispval
  28: Lexpldx(kind,slashify)
  29: int kind, slashify;     /* kind = 0 => explode to characters
  30: 				= 1 => explode to fixnums (aexploden)
  31: 			   slashify = 0 => do not quote bizarre characters
  32: 				    = 1 => quote bizarre characters
  33: 			*/
  34: {
  35:     int typ, i;
  36:     char ch, *strb, strbb[BUFSIZ], *alloca();  /* temporary string buffer */
  37:     register lispval last, handy;
  38:     extern int uctolc;
  39:     register char *cp;
  40:     Savestack(3); /* kludge register save mask */
  41: #ifdef SPISFP
  42:     Keepxs();
  43: #endif
  44: 
  45:     chkarg(1,"expldx");
  46: 
  47:     handy = Vreadtable->a.clb;
  48:     chkrtab(handy);
  49:     handy = lbot->val;
  50:     *strbuf = 0;
  51:     typ=TYPE(handy);    /* we only work for a few types */
  52: 
  53: 
  54:     /* put the characters to return in the string buffer strb */
  55: 
  56:     switch(typ) {
  57:     case STRNG:
  58:         if(slashify && !Xsdc)
  59:             errorh1(Vermisc,"Can't explode without string delimiter",nil
  60:                       ,FALSE,0,handy);
  61: 
  62:         strb = strbb;
  63:         if(slashify) *strb++ = Xsdc;
  64:         /* copy string into buffer, escape only occurances of the
  65: 		   double quoting character if in slashify mode
  66: 		*/
  67:         for(cp = (char *) handy; *cp; cp++)
  68:         {
  69:           if(slashify &&
  70:              (*cp == Xsdc || synclass(ctable[*cp])==CESC))
  71:              *strb++ = Xesc;
  72:           *strb++ = *cp;
  73:         }
  74:         if(slashify) *strb++ = Xsdc;
  75:         *strb = NULL_CHAR ;
  76:         strb = strbb;
  77:         break;
  78: 
  79:     case ATOM:
  80:         strb = handy->a.pname;
  81:         if(slashify && (strb[0]==0)) {
  82:             strb = strbb;
  83:             strbb[0] = Xdqc;
  84:             strbb[1] = Xdqc;
  85:             strbb[2] = 0;
  86:         } else
  87:     /*common:*/
  88:         if(slashify != 0)
  89:         {
  90:             char *out = strbb;
  91:             unsigned char code;
  92: 
  93:             cp = strb;
  94:             strb = strbb;
  95:             code = ctable[(*cp)&0177];
  96:             switch(synclass(code)) {
  97:             case CNUM:
  98:                 *out++ = Xesc;
  99:                 break;
 100:             case CCHAR:
 101:                 if(uctolc && isupper((*cp)&0177)) {
 102:                     *out++ = Xesc;
 103:                 }
 104:                 break;
 105:             default:
 106:                 switch(code&QUTMASK) {
 107:                 case QWNUNIQ:
 108:                     if (cp[1]==0) *out++ = Xesc;
 109:                     break;
 110:                 case QALWAYS:
 111:                 case QWNFRST:
 112:                     *out++ = Xesc;
 113:                 }
 114:             }
 115:             *out++ = *cp++;
 116:             for(; *cp; cp++)
 117:             {
 118:                 if(((ctable[*cp]&QUTMASK)==QALWAYS) ||
 119:                    (uctolc && isupper(*cp)))
 120:                     *out++ = Xesc;
 121:                 *out++ = *cp;
 122:             }
 123:             *out = 0;
 124:         }
 125:         break;
 126: 
 127:     case INT:
 128:         strb = strbb;
 129:         sprintf(strb, "%d", lbot->val->i);
 130:         break;
 131:     case DOUB:
 132:         strb = strbb;
 133:         lfltpr(strb, lbot->val->r);
 134:         break;
 135:     case SDOT:
 136:     {
 137:         struct _iobuf _strbuf;
 138:         int count;
 139:         for((handy = lbot->val), count = 12;
 140:             handy->s.CDR!=(lispval) 0;
 141:             (handy = handy->s.CDR), count += 12);
 142:         strb = alloca(count);
 143: 
 144:         _strbuf._flag = _IOWRT+_IOSTRG;
 145:         _strbuf._ptr = strb;
 146:         _strbuf._cnt = count;
 147:         pbignum(lbot->val,&_strbuf);
 148:         putc(0,&_strbuf);
 149:         break;
 150:     }
 151:     default:
 152:             errorh1(Vermisc,"EXPLODE ARG MUST BE STRING, SYMBOL, FIXNUM, OR FLONUM",nil,FALSE,0,handy);
 153:             Restorestack();
 154:             Freexs();
 155:             return(nil);
 156:         }
 157: 
 158: 
 159:     if( strb[0] != NULL_CHAR )  /* if there is something to do */
 160:     {
 161:         lispval prev;
 162: 
 163:         protect(handy = last = newdot());
 164:         strbuf[1] = NULL_CHAR ;     /* set up for getatom */
 165:         atmlen = 2;
 166: 
 167:         for(i=0; ch = strb[i++]; ) {
 168:         switch(kind) {
 169: 
 170:           case 0: strbuf[0] = hash = ch;   /* character explode */
 171:               last->d.car = (lispval) getatom(TRUE); /* look in oblist */
 172:               break;
 173: 
 174:           case 1:
 175:               last->d.car = inewint(ch);
 176:               break;
 177:         }
 178: 
 179:         /* advance pointers */
 180:         prev = last;
 181:         last->d.cdr = newdot();
 182:         last = last->d.cdr;
 183:         }
 184: 
 185:         /* end list with a nil pointer */
 186:         prev->d.cdr = nil;
 187:         Freexs();
 188:         Restorestack();
 189:         return(handy);
 190:     }
 191:     Freexs();
 192:     Restorestack();
 193:     return(nil);    /* return nil if no characters */
 194: }
 195: 
 196: /*===========================
 197: -
 198: - (aexplodec 'atm) returns (a t m)
 199: - (aexplodec 234) returns (\2 \3 \4)
 200: -===========================*/
 201: 
 202: lispval
 203: Lxpldc()
 204: { return(Lexpldx(0,0)); }
 205: 
 206: 
 207: /*===========================
 208: -
 209: - (aexploden 'abc) returns (65 66 67)
 210: - (aexploden 123)  returns (49 50 51)
 211: -=============================*/
 212: 
 213: 
 214: lispval
 215: Lxpldn()
 216: { return(Lexpldx(1,0)); }
 217: 
 218: /*===========================
 219: -
 220: - (aexplode "123")  returns (\\ \1 \2 \3);
 221: - (aexplode 123)  returns (\1 \2 \3);
 222: -=============================*/
 223: 
 224: lispval
 225: Lxplda()
 226: { return(Lexpldx(0,1)); }
 227: 
 228: /*
 229:  * (argv) returns how many arguments where on the command line which invoked
 230:  * lisp; (argv i) returns the i'th argument made into an atom;
 231:  */
 232: 
 233: lispval
 234: Largv()
 235: {
 236:     register lispval handy;
 237:     extern int Xargc;
 238:     extern char **Xargv;
 239: 
 240:     if(lbot-np==0)handy = nil;
 241:     else handy = lbot->val;
 242: 
 243:     if(TYPE(handy)==INT && handy->i>=0 && handy->i<Xargc) {
 244:         strcpy(strbuf,Xargv[handy->i]);
 245:         return(getatom(FALSE));
 246:     } else {
 247:         return(inewint(Xargc));
 248:     }
 249: }
 250: /*
 251:  * (chdir <atom>) executes a chdir command
 252:  * if successful, return t otherwise returns nil
 253:  */
 254: lispval Lchdir(){
 255:     register char *filenm;
 256: 
 257:     chkarg(1,"chdir");
 258:     filenm = (char *) verify(lbot->val,"chdir - non symbol or string arg");
 259:     if(chdir(filenm)>=0)
 260:         return(tatom);
 261:     else
 262:         return(nil);
 263: }
 264: 
 265: /* ==========================================================
 266: -
 267: -	ascii   - convert from number to ascii character
 268: -
 269: - form:(ascii number)
 270: -
 271: -	the number is checked so that it is in the range 0-255
 272: - then it is made a character and returned
 273: - =========================================================*/
 274: 
 275: lispval
 276: Lascii()
 277: {
 278:     register lispval handy;
 279: 
 280:     handy = lbot->val;      /* get argument */
 281: 
 282:     if(TYPE(handy) != INT)      /* insure that it is an integer */
 283:     {   error("argument not an integer",FALSE);
 284:         return(nil);
 285:     }
 286: 
 287:     if(handy->i < 0 || handy->i > 0377) /* insure that it is in range*/
 288:     {   error("argument is out of ascii range",FALSE);
 289:         return(nil);
 290:     }
 291: 
 292:     strbuf[0] = handy->i ;  /* ok value, make into a char */
 293:     strbuf[1] = NULL_CHAR;
 294: 
 295:     /* lookup and possibly intern the atom given in strbuf */
 296: 
 297:     return( (lispval) getatom(TRUE) );
 298: }
 299: 
 300: /*
 301:  *  boole - maclisp bitwise boolean function
 302:  *  (boole k x y) where k determines which of 16 possible bitwise
 303:  *  truth tables may be applied.  Common values are 1 (and) 6 (xor) 7 (or)
 304:  *  the result is mapped over each pair of bits on input
 305:  */
 306: lispval
 307: Lboole(){
 308:     register x, y;
 309:     register struct argent *mynp;
 310:     int k;
 311: 
 312:     if(np - lbot < 3)
 313:         error("Boole demands at least 3 args",FALSE);
 314:     mynp = lbot+AD;
 315:     k = mynp->val->i & 15;
 316:     x = (mynp+1)->val->i;
 317:     for(mynp += 2; mynp < np; mynp++) {
 318:         y = mynp->val->i;
 319:         switch(k) {
 320: 
 321:         case 0: x = 0;
 322:             break;
 323:         case 1: x = x & y;
 324:             break;
 325:         case 2: x = y & ~x;
 326:             break;
 327:         case 3: x = y;
 328:             break;
 329:         case 4: x = x & ~y;
 330:             break;
 331:         /* case 5:	x = x; break; */
 332:         case 6: x = x ^ y;
 333:             break;
 334:         case 7: x = x | y;
 335:             break;
 336:         case 8: x = ~(x | y);
 337:             break;
 338:         case 9: x = ~(x ^ y);
 339:             break;
 340:         case 10: x = ~x;
 341:             break;
 342:         case 11: x = ~x | y;
 343:             break;
 344:         case 12: x = ~y;
 345:             break;
 346:         case 13: x = x | ~y;
 347:             break;
 348:         case 14: x = ~x | ~y;
 349:             break;
 350:         case 15: x = -1;
 351:         }
 352:     }
 353:     return(inewint(x));
 354: }
 355: lispval
 356: Lfact()
 357: {
 358:     register lispval result, handy;
 359:     register itemp;
 360:     Savestack(3); /* fixup entry mask */
 361: 
 362:     result = lbot->val;
 363:     if(TYPE(result)!=INT) error("Factorial of Non-fixnum.  If you want me\
 364: to calculate fact of > 2^30 We will be here till doomsday!.",FALSE);
 365:     itemp = result->i;
 366:     protect(result = newsdot());
 367:     result->s.CDR=(lispval)0;
 368:     result->i = 1;
 369:     for(; itemp > 1; itemp--)
 370:         dmlad(result,(long)itemp,0L);
 371:     if(result->s.CDR)
 372:     {
 373:         Restorestack();
 374:         return(result);
 375:     }
 376:     handy = inewint(result->s.I);
 377:     pruneb(result);
 378:     Restorestack();
 379:     return(handy);
 380: }
 381: /*
 382:  * fix -- maclisp floating to fixnum conversion
 383:  * for the moment, mereley convert floats to ints.
 384:  * eventual convert to bignum if too big to fit.
 385:  */
 386:  lispval Lfix()
 387:  {
 388:     register lispval handy;
 389:     double floor();
 390: 
 391:     chkarg(1,"fix");
 392:     handy = lbot->val;
 393:     switch(TYPE(handy)) {
 394:     default:
 395:         error("innaproriate arg to fix.",FALSE);
 396:     case INT:
 397:     case SDOT:
 398:         return(handy);
 399:     case DOUB:
 400:         return(inewint((int)floor(handy->r)));
 401:     }
 402: }
 403: /*
 404:  * (frexp <real no>)
 405:  * returns a dotted pair (<exponent>. <bignum>)
 406:  * such that bignum is 56 bits long, and if you think of the binary
 407:  * point occuring after the high order bit, <real no> = 2^<exp> * <bignum>
 408:  *
 409:  * myfrexp is an assembly language routine found in bigmath.s to do exactly
 410:  * what is necessary to accomplish this.
 411:  * this routine is horribly vax specific.
 412:  *
 413:  * Lfix should probably be rewritten to take advantage of myfrexp
 414:  */
 415: lispval
 416: Lfrexp()
 417: {
 418:     register lispval handy, result;
 419:     int exp, hi, lo;
 420: 
 421:     Savestack(2);
 422:     chkarg(1,"frexp");
 423: 
 424:     myfrexp(lbot->val->r, &exp, &hi, &lo);
 425:     if(lo < 0) {
 426:         /* normalize for bignum */
 427:         lo &= ~ 0xC0000000;
 428:         hi += 1;
 429:     }
 430:     result = handy = newdot();
 431:     protect(handy);
 432:     handy->d.car = inewint(exp);
 433:     if(hi==0&&lo==0) {
 434:         handy->d.cdr = inewint(0);
 435:     } else {
 436:         handy = handy->d.cdr = newsdot();
 437:         handy->s.I = lo;
 438:         handy = handy->s.CDR = newdot();
 439:         handy->s.I = hi;
 440:         handy->s.CDR = 0;
 441:     }
 442:     np--;
 443:     Restorestack();
 444:     return(result);
 445: }
 446: 
 447: #define SIGFPE 8
 448: #define B 1073741824.0
 449: static double table[] = { 1.0, B, B*B, B*B*B, B*B*B*B, 0.0};
 450: 
 451: lispval
 452: Lfloat()
 453: {
 454:     register lispval handy,result;
 455:     register double sum = 0;
 456:     register int count;
 457:     chkarg(1,"float");
 458:     handy = lbot->val;
 459:     switch(TYPE(handy))
 460:     {
 461:       case DOUB: return(handy);
 462: 
 463: 
 464:       case INT:  result = newdoub();
 465:              result->r = (double) handy->i;
 466:              return(result);
 467:       case SDOT:
 468:       {
 469:         for(handy = lbot->val, count = 0;
 470:             count < 5;
 471:             count++, handy = handy->s.CDR) {
 472:             sum += handy->s.I * table[count];
 473:             if(handy->s.CDR==(lispval)0) goto done;
 474:         }
 475:         kill(getpid(),SIGFPE);
 476:     done:
 477:         result = newdoub();
 478:         result->r = sum;
 479:         return(result);
 480:     }
 481:       default: errorh1(Vermisc,"Bad argument to float",nil,FALSE,0,handy);
 482:       /* NOTREACHED */
 483:     }
 484: }
 485: double
 486: Ifloat(handy)
 487: register lispval handy;
 488: {
 489:     register double sum = 0.0; register int count=0;
 490:     for(; count < 5; count++, handy = handy->s.CDR) {
 491:         sum += handy->s.I * table[count];
 492:         if(handy->s.CDR==(lispval)0) goto done;
 493:     }
 494:     kill(getpid(),SIGFPE);
 495:     done:
 496:     return(sum);
 497: }
 498: 
 499: /* Lbreak ***************************************************************/
 500: /* If first argument is not nil, this is evaluated and printed.  Then	*/
 501: /* error is called with the "breaking" message.				*/
 502: lispval Lbreak() {
 503: 
 504:     if (np > lbot) {
 505:         printr(lbot->val,poport);
 506:         dmpport(poport);
 507:     }
 508:     return(error("",TRUE));
 509: }
 510: 
 511: 
 512: lispval
 513: LDivide() {
 514:     register lispval result, work;
 515:     register struct argent *mynp;
 516:     lispval quo, rem, arg1, arg2; struct sdot dummy, dum2;
 517:     Savestack(3);
 518: 
 519:     chkarg(2,"Divide");
 520:     mynp = lbot;
 521:     work = mynp++->val;
 522:     switch(TYPE(work)) {
 523:     case INT:
 524:         arg1 = (lispval) &dummy;
 525:         dummy.I = work->i;
 526:         dummy.CDR = (lispval) 0;
 527:         break;
 528:     case SDOT:
 529:         arg1 = work;
 530:         break;
 531:     urk:
 532:     default:
 533:         error("First arg to divide neither a bignum nor int.",FALSE);
 534:     }
 535:     work = mynp->val;
 536:     switch(TYPE(work)) {
 537:     case INT:
 538:         arg2 = (lispval) &dum2;
 539:         dum2.I = work->i;
 540:         dum2.CDR = (lispval) 0;
 541:         break;
 542:     case SDOT:
 543:         arg2 = work;
 544:         break;
 545:     default:
 546:         goto urk;
 547:     }
 548:     divbig(arg1,arg2, &quo, &rem);
 549:     protect(quo);
 550:     if(rem==((lispval)&dummy))
 551:         rem = inewint(dummy.I);
 552:     protect(rem);
 553:     protect(result = work = newdot());
 554:     work->d.car = quo;
 555:     (work->d.cdr = newdot())->d.car = rem;
 556:     Restorestack();
 557:     return(result);
 558: }
 559: 
 560: lispval LEmuldiv(){
 561:     register struct argent * mynp = lbot+AD;
 562:     register lispval work, result;
 563:     int quo, rem;
 564:     Savestack(3); /* fix register mask */
 565: 
 566:     /* (Emuldiv mul1 mult2 add quo) =>
 567: 		temp = mul1 + mul2 + sext(add);
 568: 		result = (list temp/quo temp%quo);
 569: 		to mix C and lisp a bit */
 570: 
 571:     Imuldiv(mynp[0].val->i, mynp[1].val->i, mynp[2].val->i,
 572:         mynp[3].val->i, &quo, &rem);
 573:     protect(result=newdot());
 574:     (result->d.car=inewint(quo));
 575:     work = result->d.cdr = newdot();
 576:     (work->d.car=inewint(rem));
 577:     Restorestack();
 578:     return(result);
 579: }

Defined functions

Defined variables

Defined macros