Return to eval2.c CVS log

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

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

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: eval2.c,v 1.6 83/09/12 14:18:02 sklower Exp $";
        !             4: #endif
        !             5: 
        !             6: /*                                     -[Sat May  7 23:38:37 1983 by jkf]-
        !             7:  *     eval2.c                         $Locker:  $
        !             8:  * more of the evaluator
        !             9:  *
        !            10:  * (c) copyright 1982, Regents of the University of California
        !            11:  */
        !            12: 
        !            13: 
        !            14: #include "global.h"
        !            15: #include "frame.h"
        !            16: 
        !            17: /* Iarray - handle array call.
        !            18:  *  fun - array object
        !            19:  *  args - arguments to the array call , most likely subscripts.
        !            20:  *  evalp - flag, if TRUE then the arguments should be evaluated when they
        !            21:  *     are stacked.
        !            22:  */
        !            23: lispval
        !            24: Iarray(fun,args,evalp)
        !            25: register lispval fun,args;
        !            26: {
        !            27:        Savestack(2);
        !            28:        
        !            29:        lbot = np;
        !            30:        protect(fun->ar.accfun);
        !            31:        for ( ; args != nil ; args = args->d.cdr)  /* stack subscripts */
        !            32:          if(evalp) protect(eval(args->d.car));
        !            33:          else protect(args->d.car);
        !            34:        protect(fun);
        !            35:        vtemp = Lfuncal();
        !            36:        Restorestack();
        !            37:        return(vtemp);
        !            38: }
        !            39: 
        !            40:     
        !            41: dumpmydata(thing)
        !            42: int thing;
        !            43: {
        !            44:        register int *ip = &thing;
        !            45:        register int *lim = ip + nargs();
        !            46: 
        !            47:        printf("Dumpdata got %d args:\n",nargs());
        !            48:        while(ip < lim) printf("%x\n",*ip++);
        !            49:        return(0);
        !            50: }
        !            51: /* Ifcall :: call foreign function/subroutine
        !            52:  *   Ifcall is handed a binary object which is the function to call.
        !            53:  * This function has already been determined to be a foreign function
        !            54:  * by noticing that its discipline field is a string.  
        !            55:  * The arguments to pass have already been evaluated and stacked.  We
        !            56:  * create on the stack a 'callg' type argument list to give to the 
        !            57:  * function.  What is passed to the foreign function depends on the
        !            58:  * type of argument.  Certain args are passes directly, others must be
        !            59:  * copied since the foreign function my want to change them.
        !            60:  * When the foreign function returns, we may have to box the result,
        !            61:  * depending on the type of foreign function.
        !            62:  */
        !            63: lispval
        !            64: Ifcall(a)
        !            65: lispval a;
        !            66: {
        !            67:        char *alloca();
        !            68:        long callg_();
        !            69:        register int *arglist;
        !            70:        register int index;
        !            71:        register struct argent *mynp;
        !            72:        register lispval ltemp;
        !            73:        pbuf pb;
        !            74:        int nargs = np - lbot, kind, mysize, *ap;
        !            75:        Keepxs();
        !            76: 
        !            77:        /* put a frame on the stack which will save np and lbot in a
        !            78:           easy to find place in a standard way */
        !            79:        errp = Pushframe(F_TO_FORT,nil,nil);
        !            80:        mynp = lbot;
        !            81:        kind = (((char *)a->bcd.discipline)[0]);
        !            82: 
        !            83:        /* dispatch according to whether call by reference or value semantics */
        !            84:        switch(kind) {
        !            85:        case 'f': case 'i': case 's': case 'r':
        !            86:                arglist = (int *) alloca((nargs + 1) * sizeof(int));
        !            87:                *arglist = nargs;
        !            88:                for(index = 1; index <=  nargs; index++) {
        !            89:                        switch(TYPE(ltemp=mynp->val)) {
        !            90:                                /* fixnums and flonums must be reboxed */
        !            91:                        case INT:
        !            92:                                stack(0);
        !            93:                                arglist[index] = (int) sp();
        !            94:                                *(int *) arglist[index] = ltemp->i;
        !            95:                                break;
        !            96:                        case DOUB:
        !            97:                                stack(0);
        !            98:                                stack(0);
        !            99:                                arglist[index] = (int) sp();
        !           100:                                *(double *) arglist[index] = ltemp->r;
        !           101:                                break;
        !           102: 
        !           103:                                /* these cause only part of the structure to be sent */
        !           104: 
        !           105:                        case ARRAY:
        !           106:                                arglist[index] = (int) ltemp->ar.data;
        !           107:                                break;
        !           108: 
        !           109: 
        !           110:                        case BCD:
        !           111:                                arglist[index] = (int) ltemp->bcd.start;
        !           112:                                break;
        !           113: 
        !           114:                                /* anything else should be sent directly */
        !           115: 
        !           116:                        default:
        !           117:                                arglist[index] = (int) ltemp;
        !           118:                                break;
        !           119:                        }
        !           120:                        mynp++;
        !           121:                }
        !           122:                break;
        !           123:        case 'v':
        !           124:                while(TYPE(mynp->val)!=VECTORI)
        !           125:                        mynp->val = error(
        !           126: "First arg to c-function-returning-vector must be of type vector-immediate",
        !           127:                                          TRUE);
        !           128:                nargs--;
        !           129:                mynp++;
        !           130:                lbot++;
        !           131:        case 'c': case 'd':
        !           132:                /* make one pass over args 
        !           133:                calculating size of arglist */
        !           134:                while(mynp < np) switch(TYPE(ltemp=mynp++->val)) {
        !           135:                case DOUB:
        !           136:                        nargs += ((sizeof(double)/sizeof(int))-1);
        !           137:                        break;
        !           138:                case VECTORI:
        !           139:                        if(ltemp->v.vector[-1]==Vpbv) {
        !           140:                            nargs += -1+VecTotSize(ltemp->vl.vectorl[-2]);
        !           141:                        }
        !           142:                }
        !           143:                arglist = (int *) alloca((nargs+1)*sizeof(int));
        !           144:                *arglist = nargs;
        !           145:                ap = arglist + 1;
        !           146:                /* make another pass over the args
        !           147:                   actually copying the arguments */
        !           148:                for(mynp = lbot; mynp < np; mynp++)
        !           149:                        switch(TYPE(ltemp=mynp->val)) {
        !           150:                case INT:
        !           151:                        *ap++ = ltemp->i;
        !           152:                        break;
        !           153:                case DOUB:
        !           154:                        *(double *)ap = ltemp->r;
        !           155:                        ap += (sizeof (double)) / (sizeof (long));
        !           156:                        break;
        !           157:                case VECTORI:
        !           158:                        if(ltemp->v.vector[-1]==Vpbv) {
        !           159:                                mysize = ltemp->vl.vectorl[-2];
        !           160:                                mysize = sizeof(long) * VecTotSize(mysize);
        !           161:                                bcopy(ap,ltemp,mysize);
        !           162:                                ap = (long *) (mysize + (int) ap);
        !           163:                                break;
        !           164:                        }
        !           165:                default:
        !           166:                        *ap++ = (long) ltemp;
        !           167:                }
        !           168:        }
        !           169:        switch(kind) {
        !           170:                case 'i': /* integer-function */
        !           171:                case 'c': /* C-function */
        !           172:                        ltemp = inewint(callg_(a->bcd.start,arglist));
        !           173:                        break;
        !           174: 
        !           175:                case 'r': /* real-function*/
        !           176:                case 'd': /* C function declared returning double */
        !           177:                        {
        !           178:                        double result =
        !           179:                           (* ((double (*)()) callg_))(a->bcd.start,arglist);
        !           180:                        ltemp = newdoub();
        !           181:                        ltemp->r = result; 
        !           182:                        }
        !           183:                        break;
        !           184: 
        !           185:                case 'f':  /* function */
        !           186:                        ltemp = (lispval) callg_(a->bcd.start,arglist);
        !           187:                        break;
        !           188: 
        !           189:                case 'v': /* C function returning a structure */
        !           190:                        ap = (long *) callg_(a->bcd.start,arglist);
        !           191:                        ltemp = (--lbot)->val;
        !           192:                        mysize = ltemp->vl.vectorl[-2];
        !           193:                        mysize = sizeof(long) * VecTotSize(mysize);
        !           194:                        bcopy(ltemp,ap,mysize);
        !           195:                        break;
        !           196: 
        !           197:                default:
        !           198:                case 's': /* subroutine */
        !           199:                        callg_(a->bcd.start,arglist);
        !           200:                        ltemp = tatom;
        !           201:        }
        !           202:        errp = Popframe();
        !           203:        Freexs();
        !           204:        return(ltemp);
        !           205: }
        !           206: 
        !           207: bcopy(to,from,size)
        !           208: register char *to, *from;
        !           209: register size;
        !           210: {
        !           211:        while(--size >= 0) *to++ = *from++;
        !           212: }
        !           213: 
        !           214: lispval
        !           215: ftolsp_(arg1)
        !           216: lispval arg1;
        !           217: {
        !           218:        int count; 
        !           219:        register lispval *ap = &arg1;
        !           220:        lispval save;
        !           221:        pbuf pb;
        !           222:        Savestack(1);
        !           223: 
        !           224:        if((count = nargs())==0) return;;
        !           225: 
        !           226:        if(errp->class==F_TO_FORT)
        !           227:                np = errp->svnp;
        !           228:        errp = Pushframe(F_TO_LISP,nil,nil);
        !           229:        lbot = np;
        !           230:        for(; count > 0; count--)
        !           231:                np++->val = *ap++;
        !           232:        save = Lfuncal();
        !           233:        errp = Popframe();
        !           234:        Restorestack();
        !           235:        return(save);
        !           236: }
        !           237: 
        !           238: 
        !           239:     
        !           240: /* Ifclosure :: evaluate a fclosure  (new version)
        !           241:  * the argument clos is a vector whose property is the atom fclosure
        !           242:  * the form of the vector is
        !           243:  *   0: function to run
        !           244:  * then for each symbol there is on vector entry containing a
        !           245:  * pointer to a sequence of two list cells of this form:
        !           246:  *     (name value . count)
        !           247:  * name is the symbol name to close over
        !           248:  * value is the saved value of the closure
        !           249:  *     (if the closure is 'active', the current value will be in the
        !           250:  *      symbol itself)
        !           251:  * count is a fixnum box (which can be destructively modified safely)
        !           252:  *  it is normally 0.  Each time the variable is put on the stack, it is
        !           253:  *  incremented.  It is decremented each time the the closure is left.
        !           254:  *  If the closure is invoked recusively without a rebinding of the
        !           255:  *  closure variable X, then the count will not be incremented.
        !           256:  *
        !           257:  * when entering a fclosure, for each variable there are three
        !           258:  * possibities:
        !           259:  *  (a) this is the first instance of this closed variable
        !           260:  *  (b) this is the second or greater recursive instance of
        !           261:  *      this closure variable, however it hasn't been normally lambda
        !           262:  *     bound since the last closure invocation
        !           263:  *  (c) like (b) but it has been lambda bound before the most recent
        !           264:  *     closure.
        !           265:  *
        !           266:  * case (a) can be determined by seeing if the count is 0.
        !           267:  * if the count is >0 then we must scan from the top of the stack down
        !           268:  * until we find either the closure or a lambda binding of the variable
        !           269:  * this determines whether it is case (b) or (c).
        !           270:  *
        !           271:  * There are three actions to perform in this routine:
        !           272:  * 1.  determine the closure type (a,b or c) and do any binding necessary
        !           273:  * 2.  call the closure function
        !           274:  * 3.  unbind any necessary closure variables.
        !           275:  *
        !           276:  * Now, the details of those actions:
        !           277:  * 1. for case (b), do nothing as we are still working with the correct
        !           278:  *    value
        !           279:  *    for case (a), pushdown the symbol and give it the value from
        !           280:  *     the closure, inc the closure count
        !           281:  *      push a closure marker on the bindstack too.
        !           282:  *    for case (c), must locate the correct value to set by searching
        !           283:  *      for the last lambda binding before the previous closure.
        !           284:  *      pushdown the symbol and that value, inc the closure count
        !           285:  *      push a closure marker on the bindstack too.
        !           286:  *    a closure marker has atom == int:closure-marker and value pointing
        !           287:  *      to the closure list.  This will be noticed when unbinding.
        !           288:  *
        !           289:  *  3. unbinding is just like popnames except if a closure marker is
        !           290:  *     seen, then this must be done:
        !           291:  *     if the count is 1, just store the symbol's value in the closure
        !           292:  *      and decrement the count.
        !           293:  *      if the count is >1, then search up the stack for the last
        !           294:  *      lambda before the next occurance of this closure variable
        !           295:  *      and set its value to the current value of the closure.
        !           296:  *      decrement the closure count.
        !           297:  *
        !           298:  * clos is the fclosure, funcallp is TRUE if this is called from funcall,
        !           299:  * otherwise it is called from apply
        !           300:  */
        !           301: 
        !           302: #define Case_A 0
        !           303: #define Case_B 1
        !           304: #define Case_C 2
        !           305: 
        !           306: lispval
        !           307: Ifclosure(clos,funcallp)
        !           308: register lispval clos;
        !           309: {
        !           310:     struct nament *oldbnp = bnp, *lbnp, *locatevar();
        !           311:     register int i;
        !           312:     register lispval vect;
        !           313:     int numvars, vlength, tcase, foundc;
        !           314:     lispval handy, atm_dtpr, value_dtpr, Ifuncal(), Lapply();
        !           315:     Savestack(3);
        !           316: 
        !           317:     /* bind variables to their values given in the fclosure */
        !           318:     vlength = VecTotSize(clos->vl.vectorl[VSizeOff]);
        !           319:     /* vector length must be positive (it has to have a function at least) */
        !           320:     if (vlength < 1)
        !           321:        errorh1(Vermisc,"funcall: fclosure has wrong size ",nil,FALSE,0, clos);
        !           322: 
        !           323:     numvars = (vlength - 1);   /* number of varibles */
        !           324:     
        !           325:     for (i = 1 ; i < vlength ; i += 1)
        !           326:     {
        !           327:        atm_dtpr = clos->v.vector[i];   /* car is symbol name */
        !           328:        value_dtpr = atm_dtpr->d.cdr;   /* car: value, cdr:  fixnum count */
        !           329: 
        !           330:        if(value_dtpr->d.cdr->i == 0)
        !           331:                tcase = Case_A;         /* first call */
        !           332:        else {
        !           333:            lbnp = locatevar(atm_dtpr,&foundc,bnp-1);
        !           334:            if (!foundc)
        !           335:            {
        !           336:                /* didn't find the expected closure, count must be
        !           337:                   wrong, correct it and assume case (a)
        !           338:                 */
        !           339:                tcase = Case_A;
        !           340:                value_dtpr->d.cdr->i = 0;
        !           341:            }
        !           342:            else if(lbnp) tcase = Case_C ; /* found intermediate lambda bnd*/
        !           343:            else tcase = Case_B;           /* no intermediate lambda bind */
        !           344:        }
        !           345: 
        !           346:        /* now bind the value if necessary */
        !           347:        switch(tcase) {
        !           348:            case Case_A: PUSHDOWN(atm_dtpr->d.car,value_dtpr->d.car);
        !           349:                         PUSHVAL(clos_marker,atm_dtpr);
        !           350:                         value_dtpr->d.cdr->i += 1;
        !           351:                         break;
        !           352:                         
        !           353:            case Case_B: break;         /* nothing to do */
        !           354: 
        !           355:            case Case_C: /* push first bound value after last close */
        !           356:                         PUSHDOWN(atm_dtpr->d.car,lbnp->val);
        !           357:                         PUSHVAL(clos_marker,atm_dtpr);
        !           358:                         value_dtpr->d.cdr->i += 1;
        !           359:                         break;
        !           360:        }
        !           361:     }
        !           362: 
        !           363:     if(funcallp)
        !           364:        handy = Ifuncal(clos->v.vector[0]);
        !           365:     else {
        !           366:        handy = lbot[-2].val;   /* get args to apply.  This is hacky and may
        !           367:                                           fail if apply is changed */
        !           368:        lbot = np;
        !           369:        protect(clos->v.vector[0]);
        !           370:        protect(handy);
        !           371:        handy = Lapply();
        !           372:     }
        !           373: 
        !           374:     xpopnames(oldbnp); /* pop names with consideration for closure markers */
        !           375:     
        !           376:     if(!funcallp) Restorestack();
        !           377:     return(handy);
        !           378: }
        !           379: 
        !           380: /* xpopnames :: pop values from bindstack, but look out for
        !           381:  *  closure markers.  This is  used (instead of the faster popnames)
        !           382:  * when we know there will be closure markers or when we can't
        !           383:  * be sure that there won't be closure markers (eg. in non-local go's)
        !           384:  */
        !           385: xpopnames(llimit)
        !           386: register struct nament *llimit;
        !           387: {
        !           388:     register struct nament *rnp, *lbnp;
        !           389:     lispval atm_dtpr, value_dtpr;
        !           390:     int foundc;
        !           391: 
        !           392:     for(rnp = bnp; --rnp >= llimit;)
        !           393:     {
        !           394:         if(rnp->atm == clos_marker)
        !           395:        {
        !           396:            atm_dtpr = rnp->val;
        !           397:            value_dtpr = atm_dtpr->d.cdr;
        !           398:            if(value_dtpr->d.cdr->i <= 1)
        !           399:            {
        !           400:                /* this is the only occurance of this closure variable
        !           401:                 * just restore current value to this closure.
        !           402:                 */
        !           403:                value_dtpr->d.car = atm_dtpr->d.car->a.clb;
        !           404:            }
        !           405:            else {
        !           406:                /* locate the last lambda before the next occurance of
        !           407:                 * this closure and store the current symbol's value
        !           408:                 * there
        !           409:                 */
        !           410:                lbnp = locatevar(atm_dtpr,&foundc,rnp-2);
        !           411:                if(!foundc)
        !           412:                {
        !           413:                    /* strange, there wasn't a closure to be found.
        !           414:                     * well, we will fix things up so the count is
        !           415:                     * right.
        !           416:                     */
        !           417:                    value_dtpr->d.car = atm_dtpr->d.car->a.clb;
        !           418:                    value_dtpr->d.cdr->i = 1;
        !           419:                }
        !           420:                else if (lbnp) {
        !           421:                    /* note how the closures value isn't necessarily
        !           422:                     * stored in the closure, it may be stored on
        !           423:                     * the bindstack
        !           424:                     */
        !           425:                    lbnp->val = atm_dtpr->d.car->a.clb;
        !           426:                }
        !           427:                /* the case where lbnp is 0 should never happen, but
        !           428:                   if it does, we can just do nothing safely
        !           429:                 */
        !           430:            }
        !           431:            value_dtpr->d.cdr->i -= 1;
        !           432:        } else rnp->atm->a.clb = rnp->val;  /* the normal case */
        !           433:     }
        !           434:     bnp = llimit;
        !           435: }
        !           436: 
        !           437: 
        !           438: struct nament *
        !           439: locatevar(clos,foundc,rnp)
        !           440: struct nament *rnp;
        !           441: lispval clos;
        !           442: int *foundc;
        !           443: {
        !           444:     register struct nament  *retbnp;
        !           445:     lispval symb;
        !           446: 
        !           447:     retbnp = (struct nament *) 0;
        !           448:     *foundc = 0;
        !           449:     
        !           450:     symb = clos->d.car;
        !           451:     
        !           452:     for(  ; rnp >= orgbnp ; rnp--)
        !           453:     {
        !           454:        if((rnp->atm == clos_marker) && (rnp->val == clos))
        !           455:        {
        !           456:            *foundc = 1;        /* found the closure */
        !           457:            return(retbnp);
        !           458:        }
        !           459:        if(rnp->atm == symb) retbnp = rnp;
        !           460:     }
        !           461:     return(retbnp);    
        !           462: }
        !           463: 
        !           464: lispval
        !           465: LIfss()
        !           466: {
        !           467:        register lispval atm_dtpr, value_dtpr;
        !           468:        struct nament *oldbnp = bnp, *lbnp;
        !           469:        int tcase, foundc = 0;
        !           470:        lispval newval;
        !           471:        int argc = 1;
        !           472:        Savestack(2);
        !           473: 
        !           474:        switch(np-lbot) {
        !           475:        case 2:
        !           476:                newval = np[-1].val;
        !           477:                argc++;
        !           478:        case 1:
        !           479:                atm_dtpr = lbot->val;
        !           480:                value_dtpr = atm_dtpr->d.cdr;
        !           481:                break;
        !           482:        default:
        !           483:                argerr("int:fclosure-symbol-stuff");
        !           484:        }
        !           485:        /* this code is copied from Ifclosure */
        !           486: 
        !           487:        if(value_dtpr->d.cdr->i==0)
        !           488:                tcase = Case_A; /* closure is not active */
        !           489:        else {
        !           490:                lbnp = locatevar(atm_dtpr,&foundc,bnp-1);
        !           491:                if (!foundc)
        !           492:                {
        !           493:                        /* didn't find closure, count must be wrong,
        !           494:                           correct it and assume case (a).*/
        !           495:                        tcase = Case_A;
        !           496:                        value_dtpr->d.cdr->i = 0;
        !           497:                }
        !           498:                else if(lbnp) tcase = Case_C; /* found intermediate lambda*/
        !           499:                else tcase = Case_B;
        !           500:        }
        !           501: 
        !           502:        switch(tcase) {
        !           503:        case Case_B:
        !           504:                if(argc==2) return(atm_dtpr->d.car->a.clb = newval);
        !           505:                return(atm_dtpr->d.car->a.clb);
        !           506: 
        !           507:        case Case_A:
        !           508:                if(argc==2) return(value_dtpr->d.car = newval);
        !           509:                return(value_dtpr->d.car);
        !           510: 
        !           511:        case Case_C:
        !           512:                if(argc==2) return(lbnp->val = newval);
        !           513:                return(lbnp->val);
        !           514:        }
        !           515:        /*NOTREACHED*/
        !           516: }

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