Return to eval2.c CVS log

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

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

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: eval2.c,v 1.8 85/03/24 11:03: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:                                xbcopy(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:                        xbcopy(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: xbcopy(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: lispval
        !           239: ftlspn_(func,arglist)
        !           240: lispval func;
        !           241: register long *arglist;
        !           242: {
        !           243:        int count; 
        !           244:        lispval save;
        !           245:        pbuf pb;
        !           246:        Savestack(1);
        !           247: 
        !           248:        if(errp->class==F_TO_FORT)
        !           249:                np = errp->svnp;
        !           250:        errp = Pushframe(F_TO_LISP,nil,nil);
        !           251:        lbot = np;
        !           252:        np++->val = func;
        !           253:        count = *arglist++;
        !           254:        for(; count > 0; count--)
        !           255:                np++->val = (lispval) (*arglist++);
        !           256:        save = Lfuncal();
        !           257:        errp = Popframe();
        !           258:        Restorestack();
        !           259:        return(save);
        !           260: }
        !           261: 
        !           262: 
        !           263:     
        !           264: /* Ifclosure :: evaluate a fclosure  (new version)
        !           265:  * the argument clos is a vector whose property is the atom fclosure
        !           266:  * the form of the vector is
        !           267:  *   0: function to run
        !           268:  * then for each symbol there is on vector entry containing a
        !           269:  * pointer to a sequence of two list cells of this form:
        !           270:  *     (name value . count)
        !           271:  * name is the symbol name to close over
        !           272:  * value is the saved value of the closure
        !           273:  *     (if the closure is 'active', the current value will be in the
        !           274:  *      symbol itself)
        !           275:  * count is a fixnum box (which can be destructively modified safely)
        !           276:  *  it is normally 0.  Each time the variable is put on the stack, it is
        !           277:  *  incremented.  It is decremented each time the the closure is left.
        !           278:  *  If the closure is invoked recusively without a rebinding of the
        !           279:  *  closure variable X, then the count will not be incremented.
        !           280:  *
        !           281:  * when entering a fclosure, for each variable there are three
        !           282:  * possibities:
        !           283:  *  (a) this is the first instance of this closed variable
        !           284:  *  (b) this is the second or greater recursive instance of
        !           285:  *      this closure variable, however it hasn't been normally lambda
        !           286:  *     bound since the last closure invocation
        !           287:  *  (c) like (b) but it has been lambda bound before the most recent
        !           288:  *     closure.
        !           289:  *
        !           290:  * case (a) can be determined by seeing if the count is 0.
        !           291:  * if the count is >0 then we must scan from the top of the stack down
        !           292:  * until we find either the closure or a lambda binding of the variable
        !           293:  * this determines whether it is case (b) or (c).
        !           294:  *
        !           295:  * There are three actions to perform in this routine:
        !           296:  * 1.  determine the closure type (a,b or c) and do any binding necessary
        !           297:  * 2.  call the closure function
        !           298:  * 3.  unbind any necessary closure variables.
        !           299:  *
        !           300:  * Now, the details of those actions:
        !           301:  * 1. for case (b), do nothing as we are still working with the correct
        !           302:  *    value
        !           303:  *    for case (a), pushdown the symbol and give it the value from
        !           304:  *     the closure, inc the closure count
        !           305:  *      push a closure marker on the bindstack too.
        !           306:  *    for case (c), must locate the correct value to set by searching
        !           307:  *      for the last lambda binding before the previous closure.
        !           308:  *      pushdown the symbol and that value, inc the closure count
        !           309:  *      push a closure marker on the bindstack too.
        !           310:  *    a closure marker has atom == int:closure-marker and value pointing
        !           311:  *      to the closure list.  This will be noticed when unbinding.
        !           312:  *
        !           313:  *  3. unbinding is just like popnames except if a closure marker is
        !           314:  *     seen, then this must be done:
        !           315:  *     if the count is 1, just store the symbol's value in the closure
        !           316:  *      and decrement the count.
        !           317:  *      if the count is >1, then search up the stack for the last
        !           318:  *      lambda before the next occurance of this closure variable
        !           319:  *      and set its value to the current value of the closure.
        !           320:  *      decrement the closure count.
        !           321:  *
        !           322:  * clos is the fclosure, funcallp is TRUE if this is called from funcall,
        !           323:  * otherwise it is called from apply
        !           324:  */
        !           325: 
        !           326: #define Case_A 0
        !           327: #define Case_B 1
        !           328: #define Case_C 2
        !           329: 
        !           330: lispval
        !           331: Ifclosure(clos,funcallp)
        !           332: register lispval clos;
        !           333: {
        !           334:     struct nament *oldbnp = bnp, *lbnp, *locatevar();
        !           335:     register int i;
        !           336:     register lispval vect;
        !           337:     int numvars, vlength, tcase, foundc;
        !           338:     lispval handy, atm_dtpr, value_dtpr, Ifuncal(), Lapply();
        !           339:     Savestack(3);
        !           340: 
        !           341:     /* bind variables to their values given in the fclosure */
        !           342:     vlength = VecTotSize(clos->vl.vectorl[VSizeOff]);
        !           343:     /* vector length must be positive (it has to have a function at least) */
        !           344:     if (vlength < 1)
        !           345:        errorh1(Vermisc,"funcall: fclosure has wrong size ",nil,FALSE,0, clos);
        !           346: 
        !           347:     numvars = (vlength - 1);   /* number of varibles */
        !           348:     
        !           349:     for (i = 1 ; i < vlength ; i += 1)
        !           350:     {
        !           351:        atm_dtpr = clos->v.vector[i];   /* car is symbol name */
        !           352:        value_dtpr = atm_dtpr->d.cdr;   /* car: value, cdr:  fixnum count */
        !           353: 
        !           354:        if(value_dtpr->d.cdr->i == 0)
        !           355:                tcase = Case_A;         /* first call */
        !           356:        else {
        !           357:            lbnp = locatevar(atm_dtpr,&foundc,bnp-1);
        !           358:            if (!foundc)
        !           359:            {
        !           360:                /* didn't find the expected closure, count must be
        !           361:                   wrong, correct it and assume case (a)
        !           362:                 */
        !           363:                tcase = Case_A;
        !           364:                value_dtpr->d.cdr->i = 0;
        !           365:            }
        !           366:            else if(lbnp) tcase = Case_C ; /* found intermediate lambda bnd*/
        !           367:            else tcase = Case_B;           /* no intermediate lambda bind */
        !           368:        }
        !           369: 
        !           370:        /* now bind the value if necessary */
        !           371:        switch(tcase) {
        !           372:            case Case_A: PUSHDOWN(atm_dtpr->d.car,value_dtpr->d.car);
        !           373:                         PUSHVAL(clos_marker,atm_dtpr);
        !           374:                         value_dtpr->d.cdr->i += 1;
        !           375:                         break;
        !           376:                         
        !           377:            case Case_B: break;         /* nothing to do */
        !           378: 
        !           379:            case Case_C: /* push first bound value after last close */
        !           380:                         PUSHDOWN(atm_dtpr->d.car,lbnp->val);
        !           381:                         PUSHVAL(clos_marker,atm_dtpr);
        !           382:                         value_dtpr->d.cdr->i += 1;
        !           383:                         break;
        !           384:        }
        !           385:     }
        !           386: 
        !           387:     if(funcallp)
        !           388:        handy = Ifuncal(clos->v.vector[0]);
        !           389:     else {
        !           390:        handy = lbot[-2].val;   /* get args to apply.  This is hacky and may
        !           391:                                           fail if apply is changed */
        !           392:        lbot = np;
        !           393:        protect(clos->v.vector[0]);
        !           394:        protect(handy);
        !           395:        handy = Lapply();
        !           396:     }
        !           397: 
        !           398:     xpopnames(oldbnp); /* pop names with consideration for closure markers */
        !           399:     
        !           400:     if(!funcallp) Restorestack();
        !           401:     return(handy);
        !           402: }
        !           403: 
        !           404: /* xpopnames :: pop values from bindstack, but look out for
        !           405:  *  closure markers.  This is  used (instead of the faster popnames)
        !           406:  * when we know there will be closure markers or when we can't
        !           407:  * be sure that there won't be closure markers (eg. in non-local go's)
        !           408:  */
        !           409: xpopnames(llimit)
        !           410: register struct nament *llimit;
        !           411: {
        !           412:     register struct nament *rnp, *lbnp;
        !           413:     lispval atm_dtpr, value_dtpr;
        !           414:     int foundc;
        !           415: 
        !           416:     for(rnp = bnp; --rnp >= llimit;)
        !           417:     {
        !           418:         if(rnp->atm == clos_marker)
        !           419:        {
        !           420:            atm_dtpr = rnp->val;
        !           421:            value_dtpr = atm_dtpr->d.cdr;
        !           422:            if(value_dtpr->d.cdr->i <= 1)
        !           423:            {
        !           424:                /* this is the only occurance of this closure variable
        !           425:                 * just restore current value to this closure.
        !           426:                 */
        !           427:                value_dtpr->d.car = atm_dtpr->d.car->a.clb;
        !           428:            }
        !           429:            else {
        !           430:                /* locate the last lambda before the next occurance of
        !           431:                 * this closure and store the current symbol's value
        !           432:                 * there
        !           433:                 */
        !           434:                lbnp = locatevar(atm_dtpr,&foundc,rnp-2);
        !           435:                if(!foundc)
        !           436:                {
        !           437:                    /* strange, there wasn't a closure to be found.
        !           438:                     * well, we will fix things up so the count is
        !           439:                     * right.
        !           440:                     */
        !           441:                    value_dtpr->d.car = atm_dtpr->d.car->a.clb;
        !           442:                    value_dtpr->d.cdr->i = 1;
        !           443:                }
        !           444:                else if (lbnp) {
        !           445:                    /* note how the closures value isn't necessarily
        !           446:                     * stored in the closure, it may be stored on
        !           447:                     * the bindstack
        !           448:                     */
        !           449:                    lbnp->val = atm_dtpr->d.car->a.clb;
        !           450:                }
        !           451:                /* the case where lbnp is 0 should never happen, but
        !           452:                   if it does, we can just do nothing safely
        !           453:                 */
        !           454:            }
        !           455:            value_dtpr->d.cdr->i -= 1;
        !           456:        } else rnp->atm->a.clb = rnp->val;  /* the normal case */
        !           457:     }
        !           458:     bnp = llimit;
        !           459: }
        !           460: 
        !           461: 
        !           462: struct nament *
        !           463: locatevar(clos,foundc,rnp)
        !           464: struct nament *rnp;
        !           465: lispval clos;
        !           466: int *foundc;
        !           467: {
        !           468:     register struct nament  *retbnp;
        !           469:     lispval symb;
        !           470: 
        !           471:     retbnp = (struct nament *) 0;
        !           472:     *foundc = 0;
        !           473:     
        !           474:     symb = clos->d.car;
        !           475:     
        !           476:     for(  ; rnp >= orgbnp ; rnp--)
        !           477:     {
        !           478:        if((rnp->atm == clos_marker) && (rnp->val == clos))
        !           479:        {
        !           480:            *foundc = 1;        /* found the closure */
        !           481:            return(retbnp);
        !           482:        }
        !           483:        if(rnp->atm == symb) retbnp = rnp;
        !           484:     }
        !           485:     return(retbnp);    
        !           486: }
        !           487: 
        !           488: lispval
        !           489: LIfss()
        !           490: {
        !           491:        register lispval atm_dtpr, value_dtpr;
        !           492:        struct nament *oldbnp = bnp, *lbnp;
        !           493:        int tcase, foundc = 0;
        !           494:        lispval newval;
        !           495:        int argc = 1;
        !           496:        Savestack(2);
        !           497: 
        !           498:        switch(np-lbot) {
        !           499:        case 2:
        !           500:                newval = np[-1].val;
        !           501:                argc++;
        !           502:        case 1:
        !           503:                atm_dtpr = lbot->val;
        !           504:                value_dtpr = atm_dtpr->d.cdr;
        !           505:                break;
        !           506:        default:
        !           507:                argerr("int:fclosure-symbol-stuff");
        !           508:        }
        !           509:        /* this code is copied from Ifclosure */
        !           510: 
        !           511:        if(value_dtpr->d.cdr->i==0)
        !           512:                tcase = Case_A; /* closure is not active */
        !           513:        else {
        !           514:                lbnp = locatevar(atm_dtpr,&foundc,bnp-1);
        !           515:                if (!foundc)
        !           516:                {
        !           517:                        /* didn't find closure, count must be wrong,
        !           518:                           correct it and assume case (a).*/
        !           519:                        tcase = Case_A;
        !           520:                        value_dtpr->d.cdr->i = 0;
        !           521:                }
        !           522:                else if(lbnp) tcase = Case_C; /* found intermediate lambda*/
        !           523:                else tcase = Case_B;
        !           524:        }
        !           525: 
        !           526:        switch(tcase) {
        !           527:        case Case_B:
        !           528:                if(argc==2) return(atm_dtpr->d.car->a.clb = newval);
        !           529:                return(atm_dtpr->d.car->a.clb);
        !           530: 
        !           531:        case Case_A:
        !           532:                if(argc==2) return(value_dtpr->d.car = newval);
        !           533:                return(value_dtpr->d.car);
        !           534: 
        !           535:        case Case_C:
        !           536:                if(argc==2) return(lbnp->val = newval);
        !           537:                return(lbnp->val);
        !           538:        }
        !           539:        /*NOTREACHED*/
        !           540: }

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