![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lam1.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz|
Return to lam1.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz |
1.1 ! root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.