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