![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lam3.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 41BSD / cmd / lisp|
Return to lam3.c CVS log | Up to [CSRG BSD Unix] / 41BSD / cmd / lisp |
1.1 ! root 1: static char *sccsid = "@(#)lam3.c 34.2 10/24/80"; ! 2: ! 3: # include "global.h" ! 4: lispval ! 5: Lalfalp() ! 6: { ! 7: register lispval first, second; ! 8: register struct argent *inp; ! 9: snpand(3); /* clobber save mask */ ! 10: ! 11: chkarg(2,"alphalessp"); ! 12: inp = lbot; ! 13: first = (inp)->val; ! 14: second = (inp+1)->val; ! 15: if( (TYPE(first))!=ATOM || (TYPE(second))!=ATOM) ! 16: error("alphalessp expects atoms"); ! 17: if(strcmp(first->a.pname,second->a.pname) <= 0) ! 18: return(tatom); ! 19: else ! 20: return(nil); ! 21: } ! 22: ! 23: lispval ! 24: Lncons() ! 25: { ! 26: register lispval handy; ! 27: snpand(1); /* clobber save mask */ ! 28: ! 29: chkarg(1,"ncons"); ! 30: handy = newdot(); ! 31: handy->d.cdr = nil; ! 32: handy->d.car = lbot->val; ! 33: return(handy); ! 34: } ! 35: lispval ! 36: Lzerop() ! 37: { ! 38: register lispval handy; ! 39: snpand(1); /* clobber save mask */ ! 40: ! 41: chkarg(1,"zerop"); ! 42: handy = lbot->val; ! 43: switch(TYPE(handy)) { ! 44: case INT: ! 45: return(handy->i==0?tatom:nil); ! 46: case DOUB: ! 47: return(handy->r==0.0?tatom:nil); ! 48: } ! 49: return(nil); ! 50: } ! 51: lispval ! 52: Lonep() ! 53: { ! 54: register lispval handy; lispval Ladd(); ! 55: snpand(1); /* clobber save mask */ ! 56: ! 57: chkarg(1,"onep"); ! 58: handy = lbot->val; ! 59: switch(TYPE(handy)) { ! 60: case INT: ! 61: return(handy->i==1?tatom:nil); ! 62: case DOUB: ! 63: return(handy->r==1.0?tatom:nil); ! 64: case SDOT: ! 65: protect(inewint(0)); ! 66: handy = Ladd(); ! 67: if(TYPE(handy)!=INT || handy->i !=1) ! 68: return(nil); ! 69: else ! 70: return(tatom); ! 71: } ! 72: return(nil); ! 73: } ! 74: ! 75: lispval ! 76: cmpx(lssp) ! 77: { ! 78: register struct argent *argp; ! 79: register struct argent *outarg; ! 80: register struct argent *handy; ! 81: register count; ! 82: register struct argent *lbot; ! 83: register struct argent *np; ! 84: struct argent *onp = np; ! 85: ! 86: ! 87: argp = lbot + 1; ! 88: outarg = np; ! 89: while(argp < onp) { ! 90: ! 91: np = outarg + 2; ! 92: lbot = outarg; ! 93: if(lssp) ! 94: *outarg = argp[-1], outarg[1] = *argp++; ! 95: else ! 96: outarg[1] = argp[-1], *outarg = *argp++; ! 97: lbot->val = Lsub(); ! 98: np = lbot + 1; ! 99: if(Lnegp()==nil) return(nil); ! 100: } ! 101: return(tatom); ! 102: } ! 103: ! 104: lispval ! 105: Lgreaterp() ! 106: { ! 107: register int typ; ! 108: /* do the easy cases first */ ! 109: if(np-lbot == 2) ! 110: { if((typ=TYPE(lbot->val)) == INT) ! 111: { if((typ=TYPE(lbot[1].val)) == INT) ! 112: return((lbot[0].val->i - lbot[1].val->i) > 0 ? tatom : nil); ! 113: else if(typ == DOUB) ! 114: return((lbot[0].val->i - lbot[1].val->r) > 0.0 ? tatom : nil); ! 115: } ! 116: else if(typ == DOUB) ! 117: { if((typ=TYPE(lbot[1].val)) == INT) ! 118: return((lbot[0].val->r - lbot[1].val->i) > 0.0 ? tatom : nil); ! 119: else if(typ == DOUB) ! 120: return((lbot[0].val->r - lbot[1].val->r) > 0.0 ? tatom : nil); ! 121: } ! 122: } ! 123: ! 124: return(cmpx(FALSE)); ! 125: } ! 126: ! 127: lispval ! 128: Llessp() ! 129: { ! 130: register int typ; ! 131: /* do the easy cases first */ ! 132: if(np-lbot == 2) ! 133: { if((typ=TYPE(lbot->val)) == INT) ! 134: { if((typ=TYPE(lbot[1].val)) == INT) ! 135: return((lbot[0].val->i - lbot[1].val->i) < 0 ? tatom : nil); ! 136: else if(typ == DOUB) ! 137: return((lbot[0].val->i - lbot[1].val->r) < 0.0 ? tatom : nil); ! 138: } ! 139: else if(typ == DOUB) ! 140: { if((typ=TYPE(lbot[1].val)) == INT) ! 141: return((lbot[0].val->r - lbot[1].val->i) < 0.0 ? tatom : nil); ! 142: else if(typ == DOUB) ! 143: return((lbot[0].val->r - lbot[1].val->r) < 0.0 ? tatom : nil); ! 144: } ! 145: } ! 146: ! 147: return(cmpx(TRUE)); ! 148: } ! 149: ! 150: lispval ! 151: Ldiff() ! 152: { ! 153: register lispval arg1,arg2; register handy = 0; ! 154: snpand(3); /* clobber save mask */ ! 155: ! 156: ! 157: chkarg(2,"Ldiff"); ! 158: arg1 = lbot->val; ! 159: arg2 = (lbot+1)->val; ! 160: if(TYPE(arg1)==INT && TYPE(arg2)==INT) { ! 161: handy=arg1->i - arg2->i; ! 162: } ! 163: else error("non-numeric argument",FALSE); ! 164: return(inewint(handy)); ! 165: } ! 166: ! 167: lispval ! 168: Lmod() ! 169: { ! 170: register lispval arg1,arg2; lispval handy; ! 171: struct sdot fake1, fake2; ! 172: fake2.CDR = 0; ! 173: fake1.CDR = 0; ! 174: snpand(2); /* clobber save mask */ ! 175: ! 176: chkarg(2,"mod"); ! 177: handy = arg1 = lbot->val; ! 178: arg2 = (lbot+1)->val; ! 179: switch(TYPE(arg1)) { ! 180: case SDOT: ! 181: break; ! 182: case INT: ! 183: fake1.I = arg1->i; ! 184: arg1 =(lispval) &fake1; ! 185: break; ! 186: default: ! 187: error("non-numeric argument",FALSE); ! 188: } ! 189: switch(TYPE(arg2)) { ! 190: case SDOT: ! 191: break; ! 192: case INT: ! 193: fake2.I = arg2->i; ! 194: arg2 =(lispval) &fake2; ! 195: break; ! 196: default: ! 197: error("non-numeric argument",FALSE); ! 198: } ! 199: if(TYPE((lbot+1)->val)==INT && lbot[1].val->i==0) ! 200: return(handy); ! 201: divbig(arg1,arg2,0,&handy); ! 202: if(handy==((lispval)&fake1)) ! 203: handy = inewint(fake1.I); ! 204: if(handy==((lispval)&fake2)) ! 205: handy = inewint(fake2.I); ! 206: return(handy); ! 207: ! 208: } ! 209: ! 210: ! 211: lispval ! 212: Ladd1() ! 213: { ! 214: register lispval handy; ! 215: lispval Ladd(); ! 216: snpand(1); /* fixup entry mask */ ! 217: ! 218: handy = rdrint; ! 219: handy->i = 1; ! 220: protect(handy); ! 221: return(Ladd()); ! 222: ! 223: } ! 224: ! 225: lispval ! 226: Lsub1() ! 227: { ! 228: register lispval handy; ! 229: lispval Ladd(); ! 230: snpand(1); /* fixup entry mask */ ! 231: ! 232: handy = rdrint; ! 233: handy->i = - 1; ! 234: protect(handy); ! 235: return(Ladd()); ! 236: } ! 237: ! 238: lispval ! 239: Lminus() ! 240: { ! 241: register lispval arg1, handy; ! 242: register temp; ! 243: lispval subbig(); ! 244: snpand(3); /* clobber save mask */ ! 245: ! 246: chkarg(1,"minus"); ! 247: arg1 = lbot->val; ! 248: handy = nil; ! 249: switch(TYPE(arg1)) { ! 250: case INT: ! 251: handy= inewint(0 - arg1->i); ! 252: break; ! 253: case DOUB: ! 254: handy = newdoub(); ! 255: handy->r = -arg1->r; ! 256: break; ! 257: case SDOT: ! 258: handy = rdrsdot; ! 259: handy->s.I = 0; ! 260: handy->s.CDR = (lispval) 0; ! 261: handy = subbig(handy,arg1); ! 262: break; ! 263: ! 264: default: ! 265: error("non-numeric argument",FALSE); ! 266: } ! 267: return(handy); ! 268: } ! 269: ! 270: lispval ! 271: Lnegp() ! 272: { ! 273: register lispval handy = np[-1].val, work; ! 274: register flag = 0; ! 275: snpand(3); /* clobber save mask */ ! 276: ! 277: loop: ! 278: switch(TYPE(handy)) { ! 279: case INT: ! 280: if(handy->i < 0) flag = TRUE; ! 281: break; ! 282: case DOUB: ! 283: if(handy->r < 0) flag = TRUE; ! 284: break; ! 285: case SDOT: ! 286: for(work = handy; work->s.CDR!=(lispval) 0; work = work->s.CDR); ! 287: if(work->s.I < 0) flag = TRUE; ! 288: break; ! 289: default: ! 290: handy = errorh(Vermisc, ! 291: "minusp: Non-(int,real,bignum) arg: ", ! 292: nil, ! 293: TRUE, ! 294: 0, ! 295: handy); ! 296: goto loop; ! 297: } ! 298: if(flag) return(tatom); ! 299: return(nil); ! 300: } ! 301: ! 302: lispval ! 303: Labsval() ! 304: { ! 305: register lispval arg1, handy; ! 306: register temp; ! 307: snpand(3); /* clobber save mask */ ! 308: ! 309: chkarg(1,"absval"); ! 310: arg1 = lbot->val; ! 311: if(Lnegp()!=nil) return(Lminus()); ! 312: ! 313: return(arg1); ! 314: } ! 315: ! 316: #include "frame.h" ! 317: /* new version of showstack, ! 318: We will set fp to point where the register fp points. ! 319: Then fp+2 = saved ap ! 320: fp+4 = saved pc ! 321: fp+3 = saved fp ! 322: ap+1 = first arg ! 323: If we find that the saved pc is somewhere in the routine eval, ! 324: then we print the first argument to that eval frame. This is done ! 325: by looking one beyond the saved ap. ! 326: */ ! 327: lispval ! 328: Lshostk() ! 329: { lispval isho(); ! 330: return(isho(1)); ! 331: } ! 332: static lispval ! 333: isho(f) ! 334: int f; ! 335: { ! 336: register struct frame *myfp; register lispval handy; ! 337: int **fp; /* this must be the first local */ ! 338: int virgin=1; ! 339: lispval linterp(); ! 340: lispval _qfuncl(),tynames(); /* locations in qfuncl */ ! 341: extern int prinlevel,prinlength; ! 342: ! 343: if(TYPE(Vprinlevel->a.clb) == INT) ! 344: { ! 345: prinlevel = Vprinlevel->a.clb->i; ! 346: } ! 347: else prinlevel = -1; ! 348: if(TYPE(Vprinlength->a.clb) == INT) ! 349: { ! 350: prinlength = Vprinlength->a.clb->i; ! 351: } ! 352: else prinlength = -1; ! 353: ! 354: if(f==1) ! 355: printf("Forms in evaluation:\n"); ! 356: else ! 357: printf("Backtrace:\n\n"); ! 358: ! 359: myfp = (struct frame *) (&fp +1); /* point to current frame */ ! 360: ! 361: while(TRUE) ! 362: { ! 363: if( (myfp->pc > eval && /* interpreted code */ ! 364: myfp->pc < popnames) ! 365: || ! 366: (myfp->pc > Lfuncal && /* compiled code */ ! 367: myfp->pc < linterp) ) ! 368: { ! 369: if(((int) myfp->ap[0]) == 1) /* only if arg given */ ! 370: { handy = (myfp->ap[1]); ! 371: if(f==1) ! 372: printr(handy,stdout), putchar('\n'); ! 373: else { ! 374: if(virgin) ! 375: virgin = 0; ! 376: else ! 377: printf(" -- "); ! 378: printr((TYPE(handy)==DTPR)?handy->d.car:handy,stdout); ! 379: } ! 380: } ! 381: ! 382: } ! 383: ! 384: if(myfp > myfp->fp) break; /* end of frames */ ! 385: else myfp = myfp->fp; ! 386: } ! 387: putchar('\n'); ! 388: return(nil); ! 389: } ! 390: ! 391: /* ! 392: * ! 393: * (baktrace) ! 394: * ! 395: * baktrace will print the names of all functions being evaluated ! 396: * from the current one (baktrace) down to the first one. ! 397: * currently it only prints the function name. Planned is a ! 398: * list of local variables in all stack frames. ! 399: * written by jkf. ! 400: * ! 401: */ ! 402: lispval ! 403: Lbaktrace() ! 404: { ! 405: isho(0); ! 406: } ! 407: ! 408: /* ! 409: * ! 410: * (oblist) ! 411: * ! 412: * oblist returns a list of all symbols in the oblist ! 413: * ! 414: * written by jkf. ! 415: */ ! 416: lispval ! 417: Loblist() ! 418: { ! 419: int indx; ! 420: lispval headp, tailp ; ! 421: struct atom *symb ; ! 422: extern int hashtop; ! 423: snpand(0); ! 424: ! 425: headp = tailp = newdot(); /* allocate first DTPR */ ! 426: protect(headp); /*protect the list from garbage collection*/ ! 427: /*line added by kls */ ! 428: ! 429: for( indx=0 ; indx <= hashtop-1 ; indx++ ) /* though oblist */ ! 430: { ! 431: for( symb = hasht[indx] ; ! 432: symb != (struct atom *) CNIL ; ! 433: symb = symb-> hshlnk) ! 434: { ! 435: if(TYPE(symb) != ATOM) ! 436: { printf(" non symbol in hasht[%d] = %x: ",indx,symb); ! 437: printr(symb,stdout); ! 438: printf(" \n"); ! 439: fflush(stdout); ! 440: } ! 441: tailp->d.car = (lispval) symb ; /* remember this atom */ ! 442: tailp = tailp->d.cdr = newdot() ; /* link to next DTPR */ ! 443: } ! 444: } ! 445: ! 446: tailp->d.cdr = nil ; /* close the list unfortunately throwing away ! 447: the last DTPR ! 448: */ ! 449: return(headp); ! 450: } ! 451: ! 452: /* ! 453: * Maclisp setsyntax function: ! 454: * (setsyntax c s x) ! 455: * c represents character either by fixnum or atom ! 456: * s is the atom "macro" or the atom "splicing" (in which case x is the ! 457: * macro to be invoked); or nil (meaning don't change syntax of c); or ! 458: * (well thats enough for now) if s is a fixnum then we modify the bits ! 459: * for c in the readtable. ! 460: */ ! 461: #include "chars.h" ! 462: #include "chkrtab.h" ! 463: ! 464: lispval ! 465: Lsetsyn() ! 466: { ! 467: register lispval s, c; ! 468: register struct argent *mynp; ! 469: register index; ! 470: register struct argent *lbot, *np; ! 471: lispval x,debugmode; ! 472: extern char *ctable; ! 473: extern lispval Istsrch(); ! 474: int value; ! 475: ! 476: switch(np-lbot) { ! 477: case 2: ! 478: protect(nil); ! 479: case 3: ! 480: break; ! 481: default: ! 482: argerr("setsyntax"); ! 483: } ! 484: s = Vreadtable->a.clb; ! 485: chkrtab(s); ! 486: /* debugging code ! 487: debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr; ! 488: if(debugmode) printf("Readtable addr: %x\n",ctable); ! 489: end debugging code */ ! 490: mynp = lbot; ! 491: c = (mynp++)->val; ! 492: s = (mynp++)->val; ! 493: x = (mynp++)->val; ! 494: ! 495: switch(TYPE(c)) { ! 496: default: ! 497: error("neither fixnum, atom or string as char to setsyntax",FALSE); ! 498: ! 499: case ATOM: ! 500: index = *(c->a.pname); ! 501: if((c->a.pname)[1])error("Only 1 char atoms to setsyntax",FALSE); ! 502: break; ! 503: ! 504: case INT: ! 505: index = c->i; ! 506: break; ! 507: ! 508: case STRNG: ! 509: index = (int) *((char *) c); ! 510: } ! 511: switch(TYPE(s)) { ! 512: case INT: ! 513: if(s->i == VESC) Xesc = (char) index; ! 514: else if(s->i == VDQ) Xdqc = (char) index; ! 515: else if(s->i == VSD) Xsdc = (char) index; /* string */ ! 516: ! 517: if(ctable[index] == VESC /* if we changed the current esc */ ! 518: && s->i != VESC /* to something else, pick current */ ! 519: && Xesc == (char) index) { ! 520: ctable[index] = s->i; ! 521: rpltab(VESC,&Xesc); ! 522: } ! 523: else if(ctable[index] == VDQ /* likewise for double quote */ ! 524: && s->i != VDQ ! 525: && Xdqc == (char) index) { ! 526: ctable[index] = s->i; ! 527: rpltab(VDQ,&Xdqc); ! 528: } ! 529: else if(ctable[index] == VSD /* and for string delimiter */ ! 530: && s->i != VSD ! 531: && Xsdc == (char) index) { ! 532: ctable[index] = s->i; ! 533: rpltab(VSD,&Xsdc); ! 534: } ! 535: else ctable[index] = s->i; ! 536: ! 537: break; ! 538: case ATOM: ! 539: if(s==splice) ! 540: ctable[index] = VSPL; ! 541: else if(s==macro) ! 542: ctable[index] = VMAC; ! 543: if(TYPE(c)!=ATOM) { ! 544: strbuf[0] = index; ! 545: strbuf[1] = 0; ! 546: c = (getatom()); ! 547: } ! 548: Iputprop(c,x,macro); ! 549: } ! 550: return(tatom); ! 551: } ! 552: ! 553: /* ! 554: * this aux function is used by setsyntax to determine the new current ! 555: * escape or double quote character. It scans the character table for ! 556: * the first character with the given class (either VESC or VDQ) and ! 557: * puts that character in Xesc or Xdqc (whichever is pointed to by ! 558: * addr). ! 559: */ ! 560: rpltab(cclass,addr) ! 561: char cclass; ! 562: char *addr; ! 563: { ! 564: register int i; ! 565: extern char *ctable; ! 566: for(i=0; i<=127 && ctable[i] != cclass; i++); ! 567: if(i<=127) *addr = (char) i; ! 568: else *addr = '\0'; ! 569: } ! 570: ! 571: lispval ! 572: Lzapline() ! 573: { ! 574: register FILE *port; ! 575: extern FILE * rdrport; ! 576: ! 577: port = rdrport; ! 578: while (!feof(port) && (getc(port)!='\n') ); ! 579: return(nil); ! 580: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.