Return to fex1.c CVS log

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

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

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: fex1.c,v 1.5 85/03/24 11:03:51 sklower Exp $";
        !             4: #endif
        !             5: 
        !             6: /*                                     -[Sat Mar  5 19:50:28 1983 by layer]-
        !             7:  *     fex1.c                          $Locker:  $
        !             8:  * nlambda functions
        !             9:  *
        !            10:  * (c) copyright 1982, Regents of the University of California
        !            11:  */
        !            12: 
        !            13: 
        !            14: #include "global.h"
        !            15: #include "frame.h"
        !            16: 
        !            17: /* Nprog ****************************************************************/
        !            18: /* This first sets the local variables to nil while saving their old   */
        !            19: /* values on the name stack.  Then, pointers to various things are     */
        !            20: /* saved as this function may be returned to by an "Ngo" or by a       */
        !            21: /* "Lreturn".  At the end is the loop that cycles through the contents */
        !            22: /* of the prog.                                                                */
        !            23: 
        !            24: lispval
        !            25: Nprog() {
        !            26:        register lispval where, temp;
        !            27:        struct nament *savedbnp = bnp;
        !            28:        extern struct frame *errp;
        !            29:        pbuf pb;
        !            30:        extern int retval;
        !            31:        extern lispval lispretval;
        !            32: 
        !            33:        if((np-lbot) < 1) chkarg(1,"prog");
        !            34: 
        !            35:        /* shallow bind the local variables to nil */
        !            36:        if(lbot->val->d.car != nil)
        !            37:        {
        !            38:            for( where = lbot->val->d.car ; where != nil; where = where->d.cdr )
        !            39:            {
        !            40:                if(TYPE(where) != DTPR || TYPE(temp=where->d.car) != ATOM)
        !            41:                    errorh1(Vermisc,
        !            42:                           "Illegal local variable list in prog ",nil,FALSE,
        !            43:                           1,where);
        !            44:                PUSHDOWN(temp,nil);
        !            45:            }
        !            46:        }
        !            47: 
        !            48:        /* put a frame on the stack which can be 'return'ed to or 'go'ed to */
        !            49:        errp = Pushframe(F_PROG,nil,nil);
        !            50: 
        !            51:        where = lbot->val->d.cdr;       /* first thing in the prog body */
        !            52: 
        !            53:        switch (retval) {
        !            54:        case C_RET:     /*
        !            55:                         * returning from this prog, value to return
        !            56:                         * is in lispretval
        !            57:                         */
        !            58:                        errp = Popframe();
        !            59:                        popnames(savedbnp);
        !            60:                        return(lispretval);
        !            61: 
        !            62:        case C_GO:      /*
        !            63:                         * going to a certain label, label to go to in
        !            64:                         * in lispretval
        !            65:                         */
        !            66:                        where = (lbot->val)->d.cdr;
        !            67:                        while ((TYPE(where) == DTPR) 
        !            68:                               && (where->d.car != lispretval))
        !            69:                                where = where->d.cdr;
        !            70:                        if (where->d.car == lispretval) {
        !            71:                                popnames(errp->svbnp);
        !            72:                                break;
        !            73:                        }
        !            74:                        /* label not found in this prog, must 
        !            75:                         * go up to higher prog
        !            76:                         */
        !            77:                        errp = Popframe();      /* go to next frame */
        !            78:                        Inonlocalgo(C_GO,lispretval,nil);
        !            79: 
        !            80:                        /* NOT REACHED */
        !            81: 
        !            82:        case C_INITIAL: break;
        !            83: 
        !            84:        }
        !            85: 
        !            86:        while (TYPE(where) == DTPR)
        !            87:                {
        !            88:                temp = where->d.car;
        !            89:                if((TYPE(temp))!=ATOM) eval(temp);
        !            90:                where = where->d.cdr;
        !            91:                }
        !            92:        if((where != nil) && (TYPE(where) != DTPR)) 
        !            93:            errorh1(Vermisc,"Illegal form in prog body ", nil,FALSE,0,where);
        !            94:        errp = Popframe();
        !            95:        popnames(savedbnp);     /* pop off locals */
        !            96:        return(nil);
        !            97: }
        !            98: 
        !            99: lispval globtag;
        !           100: /*
        !           101:    Ncatch is now linked to the lisp symbol *catch , which has the form
        !           102:      (*catch tag form)
        !           103:     tag is evaluated and then the catch entry is set up.
        !           104:       then form is evaluated
        !           105:     finally the catch entry is removed.
        !           106: 
        !           107:   *catch is still an nlambda since its arguments should not be evaluated
        !           108:    before this routine is called.
        !           109: 
        !           110:    (catch form [tag]) is translated to (*catch 'tag form) by a macro.
        !           111:  */
        !           112: lispval
        !           113: Ncatch()
        !           114: {
        !           115:        register lispval tag;
        !           116:        pbuf pb;
        !           117:        Savestack(3);           /* save stack pointers */
        !           118: 
        !           119:        if((TYPE(lbot->val))!=DTPR) return(nil);
        !           120:        protect(tag = eval(lbot->val->d.car));  /* protect tag from gc */
        !           121: 
        !           122:        errp = Pushframe(F_CATCH,tag,nil);
        !           123: 
        !           124:        switch(retval) {
        !           125: 
        !           126:        case C_THROW:   /*
        !           127:                         * value thrown is in lispretval
        !           128:                         */
        !           129:                        break;
        !           130: 
        !           131:        case C_INITIAL: /*
        !           132:                         * calculate value of expression
        !           133:                         */
        !           134:                         lispretval = eval(lbot->val->d.cdr->d.car);
        !           135:        }
        !           136:                        
        !           137:                        
        !           138:        errp = Popframe();
        !           139:        Restorestack();
        !           140:        return(lispretval);
        !           141: }
        !           142: /* (errset form [flag])  
        !           143:    if present, flag determines if the error message will be printed
        !           144:    if an error reaches the errset.
        !           145:    if no error occurs, errset returns a list of one element, the 
        !           146:     value returned from form.
        !           147:    if an error occurs, nil is usually returned although it could
        !           148:     be non nil if err threw a non nil value 
        !           149:  */
        !           150: 
        !           151: lispval Nerrset()
        !           152: {
        !           153:        lispval temp,flag;
        !           154:        pbuf pb;
        !           155:        Savestack(0);
        !           156: 
        !           157:        if(TYPE(lbot->val) != DTPR) return(nil);        /* no form */
        !           158: 
        !           159:        /* evaluate and save flag first */
        !           160:        flag = lbot->val->d.cdr;
        !           161:        if(TYPE(flag) == DTPR) flag = eval(flag->d.car); 
        !           162:        else flag = tatom;      /* if not present , assume t */
        !           163:        protect(flag);
        !           164: 
        !           165:        errp = Pushframe(F_CATCH,Verall,flag);
        !           166: 
        !           167:        switch(retval) {
        !           168: 
        !           169:        case C_THROW:   /*
        !           170:                         * error thrown to this routine, value thrown is
        !           171:                         * in lispretval
        !           172:                         */
        !           173:                        break;
        !           174: 
        !           175:        case C_INITIAL: /*
        !           176:                         * normally just evaluate expression and listify it.
        !           177:                         */
        !           178:                        temp = eval(lbot->val->d.car);
        !           179:                        protect(temp);
        !           180:                        (lispretval = newdot())->d.car = temp;
        !           181:                        break;
        !           182:        }
        !           183: 
        !           184:        errp = Popframe();
        !           185:        Restorestack();
        !           186:        return(lispretval);
        !           187: }
        !           188:        
        !           189: /* this was changed from throw to *throw 21nov79
        !           190:    it is now a lambda and really should be called Lthrow
        !           191: */
        !           192: lispval
        !           193: Nthrow()
        !           194: {
        !           195:        switch(np-lbot) {
        !           196:        case 0:
        !           197:                protect(nil);
        !           198:        case 1:
        !           199:                protect(nil);
        !           200:        case 2: break;
        !           201:        default:
        !           202:                argerr("throw");
        !           203:        }
        !           204:        Inonlocalgo(C_THROW,lbot->val,(lbot+1)->val);
        !           205:        /* NOT REACHED */
        !           206: }
        !           207: 
        !           208: 
        !           209: 
        !           210: /* Ngo ******************************************************************/
        !           211: /* First argument only is checked - and must be an atom or evaluate    */
        !           212: /* to one.                                                             */
        !           213: lispval
        !           214: Ngo() 
        !           215: {
        !           216:     register lispval temp;
        !           217:     chkarg(1,"go");
        !           218: 
        !           219:     temp = (lbot->val)->d.car;
        !           220:     if (TYPE(temp) != ATOM)
        !           221:     {
        !           222:        temp = eval(temp);
        !           223:        while(TYPE(temp) != ATOM) 
        !           224:          temp = errorh1(Vermisc,"Illegal tag to go to",nil,TRUE, 0,lbot->val);
        !           225:     }
        !           226:     Inonlocalgo(C_GO,temp,nil);
        !           227:     /* NOT REACHED */
        !           228: }
        !           229: 
        !           230: 
        !           231: /* Nreset ***************************************************************/
        !           232: /* All arguments are ignored.  This just returns-from-break to depth 0.        */
        !           233: lispval
        !           234: Nreset()
        !           235: {
        !           236:     Inonlocalgo(C_RESET,inewint(0),nil);
        !           237: }
        !           238: 
        !           239: 
        !           240: 
        !           241: /* Nbreak ***************************************************************/
        !           242: /* If first argument is not nil, this is evaluated and printed.  Then  */
        !           243: /* error is called with the "breaking" message.                                */
        !           244: 
        !           245: lispval
        !           246: Nbreak()
        !           247: {
        !           248:        register lispval hold; register FILE *port;
        !           249:        port = okport(Vpoport->a.clb,stdout);
        !           250:        fprintf(port,"Breaking:");
        !           251: 
        !           252:        if ((hold = lbot->val) != nil && ((hold = hold->d.car) != nil))
        !           253:        {
        !           254:                printr(hold,port);
        !           255:        }
        !           256:        putc('\n',port);
        !           257:        dmpport(port);
        !           258:        return(errorh(Verbrk,"",nil,TRUE,0));
        !           259: }
        !           260: 
        !           261: 
        !           262: /* Nexit ****************************************************************/
        !           263: /* Just calls lispend with no message.                                 */
        !           264: Nexit()
        !           265:        {
        !           266:        lispend("");
        !           267:        }
        !           268: 
        !           269: 
        !           270: /* Nsys *****************************************************************/
        !           271: /* Just calls lispend with no message.                                 */
        !           272: 
        !           273: lispval
        !           274: Nsys()
        !           275:        {
        !           276:        lispend("");
        !           277:        }
        !           278: 
        !           279: 
        !           280: 
        !           281: 
        !           282: lispval
        !           283: Ndef() {
        !           284:        register lispval arglist, body, name, form;
        !           285:        
        !           286:        form = lbot->val;
        !           287:        name = form->d.car;
        !           288:        body = form->d.cdr->d.car;
        !           289:        arglist = body->d.cdr->d.car;
        !           290:        if((TYPE(arglist))!=DTPR && arglist != nil)
        !           291:                error("Warning: defining function with nonlist of args",
        !           292:                        TRUE);
        !           293:        name->a.fnbnd = body;
        !           294:        return(name);
        !           295: }
        !           296: 
        !           297: 
        !           298: lispval
        !           299: Nquote()
        !           300: {
        !           301:        return((lbot->val)->d.car);
        !           302: }
        !           303: 
        !           304: 
        !           305: lispval
        !           306: Nsetq()
        !           307: {      register lispval handy, where, value;
        !           308:        register int lefttype;
        !           309: 
        !           310:        value = nil;
        !           311:        
        !           312:        for(where = lbot->val; where != nil; where = handy->d.cdr) {
        !           313:                handy = where->d.cdr;
        !           314:                if((TYPE(handy))!=DTPR)
        !           315:                        error("odd number of args to setq",FALSE);
        !           316:                if((lefttype=TYPE(where->d.car))==ATOM) {
        !           317:                        if(where->d.car==nil)
        !           318:                                error("Attempt to set nil",FALSE);
        !           319:                        where->d.car->a.clb = value = eval(handy->d.car);
        !           320:                 }else if(lefttype==VALUE)
        !           321:                        where->d.car->l = value = eval(handy->d.car);
        !           322:                else errorh1(Vermisc,
        !           323:                            "Can only setq atoms or values",nil,FALSE,0,
        !           324:                                        where->d.car);
        !           325:        }
        !           326:        return(value);
        !           327: }
        !           328: 
        !           329: 
        !           330: lispval
        !           331: Ncond()
        !           332: {
        !           333:        register lispval  where, last;
        !           334: 
        !           335:        where = lbot->val;
        !           336:        last = nil;
        !           337:        for(;;) {
        !           338:                if ((TYPE(where))!=DTPR)
        !           339:                        break;
        !           340:                if ((TYPE(where->d.car))!=DTPR)
        !           341:                        break;
        !           342:                if ((last=eval((where->d.car)->d.car)) != nil)
        !           343:                        break;
        !           344:                where = where->d.cdr;
        !           345:        }
        !           346: 
        !           347:        if ((TYPE(where)) != DTPR)
        !           348:                        return(nil);
        !           349:        where = (where->d.car)->d.cdr;
        !           350:        while ((TYPE(where))==DTPR) {
        !           351:                        last = eval(where->d.car);
        !           352:                        where = where->d.cdr;
        !           353:        }
        !           354:        return(last);
        !           355: }
        !           356: 
        !           357: lispval
        !           358: Nand()
        !           359: {
        !           360:        register lispval current, temp;
        !           361: 
        !           362:        current = lbot->val;
        !           363:        temp = tatom;
        !           364:        while (current != nil)
        !           365:                if ( (temp = current->d.car)!=nil && (temp = eval(temp))!=nil) 
        !           366:                        current = current->d.cdr;
        !           367:                else {
        !           368:                        current = nil;
        !           369:                        temp = nil;
        !           370:                }
        !           371:        return(temp);
        !           372: }
        !           373: 
        !           374: 
        !           375: lispval
        !           376: Nor()
        !           377: {
        !           378:        register lispval current, temp;
        !           379: 
        !           380:        current = lbot->val;
        !           381:        temp = nil;
        !           382:        while (current != nil)
        !           383:                if ( (temp = eval(current->d.car)) == nil)
        !           384:                        current = current->d.cdr;
        !           385:                else
        !           386:                        break;
        !           387:        return(temp);
        !           388: }

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