4.3BSD - /usr/src/usr.lib/libI77/lread.c

   1: /*
   2:  * Copyright (c) 1980 Regents of the University of California.
   3:  * All rights reserved.  The Berkeley software License Agreement
   4:  * specifies the terms and conditions for redistribution.
   5:  *
   6:  *	@(#)lread.c	5.2	7/30/85
   7:  */
   8: 
   9: /*
  10:  * list directed read
  11:  */
  12: 
  13: #include "fio.h"
  14: #include "lio.h"
  15: 
  16: #define SP 1
  17: #define B  2
  18: #define AP 4
  19: #define EX 8
  20: #define D 16
  21: #define EIN 32
  22: #define isblnk(x)   (ltab[x+1]&B)   /* space, tab, newline */
  23: #define issep(x)    (ltab[x+1]&SP)  /* space, tab, newline, comma */
  24: #define isapos(x)   (ltab[x+1]&AP)  /* apost., quote mark, \02 */
  25: #define isexp(x)    (ltab[x+1]&EX)  /* d, e, D, E */
  26: #define isdigit(x)  (ltab[x+1]&D)
  27: #define endlinp(x)  (ltab[x+1]&EIN) /* EOF, newline, / */
  28: 
  29: #define GETC(x) (x=(*getn)())
  30: 
  31: LOCAL char lrd[] = "list read";
  32: LOCAL char *lchar;
  33: LOCAL double lx,ly;
  34: LOCAL int ltype;
  35: int l_read(),t_getc(),ungetc();
  36: 
  37: LOCAL char ltab[128+1] =
  38: {           EIN,        /* offset one for EOF */
  39: /*   0- 15 */   0,0,AP,0,0,0,0,0,0,SP|B,SP|B|EIN,0,0,0,0,0, /* ^B,TAB,NEWLINE */
  40: /*  16- 31 */   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  41: /*  32- 47 */   SP|B,0,AP,0,0,0,0,AP,0,0,0,0,SP,0,0,EIN, /* space,",',comma,/ */
  42: /*  48- 63 */   D,D,D,D,D,D,D,D,D,D,0,0,0,0,0,0,    /* digits 0-9 */
  43: /*  64- 79 */   0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,  /* D,E */
  44: /*  80- 95 */   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  45: /*  96-111 */   0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,  /* d,e */
  46: /* 112-127 */   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  47: };
  48: 
  49: s_rsle(a) cilist *a;    /* start read sequential list external */
  50: {
  51:     int n;
  52:     reading = YES;
  53:     formatted = LISTDIRECTED;
  54:     fmtbuf = "ext list io";
  55:     if(n=c_le(a,READ)) return(n);
  56:     l_first = YES;
  57:     lquit = NO;
  58:     lioproc = l_read;
  59:     getn = t_getc;
  60:     ungetn = ungetc;
  61:     leof = curunit->uend;
  62:     lcount = 0;
  63:     ltype = NULL;
  64:     if(curunit->uwrt && ! nowreading(curunit)) err(errflag, errno, lrd)
  65:     return(OK);
  66: }
  67: 
  68: LOCAL
  69: t_getc()
  70: {   int ch;
  71:     if(curunit->uend) return(EOF);
  72:     if((ch=getc(cf))!=EOF) return(ch);
  73:     if(feof(cf))
  74:     {   curunit->uend = YES;
  75:         leof = EOF;
  76:     }
  77:     else clearerr(cf);
  78:     return(EOF);
  79: }
  80: 
  81: e_rsle()
  82: {
  83:     int ch;
  84:     if(curunit->uend) return(EOF);
  85:     while(GETC(ch) != '\n' && ch != EOF);
  86:     return(ch==EOF?EOF:OK);
  87: }
  88: 
  89: l_read(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len;
  90: {   int i,n,ch;
  91:     double *yy;
  92:     float *xx;
  93:     for(i=0;i<*number;i++)
  94:     {
  95:         if(leof) err(endflag, EOF, lrd)
  96:         if(l_first)
  97:         {   l_first = NO;
  98:             while(isblnk(GETC(ch)));    /* skip blanks */
  99:             (*ungetn)(ch,cf);
 100:         }
 101:         else if(lcount==0)      /* repeat count == 0 ? */
 102:         {   ERR(t_sep());  /* look for non-blank, allow 1 comma */
 103:             if(lquit) return(OK);   /* slash found */
 104:         }
 105:         switch((int)type)
 106:         {
 107:         case TYSHORT:
 108:         case TYLONG:
 109:         case TYREAL:
 110:         case TYDREAL:
 111:             ERR(l_R(1));
 112:             break;
 113:         case TYCOMPLEX:
 114:         case TYDCOMPLEX:
 115:             ERR(l_C());
 116:             break;
 117:         case TYLOGICAL:
 118:             ERR(l_L());
 119:             break;
 120:         case TYCHAR:
 121:             ERR(l_CHAR());
 122:             break;
 123:         }
 124: 
 125:         /* peek at next character; it should be separator or new line */
 126:         GETC(ch); (*ungetn)(ch,cf);
 127:         if(!issep(ch) && !endlinp(ch)) {
 128:             while(GETC(ch)!= '\n' && ch != EOF);
 129:             err(errflag,F_ERLIO,lrd);
 130:         }
 131: 
 132:         if(lquit) return(OK);
 133:         if(leof) err(endflag,EOF,lrd)
 134:         else if(external && ferror(cf)) err(errflag,errno,lrd)
 135:         if(ltype) switch((int)type)
 136:         {
 137:         case TYSHORT:
 138:             ptr->flshort=lx;
 139:             break;
 140:         case TYLOGICAL:
 141:             if(len == sizeof(short))
 142:                 ptr->flshort = lx;
 143:             else
 144:                 ptr->flint = lx;
 145:             break;
 146:         case TYLONG:
 147:             ptr->flint=lx;
 148:             break;
 149:         case TYREAL:
 150:             ptr->flreal=lx;
 151:             break;
 152:         case TYDREAL:
 153:             ptr->fldouble=lx;
 154:             break;
 155:         case TYCOMPLEX:
 156:             xx=(float *)ptr;
 157:             *xx++ = ly;
 158:             *xx = lx;
 159:             break;
 160:         case TYDCOMPLEX:
 161:             yy=(double *)ptr;
 162:             *yy++ = ly;
 163:             *yy = lx;
 164:             break;
 165:         case TYCHAR:
 166:             b_char(lchar,(char *)ptr,len);
 167:             break;
 168:         }
 169:         if(lcount>0) lcount--;
 170:         ptr = (flex *)((char *)ptr + len);
 171:     }
 172:     return(OK);
 173: }
 174: 
 175: LOCAL
 176: lr_comm()
 177: {   int ch;
 178:     if(lcount) return(lcount);
 179:     ltype=NULL;
 180:     while(isblnk(GETC(ch)));
 181:     (*ungetn)(ch,cf);
 182:     if(ch==',')
 183:     {   lcount=1;
 184:         return(lcount);
 185:     }
 186:     if(ch=='/')
 187:     {   lquit = YES;
 188:         return(lquit);
 189:     }
 190:     else
 191:         return(OK);
 192: }
 193: 
 194: LOCAL
 195: get_repet()
 196: {   char ch;
 197:     double lc;
 198:     if(isdigit(GETC(ch)))
 199:     {   (*ungetn)(ch,cf);
 200:         rd_int(&lc);
 201:         lcount = (int)lc;
 202:         if(GETC(ch)!='*')
 203:             if(leof) return(EOF);
 204:             else return(F_ERREPT);
 205:     }
 206:     else
 207:     {   lcount = 1;
 208:         (*ungetn)(ch,cf);
 209:     }
 210:     return(OK);
 211: }
 212: 
 213: LOCAL
 214: l_R(flg) int flg;
 215: {   double a,b,c,d;
 216:     int da,db,dc,dd;
 217:     int i,ch,sign=0;
 218:     a=b=c=d=0;
 219:     da=db=dc=dd=0;
 220: 
 221:     if( flg )       /* real */
 222:     {
 223:         if(lr_comm()) return(OK);
 224:         da=rd_int(&a);  /* repeat count ? */
 225:         if(GETC(ch)=='*')
 226:         {
 227:             if (a <= 0.) return(F_ERNREP);
 228:             lcount=(int)a;
 229:             if (nullfld()) return(OK);  /* could be R* */
 230:             db=rd_int(&b);  /* whole part of number */
 231:         }
 232:         else
 233:         {   (*ungetn)(ch,cf);
 234:             db=da;
 235:             b=a;
 236:             lcount=1;
 237:         }
 238:     }
 239:     else           /* complex */
 240:     {
 241:         db=rd_int(&b);
 242:     }
 243: 
 244:     if(GETC(ch)=='.' && isdigit(GETC(ch)))
 245:     {   (*ungetn)(ch,cf);
 246:         dc=rd_int(&c);  /* fractional part of number */
 247:     }
 248:     else
 249:     {   (*ungetn)(ch,cf);
 250:         dc=0;
 251:         c=0.;
 252:     }
 253:     if(isexp(GETC(ch)))
 254:         dd=rd_int(&d);  /* exponent */
 255:     else if (ch == '+' || ch == '-')
 256:     {   (*ungetn)(ch,cf);
 257:         dd=rd_int(&d);
 258:     }
 259:     else
 260:     {   (*ungetn)(ch,cf);
 261:         dd=0;
 262:     }
 263:     if(db<0 || b<0)
 264:     {   sign=1;
 265:         b = -b;
 266:     }
 267:     for(i=0;i<dc;i++) c/=10.;
 268:     b=b+c;
 269:     if (dd > 0)
 270:     {   for(i=0;i<d;i++) b *= 10.;
 271:         for(i=0;i< -d;i++) b /= 10.;
 272:     }
 273:     lx=sign?-b:b;
 274:     ltype=TYLONG;
 275:     return(OK);
 276: }
 277: 
 278: LOCAL
 279: rd_int(x) double *x;
 280: {   int ch,sign=0,i=0;
 281:     double y=0.0;
 282:     if(GETC(ch)=='-') sign = -1;
 283:     else if(ch=='+') sign=0;
 284:     else (*ungetn)(ch,cf);
 285:     while(isdigit(GETC(ch)))
 286:     {   i++;
 287:         y=10*y + ch-'0';
 288:     }
 289:     (*ungetn)(ch,cf);
 290:     if(sign) y = -y;
 291:     *x = y;
 292:     return(y==0.0?sign:i); /* 0:[+]&&y==0, -1:-&&y==0, >0:#digits&&y!=0 */
 293: }
 294: 
 295: LOCAL
 296: l_C()
 297: {   int ch,n;
 298:     if(lr_comm()) return(OK);
 299:     if(n=get_repet()) return(n);        /* get repeat count */
 300:     if (nullfld()) return(OK);      /* could be R* */
 301:     if(GETC(ch)!='(') err(errflag,F_ERLIO,"no (")
 302:     while(isblnk(GETC(ch)));
 303:     (*ungetn)(ch,cf);
 304:     l_R(0);     /* get real part */
 305:     ly = lx;
 306:     if(t_sep()) return(EOF);
 307:     l_R(0);     /* get imag part */
 308:     while(isblnk(GETC(ch)));
 309:     if(ch!=')') err(errflag,F_ERLIO,"no )")
 310:     ltype = TYCOMPLEX;
 311:     return(OK);
 312: }
 313: 
 314: LOCAL
 315: l_L()
 316: {
 317:     int ch,n;
 318:     if(lr_comm()) return(OK);
 319:     if(n=get_repet()) return(n);        /* get repeat count */
 320:     if (nullfld()) return(OK);      /* could be R* */
 321:     if(GETC(ch)=='.') GETC(ch);
 322:     switch(ch)
 323:     {
 324:     case 't':
 325:     case 'T':
 326:         lx=1;
 327:         break;
 328:     case 'f':
 329:     case 'F':
 330:         lx=0;
 331:         break;
 332:     default:
 333:         if(issep(ch))
 334:         {   (*ungetn)(ch,cf);
 335:             lx=0;
 336:             return(OK);
 337:         }
 338:         else if(ch==EOF) return(EOF);
 339:         else    err(errflag,F_ERLIO,"logical not T or F");
 340:     }
 341:     ltype=TYLOGICAL;
 342:     while(!issep(GETC(ch)) && !endlinp(ch));
 343:     (*ungetn)(ch,cf);
 344:     return(OK);
 345: }
 346: 
 347: #define BUFSIZE 128
 348: LOCAL
 349: l_CHAR()
 350: {   int ch,size,i,n;
 351:     char quote,*p;
 352:     if(lr_comm()) return(OK);
 353:     if(n=get_repet()) return(n);        /* get repeat count */
 354:     if (nullfld()) return(OK);      /* could be R* */
 355:     if(isapos(GETC(ch))) quote=ch;
 356:     else if(issep(ch) || ch==EOF || ch=='\n')
 357:     {   if(ch==EOF) return(EOF);
 358:         (*ungetn)(ch,cf);
 359:         return(OK);
 360:     }
 361:     else
 362:     {   quote = '\0';   /* to allow single word non-quoted */
 363:         (*ungetn)(ch,cf);
 364:     }
 365:     ltype=TYCHAR;
 366:     if(lchar!=NULL) free(lchar);
 367:     size=BUFSIZE-1;
 368:     p=lchar=(char *)malloc(BUFSIZE);
 369:     if(lchar==NULL) err(errflag,F_ERSPACE,lrd)
 370:     for(i=0;;)
 371:     {   while( ( (quote && GETC(ch)!=quote) ||
 372:             (!quote && !issep(GETC(ch)) && !endlinp(ch)) )
 373:             && ch!='\n' && ch!=EOF && ++i<size )
 374:                 *p++ = ch;
 375:         if(i==size)
 376:         {
 377:         newone:
 378:             size += BUFSIZE;
 379:             lchar=(char *)realloc(lchar, size+1);
 380:             if(lchar==NULL) err(errflag,F_ERSPACE,lrd)
 381:             p=lchar+i-1;
 382:             *p++ = ch;
 383:         }
 384:         else if(ch==EOF) return(EOF);
 385:         else if(ch=='\n')
 386:         {   if(*(p-1) == '\\') *(p-1) = ch;
 387:             else if(!quote)
 388:             {   *p = '\0';
 389:                 (*ungetn)(ch,cf);
 390:                 return(OK);
 391:             }
 392:         }
 393:         else if(quote && GETC(ch)==quote)
 394:         {   if(++i<size) *p++ = ch;
 395:             else goto newone;
 396:         }
 397:         else
 398:         {   (*ungetn)(ch,cf);
 399:             *p = '\0';
 400:             return(OK);
 401:         }
 402:     }
 403: }
 404: 
 405: LOCAL
 406: t_sep()
 407: {
 408:     int ch;
 409:     while(isblnk(GETC(ch)));
 410:     if(leof) return(EOF);
 411:     if(ch=='/')
 412:     {   lquit = YES;
 413:         (*ungetn)(ch,cf);
 414:         return(OK);
 415:     }
 416:     if(issep(ch)) while(isblnk(GETC(ch)));
 417:     if(leof) return(EOF);
 418:     (*ungetn)(ch,cf);
 419:     return(OK);
 420: }
 421: 
 422: LOCAL
 423: nullfld()   /* look for null field following a repeat count */
 424: {
 425:     int ch;
 426: 
 427:     GETC(ch);
 428:     (*ungetn)(ch,cf);
 429:     if (issep(ch) || endlinp(ch))
 430:         return(YES);
 431:     return(NO);
 432: }

Defined functions

Defined variables

Defined macros