![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to vax.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz / vax|
Return to vax.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz / vax |
1.1 ! root 1: ! 2: #ifndef lint ! 3: static char *rcsid = ! 4: "$Header: vax.c,v 1.4 83/09/12 14:06:22 sklower Exp $"; ! 5: #endif ! 6: ! 7: /* -[Mon Mar 21 19:35:50 1983 by jkf]- ! 8: * vax.c $Locker: $ ! 9: * vax specific functions ! 10: * ! 11: * (c) copyright 1982, Regents of the University of California ! 12: */ ! 13: ! 14: #include "global.h" ! 15: #include <signal.h> ! 16: #include "vaxframe.h" ! 17: ! 18: /* exarith(a,b,c,lo,hi) ! 19: * int a,b,c; ! 20: * int *lo, *hi; ! 21: * Exact arithmetic. ! 22: * a,b and c are 32 bit 2's complement integers ! 23: * calculates x=a*b+c to twice the precision of an int. ! 24: * In the vax version, the 30 low bits only are returned ! 25: * in *lo,and the next 32 bits of precision are returned in * hi. ! 26: * this works since exarith is used either for calculating the sum of ! 27: * two 32 bit numbers, (which is at most 33 bits), or ! 28: * multiplying a 30 bit number by a 32 bit numbers, ! 29: * which has a maximum precision of 62 bits. ! 30: * If *phi is 0 or -1 then ! 31: * x doesn't need any more than 31 bits plus sign to describe, so we ! 32: * place the sign in the high two bits of *lo and return 0 from this ! 33: * routine. A non zero return indicates that x requires more than 31 bits ! 34: * to describe. ! 35: */ ! 36: exarith(a,b,c,phi,plo) ! 37: int *phi, *plo; ! 38: { ! 39: asm(" emul 4(ap),8(ap),12(ap),r2 #r2 = a*b + c to 64 bits"); ! 40: asm(" extzv $0,$30,r2,*20(ap) #get new lo"); ! 41: asm(" extv $30,$32,r2,r0 #get new carry"); ! 42: asm(" beql out # hi = 0, no work necessary"); ! 43: asm(" movl r0,*16(ap) # save hi"); ! 44: asm(" mcoml r0,r0 # Is hi = -1 (it'll fit in one word)"); ! 45: asm(" bneq out # it doesn't"); ! 46: asm(" bisl2 $0xc0000000,*20(ap) # alter low so that it is ok."); ! 47: asm("out: ret"); ! 48: } ! 49: ! 50: mmuladd (a, b, c, m) ! 51: int a, b, c, m; ! 52: { ! 53: asm ("emul 4(ap),8(ap),12(ap),r0"); ! 54: asm ("ediv 16(ap),r0,r2,r0"); ! 55: } ! 56: ! 57: Imuldiv() { ! 58: asm(" emul 4(ap),8(ap),12(ap),r0"); ! 59: asm(" ediv 16(ap),r0,*20(ap),*24(ap)"); ! 60: } ! 61: ! 62: callg_(funct,arglist) ! 63: lispval (*funct)(); ! 64: int *arglist; ! 65: { ! 66: asm(" callg *8(ap),*4(ap)"); ! 67: } ! 68: ! 69: #include <errno.h> ! 70: #define WRITE 4 ! 71: #define READ 3 ! 72: ! 73: #ifdef os_vms ! 74: #define _read _$real_read ! 75: #define _write _$real_write ! 76: #else ! 77: #define _read(a,b,c) syscall(READ,a,b,c) ! 78: #define _write(a,b,c) syscall(WRITE,a,b,c) ! 79: #endif ! 80: ! 81: /*C library -- write ! 82: nwritten = write(file, buffer, count); ! 83: nwritten == -1 means error ! 84: */ ! 85: write(file, buffer, count) ! 86: char *buffer; ! 87: { ! 88: register lispval handy; ! 89: int retval; ! 90: if((file != 1) || (Vcntlw->a.clb == nil)) goto top; ! 91: /* since ^w is non nil, we do not want to print to the terminal, ! 92: but we must be sure to return a correct value from the write ! 93: in case there is no write to ptport ! 94: */ ! 95: retval = count; ! 96: goto skipit; ! 97: top: ! 98: retval = _write(file,buffer,count); ! 99: ! 100: skipit: ! 101: if(file==1) { ! 102: handy = Vptport->a.clb; ! 103: if(handy!=nil && TYPE(handy)==PORT && handy->p->_file!=1) { ! 104: fflush(handy->p); ! 105: file = handy->p->_file; ! 106: goto top; ! 107: } ! 108: } ! 109: return(retval); ! 110: } ! 111: ! 112: /* ! 113: * ! 114: *nread = read(file, buffer, count); ! 115: *nread ==0 means eof; nread == -1 means error ! 116: * ! 117: */ ! 118: ! 119: read(file,buffer,count) ! 120: { ! 121: extern int errno; ! 122: register int Size; ! 123: again: ! 124: Size = _read(file,buffer,count); ! 125: if ((Size >= 0) || (errno != EINTR)) return(Size); ! 126: if(sigintcnt > 0) sigcall(SIGINT); ! 127: goto again; ! 128: } ! 129: ! 130: lispval ! 131: Lpolyev() ! 132: { ! 133: register int count; ! 134: register double *handy, *base; ! 135: register struct argent *argp; ! 136: lispval result; int type; ! 137: char *alloca(); ! 138: Keepxs(); ! 139: ! 140: count = 2 * (((int) np) - (int) lbot); ! 141: if(count == 0) ! 142: return(inewint(0)); ! 143: if(count == 8) ! 144: return(lbot->val); ! 145: base = handy = (double *) alloca(count); ! 146: for(argp = lbot; argp < np; argp++) { ! 147: while((type = TYPE(argp->val))!=DOUB && type!=INT) ! 148: argp->val = (lispval) errorh2(Vermisc,"%%machine-polyev:non-real arg",nil,TRUE,73,lbot,argp->val); ! 149: if(TYPE(argp->val)==INT) { ! 150: *handy++ = argp->val->i; ! 151: } else ! 152: *handy++ = argp->val->r; ! 153: } ! 154: count = count/sizeof(double) - 2; ! 155: asm("polyd (r9),r11,8(r9)"); ! 156: asm("movd r0,(r9)"); ! 157: result = newdoub(); ! 158: result->r = *base; ! 159: Freexs(); ! 160: return(result); ! 161: } ! 162: ! 163: lispval ! 164: Lrot() ! 165: { ! 166: register rot,val; /* these must be the first registers */ ! 167: register struct argent *mylbot = lbot; ! 168: ! 169: chkarg(2,"rot"); ! 170: if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT)) ! 171: errorh2(Vermisc, ! 172: "Non ints to rot", ! 173: nil,FALSE,0,mylbot->val,mylbot[1].val); ! 174: val = mylbot[0].val->i; ! 175: rot = mylbot[1].val->i; ! 176: rot = rot % 32 ; /* bring it down below one byte in size */ ! 177: asm(" rotl r11,r10,r10 "); /* rotate val by rot and put back in val */ ! 178: return( inewint(val)); ! 179: } ! 180: /* new version of showstack, ! 181: We will set fp to point where the register fp points. ! 182: Then fp+2 = saved ap ! 183: fp+4 = saved pc ! 184: fp+3 = saved fp ! 185: ap+1 = first arg ! 186: If we find that the saved pc is somewhere in the routine eval, ! 187: then we print the first argument to that eval frame. This is done ! 188: by looking one beyond the saved ap. ! 189: */ ! 190: lispval ! 191: Lshostk() ! 192: { lispval isho(); ! 193: return(isho(1)); ! 194: } ! 195: static lispval ! 196: isho(f) ! 197: int f; ! 198: { ! 199: register struct frame *myfp; register lispval handy; ! 200: int **fp; /* this must be the first local */ ! 201: int virgin=1; ! 202: lispval linterp(); ! 203: lispval _qfuncl(),tynames(); /* locations in qfuncl */ ! 204: extern int plevel,plength; ! 205: ! 206: if(TYPE(Vprinlevel->a.clb) == INT) ! 207: { ! 208: plevel = Vprinlevel->a.clb->i; ! 209: } ! 210: else plevel = -1; ! 211: if(TYPE(Vprinlength->a.clb) == INT) ! 212: { ! 213: plength = Vprinlength->a.clb->i; ! 214: } ! 215: else plength = -1; ! 216: ! 217: if(f==1) ! 218: printf("Forms in evaluation:\n"); ! 219: else ! 220: printf("Backtrace:\n\n"); ! 221: ! 222: myfp = (struct frame *) (&fp +1); /* point to current frame */ ! 223: ! 224: while(TRUE) ! 225: { ! 226: if( (myfp->pc > eval && /* interpreted code */ ! 227: myfp->pc < popnames) ! 228: || ! 229: (myfp->pc > Lfuncal && /* compiled code */ ! 230: myfp->pc < linterp) ) ! 231: { ! 232: if(((int) myfp->ap[0]) == 1) /* only if arg given */ ! 233: { handy = (myfp->ap[1]); ! 234: if(f==1) ! 235: printr(handy,stdout), putchar('\n'); ! 236: else { ! 237: if(virgin) ! 238: virgin = 0; ! 239: else ! 240: printf(" -- "); ! 241: printr((TYPE(handy)==DTPR)?handy->d.car:handy,stdout); ! 242: } ! 243: } ! 244: ! 245: } ! 246: ! 247: if(myfp > myfp->fp) break; /* end of frames */ ! 248: else myfp = myfp->fp; ! 249: } ! 250: putchar('\n'); ! 251: return(nil); ! 252: } ! 253: ! 254: /* ! 255: * ! 256: * (baktrace) ! 257: * ! 258: * baktrace will print the names of all functions being evaluated ! 259: * from the current one (baktrace) down to the first one. ! 260: * currently it only prints the function name. Planned is a ! 261: * list of local variables in all stack frames. ! 262: * written by jkf. ! 263: * ! 264: */ ! 265: lispval ! 266: Lbaktrace() ! 267: { ! 268: isho(0); ! 269: } ! 270: ! 271: /* ! 272: * (int:showstack 'stack_pointer) ! 273: * return ! 274: * nil if at the end of the stack or illegal ! 275: * ( expresssion . next_stack_pointer) otherwise ! 276: * where expression is something passed to eval ! 277: * very vax specific ! 278: */ ! 279: lispval ! 280: LIshowstack() ! 281: { ! 282: int **fp; /* must be the first local variable */ ! 283: register lispval handy; ! 284: register struct frame *myfp; ! 285: lispval retval, Lfuncal(), Ifuncal(); ! 286: Savestack(2); ! 287: ! 288: chkarg(1,"int:showstack"); ! 289: ! 290: if((TYPE(handy=lbot[0].val) != INT) && (handy != nil)) ! 291: error("int:showstack non fixnum arg", FALSE); ! 292: ! 293: if(handy == nil) ! 294: myfp = (struct frame *) (&fp +1); ! 295: else ! 296: myfp = (struct frame *) handy->i; ! 297: ! 298: if((int ***)myfp <= &fp) error("int:showstack illegal stack value",FALSE); ! 299: while(myfp > 0) ! 300: { ! 301: if( (myfp->pc > eval && /* interpreted code */ ! 302: myfp->pc < popnames) ! 303: || ! 304: (myfp->pc > Ifuncal && /* compiled code */ ! 305: myfp->pc < Lfuncal) ) ! 306: { ! 307: if(((int) myfp->ap[0]) == 1) /* only if arg given */ ! 308: { ! 309: handy = (lispval)(myfp->ap[1]); /* arg to eval */ ! 310: ! 311: protect(retval=newdot()); ! 312: retval->d.car = handy; ! 313: if(myfp > myfp->fp) ! 314: myfp = 0; /* end of frames */ ! 315: else ! 316: myfp = myfp->fp; ! 317: retval->d.cdr = inewint(myfp); ! 318: return(retval); ! 319: } ! 320: } ! 321: if(myfp > myfp->fp) ! 322: myfp = 0; /* end of frames */ ! 323: else ! 324: myfp = myfp->fp; ! 325: ! 326: } ! 327: return(nil); ! 328: } ! 329: #ifdef SPISFP ! 330: char * ! 331: alloca(howmuch) ! 332: register int howmuch; ! 333: { ! 334: howmuch += 3 ; ! 335: howmuch >>= 2; ! 336: xsp -= howmuch ! 337: if (xsp < xstack) { ! 338: xsp += howmuch; ! 339: xserr(); ! 340: } ! 341: return((char *) xsp); ! 342: } ! 343: #endif
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.