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