![[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] / 3BSD / cmd / lisp|
Return to lam1.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp |
1.1 ! root 1: ! 2: # include "global.h" ! 3: # include <sgtty.h> ! 4: # include "chkrtab.h" ! 5: /**************************************************************************/ ! 6: /* */ ! 7: /* file: ccdfns.i */ ! 8: /* contents: LISP functions coded in C */ ! 9: /* */ ! 10: /* These include LISP primitives, numeric and boolean functions and */ ! 11: /* predicates, some list-processing functions, i/o support functions */ ! 12: /* and control flow functions (e.g. cont, break). */ ! 13: /* There are two types of functions: lambda (prefixed "L") and nlambda */ ! 14: /* (prefixed "N"). */ ! 15: /* Lambda's all call chkarg to insure that at least the minimum number */ ! 16: /* of necessary arguments are on the namestack. */ ! 17: /* All functions take their arguments from the namestack in a read- */ ! 18: /* only manner, and return their results via the normal C value */ ! 19: /* return mechanism. */ ! 20: /* */ ! 21: ! 22: ! 23: ! 24: lispval ! 25: Leval() ! 26: { ! 27: register lispval temp; ! 28: ! 29: chkarg(1); ! 30: temp = lbot->val; ! 31: return(eval(temp)); ! 32: } ! 33: ! 34: lispval ! 35: Lxcar() ! 36: { register int typ; ! 37: register lispval temp, result; ! 38: ! 39: chkarg(1); ! 40: temp = lbot->val; ! 41: if (((typ = TYPE(temp)) == DTPR) || (typ == ATOM)) ! 42: return(temp -> car); ! 43: else if(typ == SDOT) { ! 44: result = inewint(temp->i); ! 45: return(result); ! 46: } else if(Schainp!=nil && typ==ATOM) ! 47: return(nil); ! 48: else ! 49: return(error("BAD ARG TO CAR",FALSE)); ! 50: ! 51: } ! 52: ! 53: lispval ! 54: Lxcdr() ! 55: { register int typ; ! 56: register lispval temp, result; ! 57: ! 58: chkarg(1); ! 59: temp = lbot->val; ! 60: if(temp==nil) return (nil); ! 61: ! 62: if ((typ = TYPE(temp)) == DTPR) ! 63: return(temp -> cdr); ! 64: else if(typ==SDOT) { ! 65: if(temp->CDR==0) return(nil); ! 66: return(temp->CDR); ! 67: } else if(Schainp!=nil && typ==ATOM) ! 68: return(nil); ! 69: else ! 70: return(error("BAD ARG TO CDR",FALSE)); ! 71: } ! 72: ! 73: lispval ! 74: cxxr(as,ds) ! 75: register int as,ds; ! 76: { ! 77: ! 78: register lispval temp, temp2; ! 79: int i, typ; ! 80: lispval errorh(); ! 81: ! 82: chkarg(1); ! 83: temp = lbot->val; ! 84: ! 85: for( i=0 ; i<ds ; i++) ! 86: { ! 87: if( temp != nil) ! 88: { ! 89: if ((typ = TYPE(temp)) == DTPR) ! 90: temp = temp -> cdr; ! 91: else if(typ==SDOT) { ! 92: if(temp->CDR==0) temp = nil; ! 93: else temp = temp->CDR; ! 94: } ! 95: else if(Schainp!=nil && typ==ATOM) ! 96: return(nil); ! 97: else ! 98: return(errorh(Vermisc,"BAD ARG TO CDR",nil,FALSE,5,temp)); ! 99: } ! 100: } ! 101: ! 102: for( i=0 ; i<as ; i++) ! 103: { ! 104: if( temp != nil ) ! 105: { ! 106: if ((typ = TYPE(temp)) == DTPR) ! 107: temp = temp -> car; ! 108: else if(typ == SDOT) ! 109: temp2 = inewint(temp->i), temp = temp2; ! 110: else if(Schainp!=nil && typ==ATOM) ! 111: return(nil); ! 112: else ! 113: return(errorh(Vermisc,"BAD ARG TO CAR",nil,FALSE,5,temp)); ! 114: } ! 115: } ! 116: ! 117: return(temp); ! 118: } ! 119: ! 120: ! 121: lispval ! 122: Lcar() ! 123: { return(cxxr(1,0)); ! 124: } ! 125: ! 126: lispval ! 127: Lcdr() ! 128: { return(cxxr(0,1)); ! 129: } ! 130: ! 131: lispval ! 132: Lcadr() ! 133: { return(cxxr(1,1)); ! 134: } ! 135: ! 136: lispval ! 137: Lcaar() ! 138: { return(cxxr(2,0)); ! 139: } ! 140: ! 141: lispval ! 142: Lc02r() ! 143: { return(cxxr(0,2)); /* cddr */ ! 144: } ! 145: ! 146: lispval ! 147: Lc12r() ! 148: { return(cxxr(1,2)); /* caddr */ ! 149: } ! 150: ! 151: lispval ! 152: Lc03r() ! 153: { return(cxxr(0,3)); /* cdddr */ ! 154: } ! 155: ! 156: lispval ! 157: Lc13r() ! 158: { return(cxxr(1,3)); /* cadddr */ ! 159: } ! 160: ! 161: lispval ! 162: Lc04r() ! 163: { return(cxxr(0,4)); /* cddddr */ ! 164: } ! 165: ! 166: lispval ! 167: Lc14r() ! 168: { return(cxxr(1,4)); /* caddddr */ ! 169: } ! 170: ! 171: /************************* ! 172: * ! 173: * (nthelem num list) ! 174: * returns the num'th element of the list, by doing a caddddd...ddr ! 175: * where there are num-1 d's ! 176: * if num<=0 or greater than the length of the list, we return nil ! 177: ******************************************************/ ! 178: ! 179: lispval ! 180: Lnthelem() ! 181: { ! 182: register lispval temp; ! 183: register int i; ! 184: ! 185: chkarg(2); ! 186: ! 187: if( TYPE(temp = lbot->val) != INT) ! 188: return (error ("First arg to nthelem must be a fixnum",FALSE)); ! 189: ! 190: i = temp->i; /* pick up the first arg */ ! 191: ! 192: if( i <= 0) return(nil); ! 193: ! 194: ++lbot; /* fix lbot for call to cxxr() 'cadddd..r' */ ! 195: temp = cxxr(1,i-1); ! 196: --lbot; ! 197: ! 198: return(temp); ! 199: } ! 200: ! 201: ! 202: ! 203: ! 204: ! 205: lispval ! 206: Lscons() ! 207: { ! 208: register struct argent *argp = lbot; ! 209: register lispval retp, handy; ! 210: register int typ; ! 211: ! 212: chkarg(2); ! 213: retp = newsdot(); ! 214: handy = (argp) -> val; ! 215: if(TYPE(handy)!=INT) ! 216: error("First arg to scons must be an int.",FALSE); ! 217: retp->I = handy->i; ! 218: handy = (argp+1)->val; ! 219: if(handy==nil) ! 220: retp->CDR = (lispval) 0; ! 221: else { ! 222: if(TYPE(handy)!=SDOT) ! 223: error("Currently you may only link sdots to sdots.",FALSE); ! 224: retp->CDR = handy; ! 225: } ! 226: return(retp); ! 227: } ! 228: lispval ! 229: Lcons() ! 230: { register struct argent *argp; ! 231: lispval retp; ! 232: ! 233: chkarg(2); ! 234: retp = newdot(); ! 235: retp -> cdr = ((argp = np-1) -> val); ! 236: retp -> car = (--argp) -> val; ! 237: return(retp); ! 238: } ! 239: #define CA 0 ! 240: #define CD 1 ! 241: ! 242: lispval ! 243: rpla(what) ! 244: int what; ! 245: { register struct argent *argp; ! 246: register int typ; register lispval first, second; ! 247: ! 248: chkarg(2); ! 249: argp = np-1; ! 250: first = (argp-1)->val; ! 251: while(first==nil) ! 252: first = error("Attempt to rplac[ad] nil.",TRUE); ! 253: second = argp->val; ! 254: if (((typ = TYPE(first)) == DTPR) || (typ == ATOM)) { ! 255: if (what == CA) ! 256: first->car = second; ! 257: else ! 258: first->cdr = second; ! 259: return(first); ! 260: } ! 261: if (typ==SDOT) { ! 262: if(what == CA) { ! 263: typ = TYPE(second); ! 264: if(typ!=INT) error("Rplacca of a bignum will only replace INTS",FALSE); ! 265: first->i = second->i; ! 266: } else { ! 267: if(second==nil) ! 268: first->CDR = (lispval) 0; ! 269: else ! 270: first->CDR = second; ! 271: } ! 272: return(first); ! 273: } ! 274: return(error("BAD ARG TO RPLA",FALSE)); ! 275: } ! 276: lispval ! 277: Lrplaca() ! 278: { return(rpla(CA)); } ! 279: ! 280: lispval ! 281: Lrplacd() ! 282: { return(rpla(CD)); } ! 283: ! 284: ! 285: lispval ! 286: Leq() ! 287: { ! 288: register struct argent *mynp = lbot + AD; ! 289: int itemp, flag; ! 290: ! 291: chkarg(2); ! 292: if(mynp->val==(mynp+1)->val) return(tatom); ! 293: return(nil); ! 294: } ! 295: ! 296: ! 297: ! 298: lispval ! 299: Lnull() ! 300: { chkarg(1); ! 301: return ((lbot->val == nil) ? tatom : nil); ! 302: } ! 303: ! 304: ! 305: ! 306: /* Lreturn **************************************************************/ ! 307: /* Returns the first argument - which is nill if not specified. */ ! 308: Lreturn() ! 309: { ! 310: chkarg(1); ! 311: contval = lbot->val; ! 312: reset(BRRETN); ! 313: } ! 314: ! 315: ! 316: /* Lretbrk **************************************************************/ ! 317: /* The first argument must be an integer and must be in the range */ ! 318: /* -1 .. -depth. */ ! 319: lispval ! 320: Lretbrk() ! 321: { ! 322: lispval number; ! 323: register level; ! 324: ! 325: ! 326: chkarg(1); ! 327: number = lbot->val; ! 328: if (TYPE(number) != INT) ! 329: level = -1; ! 330: else ! 331: level = number->i; ! 332: if(level < 0) ! 333: level += depth; ! 334: contval = (lispval) level; ! 335: if (level < depth) ! 336: reset(BRRETB); ! 337: return(nil); ! 338: } ! 339: ! 340: ! 341: ! 342: lispval ! 343: Linfile() ! 344: { ! 345: FILE *port; ! 346: register lispval name; ! 347: snpand(1); ! 348: ! 349: chkarg(1); ! 350: name = lbot->val; ! 351: while (TYPE(name)!=ATOM) ! 352: name = error("Please supply atom name for port.",TRUE); ! 353: /* return nil if file couldnt be opened ! 354: if ((port = fopen(name->pname,"r")) == NULL) return(nil); */ ! 355: ! 356: while ((port = fopen(name->pname,"r")) == NULL) ! 357: name = errorh(Vermisc,"Unable to open file for reading.",nil,TRUE,31,name); ! 358: ! 359: return((lispval)(xports + (port - _iob))); ! 360: } ! 361: ! 362: lispval ! 363: Loutfile() ! 364: { ! 365: FILE *port; register lispval name; ! 366: ! 367: chkarg(1); ! 368: name = lbot->val; ! 369: while (TYPE(name)!=ATOM) ! 370: name = error("Please supply atom name for port.",TRUE); ! 371: while ((port = fopen(name->pname,"w")) == NULL) ! 372: name = errorh(Vermisc,"Unable to open file for writing.",nil,TRUE,31,name); ! 373: return((lispval)(xports + (port - _iob))); ! 374: } ! 375: lispval ! 376: Lterpr() ! 377: { ! 378: FILE *port; ! 379: ! 380: chkarg(1); ! 381: port = okport(lbot->val,okport(Vpoport->clb,stdout)); ! 382: putc('\n',port); ! 383: fflush(port); ! 384: return(nil); ! 385: } ! 386: lispval ! 387: Lclose() ! 388: { ! 389: lispval port; ! 390: ! 391: if(lbot==np) ! 392: port = error("Close requires one argument of type port",TRUE); ! 393: port = lbot->val; ! 394: if((TYPE(port))==PORT) fclose(port->p); ! 395: return(tatom); ! 396: } ! 397: ! 398: lispval ! 399: Lnwritn() ! 400: { ! 401: register FILE *port; ! 402: register value; ! 403: ! 404: chkarg(1); ! 405: port = okport(lbot->val,okport(Vpoport->clb,stdout)); ! 406: value = port->_ptr - port->_base; ! 407: return(inewint(value)); ! 408: } ! 409: ! 410: lispval ! 411: Ldrain() ! 412: { ! 413: register FILE *port; ! 414: register int iodes; ! 415: struct sgttyb arg; ! 416: ! 417: chkarg(1); ! 418: port = okport(lbot->val, okport(Vpoport->clb,stdout)); ! 419: if(port->_flag & _IOWRT) { ! 420: fflush(port); ! 421: return(nil); ! 422: } ! 423: if(! port->_flag & _IOREAD) return(nil); ! 424: port->_cnt = 0; ! 425: port->_ptr = port->_base; ! 426: iodes = fileno(port); ! 427: if(gtty(iodes,&arg) != -1) stty(iodes,&arg); ! 428: return((lispval)(xports + (port - _iob))); ! 429: } ! 430: lispval ! 431: Llist() ! 432: { ! 433: /* added for the benefit of mapping functions. */ ! 434: register struct argent *ulim, *namptr; ! 435: register lispval temp, result; ! 436: register struct argent *lbot, *np; ! 437: ! 438: ulim = np; ! 439: namptr = lbot + AD; ! 440: temp = result = (lispval) np; ! 441: protect(nil); ! 442: for(; namptr < ulim;) { ! 443: temp = temp->l = newdot(); ! 444: temp->car = (namptr++)->val; ! 445: } ! 446: temp->l = nil; ! 447: return(result->l); ! 448: } ! 449: ! 450: lispval ! 451: Lnumberp() ! 452: { ! 453: chkarg(1); ! 454: switch(TYPE(lbot->val)) { ! 455: case INT: case DOUB: case SDOT: ! 456: return(tatom); ! 457: } ! 458: return(nil); ! 459: } ! 460: ! 461: lispval ! 462: Latom() ! 463: { ! 464: chkarg(1); ! 465: if(TYPE(lbot->val)==DTPR) ! 466: return(nil); ! 467: else ! 468: return(tatom); ! 469: } ! 470: lispval ! 471: Ltype() ! 472: { ! 473: chkarg(1); ! 474: switch(TYPE(lbot->val)) { ! 475: case INT: ! 476: return(int_name); ! 477: case ATOM: ! 478: return(atom_name); ! 479: case SDOT: ! 480: return(sdot_name); ! 481: case DOUB: ! 482: return(doub_name); ! 483: case DTPR: ! 484: return(dtpr_name); ! 485: case STRNG: ! 486: return(str_name); ! 487: case ARRAY: ! 488: return(array_name); ! 489: case BCD: ! 490: return(funct_name); ! 491: case VALUE: ! 492: return(val_name); ! 493: case PORT: ! 494: return(matom("port")); /* fix this when name exists */ ! 495: } ! 496: return(nil); ! 497: } ! 498: ! 499: lispval ! 500: Ldtpr() ! 501: { ! 502: chkarg(1); ! 503: return(typred(DTPR,lbot->val)); ! 504: } ! 505: ! 506: lispval ! 507: Lbcdp() ! 508: { ! 509: chkarg(1); ! 510: return(typred(BCD,lbot->val)); ! 511: } ! 512: ! 513: lispval ! 514: Lportp() ! 515: { ! 516: chkarg(1); ! 517: return(typred(PORT,lbot->val)); ! 518: } ! 519: ! 520: lispval ! 521: Larrayp() ! 522: { ! 523: chkarg(1); ! 524: return(typred(ARRAY,lbot->val)); ! 525: } ! 526: lispval ! 527: Lset() ! 528: { ! 529: lispval varble; ! 530: snpand(0); ! 531: ! 532: chkarg(2); ! 533: varble = lbot->val; ! 534: switch(TYPE(varble)) ! 535: { ! 536: case ATOM: return(varble->clb = lbot[1].val); ! 537: ! 538: case VALUE: return(varble->l = lbot[1].val); ! 539: } ! 540: ! 541: error("IMPROPER USE OF SET",FALSE); ! 542: } ! 543: lispval ! 544: Lequal() ! 545: { ! 546: chkarg(2); ! 547: ! 548: if( lbot[1].val == lbot->val ) return(tatom); ! 549: if(Iequal(lbot[1].val,lbot->val)) return(tatom); else return(nil); ! 550: } ! 551: ! 552: Iequal(first,second) ! 553: register lispval first, second; ! 554: { ! 555: register type1, type2; ! 556: register struct argent *lbot, *np; ! 557: lispval Lsub(),Lzerop(); ! 558: ! 559: if(first==second) ! 560: return(1); ! 561: type1=TYPE(first); ! 562: type2=TYPE(second); ! 563: if(type1!=type2) { ! 564: if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT)) ! 565: goto dosub; ! 566: return(0); ! 567: } ! 568: switch(type1) { ! 569: case DTPR: ! 570: return( ! 571: Iequal(first->car,second->car) && ! 572: Iequal(first->cdr,second->cdr) ); ! 573: case DOUB: ! 574: return(first->r==second->r); ! 575: case INT: ! 576: return( (first->i==second->i)); ! 577: dosub: ! 578: case SDOT: ! 579: lbot = np; ! 580: np++->val = first; ! 581: np++->val = second; ! 582: lbot->val = Lsub(); ! 583: np = lbot + 1; ! 584: return(Lzerop()!=nil); ! 585: case VALUE: ! 586: return( first->l==second->l ); ! 587: case STRNG: ! 588: return(strcmp(first,second)==0); ! 589: } ! 590: return(0); ! 591: } ! 592: ! 593: lispval ! 594: Lprint() ! 595: { ! 596: chkarg(2); ! 597: chkrtab(Vreadtable->clb); ! 598: printr(lbot->val,okport(lbot[1].val,okport(Vpoport->clb,poport))); ! 599: return(nil); ! 600: } ! 601: ! 602: FILE * ! 603: okport(arg,proper) ! 604: lispval arg; ! 605: FILE *proper; ! 606: { ! 607: if(TYPE(arg)!=PORT) ! 608: return(proper); ! 609: else ! 610: return(arg->p); ! 611: } ! 612: lispval ! 613: Lpatom() ! 614: { ! 615: register lispval temp; ! 616: FILE *port; ! 617: ! 618: chkarg(2); ! 619: temp = Vreadtable->clb; ! 620: chkrtab(temp); ! 621: port = okport(lbot[1].val, okport(Vpoport->clb,stdout)); ! 622: if ((TYPE((temp = (lbot)->val)))!=ATOM) ! 623: printr(temp, port); ! 624: else ! 625: fputs(temp->pname, port); ! 626: return(temp); ! 627: } ! 628: ! 629: /* ! 630: * (pntlen thing) returns the length it takes to print out ! 631: * an atom or number. ! 632: */ ! 633: ! 634: lispval ! 635: Lpntlen() ! 636: { ! 637: register lispval temp; ! 638: return(inewint(Ipntlen())); ! 639: } ! 640: Ipntlen() ! 641: { ! 642: register lispval temp; ! 643: register char *handy; ! 644: ! 645: temp = np[-1].val; ! 646: loop: switch(TYPE(temp)) { ! 647: ! 648: case ATOM: ! 649: handy = temp->pname; ! 650: break; ! 651: ! 652: case INT: ! 653: sprintf(strbuf,"%d",temp->i); ! 654: handy =strbuf; ! 655: break; ! 656: ! 657: case DOUB: ! 658: sprintf(strbuf,"%g",temp->r); ! 659: handy =strbuf; ! 660: break; ! 661: ! 662: default: ! 663: temp = error("Non atom or number to pntlen\n",TRUE); ! 664: goto loop; ! 665: } ! 666: ! 667: return( strlen(handy)); ! 668: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.