4.3BSD - /usr/src/usr.lib/libI77/rsnmle.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:  *	@(#)rsnmle.c	5.3	8/28/85
   7:  */
   8: 
   9: /*
  10:  *		name-list read
  11:  */
  12: 
  13: #include "fio.h"
  14: #include "lio.h"
  15: #include "nmlio.h"
  16: #include <ctype.h>
  17: 
  18: LOCAL char *nml_rd;
  19: 
  20: static int ch;
  21: LOCAL nameflag;
  22: LOCAL   char var_name[VL+1];
  23: 
  24: #define SP 1
  25: #define B  2
  26: #define AP 4
  27: #define EX 8
  28: #define INTG 16
  29: #define RL 32
  30: #define LGC 64
  31: #define IRL         (INTG | RL | LGC )
  32: #define isblnk(x)   (ltab[x+1]&B)   /* space, tab, newline */
  33: #define issep(x)    (ltab[x+1]&SP)  /* space, tab, newline, comma */
  34: #define isapos(x)   (ltab[x+1]&AP)  /* apost., quote mark */
  35: #define isexp(x)    (ltab[x+1]&EX)  /* d, e, D, E */
  36: #define isint(x)    (ltab[x+1]&INTG)    /* 0-9, plus, minus */
  37: #define isrl(x)     (ltab[x+1]&RL)  /* 0-9, plus,  minus, period */
  38: #define islgc(x)    (ltab[x+1]&LGC) /* 0-9, period, t, f, T, F */
  39: 
  40: #define GETC (ch=t_getc())
  41: #define UNGETC() ungetc(ch,cf)
  42: 
  43: LOCAL char *lchar;
  44: LOCAL double lx,ly;
  45: LOCAL int ltype;
  46: int t_getc(), ungetc();
  47: 
  48: LOCAL char ltab[128+1] =
  49: {           0,      /* offset one for EOF */
  50: /*   0- 15 */ 0,0,0,0,0,0,0,0,0,SP|B,SP|B,0,0,0,0,0, /* TAB,NEWLINE */
  51: /*  16- 31 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  52: /*  32- 47 */ SP|B,0,AP,0,0,0,0,AP,0,0,0,RL|INTG,SP,RL|INTG,RL|LGC,0, /* space,",',comma,., */
  53: /*  48- 63 */ IRL,IRL,IRL,IRL,IRL,IRL,IRL,IRL,IRL,IRL,0,0,0,0,0,0, /* digits */
  54: /*  64- 79 */ 0,0,0,0,EX,EX,LGC,0,0,0,0,0,0,0,0,0,  /* D,E,F */
  55: /*  80- 95 */ 0,0,0,0,LGC,0,0,0,0,0,0,0,0,0,0,0,    /* T */
  56: /*  96-111 */ 0,0,0,0,EX,EX,LGC,0,0,0,0,0,0,0,0,0,  /* d,e,f */
  57: /* 112-127 */ 0,0,0,0,LGC,0,0,0,0,0,0,0,0,0,0,0     /* t */
  58: };
  59: 
  60: s_rsne(a) namelist_arglist *a;
  61: {
  62:     int n;
  63:     struct namelistentry *entry;
  64:     int nelem, vlen, vtype;
  65:     char *nmlist_nm, *addr;
  66: 
  67:     nml_rd = "namelist read";
  68:     reading = YES;
  69:     formatted = NAMELIST;
  70:     fmtbuf = "ext namelist io";
  71:     if(n=c_le(a,READ)) return(n);
  72:     getn = t_getc;
  73:     ungetn = ungetc;
  74:     leof = curunit->uend;
  75:     if(curunit->uwrt && ! nowreading(curunit)) err(errflag, errno, nml_rd)
  76: 
  77:     /* look for " &namelistname " */
  78:     nmlist_nm = a->namelist->namelistname;
  79:     while(isblnk(GETC)) ;
  80:     /* check for "&end" (like IBM) or "$end" (like DEC) */
  81:     if(ch != '&' && ch != '$') goto rderr;
  82:     /* save it - write out using the same character as used on input */
  83:     namelistkey_ = ch;
  84:     while( *nmlist_nm )
  85:         if( GETC != *nmlist_nm++ )
  86:             {
  87:                 nml_rd = "incorrect namelist name";
  88:                 goto rderr;
  89:             }
  90:     if(!isblnk(GETC)) goto rderr;
  91:     while(isblnk(GETC)) ;
  92:     if(leof) goto rderr;
  93:     UNGETC();
  94: 
  95:     while( GETC != namelistkey_ )
  96:     {
  97:         UNGETC();
  98:         /* get variable name */
  99:         if(!nameflag && rd_name(var_name)) goto rderr;
 100: 
 101:         entry = a->namelist->names;
 102:         /* loop through namelist entries looking for this variable name */
 103:         while( entry->varname[0] != 0 )
 104:         {
 105:         if( strcmp(entry->varname, var_name) == 0 ) goto got_name;
 106:         entry++;
 107:         }
 108:         nml_rd = "incorrect variable name";
 109:         goto rderr;
 110: got_name:
 111:         if( n = get_pars( entry, &addr, &nelem, &vlen, &vtype ))
 112:                             goto rderr_n;
 113:         while(isblnk(GETC)) ;
 114:         if(ch != '=') goto rderr;
 115: 
 116:         nameflag = NO;
 117:         if(n = l_read( nelem, addr, vlen, vtype )) goto rderr_n;
 118:         while(isblnk(GETC));
 119:         if(ch == ',') while(isblnk(GETC));
 120:         UNGETC();
 121:         if(leof) goto rderr;
 122:     }
 123:     /* check for 'end' after '&' or '$'*/
 124:     if(GETC!='e' || GETC!='n' || GETC!='d' )
 125:         goto rderr;
 126:     /* flush to next input record */
 127: flush:
 128:     while(GETC != '\n' && ch != EOF);
 129:     return(ch == EOF ? EOF : OK);
 130: 
 131: rderr:
 132:     if(leof)
 133:         n = EOF;
 134:     else
 135:         n = F_ERNMLIST;
 136: rderr_n:
 137:     if(n == EOF ) err(endflag,EOF,nml_rd);
 138:     /* flush after error in case restart I/O */
 139:     if(ch != '\n')  while(GETC != '\n' && ch != EOF) ;
 140:     err(errflag,n,nml_rd)
 141: }
 142: 
 143: #define MAXSUBS 7
 144: 
 145: LOCAL
 146: get_pars( entry, addr, nelem, vlen, vtype )
 147: struct namelistentry *entry;
 148: char    **addr;     /* beginning address to read into */
 149: int *nelem,     /* number of elements to read */
 150:     *vlen,      /* length of elements */
 151:     *vtype;     /* type of elements */
 152: {
 153:     int offset, i, n,
 154:         *dimptr,    /* points to dimensioning info */
 155:         ndim,       /* number of dimensions */
 156:         baseoffset, /* offset of corner element */
 157:         *span,      /* subscript span for each dimension */
 158:         subs[MAXSUBS],  /* actual subscripts */
 159:         subcnt = -1;    /* number of actual subscripts */
 160: 
 161: 
 162:     /* get element size and base address */
 163:     *vlen = entry->typelen;
 164:     *addr = entry->varaddr;
 165: 
 166:     /* get type */
 167:     switch ( *vtype = entry->type ) {
 168:         case TYSHORT:
 169:         case TYLONG:
 170:         case TYREAL:
 171:         case TYDREAL:
 172:         case TYCOMPLEX:
 173:         case TYDCOMPLEX:
 174:         case TYLOGICAL:
 175:         case TYCHAR:
 176:             break;
 177:         default:
 178:             fatal(F_ERSYS,"unknown type in rsnmle");
 179:     }
 180: 
 181:     /* get number of elements */
 182:     dimptr = entry->dimp;
 183:     if( dimptr==NULL )
 184:     {       /* scalar */
 185:         *nelem = 1;
 186:         return(OK);
 187:     }
 188: 
 189:     if( GETC != '(' )
 190:     {       /* entire array */
 191:         *nelem = dimptr[1];
 192:         UNGETC();
 193:         return(OK);
 194:     }
 195: 
 196:     /* get element length, number of dimensions, base, span vector */
 197:     ndim = dimptr[0];
 198:     if(ndim<=0 || ndim>MAXSUBS) fatal(F_ERSYS,"illegal dimensions");
 199:     baseoffset = dimptr[2];
 200:     span = dimptr+3;
 201: 
 202:     /* get subscripts from input data */
 203:     while(ch!=')') {
 204:         if( ++subcnt > MAXSUBS-1 ) return F_ERNMLIST;
 205:         if(n=get_int(&subs[subcnt])) return n;
 206:         GETC;
 207:         if(leof) return EOF;
 208:         if(ch != ',' && ch != ')') return F_ERNMLIST;
 209:     }
 210:     if( ++subcnt != ndim ) return F_ERNMLIST;
 211: 
 212:     offset = subs[ndim-1];
 213:     for( i = ndim-2; i>=0; i-- )
 214:         offset = subs[i] + span[i]*offset;
 215:     offset -= baseoffset;
 216:     *nelem = dimptr[1] - offset;
 217:     if( offset < 0 || offset >= dimptr[1] )
 218:         return F_ERNMLIST;
 219:     *addr = *addr + (*vlen)*offset;
 220:     return OK;
 221: }
 222: 
 223: LOCAL
 224: get_int(subval)
 225: int *subval;
 226: {
 227:     int sign=0, value=0, cnt=0;
 228: 
 229:     /* look for sign */
 230:     if(GETC == '-') sign = -1;
 231:     else if(ch == '+') ;
 232:     else UNGETC();
 233:     if(ch == EOF) return(EOF);
 234: 
 235:     while(isdigit(GETC))
 236:     {
 237:         value = 10*value + ch-'0';
 238:         cnt++;
 239:     }
 240:     UNGETC();
 241:     if(ch == 'EOF') return EOF;
 242:     if(cnt == 0 ) return F_ERNMLIST;
 243:     if(sign== -1) value = -value;
 244:     *subval = value;
 245:     return OK;
 246: }
 247: 
 248: LOCAL
 249: rd_name(ptr)
 250: char *ptr;
 251: {
 252:     /* read a variable name from the input stream */
 253:     char *init = ptr-1;
 254: 
 255:     if(!isalpha(GETC)) {
 256:         UNGETC();
 257:         return(ERROR);
 258:     }
 259:     *ptr++ = ch;
 260:     while(isalnum(GETC))
 261:     {
 262:         if(ptr-init > VL ) return(ERROR);
 263:         *ptr++ = ch;
 264:     }
 265:     *ptr = '\0';
 266:     UNGETC();
 267:     return(OK);
 268: }
 269: 
 270: LOCAL
 271: t_getc()
 272: {   int ch;
 273:     static newline = YES;
 274: rd:
 275:     if(curunit->uend) {
 276:         leof = EOF;
 277:         return(EOF);
 278:     }
 279:     if((ch=getc(cf))!=EOF)
 280:     {
 281:         if(ch == '\n') newline = YES;
 282:         else if(newline==YES)
 283:         {   /* skip first character on each line for namelist */
 284:             newline = NO;
 285:             goto rd;
 286:         }
 287:         return(ch);
 288:     }
 289:     if(feof(cf))
 290:     {   curunit->uend = YES;
 291:         leof = EOF;
 292:     }
 293:     else clearerr(cf);
 294:     return(EOF);
 295: }
 296: 
 297: LOCAL
 298: l_read(number,ptr,len,type) ftnint number,type; flex *ptr; ftnlen len;
 299: {   int i,n;
 300:     double *yy;
 301:     float *xx;
 302: 
 303:     lcount = 0;
 304:     for(i=0;i<number;i++)
 305:     {
 306:         if(leof) return EOF;
 307:         if(lcount==0)
 308:         {
 309:             ltype = NULL;
 310:             if(i!=0)
 311:             {   /* skip to comma */
 312:                 while(isblnk(GETC));
 313:                 if(leof) return(EOF);
 314:                 if(ch == namelistkey_)
 315:                 {   UNGETC();
 316:                     return(OK);
 317:                 }
 318:                 if(ch != ',' ) return(F_ERNMLIST);
 319:             }
 320:             while(isblnk(GETC));
 321:             if(leof) return(EOF);
 322:             UNGETC();
 323:             if(i!=0 && ch == namelistkey_) return(OK);
 324: 
 325:             switch((int)type)
 326:             {
 327:             case TYSHORT:
 328:             case TYLONG:
 329:                 if(!isint(ch)) return(OK);
 330:                 ERRNM(l_R(1));
 331:                 break;
 332:             case TYREAL:
 333:             case TYDREAL:
 334:                 if(!isrl(ch)) return(OK);
 335:                 ERRNM(l_R(1));
 336:                 break;
 337:             case TYCOMPLEX:
 338:             case TYDCOMPLEX:
 339:                 if(!isdigit(ch) && ch!='(') return(OK);
 340:                 ERRNM(l_C());
 341:                 break;
 342:             case TYLOGICAL:
 343:                 if(!islgc(ch)) return(OK);
 344:                 ERRNM(l_L());
 345:                 if(nameflag) return(OK);
 346:                 break;
 347:             case TYCHAR:
 348:                 if(!isdigit(ch) && !isapos(ch)) return(OK);
 349:                 ERRNM(l_CHAR());
 350:                 break;
 351:             }
 352: 
 353:             if(leof) return(EOF);
 354:             /* peek at next character -
 355: 				should be separator or namelistkey_ */
 356:             GETC; UNGETC();
 357:             if(!issep(ch) && (ch != namelistkey_))
 358:             return( leof?EOF:F_ERNMLIST );
 359:         }
 360: 
 361:         if(!ltype) return(F_ERNMLIST);
 362:         switch((int)type)
 363:         {
 364:         case TYSHORT:
 365:             ptr->flshort=lx;
 366:             break;
 367:         case TYLOGICAL:
 368:             if(len == sizeof(short))
 369:                 ptr->flshort = lx;
 370:             else
 371:                 ptr->flint = lx;
 372:             break;
 373:         case TYLONG:
 374:             ptr->flint=lx;
 375:             break;
 376:         case TYREAL:
 377:             ptr->flreal=lx;
 378:             break;
 379:         case TYDREAL:
 380:             ptr->fldouble=lx;
 381:             break;
 382:         case TYCOMPLEX:
 383:             xx=(float *)ptr;
 384:             *xx++ = ly;
 385:             *xx = lx;
 386:             break;
 387:         case TYDCOMPLEX:
 388:             yy=(double *)ptr;
 389:             *yy++ = ly;
 390:             *yy = lx;
 391:             break;
 392:         case TYCHAR:
 393:             b_char(lchar,(char *)ptr,len);
 394:             break;
 395:         }
 396:         if(lcount>0) lcount--;
 397:         ptr = (flex *)((char *)ptr + len);
 398:     }
 399:     if(lcount>0) return F_ERNMLIST;
 400:     return(OK);
 401: }
 402: 
 403: LOCAL
 404: get_repet()
 405: {
 406:     double lc;
 407:     if(isdigit(GETC))
 408:     {   UNGETC();
 409:         rd_int(&lc);
 410:         lcount = (int)lc;
 411:         if(GETC!='*')
 412:             if(leof) return(EOF);
 413:             else return(F_ERREPT);
 414:     }
 415:     else
 416:     {   lcount = 1;
 417:         UNGETC();
 418:     }
 419:     return(OK);
 420: }
 421: 
 422: LOCAL
 423: l_R(flg) int flg;
 424: {   double a,b,c,d;
 425:     int da,db,dc,dd;
 426:     int i,sign=0;
 427:     a=b=c=d=0;
 428:     da=db=dc=dd=0;
 429: 
 430:     if( flg )       /* real */
 431:     {
 432:         da=rd_int(&a);  /* repeat count ? */
 433:         if(GETC=='*')
 434:         {
 435:             if (a <= 0.) return(F_ERNREP);
 436:             lcount=(int)a;
 437:             db=rd_int(&b);  /* whole part of number */
 438:         }
 439:         else
 440:         {   UNGETC();
 441:             db=da;
 442:             b=a;
 443:             lcount=1;
 444:         }
 445:     }
 446:     else           /* complex */
 447:     {
 448:         db=rd_int(&b);
 449:     }
 450: 
 451:     if(GETC=='.' && isdigit(GETC))
 452:     {   UNGETC();
 453:         dc=rd_int(&c);  /* fractional part of number */
 454:     }
 455:     else
 456:     {   UNGETC();
 457:         dc=0;
 458:         c=0.;
 459:     }
 460:     if(isexp(GETC))
 461:         dd=rd_int(&d);  /* exponent */
 462:     else if (ch == '+' || ch == '-')
 463:     {   UNGETC();
 464:         dd=rd_int(&d);
 465:     }
 466:     else
 467:     {   UNGETC();
 468:         dd=0;
 469:     }
 470:     if(db<0 || b<0)
 471:     {   sign=1;
 472:         b = -b;
 473:     }
 474:     for(i=0;i<dc;i++) c/=10.;
 475:     b=b+c;
 476:     if (dd > 0)
 477:     {   for(i=0;i<d;i++) b *= 10.;
 478:         for(i=0;i< -d;i++) b /= 10.;
 479:     }
 480:     lx=sign?-b:b;
 481:     ltype=TYLONG;
 482:     return(OK);
 483: }
 484: 
 485: LOCAL
 486: rd_int(x) double *x;
 487: {   int sign=0,i=0;
 488:     double y=0.0;
 489:     if(GETC=='-') sign = -1;
 490:     else if(ch=='+') sign=0;
 491:     else UNGETC();
 492:     while(isdigit(GETC))
 493:     {   i++;
 494:         y=10*y + ch-'0';
 495:     }
 496:     UNGETC();
 497:     if(sign) y = -y;
 498:     *x = y;
 499:     return(y==0.0?sign:i); /* 0:[+]&&y==0, -1:-&&y==0, >0:#digits&&y!=0 */
 500: }
 501: 
 502: LOCAL
 503: l_C()
 504: {   int n;
 505:     if(n=get_repet()) return(n);        /* get repeat count */
 506:     if(GETC!='(') err(errflag,F_ERNMLIST,"no (")
 507:     while(isblnk(GETC));
 508:     UNGETC();
 509:     l_R(0);     /* get real part */
 510:     ly = lx;
 511:     while(isblnk(GETC));  /* get comma */
 512:     if(leof) return(EOF);
 513:     if(ch!=',') return(F_ERNMLIST);
 514:     while(isblnk(GETC));
 515:     UNGETC();
 516:     if(leof) return(EOF);
 517:     l_R(0);     /* get imag part */
 518:     while(isblnk(GETC));
 519:     if(ch!=')') err(errflag,F_ERNMLIST,"no )")
 520:     ltype = TYCOMPLEX;
 521:     return(OK);
 522: }
 523: 
 524: LOCAL
 525: l_L()
 526: {
 527:     int n, keychar=ch, scanned=NO;
 528:     if(ch=='f' || ch=='F' || ch=='t' || ch=='T')
 529:     {
 530:         scanned=YES;
 531:         if(rd_name(var_name))
 532:             return(leof?EOF:F_ERNMLIST);
 533:         while(isblnk(GETC));
 534:         UNGETC();
 535:         if(ch == '=' || ch == '(')
 536:         {   /* found a name, not a value */
 537:             nameflag = YES;
 538:             return(OK);
 539:         }
 540:     }
 541:     else
 542:     {
 543:         if(n=get_repet()) return(n);        /* get repeat count */
 544:         if(GETC=='.') GETC;
 545:         keychar = ch;
 546:     }
 547:     switch(keychar)
 548:     {
 549:     case 't':
 550:     case 'T':
 551:         lx=1;
 552:         break;
 553:     case 'f':
 554:     case 'F':
 555:         lx=0;
 556:         break;
 557:     default:
 558:         if(ch==EOF) return(EOF);
 559:         else    err(errflag,F_ERNMLIST,"logical not T or F");
 560:     }
 561:     ltype=TYLOGICAL;
 562:     if(scanned==NO)
 563:     {
 564:         while(!issep(GETC) && ch!=EOF) ;
 565:         UNGETC();
 566:     }
 567:     if(ch == EOF ) return(EOF);
 568:     return(OK);
 569: }
 570: 
 571: #define BUFSIZE 128
 572: LOCAL
 573: l_CHAR()
 574: {   int size,i,n;
 575:     char quote,*p;
 576:     if(n=get_repet()) return(n);        /* get repeat count */
 577:     if(isapos(GETC)) quote=ch;
 578:     else if(ch == EOF) return EOF;
 579:     else return F_ERNMLIST;
 580:     ltype=TYCHAR;
 581:     if(lchar!=NULL) free(lchar);
 582:     size=BUFSIZE-1;
 583:     p=lchar=(char *)malloc(BUFSIZE);
 584:     if(lchar==NULL) return (F_ERSPACE);
 585:     for(i=0;;)
 586:     {   while( GETC!=quote && ch!='\n' && ch!=EOF && ++i<size )
 587:                 *p++ = ch;
 588:         if(i==size)
 589:         {
 590:         newone:
 591:             size += BUFSIZE;
 592:             lchar=(char *)realloc(lchar, size+1);
 593:             if(lchar==NULL) return( F_ERSPACE );
 594:             p=lchar+i-1;
 595:             *p++ = ch;
 596:         }
 597:         else if(ch==EOF) return(EOF);
 598:         else if(ch=='\n')
 599:         {   if(*(p-1) == '\\') *(p-1) = ch;
 600:         }
 601:         else if(GETC==quote)
 602:         {   if(++i<size) *p++ = ch;
 603:             else goto newone;
 604:         }
 605:         else
 606:         {   UNGETC();
 607:             *p = '\0';
 608:             return(OK);
 609:         }
 610:     }
 611: }

Defined functions

Defined variables

Defined macros