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

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: lam2.c,v 1.5 83/12/09 16:35:49 sklower Exp $";
   4: #endif
   5: 
   6: /*					-[Fri Aug  5 12:46:16 1983 by jkf]-
   7:  * 	lam2.c				$Locker:  $
   8:  * lambda functions
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: # include "global.h"
  14: # include <signal.h>
  15: # include "structs.h"
  16: # include "chars.h"
  17: # include "chkrtab.h"
  18: /*
  19:  * (flatc 'thing ['max]) returns the smaller of max and the number of chars
  20:  * required to print thing linearly.
  21:  * if max argument is not given, we assume the second arg is infinity
  22:  */
  23: static flen; /*Internal to this module, used as a running counter of flatsize*/
  24: static fmax; /*used for maximum for quick reference */
  25: char *strcpy();
  26: 
  27: lispval
  28: Lflatsi()
  29: {
  30:     register lispval current;
  31:     Savestack(1);           /* fixup entry mask */
  32: 
  33:     fmax = 0x7fffffff;  /* biggest integer by default */
  34:     switch(np-lbot)
  35:     {
  36:         case 2: current = lbot[1].val;
  37:             while(TYPE(current) != INT)
  38:             current = errorh1(Vermisc,
  39:                     "flatsize: second arg not integer",
  40:                     nil,TRUE,0,current);
  41:             fmax = current->i;
  42:         case 1: break;
  43:         default: argerr("flatsize");
  44:     }
  45: 
  46:     flen = 0;
  47:     current = lbot->val;
  48:     protect(nil);           /*create space for argument to pntlen*/
  49:     Iflatsi(current);
  50:     Restorestack();
  51:     return(inewint(flen));
  52: }
  53: /*
  54:  * Iflatsi does the real work of the calculation for flatc
  55:  */
  56: Iflatsi(current)
  57: register lispval current;
  58: {
  59: 
  60:     if(flen > fmax) return;
  61:     switch(TYPE(current)) {
  62: 
  63:     patom:
  64:     case INT: case ATOM: case DOUB: case STRNG:
  65:         np[-1].val = current;
  66:         flen += Ipntlen();
  67:         return;
  68: 
  69:     pthing:
  70:     case DTPR:
  71:         flen++;
  72:         Iflatsi(current->d.car);
  73:         current = current->d.cdr;
  74:         if(current == nil) {
  75:             flen++;
  76:             return;
  77:         }
  78:         if(flen > fmax) return;
  79:         switch(TYPE(current)) {
  80:         case INT: case ATOM: case DOUB:
  81:             flen += 4;
  82:             goto patom;
  83:         case DTPR:
  84:             goto pthing;
  85:         }
  86:     }
  87: }
  88: 
  89: 
  90: #define EADC -1
  91: #define EAD  -2
  92: lispval
  93: Lread()
  94: { return (r(EAD)); }
  95: 
  96: lispval
  97: Lratom()
  98: { return (r(ATOM)); }
  99: 
 100: lispval
 101: Lreadc()
 102: { return (r(EADC)); }
 103: 
 104: 
 105: extern unsigned char *ctable;
 106: /* r *********************************************************************/
 107: /* this function maps the desired read 	function into the system-defined */
 108: /* reading functions after testing for a legal port.			 */
 109: lispval
 110: r(op)
 111: int op;
 112: {
 113:     unsigned char c; register lispval result;
 114:     register cc;
 115:     int orlevel; extern int rlevel;
 116:     FILE *ttemp;
 117:     struct nament *oldbnp = bnp;
 118:     Savestack(2);
 119: 
 120:     switch(np-lbot) {
 121:     case 0:
 122:         protect(nil);
 123:     case 1:
 124:         protect(nil);
 125:     case 2: break;
 126:     default:
 127:         argerr("read or ratom or readc");
 128:     }
 129:     result = Vreadtable->a.clb;
 130:     chkrtab(result);
 131:     orlevel = rlevel;
 132:     rlevel = 0;
 133:     ttemp = okport(Vpiport->a.clb,stdin);
 134:     ttemp = okport(lbot->val,ttemp);
 135: /*printf("entering switch\n");*/
 136:     if(ttemp == stdin) fflush(stdout);  /* flush any pending
 137: 						 * characters if reading stdin
 138: 						 * there should be tests to see
 139: 						 * if this is a tty or pipe
 140: 						 */
 141: 
 142:     switch (op)
 143:     {
 144:     case EADC:  rlevel = orlevel;
 145:             cc = getc(ttemp);
 146:             c = cc;
 147:             if(cc == EOF)
 148:             {
 149:                 Restorestack();
 150:                 return(lbot[1].val);
 151:             } else {
 152:                 strbuf[0] = hash = (c & 0177);
 153:                 strbuf[1] = 0;
 154:                 atmlen = 2;
 155:                 Restorestack();
 156:                 return((lispval)getatom(TRUE));
 157:             }
 158: 
 159:     case ATOM:  rlevel = orlevel;
 160:             result = (ratomr(ttemp));
 161:             goto out;
 162: 
 163:     case EAD:   PUSHDOWN(Vpiport,P(ttemp)); /* rebind Vpiport */
 164:             result = readr(ttemp);
 165:     out:        if(result==eofa)
 166:             {
 167:                  if(sigintcnt > 0) sigcall(SIGINT);
 168:                  result = lbot[1].val;
 169:             }
 170:             rlevel = orlevel;
 171:             popnames(oldbnp);   /* unwind bindings */
 172:             Restorestack();
 173:             return(result);
 174:     }
 175:     /* NOTREACHED */
 176: }
 177: 
 178: /* Lload *****************************************************************/
 179: /* Reads in and executes forms from the specified file. This should      */
 180: /* really be an nlambda taking multiple arguments, but the error 	 */
 181: /* handling gets funny in that case (one file out of several not 	 */
 182: /* openable, for instance).						 */
 183: lispval
 184: Lload()
 185: {
 186:     register FILE *port;
 187:     register char *p, *ttemp; register lispval vtemp;
 188:     struct nament *oldbnp = bnp;
 189:     int orlevel,typ;
 190:     char longname[100];
 191:     char *shortname, *end2, *Ilibdir();
 192:     /*Savestack(4); not necessary because np not altered */
 193: 
 194:     chkarg(1,"load");
 195:     if((typ = TYPE(lbot->val)) == ATOM)
 196:         ttemp =  lbot->val->a.pname ;  /* ttemp will point to name */
 197:     else if(typ == STRNG)
 198:         ttemp = (char *) lbot->val;
 199:     else
 200:          return(error("FILENAME MUST BE ATOMIC",FALSE));
 201:     strcpy(longname, Ilibdir());
 202:     for(p = longname; *p; p++);
 203:     *p++ = '/'; *p = 0;
 204:     shortname = p;
 205:     strcpy(p,ttemp);
 206:     for(; *p; p++);
 207:         end2 = p;
 208:     strcpy(p,".l");
 209:     if ((port = fopen(shortname,"r")) == NULL &&
 210:         (port = fopen(longname, "r")) == NULL) {
 211:             *end2 = 0;
 212:             if ((port = fopen(shortname,"r")) == NULL &&
 213:                 (port = fopen(longname, "r")) == NULL)
 214:                     errorh1(Vermisc,"Can't open file: ",
 215:                              nil,FALSE,0,lbot->val);
 216:     }
 217:     orlevel = rlevel;
 218:     rlevel = 0;
 219: 
 220:     if(ISNIL(copval(gcload,CNIL)) &&
 221:         loading->a.clb != tatom &&
 222:         ISNIL(copval(gcdis,CNIL)))
 223:         gc((struct types *)CNIL);    /*  do a gc if gc will be off  */
 224: 
 225:     /* shallow bind the value of lisp atom piport 	*/
 226:     /* so readmacros will work			*/
 227:     PUSHDOWN(Vpiport,P(port));
 228:     PUSHDOWN(loading,tatom);    /* set indication of loading status */
 229: 
 230:     while ((vtemp = readr(port)) != eofa) {
 231:         eval(vtemp);
 232:     }
 233:     popnames(oldbnp);       /* unbind piport, loading */
 234: 
 235:     rlevel = orlevel;
 236:     fclose(port);
 237:     return(nil);
 238: }
 239: 
 240: /* concat **************************************************
 241: -
 242: -  use: (concat arg1 arg2 ... )
 243: -
 244: -  concatenates the print names of all of its arguments.
 245: - the arguments may be atoms, integers or real numbers.
 246: -
 247: - *********************************************************/
 248: lispval
 249: Iconcat(unintern)
 250: {
 251:     register struct argent *temnp;
 252:     register char *cp = strbuf;
 253:     register lispval cur;
 254:     int n;
 255:     char *sprintf(), *atomtoolong();
 256:     lispval Lhau();
 257: 
 258:     *cp = NULL_CHAR ;
 259: 
 260:     /* loop for each argument */
 261:     for(temnp = lbot + AD ; temnp < np ; temnp++)
 262:     {
 263:         cur = temnp->val;
 264:         switch(TYPE(cur))
 265:         {
 266:         case ATOM:
 267:          n = strlen(cur->a.pname);
 268:          while(n + cp >= endstrb) cp = atomtoolong(cp);
 269:          strcpy(cp, cur->a.pname);
 270:          cp += n;
 271:          break;
 272: 
 273:         case STRNG:
 274:          n = strlen( (char *) cur);
 275:          while(n + cp >= endstrb) cp = atomtoolong(cp);
 276:          strcpy(cp, (char *) cur);
 277:          cp += n;
 278:          break;
 279: 
 280:         case INT:
 281:          if(15 + cp >= endstrb) cp = atomtoolong(cp);
 282:          sprintf(cp,"%d",cur->i);
 283:          while(*cp) cp++;
 284:          break;
 285: 
 286:         case DOUB:
 287:          if(15 + cp >= endstrb) cp = atomtoolong(cp);
 288:          sprintf(cp,"%f",cur->f);
 289:          while(*cp) cp++;
 290:          break;
 291: 
 292:         case SDOT: {
 293:         struct _iobuf _myiob;
 294:         register lispval handy = cur;
 295: 
 296:         for(n = 12; handy->s.CDR!=(lispval) 0; handy = handy->s.CDR)
 297:             n += 12;
 298: 
 299:         while(n + cp >= endstrb) cp = atomtoolong(cp);
 300: 
 301:         _myiob._flag = _IOWRT+_IOSTRG;
 302:         _myiob._ptr = cp;
 303:         _myiob._cnt = endstrb - cp - 1;
 304: 
 305:         pbignum(cur,&_myiob);
 306:         cp = _myiob._ptr;
 307:         *cp = 0;
 308:         break; }
 309: 
 310:         default:
 311:          cur = error("Non atom or number to concat",TRUE);
 312:          continue;    /* if returns value, try it */
 313:        }
 314: 
 315:     }
 316: 
 317:     if(unintern)
 318:         return( (lispval) newatom(FALSE)); /* uninterned atoms may
 319: 							have printname gc'd*/
 320:     else
 321:         return( (lispval) getatom(FALSE)) ;
 322: }
 323: lispval
 324: Lconcat(){
 325:     return(Iconcat(FALSE));
 326: }
 327: lispval
 328: Luconcat(){
 329:     return(Iconcat(TRUE));
 330: }
 331: 
 332: lispval
 333: Lputprop()
 334: {
 335:     lispval Iputprop();
 336:     chkarg(3,"putprop");
 337:     return(Iputprop(lbot->val,lbot[1].val,lbot[2].val));
 338: }
 339: 
 340: /*
 341:  * Iputprop :internal version of putprop used by some C functions
 342:  *  note: prop and ind are lisp values but are not protected (by this
 343:  * function) from gc.  The caller should protect them!!
 344:  */
 345: lispval
 346: Iputprop(atm,prop,ind)
 347: register lispval prop, ind, atm;
 348: {
 349:     register lispval pptr;
 350:     lispval *tack;      /* place to begin property list */
 351:     lispval pptr2;
 352:     lispval errorh();
 353:     Savestack(4);
 354: 
 355:  top:
 356:     switch (TYPE(atm)) {
 357:     case ATOM:
 358:         if(atm == nil) tack = &nilplist;
 359:         else tack =  &(atm->a.plist);
 360:         break;
 361:     case DTPR:
 362:         for (pptr = atm->d.cdr ; pptr != nil ; pptr = pptr->d.cdr->d.cdr)
 363:             if(TYPE(pptr) != DTPR || TYPE(pptr->d.cdr) != DTPR) break;
 364:         if(pptr != nil)
 365:         {   atm = errorh1(Vermisc,
 366:                  "putprop: bad disembodied property list",
 367:                  nil,TRUE,0,atm);
 368:             goto top;
 369:         }
 370:         tack = (lispval *) &(atm->d.cdr);
 371:         break;
 372:     default:
 373:         errorh1(Vermisc,"putprop: Bad first argument: ",nil,FALSE,0,atm);
 374:     }
 375:     pptr = *tack;   /* start of property list */
 376: /*findit:*/
 377:     for (pptr = *tack ; pptr != nil ; pptr = pptr->d.cdr->d.cdr)
 378:         if (pptr->d.car == ind) {
 379:             (pptr->d.cdr)->d.car = prop;
 380:             Restorestack();
 381:             return(prop);
 382:         }
 383:     /* not found, add to front
 384: 	   be careful, a gc could occur before the second newdot() */
 385: 
 386:     pptr = newdot();
 387:     pptr->d.car = prop;
 388:     pptr->d.cdr = *tack;
 389:     protect(pptr);
 390:     pptr2 = newdot();
 391:     pptr2->d.car = ind;
 392:     pptr2->d.cdr = pptr;
 393:     *tack = pptr2;
 394:     Restorestack();
 395:     return(prop);
 396: }
 397: 
 398: /* get from property list
 399:  *   there are three routines to accomplish this
 400:  *     Lget - lisp callable, the first arg can be a symbol or a disembodied
 401:  *  	      property list.  In the latter case we check to make sure it
 402:  *	      is a real one (as best we can).
 403:  *     Iget - internal routine, the first arg must be a symbol, no disembodied
 404:  *	      plists allowed
 405:  *     Igetplist - internal routine, the first arg is the plist to search.
 406:  */
 407: lispval
 408: Lget()
 409: {
 410:     register lispval ind, atm;
 411:     register lispval dum1;
 412:     lispval Igetplist();
 413: 
 414:     chkarg(2,"get");
 415:     ind = lbot[1].val;
 416:     atm = lbot[0].val;
 417: top:
 418:     switch(TYPE(atm)) {
 419:     case ATOM:
 420:         if(atm==nil) atm = nilplist;
 421:         else atm = atm->a.plist;
 422:         break;
 423: 
 424:     case DTPR:
 425:         for (dum1 = atm->d.cdr; dum1 != nil; dum1 = dum1->d.cdr->d.cdr)
 426:             if((TYPE(dum1) != DTPR) ||
 427:                (TYPE(dum1->d.cdr) != DTPR)) break; /* bad prop list */
 428:         if(dum1 != nil)
 429:         {   atm = errorh1(Vermisc,
 430:                  "get: bad disembodied property list",
 431:                  nil,TRUE,0,atm);
 432:             goto top;
 433:         }
 434:         atm = atm->d.cdr;
 435:         break;
 436:     default:
 437:         /* remove since maclisp doesnt treat
 438: 		   this as an error, ugh
 439: 		   return(errorh1(Vermisc,"get: bad first argument: ",
 440: 			       nil,FALSE,0,atm));
 441: 		 */
 442:          return(nil);
 443:     }
 444: 
 445:     while (atm != nil)
 446:         {
 447:             if (atm->d.car == ind)
 448:                 return ((atm->d.cdr)->d.car);
 449:             atm = (atm->d.cdr)->d.cdr;
 450:         }
 451:     return(nil);
 452: }
 453: /*
 454:  * Iget - the first arg must be a symbol.
 455:  */
 456: 
 457: lispval
 458: Iget(atm,ind)
 459: register lispval atm, ind;
 460: {
 461:     lispval Igetplist();
 462: 
 463:     if(atm==nil)
 464:         atm = nilplist;
 465:     else
 466:         atm = atm->a.plist;
 467:     return(Igetplist(atm,ind));
 468: }
 469: 
 470: /*
 471:  *  Igetplist
 472:  * pptr is a plist
 473:  * ind is the indicator
 474:  */
 475: 
 476: lispval
 477: Igetplist(pptr,ind)
 478: register lispval pptr,ind;
 479: {
 480:     while (pptr != nil)
 481:         {
 482:             if (pptr->d.car == ind)
 483:                 return ((pptr->d.cdr)->d.car);
 484:             pptr = (pptr->d.cdr)->d.cdr;
 485:         }
 486:     return(nil);
 487: }
 488: lispval
 489: Lgetd()
 490: {
 491:     register lispval typ;
 492: 
 493:     chkarg(1,"getd");
 494:     typ = lbot->val;
 495:     if (TYPE(typ) != ATOM)
 496:        errorh1(Vermisc,
 497:           "getd: Only symbols have function definitions",
 498:           nil,
 499:           FALSE,
 500:           0,
 501:           typ);
 502:     return(typ->a.fnbnd);
 503: }
 504: lispval
 505: Lputd()
 506: {
 507:     register lispval atom, list;
 508: 
 509:     chkarg(2,"putd");
 510:     list = lbot[1].val;
 511:     atom = lbot->val;
 512:     if (TYPE(atom) != ATOM) error("only symbols have function definitions",
 513:                     FALSE);
 514:     atom->a.fnbnd = list;
 515:     return(list);
 516: }
 517: 
 518: /* ===========================================================
 519: - mapping functions which return a list of the answers
 520: - mapcar applies the given function to successive elements
 521: - maplist applies the given function to successive sublists
 522: - ===========================================================*/
 523: 
 524: lispval
 525: Lmapcrx(maptyp,join)
 526: int maptyp;     /* 0 = mapcar,  1 = maplist  */
 527: int join;       /* 0 = the above, 1 = s/car/can/ */
 528: {
 529:     register struct argent *namptr;
 530:     register index;
 531:     register lispval temp;
 532:     register lispval current;
 533: 
 534:     struct argent *first, *last;
 535:     int count;
 536:     lispval lists[25], result;
 537:     Savestack(4);
 538: 
 539:     namptr = lbot + 1;
 540:     count = np - namptr;
 541:     if (count <= 0) return (nil);
 542:     result = current =  (lispval) np;
 543:     protect(nil);           /* set up space for returned list */
 544:     protect(lbot->val); /*copy funarg for call to funcall */
 545:     lbot = np -1;
 546:     first = np;
 547:     last = np += count;
 548:     for(index = 0; index < count; index++) {
 549:         temp =(namptr++)->val;
 550:         if (TYPE (temp ) != DTPR && temp!=nil)
 551:             error ( "bad list argument to map",FALSE);
 552:         lists[index] = temp;
 553:     }
 554:     for(;;) {
 555:         for(namptr=first,index=0; index<count; index++) {
 556:             temp = lists[index];
 557:             if(temp==nil) goto done;
 558: 
 559:             if(maptyp==0) (namptr++)->val = temp->d.car;
 560:             else (namptr++)->val = temp;
 561: 
 562:             lists[index] = temp->d.cdr;
 563:         }
 564:         if (join == 0) {
 565:             current->l = newdot();
 566:             current->l->d.car = Lfuncal();
 567:             current = (lispval) &current->l->d.cdr;
 568:         } else {
 569:             current->l = Lfuncal();
 570:             if ( TYPE ( current -> l) != DTPR && current->l != nil)
 571:                 error("bad type returned from funcall inside map",FALSE);
 572:             else  while ( current -> l  != nil )
 573:                     current = (lispval) & (current ->l ->d.cdr);
 574:         }
 575:         np = last;
 576:     }
 577: done:   if (join == 0)current->l = nil;
 578:     Restorestack();
 579:     return(result->l);
 580: }
 581: 
 582: /* ============================
 583: -
 584: - Lmapcar
 585: - =============================*/
 586: 
 587: lispval
 588: Lmpcar()
 589: {
 590:     return(Lmapcrx(0,0));   /* call general routine */
 591: }
 592: 
 593: 
 594: /* ============================
 595: -
 596: -
 597: -  Lmaplist
 598: - ==============================*/
 599: 
 600: lispval
 601: Lmaplist()
 602: {
 603:     return(Lmapcrx(1,0));   /* call general routine */
 604: }
 605: 
 606: 
 607: /* ================================================
 608: - mapping functions which return the value of the last function application.
 609: - mapc and map
 610: - ===================================================*/
 611: 
 612: lispval
 613: Lmapcx(maptyp)
 614: int maptyp;     /* 0= mapc   , 1= map  */
 615: {
 616:     register struct argent *namptr;
 617:     register index;
 618:     register lispval temp;
 619:     register lispval result;
 620: 
 621:     int count;
 622:     struct argent *first;
 623:     lispval lists[25], errorh();
 624:     Savestack(4);
 625: 
 626:     namptr = lbot + 1;
 627:     count = np - namptr;
 628:     if(count <= 0) return(nil);
 629:     result = lbot[1].val;       /*This is what macsyma wants so ... */
 630:                     /*copy funarg for call to funcall */
 631:     lbot = np; protect((namptr - 1)->val);
 632:     first = np; np += count;
 633: 
 634:     for(index = 0; index < count; index++) {
 635:         temp = (namptr++)->val;
 636:         while(temp!=nil && TYPE(temp)!=DTPR)
 637:             temp = errorh1(Vermisc,"Inappropriate list argument to mapc",nil,TRUE,0,temp);
 638:         lists[index] = temp;
 639:     }
 640:     for(;;) {
 641:         for(namptr=first,index=0; index<count; index++) {
 642:             temp = lists[index];
 643:             if(temp==nil)
 644:                 goto done;
 645:             if(maptyp==0)
 646:                 (namptr++)->val = temp->d.car;
 647:             else
 648:                 (namptr++)->val = temp;
 649:             lists[index] = temp->d.cdr;
 650:         }
 651:         Lfuncal();
 652:     }
 653: done:
 654:     Restorestack();
 655:     return(result);
 656: }
 657: 
 658: 
 659: /* ==================================
 660: -
 661: -	mapc   map the car of the lists
 662: -
 663: - ==================================*/
 664: 
 665: lispval
 666: Lmapc()
 667: {   return( Lmapcx(0) );  }
 668: 
 669: 
 670: /* =================================
 671: -
 672: -	map    map the cdr of the lists
 673: -
 674: - ===================================*/
 675: 
 676: lispval
 677: Lmap()
 678: {   return( Lmapcx(1) );   }
 679: 
 680: 
 681: lispval
 682: Lmapcan()
 683: {
 684:     lispval Lmapcrx();
 685: 
 686:     return ( Lmapcrx ( 0,1 ) );
 687: }
 688: 
 689: lispval
 690: Lmapcon()
 691: {
 692:     lispval Lmapcrx();
 693: 
 694:     return ( Lmapcrx ( 1,1 ) );
 695: }

Defined functions

Defined variables

Defined macros