Return to lam5.c CVS log

Up to [CSRG BSD Unix] / 40BSD / cmd / lisp

Annotation of 40BSD/cmd/lisp/lam5.c, revision 1.1

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

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