Return to fex1.c CVS log

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

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

1.1     ! root        1: #include "global.h"
        !             2: /* Nprog ****************************************************************/
        !             3: /* This first sets the local variables to nil while saving their old   */
        !             4: /* values on the name stack.  Then, pointers to various things are     */
        !             5: /* saved as this function may be returned to by an "Ngo" or by a       */
        !             6: /* "Lreturn".  At the end is the loop that cycles through the contents */
        !             7: /* of the prog.                                                                */
        !             8: 
        !             9: lispval
        !            10: Nprog() {
        !            11:        int     saveme[SAVSIZE];
        !            12:        register struct nament *mybnp = bnp;
        !            13:        register struct argent *savednp;
        !            14:        register lispval where, temp;
        !            15:        register struct argent *lbot, *np;
        !            16:        struct argent *savedlbot;
        !            17:        struct nament *savedbnp;
        !            18:        struct nament *topbind;
        !            19:        int myerrp; extern int errp;
        !            20: 
        !            21:        savednp = np;
        !            22:        savedlbot = lbot;
        !            23:        savedbnp = bnp;
        !            24:        temp = where = (lbot->val)->car;
        !            25:        while (TYPE(temp) == DTPR)
        !            26:        {
        !            27:                temp = where->car;
        !            28:                if (TYPE(temp) == ATOM)
        !            29:                        {
        !            30:                        bnp->atm = temp;
        !            31:                        bnp->val = (temp)->clb;
        !            32:                        (temp)->clb = nil;
        !            33:                        temp = where = where->cdr;
        !            34:                        if(bnp++ > bnplim)
        !            35:                                binderr();
        !            36:                        }
        !            37:                else return(CNIL);
        !            38:        }
        !            39:        topbind = bnp;
        !            40:        myerrp = errp;
        !            41:        if (where != nil) return(CNIL);
        !            42:        temp = where = savedlbot->val->cdr;
        !            43:        getexit(saveme);
        !            44:        while (retval = setexit()) {
        !            45:                errp = myerrp;
        !            46:                switch (retval) {
        !            47: 
        !            48:                case BRRETN:    resexit(saveme);
        !            49:                                popnames(savedbnp);
        !            50:                                lbot = savedlbot;
        !            51:                                return(contval);
        !            52: 
        !            53:                case BRGOTO:    where = (savedlbot->val)->cdr;
        !            54:                                while ((TYPE(where) == DTPR) && (where->car != contval))
        !            55:                                        where = where->cdr;
        !            56:                                if (where->car == contval) {
        !            57:                                        resexit(saveme);
        !            58:                                        popnames(topbind);
        !            59:                                        lbot = savedlbot;
        !            60:                                        break;
        !            61:                                }
        !            62: 
        !            63:                default:
        !            64:                        resexit(saveme);
        !            65:                        reset(retval);
        !            66: 
        !            67:                }
        !            68:        }
        !            69:        while (TYPE(where) == DTPR)
        !            70:                {
        !            71:                temp = where->car;
        !            72:                if((TYPE(temp))!=ATOM) eval(temp);
        !            73:                where = where->cdr;
        !            74:                }
        !            75:        resexit(saveme);
        !            76:        return((where == nil) ? nil : CNIL);
        !            77:        }
        !            78: 
        !            79: lispval globtag;
        !            80: /*
        !            81:    Ncatch is now actually *catch , which has the form
        !            82:      (*catch tag form)
        !            83:     tag is evaluated and then the catch entry is set up.
        !            84:       then form is evaluated
        !            85:     finally the catch entry is removed.
        !            86: 
        !            87:     (catch form [tag]) is translated to (*catch 'tag form)
        !            88:      by a macro.
        !            89:  */
        !            90: lispval
        !            91: Ncatch()
        !            92: {
        !            93:        struct  argent  *savednp,*savedlbot;
        !            94:        register lispval where, tag, todo;
        !            95:        register temp;
        !            96:        register struct argent *lbot, *np;
        !            97:        int type;
        !            98: 
        !            99: 
        !           100:        where = lbot->val;
        !           101:        if((TYPE(where))!=DTPR) return(nil);
        !           102:        todo = where->cdr->car;
        !           103:        tag = eval(where->car);
        !           104:        while(TYPE(tag)!=ATOM)
        !           105:                tag = error("Non symbolic tag in *catch.",TRUE);
        !           106:        asm("   pushab  On1");
        !           107:        asm("   pushr   $0x2540");
        !           108:        asm("   subl2   $40,sp");       /* THIS IS A CROCK ....
        !           109:                                           saves current environment
        !           110:                                           for (return) z.B. */
        !           111:        asm("   movc3   $40,_setsav,(sp)");
        !           112:        asm("   pushl   _bnp");
        !           113:        asm("   pushl   r10");
        !           114:        asm("   pushl   $1");
        !           115:        asm("   pushl   _errp");
        !           116:        asm("   movl    sp,_errp");
        !           117:        where = (eval(todo));
        !           118:        asm("   movl    (sp),_errp");
        !           119:        return(where);
        !           120:        asm("On1:ret");
        !           121: }
        !           122: 
        !           123: /* (errset form [flag])  
        !           124:    if present, flag determines if the error message will be printed
        !           125:    if an error reaches the errset.
        !           126:    if no error occurs, errset returns a list of one element, the 
        !           127:     value returned from form.
        !           128:    if an error occurs, nil is usually returned although it could
        !           129:     be non nil if err threw a non nil value 
        !           130:  */
        !           131: 
        !           132: lispval Nerrset()
        !           133: {
        !           134:        register lispval flag,where,todo; /* order important */
        !           135:        register lispval handy = Vlerall;         /* to access this easily */
        !           136:        register struct argent *lbot, *np;
        !           137:        where = lbot->val;
        !           138: 
        !           139:        if(TYPE(where) != DTPR) return(nil);    /* no form */
        !           140: 
        !           141:        todo = where->car;              /* form to eval */
        !           142:        flag = where->cdr;
        !           143:        if(flag != nil) flag = eval(flag->car); /* tag to tell if er messg */
        !           144:        else flag = tatom;      /* if not present , assume t */
        !           145: 
        !           146:        /* push on a catch frame */
        !           147: 
        !           148:        asm("   pushab  On2");          /* where to jump if error */
        !           149:        asm("   pushr   $0x2540");
        !           150:        asm("   subl2   $40,sp");       /* THIS IS A CROCK ....
        !           151:                                           saves current environment
        !           152:                                           for (return) z.B. */
        !           153:        asm("   movc3   $40,_setsav,(sp)");
        !           154:        asm("   pushl   _bnp");
        !           155:        asm("   pushl   r8");   /* tag , (ER%all)       */
        !           156:        asm("   pushl   r11");          /* flag                 */
        !           157:        asm("   pushl   _errp");        /* link in              */
        !           158:        asm("   movl    sp,_errp");     /*  "                   */
        !           159: 
        !           160:        /* evaluate form, and if ok, listify */
        !           161: 
        !           162:        handy = eval(todo);
        !           163:        asm("   movl    (sp),_errp");   /* unlink this frame    */
        !           164:        protect(handy);                 /* may gc on nxt call   */
        !           165:        (flag = newdot()) ->car = handy; /* listify arg */
        !           166: 
        !           167:        return(flag);
        !           168: 
        !           169:        asm("On2: ret");                /* if error occured */
        !           170:        
        !           171: }
        !           172:        
        !           173: /* this was changed from throw to *throw 21nov79
        !           174:    it really should be called Lthrow
        !           175: */
        !           176: Nthrow()
        !           177: {
        !           178:        register lispval todo, where;
        !           179:        lispval globtag,contval;
        !           180:        snpand(2);  /* save register mask */
        !           181:        chkarg(2);
        !           182:        globtag = lbot->val;
        !           183:        contval = (lbot+1)->val;
        !           184:        Idothrow(globtag,contval);
        !           185:        error("Uncaught throw",FALSE);
        !           186: }
        !           187: #include "catchframe.h"
        !           188: 
        !           189: Idothrow(tag,value)
        !           190: lispval tag,value;
        !           191: {
        !           192:        typedef struct catchfr *cp;
        !           193:        register cp curp;       /* must be first register */
        !           194:        extern int errp;
        !           195:        extern lispval globtag;
        !           196: 
        !           197:        globtag = tag;
        !           198:        for (curp=(cp)errp ; curp != (cp) nil ; curp =curp->link)
        !           199:        {
        !           200:            if(curp->labl == nil || curp->labl == tag)
        !           201:            {
        !           202:                popnames(curp->svbnp);
        !           203:                errp = (int) curp->link;
        !           204:                asm("   addl3   $16,r11,sp");
        !           205:                                /* account for current (return) */
        !           206:                asm("   movc3   $40,(sp),_setsav");
        !           207:                asm("   addl2   $40,sp");
        !           208:                asm("   popr    $0x2540");
        !           209:                asm("   movl    8(ap),r0");
        !           210:                asm("   rsb");
        !           211:                }
        !           212:        }
        !           213: 
        !           214:        return;
        !           215: }
        !           216: 
        !           217: 
        !           218: /* Ngo ******************************************************************/
        !           219: /* First argument only is checked - and must be an atom or evaluate    */
        !           220: /* to one.                                                             */
        !           221: Ngo()
        !           222:        {
        !           223:        contval = (lbot->val)->car;
        !           224:        while (TYPE(contval) != ATOM)
        !           225:                {
        !           226:                contval = eval(contval);
        !           227:                while (TYPE(contval) != ATOM) contval = error("GO ARG NOT ATOM",TRUE);
        !           228:                }
        !           229:        reset(BRGOTO);
        !           230:        }
        !           231: 
        !           232: 
        !           233: /* Nreset ***************************************************************/
        !           234: /* All arguments are ignored.  This just returns-from-break to depth 0.        */
        !           235: Nreset()
        !           236:        {
        !           237:        contval = 0;
        !           238:        reset(BRRETB);
        !           239:        }
        !           240: 
        !           241: /* Nresetio *************************************************************/
        !           242: 
        !           243: lispval
        !           244: Nresetio() {
        !           245:        register FILE *p;
        !           246: 
        !           247:        for(p = &_iob[3]; p < _iob + _NFILE; p++) {
        !           248:                if(p->_flag & (_IOWRT | _IOREAD)) fclose(p);
        !           249:                }
        !           250:        return(nil);
        !           251: 
        !           252: }
        !           253: 
        !           254: 
        !           255: /* Nbreak ***************************************************************/
        !           256: /* If first argument is not nil, this is evaluated and printed.  Then  */
        !           257: /* error is called with the "breaking" message.                                */
        !           258: 
        !           259: lispval
        !           260: Nbreak()
        !           261: {
        !           262:        register lispval hold; register FILE *port;
        !           263:        port = okport(Vpoport->clb,stdout);
        !           264:        fprintf(port,"Breaking:");
        !           265: 
        !           266:        if ((hold = lbot->val) != nil && ((hold = hold->car) != nil))
        !           267:        {
        !           268:                printr(hold,port);
        !           269:        }
        !           270:        putc('\n',port);
        !           271:        dmpport(port);
        !           272:        return(error("",TRUE));
        !           273: }
        !           274: 
        !           275: 
        !           276: /* Nexit ****************************************************************/
        !           277: /* Just calls lispend with no message.                                 */
        !           278: Nexit()
        !           279:        {
        !           280:        lispend("");
        !           281:        }
        !           282: 
        !           283: 
        !           284: /* Nsys *****************************************************************/
        !           285: /* Just calls lispend with no message.                                 */
        !           286: 
        !           287: lispval
        !           288: Nsys()
        !           289:        {
        !           290:        lispend("");
        !           291:        }
        !           292: 
        !           293: 
        !           294: 
        !           295: 
        !           296: lispval
        !           297: Ndef() {
        !           298:        register lispval arglist, body, name, form;
        !           299:        snpand(4);
        !           300:        
        !           301:        form = lbot->val;
        !           302:        name = form->car;
        !           303:        body = form->cdr->car;
        !           304:        arglist = body->cdr->car;
        !           305:        if((TYPE(arglist))!=DTPR && arglist != nil)
        !           306:                error("Warning: defining function with nonlist of args",
        !           307:                        TRUE);
        !           308:        name->fnbnd = body;
        !           309:        return(name);
        !           310: }
        !           311: 
        !           312: 
        !           313: lispval
        !           314: Nquote()
        !           315: {
        !           316:        snpand(0);
        !           317:        return((lbot->val)->car);
        !           318: }
        !           319: 
        !           320: 
        !           321: lispval
        !           322: Nsetq()
        !           323: {      register lispval handy, where, value;
        !           324:        register int lefttype;
        !           325:        register struct argent *lbot, *np;
        !           326: 
        !           327: 
        !           328:        for(where = lbot->val; where != nil; where = handy->cdr) {
        !           329:                handy = where -> cdr;
        !           330:                if((TYPE(handy))!=DTPR)
        !           331:                        error("odd number of args to setq",FALSE);
        !           332:                if((lefttype=TYPE(where->car))==ATOM) {
        !           333:                        if(where->car==nil)
        !           334:                                error("Attempt to set nil",FALSE);
        !           335:                        where->car->clb = value = eval(handy->car);
        !           336:                 }else if(lefttype==VALUE)
        !           337:                        where->car->l = value = eval(handy->car);
        !           338:                else error("CAN ONLY SETQ ATOMS OR VALUES",FALSE);
        !           339:        }
        !           340:        return(value);
        !           341: }
        !           342: 
        !           343: 
        !           344: lispval
        !           345: Ncond()
        !           346: {
        !           347:        register lispval  where, last;
        !           348:        snpand(2);
        !           349: 
        !           350:        where = lbot->val;
        !           351:        last = nil;
        !           352:        for(;;) {
        !           353:                if ((TYPE(where))!=DTPR)
        !           354:                        break;
        !           355:                if ((TYPE(where->car))!=DTPR)
        !           356:                        break;
        !           357:                if ((last=eval((where->car)->car)) != nil)
        !           358:                        break;
        !           359:                where = where->cdr;
        !           360:        }
        !           361: 
        !           362:        if ((TYPE(where)) != DTPR)
        !           363:                        return(nil);
        !           364:        where = (where->car)->cdr;
        !           365:        while ((TYPE(where))==DTPR) {
        !           366:                        last = eval(where->car);
        !           367:                        where = where->cdr;
        !           368:        }
        !           369:        return(last);
        !           370: }
        !           371: 
        !           372: lispval
        !           373: Nand()
        !           374: {
        !           375:        register lispval current, temp;
        !           376:        snpand(2);
        !           377: 
        !           378:        current = lbot->val;
        !           379:        temp = tatom;
        !           380:        while (current != nil)
        !           381:                if ( (temp = current->car)!=nil && (temp = eval(temp))!=nil) 
        !           382:                        current = current->cdr;
        !           383:                else {
        !           384:                        current = nil;
        !           385:                        temp = nil;
        !           386:                }
        !           387:        return(temp);
        !           388: }
        !           389: 
        !           390: 
        !           391: lispval
        !           392: Nor()
        !           393: {
        !           394:        register lispval current, temp;
        !           395:        snpand(2);
        !           396: 
        !           397:        current = lbot->val;
        !           398:        temp = nil;
        !           399:        while (current != nil)
        !           400:                if ( (temp = eval(current->car)) == nil)
        !           401:                        current = current->cdr;
        !           402:                else
        !           403:                        break;
        !           404:        return(temp);
        !           405: }
        !           406: 
        !           407: 
        !           408: lispval
        !           409: Nprocess() {
        !           410:        int wflag , childsi , childso , childnum, child;
        !           411:        register lispval current, temp;
        !           412:        char * sharg;
        !           413:        int handler;
        !           414:        int itemp;
        !           415:        FILE *bufs[2],*obufs[2];
        !           416: 
        !           417:        wflag = 1;
        !           418:        childsi = 0;
        !           419:        childso = 1;
        !           420:        current = lbot->val;
        !           421:        if( (TYPE(current))!=DTPR )
        !           422:                return(nil);
        !           423:        temp = current->car;
        !           424:        if( (TYPE(temp))!=ATOM )
        !           425:                return(nil);
        !           426: 
        !           427:        sharg = temp -> pname;
        !           428: 
        !           429:        if( (current = current->cdr)!=nil && (TYPE((temp = current->car)))==ATOM ) {
        !           430:        
        !           431:                if (temp == tatom) {
        !           432:                        wflag = 0;
        !           433:                        childsi = 0;
        !           434:                } else if (temp != nil) {
        !           435:                        fpipe(bufs);
        !           436:                        wflag = 0;
        !           437:                        temp->clb = (lispval)bufs[1];
        !           438:                        childsi = fileno(bufs[0]);
        !           439:                }
        !           440:        
        !           441:                if( (current = current->cdr)!=nil && (TYPE((temp = current->car)))==ATOM ) {
        !           442:        
        !           443:                        if (temp != nil) {
        !           444:                                fpipe(obufs);
        !           445:                                temp->clb = (lispval)obufs[0];
        !           446:                                childso = fileno(obufs[1]);
        !           447:                        }
        !           448:                }
        !           449:        }
        !           450:        handler = signal(2,1);
        !           451:        if((child = fork()) == 0 ) {
        !           452:                if(wflag!=0 && handler!=1)
        !           453:                        signal(2,0);
        !           454:                else
        !           455:                        signal(2,1);
        !           456:                if(childsi != 0) {
        !           457:                        close(0);
        !           458:                        dup(childsi);
        !           459:                }
        !           460:                if (childso !=1) {
        !           461:                        close(1);
        !           462:                        dup(childso);
        !           463:                }
        !           464:                execlp("csh", "csh", "-c",sharg,0);
        !           465:                execlp("sh", "sh", "-c",sharg,0);
        !           466:                exit(-1); /* if exec fails, signal problems*/
        !           467:        }
        !           468: 
        !           469:        if(childsi != 0) fclose(bufs[0]);
        !           470:        if(childso != 1) fclose(obufs[1]);
        !           471: 
        !           472:        if(wflag && child!= -1) {
        !           473:                int status=0;
        !           474:                wait(&status);
        !           475:                itemp = status >> 8;
        !           476:        } else
        !           477:                itemp = child;
        !           478:        signal(2,handler);
        !           479:        return(inewint(itemp));
        !           480: }

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