Return to lam6.c CVS log

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

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

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: lam6.c,v 1.7 85/03/24 11:04:21 sklower Exp $";
        !             4: #endif
        !             5: 
        !             6: /*                                     -[Sun Sep  4 08:56:19 1983 by jkf]-
        !             7:  *     lam6.c                          $Locker:  $
        !             8:  * lambda functions
        !             9:  *
        !            10:  * (c) copyright 1982, Regents of the University of California
        !            11:  */
        !            12: 
        !            13: #include "global.h"
        !            14: #include "frame.h"
        !            15: #include <signal.h>
        !            16: #include <sys/types.h>
        !            17: #include <sys/times.h>
        !            18: #include "chkrtab.h"
        !            19: #include "chars.h"
        !            20: 
        !            21: 
        !            22: lispval
        !            23: Lreadli()
        !            24: {
        !            25:        register lispval work, handy;
        !            26:        register FILE *p;
        !            27:        register char *string; char *alloca();
        !            28:        FILE *fstopen();
        !            29:        lispval Lread();
        !            30:        int count;
        !            31:        pbuf pb;
        !            32:        Savestack(4);
        !            33: #ifdef SPISFP
        !            34:        Keepxs();
        !            35: #endif
        !            36: 
        !            37:        if(lbot->val==nil) {            /*effectively, return(matom(""));*/
        !            38:                strbuf[0] = 0;
        !            39:                return(getatom(FALSE));
        !            40:        }
        !            41:        chkarg(1,"readlist");
        !            42:        count = 1;
        !            43: 
        !            44:        /* compute length of list */
        !            45:        for(work = lbot->val; TYPE(work)==DTPR; work=work->d.cdr)
        !            46:                count++;
        !            47:        string = alloca(count);
        !            48:        p = fstopen(string, count - 1, "r");
        !            49:        for(work = lbot->val; TYPE(work)==DTPR; work=work->d.cdr) {
        !            50:                handy = work->d.car;
        !            51:                switch(TYPE(handy)) {
        !            52:                case SDOT:
        !            53:                case INT:
        !            54:                        *string++=handy->i;
        !            55:                        break;
        !            56:                case ATOM:
        !            57:                        *string++ = *(handy->a.pname);
        !            58:                        break;
        !            59:                case STRNG:
        !            60:                        *string++ = *(char *)handy;
        !            61:                        break;
        !            62:                default:
        !            63:                        fclose(p);
        !            64:                        error("Non atom or int to readlist",FALSE);
        !            65:                }
        !            66:        }
        !            67:        *string = 0;
        !            68:        errp = Pushframe(F_CATCH,Veruwpt,nil);  /* must unwind protect
        !            69:                                                   so can deallocate p
        !            70:                                                 */
        !            71:        switch(retval) { lispval Lctcherr();
        !            72:        case C_THROW:
        !            73:                        /* an error has occured and we are given a chance
        !            74:                           to unwind before the control goes higher
        !            75:                           lispretval contains the error descriptor in
        !            76:                           it's cdr
        !            77:                         */
        !            78:                      fclose(p);        /* free port */
        !            79:                      errp = Popframe();
        !            80:                      Freexs();
        !            81:                      lbot = np;
        !            82:                      protect(lispretval->d.cdr); /* error descriptor */
        !            83:                      return(Lctcherr());       /* do a I-do-throw */
        !            84:                      
        !            85:        case C_INITIAL: 
        !            86:                        lbot = np;
        !            87:                        protect(P(p));
        !            88:                        work = Lread();  /* error  could occur here */
        !            89:                        Freexs();
        !            90:                        fclose(p);      /* whew.. no errors */
        !            91:                        errp = Popframe();      /* remove unwind-protect */
        !            92:                        Restorestack();
        !            93:                        return(work);
        !            94:        }
        !            95:        /* NOTREACHED */
        !            96: }
        !            97: 
        !            98: lispval
        !            99: Lgetenv()
        !           100: {
        !           101:        char *getenv(), *strcpy();
        !           102:        char *res;
        !           103:        chkarg(1,"getenv");
        !           104:        
        !           105: 
        !           106:        if((TYPE(lbot->val))!=ATOM)
        !           107:                error("argument to getenv must be atom",FALSE);
        !           108: 
        !           109:        res = getenv(lbot->val->a.pname);
        !           110:        if(res) strcpy(strbuf,res);
        !           111:        else strbuf[0] = '\0';
        !           112:        return(getatom(FALSE));
        !           113: }
        !           114: 
        !           115: lispval
        !           116: Lboundp()
        !           117: {
        !           118:        register lispval result, handy;
        !           119: 
        !           120:        chkarg(1,"boundp");
        !           121: 
        !           122:        if((TYPE(lbot->val))!=ATOM)
        !           123:                error("argument to boundp must be symbol",FALSE);
        !           124:        if( (handy = lbot->val)->a.clb==CNIL)
        !           125:                result = nil;
        !           126:        else
        !           127:                (result = newdot())->d.cdr = handy->a.clb;
        !           128:        return(result);
        !           129: }
        !           130: 
        !           131: 
        !           132: lispval
        !           133: Lplist()
        !           134: {      
        !           135:        register lispval atm;
        !           136:        /* get property list of an atom or disembodied property list */
        !           137: 
        !           138:        chkarg(1,"plist");
        !           139:        atm = lbot->val;
        !           140:        switch(TYPE(atm)) {
        !           141:        case ATOM:
        !           142:        case DTPR:
        !           143:                break;
        !           144:        default:
        !           145:                error("Only Atoms and disembodied property lists allowed for plist",FALSE);
        !           146:        }
        !           147:        if(atm==nil) return(nilplist);
        !           148:        return(atm->a.plist);
        !           149: }
        !           150: 
        !           151: 
        !           152: lispval
        !           153: Lsetpli()
        !           154: {      /* set the property list of the given atom to the given list */
        !           155:        register lispval atm, vall;
        !           156: 
        !           157:        chkarg(2,"setplist");
        !           158:        atm = lbot->val;
        !           159:        if (TYPE(atm) != ATOM) 
        !           160:           error("setplist: First argument must be an symbol",FALSE);
        !           161:        vall = (np-1)->val;
        !           162:        if (TYPE(vall)!= DTPR && vall !=nil)
        !           163:            error("setplist: Second argument must be a list",FALSE);
        !           164:        if (atm==nil)
        !           165:                nilplist = vall;
        !           166:        else
        !           167:                atm->a.plist = vall;
        !           168:        return(vall);
        !           169: }
        !           170: 
        !           171: lispval
        !           172: Lsignal()
        !           173: {
        !           174:        register lispval handy, old, routine;
        !           175:        int i;
        !           176:        int sginth();
        !           177: 
        !           178:        switch(np-lbot) {
        !           179: 
        !           180:        case 1: routine = nil;          /* second arg defaults to nil */
        !           181:                break;
        !           182: 
        !           183:        case 2: routine = lbot[1].val;
        !           184:                break;                  /* both args given              */
        !           185: 
        !           186:        default: argerr("signal");
        !           187:        }
        !           188: 
        !           189:        handy = lbot->val;
        !           190:        if(TYPE(handy)!=INT)
        !           191:                error("First arg to signal must be an int",FALSE);
        !           192:        i = handy->i & 15;
        !           193: 
        !           194:        if(TYPE(routine)!=ATOM)
        !           195:                error("Second arg to signal must be an atom",FALSE);
        !           196:        old = sigacts[i];
        !           197: 
        !           198:        if(old==0) old = nil;
        !           199: 
        !           200:        if(routine==nil)
        !           201:                sigacts[i]=((lispval) 0);
        !           202:        else
        !           203:                sigacts[i]=routine;
        !           204:        if(routine == nil)
        !           205:            signal(i,SIG_IGN);  /* ignore this signals */
        !           206:        else if (old == nil)
        !           207:            signal(i,sginth);   /* look for this signal */
        !           208:        if(i == SIGINT) sigintcnt = 0; /* clear memory */
        !           209:        return(old);
        !           210: }
        !           211: 
        !           212: lispval
        !           213: Lassq()
        !           214: {
        !           215:        register lispval work, handy;
        !           216: 
        !           217:        chkarg(2,"assq");
        !           218: 
        !           219:        for(work = lbot[1].val, handy = lbot[0].val; 
        !           220:            (work->d.car->d.car != handy) && (work != nil);
        !           221:            work = work->d.cdr);
        !           222:        return(work->d.car);
        !           223: }
        !           224: 
        !           225: lispval
        !           226: Lkilcopy()
        !           227: {
        !           228:        if(fork()==0) {
        !           229:                abort();
        !           230:        }
        !           231: }
        !           232: 
        !           233: lispval
        !           234: Larg()
        !           235: {
        !           236:        register lispval handy; register offset, count;
        !           237: 
        !           238:        handy = lexpr_atom->a.clb;
        !           239:        if(handy==CNIL || TYPE(handy)!=DTPR)
        !           240:                error("Arg: not in context of Lexpr.",FALSE);
        !           241:        count = ((long *)handy->d.cdr) -1 - (long *)handy->d.car;
        !           242:        if(np==lbot || lbot->val==nil)
        !           243:                return(inewint(count+1));
        !           244:        if(TYPE(lbot->val)!=INT || (offset = lbot->val->i - 1) > count || offset < 0 )
        !           245:                error("Out of bounds: arg to \"Arg\"",FALSE);
        !           246:        return( ((struct argent *)handy->d.car)[offset].val);
        !           247: }
        !           248: 
        !           249: lispval
        !           250: Lsetarg()
        !           251: {
        !           252:        register lispval handy, work;
        !           253:        register limit, index;
        !           254: 
        !           255:        chkarg(2,"setarg");
        !           256:        handy = lexpr_atom->a.clb;
        !           257:        if(handy==CNIL || TYPE(handy)!=DTPR)
        !           258:                error("Arg: not in context of Lexpr.",FALSE);
        !           259:        limit = ((long *)handy->d.cdr) - 1 -  (long *)(work = handy->d.car);
        !           260:        handy = lbot->val;
        !           261:        if(TYPE(handy)!=INT)
        !           262:                error("setarg: first argument not integer",FALSE);
        !           263:        if((index = handy->i - 1) < 0 || index > limit)
        !           264:                error("setarg: index out of range",FALSE);
        !           265:        return(((struct argent *) work)[index].val = lbot[1].val);
        !           266: }
        !           267: 
        !           268: lispval
        !           269: Lptime(){
        !           270:        extern int gctime;
        !           271:        int lgctime = gctime;
        !           272:        struct tms current;
        !           273:        register lispval result, handy;
        !           274:        Savestack(2);
        !           275: 
        !           276:        times(&current);
        !           277:        result = newdot();
        !           278:        handy = result;
        !           279:        protect(result);
        !           280:        result->d.cdr = newdot();
        !           281:        result->d.car = inewint(current.tms_utime);
        !           282:        handy = result->d.cdr;
        !           283:        handy->d.car = inewint(lgctime);
        !           284:        handy->d.cdr = nil;
        !           285:        if(gctime==0)
        !           286:                gctime = 1;
        !           287:        Restorestack();
        !           288:        return(result);
        !           289: }
        !           290: 
        !           291: /* (err-with-message message [value])
        !           292:    'message' is the error message to print.
        !           293:    'value' is the value to return from the errset (if present).
        !           294:        it defaults to nil.
        !           295:     The message may not be printed if there is an (errset ... nil)
        !           296:     pending.
        !           297:  */
        !           298: 
        !           299: lispval Lerr()
        !           300: {
        !           301:        lispval errorh();
        !           302:        lispval valret = nil;
        !           303:        char *mesg;
        !           304:        
        !           305: 
        !           306:        switch(np-lbot) {
        !           307:         case 2: valret = lbot[1].val;  /* return non nil */
        !           308:         case 1: mesg = (char *)verify(lbot[0].val,
        !           309:                                  "err-with-message: non atom or string arg");
        !           310:                 break;
        !           311:         default: argerr("err-with-message");
        !           312:        }
        !           313:        
        !           314:        return(errorh(Vererr,mesg,valret,FALSE,1));
        !           315: }
        !           316: 
        !           317: /*
        !           318:  *  (tyi ['p_port ['g_eofval]])
        !           319:  * normally -1 is return on eof, but g_eofval will be returned if given.
        !           320:  */
        !           321: lispval
        !           322: Ltyi()
        !           323: {
        !           324:        register FILE *port;
        !           325:        register lispval handy;
        !           326:        lispval eofval;
        !           327:        int val;        /* really char but getc returns int on eof */
        !           328:        int eofvalgiven;
        !           329: 
        !           330:        handy = nil;   /* default port */
        !           331:        eofvalgiven = FALSE;  /* assume no eof value given */
        !           332:        switch(np-lbot)
        !           333:        {
        !           334:            case 2:  eofval = lbot[1].val;
        !           335:                     eofvalgiven = TRUE;
        !           336:            case 1:  handy = lbot[0].val;       /* port to read */
        !           337:            case 0: 
        !           338:                     break;
        !           339:            default: argerr("tyi");
        !           340:        }
        !           341: 
        !           342:        port = okport(handy,okport(Vpiport->a.clb,stdin));
        !           343: 
        !           344: 
        !           345:        fflush(stdout);         /* flush any pending output characters */
        !           346:        val = getc(port);
        !           347:        if(val==EOF)
        !           348:        {
        !           349:                clearerr(port);
        !           350:                if(sigintcnt > 0) sigcall(SIGINT);  /* eof might mean int */
        !           351:                if(eofvalgiven) return(eofval);
        !           352:                else return(inewint(-1));
        !           353:        }
        !           354:        return(inewint(val));
        !           355: }
        !           356: 
        !           357: /* Untyi (added by DNC Feb. '80) - (untyi number port) puts the
        !           358:    character with ascii code number in the front of the input buffer of
        !           359:    port.  Note that this buffer is limited to 1 character.  That buffer is
        !           360:    also written by tyipeek, so a peek followed by an untyi will result in
        !           361:    the loss of the peeked char.
        !           362:  */
        !           363:    
        !           364: lispval
        !           365: Luntyi()
        !           366: {
        !           367: 
        !           368:     lispval port,ch;
        !           369: 
        !           370:     port = nil;
        !           371: 
        !           372:     switch(np-lbot) {
        !           373:        case 2: port = lbot[1].val;
        !           374:        case 1: ch = lbot[0].val;
        !           375:                break;
        !           376:        default:
        !           377:                argerr("untyi");
        !           378:     }
        !           379: 
        !           380:     if(TYPE(ch) != INT) {
        !           381:        errorh1(Vermisc, "untyi: expects fixnum character ",
        !           382:                                nil,FALSE,0,ch);
        !           383:     }  
        !           384: 
        !           385:     ungetc((int) ch->i,okport(port,okport(Vpiport->a.clb,stdin)));
        !           386:     return(ch);
        !           387: }
        !           388: 
        !           389: lispval
        !           390: Ltyipeek()
        !           391: {
        !           392:        register FILE *port;
        !           393:        register lispval handy;
        !           394:        int val;
        !           395: 
        !           396:        switch(np-lbot)
        !           397:        {
        !           398:            case 0:  handy = nil;       /* default port */
        !           399:                     break;
        !           400:            case 1:  handy = lbot->val;
        !           401:                     break;
        !           402:            default: argerr("tyipeek");
        !           403:        }
        !           404: 
        !           405:        port = okport(handy,okport(Vpiport->a.clb,stdin));
        !           406: 
        !           407:        fflush(stdout);         /* flush any pending output characters */
        !           408:        val = getc(port);
        !           409:        if(val==EOF)
        !           410:                clearerr(port);
        !           411:        ungetc(val,port);
        !           412:        return(inewint(val));
        !           413: }
        !           414: 
        !           415: lispval
        !           416: Ltyo()
        !           417: {
        !           418:        register FILE *port;
        !           419:        register lispval handy, where;
        !           420:        char val;
        !           421: 
        !           422:        switch(np-lbot)
        !           423:        {
        !           424:            case 1:  where = nil;       /* default port */
        !           425:                     break;
        !           426:            case 2:  where = lbot[1].val;
        !           427:                     break;
        !           428:            default: argerr("tyo");
        !           429:        }
        !           430: 
        !           431:        handy = lbot->val;
        !           432:        if(TYPE(handy)!=INT)
        !           433:                error("Tyo demands number for 1st arg",FALSE);
        !           434:        val = handy->i;
        !           435: 
        !           436:        port = (FILE *) okport(where,okport(Vpoport->a.clb,stdout));
        !           437:        putc(val,port);
        !           438:        return(handy);
        !           439: }
        !           440: 
        !           441: lispval
        !           442: Imkrtab(current)
        !           443: {
        !           444:        extern struct rtab {
        !           445:                unsigned char ctable[132];
        !           446:        } initread;
        !           447:        register lispval handy; extern lispval lastrtab;
        !           448: 
        !           449:        static int cycle = 0;
        !           450:        static char *nextfree;
        !           451:        Savestack(3);
        !           452:        
        !           453:        if((cycle++)%3==0) {
        !           454:                nextfree = (char *) csegment(STRNG,1,FALSE);
        !           455:                mrtabspace = (lispval) nextfree;
        !           456:                /* need to protect partially allocated read tables
        !           457:                   from garbage collection. */
        !           458:        }
        !           459:        handy = newarray();
        !           460:        protect(handy);
        !           461:        
        !           462:        handy->ar.data = nextfree;
        !           463:        if(current == 0)
        !           464:                *(struct rtab *)nextfree = initread;
        !           465:        else
        !           466:        {
        !           467:                register index = 0; register char *cp = nextfree;
        !           468:                lispval c;
        !           469: 
        !           470:                *(struct rtab *)cp = *(struct rtab *)ctable;
        !           471:                for(; index < 128; index++) {
        !           472:                    switch(synclass(cp[index])) {
        !           473:                    case CSPL: case CSSPL: case CMAC: case CSMAC:
        !           474:                    case CINF: case CSINF:
        !           475:                        strbuf[0] = index;
        !           476:                        strbuf[1] = 0;
        !           477:                        c = (getatom(TRUE));
        !           478:                        Iputprop(c,Iget(c,lastrtab),handy);
        !           479:                    }
        !           480:                }
        !           481:        }
        !           482:        handy->ar.delta = inewint(4);
        !           483:        handy->ar.length = inewint(sizeof(struct rtab)/sizeof(int));
        !           484:        handy->ar.accfun = handy->ar.aux  = nil;
        !           485:        nextfree += sizeof(struct rtab);
        !           486:        Restorestack();
        !           487:        return(handy);
        !           488: }
        !           489: 
        !           490: /* makereadtable - arg : t or nil
        !           491:        returns a readtable, t means return a copy of the initial readtable
        !           492: 
        !           493:                             nil means return a copy of the current readtable
        !           494: */
        !           495: lispval
        !           496: Lmakertbl()
        !           497: {
        !           498:        lispval handy = Vreadtable->a.clb;
        !           499:        lispval value;
        !           500:        chkrtab(handy);
        !           501: 
        !           502:        if(lbot==np) value = nil;
        !           503:        else if(TYPE(value=(lbot->val)) != ATOM) 
        !           504:                error("makereadtable: arg must be atom",FALSE);
        !           505: 
        !           506:        if(value == nil) return(Imkrtab(1));
        !           507:        else return(Imkrtab(0));
        !           508: }
        !           509: 
        !           510: lispval
        !           511: Lcpy1()
        !           512: {
        !           513:        register lispval handy = lbot->val, result = handy;
        !           514: 
        !           515: top:
        !           516:        switch(TYPE(handy))
        !           517:        {
        !           518:        case INT:
        !           519:                result = inewint(handy->i);
        !           520:                break;
        !           521:        case VALUE:
        !           522:                (result = newval())->l = handy->l;
        !           523:                break;
        !           524:        case DOUB:
        !           525:                (result = newdoub())->r = handy->r;
        !           526:                break;
        !           527:        default:
        !           528:                lbot->val =
        !           529:                    errorh1(Vermisc,"Bad arg to cpy1",nil,TRUE,67,handy);
        !           530:                goto top;
        !           531:        }
        !           532:        return(result);
        !           533: }
        !           534: 
        !           535: /* copyint* . This returns a copy of its integer argument.  The copy will
        !           536:  *      be a fresh integer cell, and will not point into the read only
        !           537:  *      small integer table.
        !           538:  */
        !           539: lispval
        !           540: Lcopyint()
        !           541: {
        !           542:        register lispval handy = lbot->val;
        !           543:        register lispval ret;
        !           544: 
        !           545:        while (TYPE(handy) != INT)
        !           546:        { handy=errorh1(Vermisc,"copyint* : non integer arg",nil,TRUE,0,handy);}
        !           547:        (ret = newint())->i = handy->i;
        !           548:        return(ret);
        !           549: }
        !           550: 
        !           551: 

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