Return to fex1.c CVS log

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

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

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

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