Return to lam4.c CVS log

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

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

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: lam4.c,v 1.5 83/12/28 16:21:08 sklower Exp $";
        !             4: #endif
        !             5: 
        !             6: /*                                     -[Sun Jun 19 22:25:48 1983 by jkf]-
        !             7:  *     lam4.c                          $Locker:  $
        !             8:  * lambda functions
        !             9:  *
        !            10:  * (c) copyright 1982, Regents of the University of California
        !            11:  */
        !            12: 
        !            13: 
        !            14: #include "global.h"
        !            15: lispval adbig(),subbig(),mulbig();
        !            16: double Ifloat();
        !            17: lispval
        !            18: Ladd()
        !            19: {
        !            20:        register lispval work;
        !            21:        register struct argent *result, *mynp, *oldnp;
        !            22:        long restype,prunep,hi,lo=0;
        !            23:        struct sdot dummybig;
        !            24:        double flacc;
        !            25:        Savestack(4);
        !            26: 
        !            27:        oldnp = result = np;
        !            28:        restype = INT;                  /* now start as integers */
        !            29:        protect(nil);
        !            30: 
        !            31:        for(mynp = lbot; mynp < oldnp; mynp++)
        !            32:        {
        !            33:            work = mynp->val;
        !            34:            switch(TYPE(work)) {
        !            35:            case INT:
        !            36:                switch(restype) {
        !            37:                case SDOT:
        !            38:                    dmlad(result->val,1L,work->i);
        !            39:                    prunep = TRUE;
        !            40:                    /* In adding the fixnum to the sdot we may make it
        !            41:                    possible for the bignum to be represented as a fixnum */
        !            42:                    break;
        !            43:                case INT:
        !            44:                    if(exarith(lo,1L,work->i,&hi,&lo)) {
        !            45:                        work = result->val = newsdot();
        !            46:                        work->s.I = lo;
        !            47:                        work = work->s.CDR = newdot();
        !            48:                        work->s.I = hi;
        !            49:                        work->s.CDR = 0;
        !            50:                        restype = SDOT; prunep = FALSE;
        !            51:                    } 
        !            52:                    break;
        !            53:                case DOUB:
        !            54:                    result->val->r += work->i;
        !            55:                    break;
        !            56:                default: goto urk;
        !            57:                }
        !            58:                break;
        !            59:            case SDOT:
        !            60:                switch(restype) {
        !            61:                case INT:
        !            62:                    dummybig.I = lo;
        !            63:                    dummybig.CDR = 0;
        !            64:                    work=adbig(work,(lispval)&dummybig);
        !            65:                    goto code1;
        !            66:                case SDOT:
        !            67:                    work=adbig(work,result->val);
        !            68:                    /* previous result is no longer needed */
        !            69:                    pruneb(result->val);
        !            70:                code1:
        !            71:                    restype = TYPE(work); /* SDOT or INT */
        !            72:                    if(restype==INT) {
        !            73:                        lo = work->i;
        !            74:                        prunei(work);
        !            75:                    } else {
        !            76:                        prunep = FALSE; /* sdot is cannonical */
        !            77:                        result->val = work;
        !            78:                    } break;
        !            79:                case DOUB:
        !            80:                    result->val->r += Ifloat(work);
        !            81:                    break;
        !            82:                default: goto urk;
        !            83:                }
        !            84:                break;
        !            85:            case DOUB:
        !            86:                switch(restype) {
        !            87:                case SDOT:
        !            88:                    if(prunep) {
        !            89:                        lispval handy;
        !            90:                        dummybig.I = 0;
        !            91:                        dummybig.CDR = (lispval) 0;
        !            92:                        handy = adbig((lispval)&dummybig,result->val);
        !            93:                        pruneb(result->val);
        !            94:                        result->val = handy;
        !            95:                    }
        !            96:                    flacc = Ifloat(result->val) + work->r;
        !            97:                    pruneb(result->val);
        !            98:                scrimp:
        !            99:                    (result->val = newdoub())->r = flacc;
        !           100:                    restype = DOUB;
        !           101:                    break;
        !           102:                case INT:
        !           103:                    flacc = work->r + lo;
        !           104:                    goto scrimp;
        !           105:                case DOUB:
        !           106:                    result->val->r += work->r;
        !           107:                    break;
        !           108:                default: goto urk;
        !           109:                }
        !           110:                break;
        !           111:            default:
        !           112:                    errorh1(Vermisc,"Non-number to add",nil,0,FALSE,work);
        !           113:            }
        !           114:        }
        !           115:        work = result->val;
        !           116:        switch(restype){
        !           117:        case DOUB:
        !           118:                break;
        !           119:        case INT:
        !           120:                work=inewint(lo);
        !           121:                break;
        !           122:        case SDOT:
        !           123:                if(prunep) {
        !           124:                    /* wouldn't (copy result->val) be faster ? -dhl */
        !           125:                    /* It might, but isn't guaranteed to canonicalize */
        !           126: 
        !           127:                    dummybig.I = 0;
        !           128:                    dummybig.CDR = (lispval) 0;
        !           129:                    work = adbig((lispval)&dummybig,work);
        !           130:                }
        !           131:                break;
        !           132:        default:
        !           133:        urk:
        !           134:                error("Internal error in add ",FALSE);
        !           135:        }
        !           136:        Restorestack();
        !           137:        return(work);
        !           138: }
        !           139: 
        !           140: /* exarith(a,b,c,lo,hi)
        !           141:  * int a,b,c;
        !           142:  * int *lo, *hi;
        !           143:  * Exact arithmetic.
        !           144:  * a,b and c are 32 bit 2's complement integers
        !           145:  * calculates x=a*b+c to twice the precision of an int.
        !           146:  * In the vax version, the 30 low bits only are returned
        !           147:  * in *lo,and the next 32 bits of precision are returned in * hi.
        !           148:  * this works since exarith is used either for calculating the sum of
        !           149:  * two 32 bit numbers, (which is at most 33 bits), or
        !           150:  * multiplying a 30 bit number by a 32 bit numbers,
        !           151:  * which has a maximum precision of 62 bits.
        !           152:  * If *phi is 0 or -1 then
        !           153:  * x doesn't need any more than 31 bits plus sign to describe, so we
        !           154:  * place the sign in the high two bits of *plo and return 0 from this
        !           155:  * routine.  A non zero return indicates that x requires more than 31 bits
        !           156:  * to describe.
        !           157:  *
        !           158:  * The definition has been moved to vax.c.
        !           159:  */
        !           160: 
        !           161: 
        !           162: lispval
        !           163: Lsub()
        !           164: {
        !           165:        register lispval work;
        !           166:        register struct argent *result, *mynp, *oldnp;
        !           167:        long prunep,restype,hi,lo=0;
        !           168:        struct sdot dummybig;
        !           169:        double flacc;
        !           170:        lispval Lminus();
        !           171:        Savestack(4);
        !           172: 
        !           173:        oldnp = result = np;
        !           174:        mynp = lbot + 1;
        !           175:        restype = INT;
        !           176:        prunep = TRUE;
        !           177:        if(oldnp==lbot)
        !           178:                goto out;
        !           179:        if(oldnp==mynp) {
        !           180:                work = Lminus();
        !           181:                Restorestack();
        !           182:                return(work);
        !           183:        }
        !           184:        protect(nil);
        !           185:        work = lbot->val;
        !           186: 
        !           187:        /* examine the first argument and perhaps set restype to the 
        !           188:         * correct type.  If restype (result type) is INT, then the
        !           189:         * fixnum value is stored in lo.  Otherwise, if restype is 
        !           190:         * SDOT or DOUB, then the value is stored in result->val.
        !           191:         */
        !           192:        switch(TYPE(work)) {
        !           193:        case INT:
        !           194:                lo = work->i;
        !           195:                restype = INT;
        !           196:                break;
        !           197:        case SDOT:
        !           198:                /* we want to copy the sdot we are given as an argument since
        !           199:                 * the bignum arithmetic routine dmlad clobbers the values it
        !           200:                 * is given.
        !           201:                 */
        !           202:                dummybig.I = 0;         /* create a zero sdot */
        !           203:                dummybig.CDR = 0;
        !           204:                work = adbig(work,(lispval)&dummybig);
        !           205:                /* the resulting value may have been reduced from an
        !           206:                 * sdot to a fixnum.  This should never happen though
        !           207:                 * but if it does, we simplify things.
        !           208:                 */
        !           209:                restype = TYPE(work);
        !           210:                if(restype==INT) {
        !           211:                    lo = work->i;       /* has turned into an fixnum */
        !           212:                    prunei(work);       /* return fixnum cell        */
        !           213:                } else {
        !           214:                    prunep = FALSE;     /* sdot is cannonical */
        !           215:                    result->val = work;
        !           216:                } 
        !           217:                break;
        !           218: 
        !           219:        case DOUB:
        !           220:                (result->val = newdoub())->r = work->r;
        !           221:                restype = DOUB;
        !           222:        }
        !           223: 
        !           224:        /* now loop through the rest of the arguments subtracting them
        !           225:         * from the running result in result or lo
        !           226:         */
        !           227:        for(; mynp < oldnp; mynp++)
        !           228:        {
        !           229:                work = mynp->val;
        !           230:                switch(TYPE(work)) {
        !           231:                case INT:
        !           232:                        switch(restype) {
        !           233:                        case SDOT:
        !           234:                                /* subtracting a fixnum from an bignum
        !           235:                                 * use the distructive multiply (by 1)
        !           236:                                 * and add the negative of the work value.
        !           237:                                 * The result will still be pointed to
        !           238:                                 * by result->val
        !           239:                                 */
        !           240:                                dmlad(result->val,1L, -work->i);
        !           241:                                prunep = TRUE;  /* check up on exiting */
        !           242:                                break;          /* that it didn't collapse */
        !           243:                        case INT:
        !           244:                                /* subtracting a fixnum from a fixnum,
        !           245:                                 * the result could turn into a bignum
        !           246:                                 */
        !           247:                                if(exarith(lo,1L,-work->i,&hi,&lo)) {
        !           248:                                    work = result->val = newsdot();
        !           249:                                    work->s.I = lo;
        !           250:                                    work = work->s.CDR = newdot();
        !           251:                                    work->s.I = hi;
        !           252:                                    work->s.CDR = 0;
        !           253:                                    restype = SDOT; prunep = TRUE;
        !           254:                                }
        !           255:                                break;
        !           256:                        case DOUB:
        !           257:                                /* subtracting a fixnum from a flonum */
        !           258:                                result->val->r -= work->i;
        !           259:                                break;
        !           260:                        default:
        !           261:                                goto urk;
        !           262:                        }
        !           263:                        break;
        !           264:                case SDOT:
        !           265:                        switch(restype) {
        !           266:                        case INT:
        !           267:                            /* subtracting a bignum from an integer
        !           268:                             * first make a bignum of the integer and
        !           269:                             * then fall into the next case
        !           270:                             */
        !           271:                            dummybig.I = lo;
        !           272:                            dummybig.CDR = (lispval) 0;
        !           273:                            work = subbig((lispval)&dummybig,work);
        !           274:                            goto on1;
        !           275: 
        !           276:                        case SDOT:
        !           277:                            /* subtracting one bignum from another.  The
        !           278:                             * routine to do this ends up calling addbig
        !           279:                             * and should probably be written specifically
        !           280:                             * for subtraction.
        !           281:                             */
        !           282:                             work = subbig(result->val,work);
        !           283:                             pruneb(result->val);
        !           284:                        on1:
        !           285:                             /* check if the result has turned into a fixnum */
        !           286:                             restype = TYPE(work);
        !           287:                             if(restype==INT) {
        !           288:                                lo = work->i;           /* it has */
        !           289:                                prunei(work);
        !           290:                             } else {
        !           291:                                prunep = FALSE;         /* sdot is cannonical */
        !           292:                                result->val = work;
        !           293:                             } 
        !           294:                             break;
        !           295:                        case DOUB: /* Subtract bignum from float */
        !           296:                                   /* Death on overflow          */
        !           297:                            result->val->r -= Ifloat(work);
        !           298:                            break;
        !           299:                        default:
        !           300:                                goto urk;
        !           301:                        }
        !           302:                        break;
        !           303: 
        !           304:                case DOUB:
        !           305:                        switch(restype) {
        !           306:                        case SDOT:  /* subtracting a flonum from a bignum. */
        !           307: 
        !           308:                            if(prunep) {
        !           309:                                lispval handy;
        !           310:                                dummybig.I = 0;
        !           311:                                dummybig.CDR = (lispval) 0;
        !           312:                                handy = adbig((lispval)&dummybig,result->val);
        !           313:                                pruneb(result->val);
        !           314:                                result->val = handy;
        !           315:                            }
        !           316:                            flacc = Ifloat(result->val) - work->r;
        !           317:                            pruneb(result->val);
        !           318:                scrimp:     (result->val = newdoub())->r = flacc;
        !           319:                            restype = DOUB;
        !           320:                            break;
        !           321:                        case INT:
        !           322:                                /* subtracting a flonum from an fixnum. 
        !           323:                                 * The result will be an flonum.
        !           324:                                 */
        !           325:                                flacc = lo - work->r;
        !           326:                                goto scrimp;
        !           327:                        case DOUB:
        !           328:                                /* subtracting a flonum from a flonum, what
        !           329:                                 * could be easier?
        !           330:                                 */
        !           331:                                result->val->r -= work->r;
        !           332:                                break;
        !           333:                        default:
        !           334:                                goto urk;
        !           335:                        }
        !           336:                        break;
        !           337:                default:
        !           338:                        errorh1(Vermisc,"Non-number to minus",nil,FALSE,0,work);
        !           339:                }
        !           340:        }
        !           341: out:
        !           342:        work = result->val;
        !           343:        switch(restype){
        !           344:        case DOUB:
        !           345:                break;
        !           346:        case INT:
        !           347:                work = inewint(lo);
        !           348:                break;
        !           349:        case SDOT:
        !           350:                if(prunep) {
        !           351:                    dummybig.I = 0;
        !           352:                    dummybig.CDR = (lispval) 0;
        !           353:                    work = adbig((lispval)&dummybig,work);
        !           354:                }
        !           355:                break;
        !           356:        default:
        !           357:        urk:
        !           358:                error("Internal error in difference",FALSE);
        !           359:        }
        !           360:        Restorestack();
        !           361:        return(work);
        !           362: }
        !           363: 
        !           364: lispval
        !           365: Ltimes()
        !           366: {
        !           367:        register lispval work;
        !           368:        register struct argent *result, *mynp, *oldnp;
        !           369:        long restype,prunep,hi,lo=1;
        !           370:        struct sdot dummybig;
        !           371:        double flacc;
        !           372:        Savestack(4);
        !           373: 
        !           374:        oldnp = result = np;
        !           375:        restype = INT;                  /* now start as integers */
        !           376:        prunep = TRUE;
        !           377:        protect(nil);
        !           378: 
        !           379:        for(mynp = lbot; mynp < oldnp; mynp++)
        !           380:        {
        !           381:            work = mynp->val;
        !           382:            switch(TYPE(work)) {
        !           383:            case INT:
        !           384:                switch(restype) {
        !           385:                case SDOT:
        !           386:                    dmlad(result->val,work->i,0L);
        !           387:                    prunep = TRUE;
        !           388:                    /* In adding the fixnum to the sdot we may make it
        !           389:                    possible for the bignum to be represented as a fixnum */
        !           390:                    break;
        !           391:                case INT:
        !           392:                    if(exarith(lo,work->i,0L,&hi,&lo)) {
        !           393:                        work = result->val = newsdot();
        !           394:                        work->s.I = lo;
        !           395:                        work = work->s.CDR = newdot();
        !           396:                        work->s.I = hi;
        !           397:                        work->s.CDR = 0;
        !           398:                        restype = SDOT; prunep = TRUE;
        !           399:                    } 
        !           400:                    break;
        !           401:                case DOUB:
        !           402:                    result->val->r *= work->i;
        !           403:                    break;
        !           404:                default: goto urk;
        !           405:                }
        !           406:                break;
        !           407:            case SDOT:
        !           408:                switch(restype) {
        !           409:                case INT:
        !           410:                    dummybig.I = lo;
        !           411:                    dummybig.CDR = 0;
        !           412:                    work=mulbig(work,(lispval)&dummybig);
        !           413:                    goto code1;
        !           414:                case SDOT:
        !           415:                    work=mulbig(work,result->val);
        !           416:                    /* previous result is no longer needed */
        !           417:                    pruneb(result->val);
        !           418:                code1:
        !           419:                    restype = TYPE(work); /* SDOT or INT */
        !           420:                    if(restype==INT) {
        !           421:                        lo = work->i;
        !           422:                        prunei(work);
        !           423:                    } else {
        !           424:                        prunep = FALSE; /* sdot is cannonical */
        !           425:                        result->val = work;
        !           426:                    } break;
        !           427:                case DOUB:
        !           428:                    result->val->r *= Ifloat(work);
        !           429:                    break;
        !           430:                default: goto urk;
        !           431:                }
        !           432:                break;
        !           433:            case DOUB:
        !           434:                switch(restype) {
        !           435:                case SDOT:
        !           436:                    if(prunep) {
        !           437:                        lispval handy;
        !           438:                        dummybig.I = 0;
        !           439:                        dummybig.CDR = (lispval) 0;
        !           440:                        handy = adbig((lispval)&dummybig,result->val);
        !           441:                        pruneb(result->val);
        !           442:                        result->val = handy;
        !           443:                    }
        !           444:                    flacc = Ifloat(result->val) * work->r;
        !           445:                    pruneb(result->val);
        !           446:        scrimp:     (result->val = newdoub())->r = flacc;
        !           447:                    restype = DOUB;
        !           448:                    break;
        !           449:                case INT:
        !           450:                    flacc = work->r * lo;
        !           451:                    goto scrimp;
        !           452:                case DOUB:
        !           453:                    result->val->r *= work->r;
        !           454:                    break;
        !           455:                default: goto urk;
        !           456:                }
        !           457:                break;
        !           458:            default:
        !           459:                    errorh1(Vermisc,"Non-number to add",nil,0,FALSE,work);
        !           460:            }
        !           461:        }
        !           462:        work = result->val;
        !           463:        switch(restype){
        !           464:        case DOUB:
        !           465:                break;
        !           466:        case INT:
        !           467:                work = inewint(lo);
        !           468:                break;
        !           469:        case SDOT:
        !           470:                if(prunep) {
        !           471:                    dummybig.I = 0;
        !           472:                    dummybig.CDR = (lispval) 0;
        !           473:                    work = adbig((lispval)&dummybig,work);
        !           474:                }
        !           475:                break;
        !           476:        default:
        !           477:        urk:
        !           478:                error("Internal error in times",FALSE);
        !           479:        }
        !           480:        Restorestack();
        !           481:        return(work);
        !           482: }
        !           483: 
        !           484: lispval
        !           485: Lquo()
        !           486: {
        !           487:        register lispval work;
        !           488:        register struct argent *result, *mynp, *oldnp;
        !           489:        int restype; lispval quotient; double flacc;
        !           490:        struct sdot dummybig;
        !           491:        Savestack(4);
        !           492: 
        !           493:        oldnp = result = np;
        !           494:        protect(nil);
        !           495:        mynp = lbot + 1;
        !           496:        restype = INT;
        !           497:        dummybig.I = 1; dummybig.CDR = (lispval) 0;
        !           498: 
        !           499:        if(oldnp==lbot) goto out;
        !           500:        if(oldnp==mynp) mynp = lbot;
        !           501:        else {
        !           502:            /* examine the first argument and perhaps set restype to the 
        !           503:             * correct type.  If restype (result type) is INT, then the
        !           504:             * fixnum value is stored in lo.  Otherwise, if restype is 
        !           505:             * SDOT or DOUB, then the value is stored in result->val.
        !           506:             */
        !           507:            work = lbot->val;
        !           508:            switch(TYPE(work)) {
        !           509:            case INT:
        !           510:                dummybig.I = work->i;
        !           511:                break;
        !           512:            case SDOT:
        !           513:                /* we want to copy the sdot we are given as an argument since
        !           514:                 * the bignum divide routine divbig expects an argument in
        !           515:                 * canonical form.
        !           516:                 */
        !           517:                dummybig.I = 0;         /* create a zero sdot */
        !           518:                work = adbig(work,(lispval)&dummybig);
        !           519:                restype = TYPE(work);
        !           520:                if(restype==INT) {      /* Either INT or SDOT */
        !           521:                    dummybig.I=work->i; /* has turned into an fixnum */
        !           522:                    prunei(work);       /* return fixnum cell        */
        !           523:                } else {
        !           524:                    result->val = work;
        !           525:                } 
        !           526:                break;
        !           527:            case DOUB:
        !           528:                (result->val = newdoub())->r = work->r;
        !           529:                restype = DOUB;
        !           530:                break;
        !           531:            default:
        !           532:                errorh1(Vermisc,"Internal quotient error #1: ",nil,FALSE,0,
        !           533:                                         work);
        !           534:                goto urk;
        !           535:            }
        !           536:        }
        !           537: 
        !           538:        /* now loop through the rest of the arguments dividing them
        !           539:         * into the running result in result or dummybig.I
        !           540:         */
        !           541:        for(; mynp < oldnp; mynp++)
        !           542:        {
        !           543:            work = mynp->val;
        !           544:            switch(TYPE(work)) {
        !           545:            case INT:
        !           546:                if (work->i==0)
        !           547:                    kill(getpid(),8);
        !           548:                switch(restype) {
        !           549:                case SDOT:      /* there is no fast routine to destructively
        !           550:                                   divide a bignum by an int, so do it the
        !           551:                                   hard way. */
        !           552:                    dummybig.I = work->i;
        !           553:                    divbig(result->val,(lispval)&dummybig,&quotient,(lispval *)0);
        !           554:                    pruneb(result->val);
        !           555:                on1:
        !           556:                    /* check if the result has turned into a fixnum */
        !           557:                    restype = TYPE(quotient);
        !           558:                    if(restype==INT) {          /* Either INT or SDOT */
        !           559:                        dummybig.I=quotient->i; /* has turned into an fixnum */
        !           560:                        prunei(quotient);       /* return fixnum cell        */
        !           561:                    } else
        !           562:                        result->val = quotient;
        !           563:                    break;
        !           564:                case INT:       /* divide int by int */
        !           565:                    dummybig.I /= work->i;
        !           566:                    break;
        !           567:                case DOUB:
        !           568:                    result->val->r /= work->i;
        !           569:                    break;
        !           570:                default:
        !           571:                    errorh1(Vermisc,"Internal quotient error #2: ",nil,FALSE,0,
        !           572:                                         result->val);
        !           573:                    goto urk;
        !           574:                }
        !           575:                break;
        !           576:            case SDOT:
        !           577:                switch(restype) {
        !           578:                case INT:
        !           579:                    /* Although it seems that dividing an int
        !           580:                     * by a bignum can only lead to zero, it is
        !           581:                     * concievable that the bignum is improperly boxed,
        !           582:                     * i.e. actually an int.
        !           583:                     */
        !           584:                    divbig((lispval)&dummybig,work,&quotient,(lispval *)0);
        !           585:                    goto on1;
        !           586: 
        !           587:                case SDOT:
        !           588:                    /* dividing one bignum by another. */
        !           589:                    divbig(result->val,work,&quotient,(lispval *)0);
        !           590:                    pruneb(result->val);
        !           591:                    goto on1;
        !           592:                case DOUB:
        !           593:                    /* dividing a bignum into a flonum.
        !           594:                     */
        !           595:                    result->val->r /= Ifloat(work);
        !           596:                    break;
        !           597:                default:
        !           598:                    errorh1(Vermisc,"Internal quotient error #3: ",nil,FALSE,0,
        !           599:                                         result->val);
        !           600:                    goto urk;
        !           601:                }
        !           602:                break;
        !           603: 
        !           604:            case DOUB:
        !           605:                switch(restype) {
        !           606:                case SDOT: /* Divide bignum by flonum converting to flonum
        !           607:                            * May die due to overflow */
        !           608:                    flacc = Ifloat(result->val) / work->r;
        !           609:                    pruneb(result->val);
        !           610:                scrimp:
        !           611:                    (result->val = newdoub())->r = flacc;
        !           612:                    restype = DOUB;
        !           613:                    break;
        !           614:                case INT: /* dividing a flonum into a fixnum. 
        !           615:                           * The result will be a flonum. */
        !           616: 
        !           617:                    flacc = ((double) dummybig.I) / work->r;
        !           618:                    goto scrimp;
        !           619:                case DOUB: /* dividing a flonum into a flonum, what
        !           620:                            * could be easier?
        !           621:                            */
        !           622:                    result->val->r /= work->r;
        !           623:                    break;
        !           624:                default:
        !           625:                        errorh1(Vermisc,"Internal quotient error #4: ",nil,
        !           626:                                                 FALSE,0, result->val);
        !           627:                        goto urk;
        !           628:                }
        !           629:                    break;
        !           630:            default:
        !           631:                    errorh1(Vermisc,"Non-number to quotient ",nil,FALSE,0,work);
        !           632:            }
        !           633:        }
        !           634: out:
        !           635:        work = result->val;
        !           636:        switch(restype){
        !           637:        case SDOT:
        !           638:        case DOUB:
        !           639:            break;
        !           640:        case INT:
        !           641:            work = inewint(dummybig.I);
        !           642:            break;
        !           643:        default:
        !           644:        urk:
        !           645:            errorh1(Vermisc,"Internal quotient error #5: ",nil,FALSE,0,
        !           646:                                         work);
        !           647:        }
        !           648:        Restorestack();
        !           649:        return(work);
        !           650: }
        !           651: 
        !           652: 
        !           653: lispval Lfp()
        !           654: {
        !           655:        register temp = 0;
        !           656:        register struct argent *argp; 
        !           657: 
        !           658:        for(argp = lbot; argp < np; argp++)
        !           659:            if(TYPE(argp->val) != INT)
        !           660:                errorh1(Vermisc,"+: non fixnum argument ",
        !           661:                                nil,FALSE,0,argp->val);
        !           662:            else
        !           663:                temp += argp->val->i;
        !           664:        return(inewint(temp));
        !           665: }
        !           666: 
        !           667: lispval Lfm()
        !           668: {
        !           669:        register temp;
        !           670:        register struct argent *argp;
        !           671: 
        !           672:        if(lbot==np)return(inewint(0));
        !           673:           if(TYPE(lbot->val) != INT)
        !           674:                errorh1(Vermisc,"-: non fixnum argument ",
        !           675:                                nil,FALSE,0,lbot->val);
        !           676:           else
        !           677:               temp = lbot->val->i;
        !           678:        if(lbot+1==np) return(inewint(-temp));
        !           679:        for(argp = lbot+1; argp < np; argp++)
        !           680:            if(TYPE(argp->val) != INT)
        !           681:                errorh1(Vermisc,"-: non fixnum argument ",
        !           682:                                nil,FALSE,0,argp->val);
        !           683:            else
        !           684:                temp -= argp->val->i;
        !           685:        return(inewint(temp));
        !           686: }
        !           687: 
        !           688: lispval Lft()
        !           689: {
        !           690:        register temp = 1;
        !           691:        register struct argent *argp;
        !           692: 
        !           693:        for(argp = lbot; argp < np; argp++)
        !           694:            if(TYPE(argp->val) != INT)
        !           695:                errorh1(Vermisc,"*: non fixnum argument ",
        !           696:                                nil,FALSE,0,argp->val);
        !           697:            else
        !           698:                temp *= argp->val->i;
        !           699:        return(inewint(temp));
        !           700: }
        !           701: 
        !           702: lispval Lflessp()
        !           703: {
        !           704:        register struct argent *argp = lbot;
        !           705:        register old, new;
        !           706: 
        !           707:        if(np < argp + 2) return(nil);
        !           708:        old = argp->val->i; argp++;
        !           709:        for(; argp < np; argp++)
        !           710:                if(TYPE(argp->val) != INT)
        !           711:                        errorh1(Vermisc,"<: non fixnum argument ",
        !           712:                        nil,FALSE,0,argp->val);
        !           713:                else {
        !           714:                        new = argp->val->i;
        !           715:                        if(!(old < new)) return(nil);
        !           716:                        old = new;
        !           717:                }
        !           718:        return(tatom);
        !           719: }
        !           720: 
        !           721: lispval Lfd()
        !           722: {
        !           723:        register temp = 0;
        !           724:        register struct argent *argp;
        !           725: 
        !           726:        if(lbot==np)return(inewint(1));
        !           727:        if(TYPE(lbot->val) != INT)
        !           728:            errorh1(Vermisc,"/: non fixnum argument ",
        !           729:                        nil,FALSE,0,lbot->val);
        !           730:        temp = lbot->val->i;
        !           731:        if(lbot+1==np) return(inewint(1/temp));
        !           732:        for(argp = lbot+1; argp < np; argp++)
        !           733:            if(TYPE(argp->val) != INT)
        !           734:                errorh1(Vermisc,"/: non fixnum argument ",
        !           735:                        nil,FALSE,0,argp->val);
        !           736:            else
        !           737:                temp /= argp->val->i;
        !           738:        return(inewint(temp));
        !           739: }
        !           740: 
        !           741: lispval Lfadd1()
        !           742: {
        !           743:     chkarg(1,"1+");
        !           744:     if(TYPE(lbot->val) != INT)
        !           745:         errorh1(Vermisc,"1+: non fixnum argument ",
        !           746:                        nil,FALSE,0,lbot->val);
        !           747:     return(inewint(lbot->val->i + 1));
        !           748: }
        !           749: 
        !           750: /*
        !           751:  * Lfexpt      (^ 'x_a 'x_b)
        !           752:  *   exponentiation of fixnums x_a and x_b returning a fixnum
        !           753:  * result
        !           754:  */
        !           755: lispval Lfexpt()
        !           756: {
        !           757:     register int base;
        !           758:     register int exp;
        !           759:     register int res;
        !           760:     
        !           761:     chkarg(2,"^");
        !           762:     if((TYPE(lbot[0].val) != INT ) || (TYPE(lbot[1].val) != INT))
        !           763:       errorh2(Vermisc,"^: non fixnum arguments", nil,0,
        !           764:                lbot[0].val,lbot[1].val);
        !           765:                
        !           766:     base = lbot[0].val->i;
        !           767:     exp = lbot[1].val->i;
        !           768: 
        !           769:     if(base == 0)
        !           770:     {
        !           771:        /* 0^0 == 1,  0 to any other power (even negative powers)
        !           772:         *  is zero (according to Maclisp)
        !           773:         */
        !           774:        if(exp == 0) return(inewint(1));
        !           775:        else return(inewint(0));
        !           776:     }
        !           777:     else if(base == 1)
        !           778:         /*
        !           779:         *  1 to any power is 1
        !           780:         */
        !           781:        return(lbot[0].val);    /* == 1 */
        !           782:     else if(exp == 0)
        !           783:        /*
        !           784:         * anything to the zero power is 1
        !           785:         */
        !           786:        return(inewint(1));
        !           787:     else if(base == -1)
        !           788:     {
        !           789:         /*
        !           790:         * -1 to an even power is 1, to an odd is -1
        !           791:         */
        !           792:        if(exp & 1) return(lbot[0].val);
        !           793:        else return(inewint(1));
        !           794:     }
        !           795:     else if(exp < 0)
        !           796:         /*
        !           797:         * anything not 0,-1,or 1  to a negative power is 0
        !           798:         *
        !           799:         */
        !           800:         return(inewint(0));
        !           801: 
        !           802:     /* compute exponentiation.  This should check for overflows,
        !           803:        I suppose. --jkf
        !           804:      */
        !           805:     res = 1;
        !           806:     while( exp > 0)
        !           807:     {
        !           808:        if( exp & 1 )
        !           809:        {   /* odd, just multiply by one */
        !           810:            res = res * base;
        !           811:            exp--;
        !           812:        }
        !           813:        else {
        !           814:            /* even, square base */
        !           815:            base = base * base;
        !           816:            exp = exp / 2;
        !           817:        }
        !           818:     }
        !           819:     return(inewint(res));
        !           820: }
        !           821:            
        !           822:     
        !           823: 
        !           824: lispval Lfsub1()
        !           825: {
        !           826:     chkarg(1,"1-");
        !           827:     if(TYPE(lbot->val) != INT)
        !           828:         errorh1(Vermisc,"1-: non fixnum argument ",
        !           829:                        nil,FALSE,0,lbot->val);
        !           830:     return(inewint(lbot->val->i - 1));
        !           831: }
        !           832: 
        !           833: lispval
        !           834: Ldbtofl()
        !           835: {
        !           836:        float x;
        !           837:        chkarg(1,"double-to-float");
        !           838: 
        !           839:        if(TYPE(lbot->val) != DOUB)
        !           840:         errorh1(Vermisc,"double-to-float: non flonum argument ",
        !           841:                        nil,FALSE,0,lbot->val);
        !           842:        x = lbot->val->r;
        !           843:        return(inewint(*(long *)&x));
        !           844: }
        !           845: 
        !           846: lispval
        !           847: Lfltodb()
        !           848: {
        !           849:        register lispval handy;
        !           850:        chkarg(1,"float-to-double");
        !           851: 
        !           852:        if(TYPE(lbot->val) != INT)
        !           853:         errorh1(Vermisc,"float-to-double: non fixnum argument ",
        !           854:                        nil,FALSE,0,lbot->val);
        !           855:        handy = newdoub();
        !           856:        handy->r = *(float *)lbot->val;
        !           857:        return(handy);
        !           858: }

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