Return to fex2.c CVS log

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

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

1.1     ! root        1: 
        !             2: #ifndef lint
        !             3: static char *rcsid =
        !             4:    "$Header: fex2.c,v 1.3 83/09/07 17:55:38 sklower Exp $";
        !             5: #endif
        !             6: 
        !             7: /*                                     -[Mon Jan 31 21:54:52 1983 by layer]-
        !             8:  *     fex2.c                          $Locker:  $
        !             9:  * nlambda functions
        !            10:  *
        !            11:  * (c) copyright 1982, Regents of the University of California
        !            12:  */
        !            13: 
        !            14: #include "global.h"
        !            15: #define NDOVARS 30
        !            16: #include "frame.h"
        !            17: 
        !            18: /*
        !            19:  * Ndo  maclisp do function.
        !            20:  */
        !            21: lispval
        !            22: Ndo()
        !            23: {
        !            24:        register lispval current, where, handy;
        !            25:        register struct nament *mybnp;
        !            26:        lispval temp, atom;
        !            27:        lispval body, endtest, endform, varstuff, renewals[NDOVARS] ;
        !            28:        struct argent *getem, *startnp;  
        !            29:        struct nament *savedbnp = bnp;
        !            30:        int count, repeatdo, index;
        !            31:        extern struct frame *errp;
        !            32:        pbuf pb;
        !            33:        Savestack(3);
        !            34: 
        !            35:        current = lbot->val;
        !            36:        varstuff = current->d.car;
        !            37: 
        !            38:        switch( TYPE(varstuff) ) {
        !            39: 
        !            40:        case ATOM:                      /* This is old style maclisp do;
        !            41:                                           atom is var, cadr(current) = init;
        !            42:                                           caddr(current) = repeat etc. */
        !            43:                if(varstuff==nil) goto newstyle;
        !            44:                current = current->d.cdr;       /* car(current) is now init */
        !            45:                PUSHDOWN(varstuff,eval(current->d.car));
        !            46:                                        /* Init var.        */
        !            47:                *renewals = (current = current->d.cdr)->d.car;
        !            48:                                        /* get repeat form  */
        !            49:                endtest = (current = current->d.cdr)->d.car;
        !            50:                body = current->d.cdr;
        !            51: 
        !            52:                errp = Pushframe(F_PROG,nil,nil);
        !            53: 
        !            54:                switch (retval) {
        !            55:                    case C_RET: /*
        !            56:                                 * returning from this prog, value to return
        !            57:                                 * is in lispretval
        !            58:                                 */
        !            59:                                errp = Popframe();
        !            60:                                popnames(savedbnp);
        !            61:                                return(lispretval);
        !            62: 
        !            63:                    case C_GO:  /*
        !            64:                                 * going to a certain label, label to go to in
        !            65:                                 * in lispretval
        !            66:                                 */
        !            67:                                where = body;
        !            68:                                while ((TYPE(where) == DTPR) 
        !            69:                                        & (where->d.car != lispretval))
        !            70:                                where = where->d.cdr;
        !            71:                                if (where->d.car == lispretval) {
        !            72:                                        popnames(errp->svbnp);
        !            73:                                        where = where->d.cdr;
        !            74:                                        goto singbody;
        !            75:                                }
        !            76:                                /* label not found in this prog, must 
        !            77:                                 * go up to higher prog
        !            78:                                 */
        !            79:                                Inonlocalgo(C_GO,lispretval,nil);
        !            80: 
        !            81:                                /* NOT REACHED */
        !            82: 
        !            83:                    case C_INITIAL: break;      /* fall through */
        !            84: 
        !            85:                }
        !            86: 
        !            87:            singtop:
        !            88:                    if(eval(endtest)!=nil) {
        !            89:                        errp = Popframe();
        !            90:                        popnames(savedbnp);
        !            91:                        return(nil);
        !            92:                    }
        !            93:                    where = body;
        !            94:                    
        !            95:            singbody:
        !            96:                    while (TYPE(where) == DTPR)
        !            97:                    {
        !            98:                        temp = where->d.car;
        !            99:                        if((TYPE(temp))!=ATOM) eval(temp);
        !           100:                        where = where->d.cdr;
        !           101:                    }
        !           102:                    varstuff->a.clb = eval(*renewals);
        !           103:                    goto singtop;
        !           104:        
        !           105: 
        !           106:        newstyle:
        !           107:        case DTPR:                      /* New style maclisp do; atom is
        !           108:                                           list of things of the form
        !           109:                                           (var init repeat)            */
        !           110:                count = 0;
        !           111:                startnp = np;
        !           112:                for(where = varstuff; where != nil; where = where->d.cdr) {
        !           113:                                        /* do inits and count do vars. */
        !           114:                                        /* requires "simultaneous" eval
        !           115:                                           of all inits                 */
        !           116:                        while (TYPE(where->d.car) != DTPR)
        !           117:                          where->d.car =
        !           118:                             errorh1(Vermisc,"do: variable forms must be lists ",
        !           119:                             nil,TRUE,0,where->d.car);
        !           120:                        handy = where->d.car->d.cdr;
        !           121:                        temp = nil;
        !           122:                        if(handy !=nil)
        !           123:                                temp = eval(handy->d.car);
        !           124:                        protect(temp);
        !           125:                        count++;
        !           126:                }
        !           127:                if(count > NDOVARS)
        !           128:                        error("More than 15 do vars",FALSE);
        !           129:                where = varstuff;
        !           130:                getem = startnp;        /* base of stack of init forms */
        !           131:                for(index = 0; index < count; index++) {
        !           132: 
        !           133:                        handy = where->d.car;
        !           134:                                        /* get var name from group      */
        !           135: 
        !           136:                        atom = handy->d.car;
        !           137:                        while((TYPE(atom) != ATOM) || (atom == nil))
        !           138:                          atom = errorh1(Vermisc,"do variable must be a non nil symbol ",
        !           139:                                                    nil,TRUE,0,atom);
        !           140:                        PUSHDOWN(atom,getem->val);
        !           141:                        getem++;
        !           142:                        handy = handy->d.cdr->d.cdr;
        !           143:                        if(handy==nil)
        !           144:                                handy = CNIL;  /* be sure not to rebind later */
        !           145:                        else
        !           146:                                handy = handy->d.car;
        !           147:                        renewals[index] = handy;
        !           148: 
        !           149:                                        /* more loop "increments" */
        !           150:                        where = where->d.cdr;
        !           151:                }
        !           152:                np = startnp;           /* pop off all init forms */
        !           153:                                        /* Examine End test and End form */
        !           154:                current = current->d.cdr;
        !           155:                handy = current->d.car;
        !           156:                body = current->d.cdr;
        !           157: 
        !           158:                /* 
        !           159:                 * a do form with a test of nil just does the body once
        !           160:                 * and returns nil
        !           161:                 */
        !           162:                if (handy == nil) repeatdo = 1; /* just do it once */
        !           163:                else repeatdo = -1;             /* do it forever   */
        !           164: 
        !           165:                endtest = handy->d.car;
        !           166:                endform = handy->d.cdr;
        !           167: 
        !           168:                where = body;
        !           169: 
        !           170:                errp = Pushframe(F_PROG,nil,nil);
        !           171:                while(TRUE) {
        !           172: 
        !           173:                    switch (retval) {
        !           174:                    case C_RET: /*
        !           175:                                 * returning from this prog, value to return
        !           176:                                 * is in lispretval
        !           177:                                 */
        !           178:                                errp = Popframe();
        !           179:                                popnames(savedbnp);
        !           180:                                Restorestack();
        !           181:                                return(lispretval);
        !           182: 
        !           183:                    case C_GO:  /*
        !           184:                                 * going to a certain label, label to go to in
        !           185:                                 * in lispretval
        !           186:                                 */
        !           187:                                where = body;
        !           188:                                while ((TYPE(where) == DTPR) 
        !           189:                                        & (where->d.car != lispretval))
        !           190:                                where = where->d.cdr;
        !           191:                                if (where->d.car == lispretval) {
        !           192:                                        popnames(errp->svbnp);
        !           193:                                        where = where->d.cdr;
        !           194:                                        goto bodystart;
        !           195:                                }
        !           196:                                /* label not found in this prog, must 
        !           197:                                 * go up to higher prog
        !           198:                                 */
        !           199:                                Inonlocalgo(C_GO,lispretval,nil);
        !           200: 
        !           201:                                /* NOT REACHED */
        !           202: 
        !           203:                    case C_INITIAL: break;      /* fall through */
        !           204: 
        !           205:                    }
        !           206: 
        !           207:            loop:
        !           208:                    np = startnp;       /* is bumped when doing repeat forms */
        !           209: 
        !           210:                    if((repeatdo-- == 0) || (eval(endtest) !=nil)) {
        !           211:                        for(handy = nil; endform!=nil; endform = endform->d.cdr)
        !           212:                        {
        !           213:                                handy = eval(endform->d.car);
        !           214:                        }
        !           215:                        errp = Popframe();
        !           216:                        popnames(savedbnp);
        !           217:                        Restorestack();
        !           218:                        return(handy);
        !           219:                    }
        !           220:                    
        !           221:            bodystart:
        !           222:                    while (TYPE(where) == DTPR)
        !           223:                    {
        !           224:                        temp = where->d.car;
        !           225:                        if((TYPE(temp))!=ATOM) eval(temp);
        !           226:                        where = where->d.cdr;
        !           227:                    }
        !           228:                    where = body;
        !           229:                    getem = np = startnp;
        !           230:                                        /* Simultaneously eval repeat forms */
        !           231:                    for(index = 0; index < count; index++) {
        !           232:                        temp = renewals[index];
        !           233:                        if (temp == nil || temp == CNIL)
        !           234:                                protect(temp);
        !           235:                        else
        !           236:                                protect(eval(temp));
        !           237:                    }
        !           238:                                        /* now simult. rebind all the atoms */
        !           239:                    mybnp = savedbnp;
        !           240:                    for(index = 0; index < count; index++) 
        !           241:                    {
        !           242:                       if( getem->val != CNIL )  /* if this atom has a repeat */
        !           243:                        mybnp->atm->a.clb = (getem)->val;  /* rebind */
        !           244:                        mybnp++;
        !           245:                        getem++;
        !           246:                    }
        !           247:                    goto loop;
        !           248:                }
        !           249:            default:
        !           250:                error("do: neither list nor atom follows do", FALSE);
        !           251:            }
        !           252:                /* NOTREACHED */
        !           253: }
        !           254: 
        !           255: lispval
        !           256: Nprogv()
        !           257: {
        !           258:        register lispval where, handy;
        !           259:        register struct nament *namptr;
        !           260:        register struct argent *vars;
        !           261:        struct nament *oldbnp = bnp;
        !           262:        Savestack(4);
        !           263: 
        !           264:        where = lbot->val;
        !           265:        protect(eval(where->d.car));            /* list of vars = lbot[1].val */
        !           266:        protect(eval((where = where->d.cdr)->d.car));
        !           267:                                                /* list of vals */
        !           268:        handy = lbot[2].val;
        !           269:        namptr = oldbnp;
        !           270:                                                /* simultaneous eval of all
        !           271:                                                   args */
        !           272:        for(;handy!=nil; handy = handy->d.cdr) {
        !           273:                (np++)->val = (handy->d.car);
        !           274:                /*  Note, each element should not be reevaluated like it 
        !           275:                 *  was  before.  - dhl */
        !           276:                /* Before: (np++)->val = eval(handy->d.car);*/
        !           277:                TNP;
        !           278:        }
        !           279:        /*asm("# Here is where rebinding is done");      /* very cute */
        !           280:        for(handy=lbot[1].val,vars=lbot+3; handy!=nil; handy=handy->d.cdr) {
        !           281:            namptr->atm = handy->d.car;
        !           282:            ++namptr;                           /* protect against interrupts
        !           283:                                                   while re-lambda binding */
        !           284:            bnp = namptr;
        !           285:            namptr[-1].atm = handy->d.car;
        !           286:            namptr[-1].val = handy->d.car->a.clb;
        !           287:            if(vars < np)
        !           288:                handy->d.car->a.clb = vars++->val;
        !           289:            else
        !           290:                handy->d.car->a.clb = nil;
        !           291:        }
        !           292:                
        !           293:        handy = nil;
        !           294:        for(where = where->d.cdr; where != nil; where = where->d.cdr)
        !           295:                handy = eval(where->d.car);
        !           296:        popnames(oldbnp);
        !           297:        Restorestack();
        !           298:        return(handy);
        !           299: }
        !           300: 
        !           301: lispval
        !           302: Nprogn()
        !           303: {
        !           304:        register lispval result, where;
        !           305: 
        !           306:        result = nil;
        !           307:        for(where = lbot->val; where != nil; where = where->d.cdr)
        !           308:                result = eval(where->d.car);
        !           309:        return(result);
        !           310: 
        !           311: 
        !           312: }
        !           313: lispval
        !           314: Nprog2()
        !           315: {
        !           316:        register lispval result, where;
        !           317: 
        !           318:        where = lbot->val; 
        !           319:        eval(where->d.car);
        !           320:        result = eval((where = where->d.cdr)->d.car);
        !           321:        protect(result);
        !           322:        for(where = where->d.cdr; where != nil; where = where->d.cdr)
        !           323:                eval(where->d.car);
        !           324:        np--;
        !           325:        return(result);
        !           326: }
        !           327: lispval
        !           328: typred(typ,ptr)
        !           329: int    typ;
        !           330: lispval        ptr;
        !           331: 
        !           332: {   int tx;
        !           333:        if ((tx = TYPE(ptr)) == typ) return(tatom);
        !           334:        if ((tx == INT) && (typ == ATOM)) return(tatom);
        !           335:        return(nil);
        !           336: }
        !           337: 
        !           338: /*
        !           339:  * function
        !           340:  * In the interpreter, function is the same as quote
        !           341:  */
        !           342: lispval
        !           343: Nfunction()
        !           344: {
        !           345:        if((lbot->val == nil) || (lbot->val->d.cdr != nil))
        !           346:                argerr("function");
        !           347:        return(lbot->val->d.car);
        !           348: }

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