Return to lam3.c CVS log

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

Annotation of 3BSD/cmd/lisp/lam3.c, revision 1.1

1.1     ! root        1: # include "global.h"
        !             2: lispval
        !             3: Lalfalp()
        !             4: {
        !             5:        register lispval first, second;
        !             6:        register struct argent *inp;
        !             7:        snpand(3); /* clobber save mask */
        !             8: 
        !             9:        chkarg(2);
        !            10:        inp = lbot;
        !            11:        first = (inp)->val;
        !            12:        second = (inp+1)->val;
        !            13:        if( (TYPE(first))!=ATOM || (TYPE(second))!=ATOM)
        !            14:                error("alphalessp expects atoms");
        !            15:        if(strcmp(first->pname,second->pname) <= 0)
        !            16:                return(tatom);
        !            17:        else
        !            18:                return(nil);
        !            19: }
        !            20: 
        !            21: lispval
        !            22: Lncons()
        !            23: {
        !            24:        register lispval handy;
        !            25:        snpand(1); /* clobber save mask */
        !            26: 
        !            27:        chkarg(1);
        !            28:        handy = newdot();
        !            29:        handy -> cdr = nil;
        !            30:        handy -> car = lbot->val;
        !            31:        return(handy);
        !            32: }
        !            33: lispval
        !            34: Lzerop()
        !            35: {
        !            36:        register lispval handy;
        !            37:        snpand(1); /* clobber save mask */
        !            38: 
        !            39:        chkarg(1);
        !            40:        handy = lbot->val;
        !            41:        switch(TYPE(handy)) {
        !            42:        case INT:
        !            43:                return(handy->i==0?tatom:nil);
        !            44:        case DOUB:
        !            45:                return(handy->r==0.0?tatom:nil);
        !            46:        }
        !            47:        return(nil);
        !            48: }
        !            49: lispval
        !            50: Lonep()
        !            51: {
        !            52:        register lispval handy; lispval Ladd();
        !            53:        snpand(1); /* clobber save mask */
        !            54: 
        !            55:        chkarg(1);
        !            56:        handy = lbot->val;
        !            57:        switch(TYPE(handy)) {
        !            58:        case INT:
        !            59:                return(handy->i==1?tatom:nil);
        !            60:        case DOUB:
        !            61:                return(handy->r==1.0?tatom:nil);
        !            62:        case SDOT:
        !            63:                protect(inewint(0));
        !            64:                handy = Ladd();
        !            65:                if(TYPE(handy)!=INT || handy->i !=1)
        !            66:                        return(nil);
        !            67:                else
        !            68:                        return(tatom);
        !            69:        }
        !            70:        return(nil);
        !            71: }
        !            72: 
        !            73: lispval
        !            74: cmpx(lssp)
        !            75: {
        !            76:        register struct argent *argp;
        !            77:        register struct argent *outarg;
        !            78:        register struct argent *handy;
        !            79:        register count;
        !            80:        register struct argent *lbot;
        !            81:        register struct argent *np;
        !            82:        struct argent *onp = np;
        !            83: 
        !            84: 
        !            85:        argp = lbot + 1;
        !            86:        outarg = np;
        !            87:        while(argp < onp) {
        !            88: 
        !            89:                np = outarg + 2;
        !            90:                lbot = outarg;
        !            91:                if(lssp)
        !            92:                        *outarg = argp[-1], outarg[1]  = *argp++;
        !            93:                else
        !            94:                        outarg[1]  = argp[-1], *outarg = *argp++;
        !            95:                lbot->val = Lsub();
        !            96:                np = lbot + 1;
        !            97:                if(Lnegp()==nil) return(nil);
        !            98:        }
        !            99:        return(tatom);
        !           100: }
        !           101: 
        !           102: lispval
        !           103: Lgreaterp()
        !           104: {
        !           105:        return(cmpx(FALSE));
        !           106: }
        !           107: 
        !           108: lispval
        !           109: Llessp()
        !           110: {
        !           111:        return(cmpx(TRUE));
        !           112: }
        !           113: 
        !           114: lispval
        !           115: Ldiff()
        !           116: {
        !           117:        register lispval arg1,arg2; register handy = 0;
        !           118:        snpand(3); /* clobber save mask */
        !           119: 
        !           120: 
        !           121:        chkarg(2);
        !           122:        arg1 = lbot->val;
        !           123:        arg2 = (lbot+1)->val;
        !           124:        if(TYPE(arg1)==INT && TYPE(arg2)==INT) {
        !           125:                handy=arg1->i - arg2->i;
        !           126:        }
        !           127:        else error("non-numeric argument",FALSE);
        !           128:        return(inewint(handy));
        !           129: }
        !           130: 
        !           131: lispval
        !           132: Lmod()
        !           133: {
        !           134:        register lispval arg1,arg2; lispval  handy;
        !           135:        struct sdot fake1, fake2;
        !           136:        fake2.CDR = 0;
        !           137:        fake1.CDR = 0;
        !           138:        snpand(2); /* clobber save mask */
        !           139: 
        !           140:        chkarg(2);
        !           141:        handy = arg1 = lbot->val;
        !           142:        arg2 = (lbot+1)->val;
        !           143:        switch(TYPE(arg1)) {
        !           144:        case SDOT:
        !           145:                break;
        !           146:        case INT:
        !           147:                fake1.I = arg1->i;
        !           148:                arg1 =(lispval) &fake1;
        !           149:                break;
        !           150:        default:
        !           151:                error("non-numeric argument",FALSE);
        !           152:        }
        !           153:        switch(TYPE(arg2)) {
        !           154:        case SDOT:
        !           155:                break;
        !           156:        case INT:
        !           157:                fake2.I = arg2->i;
        !           158:                arg2 =(lispval) &fake2;
        !           159:                break;
        !           160:        default:
        !           161:                error("non-numeric argument",FALSE);
        !           162:        }
        !           163:                if(Lzerop()!=nil) return(handy);
        !           164:                divbig(arg1,arg2,0,&handy);
        !           165:                if(handy==((lispval)&fake1))
        !           166:                        handy = inewint(fake1.I);
        !           167:                if(handy==((lispval)&fake2))
        !           168:                        handy = inewint(fake2.I);
        !           169:                return(handy);
        !           170: 
        !           171: }
        !           172: 
        !           173: 
        !           174: lispval
        !           175: Ladd1()
        !           176: {
        !           177:        register lispval handy;
        !           178:        lispval Ladd();
        !           179:        snpand(1); /* fixup entry mask */
        !           180: 
        !           181:        handy = rdrint;
        !           182:        handy->i = 1;
        !           183:        protect(handy);
        !           184:        return(Ladd());
        !           185: 
        !           186: }
        !           187: 
        !           188: lispval
        !           189: Lsub1()
        !           190: {
        !           191:        register lispval handy;
        !           192:        lispval Ladd();
        !           193:        snpand(1); /* fixup entry mask */
        !           194: 
        !           195:        handy = rdrint;
        !           196:        handy->i = - 1;
        !           197:        protect(handy);
        !           198:        return(Ladd());
        !           199: }
        !           200: 
        !           201: lispval
        !           202: Lminus()
        !           203: {
        !           204:        register lispval arg1, handy;
        !           205:        register temp;
        !           206:        lispval subbig();
        !           207:        snpand(3); /* clobber save mask */
        !           208: 
        !           209:        chkarg(1);
        !           210:        arg1 = lbot->val;
        !           211:        handy = nil;
        !           212:        switch(TYPE(arg1)) {
        !           213:        case INT:
        !           214:                handy= inewint(0 - arg1->i);
        !           215:                break;
        !           216:        case DOUB:
        !           217:                handy = newdoub();
        !           218:                handy->r = -arg1->r;
        !           219:                break;
        !           220:        case SDOT:
        !           221:                handy = rdrsdot;
        !           222:                handy->I = 0;
        !           223:                handy->CDR = (lispval) 0;
        !           224:                handy = subbig(handy,arg1);
        !           225:                break;
        !           226: 
        !           227:        default:
        !           228:                error("non-numeric argument",FALSE);
        !           229:        }
        !           230:        return(handy);
        !           231: }
        !           232: 
        !           233: lispval
        !           234: Lnegp()
        !           235: {
        !           236:        register lispval handy = np[-1].val, work;
        !           237:        register flag = 0;
        !           238:        snpand(3); /* clobber save mask */
        !           239: 
        !           240: loop:
        !           241:        switch(TYPE(handy)) {
        !           242:        case INT:
        !           243:                if(handy->i < 0) flag = TRUE;
        !           244:                break;
        !           245:        case DOUB:
        !           246:                if(handy->r < 0) flag = TRUE;
        !           247:                break;
        !           248:        case SDOT:
        !           249:                for(work = handy; work->CDR!=(lispval) 0; work = work->CDR);
        !           250:                if(work->I < 0) flag = TRUE;
        !           251:                break;
        !           252:        default:
        !           253:                handy = errorh(Vermisc,
        !           254:                                  "minusp: Non-(int,real,bignum) arg: ",
        !           255:                                  nil,
        !           256:                                  TRUE,
        !           257:                                  0,
        !           258:                                  handy);
        !           259:                goto loop;
        !           260:        }
        !           261:        if(flag) return(tatom);
        !           262:        return(nil);
        !           263: }
        !           264: 
        !           265: lispval
        !           266: Labsval()
        !           267: {
        !           268:        register lispval arg1, handy;
        !           269:        register temp;
        !           270:        snpand(3); /* clobber save mask */
        !           271: 
        !           272:        chkarg(1);
        !           273:        arg1 = lbot->val;
        !           274:        if(Lnegp()!=nil) return(Lminus());
        !           275: 
        !           276:        return(arg1);
        !           277: }
        !           278: 
        !           279: #include "frame.h"
        !           280: /* new version of showstack,
        !           281:        We will set fp to point where the register fp points.
        !           282:        Then fp+2 = saved ap
        !           283:             fp+4 = saved pc
        !           284:             fp+3 = saved fp
        !           285:             ap+1 = first arg
        !           286:        If we find that the saved pc is somewhere in the routine eval,
        !           287:    then we print the first argument to that eval frame. This is done
        !           288:    by looking one beyond the saved ap.
        !           289: */
        !           290: lispval
        !           291: Lshostk()
        !           292: {      lispval isho();
        !           293:        return(isho(1));
        !           294: }
        !           295: static lispval
        !           296: isho(f)
        !           297: int f;
        !           298: {
        !           299:        register struct frame *myfp; register lispval handy;
        !           300:        int **fp;       /* this must be the first local */
        !           301:        int virgin=1;
        !           302:        lispval _qfuncl(),tynames();    /* locations in qfuncl */
        !           303: 
        !           304:        if(f==1)
        !           305:                printf("Forms in evaluation:\n");
        !           306:        else
        !           307:                printf("Backtrace:\n\n");
        !           308: 
        !           309:        myfp = (struct frame *) (&fp +1);       /* point to current frame */
        !           310: 
        !           311:        while(TRUE)
        !           312:        {
        !           313:            if( (myfp->pc > eval  &&            /* interpreted code */
        !           314:                 myfp->pc < popnames)
        !           315:                ||
        !           316:                (myfp->pc > _qfuncl &&          /* compiled code */
        !           317:                 myfp->pc < tynames)  )
        !           318:            {
        !           319:                handy = (myfp->ap[1]);
        !           320:                if(f==1)
        !           321:                        printr(handy,stdout), putchar('\n');
        !           322:                else {
        !           323:                        if(virgin)
        !           324:                                virgin = 0;
        !           325:                        else
        !           326:                                printf(" -- ");
        !           327:                        printr((TYPE(handy)==DTPR)?handy->car:handy,stdout);
        !           328:                }
        !           329: 
        !           330:            }
        !           331: 
        !           332:            if(myfp > myfp->fp) break;  /* end of frames */
        !           333:            else myfp = myfp->fp;
        !           334:        }
        !           335:        putchar('\n');
        !           336:        return(nil);
        !           337: }
        !           338: lispval
        !           339: Lbaktrace()
        !           340: {
        !           341:        isho(0);
        !           342: }
        !           343: /* ===========================================================
        !           344: -
        !           345: **** baktrace ****     (moved back by kls)
        !           346: -
        !           347: - baktrace will print the names of all functions being evaluated
        !           348: - from the current one (baktrace) down to the first one.
        !           349: - currently it only prints the function name.  Planned is a
        !           350: - list of local variables in all stack frames.
        !           351: - written by jkf.
        !           352: -
        !           353: -============================================================*/
        !           354: 
        !           355: /*=============================================================
        !           356: -
        !           357: -***  oblist ****
        !           358: -
        !           359: - oblist returns a list of all symbols in the oblist
        !           360: -
        !           361: - written by jkf.
        !           362: ============================================================*/
        !           363: 
        !           364: lispval
        !           365: Loblist()
        !           366: {
        !           367:     int indx;
        !           368:     lispval headp, tailp ;
        !           369:     struct atom *symb ;
        !           370: 
        !           371:     headp = tailp = newdot(); /* allocate first DTPR */
        !           372:     protect(headp);            /*protect the list from garbage collection*/
        !           373:                                /*line added by kls                       */
        !           374: 
        !           375:     for( indx=0 ; indx <= HASHTOP-1 ; indx++ ) /* though oblist */
        !           376:     {
        !           377:        for( symb = hasht[indx] ;
        !           378:             symb != (struct atom *) CNIL ;
        !           379:             symb = symb-> hshlnk)
        !           380:        {
        !           381:            tailp->car = (lispval) symb  ; /* remember this atom */
        !           382:            tailp = tailp->cdr = newdot() ; /* link to next DTPR */
        !           383:        }
        !           384:     }
        !           385: 
        !           386:     tailp->cdr = nil ; /* close the list unfortunately throwing away
        !           387:                          the last DTPR
        !           388:                          */
        !           389:     return(headp);
        !           390: }
        !           391: 
        !           392: /*
        !           393:  * Maclisp setsyntax function:
        !           394:  *    (setsyntax c s x)
        !           395:  * c represents character either by fixnum or atom
        !           396:  * s is the atom "macro" or the atom "splicing" (in which case x is the
        !           397:  * macro to be invoked); or nil (meaning don't change syntax of c); or
        !           398:  * (well thats enough for now) if s is a fixnum then we modify the bits
        !           399:  * for c in the readtable.
        !           400:  */
        !           401: #define VMAC   0316
        !           402: #define VSPL   0315
        !           403: #define VDQ     0212
        !           404: #define VESC   0217
        !           405: #include "chkrtab.h"
        !           406: 
        !           407: lispval
        !           408: Lsetsyn()
        !           409: {
        !           410:        register lispval s, c;
        !           411:        register struct argent *mynp;
        !           412:        register index;
        !           413:        register struct argent *lbot, *np;
        !           414:        lispval x;
        !           415:        extern char *ctable;
        !           416:        int value;
        !           417: 
        !           418:        chkarg(3);
        !           419:        s = Vreadtable->clb;
        !           420:        chkrtab(s);
        !           421:        mynp = lbot;
        !           422:        c = (mynp++)->val;
        !           423:        s = (mynp++)->val;
        !           424:        x = (mynp++)->val;
        !           425: 
        !           426:        switch(TYPE(c)) {
        !           427:        default:
        !           428:                error("neither fixnum nor atom as char to setsyntax",FALSE);
        !           429: 
        !           430:        case ATOM:
        !           431:                index = *(c->pname);
        !           432:                if((c->pname)[1])error("Only 1 char atoms to setsyntax",FALSE);
        !           433:                break;
        !           434: 
        !           435:        case INT:
        !           436:                index = c->i;
        !           437:        }
        !           438:        switch(TYPE(s)) {
        !           439:        case INT:
        !           440:                if(s->i == VESC) Xesc = (char) index;
        !           441:                else if(s->i == VDQ) Xdqc = (char) index;
        !           442: 
        !           443:                if(ctable[index] == VESC   /* if we changed the current esc */
        !           444:                  && s->i != VESC          /* to something else, pick current */
        !           445:                  && Xesc == (char) index) {
        !           446:                        ctable[index] = s->i;
        !           447:                        rpltab(VESC,&Xesc);
        !           448:                }
        !           449:                else if(ctable[index] == VDQ   /*  likewise for double quote */
        !           450:                       && s->i != VDQ
        !           451:                       && Xdqc == (char) index)  {
        !           452:                        ctable[index] = s->i;
        !           453:                        rpltab(VDQ,&Xdqc);
        !           454:                }
        !           455:                else ctable[index] = s->i;
        !           456: 
        !           457:                break;
        !           458:        case ATOM:
        !           459:                if(s==splice)
        !           460:                        ctable[index] = VSPL;
        !           461:                else if(s==macro)
        !           462:                        ctable[index] = VMAC;
        !           463:                if(TYPE(c)!=ATOM) {
        !           464:                        strbuf[0] = index;
        !           465:                        strbuf[1] = 0;
        !           466:                        c = (getatom());
        !           467:                }
        !           468:                Iputprop(c,x,macro);
        !           469:        }
        !           470:        return(tatom);
        !           471: }
        !           472: 
        !           473: 
        !           474: 
        !           475: /* this aux function is used by setsyntax to determine the new current
        !           476:    escape or double quote character.  It scans the character table for
        !           477:    the first character with the given class (either VESC or VDQ) and
        !           478:    puts that character in Xesc or Xdqc (whichever is pointed to by
        !           479:    addr).
        !           480: */
        !           481: rpltab(cclass,addr)
        !           482: char cclass;
        !           483: char *addr;
        !           484: {
        !           485:        register int i;
        !           486:        extern char *ctable;
        !           487:        for(i=0; i<=127 && ctable[i] != cclass; i++);
        !           488:        if(i<=127) *addr = (char) i;
        !           489:        else *addr = '\0';
        !           490: }
        !           491: 
        !           492: 
        !           493: 
        !           494: lispval
        !           495: Lzapline()
        !           496: {
        !           497:        register FILE *port;
        !           498:        extern FILE * rdrport;
        !           499: 
        !           500:        port = rdrport;
        !           501:        while (!feof(port) && (getc(port)!='\n') );
        !           502:        return(nil);
        !           503: }
        !           504: 

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