4.3BSD - /usr/src/ucb/lisp/franz/vax/vax.c

   1: 
   2: #ifndef lint
   3: static char *rcsid =
   4:    "$Header: vax.c,v 1.6 84/02/29 16:45:23 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 machframe *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 machframe *) (&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 machframe *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 machframe *) (&fp +1);
 295:     else
 296:         myfp = (struct machframe *) 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: #include "frame.h"
 330: /*
 331:  * this code is very similar to ftolsp.
 332:  * if it gets revised, so should this.
 333:  */
 334: lispval
 335: dothunk(func,count,arglist)
 336: lispval func;
 337: long count;
 338: register long *arglist;
 339: {
 340: 
 341:     lispval save;
 342:     pbuf pb;
 343:     Savestack(1);
 344: 
 345:     if(errp->class==F_TO_FORT)
 346:         np = errp->svnp;
 347:     errp = Pushframe(F_TO_LISP,nil,nil);
 348:     lbot = np;
 349:     np++->val = func;
 350:     arglist++;
 351:     for(; count > 0; count--)
 352:         np++->val = inewint(*arglist++);
 353:     save = Lfuncal();
 354:     errp = Popframe();
 355:     Restorestack();
 356:     return(save);
 357: }
 358: /*
 359: _thcpy:
 360: 	movl	(sp),r0
 361: 	pushl	ap
 362: 	pushl	(r0)+
 363: 	pushl	(r0)+
 364: 	calls	$3,_dothunk
 365: 	ret */
 366: static char fourwords[] = "0123456789012345";
 367: 
 368: lispval
 369: Lmkcth()
 370: {
 371:     register struct argent *mylbot = lbot;
 372:     register struct thunk {
 373:         short   mask;
 374:         short   jsri;
 375:         char    *thcpy;
 376:         long    count;
 377:         lispval func;
 378:     } *th;
 379:     extern char thcpy[];
 380: 
 381:     chkarg(2,"make-c-thunk");
 382:     th = (struct thunk *)pinewstr(fourwords);
 383:     th->mask = 0;
 384:     th->jsri = 0x9f16;
 385:     th->thcpy = thcpy;
 386:     th->func = mylbot->val;
 387:     th->count = mylbot[1].val->i;
 388: 
 389:     return((lispval)th);
 390: }

Defined functions

Defined variables

Defined struct's

Defined macros