Return to lam5.c CVS log

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

Annotation of 42BSD/ucb/lisp/franz/lam5.c, revision 1.1

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: lam5.c,v 1.5 83/09/12 14:14:15 sklower Exp $";
        !             4: #endif
        !             5: 
        !             6: /*                                     -[Fri Aug  5 12:49:06 1983 by jkf]-
        !             7:  *     lam5.c                          $Locker:  $
        !             8:  * lambda functions
        !             9:  *
        !            10:  * (c) copyright 1982, Regents of the University of California
        !            11:  */
        !            12: 
        !            13: #include "global.h"
        !            14: #include "chkrtab.h"
        !            15: #include <ctype.h>
        !            16: char *strcpy(), *sprintf();
        !            17: 
        !            18: /*===========================================
        !            19: -
        !            20: -      explode functions: aexplode , aexplodec, aexploden
        !            21: - The following function partially implement the explode functions for atoms.
        !            22: -  The full explode functions are written in lisp and call these for atom args.
        !            23: -
        !            24: -===========================================*/
        !            25: 
        !            26: #include "chars.h"
        !            27: lispval
        !            28: Lexpldx(kind,slashify)
        !            29: int kind, slashify;    /* kind = 0 => explode to characters 
        !            30:                                = 1 => explode to fixnums (aexploden)
        !            31:                           slashify = 0 => do not quote bizarre characters
        !            32:                                    = 1 => quote bizarre characters
        !            33:                        */
        !            34: {
        !            35:        int typ, i;
        !            36:        char ch, *strb, strbb[BUFSIZ], *alloca();  /* temporary string buffer */
        !            37:        register lispval last, handy;
        !            38:        extern int uctolc;
        !            39:        register char *cp;
        !            40: #ifdef SPISFP
        !            41:        Keepxs();
        !            42: #endif
        !            43:        Savestack(3); /* kludge register save mask */
        !            44: 
        !            45:        chkarg(1,"expldx");
        !            46: 
        !            47:        handy = Vreadtable->a.clb;
        !            48:        chkrtab(handy);
        !            49:        handy = lbot->val;
        !            50:        *strbuf = 0;
        !            51:        typ=TYPE(handy);        /* we only work for a few types */
        !            52: 
        !            53: 
        !            54:        /* put the characters to return in the string buffer strb */
        !            55: 
        !            56:        switch(typ) {
        !            57:        case STRNG:
        !            58:                if(slashify && !Xsdc)
        !            59:                    errorh1(Vermisc,"Can't explode without string delimiter",nil
        !            60:                                          ,FALSE,0,handy);
        !            61:                
        !            62:                strb = strbb;
        !            63:                if(slashify) *strb++ = Xsdc;
        !            64:                /* copy string into buffer, escape only occurances of the 
        !            65:                   double quoting character if in slashify mode
        !            66:                */
        !            67:                for(cp = (char *) handy; *cp; cp++)
        !            68:                {
        !            69:                  if(slashify &&
        !            70:                     (*cp == Xsdc || synclass(ctable[*cp])==CESC))
        !            71:                         *strb++ = Xesc;
        !            72:                  *strb++ = *cp;
        !            73:                }
        !            74:                if(slashify) *strb++ = Xsdc;
        !            75:                *strb = NULL_CHAR ;
        !            76:                strb = strbb;
        !            77:                break;
        !            78: 
        !            79:        case ATOM:
        !            80:                strb = handy->a.pname;
        !            81:                if(slashify && (strb[0]==0)) {
        !            82:                        strb = strbb;
        !            83:                        strbb[0] = Xdqc;
        !            84:                        strbb[1] = Xdqc;
        !            85:                        strbb[2] = 0;
        !            86:                } else
        !            87:        /*common:*/
        !            88:                if(slashify != 0)
        !            89:                {
        !            90:                        char *out = strbb;
        !            91:                        unsigned char code;
        !            92: 
        !            93:                        cp = strb;
        !            94:                        strb = strbb;
        !            95:                        code = ctable[(*cp)&0177];
        !            96:                        switch(synclass(code)) {
        !            97:                        case CNUM:
        !            98:                                *out++ = Xesc;
        !            99:                                break;
        !           100:                        case CCHAR:
        !           101:                                if(uctolc && isupper((*cp)&0177)) {
        !           102:                                    *out++ = Xesc;
        !           103:                                }
        !           104:                                break;
        !           105:                        default:
        !           106:                            switch(code&QUTMASK) {
        !           107:                            case QWNUNIQ:
        !           108:                                    if (cp[1]==0) *out++ = Xesc;
        !           109:                                    break;
        !           110:                            case QALWAYS:
        !           111:                            case QWNFRST:
        !           112:                                    *out++ = Xesc;
        !           113:                            }
        !           114:                        }
        !           115:                        *out++ = *cp++;
        !           116:                        for(; *cp; cp++)
        !           117:                        {
        !           118:                                if(((ctable[*cp]&QUTMASK)==QALWAYS) ||
        !           119:                                   (uctolc && isupper(*cp)))
        !           120:                                        *out++ = Xesc;
        !           121:                                *out++ = *cp;
        !           122:                        }
        !           123:                        *out = 0;
        !           124:                }
        !           125:                break;
        !           126:                                
        !           127:        case INT:
        !           128:                strb = strbb;
        !           129:                sprintf(strb, "%d", lbot->val->i);
        !           130:                break;
        !           131:        case DOUB:
        !           132:                strb = strbb;
        !           133:                lfltpr(strb, lbot->val->r);
        !           134:                break;
        !           135:        case SDOT:
        !           136:        {
        !           137:                struct _iobuf _strbuf;
        !           138:                int count;
        !           139:                for((handy = lbot->val), count = 12;
        !           140:                    handy->s.CDR!=(lispval) 0;
        !           141:                    (handy = handy->s.CDR), count += 12);
        !           142:                strb = alloca(count);
        !           143: 
        !           144:                _strbuf._flag = _IOWRT+_IOSTRG;
        !           145:                _strbuf._ptr = strb;
        !           146:                _strbuf._cnt = count;
        !           147:                pbignum(lbot->val,&_strbuf);
        !           148:                putc(0,&_strbuf);
        !           149:                break;
        !           150:        }
        !           151:        default:
        !           152:                        errorh1(Vermisc,"EXPLODE ARG MUST BE STRING, SYMBOL, FIXNUM, OR FLONUM",nil,FALSE,0,handy);
        !           153:                        Restorestack();
        !           154:                        Freexs();
        !           155:                        return(nil);
        !           156:                }
        !           157: 
        !           158: 
        !           159:        if( strb[0] != NULL_CHAR )      /* if there is something to do */
        !           160:        {
        !           161:            lispval prev;
        !           162: 
        !           163:            protect(handy = last = newdot()); 
        !           164:            strbuf[1] = NULL_CHAR ;     /* set up for getatom */
        !           165:            atmlen = 2;
        !           166: 
        !           167:            for(i=0; ch = strb[i++]; ) {
        !           168:                switch(kind) {
        !           169: 
        !           170:                  case 0: strbuf[0] = hash = ch;   /* character explode */
        !           171:                          last->d.car = (lispval) getatom(TRUE); /* look in oblist */
        !           172:                          break;
        !           173: 
        !           174:                  case 1: 
        !           175:                          last->d.car = inewint(ch);
        !           176:                          break;
        !           177:                }
        !           178: 
        !           179:                /* advance pointers */
        !           180:                prev = last;
        !           181:                last->d.cdr = newdot();
        !           182:                last = last->d.cdr;
        !           183:            }
        !           184: 
        !           185:            /* end list with a nil pointer */
        !           186:            prev->d.cdr = nil;
        !           187:            Freexs();
        !           188:            Restorestack();
        !           189:            return(handy);
        !           190:        }
        !           191:        Freexs();
        !           192:        Restorestack();
        !           193:        return(nil);    /* return nil if no characters */
        !           194: }
        !           195: 
        !           196: /*===========================
        !           197: -
        !           198: - (aexplodec 'atm) returns (a t m)
        !           199: - (aexplodec 234) returns (\2 \3 \4)
        !           200: -===========================*/
        !           201: 
        !           202: lispval
        !           203: Lexpldc()
        !           204: { return(Lexpldx(0,0)); }
        !           205: 
        !           206: 
        !           207: /*===========================
        !           208: -
        !           209: - (aexploden 'abc) returns (65 66 67)
        !           210: - (aexploden 123)  returns (49 50 51)
        !           211: -=============================*/
        !           212: 
        !           213: 
        !           214: lispval
        !           215: Lexpldn()
        !           216: { return(Lexpldx(1,0)); }
        !           217: 
        !           218: /*===========================
        !           219: -
        !           220: - (aexplode "123")  returns (\\ \1 \2 \3);
        !           221: - (aexplode 123)  returns (\1 \2 \3);
        !           222: -=============================*/
        !           223: 
        !           224: lispval
        !           225: Lexplda()
        !           226: { return(Lexpldx(0,1)); }
        !           227: 
        !           228: /*
        !           229:  * (argv) returns how many arguments where on the command line which invoked
        !           230:  * lisp; (argv i) returns the i'th argument made into an atom;
        !           231:  */
        !           232: 
        !           233: lispval
        !           234: Largv()
        !           235: {
        !           236:        register lispval handy;
        !           237:        extern int Xargc;
        !           238:        extern char **Xargv;
        !           239: 
        !           240:        if(lbot-np==0)handy = nil;
        !           241:        else handy = lbot->val;
        !           242:        
        !           243:        if(TYPE(handy)==INT && handy->i>=0 && handy->i<Xargc) {
        !           244:                strcpy(strbuf,Xargv[handy->i]);
        !           245:                return(getatom(FALSE));
        !           246:        } else { 
        !           247:                return(inewint(Xargc));
        !           248:        }
        !           249: }
        !           250: /*
        !           251:  * (chdir <atom>) executes a chdir command
        !           252:  * if successful, return t otherwise returns nil
        !           253:  */
        !           254: lispval Lchdir(){
        !           255:        register char *filenm;
        !           256: 
        !           257:        chkarg(1,"chdir");
        !           258:        filenm = (char *) verify(lbot->val,"chdir - non symbol or string arg");
        !           259:        if(chdir(filenm)>=0)
        !           260:                return(tatom);
        !           261:        else
        !           262:                return(nil);
        !           263: }
        !           264: 
        !           265: /* ==========================================================
        !           266: -
        !           267: -      ascii   - convert from number to ascii character
        !           268: -
        !           269: - form:(ascii number)
        !           270: -
        !           271: -      the number is checked so that it is in the range 0-255
        !           272: - then it is made a character and returned
        !           273: - =========================================================*/
        !           274: 
        !           275: lispval
        !           276: Lascii() 
        !           277: {
        !           278:        register lispval handy;
        !           279: 
        !           280:        handy = lbot->val;              /* get argument */
        !           281: 
        !           282:        if(TYPE(handy) != INT)          /* insure that it is an integer */
        !           283:        {       error("argument not an integer",FALSE);
        !           284:                return(nil);
        !           285:        }
        !           286: 
        !           287:        if(handy->i < 0 || handy->i > 0377)     /* insure that it is in range*/
        !           288:        {       error("argument is out of ascii range",FALSE);
        !           289:                return(nil);
        !           290:        }
        !           291: 
        !           292:        strbuf[0] = handy->i ;  /* ok value, make into a char */
        !           293:        strbuf[1] = NULL_CHAR;
        !           294: 
        !           295:        /* lookup and possibly intern the atom given in strbuf */
        !           296: 
        !           297:        return( (lispval) getatom(TRUE) );
        !           298: }
        !           299: 
        !           300: /*
        !           301:  *  boole - maclisp bitwise boolean function
        !           302:  *  (boole k x y) where k determines which of 16 possible bitwise 
        !           303:  *  truth tables may be applied.  Common values are 1 (and) 6 (xor) 7 (or)
        !           304:  *  the result is mapped over each pair of bits on input
        !           305:  */
        !           306: lispval
        !           307: Lboole(){
        !           308:        register x, y;
        !           309:        register struct argent *mynp;
        !           310:        int k;
        !           311: 
        !           312:        if(np - lbot < 3)
        !           313:                error("Boole demands at least 3 args",FALSE);
        !           314:        mynp = lbot+AD;
        !           315:        k = mynp->val->i & 15;
        !           316:        x = (mynp+1)->val->i;
        !           317:        for(mynp += 2; mynp < np; mynp++) {
        !           318:                y = mynp->val->i;
        !           319:                switch(k) {
        !           320: 
        !           321:                case 0: x = 0;
        !           322:                        break;
        !           323:                case 1: x = x & y;
        !           324:                        break;
        !           325:                case 2: x = y & ~x;
        !           326:                        break;
        !           327:                case 3: x = y;
        !           328:                        break;
        !           329:                case 4: x = x & ~y;
        !           330:                        break;
        !           331:                /* case 5:      x = x; break; */
        !           332:                case 6: x = x ^ y;
        !           333:                        break;
        !           334:                case 7: x = x | y;
        !           335:                        break;
        !           336:                case 8: x = ~(x | y);
        !           337:                        break;
        !           338:                case 9: x = ~(x ^ y);
        !           339:                        break;
        !           340:                case 10: x = ~x;
        !           341:                        break;
        !           342:                case 11: x = ~x | y;
        !           343:                        break;
        !           344:                case 12: x = ~y;
        !           345:                        break;
        !           346:                case 13: x = x | ~y;
        !           347:                        break;
        !           348:                case 14: x = ~x | ~y;
        !           349:                        break;
        !           350:                case 15: x = -1;
        !           351:                }
        !           352:        }
        !           353:        return(inewint(x));
        !           354: }
        !           355: lispval
        !           356: Lfact()
        !           357: {
        !           358:        register lispval result, handy;
        !           359:        register itemp;
        !           360:        Savestack(3); /* fixup entry mask */
        !           361: 
        !           362:        result = lbot->val;
        !           363:        if(TYPE(result)!=INT) error("Factorial of Non-fixnum.  If you want me\
        !           364: to calculate fact of > 2^30 We will be here till doomsday!.",FALSE);
        !           365:        itemp = result->i;
        !           366:        protect(result = newsdot());
        !           367:        result->s.CDR=(lispval)0;
        !           368:        result->i = 1;
        !           369:        for(; itemp > 1; itemp--)
        !           370:                dmlad(result,(long)itemp,0L);
        !           371:        if(result->s.CDR) 
        !           372:        {
        !           373:            Restorestack();
        !           374:            return(result);
        !           375:        }
        !           376:        handy = inewint(result->s.I);
        !           377:        pruneb(result);
        !           378:        Restorestack();
        !           379:        return(handy);
        !           380: }
        !           381: /*
        !           382:  * fix -- maclisp floating to fixnum conversion
        !           383:  * for the moment, mereley convert floats to ints.
        !           384:  * eventual convert to bignum if too big to fit.
        !           385:  */
        !           386:  lispval Lfix() 
        !           387:  {
        !           388:        register lispval handy;
        !           389:        double floor();
        !           390: 
        !           391:        chkarg(1,"fix");
        !           392:        handy = lbot->val;
        !           393:        switch(TYPE(handy)) {
        !           394:        default:
        !           395:                error("innaproriate arg to fix.",FALSE);
        !           396:        case INT:
        !           397:        case SDOT:
        !           398:                return(handy);
        !           399:        case DOUB:
        !           400:                return(inewint((int)floor(handy->r)));
        !           401:        }
        !           402: }
        !           403: /*
        !           404:  * (frexp <real no>)
        !           405:  * returns a dotted pair (<exponent>. <bignum>)
        !           406:  * such that bignum is 56 bits long, and if you think of the binary
        !           407:  * point occuring after the high order bit, <real no> = 2^<exp> * <bignum>
        !           408:  *
        !           409:  * myfrexp is an assembly language routine found in bigmath.s to do exactly
        !           410:  * what is necessary to accomplish this.
        !           411:  * this routine is horribly vax specific.
        !           412:  *
        !           413:  * Lfix should probably be rewritten to take advantage of myfrexp
        !           414:  */
        !           415: lispval
        !           416: Lfrexp()
        !           417: {
        !           418:        register lispval handy, result;
        !           419:        int exp, hi, lo;
        !           420: 
        !           421:        Savestack(2);
        !           422:        chkarg(1,"frexp");
        !           423: 
        !           424:        myfrexp(lbot->val->r, &exp, &hi, &lo);
        !           425:        if(lo < 0) {
        !           426:                /* normalize for bignum */
        !           427:                lo &= ~ 0xC0000000;
        !           428:                hi += 1;
        !           429:        }
        !           430:        result = handy = newdot(); 
        !           431:        protect(handy);
        !           432:        handy->d.car = inewint(exp);
        !           433:        if(hi==0&&lo==0) {
        !           434:                handy->d.cdr = inewint(0);
        !           435:        } else {
        !           436:                handy = handy->d.cdr = newsdot();
        !           437:                handy->s.I = lo;
        !           438:                handy = handy->s.CDR = newdot();
        !           439:                handy->s.I = hi;
        !           440:                handy->s.CDR = 0;
        !           441:        }
        !           442:        np--;
        !           443:        Restorestack();
        !           444:        return(result);
        !           445: }
        !           446: 
        !           447: #define SIGFPE 8
        !           448: #define B 1073741824.0
        !           449: static double table[] = { 1.0, B, B*B, B*B*B, B*B*B*B, 0.0};
        !           450: 
        !           451: lispval
        !           452: Lfloat()
        !           453: {
        !           454:        register lispval handy,result;
        !           455:        register double sum = 0;
        !           456:        register int count;
        !           457:        chkarg(1,"float");
        !           458:        handy = lbot->val;
        !           459:        switch(TYPE(handy))
        !           460:        {
        !           461:          case DOUB: return(handy);
        !           462: 
        !           463: 
        !           464:          case INT:  result = newdoub();
        !           465:                     result->r = (double) handy->i;
        !           466:                     return(result);
        !           467:          case SDOT: 
        !           468:          {
        !           469:                for(handy = lbot->val, count = 0;
        !           470:                    count < 5;
        !           471:                    count++, handy = handy->s.CDR) {
        !           472:                        sum += handy->s.I * table[count];
        !           473:                        if(handy->s.CDR==(lispval)0) goto done;
        !           474:                }
        !           475:                kill(getpid(),SIGFPE);
        !           476:        done:
        !           477:                result = newdoub();
        !           478:                result->r = sum;
        !           479:                return(result);
        !           480:        }
        !           481:          default: errorh1(Vermisc,"Bad argument to float",nil,FALSE,0,handy);
        !           482:          /* NOTREACHED */
        !           483:        }
        !           484: }
        !           485: double
        !           486: Ifloat(handy)
        !           487: register lispval handy;
        !           488: {
        !           489:        register double sum = 0.0; register int count=0;
        !           490:        for(; count < 5; count++, handy = handy->s.CDR) {
        !           491:                sum += handy->s.I * table[count];
        !           492:                if(handy->s.CDR==(lispval)0) goto done;
        !           493:        }
        !           494:        kill(getpid(),SIGFPE);
        !           495:        done:
        !           496:        return(sum);
        !           497: }
        !           498: 
        !           499: /* Lbreak ***************************************************************/
        !           500: /* If first argument is not nil, this is evaluated and printed.  Then  */
        !           501: /* error is called with the "breaking" message.                                */
        !           502: lispval Lbreak() {
        !           503: 
        !           504:        if (np > lbot) {
        !           505:                printr(lbot->val,poport);
        !           506:                dmpport(poport);
        !           507:        }
        !           508:        return(error("",TRUE));
        !           509: }
        !           510: 
        !           511: 
        !           512: lispval
        !           513: LDivide() {
        !           514:        register lispval result, work;
        !           515:        register struct argent *mynp;
        !           516:        lispval quo, rem, arg1, arg2; struct sdot dummy, dum2;
        !           517:        Savestack(3);
        !           518: 
        !           519:        chkarg(2,"Divide");
        !           520:        mynp = lbot;
        !           521:        work = mynp++->val;
        !           522:        switch(TYPE(work)) {
        !           523:        case INT:
        !           524:                arg1 = (lispval) &dummy;
        !           525:                dummy.I = work->i;
        !           526:                dummy.CDR = (lispval) 0;
        !           527:                break;
        !           528:        case SDOT:
        !           529:                arg1 = work;
        !           530:                break;
        !           531:        urk:
        !           532:        default:
        !           533:                error("First arg to divide neither a bignum nor int.",FALSE);
        !           534:        }
        !           535:        work = mynp->val;
        !           536:        switch(TYPE(work)) {
        !           537:        case INT:
        !           538:                arg2 = (lispval) &dum2;
        !           539:                dum2.I = work->i;
        !           540:                dum2.CDR = (lispval) 0;
        !           541:                break;
        !           542:        case SDOT:
        !           543:                arg2 = work;
        !           544:                break;
        !           545:        default:
        !           546:                goto urk;
        !           547:        }
        !           548:        divbig(arg1,arg2, &quo, &rem);
        !           549:        protect(quo);
        !           550:        if(rem==((lispval)&dummy))
        !           551:                rem = inewint(dummy.I);
        !           552:        protect(rem);
        !           553:        protect(result = work = newdot());
        !           554:        work->d.car = quo;
        !           555:        (work->d.cdr = newdot())->d.car = rem;
        !           556:        Restorestack();
        !           557:        return(result);
        !           558: }
        !           559: 
        !           560: lispval LEmuldiv(){
        !           561:        register struct argent * mynp = lbot+AD;
        !           562:        register lispval work, result;
        !           563:        int quo, rem;
        !           564:        Savestack(3); /* fix register mask */
        !           565: 
        !           566:        /* (Emuldiv mul1 mult2 add quo) => 
        !           567:                temp = mul1 + mul2 + sext(add);
        !           568:                result = (list temp/quo temp%quo);
        !           569:                to mix C and lisp a bit */
        !           570: 
        !           571:        Imuldiv(mynp[0].val->i, mynp[1].val->i, mynp[2].val->i,
        !           572:                mynp[3].val->i, &quo, &rem);
        !           573:        protect(result=newdot());
        !           574:        (result->d.car=inewint(quo));
        !           575:        work = result->d.cdr = newdot();
        !           576:        (work->d.car=inewint(rem));
        !           577:        Restorestack();
        !           578:        return(result);
        !           579: }

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