![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tahoe.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / franz / tahoe|
Return to tahoe.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / franz / tahoe |
1.1 ! root 1: /* ! 2: * tahoe.c ! 3: * tahoe specific functions ! 4: * ! 5: * (c) copyright 1982, Regents of the University of California ! 6: */ ! 7: ! 8: #include "global.h" ! 9: #include <signal.h> ! 10: ! 11: mmuladd (a, b, c, m) ! 12: int a, b, c, m; ! 13: { ! 14: asm ("emul 4(fp),8(fp),12(fp),r0"); ! 15: asm ("ediv 16(fp),r0,r2,r0"); ! 16: } ! 17: ! 18: Imuldiv(a, b, c, d, e) ! 19: { ! 20: asm(" emul 4(fp),8(fp),12(fp),r0"); ! 21: asm(" ediv 16(fp),r0,*20(fp),*24(fp)"); ! 22: } ! 23: ! 24: lispval ! 25: Lpolyev() ! 26: { ! 27: register int count; ! 28: register double *handy, *base; ! 29: register struct argent *argp; ! 30: lispval result; int type; ! 31: char *alloca(); ! 32: Keepxs(); ! 33: ! 34: error("Lpolyev - Unimplemented or inappropriate CCI function",FALSE); ! 35: count = 2 * (((int) np) - (int) lbot); ! 36: if(count == 0) ! 37: return(inewint(0)); ! 38: if(count == 8) ! 39: return(lbot->val); ! 40: base = handy = (double *) alloca(count); ! 41: for(argp = lbot; argp < np; argp++) { ! 42: while((type = TYPE(argp->val))!=DOUB && type!=INT) ! 43: argp->val = (lispval) errorh2(Vermisc,"%%machine-polyev:non-real arg",nil,TRUE,73,lbot,argp->val); ! 44: if(TYPE(argp->val)==INT) { ! 45: *handy++ = argp->val->i; ! 46: } else ! 47: *handy++ = argp->val->r; ! 48: } ! 49: count = count/sizeof(double) - 2; ! 50: #ifdef vax ! 51: asm("polyd (r9),r11,8(r9)"); ! 52: asm("movd r0,(r9)"); ! 53: #endif ! 54: result = newdoub(); ! 55: result->r = *base; ! 56: Freexs(); ! 57: return(result); ! 58: } ! 59: ! 60: lispval ! 61: Lrot() ! 62: { ! 63: register val; ! 64: register unsigned long mask2 = -1; ! 65: register struct argent *mylbot = lbot; ! 66: long rot; ! 67: ! 68: chkarg(2,"rot"); ! 69: if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT)) ! 70: errorh2(Vermisc, ! 71: "Non ints to rot", ! 72: nil,FALSE,0,mylbot->val,mylbot[1].val); ! 73: val = mylbot[0].val->i; ! 74: rot = mylbot[1].val->i; ! 75: rot = rot & 0x3f; /* bring it down below one byte in size */ ! 76: mask2 >>= rot; ! 77: mask2 ^= -1; ! 78: mask2 &= val; ! 79: mask2 >>= (32 - rot); ! 80: val <<= rot; ! 81: val |= mask2; ! 82: return( inewint(val)); ! 83: } ! 84: ! 85: #include "tahoeframe.h" ! 86: /* new version of showstack, ! 87: We will set fp to point where the register fp points. ! 88: Then fp+2 = saved ap ! 89: fp+4 = saved pc ! 90: fp+3 = saved fp ! 91: ap+1 = first arg ! 92: If we find that the saved pc is somewhere in the routine eval, ! 93: then we print the first argument to that eval frame. This is done ! 94: by looking one beyond the saved ap. ! 95: */ ! 96: lispval ! 97: Lshostk() ! 98: { lispval isho(); ! 99: return(isho(1)); ! 100: } ! 101: static lispval ! 102: isho(f) ! 103: int f; ! 104: { ! 105: register struct machframe *myfp; register lispval handy; ! 106: int **fp; /* this must be the first local */ ! 107: int virgin=1; ! 108: lispval linterp(); ! 109: lispval _qfuncl(),tynames(); /* locations in qfuncl */ ! 110: extern int plevel,plength; ! 111: ! 112: error("C coded showstack - Unimplemented or inappropriate CCI function",FALSE); ! 113: if(TYPE(Vprinlevel->a.clb) == INT) ! 114: { ! 115: plevel = Vprinlevel->a.clb->i; ! 116: } ! 117: else plevel = -1; ! 118: if(TYPE(Vprinlength->a.clb) == INT) ! 119: { ! 120: plength = Vprinlength->a.clb->i; ! 121: } ! 122: else plength = -1; ! 123: ! 124: if(f==1) ! 125: printf("Forms in evaluation:\n"); ! 126: else ! 127: printf("Backtrace:\n\n"); ! 128: ! 129: myfp = (struct machframe *) (&fp +1); /* point to current frame */ ! 130: ! 131: while(TRUE) ! 132: { ! 133: if( (myfp->pc > eval && /* interpreted code */ ! 134: myfp->pc < popnames) ! 135: || ! 136: (myfp->pc > Lfuncal && /* compiled code */ ! 137: myfp->pc < linterp) ) ! 138: { ! 139: #ifdef vax ! 140: if(((int) myfp->ap[0]) == 1) /* only if arg given */ ! 141: { handy = (myfp->ap[1]); ! 142: if(f==1) ! 143: printr(handy,stdout), putchar('\n'); ! 144: else { ! 145: if(virgin) ! 146: virgin = 0; ! 147: else ! 148: printf(" -- "); ! 149: printr((TYPE(handy)==DTPR)?handy->d.car:handy,stdout); ! 150: } ! 151: } ! 152: #endif ! 153: ! 154: } ! 155: ! 156: if(myfp > myfp->fp) break; /* end of frames */ ! 157: else myfp = myfp->fp; ! 158: } ! 159: putchar('\n'); ! 160: return(nil); ! 161: } ! 162: ! 163: /* ! 164: * ! 165: * (baktrace) ! 166: * ! 167: * baktrace will print the names of all functions being evaluated ! 168: * from the current one (baktrace) down to the first one. ! 169: * currently it only prints the function name. Planned is a ! 170: * list of local variables in all stack frames. ! 171: * written by jkf. ! 172: * ! 173: */ ! 174: lispval ! 175: Lbaktrace() ! 176: { ! 177: isho(0); ! 178: } ! 179: ! 180: /* ! 181: * (int:showstack 'stack_pointer) ! 182: * return ! 183: * nil if at the end of the stack or illegal ! 184: * ( expresssion . next_stack_pointer) otherwise ! 185: * where expression is something passed to eval ! 186: * very tahoe specific ! 187: */ ! 188: ! 189: ! 190: lispval ! 191: LIshowstack() ! 192: { ! 193: int **fp; /* must be the first local variable */ ! 194: register lispval handy; ! 195: register struct machframe *myfp; ! 196: lispval retval, Lfuncal(), Ifuncal(); ! 197: lispval (*pc)() = 0; ! 198: Savestack(2); ! 199: ! 200: chkarg(1,"int:showstack"); ! 201: ! 202: if((TYPE(handy=lbot[0].val) != INT) && (handy != nil)) ! 203: error("int:showstack non fixnum arg", FALSE); ! 204: ! 205: if(handy == nil) ! 206: asm("movab -8(fp),r11"); /* only way I could think of */ ! 207: else ! 208: myfp = (struct machframe *) handy->i; ! 209: ! 210: /* if((int ***)myfp <= &fp) error("int:showstack illegal stack value",FALSE); */ ! 211: ! 212: while(myfp > 0) ! 213: { ! 214: /*fprintf(stderr, "myfp=%x pc=%x fp=%x removed=%d\n", myfp, myfp->pc, ! 215: myfp->fp, myfp->removed); ! 216: fflush(stderr);*/ ! 217: ! 218: if( (pc >= eval && /* interpreted code */ ! 219: pc < popnames) ! 220: || ! 221: (pc >= Ifuncal && /* compiled code */ ! 222: pc < Lfuncal) ) ! 223: { ! 224: if(myfp->removed == 8) /* only if arg given */ ! 225: { ! 226: handy = (lispval)(myfp->arg[0]); /* arg to eval */ ! 227: ! 228: protect(retval=newdot()); ! 229: retval->d.car = handy; ! 230: if(myfp > myfp->fp) ! 231: myfp = 0; /* end of frames */ ! 232: else ! 233: myfp = (struct machframe *) ((char *)myfp->fp - 8); ! 234: retval->d.cdr = inewint(myfp); ! 235: return(retval); ! 236: } ! 237: } ! 238: if(myfp > myfp->fp) ! 239: myfp = 0; /* end of frames */ ! 240: else ! 241: {pc = myfp->pc; ! 242: myfp = (struct machframe *) ((char *)myfp->fp - 8); ! 243: } ! 244: } ! 245: return(nil); ! 246: } ! 247: ! 248: #include "frame.h" ! 249: /* ! 250: * this code is very similar to ftolsp. ! 251: * if it gets revised, so should this. ! 252: */ ! 253: lispval ! 254: dothunk(func,count,arglist) ! 255: lispval func; ! 256: long count; ! 257: register long *arglist; ! 258: { ! 259: lispval save; ! 260: pbuf pb; ! 261: ! 262: if(errp->class==F_TO_FORT) ! 263: np = errp->svnp; ! 264: errp = Pushframe(F_TO_LISP,nil,nil); ! 265: lbot = np; ! 266: np++->val = func; ! 267: arglist++; /* this is a vaxism, we'll compensate elsewhere */ ! 268: for(; count > 0; count--) ! 269: np++->val = inewint(*arglist++); ! 270: save = Lfuncal(); ! 271: errp = Popframe(); ! 272: return(save); ! 273: } ! 274: ! 275: ! 276: /* ! 277: _thcpy: ! 278: movl (sp),r0 ! 279: pushl ap ! 280: pushl (r0)+ ! 281: pushl (r0)+ ! 282: calls $3,_dothunk ! 283: ret */ ! 284: ! 285: /* ! 286: * This is thunkmodel: ! 287: .word 0 ! 288: movl r0,r0 ! 289: callf $4,_thunkstack1 ! 290: .long 0 <count> ! 291: .long 0 <func> ! 292: */ ! 293: ! 294: extern lispval thunkstack1(); ! 295: struct thunk { ! 296: short mask; ! 297: char nop[3]; ! 298: char callf[3]; ! 299: lispval (*stack1)(); ! 300: long count; ! 301: lispval func; ! 302: } thunkmodel = ! 303: { 0, { 0xd , 0x50 , 0x50}, {0xfe , 0x4 , 0x9f}, thunkstack1, 0, 0}; ! 304: static char sixwords[] = "01234567890123456789012"; /* trailing 0! */ ! 305: ! 306: lispval ! 307: Lmkcth() ! 308: { ! 309: register struct argent *mylbot = lbot; ! 310: register struct thunk *th; ! 311: ! 312: ! 313: chkarg(2,"make-c-thunk"); ! 314: th = (struct thunk *)pinewstr(sixwords); ! 315: th = (struct thunk *) ((((int) th) | 3) & ~3); ! 316: *th = thunkmodel; ! 317: th->func = mylbot->val; ! 318: th->count = mylbot[1].val->i; ! 319: ! 320: return((lispval)th); ! 321: } ! 322: ! 323: /* ! 324: * This removes the frame from the stack for the thunk ! 325: * and retrieves various data. (Actually merges it into ! 326: * its own stack frame). ! 327: */ ! 328: lispval ! 329: thunkstack1(retfromthunk) ! 330: { ! 331: register int *handy, *midthunk; ! 332: int *arglist; ! 333: lispval func; ! 334: int count; ! 335: ! 336: handy = &retfromthunk; ! 337: arglist = handy + 2; /* should be +3, first is taken as ! 338: vax arglist count and ignored */ ! 339: handy[-1] = handy[2]; /* unlink frame */ ! 340: midthunk = (int *) handy[-3]; /* our oldpc points to mid thunk */ ! 341: handy[-3] = retfromthunk; ! 342: handy[-2] += (8 + handy[1]); /* save mask for thunk is 0, ! 343: adjust bytes to remove from us */ ! 344: ! 345: count = *midthunk; ! 346: func = (lispval) midthunk[1]; ! 347: /* you could even merge this in and avoid another callf! */ ! 348: return(dothunk(func,count,arglist)); ! 349: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.