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

Defined functions

Defined variables

Defined macros