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