UNIX 7th Ed. - /usr/src/libI77/lread.c

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

Defined functions

Defined variables

Defined macros