Return to lam6.c CVS log

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

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

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

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