![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lam2.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 lam2.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 ! root 1: static char *sccsid = "@(#)lam2.c 34.1 10/3/80"; ! 2: ! 3: # include "global.h" ! 4: # include <signal.h> ! 5: /* ! 6: * (flatc thing max) returns the smaller of max and the number of chars ! 7: * required to print thing linearly. ! 8: * if max argument is not given, we assume the second arg is infinity ! 9: */ ! 10: static flen; /*Internal to this module, used as a running counter of flatsize*/ ! 11: static fmax; /*used for maximum for quick reference */ ! 12: ! 13: lispval ! 14: Lflatsi() ! 15: { ! 16: register lispval current, temp; ! 17: register struct argent *mylbot = lbot; ! 18: snpand(3); /* fixup entry mask */ ! 19: ! 20: if( np-lbot == 1) fmax = 0x7fffffff; /* biggest integer */ ! 21: else fmax = mylbot[1].val->i; ! 22: flen = 0; ! 23: current = mylbot->val; ! 24: protect(nil); /*create space for argument to pntlen*/ ! 25: Iflatsi(current); ! 26: return(inewint(flen)); ! 27: } ! 28: /* ! 29: * Iflatsi does the real work of the calculation for flatc ! 30: */ ! 31: Iflatsi(current) ! 32: register lispval current; ! 33: { ! 34: register lispval handy; ! 35: register int temp; ! 36: ! 37: if(flen > fmax) return(fmax); ! 38: switch(TYPE(current)) { ! 39: ! 40: patom: ! 41: case INT: case ATOM: case DOUB: case STRNG: ! 42: np[-1].val = current; ! 43: flen += Ipntlen(); ! 44: return; ! 45: ! 46: pthing: ! 47: case DTPR: ! 48: flen++; ! 49: Iflatsi(current->d.car); ! 50: current = current->d.cdr; ! 51: if(current == nil) { ! 52: flen++; ! 53: return; ! 54: } ! 55: if(flen > fmax) return; ! 56: switch(TYPE(current)) { ! 57: case INT: case ATOM: case DOUB: ! 58: flen += 4; ! 59: goto patom; ! 60: case DTPR: ! 61: goto pthing; ! 62: } ! 63: } ! 64: } ! 65: ! 66: ! 67: #define EADC -1 ! 68: #define EAD -2 ! 69: lispval ! 70: Lread() ! 71: { return (r(EAD)); } ! 72: ! 73: lispval ! 74: Lratom() ! 75: { return (r(ATOM)); } ! 76: ! 77: lispval ! 78: Lreadc() ! 79: { return (r(EADC)); } ! 80: ! 81: #include "chars.h" ! 82: #include "chkrtab.h" ! 83: ! 84: extern char *ctable; ! 85: /* r *********************************************************************/ ! 86: /* this function maps the desired read function into the system-defined */ ! 87: /* reading functions after testing for a legal port. */ ! 88: lispval ! 89: r(op) ! 90: int op; ! 91: { ! 92: register char c; register lispval result; ! 93: int orlevel; extern int rlevel; ! 94: FILE *ttemp; ! 95: struct nament *oldbnp = bnp; ! 96: snpand(2); ! 97: ! 98: switch(np-lbot) { ! 99: case 0: ! 100: protect(nil); ! 101: case 1: ! 102: protect(nil); ! 103: case 2: break; ! 104: default: ! 105: argerr("read or ratom or readc"); ! 106: } ! 107: result = Vreadtable->a.clb; ! 108: chkrtab(result); ! 109: orlevel = rlevel; ! 110: rlevel = 0; ! 111: ttemp = okport(Vpiport->a.clb,stdin); ! 112: ttemp = okport(lbot->val,ttemp); ! 113: /*printf("entering switch\n");*/ ! 114: fflush(stdout); /* flush any pending characters */ ! 115: ! 116: switch (op) ! 117: { ! 118: case EADC: rlevel = orlevel; ! 119: switch (ctable[c = getc(ttemp) & 0177] & 0377) ! 120: { ! 121: case VEOF: ! 122: return(lbot[1].val); ! 123: default: ! 124: strbuf[0] = hash = c; ! 125: strbuf[1] = 0; ! 126: atmlen = 2; ! 127: return((lispval)getatom()); ! 128: } ! 129: case ATOM: rlevel = orlevel; ! 130: result = (ratomr(ttemp)); ! 131: goto out; ! 132: ! 133: case EAD: PUSHDOWN(Vpiport,P(ttemp)); /* rebind Vpiport */ ! 134: result = readr(ttemp); ! 135: out: if(result==eofa) ! 136: { ! 137: if(sigintcnt > 0) sigcall(SIGINT); ! 138: result = lbot[1].val; ! 139: } ! 140: rlevel = orlevel; ! 141: popnames(oldbnp); /* unwind bindings */ ! 142: return(result); ! 143: } ! 144: } ! 145: ! 146: /* Lload *****************************************************************/ ! 147: /* Reads in and executes forms from the specified file. This should */ ! 148: /* really be an nlambda taking multiple arguments, but the error */ ! 149: /* handling gets funny in that case (one file out of several not */ ! 150: /* openable, for instance). */ ! 151: lispval ! 152: Lload() ! 153: { ! 154: register FILE *port; ! 155: register char *p, *ttemp; register lispval vtemp; ! 156: register struct argent *lbot, *np; ! 157: struct nament *oldbnp = bnp; ! 158: int orlevel,typ; ! 159: char longname[100]; ! 160: char *shortname, *end2; ! 161: ! 162: chkarg(1,"load"); ! 163: if((typ = TYPE(lbot->val)) == ATOM) ! 164: ttemp = lbot->val->a.pname ; /* ttemp will point to name */ ! 165: else if(typ == STRNG) ! 166: ttemp = (char *) lbot->val; ! 167: else ! 168: return(error("FILENAME MUST BE ATOMIC",FALSE)); ! 169: strcpy(longname,"/usr/lib/lisp/" ); ! 170: for(p = longname; *p; p++); ! 171: shortname = p; ! 172: strcpy(p,ttemp); ! 173: for(; *p; p++); ! 174: end2 = p; ! 175: strcpy(p,".l"); ! 176: if ((port = fopen(shortname,"r")) == NULL && ! 177: (port = fopen(longname, "r")) == NULL) { ! 178: *end2 = 0; ! 179: if ((port = fopen(shortname,"r")) == NULL && ! 180: (port = fopen(longname, "r")) == NULL) ! 181: errorh(Vermisc,"Can't open file: ", ! 182: nil,FALSE,0,lbot->val); ! 183: } ! 184: orlevel = rlevel; ! 185: rlevel = 0; ! 186: ! 187: if(ISNIL(copval(gcload,CNIL)) && ! 188: loading->a.clb != tatom && ! 189: ISNIL(copval(gcdis,CNIL))) ! 190: gc(CNIL); /* do a gc if gc will be off */ ! 191: ! 192: /* shallow bind the value of lisp atom piport */ ! 193: /* so readmacros will work */ ! 194: PUSHDOWN(Vpiport,P(port)); ! 195: PUSHDOWN(loading,tatom); /* set indication of loading status */ ! 196: ! 197: while ((vtemp = readr(port)) != eofa) { ! 198: eval(vtemp); ! 199: } ! 200: popnames(oldbnp); /* unbind piport, loading */ ! 201: ! 202: rlevel = orlevel; ! 203: fclose(port); ! 204: return(nil); ! 205: } ! 206: ! 207: /* concat ************************************************** ! 208: - ! 209: - use: (concat arg1 arg2 ... ) ! 210: - ! 211: - concatenates the print names of all of its arguments. ! 212: - the arguments may be atoms, integers or real numbers. ! 213: - ! 214: - *********************************************************/ ! 215: lispval ! 216: Iconcat(unintern) ! 217: { ! 218: register struct argent *temnp; ! 219: register int atmlen; /* Passt auf! atmlen in the external ! 220: sense calculated by newstr */ ! 221: int i; ! 222: lispval cur; ! 223: char lstrbf[200]; /* local string buffer needed if sdot seen */ ! 224: snpand(2); ! 225: ! 226: atmlen = 0 ; ! 227: strbuf[0] = NULL_CHAR ; ! 228: ! 229: /* loop for each argument */ ! 230: for(temnp = lbot + AD ; temnp < np ; temnp++) ! 231: { ! 232: cur = temnp->val; ! 233: loop: switch(TYPE(cur)) ! 234: { ! 235: case ATOM: ! 236: strcpy(&strbuf[atmlen], ((struct atom *) cur) -> pname) ; ! 237: break; ! 238: ! 239: case STRNG: ! 240: strcpy(&strbuf[atmlen], cur); ! 241: break; ! 242: ! 243: case INT: ! 244: sprintf(&strbuf[atmlen],"%d",cur->i); ! 245: break; ! 246: ! 247: case DOUB: ! 248: sprintf(&strbuf[atmlen],"%f",cur->f); ! 249: break; ! 250: ! 251: case SDOT: ! 252: if(atmlen > 200) error("concat: string buffer overflow",FALSE); ! 253: strcpy(lstrbf,strbuf); /* save around explode */ ! 254: lbot = np; ! 255: protect(cur); /* must explode */ ! 256: cur= Lexplda(); ! 257: np = lbot; ! 258: strcpy(strbuf,lstrbf); ! 259: for( ; cur != nil ; cur = cur->d.cdr) ! 260: strbuf[atmlen++] = cur->d.car->a.pname[0]; ! 261: strbuf[atmlen] = '\0'; ! 262: break; ! 263: ! 264: default: ! 265: cur = error("Non atom or number to concat",TRUE); ! 266: goto loop; /* if returns value, try it */ ! 267: } ! 268: atmlen = strlen(strbuf); ! 269: ! 270: } ! 271: ! 272: if(unintern) ! 273: return( (lispval) newatom()); ! 274: else ! 275: return( (lispval) getatom()) ; ! 276: } ! 277: lispval ! 278: Lconcat(){ ! 279: return(Iconcat(FALSE)); ! 280: } ! 281: lispval ! 282: Luconcat(){ ! 283: return(Iconcat(TRUE)); ! 284: } ! 285: ! 286: lispval ! 287: Lputprop() ! 288: { ! 289: register struct argent *argp = lbot; ! 290: lispval Iputprop(); ! 291: snpand(1); ! 292: chkarg(3,"putprop"); ! 293: return(Iputprop(argp->val,argp[1].val,argp[2].val)); ! 294: } ! 295: ! 296: lispval ! 297: Iputprop(atm,prop,ind) ! 298: register lispval prop, ind, atm; ! 299: { ! 300: register lispval pptr; ! 301: lispval *tack; /* place to begin property list */ ! 302: lispval errorh(); ! 303: top: ! 304: switch (TYPE(atm)) { ! 305: case ATOM: ! 306: if(atm == nil) tack = &nilplist; ! 307: else tack = &(atm->a.plist); ! 308: break; ! 309: case DTPR: ! 310: for (pptr = atm->d.cdr ; pptr != nil ; pptr = pptr->d.cdr->d.cdr) ! 311: if(TYPE(pptr) != DTPR || TYPE(pptr->d.cdr) != DTPR) break; ! 312: if(pptr != nil) ! 313: { atm = errorh(Vermisc, ! 314: "putprop: bad disembodied property list", ! 315: nil,TRUE,0,atm); ! 316: goto top; ! 317: } ! 318: tack = (lispval *) &(atm->d.cdr); ! 319: break; ! 320: default: ! 321: errorh(Vermisc,"putprop: Bad first argument: ",nil,FALSE,0,atm); ! 322: } ! 323: pptr = *tack; /* start of property list */ ! 324: findit: ! 325: for (pptr = *tack ; pptr != nil ; pptr = pptr->d.cdr->d.cdr) ! 326: if (pptr->d.car == ind) { ! 327: (pptr->d.cdr)->d.car = prop; ! 328: return(prop); ! 329: } ! 330: else tack = &(pptr->d.cdr->d.cdr) ; ! 331: *tack = pptr = newdot(); ! 332: pptr->d.car = ind; ! 333: pptr = pptr->d.cdr = (lispval) newdot(); ! 334: pptr->d.car = prop; ! 335: return(prop); ! 336: } ! 337: ! 338: /* get from property list ! 339: * there are three routines to accomplish this ! 340: * Lget - lisp callable, the first arg can be a symbol or a disembodied ! 341: * property list. In the latter case we check to make sure it ! 342: * is a real one (as best we can). ! 343: * Iget - internal routine, the first arg must be a symbol, no disembodied ! 344: * plists allowed ! 345: * Igetplist - internal routine, the first arg is the plist to search. ! 346: */ ! 347: lispval ! 348: Lget() ! 349: { ! 350: register lispval ind, atm; ! 351: register lispval dum1, dum2; ! 352: lispval Igetplist(); ! 353: snpand(2); ! 354: ! 355: chkarg(2,"get"); ! 356: ind = lbot[1].val; ! 357: atm = lbot[0].val; ! 358: top: ! 359: switch(TYPE(atm)) { ! 360: case ATOM: ! 361: if(atm==nil) atm = nilplist; ! 362: else atm = atm->a.plist; ! 363: break; ! 364: ! 365: case DTPR: ! 366: for (dum1 = atm->d.cdr; dum1 != nil; dum1 = dum1->d.cdr->d.cdr) ! 367: if((TYPE(dum1) != DTPR) || ! 368: (TYPE(dum1->d.cdr) != DTPR)) break; /* bad prop list */ ! 369: if(dum1 != nil) ! 370: { atm = errorh(Vermisc, ! 371: "get: bad disembodied property list", ! 372: nil,TRUE,0,atm); ! 373: goto top; ! 374: } ! 375: atm = atm->d.cdr; ! 376: break; ! 377: default: ! 378: /* remove since maclisp doesnt treat ! 379: this as an error, ugh ! 380: return(errorh(Vermisc,"get: bad first argument: ", ! 381: nil,FALSE,0,atm)); ! 382: */ ! 383: return(nil); ! 384: } ! 385: ! 386: while (atm != nil) ! 387: { ! 388: if (atm->d.car == ind) ! 389: return ((atm->d.cdr)->d.car); ! 390: atm = (atm->d.cdr)->d.cdr; ! 391: } ! 392: return(nil); ! 393: } ! 394: /* ! 395: * Iget - the first arg must be a symbol. ! 396: */ ! 397: ! 398: lispval ! 399: Iget(atm,ind) ! 400: register lispval atm, ind; ! 401: { ! 402: lispval Igetplist(); ! 403: ! 404: if(atm==nil) ! 405: atm = nilplist; ! 406: else ! 407: atm = atm->a.plist; ! 408: return(Igetplist(atm,ind)); ! 409: } ! 410: ! 411: /* ! 412: * Igetplist ! 413: * pptr is a plist ! 414: * ind is the indicator ! 415: */ ! 416: ! 417: lispval ! 418: Igetplist(pptr,ind) ! 419: register lispval pptr,ind; ! 420: { ! 421: while (pptr != nil) ! 422: { ! 423: if (pptr->d.car == ind) ! 424: return ((pptr->d.cdr)->d.car); ! 425: pptr = (pptr->d.cdr)->d.cdr; ! 426: } ! 427: return(nil); ! 428: } ! 429: lispval ! 430: Lgetd() ! 431: { ! 432: register lispval typ; ! 433: snpand(1); ! 434: ! 435: chkarg(1,"getd"); ! 436: typ = lbot->val; ! 437: if (TYPE(typ) != ATOM) ! 438: errorh(Vermisc, ! 439: "getd: ONLY ATOMS HAVE FUNCTION DEFINITIONS", ! 440: nil, ! 441: FALSE, ! 442: 0, ! 443: typ); ! 444: return(typ->a.fnbnd); ! 445: } ! 446: lispval ! 447: Lputd() ! 448: { ! 449: register lispval atom, list; ! 450: register lispval dum1, dum2; ! 451: register struct argent *lbot, *np; ! 452: snpand(2); ! 453: ! 454: chkarg(2,"putd"); ! 455: list = lbot[1].val; ! 456: atom = lbot->val; ! 457: if (TYPE(atom) != ATOM) error("ONLY ATOMS HAVE FUNCTION DEFINITIONS",FALSE); ! 458: atom->a.fnbnd = list; ! 459: return(list); ! 460: } ! 461: ! 462: /* =========================================================== ! 463: - mapping functions which return a list of the answers ! 464: - mapcar applies the given function to successive elements ! 465: - maplist applies the given function to successive sublists ! 466: - ===========================================================*/ ! 467: ! 468: lispval ! 469: Lmapcrx(maptyp,join) ! 470: int maptyp; /* 0 = mapcar, 1 = maplist */ ! 471: int join; /* 0 = the above, 1 = s/car/can/ */ ! 472: { ! 473: register struct argent *namptr; ! 474: register index; ! 475: register lispval temp; ! 476: register lispval current; ! 477: register struct argent *lbot; ! 478: register struct argent *np; ! 479: ! 480: struct argent *first, *last; ! 481: int count; ! 482: lispval lists[25], result; ! 483: ! 484: namptr = lbot + 1; ! 485: count = np - namptr; ! 486: if (count <= 0) return (nil); ! 487: /*oldlbot = lbot; /* lbot saved by virtue of entry mask */ ! 488: result = current = (lispval) np; ! 489: protect(nil); /* set up space for returned list */ ! 490: protect(lbot->val); /*copy funarg for call to funcall */ ! 491: lbot = np -1; ! 492: first = np; ! 493: last = np += count; ! 494: for(index = 0; index < count; index++) { ! 495: temp =(namptr++)->val; ! 496: if (TYPE (temp ) != DTPR && temp!=nil) ! 497: error ( "bad list argument to map",FALSE); ! 498: lists[index] = temp; ! 499: } ! 500: for(;;) { ! 501: for(namptr=first,index=0; index<count; index++) { ! 502: temp = lists[index]; ! 503: if(temp==nil) goto done; ! 504: ! 505: if(maptyp==0) (namptr++)->val = temp->d.car; ! 506: else (namptr++)->val = temp; ! 507: ! 508: lists[index] = temp->d.cdr; ! 509: } ! 510: if (join == 0) { ! 511: current->l = newdot(); ! 512: current->l->d.car = Lfuncal(); ! 513: current = (lispval) ¤t->l->d.cdr; ! 514: } else { ! 515: current->l = Lfuncal(); ! 516: if ( TYPE ( current -> l) != DTPR && current->l != nil) ! 517: error("bad type returned from funcall inside map",FALSE); ! 518: else while ( current -> l != nil ) ! 519: current = (lispval) & (current ->l ->d.cdr); ! 520: } ! 521: np = last; ! 522: } ! 523: done: if (join == 0)current->l = nil; ! 524: /*lbot = oldlbot;*/ ! 525: return(result->l); ! 526: } ! 527: ! 528: /* ============================ ! 529: - ! 530: - Lmapcar ! 531: - =============================*/ ! 532: ! 533: lispval ! 534: Lmapcar() ! 535: { ! 536: snpand(0); ! 537: return(Lmapcrx(0,0)); } /* call general routine */ ! 538: ! 539: ! 540: /* ============================ ! 541: - ! 542: - ! 543: - Lmaplist ! 544: - ==============================*/ ! 545: ! 546: lispval ! 547: Lmaplist() ! 548: { ! 549: snpand(0); ! 550: return(Lmapcrx(1,0)); } /* call general routine */ ! 551: ! 552: ! 553: /* ================================================ ! 554: - mapping functions which return the value of the last function application. ! 555: - mapc and map ! 556: - ===================================================*/ ! 557: ! 558: lispval ! 559: Lmapcx(maptyp) ! 560: int maptyp; /* 0= mapc , 1= map */ ! 561: { ! 562: register struct argent *namptr; ! 563: register index; ! 564: register lispval temp; ! 565: register lispval result; ! 566: register struct argent *lbot; ! 567: register struct argent *np; ! 568: ! 569: int count; ! 570: struct argent *first; ! 571: lispval lists[25], errorh(); ! 572: ! 573: namptr = lbot + 1; ! 574: count = np - namptr; ! 575: if(count <= 0) return(nil); ! 576: result = lbot[1].val; /*This is what macsyma wants so ... */ ! 577: /*copy funarg for call to funcall */ ! 578: lbot = np; protect((namptr - 1)->val); ! 579: first = np; np += count; ! 580: ! 581: for(index = 0; index < count; index++) { ! 582: temp = (namptr++)->val; ! 583: while(temp!=nil && TYPE(temp)!=DTPR) ! 584: temp = errorh(Vermisc,"Inappropriate list argument to mapc",nil,TRUE,0,temp); ! 585: lists[index] = temp; ! 586: } ! 587: for(;;) { ! 588: for(namptr=first,index=0; index<count; index++) { ! 589: temp = lists[index]; ! 590: if(temp==nil) ! 591: goto done; ! 592: if(maptyp==0) ! 593: (namptr++)->val = temp->d.car; ! 594: else ! 595: (namptr++)->val = temp; ! 596: lists[index] = temp->d.cdr; ! 597: } ! 598: Lfuncal(); ! 599: } ! 600: done: ! 601: return(result); ! 602: } ! 603: ! 604: ! 605: /* ================================== ! 606: - ! 607: - mapc map the car of the lists ! 608: - ! 609: - ==================================*/ ! 610: ! 611: lispval ! 612: Lmapc() ! 613: { return( Lmapcx(0) ); } ! 614: ! 615: ! 616: /* ================================= ! 617: - ! 618: - map map the cdr of the lists ! 619: - ! 620: - ===================================*/ ! 621: ! 622: lispval ! 623: Lmap() ! 624: { return( Lmapcx(1) ); } ! 625: ! 626: ! 627: lispval ! 628: Lmapcan() ! 629: { ! 630: lispval Lmapcrx(); ! 631: ! 632: return ( Lmapcrx ( 0,1 ) ); ! 633: } ! 634: ! 635: lispval ! 636: Lmapcon() ! 637: { ! 638: lispval Lmapcrx(); ! 639: ! 640: return ( Lmapcrx ( 1,1 ) ); ! 641: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.