4.3BSD - /usr/src/ucb/lisp/franz/68k/68k.c

   1: #include "global.h"
   2: #include <signal.h>
   3: 
   4: 
   5: mmuladd(a,b,c,m)
   6: long a,b,c,m;
   7: {
   8:     long work[2]; char err;
   9:     emul(a,b,c,work);
  10:     ediv(work,m,err);
  11:     return(work[0]);
  12: }
  13: /*mmuladd (a, b, c, m)
  14: int a, b, c, m;
  15: {
  16: 	asm ("emul	4(ap),8(ap),12(ap),r0");
  17: 	asm ("ediv	16(ap),r0,r2,r0");
  18: }
  19: 
  20: Imuldiv() {
  21: asm("	emul	4(ap),8(ap),12(ap),r0");
  22: asm("	ediv	16(ap),r0,*20(ap),*24(ap)");
  23: }*/
  24: 
  25: Imuldiv(p1,p2,add,dv,quo,rem)
  26: long p1, p2, add, dv;
  27: long *quo, *rem;
  28: {
  29:     long work[2]; char err;
  30: 
  31:     emul(p1,p2,add,work);
  32:     *quo = ediv(work,dv, &err);
  33:     *rem = *work;
  34: }
  35: /*C library -- write
  36:   nwritten = write(file, buffer, count);
  37:   nwritten == -1 means error
  38: */
  39: write(file, buffer, count)
  40: char *buffer;
  41: {
  42:     register lispval handy;
  43:     int retval;
  44:     if((file != 1) || (Vcntlw->a.clb == nil)) goto top;
  45:     /* since ^w is non nil, we do not want to print to the terminal,
  46: 	   but we must be sure to return a correct value from the write
  47: 	   in case there is no write to ptport
  48: 	*/
  49:     retval = count;
  50:     goto skipit;
  51: 
  52: top:
  53: 
  54:     retval = _write(file,buffer,count);
  55: 
  56: skipit:
  57:     if(file==1) {
  58:     handy = Vptport->a.clb;
  59:     if(handy!=nil && TYPE(handy)==PORT && handy->p->_file!=1) {
  60:         fflush(handy->p);
  61:         file = handy->p->_file;
  62:         goto top;
  63:     }
  64:     }
  65:     return(retval);
  66: }
  67: 
  68: /*
  69: # C library -- read
  70: 
  71: # nread = read(file, buffer, count);
  72: #
  73: # nread ==0 means eof; nread == -1 means error
  74: */
  75: #include <errno.h>
  76: read(file,buffer,count)
  77: {
  78:     extern int errno;
  79:     register int Size;
  80: again:
  81: 
  82:     Size = _read(file,buffer,count);
  83:     if ((Size >= 0) || (errno != EINTR)) return(Size);
  84:     if(sigintcnt > 0) sigcall(SIGINT);
  85:     goto again;
  86: }
  87: 
  88: lispval
  89: Lpolyev()
  90: {
  91:     register int count;
  92:     register double *handy, *base;
  93:     register struct argent *argp;
  94:     lispval result; int type;
  95:     char *alloca();
  96: 
  97:     count = 2 * (((int) np) - (int) lbot);
  98:     if(count == 0)
  99:         return(inewint(0));
 100:     if(count == 8)
 101:         return(lbot->val);
 102:     base = handy = (double *) alloca(count);
 103:     for(argp = lbot; argp < np; argp++) {
 104:         while((type = TYPE(argp->val))!=DOUB && type!=INT)
 105:             argp->val = (lispval) errorh2(Vermisc,"%%machine-polyev:non-real arg",nil,TRUE,73,lbot,argp->val);
 106:         if(TYPE(argp->val)==INT) {
 107:             *handy++ = argp->val->i;
 108:         } else
 109:             *handy++ = argp->val->r;
 110:     }
 111:     count = count/sizeof(double) - 2;
 112: /*	asm("polyd	(r9),r11,8(r9)");
 113: 	asm("movd	r0,(r9)");*/
 114:     result = newdoub();
 115:     result->r = *base;
 116:     return(result);
 117: }
 118: 
 119: lispval
 120: Lrot()
 121: {
 122:     register rot,val;       /* these must be the first registers */
 123:     register struct argent *mylbot = lbot;
 124: 
 125:     chkarg(2,"rot");
 126:     if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT))
 127:         errorh2(Vermisc,
 128:                "Non ints to rot",
 129:                nil,FALSE,0,mylbot->val,mylbot[1].val);
 130:     val = mylbot[0].val->i;
 131:     rot = mylbot[1].val->i;
 132:     rot = rot % 32 ;    /* bring it down below one byte in size */
 133:     if(rot < 0) {
 134:         rot = -rot;
 135:         {asm("roll	d7,d6");}
 136:     } else {asm("rorl	d7,d6");}
 137:     return( inewint(val));
 138: }
 139: 
 140: myfrexp() { error("myfrexp called", FALSE);}
 141: #if os_unisoft | os_unix_ts
 142: syscall() { error("vsyscall called", FALSE);}
 143: #endif
 144: 
 145: #include "structs.h"
 146: prunei(what)
 147: register lispval what;
 148: {
 149:     extern struct types int_str;
 150:     int gstart();
 151:     if(((long)what) > ((long) gstart)) {
 152:         --(int_items->i);
 153:         what->i = (long) int_str.next_free;
 154:         int_str.next_free = (char *) what;
 155:     }
 156: }
 157: #include "68kframe.h"
 158: /* new version of showstack,
 159: 	We will set fp to point where the register fp points.
 160: 	If we find that the saved pc is somewhere in the routine eval,
 161:    then we print the first argument to that eval frame. This is done
 162:    by looking on the stack.
 163: */
 164: lispval
 165: Lshostk()
 166: {   lispval isho();
 167:     return(isho(1));
 168: }
 169: static lispval
 170: isho(f)
 171: int f;
 172: {
 173:     register struct machframe *myfp; register lispval handy;
 174:     int **fp;   /* this must be the first local */
 175:     int virgin=1;
 176:     lispval linterp(), Ifuncal();
 177:     lispval _qfuncl(),tynames();    /* locations in qfuncl */
 178:     extern int plevel,plength;
 179: 
 180:     if(TYPE(Vprinlevel->a.clb) == INT)
 181:     {
 182:        plevel = Vprinlevel->a.clb->i;
 183:     }
 184:     else plevel = -1;
 185:     if(TYPE(Vprinlength->a.clb) == INT)
 186:     {
 187:         plength = Vprinlength->a.clb->i;
 188:     }
 189:     else plength = -1;
 190: 
 191:     if(f==1)
 192:         printf("Forms in evaluation:\n");
 193:     else
 194:         printf("Backtrace:\n\n");
 195: 
 196:     myfp = (struct machframe *) (&fp +1);   /* point to current machframe */
 197: 
 198:     while(TRUE)
 199:     {
 200:         if( (myfp->pc > eval  &&        /* interpreted code */
 201:          myfp->pc < popnames)
 202:         ||
 203:         (myfp->pc > Ifuncal &&      /* compiled code */
 204:          myfp->pc < Lfuncal)  )
 205:         {
 206:           { handy = (myfp->fp->ap[0]);
 207:         if(f==1)
 208:             printr(handy,stdout), putchar('\n');
 209:         else {
 210:             if(virgin)
 211:                 virgin = 0;
 212:             else
 213:                 printf(" -- ");
 214:             printr((TYPE(handy)==DTPR)?handy->d.car:handy,stdout);
 215:         }
 216:           }
 217: 
 218:         }
 219: 
 220:         if(myfp > myfp->fp) break;  /* end of frames */
 221:         else myfp = myfp->fp;
 222:     }
 223:     putchar('\n');
 224:     return(nil);
 225: }
 226: 
 227: /*
 228:  *
 229:  *	(baktrace)
 230:  *
 231:  * baktrace will print the names of all functions being evaluated
 232:  * from the current one (baktrace) down to the first one.
 233:  * currently it only prints the function name.  Planned is a
 234:  * list of local variables in all stack frames.
 235:  * written by jkf.
 236:  *
 237:  */
 238: lispval
 239: Lbaktrace()
 240: {
 241:     isho(0);
 242: }
 243: 
 244: /*
 245:  * (int:showstack 'stack_pointer)
 246:  * return
 247:  *   nil if at the end of the stack or illegal
 248:  *   ( expresssion . next_stack_pointer) otherwise
 249:  *   where expression is something passed to eval
 250:  * very vax specific
 251:  */
 252: lispval
 253: LIshowstack()
 254: {
 255:     int **fp;   /* must be the first local variable */
 256:     register lispval handy;
 257:     register struct machframe *myfp;
 258:     lispval retval, Ifuncal();
 259:     Savestack(2);
 260: 
 261:     chkarg(1,"int:showstack");
 262: 
 263:     if((TYPE(handy=lbot[0].val) != INT) && (handy != nil))
 264:         error("int:showstack non fixnum arg", FALSE);
 265: 
 266:     if(handy == nil)
 267:         myfp = (struct machframe *) (&fp +1);
 268:     else
 269:         myfp = (struct machframe *) handy->i;
 270: 
 271:     if((int ***)myfp <= &fp) error("int:showstack illegal stack value",FALSE);
 272:     while(myfp > 0)
 273:     {
 274:         if( (myfp->pc > eval  &&        /* interpreted code */
 275:             myfp->pc < popnames)
 276:         ||
 277:         (myfp->pc > Ifuncal &&      /* compiled code */
 278:         myfp->pc < Lfuncal)  )
 279:         {
 280:         {
 281:         handy = (lispval)(myfp->fp->ap[0]); /* arg to eval */
 282: 
 283:         protect(retval=newdot());
 284:         retval->d.car = handy;
 285:         if(myfp > myfp->fp)
 286:             myfp = 0;   /* end of frames */
 287:         else
 288:             myfp = myfp->fp;
 289:         retval->d.cdr = inewint(myfp);
 290:         return(retval);
 291:         }
 292:     }
 293:     if(myfp > myfp->fp)
 294:          myfp = 0;  /* end of frames */
 295:     else
 296:          myfp = myfp->fp;
 297: 
 298:     }
 299:     return(nil);
 300: }
 301: #include "frame.h"
 302: /*
 303:  * this code is very similar to ftolsp.
 304:  * if it gets revised, so should this.
 305:  */
 306: lispval
 307: dothunk(func,count)
 308: lispval func;
 309: long count;
 310: {
 311:     register long *arglist = (& count) + 3;
 312:     lispval save;
 313:     pbuf pb;
 314:     Savestack(1);
 315: 
 316:     if(errp->class==F_TO_FORT)
 317:         np = errp->svnp;
 318:     errp = Pushframe(F_TO_LISP,nil,nil);
 319:     lbot = np;
 320:     np++->val = func;
 321:     for(; count > 0; count--)
 322:         np++->val = inewint(*arglist++);
 323:     save = Lfuncal();
 324:     errp = Popframe();
 325:     Restorestack();
 326:     return(save);
 327: }
 328: /*
 329: _thcpy:
 330: 	movl	sp@,a0
 331: 	movl	a0@+,sp@-
 332: 	movl	a0@+,sp@-
 333: 	jsr	_dothunk
 334: 	lea	sp@(12),sp
 335: 	rts*/
 336: static char fivewords[] = "01234567890123456789";
 337: 
 338: lispval
 339: Lmkcth()
 340: {
 341:     register struct argent *mylbot = lbot;
 342:     register struct thunk {
 343:         short   nop;
 344:         short   jsri;
 345:         char    *thcpy;
 346:         long    count;
 347:         lispval func;
 348:     } *th;
 349:     long handy = (long) pinewstr(fivewords);
 350:     extern char thcpy[];
 351: 
 352:     chkarg(2,"make-c-thunk");
 353:     handy = ((handy - 1 ) | 3) + 1;
 354:     th = (struct thunk *) handy;
 355:     th->nop = 0x4e71;
 356:     th->jsri = 0x4eb9;
 357:     th->thcpy = thcpy;
 358:     th->func = mylbot->val;
 359:     th->count = mylbot[1].val->i;
 360: 
 361:     return((lispval)th);
 362: }

Defined functions

Defined variables

Defined struct's