Annotation of 43BSD/ucb/lisp/franz/lam4.c, revision 1.1.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: }

unix.superglobalmegacorp.com

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