Return to vax.c CVS log

Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz / vax

Annotation of 43BSD/ucb/lisp/franz/vax/vax.c, revision 1.1

1.1     ! root        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: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.