2.11BSD#431 - /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.1	1/1/94
   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: #ifndef pdp11
 242:     if(ch == 'EOF') return EOF;
 243: #endif
 244:     if(cnt == 0 ) return F_ERNMLIST;
 245:     if(sign== -1) value = -value;
 246:     *subval = value;
 247:     return OK;
 248: }
 249: 
 250: LOCAL
 251: rd_name(ptr)
 252: char *ptr;
 253: {
 254:     /* read a variable name from the input stream */
 255:     char *init = ptr-1;
 256: 
 257:     if(!isalpha(GETC)) {
 258:         UNGETC();
 259:         return(ERROR);
 260:     }
 261:     *ptr++ = ch;
 262:     while(isalnum(GETC))
 263:     {
 264:         if(ptr-init > VL ) return(ERROR);
 265:         *ptr++ = ch;
 266:     }
 267:     *ptr = '\0';
 268:     UNGETC();
 269:     return(OK);
 270: }
 271: 
 272: LOCAL
 273: t_getc()
 274: {   int ch;
 275:     static newline = YES;
 276: rd:
 277:     if(curunit->uend) {
 278:         leof = EOF;
 279:         return(EOF);
 280:     }
 281:     if((ch=getc(cf))!=EOF)
 282:     {
 283:         if(ch == '\n') newline = YES;
 284:         else if(newline==YES)
 285:         {   /* skip first character on each line for namelist */
 286:             newline = NO;
 287:             goto rd;
 288:         }
 289:         return(ch);
 290:     }
 291:     if(feof(cf))
 292:     {   curunit->uend = YES;
 293:         leof = EOF;
 294:     }
 295:     else clearerr(cf);
 296:     return(EOF);
 297: }
 298: 
 299: LOCAL
 300: l_read(number,ptr,len,type) ftnint number,type; flex *ptr; ftnlen len;
 301: {   int i,n;
 302:     double *yy;
 303:     float *xx;
 304: 
 305:     lcount = 0;
 306:     for(i=0;i<number;i++)
 307:     {
 308:         if(leof) return EOF;
 309:         if(lcount==0)
 310:         {
 311:             ltype = NULL;
 312:             if(i!=0)
 313:             {   /* skip to comma */
 314:                 while(isblnk(GETC));
 315:                 if(leof) return(EOF);
 316:                 if(ch == namelistkey_)
 317:                 {   UNGETC();
 318:                     return(OK);
 319:                 }
 320:                 if(ch != ',' ) return(F_ERNMLIST);
 321:             }
 322:             while(isblnk(GETC));
 323:             if(leof) return(EOF);
 324:             UNGETC();
 325:             if(i!=0 && ch == namelistkey_) return(OK);
 326: 
 327:             switch((int)type)
 328:             {
 329:             case TYSHORT:
 330:             case TYLONG:
 331:                 if(!isint(ch)) return(OK);
 332:                 ERRNM(l_R(1));
 333:                 break;
 334:             case TYREAL:
 335:             case TYDREAL:
 336:                 if(!isrl(ch)) return(OK);
 337:                 ERRNM(l_R(1));
 338:                 break;
 339:             case TYCOMPLEX:
 340:             case TYDCOMPLEX:
 341:                 if(!isdigit(ch) && ch!='(') return(OK);
 342:                 ERRNM(l_C());
 343:                 break;
 344:             case TYLOGICAL:
 345:                 if(!islgc(ch)) return(OK);
 346:                 ERRNM(l_L());
 347:                 if(nameflag) return(OK);
 348:                 break;
 349:             case TYCHAR:
 350:                 if(!isdigit(ch) && !isapos(ch)) return(OK);
 351:                 ERRNM(l_CHAR());
 352:                 break;
 353:             }
 354: 
 355:             if(leof) return(EOF);
 356:             /* peek at next character -
 357: 				should be separator or namelistkey_ */
 358:             GETC; UNGETC();
 359:             if(!issep(ch) && (ch != namelistkey_))
 360:             return( leof?EOF:F_ERNMLIST );
 361:         }
 362: 
 363:         if(!ltype) return(F_ERNMLIST);
 364:         switch((int)type)
 365:         {
 366:         case TYSHORT:
 367:             ptr->flshort=lx;
 368:             break;
 369:         case TYLOGICAL:
 370:             if(len == sizeof(short))
 371:                 ptr->flshort = lx;
 372:             else
 373:                 ptr->flint = lx;
 374:             break;
 375:         case TYLONG:
 376:             ptr->flint=lx;
 377:             break;
 378:         case TYREAL:
 379:             ptr->flreal=lx;
 380:             break;
 381:         case TYDREAL:
 382:             ptr->fldouble=lx;
 383:             break;
 384:         case TYCOMPLEX:
 385:             xx=(float *)ptr;
 386:             *xx++ = ly;
 387:             *xx = lx;
 388:             break;
 389:         case TYDCOMPLEX:
 390:             yy=(double *)ptr;
 391:             *yy++ = ly;
 392:             *yy = lx;
 393:             break;
 394:         case TYCHAR:
 395:             b_char(lchar,(char *)ptr,len);
 396:             break;
 397:         }
 398:         if(lcount>0) lcount--;
 399:         ptr = (flex *)((char *)ptr + len);
 400:     }
 401:     if(lcount>0) return F_ERNMLIST;
 402:     return(OK);
 403: }
 404: 
 405: LOCAL
 406: get_repet()
 407: {
 408:     double lc;
 409:     if(isdigit(GETC))
 410:     {   UNGETC();
 411:         rd_int(&lc);
 412:         lcount = (int)lc;
 413:         if(GETC!='*')
 414:             if(leof) return(EOF);
 415:             else return(F_ERREPT);
 416:     }
 417:     else
 418:     {   lcount = 1;
 419:         UNGETC();
 420:     }
 421:     return(OK);
 422: }
 423: 
 424: LOCAL
 425: l_R(flg) int flg;
 426: {   double a,b,c,d;
 427:     int da,db,dc,dd;
 428:     int i,sign=0;
 429:     a=b=c=d=0;
 430:     da=db=dc=dd=0;
 431: 
 432:     if( flg )       /* real */
 433:     {
 434:         da=rd_int(&a);  /* repeat count ? */
 435:         if(GETC=='*')
 436:         {
 437:             if (a <= 0.) return(F_ERNREP);
 438:             lcount=(int)a;
 439:             db=rd_int(&b);  /* whole part of number */
 440:         }
 441:         else
 442:         {   UNGETC();
 443:             db=da;
 444:             b=a;
 445:             lcount=1;
 446:         }
 447:     }
 448:     else           /* complex */
 449:     {
 450:         db=rd_int(&b);
 451:     }
 452: 
 453:     if(GETC=='.' && isdigit(GETC))
 454:     {   UNGETC();
 455:         dc=rd_int(&c);  /* fractional part of number */
 456:     }
 457:     else
 458:     {   UNGETC();
 459:         dc=0;
 460:         c=0.;
 461:     }
 462:     if(isexp(GETC))
 463:         dd=rd_int(&d);  /* exponent */
 464:     else if (ch == '+' || ch == '-')
 465:     {   UNGETC();
 466:         dd=rd_int(&d);
 467:     }
 468:     else
 469:     {   UNGETC();
 470:         dd=0;
 471:     }
 472:     if(db<0 || b<0)
 473:     {   sign=1;
 474:         b = -b;
 475:     }
 476:     for(i=0;i<dc;i++) c/=10.;
 477:     b=b+c;
 478:     if (dd > 0)
 479:     {   for(i=0;i<d;i++) b *= 10.;
 480:         for(i=0;i< -d;i++) b /= 10.;
 481:     }
 482:     lx=sign?-b:b;
 483:     ltype=TYLONG;
 484:     return(OK);
 485: }
 486: 
 487: LOCAL
 488: rd_int(x) double *x;
 489: {   int sign=0,i=0;
 490:     double y=0.0;
 491:     if(GETC=='-') sign = -1;
 492:     else if(ch=='+') sign=0;
 493:     else UNGETC();
 494:     while(isdigit(GETC))
 495:     {   i++;
 496:         y=10*y + ch-'0';
 497:     }
 498:     UNGETC();
 499:     if(sign) y = -y;
 500:     *x = y;
 501:     return(y==0.0?sign:i); /* 0:[+]&&y==0, -1:-&&y==0, >0:#digits&&y!=0 */
 502: }
 503: 
 504: LOCAL
 505: l_C()
 506: {   int n;
 507:     if(n=get_repet()) return(n);        /* get repeat count */
 508:     if(GETC!='(') err(errflag,F_ERNMLIST,"no (")
 509:     while(isblnk(GETC));
 510:     UNGETC();
 511:     l_R(0);     /* get real part */
 512:     ly = lx;
 513:     while(isblnk(GETC));  /* get comma */
 514:     if(leof) return(EOF);
 515:     if(ch!=',') return(F_ERNMLIST);
 516:     while(isblnk(GETC));
 517:     UNGETC();
 518:     if(leof) return(EOF);
 519:     l_R(0);     /* get imag part */
 520:     while(isblnk(GETC));
 521:     if(ch!=')') err(errflag,F_ERNMLIST,"no )")
 522:     ltype = TYCOMPLEX;
 523:     return(OK);
 524: }
 525: 
 526: LOCAL
 527: l_L()
 528: {
 529:     int n, keychar=ch, scanned=NO;
 530:     if(ch=='f' || ch=='F' || ch=='t' || ch=='T')
 531:     {
 532:         scanned=YES;
 533:         if(rd_name(var_name))
 534:             return(leof?EOF:F_ERNMLIST);
 535:         while(isblnk(GETC));
 536:         UNGETC();
 537:         if(ch == '=' || ch == '(')
 538:         {   /* found a name, not a value */
 539:             nameflag = YES;
 540:             return(OK);
 541:         }
 542:     }
 543:     else
 544:     {
 545:         if(n=get_repet()) return(n);        /* get repeat count */
 546:         if(GETC=='.') GETC;
 547:         keychar = ch;
 548:     }
 549:     switch(keychar)
 550:     {
 551:     case 't':
 552:     case 'T':
 553:         lx=1;
 554:         break;
 555:     case 'f':
 556:     case 'F':
 557:         lx=0;
 558:         break;
 559:     default:
 560:         if(ch==EOF) return(EOF);
 561:         else    err(errflag,F_ERNMLIST,"logical not T or F");
 562:     }
 563:     ltype=TYLOGICAL;
 564:     if(scanned==NO)
 565:     {
 566:         while(!issep(GETC) && ch!=EOF) ;
 567:         UNGETC();
 568:     }
 569:     if(ch == EOF ) return(EOF);
 570:     return(OK);
 571: }
 572: 
 573: #define BUFSIZE 128
 574: LOCAL
 575: l_CHAR()
 576: {   int size,i,n;
 577:     char quote,*p;
 578:     if(n=get_repet()) return(n);        /* get repeat count */
 579:     if(isapos(GETC)) quote=ch;
 580:     else if(ch == EOF) return EOF;
 581:     else return F_ERNMLIST;
 582:     ltype=TYCHAR;
 583:     if(lchar!=NULL) free(lchar);
 584:     size=BUFSIZE-1;
 585:     p=lchar=(char *)malloc(BUFSIZE);
 586:     if(lchar==NULL) return (F_ERSPACE);
 587:     for(i=0;;)
 588:     {   while( GETC!=quote && ch!='\n' && ch!=EOF && ++i<size )
 589:                 *p++ = ch;
 590:         if(i==size)
 591:         {
 592:         newone:
 593:             size += BUFSIZE;
 594:             lchar=(char *)realloc(lchar, size+1);
 595:             if(lchar==NULL) return( F_ERSPACE );
 596:             p=lchar+i-1;
 597:             *p++ = ch;
 598:         }
 599:         else if(ch==EOF) return(EOF);
 600:         else if(ch=='\n')
 601:         {   if(*(p-1) == '\\') *(p-1) = ch;
 602:         }
 603:         else if(GETC==quote)
 604:         {   if(++i<size) *p++ = ch;
 605:             else goto newone;
 606:         }
 607:         else
 608:         {   UNGETC();
 609:             *p = '\0';
 610:             return(OK);
 611:         }
 612:     }
 613: }

Defined functions

Defined variables

Defined macros