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