Return to eval.c CVS log

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

Annotation of 42BSD/ucb/lisp/franz/eval.c, revision 1.1

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: eval.c,v 1.6 83/09/07 17:54:42 sklower Exp $";
        !             4: #endif
        !             5: 
        !             6: /*                                     -[Thu Aug 18 10:07:22 1983 by jkf]-
        !             7:  *     eval.c                          $Locker:  $
        !             8:  * evaluator
        !             9:  *
        !            10:  * (c) copyright 1982, Regents of the University of California
        !            11:  */
        !            12: 
        !            13: #include "global.h"
        !            14: #include <signal.h>
        !            15: #include "frame.h"
        !            16: 
        !            17: 
        !            18: 
        !            19: /*
        !            20:  *     eval
        !            21:  * returns the value of the pointer passed as the argument.            
        !            22:  *
        !            23:  */
        !            24: 
        !            25: lispval
        !            26: eval(actarg)
        !            27: lispval actarg;
        !            28: {
        !            29: #define argptr handy
        !            30:     register lispval a = actarg;
        !            31:     register lispval handy;
        !            32:     register struct nament *namptr;
        !            33:     register struct argent *workp;
        !            34:     struct nament *oldbnp = bnp;
        !            35:     int dopopframe = FALSE;
        !            36:     int type, shortcircuit = TRUE;
        !            37:     lispval Ifcall(), Iarray();
        !            38:     Savestack(4);
        !            39: 
        !            40:     /*debugging 
        !            41:     if (rsetsw && rsetatom->a.clb != nil) {
        !            42:        printf("Eval:");
        !            43:        printr(a,stdout);
        !            44:        printf("\nrsetsw: %d evalhsw: %d\n", rsetsw, evalhsw);
        !            45:        printf("*rset: ");
        !            46:        printr(rsetatom->a.clb,stdout);
        !            47:        printf(" evalhook: ");
        !            48:        printr(evalhatom->a.clb,stdout);
        !            49:        printf(" evalhook call flag^G: %d\n", evalhcallsw);
        !            50:        fflush(stdout); 
        !            51:     };  
        !            52:     */
        !            53: 
        !            54:     /* check if an interrupt is pending         and handle if so */
        !            55:     if(sigintcnt > 0) sigcall(SIGINT);
        !            56: 
        !            57:     if (rsetsw && rsetatom->a.clb != nil)  /* if (*rset t) has been done */
        !            58:     {
        !            59:        pbuf pb;
        !            60:        shortcircuit = FALSE;
        !            61:        if (evalhsw != nil && evalhatom->a.clb != nil)
        !            62:        {
        !            63:                                                /*if (sstatus evalhook t)
        !            64:                                                    and evalhook non-nil */
        !            65:            if (!evalhcallsw)
        !            66:                        /*if we got here after calling evalhook, then
        !            67:                          evalhcallsw will be TRUE, so we want to skip calling
        !            68:                          the hook function, permitting one form to be
        !            69:                          evaluated before the hook fires.
        !            70:                         */
        !            71:            {
        !            72:                /* setup equivalent of (funcall evalhook <arg to eval>) */
        !            73:                (np++)->val = a;                /* push form on namestack */
        !            74:                lbot=np;                        /* set up args to funcall */
        !            75:                (np++)->val = evalhatom->a.clb; /* push evalhook's clb */
        !            76:                (np++)->val = a;                /* eval's arg becomes
        !            77:                                                   2nd arg to funcall */
        !            78:                PUSHDOWN(evalhatom, nil);       /* bind evalhook to nil*/
        !            79:                PUSHDOWN(funhatom, nil);        /* bind funcallhook to nil*/
        !            80:                funhcallsw = TRUE;              /* skip any funcall hook */
        !            81:                handy = Lfuncal();              /* now call funcall */
        !            82:                funhcallsw = FALSE;
        !            83:                POP;
        !            84:                POP;
        !            85:                Restorestack();
        !            86:                return(handy);
        !            87:            };
        !            88:        }
        !            89:        errp = Pushframe(F_EVAL,a,nil);
        !            90:        dopopframe = TRUE;      /* remember to pop later */
        !            91:        if(retval == C_FRETURN)
        !            92:        {
        !            93:            Restorestack();
        !            94:            errp = Popframe();
        !            95:            return(lispretval);
        !            96:        }
        !            97:     };
        !            98:         
        !            99:     evalhcallsw = FALSE;   /* clear indication that evalhook called */
        !           100:     
        !           101:     switch (TYPE(a))
        !           102:     {
        !           103:     case ATOM:
        !           104:        if (rsetsw && rsetatom->a.clb != nil && bptr_atom->a.clb != nil) {
        !           105: 
        !           106:            struct nament *bpntr, *eval1bptr;
        !           107:                                  /* Both rsetsw and rsetatom for efficiency*/
        !           108:                                    /* bptr_atom set by second arg to eval1 */
        !           109:            eval1bptr = (struct nament *) bptr_atom->a.clb->d.cdr;
        !           110:                                    /* eval1bptr is bnp when eval1 was called;
        !           111:                                       if an atom was bound after this,
        !           112:                                       then its clb is valid */
        !           113:            for (bpntr = eval1bptr; bpntr < bnp; bpntr++)
        !           114:                if (bpntr->atm==a) {
        !           115:                    handy = a->a.clb;
        !           116:                    goto gotatom;
        !           117:                };                  /* Value saved in first binding of a,
        !           118:                                       if any, after pointer to eval1,
        !           119:                                       is the valid value, else use its clb */
        !           120:            for (bpntr = (struct nament *)bptr_atom->a.clb->d.car;
        !           121:              bpntr < eval1bptr; bpntr++)
        !           122:                if (bpntr->atm==a) {
        !           123:                    handy=bpntr->val;
        !           124:                    goto gotatom;   /* Simply no way around goto here */
        !           125:                };
        !           126:        };
        !           127:         handy = a->a.clb;
        !           128:     gotatom:
        !           129:         if(handy==CNIL) {
        !           130:             handy = errorh1(Vermisc,"Unbound Variable:",nil,TRUE,0,a);
        !           131:         }
        !           132:        if(dopopframe) errp = Popframe();
        !           133:        Restorestack();
        !           134:         return(handy);
        !           135: 
        !           136:     case VALUE:
        !           137:        if(dopopframe) errp = Popframe();
        !           138:        Restorestack();
        !           139:         return(a->l);
        !           140: 
        !           141:     case DTPR:
        !           142:         (np++)->val = a;               /* push form on namestack */
        !           143:         lbot = np;                     /* define beginning of argstack */
        !           144:         /* oldbnp = bnp;                  redundant - Mitch Marcus */
        !           145:         a = a->d.car;                  /* function name or lambda-expr */
        !           146:         for(EVER)
        !           147:             {
        !           148:             switch(TYPE(a))
        !           149:                 {
        !           150:             case ATOM:
        !           151:                                        /*  get function binding  */
        !           152:                 if(a->a.fnbnd==nil && a->a.clb!=nil) {
        !           153:                     a=a->a.clb;
        !           154:                     if(TYPE(a)==ATOM)
        !           155:                         a=a->a.fnbnd;
        !           156:                 } else
        !           157:                     a = a->a.fnbnd;
        !           158:                 break;
        !           159:             case VALUE:
        !           160:                 a = a->l;              /*  get value  */
        !           161:                 break;
        !           162:                 }
        !           163: 
        !           164:             vtemp = (CNIL-1);       /* sentinel value for error test */
        !           165: 
        !           166:         /*funcal:*/    switch (TYPE(a))
        !           167:                 {
        !           168:             case BCD:    /* function */
        !           169:                 argptr = actarg->d.cdr;
        !           170: 
        !           171:                                    /* decide whether lambda, nlambda or
        !           172:                                       macro and push args onto argstack
        !           173:                                       accordingly.                */
        !           174: 
        !           175:                 if(a->bcd.discipline==nlambda) {
        !           176:                     (np++)->val = argptr;
        !           177:                     TNP;
        !           178:                 } else if(a->bcd.discipline==macro) {
        !           179:                     (np++)->val = actarg;
        !           180:                     TNP;
        !           181:                 } else for(;argptr!=nil; argptr = argptr->d.cdr) {
        !           182:                    /* short circuit evaluations of ATOM, INT, DOUB
        !           183:                     * if not in debugging mode
        !           184:                     */
        !           185:                    if(shortcircuit
        !           186:                       && ((type = TYPE(argptr->d.car)) == ATOM)
        !           187:                       && (argptr->d.car->a.clb != CNIL))
        !           188:                        (np++)->val = argptr->d.car->a.clb;
        !           189:                    else if(shortcircuit &&
        !           190:                                ((type == INT) || (type == STRNG)))
        !           191:                        (np++)->val = argptr->d.car;
        !           192:                    else
        !           193:                        (np++)->val = eval(argptr->d.car);
        !           194:                     TNP;
        !           195:                 }
        !           196:                 /* go for it */
        !           197: 
        !           198:                 if(TYPE(a->bcd.discipline)==STRNG)
        !           199:                     vtemp = Ifcall(a);
        !           200:                 else
        !           201:                     vtemp = (*(lispval (*)())(a->bcd.start))();
        !           202:                 break;
        !           203: 
        !           204:             case ARRAY:
        !           205:                 vtemp = Iarray(a,actarg->d.cdr,TRUE);
        !           206:                 break;
        !           207: 
        !           208:             case DTPR:             /* push args on argstack according to
        !           209:                                       type                */
        !           210:                protect(a);     /* save function definition in case function
        !           211:                                   is redefined */
        !           212:                lbot = np;
        !           213:                 argptr = a->d.car;
        !           214:                 if (argptr==lambda) {
        !           215:                     for(argptr = actarg->d.cdr;
        !           216:                         argptr!=nil; argptr=argptr->d.cdr) {
        !           217:                         
        !           218:                         (np++)->val = eval(argptr->d.car);
        !           219:                         TNP;
        !           220:                     }
        !           221:                 } else if (argptr==nlambda) {
        !           222:                     (np++)->val = actarg->d.cdr;
        !           223:                     TNP;
        !           224:                 } else if (argptr==macro) {
        !           225:                     (np++)->val = actarg;
        !           226:                     TNP;
        !           227:                 } else if (argptr==lexpr) {
        !           228:                     for(argptr = actarg->d.cdr;
        !           229:                       argptr!=nil; argptr=argptr->d.cdr) {
        !           230:                         
        !           231:                         (np++)->val = eval(argptr->d.car);
        !           232:                         TNP;
        !           233:                     }
        !           234:                     handy = newdot();
        !           235:                     handy->d.car = (lispval)lbot;
        !           236:                     handy->d.cdr = (lispval)np;
        !           237:                     PUSHDOWN(lexpr_atom,handy);
        !           238:                     lbot = np;
        !           239:                     (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car);
        !           240: 
        !           241:                 } else break;    /* something is wrong - this isn't a proper function */
        !           242: 
        !           243:                 argptr = (a->d.cdr)->d.car;
        !           244:                 namptr =  bnp;
        !           245:                 workp = lbot;
        !           246:                 if(bnp + (np - lbot)> bnplim)
        !           247:                     binderr();
        !           248:                 for(;argptr != (lispval)nil;
        !           249:                      workp++,argptr = argptr->d.cdr)    /* rebind formal names (shallow) */
        !           250:                 {
        !           251:                     if(argptr->d.car==nil)
        !           252:                         continue;
        !           253:                     /*if(((namptr)->atm = argptr->d.car)==nil)
        !           254:                         error("Attempt to lambda bind nil",FALSE);*/
        !           255:                     namptr->atm = argptr->d.car;
        !           256:                     if (workp < np) {
        !           257:                         namptr->val = namptr->atm->a.clb;
        !           258:                         namptr->atm->a.clb = workp->val;
        !           259:                     } else
        !           260:                         bnp = namptr,
        !           261:                         error("Too few actual parameters",FALSE);
        !           262:                     namptr++;
        !           263:                 }
        !           264:                 bnp = namptr;
        !           265:                 if (workp < np)
        !           266:                     error("Too many actual parameters",FALSE);
        !           267: 
        !           268:                                    /* execute body, implied prog allowed */
        !           269: 
        !           270:                 for (handy = a->d.cdr->d.cdr;
        !           271:                     handy != nil;
        !           272:                     handy = handy->d.cdr) {
        !           273:                         vtemp = eval(handy->d.car);
        !           274:                     }
        !           275:                 }
        !           276:             if (vtemp != (CNIL-1)) {
        !           277:                                /* if we get here with a believable value, */
        !           278:                                /* we must have executed a function. */
        !           279:                 popnames(oldbnp);
        !           280: 
        !           281:                 /* in case some clown trashed t */
        !           282: 
        !           283:                 tatom->a.clb = (lispval) tatom;
        !           284:                 if(a->d.car==macro)
        !           285:                {
        !           286:                    if(Vdisplacemacros->a.clb && (TYPE(vtemp) == DTPR))
        !           287:                    {
        !           288:                        actarg->d.car = vtemp->d.car;
        !           289:                        actarg->d.cdr = vtemp->d.cdr;
        !           290:                    }
        !           291:                    vtemp = eval(vtemp);
        !           292:                }
        !           293:                     /* It is of the most wonderful 
        !           294:                        coincidence that the offset
        !           295:                        for car is the same as for
        !           296:                        discipline so we get bcd macros
        !           297:                        for free here ! */
        !           298:                if(dopopframe) errp = Popframe();
        !           299:                Restorestack();
        !           300:                return(vtemp);
        !           301:            }
        !           302:             popnames(oldbnp);
        !           303:             a = (lispval) errorh1(Verundef,"eval: Undefined function ",nil,TRUE,0,actarg->d.car);
        !           304:             }
        !           305: 
        !           306:         }
        !           307:     if(dopopframe) errp = Popframe();
        !           308:     Restorestack();
        !           309:     return(a);    /* other data types are considered constants */
        !           310: }
        !           311: 
        !           312: /*
        !           313:  *    popnames
        !           314:  * removes from the name stack all entries above the first argument.   
        !           315:  * routine should usually be used to clean up the name stack as it    
        !           316:  * knows about the special cases.  bnp is returned pointing to the
        !           317:  * same place as the argument passed.
        !           318:  */
        !           319: lispval
        !           320: popnames(llimit)
        !           321: register struct nament *llimit;
        !           322: {
        !           323:     register struct nament *rnp;
        !           324: 
        !           325:     for(rnp = bnp; --rnp >= llimit;)
        !           326:         rnp->atm->a.clb = rnp->val;
        !           327:     bnp = llimit;
        !           328: }
        !           329: 
        !           330: 
        !           331: /* dumpnamestack
        !           332:  * utility routine to dump out the namestack.
        !           333:  * from bottom to 5 above np
        !           334:  * should be put elsewhere
        !           335:  */
        !           336: dumpnamestack()
        !           337: {
        !           338:     struct argent *newnp;
        !           339: 
        !           340:     printf("namestack dump:\n");
        !           341:     for(newnp = orgnp ; (newnp < np + 6) && (newnp < nplim) ; newnp++)
        !           342:     {
        !           343:        if(newnp == np) printf("**np:**\n");
        !           344:        printf("[%d]: ",newnp-orgnp);
        !           345:        printr(newnp->val,stdout);
        !           346:        printf("\n");
        !           347:     }
        !           348:     printf("end namestack dump\n");
        !           349: }
        !           350: 
        !           351: 
        !           352: 
        !           353: lispval
        !           354: Lapply()
        !           355: {
        !           356:     register lispval a;
        !           357:     register lispval handy;
        !           358:     lispval vtemp, Ifclosure();
        !           359:     struct nament *oldbnp = bnp;
        !           360:     struct argent *oldlbot = lbot; /* Bottom of my frame! */
        !           361:     struct argent *oldnp = np; /* First free on stack */
        !           362:     int extrapush;             /* if must save function value */
        !           363: 
        !           364:     a = lbot->val;
        !           365:     argptr = lbot[1].val;
        !           366:     if(np-lbot!=2)
        !           367:         errorh2(Vermisc,"Apply: Wrong number of args.",nil,FALSE,
        !           368:                999,a,argptr);
        !           369:     if(TYPE(argptr)!=DTPR && argptr!=nil)
        !           370:         argptr = errorh1(Vermisc,"Apply: non-list of args",nil,TRUE,
        !           371:                 998,argptr);
        !           372:     (np++)->val = a;    /* push form on namestack */
        !           373:     TNP;
        !           374:     lbot = np;        /* bottom of current frame */
        !           375:     for(EVER)
        !           376:         {
        !           377:        extrapush = 0;
        !           378:         if (TYPE(a) == ATOM) { a = a->a.fnbnd; extrapush = 1; }
        !           379:                                        /* get function definition (unless
        !           380:                                           calling form is itself a lambda-
        !           381:                                           expression) */
        !           382:         vtemp = CNIL;                  /* sentinel value for error test */
        !           383:         switch (TYPE(a)) {
        !           384: 
        !           385:         case BCD: 
        !           386:                                        /* push arguments - value of a */
        !           387:             if(a->bcd.discipline==nlambda || a->bcd.discipline==macro) {
        !           388:                 (np++)->val=argptr;
        !           389:                 TNP;
        !           390:             } else for (; argptr!=nil; argptr = argptr->d.cdr) {
        !           391:                 (np++)->val=argptr->d.car;
        !           392:                 TNP;
        !           393:             }
        !           394: 
        !           395:            if(TYPE(a->bcd.discipline) == STRNG)
        !           396:              vtemp = Ifcall(a);        /* foreign function */
        !           397:            else
        !           398:               vtemp = (*(lispval (*)())(a->bcd.start))(); /* go for it */
        !           399:             break;
        !           400: 
        !           401:         case ARRAY:
        !           402:             vtemp = Iarray(a,argptr,FALSE);
        !           403:             break;
        !           404: 
        !           405: 
        !           406:         case DTPR:
        !           407:             if (a->d.car==nlambda || a->d.car==macro) {
        !           408:                 (np++)->val = argptr;
        !           409:                 TNP;
        !           410:             } else if (a->d.car==lambda)
        !           411:                 for (; argptr!=nil; argptr = argptr->d.cdr) {
        !           412:                     (np++)->val = argptr->d.car;
        !           413:                     TNP;
        !           414:                 }
        !           415:             else if(a->d.car==lexpr) {
        !           416:                 for (; argptr!=nil; argptr = argptr->d.cdr) {
        !           417:                     
        !           418:                     (np++)->val = argptr->d.car;
        !           419:                     TNP;
        !           420:                 }
        !           421:                 handy = newdot();
        !           422:                 handy->d.car = (lispval)lbot;
        !           423:                 handy->d.cdr = (lispval)np;
        !           424:                 PUSHDOWN(lexpr_atom,handy);
        !           425:                 lbot = np;
        !           426:                 (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car);
        !           427: 
        !           428:             } else break;    /* something is wrong - this isnt a proper function */
        !           429:             rebind(a->d.cdr->d.car,lbot);
        !           430: 
        !           431:            if (extrapush == 1) { protect(a); extrapush = 2;}
        !           432:             for (handy = a->d.cdr->d.cdr;
        !           433:                 handy != nil;
        !           434:                 handy = handy->d.cdr) {
        !           435:                     vtemp = eval(handy->d.car);    /* go for it */
        !           436:                 }
        !           437:            break;
        !           438:            
        !           439:        case VECTOR:
        !           440:            /* certain vectors are valid (fclosures) */
        !           441:           if(a->v.vector[VPropOff] == fclosure)
        !           442:               vtemp = (lispval) Ifclosure(a,FALSE);
        !           443:           break;
        !           444:                
        !           445:         };
        !           446:        
        !           447:        /* pop off extra value if we pushed it before */
        !           448:        if (extrapush == 2)
        !           449:        {
        !           450:            np--;
        !           451:            extrapush = 0;
        !           452:        };
        !           453:        
        !           454:         if (vtemp != CNIL)
        !           455:                                /* if we get here with a believable value, */
        !           456:                                /* we must have executed a function. */
        !           457:             {
        !           458:             popnames(oldbnp);
        !           459: 
        !           460:             /* in case some clown trashed t */
        !           461: 
        !           462:             tatom->a.clb = (lispval) tatom;
        !           463:            np = oldnp; lbot = oldlbot;
        !           464:             return(vtemp);
        !           465:             }
        !           466:         popnames(oldbnp);
        !           467:         a = (lispval) errorh1(Verundef,"apply: Undefined Function ",
        !           468:                                              nil,TRUE,0,oldlbot->val);
        !           469:     }
        !           470:     /*NOT REACHED*/
        !           471: }
        !           472: 
        !           473: 
        !           474: /*
        !           475:  * Rebind -- rebind formal names
        !           476:  */
        !           477: rebind(argptr,workp)
        !           478: register lispval argptr;        /* argptr points to list of atoms */
        !           479: register struct argent * workp;        /* workp points to position on stack
        !           480:                        where evaluated args begin */
        !           481: {
        !           482:     register struct nament *namptr = bnp;
        !           483: 
        !           484:     for(;argptr != (lispval)nil;
        !           485:          workp++,argptr = argptr->d.cdr)  /* rebind formal names (shallow) */
        !           486:     {
        !           487:         if(argptr->d.car==nil)
        !           488:             continue;
        !           489:         namptr->atm = argptr->d.car;
        !           490:         if (workp < np) {
        !           491:             namptr->val = namptr->atm->a.clb;
        !           492:             namptr->atm->a.clb = workp->val;
        !           493:         } else
        !           494:             bnp = namptr,
        !           495:             error("Too few actual parameters",FALSE);
        !           496:         namptr++;
        !           497:         if(namptr > bnplim)
        !           498:             binderr();
        !           499:     }
        !           500:     bnp = namptr;
        !           501:     if (workp < np)
        !           502:         error("Too many actual parameters",FALSE);
        !           503: }
        !           504: 
        !           505: /* the argument to Lfuncal is now mandatory since nargs
        !           506:  * wont work on RISC. If it is given  then it is 
        !           507:  * the name of the function to call and lbot points to the first arg.
        !           508:  * if it is not given, then lbot points to the function to call
        !           509:  */
        !           510: lispval
        !           511: Ifuncal(fcn)
        !           512: lispval fcn;
        !           513: {
        !           514:     register lispval a;
        !           515:     register lispval handy; 
        !           516:     struct nament *oldbnp = bnp;       /* MUST be first local for evalframe */
        !           517:     lispval fcncalled;
        !           518:     lispval Ifcall(),Llist(),Iarray(), Ifclosure();
        !           519:     lispval vtemp;
        !           520:     int typ, dopopframe = FALSE, extrapush;
        !           521:     extern lispval end[];
        !           522:     Savestack(3);
        !           523: 
        !           524:     /*if(nargs()==1)                   /* function I am evaling.    */
        !           525:        a = fcncalled = fcn;
        !           526:     /*else { a = fcncalled = lbot->val; lbot++; }*/
        !           527: 
        !           528:     /*debugging 
        !           529:     if (rsetsw && rsetatom->a.clb != nil) {
        !           530:        printf("funcall:");
        !           531:        printr(a,stdout);
        !           532:        printf("\nrsetsw: %d evalhsw: %d\n", rsetsw, evalhsw);
        !           533:        printf("*rset: ");
        !           534:        printr(rsetatom->a.clb,stdout);
        !           535:        printf(" funhook: ");
        !           536:        printr(funhatom->a.clb,stdout);
        !           537:        printf(" funhook call flag^G: %d\n",funhcallsw);
        !           538:        fflush(stdout); 
        !           539:     };  
        !           540:     */
        !           541: 
        !           542:     /* check if exception pending */
        !           543:     if(sigintcnt > 0 ) sigcall(SIGINT);
        !           544: 
        !           545:     if (rsetsw && rsetatom->a.clb != nil)  /* if (*rset t) has been done */
        !           546:     {          
        !           547:        pbuf pb;
        !           548:        if (evalhsw != nil && funhatom->a.clb != nil)
        !           549:        {
        !           550:                                                /*if (sstatus evalhook t)
        !           551:                                                    and evalhook non-nil */
        !           552:            if (!funhcallsw)
        !           553:                        /*if we got here after calling funcallhook, then
        !           554:                          funhcallsw will be TRUE, so we want to skip calling
        !           555:                          the hook function, permitting one form to be
        !           556:                          evaluated before the hook fires.
        !           557:                         */
        !           558:            {
        !           559:                /* setup equivalent of (funcall funcallhook <args to eval>) */
        !           560:                protect(a);
        !           561:                a = fcncalled = funhatom->a.clb; /* new function to funcall */
        !           562:                PUSHDOWN(funhatom, nil);        /* lambda-bind 
        !           563:                                                 * funcallhook to nil
        !           564:                                                 */
        !           565:                PUSHDOWN(evalhatom, nil);       
        !           566:             /* printf(" now will funcall ");
        !           567:                printr(a,stdout);
        !           568:                putchar('\n');
        !           569:                fflush(stdout); */
        !           570:            };
        !           571:        }
        !           572:        errp = Pushframe(F_FUNCALL,a,nil);
        !           573:        dopopframe = TRUE;      /* remember to pop later */
        !           574:        if(retval == C_FRETURN)
        !           575:        {
        !           576:            popnames(oldbnp);
        !           577:            errp = Popframe();
        !           578:            Restorestack();
        !           579:            return(lispretval);
        !           580:        }
        !           581:     };
        !           582:     
        !           583:     funhcallsw = FALSE;        /* so recursive calls to funcall will cause hook
        !           584:                           to fire */
        !           585:     for(EVER)
        !           586:     {
        !           587:      top:
        !           588:         extrapush = 0;
        !           589:        
        !           590:         typ = TYPE(a);
        !           591:         if (typ == ATOM)
        !           592:        {   /* get function defn (unless calling form */
        !           593:             /* is itself a lambda-expr) */
        !           594:            a = a->a.fnbnd;
        !           595:            typ = TYPE(a);
        !           596:            extrapush = 1;      /* must protect this later */
        !           597:        }
        !           598:         vtemp = CNIL-1;            /* sentinel value for error test */
        !           599:         switch (typ) {
        !           600:         case ARRAY:
        !           601:            protect(a);                 /* stack array descriptor on top */
        !           602:            a = a->ar.accfun;           /* now funcall access function */
        !           603:            goto top;
        !           604:         case BCD:
        !           605:             if(a->bcd.discipline==nlambda)
        !           606:                 {   if(np==lbot) protect(nil);  /* default is nil */
        !           607:                 while(np-lbot!=1 || (lbot->val != nil &&
        !           608:                       TYPE(lbot->val)!=DTPR)) {
        !           609: 
        !           610:                            lbot->val = errorh1(Vermisc,"Bad funcall arg(s) to fexpr.",
        !           611:                                                 nil,TRUE,0,lbot->val);
        !           612:                            
        !           613:                     np = lbot+1;
        !           614:                     }
        !           615:                 }
        !           616:             /* go for it */
        !           617: 
        !           618:             if(TYPE(a->bcd.discipline)==STRNG)
        !           619:                 vtemp = Ifcall(a);
        !           620:             else
        !           621:                 vtemp = (*(lispval (*)())(a->bcd.start))();
        !           622:             if(a->bcd.discipline==macro)
        !           623:                 vtemp = eval(vtemp);
        !           624:             break;
        !           625: 
        !           626: 
        !           627:         case DTPR:
        !           628:             if (a->d.car == lambda) {
        !           629:                 ;/* VOID */
        !           630:             } else if (a->d.car == nlambda || a->d.car==macro) {
        !           631:                 if( np==lbot ) protect(nil);    /* default */
        !           632:                 while(np-lbot!=1 || (lbot->val != nil &&
        !           633:                           TYPE(lbot->val)!=DTPR)) {
        !           634:                     lbot->val = error("Bad funcall arg(s) to fexpr.",TRUE);
        !           635:                     np = lbot+1;
        !           636:                     }
        !           637:             } else if (a->d.car == lexpr) {
        !           638:                 handy = newdot();
        !           639:                 handy->d.car = (lispval) lbot;
        !           640:                 handy->d.cdr = (lispval) np;
        !           641:                 PUSHDOWN(lexpr_atom,handy);
        !           642:                 lbot = np;
        !           643:                 (np++)->val = inewint(((lispval *)handy->d.cdr) - (lispval *)handy->d.car);
        !           644:             } else break;        /* something is wrong - this isn't a proper function */
        !           645:             rebind(a->d.cdr->d.car,lbot);
        !           646: 
        !           647:            /* since the actual arguments are bound to their formal params
        !           648:             * we can pop them off the stack.  However if we are doing
        !           649:             * debugging (that is if we've pushed a frame on the stack)
        !           650:             * then we must not pop off the actual args since they must
        !           651:             * be visible for evalframe to work
        !           652:             */
        !           653:             if(!dopopframe) np = lbot;
        !           654:            if (extrapush == 1) {protect(a);  extrapush = 2;}
        !           655:             for (handy = a->d.cdr->d.cdr;
        !           656:                 handy != nil;
        !           657:                 handy = handy->d.cdr) {
        !           658:                     vtemp = eval(handy->d.car);    /* go for it */
        !           659:                 }
        !           660:             if(a->d.car==macro)
        !           661:                 vtemp = eval(vtemp);
        !           662:            break;
        !           663:            
        !           664:        case VECTOR:
        !           665:           /* A fclosure represented as a vector with the property 'fclosure' */
        !           666:           if(a->v.vector[VPropOff] == fclosure)
        !           667:               vtemp = (lispval) Ifclosure(a,TRUE);
        !           668:           break;
        !           669:           
        !           670:         }
        !           671:        
        !           672:        /* pop off extra value if we pushed it before */
        !           673:        if(extrapush == 2) { np-- ; extrapush = 0; }
        !           674:        
        !           675:         if (vtemp != CNIL-1)
        !           676:             /* if we get here with a believable value, */
        !           677:             /* we must have executed a function. */
        !           678:             {
        !           679:             popnames(oldbnp);
        !           680: 
        !           681:             /* in case some clown trashed t */
        !           682: 
        !           683:             tatom->a.clb = (lispval) tatom;
        !           684: 
        !           685:            if(dopopframe) errp = Popframe();
        !           686:            Restorestack();
        !           687:             return(vtemp);
        !           688:             }
        !           689:         popnames(oldbnp);
        !           690:            a = fcncalled = (lispval) errorh1(Verundef,"funcall: Bad function",
        !           691:                                               nil,TRUE,0,fcncalled);
        !           692:     }
        !           693:     /*NOT REACHED*/
        !           694: }
        !           695: lispval   /* this version called from lisp */
        !           696: Lfuncal()
        !           697: {
        !           698:        lispval handy;
        !           699:        Savestack(0);
        !           700:        
        !           701:        switch(np-lbot)
        !           702:        {
        !           703:            case 0: argerr("funcall");
        !           704:                    break;
        !           705:        }
        !           706:        handy = lbot++->val;
        !           707:        handy = Ifuncal(handy);
        !           708:        Restorestack();
        !           709:        return(handy);
        !           710: }
        !           711: 
        !           712: /* The following must be the next "function" after Lfuncal, for the
        !           713: sake of Levalf.  */
        !           714: fchack () {}
        !           715: 
        !           716: 
        !           717: /*
        !           718:  * Llexfun  :: lisp function lexpr-funcall
        !           719:  * lexpr-funcall is a cross between funcall and apply.
        !           720:  * the last argument is nil or a list of the rest of the arguments.
        !           721:  * we push those arguments on the stack and call funcall
        !           722:  *
        !           723:  */
        !           724: lispval
        !           725: Llexfun()
        !           726: {
        !           727:     register lispval handy;
        !           728:     
        !           729:     switch(np-lbot)
        !           730:     {
        !           731:        case 0: argerr("lexpr-funcall");        /* need at least one arg */
        !           732:                break;
        !           733:        case 1: return(Lfuncal());       /* no args besides function */
        !           734:     }
        !           735:     /* have at least one argument past the function to funcall */
        !           736:     handy = np[-1].val;                /* get last value */
        !           737:     np--;                      /* pop it off stack */
        !           738:     
        !           739:     while((handy != nil) && (TYPE(handy) != DTPR))
        !           740:        handy = errorh1(Vermisc,"lexpr-funcall: last argument is not a list ",
        !           741:                        nil,TRUE,0,handy);
        !           742: 
        !           743:     /* stack arguments */
        !           744:     for( ; handy != nil ; handy = handy->d.cdr) protect(handy->d.car);
        !           745: 
        !           746:     return(Lfuncal());
        !           747: }
        !           748: 
        !           749:        
        !           750: #undef protect
        !           751:        
        !           752: /* protect 
        !           753:  * pushes the first argument onto namestack, thereby protecting from gc
        !           754:  */
        !           755: lispval
        !           756: protect(a)
        !           757: lispval a;
        !           758: {
        !           759:     (np++)->val = a;
        !           760:        if (np >=  nplim)
        !           761:         namerr();
        !           762: }
        !           763: 
        !           764: /* unprot
        !           765:  * returns the top thing on the name stack.  Underflow had better not
        !           766:  * occur.
        !           767:  */
        !           768: lispval
        !           769: unprot()
        !           770:     {
        !           771:     return((--np)->val);
        !           772:     }
        !           773: 
        !           774: lispval
        !           775: linterp()
        !           776:     {
        !           777:     error("BYTE INTERPRETER CALLED ERRONEOUSLY",FALSE);
        !           778:     }
        !           779: 
        !           780: /* Undeff - called from qfuncl when it detects a call to a undefined
        !           781:     function from compiled code, we print out a message and
        !           782:     will continue only if returned a symbol (ATOM in C parlance).
        !           783: */
        !           784: lispval
        !           785: Undeff(atmn)
        !           786: lispval atmn;
        !           787: {
        !           788:     do {atmn =errorh1(Verundef,"Undefined function called from compiled code ",
        !           789:                                      nil,TRUE,0,atmn);}
        !           790:        while(TYPE(atmn) != ATOM);
        !           791:     return(atmn);                    
        !           792: }
        !           793: 
        !           794: /* VARARGS1 */
        !           795: bindfix(firstarg)
        !           796: lispval firstarg;
        !           797: {
        !           798:     register lispval *argp = &firstarg;
        !           799:     register struct nament *mybnp = bnp;
        !           800:     while(*argp != nil) {
        !           801:         mybnp->atm = *argp++;
        !           802:         mybnp->val = mybnp->atm->a.clb;
        !           803:         mybnp->atm->a.clb = *argp++;
        !           804:         bnp = mybnp++;
        !           805:     }
        !           806: }
        !           807: 

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