4.3BSD - /usr/src/usr.lib/libI77/fmt.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:  *	@(#)fmt.c	5.1	6/7/85
   7:  */
   8: 
   9: /*
  10:  * fortran format parser
  11:  */
  12: 
  13: #include "fio.h"
  14: #include "format.h"
  15: 
  16: #define isdigit(x)  (x>='0' && x<='9')
  17: #define isspace(s)  (s==' ')
  18: #define skip(s)     while(isspace(*s)) s++
  19: 
  20: #ifdef interdata
  21: #define SYLMX 300
  22: #endif
  23: 
  24: #ifdef pdp11
  25: #define SYLMX 300
  26: #endif
  27: 
  28: #ifdef vax
  29: #define SYLMX 300
  30: #endif
  31: 
  32: LOCAL struct syl syl_vec[SYLMX];
  33: struct syl *syl_ptr;
  34: LOCAL int parenlvl,revloc;
  35: int low_case[256];
  36: short pc;
  37: char *f_s(), *f_list(), *i_tem(), *gt_num(), *ap_end();
  38: char *s_init;
  39: 
  40: pars_f()
  41: {
  42:     short *s_ptr;
  43:     long  *l_ptr;
  44:     int i;
  45: 
  46:     /* first time, initialize low_case[] */
  47:     if( low_case[1] == 0 ) {
  48:         for(i = 0; i<256; i++) low_case[i]=i;
  49:         for(i = 'A'; i<='Z'; i++) low_case[i]=i-'A'+'a';
  50:     }
  51: 
  52:     parenlvl=revloc=pc=0;
  53: 
  54:     s_ptr = (short *) fmtbuf;
  55:     if( *s_ptr == FMT_COMP ) {
  56:         /* already compiled - copy value of pc */
  57:         pc = *(s_ptr+1);
  58:         /* get address of the format */
  59:         l_ptr = (long *) fmtbuf;
  60:         fmtbuf = s_init = (char *) *(l_ptr+1);
  61:         /* point syl_ptr to the compiled format */
  62:         syl_ptr = (struct syl *) (l_ptr + 2);
  63:         return(OK);
  64:     } else {
  65:         syl_ptr = syl_vec;
  66:         s_init = fmtbuf;
  67:         return((f_s(fmtbuf,0)==FMTERR)? ERROR : OK);
  68:     }
  69: }
  70: 
  71: LOCAL
  72: char *f_s(s,curloc) char *s;
  73: {
  74:     skip(s);
  75:     if(*s++!='(')
  76:     {
  77:         fmtptr = s;
  78:         return(FMTERR);
  79:     }
  80:     if(parenlvl++ ==1) revloc=curloc;
  81:     op_gen(RET,curloc,0,0,s);
  82:     if((s=f_list(s))==FMTERR)
  83:     {
  84:         return(FMTERR);
  85:     }
  86:     skip(s);
  87:     return(s);
  88: }
  89: 
  90: LOCAL
  91: char *f_list(s) char *s;
  92: {
  93:     while (*s)
  94:     {   skip(s);
  95:         if((s=i_tem(s))==FMTERR) return(FMTERR);
  96:         skip(s);
  97:         if(*s==',') s++;
  98:         else if(*s==')')
  99:         {   if(--parenlvl==0)
 100:                 op_gen(REVERT,revloc,0,0,s);
 101:             else
 102:                 op_gen(GOTO,0,0,0,s);
 103:             return(++s);
 104:         }
 105:     }
 106:     fmtptr = s;
 107:     return(FMTERR);
 108: }
 109: 
 110: LOCAL
 111: char *i_tem(s) char *s;
 112: {   char *t;
 113:     int n,curloc;
 114:     if(*s==')') return(s);
 115:     if ((n=ne_d(s,&t))==FMTOK)
 116:         return(t);
 117:     else if (n==FMTERR)
 118:         return(FMTERR);
 119:     if ((n=e_d(s,&t))==FMTOK)
 120:         return(t);
 121:     else if (n==FMTERR)
 122:         return(FMTERR);
 123:     s=gt_num(s,&n);
 124:     if (n == 0) { fmtptr = s; return(FMTERR); }
 125:     curloc = op_gen(STACK,n,0,0,s);
 126:     return(f_s(s,curloc));
 127: }
 128: 
 129: LOCAL
 130: ne_d(s,p) char *s,**p;
 131: {   int n,x,sign=0,pp1,pp2;
 132:     switch(low_case[*s])
 133:     {
 134:     case ':': op_gen(COLON,(int)('\n'),0,0,s); break;
 135: #ifndef KOSHER
 136:     case '$': op_gen(DOLAR,(int)('\0'),0,0,s); break;  /*** NOT STANDARD FORTRAN ***/
 137: #endif
 138:     case 'b':
 139:         switch(low_case[*(s+1)])
 140:         {
 141:             case 'n': s++; op_gen(BNZ,0,0,0,s); break;
 142:             case 'z': s++; op_gen(BNZ,1,0,0,s); break;
 143: #ifndef KOSHER
 144:             default: op_gen(B,0,0,0,s); break;  /*** NOT STANDARD FORTRAN ***/
 145: #else
 146:             default: fmtptr = s; return(FMTUNKN);
 147: #endif
 148:         }
 149:         break;
 150:     case 's':
 151:         switch(low_case[*(s+1)])
 152:         {
 153:             case 'p': s++; x=SP; pp1=1; pp2=1; break;
 154: #ifndef KOSHER
 155:             case 'u': s++; x=SU; pp1=0; pp2=0; break;  /*** NOT STANDARD FORTRAN ***/
 156: #endif
 157:             case 's': s++; x=SS; pp1=0; pp2=1; break;
 158:             default:  x=S; pp1=0; pp2=1; break;
 159:         }
 160:         op_gen(x,pp1,pp2,0,s);
 161:         break;
 162:     case '/': op_gen(SLASH,0,0,0,s); break;
 163: 
 164:     case '-': sign=1;   /* OUTRAGEOUS CODING */
 165:     case '+': s++;      /* OUTRAGEOUS CODING */
 166:     case '0': case '1': case '2': case '3': case '4':
 167:     case '5': case '6': case '7': case '8': case '9':
 168:         s=gt_num(s,&n);
 169:         switch(low_case[*s])
 170:         {
 171:         case 'p': if(sign) n= -n; op_gen(P,n,0,0,s); break;
 172: #ifndef KOSHER
 173:         case 'r': if(n<=1)      /*** NOT STANDARD FORTRAN ***/
 174:             {   fmtptr = --s; return(FMTERR); }
 175:             op_gen(R,n,0,0,s); break;
 176:         case 't': op_gen(T,0,n,0,s); break; /* NOT STANDARD FORT */
 177: #endif
 178:         case 'x': op_gen(X,n,0,0,s); break;
 179:         case 'h': op_gen(H,n,(s+1)-s_init,0,s);
 180:             s+=n;
 181:             break;
 182:         default: fmtptr = s; return(FMTUNKN);
 183:         }
 184:         break;
 185:     case GLITCH:
 186:     case '"':
 187:     case '\'': op_gen(APOS,s-s_init,0,0,s);
 188:         *p = ap_end(s);
 189:         return(FMTOK);
 190:     case 't':
 191:         switch(low_case[*(s+1)])
 192:         {
 193:             case 'l': s++; x=TL; break;
 194:             case 'r': s++; x=TR; break;
 195:             default:  x=T; break;
 196:         }
 197:         if(isdigit(*(s+1))) {s=gt_num(s+1,&n); s--;}
 198: #ifdef KOSHER
 199:         else { fmtptr = s; return(FMTERR); }
 200: #else
 201:         else n = 0; /* NOT STANDARD FORTRAN, should be error */
 202: #endif
 203:         op_gen(x,n,1,0,s);
 204:         break;
 205:     case 'x': op_gen(X,1,0,0,s); break;
 206:     case 'p': op_gen(P,0,0,0,s); break;
 207: #ifndef KOSHER
 208:     case 'r': op_gen(R,10,1,0,s); break;  /*** NOT STANDARD FORTRAN ***/
 209: #endif
 210: 
 211:     default: fmtptr = s; return(FMTUNKN);
 212:     }
 213:     s++;
 214:     *p=s;
 215:     return(FMTOK);
 216: }
 217: 
 218: LOCAL
 219: e_d(s,p) char *s,**p;
 220: {   int n,w,d,e,x=0, rep_count;
 221:     char *sv=s;
 222:     char c;
 223:     s=gt_num(s,&rep_count);
 224:     if (rep_count == 0) goto ed_err;
 225:     c = low_case[*s]; s++;
 226:     switch(c)
 227:     {
 228:     case 'd':
 229:     case 'e':
 230:     case 'g':
 231:         s = gt_num(s, &w);
 232:         if (w==0) goto ed_err;
 233:         if(*s=='.')
 234:         {   s++;
 235:             s=gt_num(s,&d);
 236:         }
 237:         else d=0;
 238:         if(low_case[*s] == 'e'
 239: #ifndef KOSHER
 240:         || *s == '.'         /*** '.' is NOT STANDARD FORTRAN ***/
 241: #endif
 242:         )
 243:         {   s++;
 244:             s=gt_num(s,&e);
 245:             if (e==0 || e>127 || d>127 ) goto ed_err;
 246:             if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE;
 247:             op_gen(n,w,d + (e<<8),rep_count,s);
 248:         }
 249:         else
 250:         {
 251:             if(c=='e') n=E; else if(c=='d') n=D; else n=G;
 252:             op_gen(n,w,d,rep_count,s);
 253:         }
 254:         break;
 255:     case 'l':
 256:         s = gt_num(s, &w);
 257:         if (w==0) goto ed_err;
 258:         op_gen(L,w,0,rep_count,s);
 259:         break;
 260:     case 'a':
 261:         skip(s);
 262:         if(isdigit(*s))
 263:         {   s=gt_num(s,&w);
 264: #ifdef  KOSHER
 265:             if (w==0) goto ed_err;
 266: #else
 267:             if (w==0) op_gen(A,0,0,rep_count,s);
 268:             else
 269: #endif
 270:             op_gen(AW,w,0,rep_count,s);
 271:             break;
 272:         }
 273:         op_gen(A,0,0,rep_count,s);
 274:         break;
 275:     case 'f':
 276:         s = gt_num(s, &w);
 277:         if (w==0) goto ed_err;
 278:         if(*s=='.')
 279:         {   s++;
 280:             s=gt_num(s,&d);
 281:         }
 282:         else d=0;
 283:         op_gen(F,w,d,rep_count,s);
 284:         break;
 285: #ifndef KOSHER
 286:     case 'o':   /*** octal format - NOT STANDARD FORTRAN ***/
 287:     case 'z':   /*** hex   format - NOT STANDARD FORTRAN ***/
 288: #endif
 289:     case 'i':
 290:         s = gt_num(s, &w);
 291:         if (w==0) goto ed_err;
 292:         if(*s =='.')
 293:         {
 294:             s++;
 295:             s=gt_num(s,&d);
 296:             x = IM;
 297:         }
 298:         else
 299:         {   d = 1;
 300:             x = I;
 301:         }
 302: #ifndef KOSHER
 303:         if (c == 'o')
 304:             op_gen(R,8,1,rep_count,s);
 305:         else if (c == 'z')
 306:             op_gen(R,16,1,rep_count,s);
 307: #endif
 308:         op_gen(x,w,d,rep_count,s);
 309: #ifndef KOSHER
 310:         if (c == 'o' || c == 'z')
 311:             op_gen(R,10,1,rep_count,s);
 312: #endif
 313:         break;
 314:     default:
 315:         *p = sv;
 316:         fmtptr = s;
 317:         return(FMTUNKN);
 318:     }
 319:     *p = s;
 320:     return(FMTOK);
 321: ed_err:
 322:     fmtptr = --s;
 323:     return(FMTERR);
 324: }
 325: 
 326: LOCAL
 327: op_gen(a,b,c,rep,s) char *s;
 328: {   struct syl *p= &syl_ptr[pc];
 329:     if(pc>=SYLMX)
 330:     {   fmtptr = s;
 331:         fatal(F_ERFMT,"format too complex");
 332:     }
 333:     if( b>32767 || c>32767 || rep>32767 )
 334:     {   fmtptr = s;
 335:         fatal("field width or repeat count too large");
 336:     }
 337: #ifdef DEBUG
 338:     fprintf(stderr,"%3d opgen: %d %d %d %d %c\n",
 339:         pc,a,b,c,rep,*s==GLITCH?'"':*s); /* for debug */
 340: #endif
 341:     p->op=a;
 342:     p->p1=b;
 343:     p->p2=c;
 344:     p->rpcnt=rep;
 345:     return(pc++);
 346: }
 347: 
 348: LOCAL
 349: char *gt_num(s,n) char *s; int *n;
 350: {   int m=0,a_digit=NO;
 351:     skip(s);
 352:     while(isdigit(*s) || isspace(*s))
 353:     {
 354:         if (isdigit(*s))
 355:         {
 356:             m = 10*m + (*s)-'0';
 357:             a_digit = YES;
 358:         }
 359:         s++;
 360:     }
 361:     if(a_digit) *n=m;
 362:     else *n=1;
 363:     return(s);
 364: }
 365: 
 366: LOCAL
 367: char *ap_end(s) char *s;
 368: {
 369:     char quote;
 370:     quote = *s++;
 371:     for(;*s;s++)
 372:     {
 373:         if(*s==quote && *++s!=quote) return(s);
 374:     }
 375:     fmtptr = s;
 376:     fatal(F_ERFMT,"bad string");
 377: }

Defined functions

Defined variables

Defined macros