1 /* 2 char id_fmt[] = "@(#)fmt.c 1.2"; 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 'z': s++; op_gen(BZ,1,0,0,s); break; 97 case 'n': s++; 98 default: op_gen(BN,0,0,0,s); break; 99 } 100 break; 101 case 's': 102 switch(lcase(*(s+1))) 103 { 104 case 'p': s++; x=SP; pp1=1; pp2=1; break; 105 #ifndef KOSHER 106 case 'u': s++; x=SU; pp1=0; pp2=0; break; /*** NOT STANDARD FORTRAN ***/ 107 #endif 108 case 's': s++; x=SS; pp1=0; pp2=1; break; 109 default: x=S; pp1=0; pp2=1; break; 110 } 111 op_gen(x,pp1,pp2,0,s); 112 break; 113 case '/': op_gen(SLASH,0,0,0,s); break; 114 case '-': sign=1; s++; /*OUTRAGEOUS CODING TRICK*/ 115 case '0': case '1': case '2': case '3': case '4': 116 case '5': case '6': case '7': case '8': case '9': 117 s=gt_num(s,&n); 118 switch(lcase(*s)) 119 { 120 case 'p': if(sign) n= -n; op_gen(P,n,0,0,s); break; 121 #ifndef KOSHER 122 case 'r': if(n<=1) /*** NOT STANDARD FORTRAN ***/ 123 { fmtptr = s; return(FMTERR); } 124 op_gen(R,n,0,0,s); break; 125 case 't': op_gen(T,0,n,0,s); break; /* NOT STANDARD FORT */ 126 #endif 127 case 'x': op_gen(X,n,0,0,s); break; 128 case 'h': op_gen(H,n,(int)(s+1),0,s); 129 s+=n; 130 break; 131 default: fmtptr = s; return(0); 132 } 133 break; 134 case GLITCH: 135 case '"': 136 case '\'': op_gen(APOS,(int)s,0,0,s); 137 *p = ap_end(s); 138 return(FMTOK); 139 case 't': 140 switch(lcase(*(s+1))) 141 { 142 case 'l': s++; x=TL; break; 143 case 'r': s++; x=TR; break; 144 default: x=T; break; 145 } 146 if(isdigit(*(s+1))) {s=gt_num(s+1,&n); s--;} 147 #ifndef KOSHER 148 else n = 0; /* NOT STANDARD FORTRAN, should be error */ 149 #endif 150 #ifdef KOSHER 151 fmtptr = s; return(FMTERR); 152 #endif 153 op_gen(x,n,1,0,s); 154 break; 155 case 'x': op_gen(X,1,0,0,s); break; 156 case 'p': op_gen(P,0,0,0,s); break; 157 #ifndef KOSHER 158 case 'r': op_gen(R,10,1,0,s); break; /*** NOT STANDARD FORTRAN ***/ 159 #endif 160 161 default: fmtptr = s; return(0); 162 } 163 s++; 164 *p=s; 165 return(FMTOK); 166 } 167 168 e_d(s,p) char *s,**p; 169 { int n,w,d,e,x=0; 170 char *sv=s; 171 char c; 172 s=gt_num(s,&n); 173 op_gen(STACK,n,0,0,s); 174 c = lcase(*s); s++; 175 switch(c) 176 { 177 case 'd': 178 case 'e': 179 case 'g': 180 s = gt_num(s, &w); 181 if (w==0) break; 182 if(*s=='.') 183 { s++; 184 s=gt_num(s,&d); 185 } 186 else d=0; 187 if(lcase(*s) == 'e' 188 #ifndef KOSHER 189 || *s == '.' /*** '.' is NOT STANDARD FORTRAN ***/ 190 #endif 191 ) 192 { s++; 193 s=gt_num(s,&e); 194 if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE; 195 } 196 else 197 { e=2; 198 if(c=='e') n=E; else if(c=='d') n=D; else n=G; 199 } 200 op_gen(n,w,d,e,s); 201 break; 202 case 'l': 203 s = gt_num(s, &w); 204 if (w==0) break; 205 op_gen(L,w,0,0,s); 206 break; 207 case 'a': 208 skip(s); 209 if(*s>='0' && *s<='9') 210 { s=gt_num(s,&w); 211 if(w==0) break; 212 op_gen(AW,w,0,0,s); 213 break; 214 } 215 op_gen(A,0,0,0,s); 216 break; 217 case 'f': 218 s = gt_num(s, &w); 219 if (w==0) break; 220 if(*s=='.') 221 { s++; 222 s=gt_num(s,&d); 223 } 224 else d=0; 225 op_gen(F,w,d,0,s); 226 break; 227 case 'i': 228 s = gt_num(s, &w); 229 if (w==0) break; 230 if(*s =='.') 231 { 232 s++; 233 s=gt_num(s,&d); 234 x = IM; 235 } 236 else 237 { d = 1; 238 x = I; 239 } 240 op_gen(x,w,d,0,s); 241 break; 242 default: 243 pc--; /* unSTACK */ 244 *p = sv; 245 fmtptr = s; 246 return(FMTERR); 247 } 248 *p = s; 249 return(FMTOK); 250 } 251 252 op_gen(a,b,c,d,s) char *s; 253 { struct syl *p= &syl[pc]; 254 if(pc>=SYLMX) 255 { fmtptr = s; 256 fatal(F_ERFMT,"format too complex"); 257 } 258 #ifdef DEBUG 259 fprintf(stderr,"%3d opgen: %d %d %d %d %c\n", 260 pc,a,b,c,d,*s==GLITCH?'"':*s); /* for debug */ 261 #endif 262 p->op=a; 263 p->p1=b; 264 p->p2=c; 265 p->p3=d; 266 return(pc++); 267 } 268 269 char *gt_num(s,n) char *s; int *n; 270 { int m=0,a_digit=NO; 271 skip(s); 272 while(isdigit(*s) || isspace(*s)) 273 { 274 if (isdigit(*s)) 275 { 276 m = 10*m + (*s)-'0'; 277 a_digit = YES; 278 } 279 s++; 280 } 281 if(a_digit) *n=m; 282 else *n=1; 283 return(s); 284 } 285 286 char *ap_end(s) char *s; 287 { 288 char quote; 289 quote = *s++; 290 for(;*s;s++) 291 { 292 if(*s==quote && *++s!=quote) return(s); 293 } 294 fmtptr = s; 295 fatal(F_ERFMT,"bad string"); 296 } 297