Return to 68k.c CVS log

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

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

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

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