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 } 300