![[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] / 42BSD / ucb / lisp / franz|
Return to lam1.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 ! root 1: #ifndef lint ! 2: static char *rcsid = ! 3: "$Header: lam1.c,v 1.4 83/09/12 14:10:52 sklower Exp $"; ! 4: #endif ! 5: ! 6: /* -[Fri Aug 12 07:28:13 1983 by jkf]- ! 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: Lrplaca() ! 294: { return(rpla(CA)); } ! 295: ! 296: lispval ! 297: Lrplacd() ! 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: } ! 428: ! 429: lispval ! 430: Ltruename() ! 431: { ! 432: chkarg(1,"truename"); ! 433: if(TYPE(lbot->val) != PORT) ! 434: errorh1(Vermisc,"truename: non port argument",nil,FALSE,0,lbot->val); ! 435: ! 436: return(ioname[PN(lbot->val->p)]); ! 437: } ! 438: ! 439: lispval ! 440: Lnwritn() ! 441: { ! 442: register FILE *port; ! 443: register value; ! 444: register lispval handy; ! 445: ! 446: if(lbot==np) handy = nil; ! 447: else ! 448: { ! 449: chkarg(1,"nwritn"); ! 450: handy = lbot->val; ! 451: } ! 452: ! 453: port = okport(handy,okport(Vpoport->a.clb,stdout)); ! 454: value = port->_ptr - port->_base; ! 455: return(inewint(value)); ! 456: } ! 457: ! 458: lispval ! 459: Ldrain() ! 460: { ! 461: register FILE *port; ! 462: register int iodes; ! 463: register lispval handy; ! 464: struct sgttyb arg; ! 465: ! 466: if(lbot==np) handy = nil; ! 467: else ! 468: { ! 469: chkarg(1,"nwritn"); ! 470: handy = lbot->val; ! 471: } ! 472: port = okport(handy, okport(Vpoport->a.clb,stdout)); ! 473: if(port->_flag & _IOWRT) { ! 474: fflush(port); ! 475: return(nil); ! 476: } ! 477: if(! port->_flag & _IOREAD) return(nil); ! 478: port->_cnt = 0; ! 479: port->_ptr = port->_base; ! 480: iodes = fileno(port); ! 481: if(gtty(iodes,&arg) != -1) stty(iodes,&arg); ! 482: return((lispval)(xports + (port - _iob))); ! 483: } ! 484: ! 485: lispval ! 486: Llist() ! 487: { ! 488: /* added for the benefit of mapping functions. */ ! 489: register struct argent *ulim, *namptr; ! 490: register lispval temp, result; ! 491: Savestack(4); ! 492: ! 493: ulim = np; ! 494: namptr = lbot + AD; ! 495: temp = result = (lispval) np; ! 496: protect(nil); ! 497: for(; namptr < ulim;) { ! 498: temp = temp->l = newdot(); ! 499: temp->d.car = (namptr++)->val; ! 500: } ! 501: temp->l = nil; ! 502: Restorestack(); ! 503: return(result->l); ! 504: } ! 505: ! 506: lispval ! 507: Lnumberp() ! 508: { ! 509: chkarg(1,"numberp"); ! 510: switch(TYPE(lbot->val)) { ! 511: case INT: case DOUB: case SDOT: ! 512: return(tatom); ! 513: } ! 514: return(nil); ! 515: } ! 516: ! 517: lispval ! 518: Latom() ! 519: { ! 520: register struct argent *lb = lbot; ! 521: chkarg(1,"atom"); ! 522: if(TYPE(lb->val)==DTPR || (HUNKP(lb->val))) ! 523: return(nil); ! 524: else ! 525: return(tatom); ! 526: } ! 527: ! 528: lispval ! 529: Ltype() ! 530: { ! 531: chkarg(1,"type"); ! 532: switch(TYPE(lbot->val)) { ! 533: case INT: ! 534: return(int_name); ! 535: case ATOM: ! 536: return(atom_name); ! 537: case SDOT: ! 538: return(sdot_name); ! 539: case DOUB: ! 540: return(doub_name); ! 541: case DTPR: ! 542: return(dtpr_name); ! 543: case STRNG: ! 544: return(str_name); ! 545: case ARRAY: ! 546: return(array_name); ! 547: case BCD: ! 548: return(funct_name); ! 549: case OTHER: ! 550: return(other_name); ! 551: ! 552: case HUNK2: ! 553: return(hunk_name[0]); ! 554: case HUNK4: ! 555: return(hunk_name[1]); ! 556: case HUNK8: ! 557: return(hunk_name[2]); ! 558: case HUNK16: ! 559: return(hunk_name[3]); ! 560: case HUNK32: ! 561: return(hunk_name[4]); ! 562: case HUNK64: ! 563: return(hunk_name[5]); ! 564: case HUNK128: ! 565: return(hunk_name[6]); ! 566: ! 567: case VECTOR: ! 568: return(vect_name); ! 569: case VECTORI: ! 570: return(vecti_name); ! 571: ! 572: case VALUE: ! 573: return(val_name); ! 574: case PORT: ! 575: return(port_name); ! 576: } ! 577: return(nil); ! 578: } ! 579: ! 580: lispval ! 581: Ldtpr() ! 582: { ! 583: chkarg(1,"dtpr"); ! 584: return(typred(DTPR, lbot->val)); ! 585: } ! 586: ! 587: lispval ! 588: Lbcdp() ! 589: { ! 590: chkarg(1,"bcdp"); ! 591: return(typred(BCD, lbot->val)); ! 592: } ! 593: ! 594: lispval ! 595: Lportp() ! 596: { ! 597: chkarg(1,"portp"); ! 598: return(typred(PORT, lbot->val)); ! 599: } ! 600: ! 601: lispval ! 602: Larrayp() ! 603: { ! 604: chkarg(1,"arrayp"); ! 605: return(typred(ARRAY, lbot->val)); ! 606: } ! 607: ! 608: /* ! 609: * (hunkp 'g_arg1) ! 610: * Returns t if g_arg1 is a hunk, otherwise returns nil. ! 611: */ ! 612: ! 613: lispval ! 614: Lhunkp() ! 615: { ! 616: chkarg(1,"hunkp"); ! 617: if (HUNKP(lbot->val)) ! 618: return(tatom); /* If a hunk, return t */ ! 619: else ! 620: return(nil); /* else nil */ ! 621: } ! 622: ! 623: lispval ! 624: Lset() ! 625: { ! 626: lispval varble; ! 627: ! 628: chkarg(2,"set"); ! 629: varble = lbot->val; ! 630: switch(TYPE(varble)) ! 631: { ! 632: case ATOM: return(varble->a.clb = lbot[1].val); ! 633: ! 634: case VALUE: return(varble->l = lbot[1].val); ! 635: } ! 636: ! 637: error("IMPROPER USE OF SET",FALSE); ! 638: /* NOTREACHED */ ! 639: } ! 640: ! 641: lispval ! 642: Lequal() ! 643: { ! 644: register lispval first, second; ! 645: register type1, type2; ! 646: lispval Lsub(),Lzerop(); ! 647: long *oldsp; ! 648: Keepxs(); ! 649: chkarg(2,"equal"); ! 650: ! 651: ! 652: if(lbot->val==lbot[1].val) return(tatom); ! 653: ! 654: oldsp=sp(); stack((long)lbot->val);stack((long)lbot[1].val); ! 655: for(;oldsp > sp();) { ! 656: ! 657: first = (lispval) unstack(); second = (lispval) unstack(); ! 658: again: ! 659: if(first==second) continue; ! 660: ! 661: type1=TYPE(first); type2=TYPE(second); ! 662: if(type1!=type2) { ! 663: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT)) ! 664: goto dosub; ! 665: {Freexs(); return(nil);} ! 666: } ! 667: switch(type1) { ! 668: case DTPR: ! 669: stack((long)first->d.cdr); stack((long)second->d.cdr); ! 670: first = first->d.car; second = second->d.car; ! 671: goto again; ! 672: case DOUB: ! 673: if(first->r!=second->r) ! 674: {Freexs(); return(nil);} ! 675: continue; ! 676: case INT: ! 677: if(first->i!=second->i) ! 678: {Freexs(); return(nil);} ! 679: continue; ! 680: case VECTOR: ! 681: if(!vecequal(first,second)) {Freexs(); return(nil);} ! 682: continue; ! 683: case VECTORI: ! 684: if(!veciequal(first,second)) {Freexs(); return(nil);} ! 685: continue; ! 686: dosub: ! 687: case SDOT: { ! 688: lispval temp; ! 689: struct argent *OLDlbot = lbot; ! 690: lbot = np; ! 691: np++->val = first; ! 692: np++->val = second; ! 693: temp = Lsub(); ! 694: np = lbot; ! 695: lbot = OLDlbot; ! 696: if(TYPE(temp)!=INT || temp->i!=0) ! 697: {Freexs(); return(nil);} ! 698: } ! 699: continue; ! 700: case VALUE: ! 701: if(first->l!=second->l) ! 702: {Freexs(); return(nil);} ! 703: continue; ! 704: case STRNG: ! 705: if(strcmp((char *)first,(char *)second)!=0) ! 706: {Freexs(); return(nil);} ! 707: continue; ! 708: ! 709: default: ! 710: {Freexs(); return(nil);} ! 711: } ! 712: } ! 713: {Freexs(); return(tatom);} ! 714: } ! 715: lispval ! 716: oLequal() ! 717: { ! 718: chkarg(2,"equal"); ! 719: ! 720: if( lbot[1].val == lbot->val ) return(tatom); ! 721: if(Iequal(lbot[1].val,lbot->val)) return(tatom); else return(nil); ! 722: } ! 723: ! 724: Iequal(first,second) ! 725: register lispval first, second; ! 726: { ! 727: register type1, type2; ! 728: lispval Lsub(),Lzerop(); ! 729: ! 730: if(first==second) ! 731: return(1); ! 732: type1=TYPE(first); ! 733: type2=TYPE(second); ! 734: if(type1!=type2) { ! 735: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT)) ! 736: goto dosub; ! 737: return(0); ! 738: } ! 739: switch(type1) { ! 740: case DTPR: ! 741: return( ! 742: Iequal(first->d.car,second->d.car) && ! 743: Iequal(first->d.cdr,second->d.cdr) ); ! 744: case DOUB: ! 745: return(first->r==second->r); ! 746: case INT: ! 747: return( (first->i==second->i)); ! 748: dosub: ! 749: case SDOT: ! 750: { ! 751: lispval temp; ! 752: struct argent *OLDlbot = lbot; ! 753: lbot = np; ! 754: np++->val = first; ! 755: np++->val = second; ! 756: temp = Lsub(); ! 757: np = lbot; ! 758: lbot = OLDlbot; ! 759: return(TYPE(temp)==INT&& temp->i==0); ! 760: } ! 761: case VALUE: ! 762: return( first->l==second->l ); ! 763: case STRNG: ! 764: return(strcmp((char *)first,(char *)second)==0); ! 765: } ! 766: return(0); ! 767: } ! 768: lispval ! 769: Zequal() ! 770: { ! 771: register lispval first, second; ! 772: register type1, type2; ! 773: lispval Lsub(),Lzerop(); ! 774: long *oldsp; ! 775: Keepxs(); ! 776: chkarg(2,"equal"); ! 777: ! 778: ! 779: if(lbot->val==lbot[1].val) return(tatom); ! 780: ! 781: oldsp=sp(); stack((long)lbot->val);stack((long)lbot[1].val); ! 782: ! 783: for(;oldsp > sp();) { ! 784: ! 785: first = (lispval) unstack(); second = (lispval) unstack(); ! 786: again: ! 787: if(first==second) continue; ! 788: ! 789: type1=TYPE(first); type2=TYPE(second); ! 790: if(type1!=type2) { ! 791: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT)) ! 792: goto dosub; ! 793: {Freexs(); return(nil);} ! 794: } ! 795: switch(type1) { ! 796: case DTPR: ! 797: stack((long)first->d.cdr); stack((long)second->d.cdr); ! 798: first = first->d.car; second = second->d.car; ! 799: goto again; ! 800: case DOUB: ! 801: if(first->r!=second->r) ! 802: {Freexs(); return(nil);} ! 803: continue; ! 804: case INT: ! 805: if(first->i!=second->i) ! 806: {Freexs(); return(nil);} ! 807: continue; ! 808: dosub: ! 809: case SDOT: ! 810: { ! 811: lispval temp; ! 812: struct argent *OLDlbot = lbot; ! 813: lbot = np; ! 814: np++->val = first; ! 815: np++->val = second; ! 816: temp = Lsub(); ! 817: np = lbot; ! 818: lbot = OLDlbot; ! 819: if(TYPE(temp)!=INT || temp->i!=0) ! 820: {Freexs(); return(nil);} ! 821: } ! 822: continue; ! 823: case VALUE: ! 824: if(first->l!=second->l) ! 825: {Freexs(); return(nil);} ! 826: continue; ! 827: case STRNG: ! 828: if(strcmp((char *)first,(char *)second)!=0) ! 829: {Freexs(); return(nil);} ! 830: continue; ! 831: } ! 832: } ! 833: {Freexs(); return(tatom);} ! 834: } ! 835: ! 836: /* ! 837: * (print 'expression ['port]) prints the given expression to the given ! 838: * port or poport if no port is given. The amount of structure ! 839: * printed is a function of global lisp variables plevel and ! 840: * plength. ! 841: */ ! 842: lispval ! 843: Lprint() ! 844: { ! 845: register lispval handy; ! 846: extern int plevel,plength; ! 847: ! 848: ! 849: handy = nil; /* port is optional, default nil */ ! 850: switch(np-lbot) ! 851: { ! 852: case 2: handy = lbot[1].val; ! 853: case 1: break; ! 854: default: argerr("print"); ! 855: } ! 856: ! 857: chkrtab(Vreadtable->a.clb); ! 858: if(TYPE(Vprinlevel->a.clb) == INT) ! 859: { ! 860: plevel = Vprinlevel->a.clb->i; ! 861: } ! 862: else plevel = -1; ! 863: if(TYPE(Vprinlength->a.clb) == INT) ! 864: { ! 865: plength = Vprinlength->a.clb->i; ! 866: } ! 867: else plength = -1; ! 868: printr(lbot->val,okport(handy,okport(Vpoport->a.clb,poport))); ! 869: return(nil); ! 870: } ! 871: ! 872: /* patom does not use plevel or plength ! 873: * ! 874: * form is (patom 'value ['port]) ! 875: */ ! 876: lispval ! 877: Lpatom() ! 878: { ! 879: register lispval temp; ! 880: register lispval handy; ! 881: register int typ; ! 882: FILE *port; ! 883: ! 884: handy = nil; /* port is optional, default nil */ ! 885: switch(np-lbot) ! 886: { ! 887: case 2: handy = lbot[1].val; ! 888: case 1: break; ! 889: default: argerr("patom"); ! 890: } ! 891: ! 892: temp = Vreadtable->a.clb; ! 893: chkrtab(temp); ! 894: port = okport(handy, okport(Vpoport->a.clb,stdout)); ! 895: if ((typ= TYPE((temp = (lbot)->val))) == ATOM) ! 896: fputs(temp->a.pname, port); ! 897: else if(typ == STRNG) ! 898: fputs((char *)temp,port); ! 899: else ! 900: { ! 901: if(TYPE(Vprinlevel->a.clb) == INT) ! 902: { ! 903: plevel = Vprinlevel->a.clb->i; ! 904: } ! 905: else plevel = -1; ! 906: if(TYPE(Vprinlength->a.clb) == INT) ! 907: { ! 908: plength = Vprinlength->a.clb->i; ! 909: } ! 910: else plength = -1; ! 911: ! 912: printr(temp, port); ! 913: } ! 914: return(temp); ! 915: } ! 916: ! 917: /* ! 918: * (pntlen thing) returns the length it takes to print out ! 919: * an atom or number. ! 920: */ ! 921: ! 922: lispval ! 923: Lpntlen() ! 924: { ! 925: return(inewint((long)Ipntlen())); ! 926: } ! 927: Ipntlen() ! 928: { ! 929: register lispval temp; ! 930: register char *handy; ! 931: char *sprintf(); ! 932: ! 933: temp = np[-1].val; ! 934: loop: switch(TYPE(temp)) { ! 935: ! 936: case ATOM: ! 937: handy = temp->a.pname; ! 938: break; ! 939: ! 940: case STRNG: ! 941: handy = (char *) temp; ! 942: break; ! 943: ! 944: case INT: ! 945: sprintf(strbuf,"%d",temp->i); ! 946: handy =strbuf; ! 947: break; ! 948: ! 949: case DOUB: ! 950: sprintf(strbuf,"%g",temp->r); ! 951: handy =strbuf; ! 952: break; ! 953: ! 954: default: ! 955: temp = error("Non atom or number to pntlen\n",TRUE); ! 956: goto loop; ! 957: } ! 958: ! 959: return( strlen(handy)); ! 960: } ! 961: #undef okport ! 962: FILE * ! 963: okport(arg,proper) ! 964: lispval arg; ! 965: FILE *proper; ! 966: { ! 967: if(TYPE(arg)!=PORT) ! 968: return(proper); ! 969: else ! 970: return(arg->p); ! 971: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.