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

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: lam1.c,v 1.7 85/03/24 11:04:00 sklower Exp $";
   4: #endif
   5: 
   6: /*					-[Fri Feb 17 16:44:24 1984 by layer]-
   7:  * 	lam1.c				$Locker:  $
   8:  * lambda functions
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: # include "global.h"
  14: # include <sgtty.h>
  15: # include "chkrtab.h"
  16: # include "frame.h"
  17: 
  18: lispval
  19: Leval()
  20: {
  21:     register lispval temp;
  22: 
  23:     chkarg(1,"eval");
  24:     temp = lbot->val;
  25:         return(eval(temp));
  26: }
  27: 
  28: lispval
  29: Lxcar()
  30: {   register int typ;
  31:     register lispval temp, result;
  32: 
  33:     chkarg(1,"xcar");
  34:     temp = lbot->val;
  35:     if (((typ = TYPE(temp)) == DTPR) || (typ == ATOM) || HUNKP(temp))
  36:         return(temp->d.car);
  37:     else if(typ == SDOT) {
  38:         result = inewint(temp->i);
  39:         return(result);
  40:     } else if(Schainp!=nil && typ==ATOM)
  41:         return(nil);
  42:     else
  43:         return(error("Bad arg to car",FALSE));
  44: 
  45: }
  46: 
  47: lispval
  48: Lxcdr()
  49: {   register int typ;
  50:     register lispval temp;
  51: 
  52:     chkarg(1,"xcdr");
  53:     temp = lbot->val;
  54:     if(temp==nil) return (nil);
  55: 
  56:     if (((typ = TYPE(temp)) == DTPR) || HUNKP(temp))
  57:         return(temp->d.cdr);
  58:     else if(typ==SDOT) {
  59:         if(temp->s.CDR==0) return(nil);
  60:         temp = temp->s.CDR;
  61:         if(TYPE(temp)==DTPR)
  62:             errorh1(Vermisc,"Fell off the end of a bignum",nil,FALSE,5,lbot->val);
  63:         return(temp);
  64:     } else if(Schainp!=nil && typ==ATOM)
  65:         return(nil);
  66:     else
  67:         return(error("Bad arg to cdr", FALSE));
  68: }
  69: 
  70: lispval
  71: cxxr(as,ds)
  72: register int as,ds;
  73: {
  74: 
  75:     register lispval temp, temp2;
  76:     int i, typ;
  77:     lispval errorh();
  78: 
  79:     chkarg(1,"c{ad}+r");
  80:     temp = lbot->val;
  81: 
  82:     for( i=0 ; i<ds ; i++)
  83:     {
  84:         if( temp != nil)
  85:         {
  86:         typ = TYPE(temp);
  87:         if ((typ == DTPR) || HUNKP(temp))
  88:             temp = temp->d.cdr;
  89:         else
  90:             if(typ==SDOT)
  91:             {
  92:             if(temp->s.CDR==0)
  93:                 temp = nil;
  94:             else
  95:                 temp = temp->s.CDR;
  96:             if(TYPE(temp)==DTPR)
  97:                     errorh1(Vermisc,"Fell off the end of a bignum",nil,FALSE,5,lbot->val);
  98:             }
  99:         else
 100:             if(Schainp!=nil && typ==ATOM)
 101:             return(nil);
 102:         else
 103:             return(errorh1(Vermisc,"Bad arg to cdr",nil,FALSE,5,temp));
 104:         }
 105:     }
 106: 
 107:     for( i=0 ; i<as ; i++)
 108:     {
 109:         if( temp != nil )
 110:         {
 111:         typ = TYPE(temp);
 112:         if ((typ == DTPR) || HUNKP(temp))
 113:             temp = temp->d.car;
 114:         else if(typ == SDOT)
 115:             temp2 = inewint(temp->i), temp = temp2;
 116:         else if(Schainp!=nil && typ==ATOM)
 117:             return(nil);
 118:         else
 119:             return(errorh1(Vermisc,"Bad arg to car",nil,FALSE,5,temp));
 120:         }
 121:     }
 122: 
 123:     return(temp);
 124: }
 125: 
 126: lispval
 127: Lcar()
 128: {   return(cxxr(1,0)); }
 129: 
 130: lispval
 131: Lcdr()
 132: {   return(cxxr(0,1)); }
 133: 
 134: lispval
 135: Lcadr()
 136: {   return(cxxr(1,1)); }
 137: 
 138: lispval
 139: Lcaar()
 140: {   return(cxxr(2,0)); }
 141: 
 142: lispval
 143: Lc02r()
 144: {   return(cxxr(0,2)); }    /* cddr */
 145: 
 146: lispval
 147: Lc12r()
 148: {   return(cxxr(1,2)); }    /* caddr */
 149: 
 150: lispval
 151: Lc03r()
 152: {   return(cxxr(0,3)); }    /* cdddr */
 153: 
 154: lispval
 155: Lc13r()
 156: {   return(cxxr(1,3)); }    /* cadddr */
 157: 
 158: lispval
 159: Lc04r()
 160: {   return(cxxr(0,4)); }    /* cddddr */
 161: 
 162: lispval
 163: Lc14r()
 164: {   return(cxxr(1,4)); }    /* caddddr */
 165: 
 166: /*
 167:  *
 168:  *	(nthelem num list)
 169:  *
 170:  * Returns the num'th element of the list, by doing a caddddd...ddr
 171:  * where there are num-1 d's. If num<=0 or greater than the length of
 172:  * the list, we return nil.
 173:  *
 174:  */
 175: 
 176: lispval
 177: Lnthelem()
 178: {
 179:     register lispval temp;
 180:     register int i;
 181: 
 182:     chkarg(2,"nthelem");
 183: 
 184:     if( TYPE(temp = lbot->val) != INT)
 185:     return (error ("First arg to nthelem must be a fixnum",FALSE));
 186: 
 187:     i = temp->i;    /* pick up the first arg */
 188: 
 189:     if( i <= 0) return(nil);
 190: 
 191:     ++lbot;         /* fix lbot for call to cxxr() 'cadddd..r' */
 192:     temp = cxxr(1,i-1);
 193:     --lbot;
 194: 
 195:     return(temp);
 196: }
 197: 
 198: lispval
 199: Lscons()
 200: {
 201:     register struct argent *argp = lbot;
 202:     register lispval retp, handy;
 203: 
 204:     chkarg(2,"scons");
 205:     retp = newsdot();
 206:     handy = (argp) -> val;
 207:     if(TYPE(handy)!=INT)
 208:         error("First arg to scons must be an int.",FALSE);
 209:     retp->s.I = handy->i;
 210:     handy = (argp+1)->val;
 211:     if(handy==nil)
 212:         retp->s.CDR = (lispval) 0;
 213:     else {
 214:         if(TYPE(handy)!=SDOT)
 215:             error("Currently you may only link sdots to sdots.",FALSE);
 216:         retp->s.CDR = handy;
 217:     }
 218:     return(retp);
 219: }
 220: 
 221: lispval
 222: Lbigtol(){
 223:     register lispval handy,newp;
 224: 
 225:     chkarg(1,"Bignum-to-list");
 226:     handy = lbot->val;
 227:     while(TYPE(handy)!=SDOT)
 228:         handy = errorh1(Vermisc,
 229:                 "Non bignum argument to Bignum-to-list",
 230:                 nil,TRUE,5755,handy);
 231:     protect(newp = newdot());
 232:     while(handy) {
 233:         newp->d.car = inewint((long)handy->s.I);
 234:         if(handy->s.CDR==(lispval) 0) break;
 235:         newp->d.cdr = newdot();
 236:         newp = newp->d.cdr;
 237:         handy = handy->s.CDR;
 238:     }
 239:     handy = (--np)->val;
 240:     return(handy);
 241: }
 242: 
 243: lispval
 244: Lcons()
 245: {
 246:     register lispval retp;
 247:     register struct argent *argp;
 248: 
 249:     chkarg(2,"cons");
 250:     retp = newdot();
 251:     retp->d.car = ((argp = lbot) -> val);
 252:     retp->d.cdr = argp[1].val;
 253:     return(retp);
 254: }
 255: #define CA 0
 256: #define CD 1
 257: 
 258: lispval
 259: rpla(what)
 260: int what;
 261: {   register struct argent *argp;
 262:     register int typ; register lispval first, second;
 263: 
 264:     chkarg(2,"rplac[ad]");
 265:     argp = np-1;
 266:     first = (argp-1)->val;
 267:     while(first==nil)
 268:         first = error("Attempt to rplac[ad] nil.",TRUE);
 269:     second = argp->val;
 270:     if (((typ = TYPE(first)) == DTPR) || (typ == ATOM) || HUNKP(first)) {
 271:         if (what == CA)
 272:             first->d.car = second;
 273:         else
 274:             first->d.cdr = second;
 275:         return(first);
 276:     }
 277:     if (typ==SDOT) {
 278:         if(what == CA) {
 279:             typ = TYPE(second);
 280:             if(typ!=INT) error("Rplacca of a bignum will only replace INTS",FALSE);
 281:             first->s.I = second->i;
 282:         } else {
 283:             if(second==nil)
 284:                 first->s.CDR = (lispval) 0;
 285:             else
 286:                 first->s.CDR = second;
 287:         }
 288:         return(first);
 289:     }
 290:     return(error("Bad arg to rpla",FALSE));
 291: }
 292: lispval
 293: Lrplca()
 294: {   return(rpla(CA));   }
 295: 
 296: lispval
 297: Lrplcd()
 298: {   return(rpla(CD));   }
 299: 
 300: 
 301: lispval
 302: Leq()
 303: {
 304:     register struct argent *mynp = lbot + AD;
 305: 
 306:     chkarg(2,"eq");
 307:     if(mynp->val==(mynp+1)->val) return(tatom);
 308:     return(nil);
 309: }
 310: 
 311: 
 312: 
 313: lispval
 314: Lnull()
 315: {   chkarg(1,"null");
 316:     return ((lbot->val == nil) ? tatom : nil);
 317: }
 318: 
 319: 
 320: 
 321: /* Lreturn **************************************************************/
 322: /* Returns the first argument - which is nill if not specified.		*/
 323: 
 324: lispval
 325: Lreturn()
 326: {
 327:     if(lbot==np) protect (nil);
 328:     Inonlocalgo(C_RET,lbot->val,nil);
 329:     /* NOT REACHED */
 330: }
 331: 
 332: 
 333: lispval
 334: Linfile()
 335: {
 336:     FILE *port;
 337:     register lispval name;
 338: 
 339:     chkarg(1,"infile");
 340:     name = lbot->val;
 341: loop:
 342:     name = verify(name,"infile: file name must be atom or string");
 343:     /* return nil if file couldnt be opened
 344: 	if ((port = fopen((char *)name,"r")) == NULL) return(nil); */
 345: 
 346:     if ((port = fopen((char *)name,"r")) == NULL) {
 347:         name = errorh1(Vermisc,"Unable to open file for reading.",nil,TRUE,31,name);
 348:         goto loop;
 349:     }
 350:     ioname[PN(port)] = (lispval) inewstr((char *)name); /* remember name */
 351:     return(P(port));
 352: }
 353: 
 354: /* outfile - open a file for writing.
 355:  * 27feb81 [jkf] - modifed to accept two arguments, the second one being a
 356:  *   string or atom, which if it begins with an `a' tells outfile to open the
 357:  *   file in append mode
 358:  */
 359: lispval
 360: Loutfile()
 361: {
 362:     FILE *port; register lispval name;
 363:     char *mode ="w";    /* mode is w for create new file, a for append */
 364:     char *given;
 365: 
 366:     if(lbot+1== np) protect(nil);
 367:     chkarg(2,"outfile");
 368:     name = lbot->val;
 369:     given = (char *)verify((lbot+1)->val,"Illegal file open mode.");
 370:     if(*given == 'a') mode = "a";
 371: loop:
 372:     name = verify(name,"Please supply atom or string name for port.");
 373: #ifdef  os_vms
 374:     /*
 375: 	 *	If "w" mode, open it as a "txt" file for convenience in VMS
 376: 	 */
 377:     if (strcmp(mode,"w") == 0) {
 378:         int fd;
 379: 
 380:         if ((fd = creat(name,0777,"txt")) < 0) {
 381:             name = errorh1(Vermisc,"Unable to open file for writing.",nil,TRUE,31,name);
 382:             goto loop;
 383:         }
 384:         port = fdopen(fd,mode);
 385:     } else
 386: #endif
 387:     if ((port = fopen((char *)name,mode)) == NULL) {
 388:         name = errorh1(Vermisc,"Unable to open file for writing.",nil,TRUE,31,name);
 389:         goto loop;
 390:     }
 391:     ioname[PN(port)] = (lispval) inewstr((char *)name);
 392:     return(P(port));
 393: }
 394: 
 395: lispval
 396: Lterpr()
 397: {
 398:     register lispval handy;
 399:     FILE *port;
 400: 
 401:     if(lbot==np) handy = nil;
 402:     else
 403:     {
 404:         chkarg(1,"terpr");
 405:         handy = lbot->val;
 406:     }
 407: 
 408:     port = okport(handy,okport(Vpoport->a.clb,stdout));
 409:     putc('\n',port);
 410:     fflush(port);
 411:     return(nil);
 412: }
 413: 
 414: lispval
 415: Lclose()
 416: {
 417:     lispval port;
 418: 
 419:     chkarg(1,"close");
 420:     port = lbot->val;
 421:     if((TYPE(port))==PORT) {
 422:         fclose(port->p);
 423:         ioname[PN(port->p)] = nil;
 424:         return(tatom);
 425:     }
 426:     errorh1(Vermisc,"close:Non-port",nil,FALSE,987,port);
 427:     /* not reached */
 428: }
 429: 
 430: lispval
 431: Ltruename()
 432: {
 433:     chkarg(1,"truename");
 434:     if(TYPE(lbot->val) != PORT)
 435:         errorh1(Vermisc,"truename: non port argument",nil,FALSE,0,lbot->val);
 436: 
 437:     return(ioname[PN(lbot->val->p)]);
 438: }
 439: 
 440: lispval
 441: Lnwritn()
 442: {
 443:     register FILE *port;
 444:     register value;
 445:     register lispval handy;
 446: 
 447:     if(lbot==np) handy = nil;
 448:     else
 449:     {
 450:         chkarg(1,"nwritn");
 451:         handy = lbot->val;
 452:     }
 453: 
 454:     port = okport(handy,okport(Vpoport->a.clb,stdout));
 455:     value = port->_ptr - port->_base;
 456:     return(inewint(value));
 457: }
 458: 
 459: lispval
 460: Ldrain()
 461: {
 462:     register FILE *port;
 463:     register int iodes;
 464:     register lispval handy;
 465:     struct sgttyb arg;
 466: 
 467:     if(lbot==np) handy = nil;
 468:     else
 469:     {
 470:         chkarg(1,"nwritn");
 471:         handy = lbot->val;
 472:     }
 473:     port = okport(handy, okport(Vpoport->a.clb,stdout));
 474:     if(port->_flag & _IOWRT) {
 475:         fflush(port);
 476:         return(nil);
 477:     }
 478:     if(! port->_flag & _IOREAD) return(nil);
 479:     port->_cnt = 0;
 480:     port->_ptr = port->_base;
 481:     iodes = fileno(port);
 482:     if(gtty(iodes,&arg) != -1) stty(iodes,&arg);
 483:     return(P(port));
 484: }
 485: 
 486: lispval
 487: Llist()
 488: {
 489:     /* added for the benefit of mapping functions. */
 490:     register struct argent *ulim, *namptr;
 491:     register lispval temp, result;
 492:     Savestack(4);
 493: 
 494:     ulim = np;
 495:     namptr = lbot + AD;
 496:     temp = result = (lispval) np;
 497:     protect(nil);
 498:     for(; namptr < ulim;) {
 499:         temp = temp->l = newdot();
 500:         temp->d.car = (namptr++)->val;
 501:     }
 502:     temp->l = nil;
 503:     Restorestack();
 504:     return(result->l);
 505: }
 506: 
 507: lispval
 508: Lnumberp()
 509: {
 510:     chkarg(1,"numberp");
 511:     switch(TYPE(lbot->val)) {
 512:     case INT: case DOUB: case SDOT:
 513:         return(tatom);
 514:     }
 515:     return(nil);
 516: }
 517: 
 518: lispval
 519: Latom()
 520: {
 521:     register struct argent *lb = lbot;
 522:     chkarg(1,"atom");
 523:     if(TYPE(lb->val)==DTPR || (HUNKP(lb->val)))
 524:         return(nil);
 525:     else
 526:         return(tatom);
 527: }
 528: 
 529: lispval
 530: Ltype()
 531: {
 532:     chkarg(1,"type");
 533:     switch(TYPE(lbot->val)) {
 534:     case INT:
 535:         return(int_name);
 536:     case ATOM:
 537:         return(atom_name);
 538:     case SDOT:
 539:         return(sdot_name);
 540:     case DOUB:
 541:         return(doub_name);
 542:     case DTPR:
 543:         return(dtpr_name);
 544:     case STRNG:
 545:         return(str_name);
 546:     case ARRAY:
 547:         return(array_name);
 548:     case BCD:
 549:         return(funct_name);
 550:     case OTHER:
 551:         return(other_name);
 552: 
 553:     case HUNK2:
 554:         return(hunk_name[0]);
 555:     case HUNK4:
 556:         return(hunk_name[1]);
 557:     case HUNK8:
 558:         return(hunk_name[2]);
 559:     case HUNK16:
 560:         return(hunk_name[3]);
 561:     case HUNK32:
 562:         return(hunk_name[4]);
 563:     case HUNK64:
 564:         return(hunk_name[5]);
 565:     case HUNK128:
 566:         return(hunk_name[6]);
 567: 
 568:     case VECTOR:
 569:         return(vect_name);
 570:     case VECTORI:
 571:         return(vecti_name);
 572: 
 573:     case VALUE:
 574:         return(val_name);
 575:     case PORT:
 576:         return(port_name);
 577:     }
 578:     return(nil);
 579: }
 580: 
 581: lispval
 582: Ldtpr()
 583: {
 584:     chkarg(1,"dtpr");
 585:     return(typred(DTPR, lbot->val));
 586: }
 587: 
 588: lispval
 589: Lbcdp()
 590: {
 591:     chkarg(1,"bcdp");
 592:     return(typred(BCD, lbot->val));
 593: }
 594: 
 595: lispval
 596: Lportp()
 597: {
 598:     chkarg(1,"portp");
 599:     return(typred(PORT, lbot->val));
 600: }
 601: 
 602: lispval
 603: Larrayp()
 604: {
 605:     chkarg(1,"arrayp");
 606:     return(typred(ARRAY, lbot->val));
 607: }
 608: 
 609: /*
 610:  *	(hunkp 'g_arg1)
 611:  * Returns t if g_arg1 is a hunk, otherwise returns nil.
 612:  */
 613: 
 614: lispval
 615: Lhunkp()
 616: {
 617:     chkarg(1,"hunkp");
 618:     if (HUNKP(lbot->val))
 619:         return(tatom);      /* If a hunk, return t */
 620:     else
 621:         return(nil);        /* else nil */
 622: }
 623: 
 624: lispval
 625: Lset()
 626: {
 627:     lispval varble;
 628: 
 629:     chkarg(2,"set");
 630:     varble = lbot->val;
 631:     switch(TYPE(varble))
 632:         {
 633:     case ATOM:  return(varble->a.clb = lbot[1].val);
 634: 
 635:     case VALUE: return(varble->l = lbot[1].val);
 636:         }
 637: 
 638:     error("IMPROPER USE OF SET",FALSE);
 639:     /* NOTREACHED */
 640: }
 641: 
 642: lispval
 643: Lequal()
 644: {
 645:     register lispval first, second;
 646:     register type1, type2;
 647:     lispval Lsub(),Lzerop();
 648:     long *oldsp;
 649:     Keepxs();
 650:     chkarg(2,"equal");
 651: 
 652: 
 653:     if(lbot->val==lbot[1].val) return(tatom);
 654: 
 655:     oldsp=sp(); stack((long)lbot->val);stack((long)lbot[1].val);
 656:     for(;oldsp > sp();) {
 657: 
 658:         first = (lispval) unstack(); second = (lispval) unstack();
 659:     again:
 660:         if(first==second) continue;
 661: 
 662:         type1=TYPE(first); type2=TYPE(second);
 663:         if(type1!=type2) {
 664:         if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
 665:             goto dosub;
 666:         {Freexs(); return(nil);}
 667:         }
 668:         switch(type1) {
 669:         case DTPR:
 670:         stack((long)first->d.cdr); stack((long)second->d.cdr);
 671:         first = first->d.car; second = second->d.car;
 672:         goto again;
 673:         case DOUB:
 674:         if(first->r!=second->r)
 675:             {Freexs(); return(nil);}
 676:         continue;
 677:         case INT:
 678:         if(first->i!=second->i)
 679:             {Freexs(); return(nil);}
 680:         continue;
 681:         case VECTOR:
 682:             if(!vecequal(first,second)) {Freexs(); return(nil);}
 683:         continue;
 684:         case VECTORI:
 685:             if(!veciequal(first,second)) {Freexs(); return(nil);}
 686:         continue;
 687:     dosub:
 688:         case SDOT: {
 689:         lispval temp;
 690:         struct argent *OLDlbot = lbot;
 691:         lbot = np;
 692:         np++->val = first;
 693:         np++->val = second;
 694:         temp = Lsub();
 695:         np = lbot;
 696:         lbot = OLDlbot;
 697:         if(TYPE(temp)!=INT || temp->i!=0)
 698:             {Freexs(); return(nil);}
 699:         }
 700:         continue;
 701:         case VALUE:
 702:         if(first->l!=second->l)
 703:             {Freexs(); return(nil);}
 704:         continue;
 705:         case STRNG:
 706:         if(strcmp((char *)first,(char *)second)!=0)
 707:             {Freexs(); return(nil);}
 708:         continue;
 709: 
 710:         default:
 711:         {Freexs(); return(nil);}
 712:         }
 713:     }
 714:     {Freexs(); return(tatom);}
 715: }
 716: lispval
 717: oLequal()
 718: {
 719:     chkarg(2,"equal");
 720: 
 721:     if( lbot[1].val == lbot->val ) return(tatom);
 722:     if(Iequal(lbot[1].val,lbot->val)) return(tatom); else return(nil);
 723: }
 724: 
 725: Iequal(first,second)
 726: register lispval first, second;
 727: {
 728:     register type1, type2;
 729:     lispval Lsub(),Lzerop();
 730: 
 731:     if(first==second)
 732:         return(1);
 733:     type1=TYPE(first);
 734:     type2=TYPE(second);
 735:     if(type1!=type2) {
 736:         if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
 737:             goto dosub;
 738:         return(0);
 739:     }
 740:     switch(type1) {
 741:     case DTPR:
 742:          return(
 743:             Iequal(first->d.car,second->d.car) &&
 744:             Iequal(first->d.cdr,second->d.cdr) );
 745:     case DOUB:
 746:         return(first->r==second->r);
 747:     case INT:
 748:         return( (first->i==second->i));
 749: dosub:
 750:     case SDOT:
 751:     {
 752:         lispval temp;
 753:         struct argent *OLDlbot = lbot;
 754:         lbot = np;
 755:         np++->val = first;
 756:         np++->val = second;
 757:         temp = Lsub();
 758:         np = lbot;
 759:         lbot = OLDlbot;
 760:         return(TYPE(temp)==INT&& temp->i==0);
 761:     }
 762:     case VALUE:
 763:         return( first->l==second->l );
 764:     case STRNG:
 765:         return(strcmp((char *)first,(char *)second)==0);
 766:     }
 767:     return(0);
 768: }
 769: lispval
 770: Zequal()
 771: {
 772:     register lispval first, second;
 773:     register type1, type2;
 774:     lispval Lsub(),Lzerop();
 775:     long *oldsp;
 776:     Keepxs();
 777:     chkarg(2,"equal");
 778: 
 779: 
 780:     if(lbot->val==lbot[1].val) return(tatom);
 781: 
 782:     oldsp=sp(); stack((long)lbot->val);stack((long)lbot[1].val);
 783: 
 784:     for(;oldsp > sp();) {
 785: 
 786:         first = (lispval) unstack(); second = (lispval) unstack();
 787:     again:
 788:         if(first==second) continue;
 789: 
 790:         type1=TYPE(first); type2=TYPE(second);
 791:         if(type1!=type2) {
 792:         if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT))
 793:             goto dosub;
 794:         {Freexs(); return(nil);}
 795:         }
 796:         switch(type1) {
 797:         case DTPR:
 798:         stack((long)first->d.cdr); stack((long)second->d.cdr);
 799:         first = first->d.car; second = second->d.car;
 800:         goto again;
 801:         case DOUB:
 802:         if(first->r!=second->r)
 803:             {Freexs(); return(nil);}
 804:         continue;
 805:         case INT:
 806:         if(first->i!=second->i)
 807:             {Freexs(); return(nil);}
 808:         continue;
 809:     dosub:
 810:         case SDOT:
 811:         {
 812:         lispval temp;
 813:         struct argent *OLDlbot = lbot;
 814:         lbot = np;
 815:         np++->val = first;
 816:         np++->val = second;
 817:         temp = Lsub();
 818:         np = lbot;
 819:         lbot = OLDlbot;
 820:         if(TYPE(temp)!=INT || temp->i!=0)
 821:             {Freexs(); return(nil);}
 822:         }
 823:         continue;
 824:         case VALUE:
 825:         if(first->l!=second->l)
 826:             {Freexs(); return(nil);}
 827:         continue;
 828:         case STRNG:
 829:         if(strcmp((char *)first,(char *)second)!=0)
 830:             {Freexs(); return(nil);}
 831:         continue;
 832:         }
 833:     }
 834:     {Freexs(); return(tatom);}
 835: }
 836: 
 837: /*
 838:  * (print 'expression ['port]) prints the given expression to the given
 839:  * port or poport if no port is given.  The amount of structure
 840:  * printed is a function of global lisp variables plevel and
 841:  * plength.
 842:  */
 843: lispval
 844: Lprint()
 845: {
 846:     register lispval handy;
 847:     extern int plevel,plength;
 848: 
 849: 
 850:     handy = nil;            /* port is optional, default nil */
 851:     switch(np-lbot)
 852:     {
 853:         case 2: handy = lbot[1].val;
 854:         case 1: break;
 855:         default: argerr("print");
 856:     }
 857: 
 858:     chkrtab(Vreadtable->a.clb);
 859:     if(TYPE(Vprinlevel->a.clb) == INT)
 860:     {
 861:        plevel = Vprinlevel->a.clb->i;
 862:     }
 863:     else plevel = -1;
 864:     if(TYPE(Vprinlength->a.clb) == INT)
 865:     {
 866:         plength = Vprinlength->a.clb->i;
 867:     }
 868:     else plength = -1;
 869:     printr(lbot->val,okport(handy,okport(Vpoport->a.clb,poport)));
 870:     return(nil);
 871: }
 872: 
 873: /* patom does not use plevel or plength
 874:  *
 875:  * form is (patom 'value ['port])
 876:  */
 877: lispval
 878: Lpatom()
 879: {
 880:     register lispval temp;
 881:     register lispval handy;
 882:     register int typ;
 883:     FILE *port;
 884: 
 885:     handy = nil;            /* port is optional, default nil */
 886:     switch(np-lbot)
 887:     {
 888:         case 2: handy = lbot[1].val;
 889:         case 1: break;
 890:         default: argerr("patom");
 891:     }
 892: 
 893:     temp = Vreadtable->a.clb;
 894:     chkrtab(temp);
 895:     port = okport(handy, okport(Vpoport->a.clb,stdout));
 896:     if ((typ= TYPE((temp = (lbot)->val))) == ATOM)
 897:         fputs(temp->a.pname, port);
 898:     else if(typ == STRNG)
 899:         fputs((char *)temp,port);
 900:     else
 901:     {
 902:             if(TYPE(Vprinlevel->a.clb) == INT)
 903:         {
 904:             plevel = Vprinlevel->a.clb->i;
 905:         }
 906:         else plevel = -1;
 907:         if(TYPE(Vprinlength->a.clb) == INT)
 908:         {
 909:             plength = Vprinlength->a.clb->i;
 910:         }
 911:         else plength = -1;
 912: 
 913:         printr(temp, port);
 914:     }
 915:     return(temp);
 916: }
 917: 
 918: /*
 919:  * (pntlen thing) returns the length it takes to print out
 920:  * an atom or number.
 921:  */
 922: 
 923: lispval
 924: Lpntlen()
 925: {
 926:     return(inewint((long)Ipntlen()));
 927: }
 928: Ipntlen()
 929: {
 930:     register lispval temp;
 931:     register char *handy;
 932:     char *sprintf();
 933: 
 934:     temp = np[-1].val;
 935: loop:   switch(TYPE(temp)) {
 936: 
 937:     case ATOM:
 938:         handy = temp->a.pname;
 939:         break;
 940: 
 941:     case STRNG:
 942:         handy = (char *) temp;
 943:         break;
 944: 
 945:     case INT:
 946:         sprintf(strbuf,"%d",temp->i);
 947:         handy =strbuf;
 948:         break;
 949: 
 950:     case DOUB:
 951:         sprintf(strbuf,"%g",temp->r);
 952:         handy =strbuf;
 953:         break;
 954: 
 955:     default:
 956:         temp = error("Non atom or number to pntlen\n",TRUE);
 957:         goto loop;
 958:     }
 959: 
 960:     return( strlen(handy));
 961: }
 962: #undef okport
 963: FILE *
 964: okport(arg,proper)
 965: lispval arg;
 966: FILE *proper;
 967: {
 968:     if(TYPE(arg)!=PORT)
 969:         return(proper);
 970:     else
 971:         return(arg->p);
 972: }

Defined functions

Defined variables

Defined macros