2.9BSD - /usr/src/lib/libI77/fmt.c

   1: /*
   2: char id_fmt[] = "@(#)fmt.c	1.4";
   3:  *
   4:  * fortran format parser
   5:  */
   6: 
   7: #include "fio.h"
   8: #include "format.h"
   9: 
  10: #define isdigit(x)  (x>='0' && x<='9')
  11: #define isspace(s)  (s==' ')
  12: #define skip(s)     while(isspace(*s)) s++
  13: 
  14: #ifdef interdata
  15: #define SYLMX 300
  16: #endif
  17: 
  18: #ifdef pdp11
  19: #define SYLMX 300
  20: #endif
  21: 
  22: #ifdef vax
  23: #define SYLMX 300
  24: #endif
  25: 
  26: struct syl syl[SYLMX];
  27: int parenlvl,pc,revloc;
  28: char *f_s(), *f_list(), *i_tem(), *gt_num(), *ap_end();
  29: 
  30: pars_f(s) char *s;
  31: {
  32:     parenlvl=revloc=pc=0;
  33:     return((f_s(s,0)==FMTERR)? ERROR : OK);
  34: }
  35: 
  36: char *f_s(s,curloc) char *s;
  37: {
  38:     skip(s);
  39:     if(*s++!='(')
  40:     {
  41:         fmtptr = s;
  42:         return(FMTERR);
  43:     }
  44:     if(parenlvl++ ==1) revloc=curloc;
  45:     op_gen(RET,curloc,0,0,s);
  46:     if((s=f_list(s))==FMTERR)
  47:     {
  48:         return(FMTERR);
  49:     }
  50:     skip(s);
  51:     return(s);
  52: }
  53: 
  54: char *f_list(s) char *s;
  55: {
  56:     while (*s)
  57:     {   skip(s);
  58:         if((s=i_tem(s))==FMTERR) return(FMTERR);
  59:         skip(s);
  60:         if(*s==',') s++;
  61:         else if(*s==')')
  62:         {   if(--parenlvl==0)
  63:             {
  64:                 op_gen(REVERT,revloc,0,0,s);
  65:             }
  66:             else    op_gen(GOTO,0,0,0,s);
  67:             return(++s);
  68:         }
  69:     }
  70:     fmtptr = s;
  71:     return(FMTERR);
  72: }
  73: 
  74: char *i_tem(s) char *s;
  75: {   char *t;
  76:     int n,curloc;
  77:     if(*s==')') return(s);
  78:     if(ne_d(s,&t)) return(t);
  79:     if(e_d(s,&t)) return(t);
  80:     s=gt_num(s,&n);
  81:     curloc = op_gen(STACK,n,0,0,s);
  82:     return(f_s(s,curloc));
  83: }
  84: 
  85: ne_d(s,p) char *s,**p;
  86: {   int n,x,sign=0,pp1,pp2;
  87:     switch(lcase(*s))
  88:     {
  89:     case ':': op_gen(COLON,(int)('\n'),0,0,s); break;
  90: #ifndef KOSHER
  91:     case '$': op_gen(DOLAR,(int)('\0'),0,0,s); break;  /*** NOT STANDARD FORTRAN ***/
  92: #endif
  93:     case 'b':
  94:         switch(lcase(*(s+1)))
  95:         {
  96:             case '\0': op_gen(BN,cblank,0,0,s); break;
  97:             case 'z': s++; op_gen(BZ,1,0,0,s); break;
  98:             case 'n': s++;
  99:             default:  op_gen(BN,0,0,0,s); break;
 100:         }
 101:         break;
 102:     case 's':
 103:         switch(lcase(*(s+1)))
 104:         {
 105:             case 'p': s++; x=SP; pp1=1; pp2=1; break;
 106: #ifndef KOSHER
 107:             case 'u': s++; x=SU; pp1=0; pp2=0; break;  /*** NOT STANDARD FORTRAN ***/
 108: #endif
 109:             case 's': s++; x=SS; pp1=0; pp2=1; break;
 110:             default:  x=S; pp1=0; pp2=1; break;
 111:         }
 112:         op_gen(x,pp1,pp2,0,s);
 113:         break;
 114:     case '/': op_gen(SLASH,0,0,0,s); break;
 115: 
 116:     case '-': sign=1;   /* OUTRAGEOUS CODING */
 117:     case '+': s++;      /* OUTRAGEOUS CODING */
 118:     case '0': case '1': case '2': case '3': case '4':
 119:     case '5': case '6': case '7': case '8': case '9':
 120:         s=gt_num(s,&n);
 121:         switch(lcase(*s))
 122:         {
 123:         case 'p': if(sign) n= -n; op_gen(P,n,0,0,s); break;
 124: #ifndef KOSHER
 125:         case 'r': if(n<=1)      /*** NOT STANDARD FORTRAN ***/
 126:             {   fmtptr = s; return(FMTERR); }
 127:             op_gen(R,n,0,0,s); break;
 128:         case 't': op_gen(T,0,n,0,s); break; /* NOT STANDARD FORT */
 129: #endif
 130:         case 'x': op_gen(X,n,0,0,s); break;
 131:         case 'h': op_gen(H,n,(int)(s+1),0,s);
 132:             s+=n;
 133:             break;
 134:         default: fmtptr = s; return(0);
 135:         }
 136:         break;
 137:     case GLITCH:
 138:     case '"':
 139:     case '\'': op_gen(APOS,(int)s,0,0,s);
 140:         *p = ap_end(s);
 141:         return(FMTOK);
 142:     case 't':
 143:         switch(lcase(*(s+1)))
 144:         {
 145:             case 'l': s++; x=TL; break;
 146:             case 'r': s++; x=TR; break;
 147:             default:  x=T; break;
 148:         }
 149:         if(isdigit(*(s+1))) {s=gt_num(s+1,&n); s--;}
 150: #ifndef KOSHER
 151:         else n = 0; /* NOT STANDARD FORTRAN, should be error */
 152: #endif
 153: #ifdef KOSHER
 154:         fmtptr = s; return(FMTERR);
 155: #endif
 156:         op_gen(x,n,1,0,s);
 157:         break;
 158:     case 'x': op_gen(X,1,0,0,s); break;
 159:     case 'p': op_gen(P,0,0,0,s); break;
 160: #ifndef KOSHER
 161:     case 'r': op_gen(R,10,1,0,s); break;  /*** NOT STANDARD FORTRAN ***/
 162: #endif
 163: 
 164:     default: fmtptr = s; return(0);
 165:     }
 166:     s++;
 167:     *p=s;
 168:     return(FMTOK);
 169: }
 170: 
 171: e_d(s,p) char *s,**p;
 172: {   int n,w,d,e,x=0;
 173:     char *sv=s;
 174:     char c;
 175:     s=gt_num(s,&n);
 176:     op_gen(STACK,n,0,0,s);
 177:     c = lcase(*s); s++;
 178:     switch(c)
 179:     {
 180:     case 'd':
 181:     case 'e':
 182:     case 'g':
 183:         s = gt_num(s, &w);
 184:         if (w==0) break;
 185:         if(*s=='.')
 186:         {   s++;
 187:             s=gt_num(s,&d);
 188:         }
 189:         else d=0;
 190:         if(lcase(*s) == 'e'
 191: #ifndef KOSHER
 192:         || *s == '.'         /*** '.' is NOT STANDARD FORTRAN ***/
 193: #endif
 194:         )
 195:         {   s++;
 196:             s=gt_num(s,&e);
 197:             if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE;
 198:         }
 199:         else
 200:         {   e=2;
 201:             if(c=='e') n=E; else if(c=='d') n=D; else n=G;
 202:         }
 203:         op_gen(n,w,d,e,s);
 204:         break;
 205:     case 'l':
 206:         s = gt_num(s, &w);
 207:         if (w==0) break;
 208:         op_gen(L,w,0,0,s);
 209:         break;
 210:     case 'a':
 211:         skip(s);
 212:         if(*s>='0' && *s<='9')
 213:         {   s=gt_num(s,&w);
 214:             if(w==0) break;
 215:             op_gen(AW,w,0,0,s);
 216:             break;
 217:         }
 218:         op_gen(A,0,0,0,s);
 219:         break;
 220:     case 'f':
 221:         s = gt_num(s, &w);
 222:         if (w==0) break;
 223:         if(*s=='.')
 224:         {   s++;
 225:             s=gt_num(s,&d);
 226:         }
 227:         else d=0;
 228:         op_gen(F,w,d,0,s);
 229:         break;
 230:     case 'i':
 231:         s = gt_num(s, &w);
 232:         if (w==0) break;
 233:         if(*s =='.')
 234:         {
 235:             s++;
 236:             s=gt_num(s,&d);
 237:             x = IM;
 238:         }
 239:         else
 240:         {   d = 1;
 241:             x = I;
 242:         }
 243:         op_gen(x,w,d,0,s);
 244:         break;
 245:     default:
 246:         pc--;   /* unSTACK */
 247:         *p = sv;
 248:         fmtptr = s;
 249:         return(FMTERR);
 250:     }
 251:     *p = s;
 252:     return(FMTOK);
 253: }
 254: 
 255: op_gen(a,b,c,d,s) char *s;
 256: {   struct syl *p= &syl[pc];
 257:     if(pc>=SYLMX)
 258:     {   fmtptr = s;
 259:         fatal(F_ERFMT,"format too complex");
 260:     }
 261: #ifdef DEBUG
 262:     fprintf(stderr,"%3d opgen: %d %d %d %d %c\n",
 263:         pc,a,b,c,d,*s==GLITCH?'"':*s); /* for debug */
 264: #endif
 265:     p->op=a;
 266:     p->p1=b;
 267:     p->p2=c;
 268:     p->p3=d;
 269:     return(pc++);
 270: }
 271: 
 272: char *gt_num(s,n) char *s; int *n;
 273: {   int m=0,a_digit=NO;
 274:     skip(s);
 275:     while(isdigit(*s) || isspace(*s))
 276:     {
 277:         if (isdigit(*s))
 278:         {
 279:             m = 10*m + (*s)-'0';
 280:             a_digit = YES;
 281:         }
 282:         s++;
 283:     }
 284:     if(a_digit) *n=m;
 285:     else *n=1;
 286:     return(s);
 287: }
 288: 
 289: char *ap_end(s) char *s;
 290: {
 291:     char quote;
 292:     quote = *s++;
 293:     for(;*s;s++)
 294:     {
 295:         if(*s==quote && *++s!=quote) return(s);
 296:     }
 297:     fmtptr = s;
 298:     fatal(F_ERFMT,"bad string");
 299: }

Defined functions

Defined variables

Defined macros