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 07/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 } 433