![[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] / 40BSD / cmd / lisp|
Return to lam1.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 ! root 1: static char *sccsid = "@(#)lam1.c 34.3 10/24/80"; ! 2: ! 3: # include "global.h" ! 4: # include <sgtty.h> ! 5: # include "chkrtab.h" ! 6: /**************************************************************************/ ! 7: /* */ ! 8: /* file: ccdfns.i */ ! 9: /* contents: LISP functions coded in C */ ! 10: /* */ ! 11: /* These include LISP primitives, numeric and boolean functions and */ ! 12: /* predicates, some list-processing functions, i/o support functions */ ! 13: /* and control flow functions (e.g. cont, break). */ ! 14: /* There are two types of functions: lambda (prefixed "L") and nlambda */ ! 15: /* (prefixed "N"). */ ! 16: /* Lambda's all call chkarg to insure that at least the minimum number */ ! 17: /* of necessary arguments are on the namestack. */ ! 18: /* All functions take their arguments from the namestack in a read- */ ! 19: /* only manner, and return their results via the normal C value */ ! 20: /* return mechanism. */ ! 21: /* */ ! 22: ! 23: lispval ! 24: Leval() ! 25: { ! 26: register lispval temp; ! 27: ! 28: chkarg(1,"eval"); ! 29: temp = lbot->val; ! 30: return(eval(temp)); ! 31: } ! 32: ! 33: lispval ! 34: Lxcar() ! 35: { register int typ; ! 36: register lispval temp, result; ! 37: ! 38: chkarg(1,"xcar"); ! 39: temp = lbot->val; ! 40: if (((typ = TYPE(temp)) == DTPR) || (typ == ATOM) || HUNKP(temp)) ! 41: return(temp->d.car); ! 42: else if(typ == SDOT) { ! 43: result = inewint(temp->i); ! 44: return(result); ! 45: } else if(Schainp!=nil && typ==ATOM) ! 46: return(nil); ! 47: else ! 48: return(error("Bad arg to car",FALSE)); ! 49: ! 50: } ! 51: ! 52: lispval ! 53: Lxcdr() ! 54: { register int typ; ! 55: register lispval temp, result; ! 56: ! 57: chkarg(1,"xcdr"); ! 58: temp = lbot->val; ! 59: if(temp==nil) return (nil); ! 60: ! 61: if (((typ = TYPE(temp)) == DTPR) || HUNKP(temp)) ! 62: return(temp->d.cdr); ! 63: else if(typ==SDOT) { ! 64: if(temp->s.CDR==0) return(nil); ! 65: return(temp->s.CDR); ! 66: } else if(Schainp!=nil && typ==ATOM) ! 67: return(nil); ! 68: else ! 69: return(error("Bad arg to cdr", FALSE)); ! 70: } ! 71: ! 72: lispval ! 73: cxxr(as,ds) ! 74: register int as,ds; ! 75: { ! 76: ! 77: register lispval temp, temp2; ! 78: int i, typ; ! 79: lispval errorh(); ! 80: ! 81: chkarg(1,"c{ad}+r"); ! 82: temp = lbot->val; ! 83: ! 84: for( i=0 ; i<ds ; i++) ! 85: { ! 86: if( temp != nil) ! 87: { ! 88: typ = TYPE(temp); ! 89: if ((typ == DTPR) || HUNKP(temp)) ! 90: temp = temp->d.cdr; ! 91: else ! 92: if(typ==SDOT) ! 93: { ! 94: if(temp->s.CDR==0) ! 95: temp = nil; ! 96: else ! 97: temp = temp->s.CDR; ! 98: } ! 99: else ! 100: if(Schainp!=nil && typ==ATOM) ! 101: return(nil); ! 102: else ! 103: return(errorh(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(errorh(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: register int typ; ! 204: ! 205: chkarg(2,"scons"); ! 206: retp = newsdot(); ! 207: handy = (argp) -> val; ! 208: if(TYPE(handy)!=INT) ! 209: error("First arg to scons must be an int.",FALSE); ! 210: retp->s.I = handy->i; ! 211: handy = (argp+1)->val; ! 212: if(handy==nil) ! 213: retp->s.CDR = (lispval) 0; ! 214: else { ! 215: if(TYPE(handy)!=SDOT) ! 216: error("Currently you may only link sdots to sdots.",FALSE); ! 217: retp->s.CDR = handy; ! 218: } ! 219: return(retp); ! 220: } ! 221: ! 222: lispval ! 223: Lcons() ! 224: { ! 225: register lispval retp; ! 226: register struct argent *argp; ! 227: ! 228: chkarg(2,"cons"); ! 229: retp = newdot(); ! 230: retp->d.car = ((argp = lbot) -> val); ! 231: retp->d.cdr = argp[1].val; ! 232: return(retp); ! 233: } ! 234: #define CA 0 ! 235: #define CD 1 ! 236: ! 237: lispval ! 238: rpla(what) ! 239: int what; ! 240: { register struct argent *argp; ! 241: register int typ; register lispval first, second; ! 242: ! 243: chkarg(2,"rplac[ad]"); ! 244: argp = np-1; ! 245: first = (argp-1)->val; ! 246: while(first==nil) ! 247: first = error("Attempt to rplac[ad] nil.",TRUE); ! 248: second = argp->val; ! 249: if (((typ = TYPE(first)) == DTPR) || (typ == ATOM) || HUNKP(first)) { ! 250: if (what == CA) ! 251: first->d.car = second; ! 252: else ! 253: first->d.cdr = second; ! 254: return(first); ! 255: } ! 256: if (typ==SDOT) { ! 257: if(what == CA) { ! 258: typ = TYPE(second); ! 259: if(typ!=INT) error("Rplacca of a bignum will only replace INTS",FALSE); ! 260: first->s.I = second->i; ! 261: } else { ! 262: if(second==nil) ! 263: first->s.CDR = (lispval) 0; ! 264: else ! 265: first->s.CDR = second; ! 266: } ! 267: return(first); ! 268: } ! 269: return(error("Bad arg to rpla",FALSE)); ! 270: } ! 271: lispval ! 272: Lrplaca() ! 273: { return(rpla(CA)); } ! 274: ! 275: lispval ! 276: Lrplacd() ! 277: { return(rpla(CD)); } ! 278: ! 279: ! 280: lispval ! 281: Leq() ! 282: { ! 283: register struct argent *mynp = lbot + AD; ! 284: int itemp, flag; ! 285: ! 286: chkarg(2,"eq"); ! 287: if(mynp->val==(mynp+1)->val) return(tatom); ! 288: return(nil); ! 289: } ! 290: ! 291: ! 292: ! 293: lispval ! 294: Lnull() ! 295: { chkarg(1,"null"); ! 296: return ((lbot->val == nil) ? tatom : nil); ! 297: } ! 298: ! 299: ! 300: ! 301: /* Lreturn **************************************************************/ ! 302: /* Returns the first argument - which is nill if not specified. */ ! 303: ! 304: Lreturn() ! 305: { ! 306: snpand(0); ! 307: if(lbot==np) protect (nil); ! 308: contval = lbot->val; ! 309: reset(BRRETN); ! 310: } ! 311: ! 312: ! 313: /* Lretbrk **************************************************************/ ! 314: /* The first argument must be an integer and must be in the range */ ! 315: /* -1 .. -depth. */ ! 316: lispval ! 317: Lretbrk() ! 318: { ! 319: lispval number; ! 320: register level; ! 321: ! 322: snpand(1); ! 323: if(lbot==np) protect (nil); ! 324: number = lbot->val; ! 325: if (TYPE(number) != INT) ! 326: level = -1; ! 327: else ! 328: level = number->i; ! 329: if(level < 0) ! 330: level += depth; ! 331: contval = (lispval) level; ! 332: if (level < depth) ! 333: reset(BRRETB); ! 334: return(nil); ! 335: } ! 336: ! 337: ! 338: ! 339: lispval ! 340: Linfile() ! 341: { ! 342: FILE *port; ! 343: register lispval name; ! 344: int typ; ! 345: snpand(1); ! 346: ! 347: chkarg(1,"infile"); ! 348: name = lbot->val; ! 349: loop: ! 350: name = verify(name,"infile: file name must be atom or string"); ! 351: /* return nil if file couldnt be opened ! 352: if ((port = fopen((char *)name,"r")) == NULL) return(nil); */ ! 353: ! 354: if ((port = fopen((char *)name,"r")) == NULL) { ! 355: name = errorh(Vermisc,"Unable to open file for reading.",nil,TRUE,31,name); ! 356: goto loop; ! 357: } ! 358: ioname[PN(port)] = (lispval) inewstr(name); /* remember name */ ! 359: return(P(port)); ! 360: } ! 361: ! 362: lispval ! 363: Loutfile() ! 364: { ! 365: FILE *port; register lispval name; ! 366: ! 367: chkarg(1,"outfile"); ! 368: name = lbot->val; ! 369: loop: ! 370: name = verify(name,"Please supply atom or string name for port."); ! 371: if ((port = fopen(name,"w")) == NULL) { ! 372: name = errorh(Vermisc,"Unable to open file for writing.",nil,TRUE,31,name); ! 373: goto loop; ! 374: } ! 375: ioname[PN(port)] = (lispval) inewstr(name); ! 376: return(P(port)); ! 377: } ! 378: ! 379: lispval ! 380: Lterpr() ! 381: { ! 382: FILE *port; ! 383: ! 384: snpand(0); ! 385: if(lbot==np) protect (nil); ! 386: port = okport(lbot->val,okport(Vpoport->a.clb,stdout)); ! 387: putc('\n',port); ! 388: fflush(port); ! 389: return(nil); ! 390: } ! 391: ! 392: lispval ! 393: Lclose() ! 394: { ! 395: lispval port; ! 396: ! 397: if(lbot==np) ! 398: port = error("Close requires one argument of type port",TRUE); ! 399: port = lbot->val; ! 400: if((TYPE(port))==PORT) fclose(port->p); ! 401: ioname[PN(port->p)] = nil; ! 402: return(tatom); ! 403: } ! 404: ! 405: lispval ! 406: Lnwritn() ! 407: { ! 408: register FILE *port; ! 409: register value; ! 410: ! 411: snpand(2); ! 412: if(lbot==np) protect (nil); ! 413: port = okport(lbot->val,okport(Vpoport->a.clb,stdout)); ! 414: value = port->_ptr - port->_base; ! 415: return(inewint(value)); ! 416: } ! 417: ! 418: lispval ! 419: Ldrain() ! 420: { ! 421: register FILE *port; ! 422: register int iodes; ! 423: struct sgttyb arg; ! 424: ! 425: snpand(2); ! 426: if(lbot==np) protect (nil); ! 427: port = okport(lbot->val, okport(Vpoport->a.clb,stdout)); ! 428: if(port->_flag & _IOWRT) { ! 429: fflush(port); ! 430: return(nil); ! 431: } ! 432: if(! port->_flag & _IOREAD) return(nil); ! 433: port->_cnt = 0; ! 434: port->_ptr = port->_base; ! 435: iodes = fileno(port); ! 436: if(gtty(iodes,&arg) != -1) stty(iodes,&arg); ! 437: return((lispval)(xports + (port - _iob))); ! 438: } ! 439: ! 440: lispval ! 441: Llist() ! 442: { ! 443: /* added for the benefit of mapping functions. */ ! 444: register struct argent *ulim, *namptr; ! 445: register lispval temp, result; ! 446: register struct argent *lbot, *np; ! 447: ! 448: ulim = np; ! 449: namptr = lbot + AD; ! 450: temp = result = (lispval) np; ! 451: protect(nil); ! 452: for(; namptr < ulim;) { ! 453: temp = temp->l = newdot(); ! 454: temp->d.car = (namptr++)->val; ! 455: } ! 456: temp->l = nil; ! 457: return(result->l); ! 458: } ! 459: ! 460: lispval ! 461: Lnumberp() ! 462: { ! 463: chkarg(1,"numberp"); ! 464: switch(TYPE(lbot->val)) { ! 465: case INT: case DOUB: case SDOT: ! 466: return(tatom); ! 467: } ! 468: return(nil); ! 469: } ! 470: ! 471: lispval ! 472: Latom() ! 473: { ! 474: register struct argent *lb = lbot; ! 475: chkarg(1,"atom"); ! 476: if(TYPE(lb->val)==DTPR || (HUNKP(lb->val))) ! 477: return(nil); ! 478: else ! 479: return(tatom); ! 480: } ! 481: ! 482: lispval ! 483: Ltype() ! 484: { ! 485: chkarg(1,"type"); ! 486: switch(TYPE(lbot->val)) { ! 487: case INT: ! 488: return(int_name); ! 489: case ATOM: ! 490: return(atom_name); ! 491: case SDOT: ! 492: return(sdot_name); ! 493: case DOUB: ! 494: return(doub_name); ! 495: case DTPR: ! 496: return(dtpr_name); ! 497: case STRNG: ! 498: return(str_name); ! 499: case ARRAY: ! 500: return(array_name); ! 501: case BCD: ! 502: return(funct_name); ! 503: ! 504: case HUNK2: ! 505: return(hunk_name[0]); ! 506: case HUNK4: ! 507: return(hunk_name[1]); ! 508: case HUNK8: ! 509: return(hunk_name[2]); ! 510: case HUNK16: ! 511: return(hunk_name[3]); ! 512: case HUNK32: ! 513: return(hunk_name[4]); ! 514: case HUNK64: ! 515: return(hunk_name[5]); ! 516: case HUNK128: ! 517: return(hunk_name[6]); ! 518: ! 519: case VALUE: ! 520: return(val_name); ! 521: case PORT: ! 522: return(port_name); ! 523: } ! 524: return(nil); ! 525: } ! 526: ! 527: lispval ! 528: Ldtpr() ! 529: { ! 530: chkarg(1,"dtpr"); ! 531: return(typred(DTPR, lbot->val)); ! 532: } ! 533: ! 534: lispval ! 535: Lbcdp() ! 536: { ! 537: chkarg(1,"bcdp"); ! 538: return(typred(BCD, lbot->val)); ! 539: } ! 540: ! 541: lispval ! 542: Lportp() ! 543: { ! 544: chkarg(1,"portp"); ! 545: return(typred(PORT, lbot->val)); ! 546: } ! 547: ! 548: lispval ! 549: Larrayp() ! 550: { ! 551: chkarg(1,"arrayp"); ! 552: return(typred(ARRAY, lbot->val)); ! 553: } ! 554: ! 555: /* ! 556: * (hunkp 'g_arg1) ! 557: * Returns t if g_arg1 is a hunk, otherwise returns nil. ! 558: */ ! 559: ! 560: lispval ! 561: Lhunkp() ! 562: { ! 563: chkarg(1,"hunkp"); ! 564: if (HUNKP(lbot->val)) ! 565: return(tatom); /* If a hunk, return t */ ! 566: else ! 567: return(nil); /* else nil */ ! 568: } ! 569: ! 570: lispval ! 571: Lset() ! 572: { ! 573: lispval varble; ! 574: snpand(0); ! 575: ! 576: chkarg(2,"set"); ! 577: varble = lbot->val; ! 578: switch(TYPE(varble)) ! 579: { ! 580: case ATOM: return(varble->a.clb = lbot[1].val); ! 581: ! 582: case VALUE: return(varble->l = lbot[1].val); ! 583: } ! 584: ! 585: error("IMPROPER USE OF SET",FALSE); ! 586: } ! 587: ! 588: lispval ! 589: Lequal() ! 590: { ! 591: register lispval first, second; ! 592: register type1, type2; ! 593: register struct argent *lbot, *np; ! 594: lispval Lsub(),Lzerop(), *stack(), unstack(), *sp(); ! 595: lispval *oldsp; int mustloop = FALSE, result; ! 596: chkarg(2,"equal"); ! 597: ! 598: ! 599: if(lbot->val==lbot[1].val) return(tatom); ! 600: ! 601: for((oldsp=sp(), stack(lbot->val,lbot[1].val)); ! 602: oldsp > sp();) { ! 603: ! 604: first = unstack(); second = unstack(); ! 605: again: ! 606: if(first==second) continue; ! 607: ! 608: type1=TYPE(first); type2=TYPE(second); ! 609: if(type1!=type2) { ! 610: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT)) ! 611: goto dosub; ! 612: return(nil); ! 613: } ! 614: switch(type1) { ! 615: case DTPR: ! 616: stack(first->d.cdr,second->d.cdr); ! 617: first = first->d.car; second = second->d.car; ! 618: goto again; ! 619: case DOUB: ! 620: if(first->r!=second->r) ! 621: return(nil); ! 622: continue; ! 623: case INT: ! 624: if(first->i!=second->i) ! 625: return(nil); ! 626: continue; ! 627: dosub: ! 628: case SDOT: ! 629: lbot = np; ! 630: np++->val = first; ! 631: np++->val = second; ! 632: lbot->val = Lsub(); ! 633: if(TYPE(lbot->val)!=INT || lbot->val->i!=0) ! 634: return(nil); ! 635: np = lbot; ! 636: continue; ! 637: case VALUE: ! 638: if(first->l!=second->l) ! 639: return(nil); ! 640: continue; ! 641: case STRNG: ! 642: if(strcmp(first,second)!=0) ! 643: return(nil); ! 644: continue; ! 645: ! 646: default: ! 647: return(nil); ! 648: } ! 649: } ! 650: return(tatom); ! 651: } ! 652: lispval ! 653: oLequal() ! 654: { ! 655: chkarg(2,"equal"); ! 656: ! 657: if( lbot[1].val == lbot->val ) return(tatom); ! 658: if(Iequal(lbot[1].val,lbot->val)) return(tatom); else return(nil); ! 659: } ! 660: ! 661: Iequal(first,second) ! 662: register lispval first, second; ! 663: { ! 664: register type1, type2; ! 665: register struct argent *lbot, *np; ! 666: lispval Lsub(),Lzerop(); ! 667: ! 668: if(first==second) ! 669: return(1); ! 670: type1=TYPE(first); ! 671: type2=TYPE(second); ! 672: if(type1!=type2) { ! 673: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT)) ! 674: goto dosub; ! 675: return(0); ! 676: } ! 677: switch(type1) { ! 678: case DTPR: ! 679: return( ! 680: Iequal(first->d.car,second->d.car) && ! 681: Iequal(first->d.cdr,second->d.cdr) ); ! 682: case DOUB: ! 683: return(first->r==second->r); ! 684: case INT: ! 685: return( (first->i==second->i)); ! 686: dosub: ! 687: case SDOT: ! 688: lbot = np; ! 689: np++->val = first; ! 690: np++->val = second; ! 691: lbot->val = Lsub(); ! 692: np = lbot + 1; ! 693: return(TYPE(lbot->val)==INT&& lbot->val->i==0); ! 694: case VALUE: ! 695: return( first->l==second->l ); ! 696: case STRNG: ! 697: return(strcmp(first,second)==0); ! 698: } ! 699: return(0); ! 700: } ! 701: lispval ! 702: Zequal() ! 703: { ! 704: register lispval first, second; ! 705: register type1, type2; ! 706: register struct argent *lbot, *np; ! 707: lispval Lsub(),Lzerop(), *stack(), unstack(), *sp(); ! 708: lispval *oldsp; int mustloop = FALSE, result; ! 709: chkarg(2,"equal"); ! 710: ! 711: ! 712: if(lbot->val==lbot[1].val) return(tatom); ! 713: ! 714: for((oldsp=sp(), stack(lbot->val,lbot[1].val)); ! 715: oldsp > sp();) { ! 716: ! 717: first = unstack(); second = unstack(); ! 718: again: ! 719: if(first==second) continue; ! 720: ! 721: type1=TYPE(first); type2=TYPE(second); ! 722: if(type1!=type2) { ! 723: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT)) ! 724: goto dosub; ! 725: return(nil); ! 726: } ! 727: switch(type1) { ! 728: case DTPR: ! 729: stack(first->d.cdr,second->d.cdr); ! 730: first = first->d.car; second = second->d.car; ! 731: goto again; ! 732: case DOUB: ! 733: if(first->r!=second->r) ! 734: return(nil); ! 735: continue; ! 736: case INT: ! 737: if(first->i!=second->i) ! 738: return(nil); ! 739: continue; ! 740: dosub: ! 741: case SDOT: ! 742: lbot = np; ! 743: np++->val = first; ! 744: np++->val = second; ! 745: lbot->val = Lsub(); ! 746: if(TYPE(lbot->val)!=INT || lbot->val->i!=0) ! 747: return(nil); ! 748: np = lbot; ! 749: continue; ! 750: case VALUE: ! 751: if(first->l!=second->l) ! 752: return(nil); ! 753: continue; ! 754: case STRNG: ! 755: if(strcmp(first,second)!=0) ! 756: return(nil); ! 757: continue; ! 758: } ! 759: } ! 760: return(tatom); ! 761: } ! 762: ! 763: lispval ! 764: Lprint() ! 765: { ! 766: extern int prinlevel,prinlength; ! 767: ! 768: snpand(0); ! 769: if(np-lbot==1) protect(nil); ! 770: chkarg(2,"print"); ! 771: chkrtab(Vreadtable->a.clb); ! 772: if(TYPE(Vprinlevel->a.clb) == INT) ! 773: { ! 774: prinlevel = Vprinlevel->a.clb->i; ! 775: } ! 776: else prinlevel = -1; ! 777: if(TYPE(Vprinlength->a.clb) == INT) ! 778: { ! 779: prinlength = Vprinlength->a.clb->i; ! 780: } ! 781: else prinlength = -1; ! 782: printr(lbot->val,okport(lbot[1].val,okport(Vpoport->a.clb,poport))); ! 783: return(nil); ! 784: } ! 785: ! 786: /* patom does not use prinlevel or prinlength */ ! 787: lispval ! 788: Lpatom() ! 789: { ! 790: register lispval temp; ! 791: register int typ; ! 792: FILE *port; ! 793: extern int prinlevel,prinlength; ! 794: ! 795: snpand(2); ! 796: if(np-lbot==1) protect(nil); ! 797: chkarg(2,"patom"); ! 798: temp = Vreadtable->a.clb; ! 799: chkrtab(temp); ! 800: port = okport(lbot[1].val, okport(Vpoport->a.clb,stdout)); ! 801: if ((typ= TYPE((temp = (lbot)->val))) == ATOM) ! 802: fputs(temp->a.pname, port); ! 803: else if(typ == STRNG) ! 804: fputs(temp,port); ! 805: else ! 806: { ! 807: printr(temp, port); ! 808: } ! 809: return(temp); ! 810: } ! 811: ! 812: /* ! 813: * (pntlen thing) returns the length it takes to print out ! 814: * an atom or number. ! 815: */ ! 816: ! 817: lispval ! 818: Lpntlen() ! 819: { ! 820: register lispval temp; ! 821: return(inewint(Ipntlen())); ! 822: } ! 823: Ipntlen() ! 824: { ! 825: register lispval temp; ! 826: register char *handy; ! 827: ! 828: temp = np[-1].val; ! 829: loop: switch(TYPE(temp)) { ! 830: ! 831: case ATOM: ! 832: handy = temp->a.pname; ! 833: break; ! 834: ! 835: case STRNG: ! 836: handy = (char *) temp; ! 837: break; ! 838: ! 839: case INT: ! 840: sprintf(strbuf,"%d",temp->i); ! 841: handy =strbuf; ! 842: break; ! 843: ! 844: case DOUB: ! 845: sprintf(strbuf,"%g",temp->r); ! 846: handy =strbuf; ! 847: break; ! 848: ! 849: default: ! 850: temp = error("Non atom or number to pntlen\n",TRUE); ! 851: goto loop; ! 852: } ! 853: ! 854: return( strlen(handy)); ! 855: } ! 856: #undef okport ! 857: FILE * ! 858: okport(arg,proper) ! 859: lispval arg; ! 860: FILE *proper; ! 861: { ! 862: if(TYPE(arg)!=PORT) ! 863: return(proper); ! 864: else ! 865: return(arg->p); ! 866: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.