Return to lread.c CVS log

Up to [CSRG BSD Unix] / 3BSD / libI77

Annotation of 3BSD/libI77/lread.c, revision 1.1

1.1     ! root        1: #include "fio.h"
        !             2: #include "fmt.h"
        !             3: #include "lio.h"
        !             4: #include "ctype.h"
        !             5: extern char *fmtbuf;
        !             6: int (*lioproc)();
        !             7: 
        !             8: #define isblnk(x) (ltab[x+1]&B)
        !             9: #define issep(x) (ltab[x+1]&SX)
        !            10: #define isapos(x) (ltab[x+1]&AX)
        !            11: #define isexp(x) (ltab[x+1]&EX)
        !            12: #define issign(x) (ltab[x+1]&SG)
        !            13: #define SX 1
        !            14: #define B 2
        !            15: #define AX 4
        !            16: #define EX 8
        !            17: #define SG 16
        !            18: char ltab[128+1] = {   /* offset one for EOF */
        !            19:        0,
        !            20:        0,0,AX,0,0,0,0,0,0,0,SX,0,0,0,0,0,
        !            21:        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
        !            22:        SX|B,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
        !            23:        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
        !            24:        0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
        !            25:        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
        !            26:        AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
        !            27:        0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
        !            28: };
        !            29: 
        !            30: char l_comma, l_first;
        !            31: t_getc()
        !            32: {      int ch;
        !            33:        if(curunit->uend) return(EOF);
        !            34:        if((ch=getc(cf))!=EOF) return(ch);
        !            35:        if(feof(cf)) curunit->uend = 1;
        !            36:        return(EOF);
        !            37: }
        !            38: e_rsle()
        !            39: {
        !            40:        int ch;
        !            41:        if(curunit->uend) return(0);
        !            42:        while((ch=t_getc())!='\n' && ch!=EOF);
        !            43:        return(0);
        !            44: }
        !            45: 
        !            46: flag lquit;
        !            47: int lcount,ltype;
        !            48: char *lchar;
        !            49: double lx,ly;
        !            50: #define ERR(x) if(n=(x)) return(n)
        !            51: #define GETC(x) (x=t_getc())
        !            52: 
        !            53: l_read(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len;
        !            54: {      int i,n,ch;
        !            55:        double *yy;
        !            56:        float *xx;
        !            57:        for(i=0;i<*number;i++)
        !            58:        {
        !            59:                if(lquit) return(0);
        !            60:                if(curunit->uend) err(elist->ciend, EOF, "list in")
        !            61:                if(lcount == 0) {
        !            62:                        ltype = NULL;
        !            63:                        if(!l_first) l_comma = 0;
        !            64:                        else l_first = 0;
        !            65:                        for(;;)  {
        !            66:                                GETC(ch);
        !            67:                                switch(ch) {
        !            68:                                case EOF:
        !            69:                                        goto loopend;
        !            70:                                case ' ':
        !            71:                                case '\n':
        !            72:                                        continue;
        !            73:                                case '/':
        !            74:                                        lquit = 1;
        !            75:                                        goto loopend;
        !            76:                                case ',':
        !            77:                                        if(l_comma) {
        !            78:                                                lcount = 1;
        !            79:                                                ungetc(ch, cf);
        !            80:                                                goto loopend;
        !            81:                                        }
        !            82:                                        l_comma = 1;
        !            83:                                        continue;
        !            84:                                default:
        !            85:                                        ungetc(ch, cf);
        !            86:                                        goto rddata;
        !            87:                                }
        !            88:                        }
        !            89:                }
        !            90:        rddata:
        !            91:                switch((int)type)
        !            92:                {
        !            93:                case TYSHORT:
        !            94:                case TYLONG:
        !            95:                case TYREAL:
        !            96:                case TYDREAL:
        !            97:                        ERR(l_R());
        !            98:                        break;
        !            99:                case TYCOMPLEX:
        !           100:                case TYDCOMPLEX:
        !           101:                        ERR(l_C());
        !           102:                        break;
        !           103:                case TYLOGICAL:
        !           104:                        ERR(l_L());
        !           105:                        break;
        !           106:                case TYCHAR:
        !           107:                        ERR(l_CHAR());
        !           108:                        break;
        !           109:                }
        !           110:        loopend:
        !           111:                if(lquit) return(0);
        !           112:                if(feof(cf)) err(elist->ciend,(EOF),"list in")
        !           113:                else if(ferror(cf))
        !           114:                {       clearerr(cf);
        !           115:                        err(elist->cierr,errno,"list in")
        !           116:                }
        !           117:                if(ltype==NULL) goto bump;
        !           118:                switch((int)type)
        !           119:                {
        !           120:                case TYSHORT:
        !           121:                        ptr->flshort=lx;
        !           122:                        break;
        !           123:                case TYLOGICAL:
        !           124:                case TYLONG:
        !           125:                        ptr->flint=lx;
        !           126:                        break;
        !           127:                case TYREAL:
        !           128:                        ptr->flreal=lx;
        !           129:                        break;
        !           130:                case TYDREAL:
        !           131:                        ptr->fldouble=lx;
        !           132:                        break;
        !           133:                case TYCOMPLEX:
        !           134:                        xx=(float *)ptr;
        !           135:                        *xx++ = lx;
        !           136:                        *xx = ly;
        !           137:                        break;
        !           138:                case TYDCOMPLEX:
        !           139:                        yy=(double *)ptr;
        !           140:                        *yy++ = lx;
        !           141:                        *yy = ly;
        !           142:                        break;
        !           143:                case TYCHAR:
        !           144:                        b_char(lchar,(char *)ptr,len);
        !           145:                        break;
        !           146:                }
        !           147:        bump:
        !           148:                if(lcount>0) lcount--;
        !           149:                ptr = (flex *)((char *)ptr + len);
        !           150:        }
        !           151:        return(0);
        !           152: }
        !           153: l_R()
        !           154: {      double a,b,c,d;
        !           155:        int i,ch,sign=0,da,db,dc;
        !           156:        a=b=c=d=0;
        !           157:        da=db=dc=0;
        !           158:        if(lcount>0) return(0);
        !           159:        ltype=NULL;
        !           160:        da=rd_int(&a);
        !           161:        if(da== -1) sign=da;
        !           162:        if(GETC(ch)!='*')
        !           163:        {       ungetc(ch,cf);
        !           164:                db=1;
        !           165:                b=a;
        !           166:                a=1;
        !           167:        }
        !           168:        else
        !           169:                db=rd_int(&b);
        !           170:        if(GETC(ch)!='.')
        !           171:        {       dc=c=0;
        !           172:                ungetc(ch,cf);
        !           173:        }
        !           174:        else    dc=rd_int(&c);
        !           175:        if(isexp(GETC(ch))) db=rd_int(&d);
        !           176:        else if(issign(ch))
        !           177:        {       ungetc(ch, cf);
        !           178:                db = rd_int(&d);
        !           179:        }
        !           180:        else
        !           181:        {       ungetc(ch,cf);
        !           182:                d=0;
        !           183:        }
        !           184:        lcount=a;
        !           185:        if(!db && !dc)
        !           186:                return(0);
        !           187:        if(db && b<0)
        !           188:        {       sign=1;
        !           189:                b = -b;
        !           190:        }
        !           191:        for(i=0;i<dc;i++) c/=10;
        !           192:        b=b+c;
        !           193:        for(i=0;i<d;i++) b *= 10;
        !           194:        for(i=0;i< -d;i++) b /= 10;
        !           195:        if(sign) b = -b;
        !           196:        ltype=TYLONG;
        !           197:        lx=b;
        !           198:        return(0);
        !           199: }
        !           200: rd_int(x) double *x;
        !           201: {      int ch,sign=0,i;
        !           202:        double y;
        !           203:        i=0;
        !           204:        y=0;
        !           205:        if(GETC(ch)=='-') sign = -1;
        !           206:        else if(ch=='+') sign=0;
        !           207:        else ungetc(ch,cf);
        !           208:        while(isdigit(GETC(ch)))
        !           209:        {       i++;
        !           210:                y=10*y+ch-'0';
        !           211:        }
        !           212:        ungetc(ch,cf);
        !           213:        if(sign) y = -y;
        !           214:        *x = y;
        !           215:        return(y!=0?i:sign);
        !           216: }
        !           217: l_C()
        !           218: {      int ch;
        !           219:        if(lcount>0) return(0);
        !           220:        ltype=NULL;
        !           221:        GETC(ch);
        !           222:        if(ch!='(')
        !           223:        {       if(fscanf(cf,"%d",&lcount)!=1)
        !           224:                        if(!feof(cf)) err(elist->cierr,112,"complex format")
        !           225:                        else err(elist->cierr,(EOF),"lread");
        !           226:                if(GETC(ch)!='*')
        !           227:                {       ungetc(ch,cf);
        !           228:                        if(!feof(cf)) err(elist->cierr,112,"no star")
        !           229:                        else err(elist->cierr,(EOF),"lread");
        !           230:                }
        !           231:                if(GETC(ch)!='(')
        !           232:                {       ungetc(ch,cf);
        !           233:                        return(0);
        !           234:                }
        !           235:        }
        !           236:        lcount = 1;
        !           237:        ltype=TYLONG;
        !           238:        fscanf(cf,"%lf",&lx);
        !           239:        while(isblnk(GETC(ch)) || (ch == '\n'));
        !           240:        if(ch!=',')
        !           241:        {       ungetc(ch,cf);
        !           242:                err(elist->cierr,112,"no comma");
        !           243:        }
        !           244:        while(isblnk(GETC(ch)));
        !           245:        ungetc(ch,cf);
        !           246:        fscanf(cf,"%lf",&ly);
        !           247:        while(isblnk(GETC(ch)));
        !           248:        if(ch!=')') err(elist->cierr,112,"no )");
        !           249:        while(isblnk(GETC(ch)));
        !           250:        if(ch != '\n') ungetc(ch,cf);
        !           251:        return(0);
        !           252: }
        !           253: l_L()
        !           254: {
        !           255:        int ch;
        !           256:        if(lcount>0) return(0);
        !           257:        ltype=NULL;
        !           258:        GETC(ch);
        !           259:        if(isdigit(ch))
        !           260:        {       ungetc(ch,cf);
        !           261:                fscanf(cf,"%d",&lcount);
        !           262:                if(GETC(ch)!='*')
        !           263:                        if(!feof(cf)) err(elist->cierr,112,"no star")
        !           264:                        else err(elist->cierr,(EOF),"lread");
        !           265:        }
        !           266:        else    ungetc(ch,cf);
        !           267:        if(GETC(ch)=='.') GETC(ch);
        !           268:        switch(ch)
        !           269:        {
        !           270:        case 't':
        !           271:        case 'T':
        !           272:                lx=1;
        !           273:                break;
        !           274:        case 'f':
        !           275:        case 'F':
        !           276:                lx=0;
        !           277:                break;
        !           278:        default:
        !           279:                if(isblnk(ch) || issep(ch) || ch==EOF)
        !           280:                {       ungetc(ch,cf);
        !           281:                        return(0);
        !           282:                }
        !           283:                else    err(elist->cierr,112,"logical");
        !           284:        }
        !           285:        ltype=TYLONG;
        !           286:        lcount = 1;
        !           287:        while(!issep(GETC(ch)) && ch!=EOF);
        !           288:        ungetc(ch, cf);
        !           289:        return(0);
        !           290: }
        !           291: #define BUFSIZE        128
        !           292: l_CHAR()
        !           293: {      int ch,size,i;
        !           294:        char quote,*p;
        !           295:        if(lcount>0) return(0);
        !           296:        ltype=NULL;
        !           297: 
        !           298:        GETC(ch);
        !           299:        if(isdigit(ch))
        !           300:        {       ungetc(ch,cf);
        !           301:                fscanf(cf,"%d",&lcount);
        !           302:                if(GETC(ch)!='*') err(elist->cierr,112,"no star");
        !           303:        }
        !           304:        else    ungetc(ch,cf);
        !           305:        if(GETC(ch)=='\'' || ch=='"') quote=ch;
        !           306:        else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
        !           307:        {       ungetc(ch,cf);
        !           308:                return(0);
        !           309:        }
        !           310:        else err(elist->cierr,112,"no quote");
        !           311:        ltype=TYCHAR;
        !           312:        if(lchar!=NULL) free(lchar);
        !           313:        size=BUFSIZE;
        !           314:        p=lchar=(char *)malloc(size);
        !           315:        if(lchar==NULL) err(elist->cierr,113,"no space");
        !           316:        for(i=0;;)
        !           317:        {       while(GETC(ch)!=quote && ch!='\n'
        !           318:                        && ch!=EOF && ++i<size) *p++ = ch;
        !           319:                if(i==size)
        !           320:                {
        !           321:                newone:
        !           322:                        lchar=(char *)realloc(lchar, size += BUFSIZE);
        !           323:                        p=lchar+i-1;
        !           324:                        *p++ = ch;
        !           325:                }
        !           326:                else if(ch==EOF) return(EOF);
        !           327:                else if(ch=='\n')
        !           328:                {       if(*(p-1) != '\\') continue;
        !           329:                        i--;
        !           330:                        p--;
        !           331:                        if(++i<size) *p++ = ch;
        !           332:                        else goto newone;
        !           333:                }
        !           334:                else if(GETC(ch)==quote)
        !           335:                {       if(++i<size) *p++ = ch;
        !           336:                        else goto newone;
        !           337:                }
        !           338:                else
        !           339:                {       ungetc(ch,cf);
        !           340:                        *p++ = 0;
        !           341:                        return(0);
        !           342:                }
        !           343:        }
        !           344: }
        !           345: s_rsle(a) cilist *a;
        !           346: {
        !           347:        int n;
        !           348:        if(!init) f_init();
        !           349:        if(n=c_le(a,READ)) return(n);
        !           350:        reading=1;
        !           351:        external=1;
        !           352:        formatted=1;
        !           353:        l_first=1;
        !           354:        l_comma = 1;
        !           355:        lioproc = l_read;
        !           356:        lquit = 0;
        !           357:        lcount = 0;
        !           358:        if(curunit->uwrt)
        !           359:                return(nowreading(curunit));
        !           360:        else    return(0);
        !           361: }
        !           362: c_le(a,flag) cilist *a;
        !           363: {
        !           364:        fmtbuf="list io";
        !           365:        if(a->ciunit>=MXUNIT || a->ciunit<0)
        !           366:                err(a->cierr,101,"stler");
        !           367:        scale=recpos=0;
        !           368:        elist=a;
        !           369:        curunit = &units[a->ciunit];
        !           370:        if(curunit->ufd==NULL && fk_open(flag,SEQ,FMT,a->ciunit))
        !           371:                err(a->cierr,102,"lio");
        !           372:        cf=curunit->ufd;
        !           373:        if(!curunit->ufmt) err(a->cierr,103,"lio")
        !           374:        return(0);
        !           375: }
        !           376: do_lio(type,number,ptr,len) ftnint *number,*type; flex *ptr; ftnlen len;
        !           377: {
        !           378:        return((*lioproc)(number,ptr,len,*type));
        !           379: }

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