1 /* 2 char id_fmt[] = "@(#)fmt.c 1.9"; 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 LOCAL struct syl syl_vec[SYLMX]; 27 struct syl *syl_ptr; 28 LOCAL int parenlvl,revloc; 29 int low_case[256]; 30 short pc; 31 char *f_s(), *f_list(), *i_tem(), *gt_num(), *ap_end(); 32 char *s_init; 33 34 pars_f() 35 { 36 short *s_ptr; 37 long *l_ptr; 38 int i; 39 40 /* first time, initialize low_case[] */ 41 if( low_case[1] == 0 ) { 42 for(i = 0; i<256; i++) low_case[i]=i; 43 for(i = 'A'; i<='Z'; i++) low_case[i]=i-'A'+'a'; 44 } 45 46 parenlvl=revloc=pc=0; 47 48 s_ptr = (short *) fmtbuf; 49 if( *s_ptr == FMT_COMP ) { 50 /* already compiled - copy value of pc */ 51 pc = *(s_ptr+1); 52 /* get address of the format */ 53 l_ptr = (long *) fmtbuf; 54 fmtbuf = s_init = (char *) *(l_ptr+1); 55 /* point syl_ptr to the compiled format */ 56 syl_ptr = (struct syl *) (l_ptr + 2); 57 return(OK); 58 } else { 59 syl_ptr = syl_vec; 60 s_init = fmtbuf; 61 return((f_s(fmtbuf,0)==FMTERR)? ERROR : OK); 62 } 63 } 64 65 LOCAL 66 char *f_s(s,curloc) char *s; 67 { 68 skip(s); 69 if(*s++!='(') 70 { 71 fmtptr = s; 72 return(FMTERR); 73 } 74 if(parenlvl++ ==1) revloc=curloc; 75 op_gen(RET,curloc,0,0,s); 76 if((s=f_list(s))==FMTERR) 77 { 78 return(FMTERR); 79 } 80 skip(s); 81 return(s); 82 } 83 84 LOCAL 85 char *f_list(s) char *s; 86 { 87 while (*s) 88 { skip(s); 89 if((s=i_tem(s))==FMTERR) return(FMTERR); 90 skip(s); 91 if(*s==',') s++; 92 else if(*s==')') 93 { if(--parenlvl==0) 94 op_gen(REVERT,revloc,0,0,s); 95 else 96 op_gen(GOTO,0,0,0,s); 97 return(++s); 98 } 99 } 100 fmtptr = s; 101 return(FMTERR); 102 } 103 104 LOCAL 105 char *i_tem(s) char *s; 106 { char *t; 107 int n,curloc; 108 if(*s==')') return(s); 109 if ((n=ne_d(s,&t))==FMTOK) 110 return(t); 111 else if (n==FMTERR) 112 return(FMTERR); 113 if ((n=e_d(s,&t))==FMTOK) 114 return(t); 115 else if (n==FMTERR) 116 return(FMTERR); 117 s=gt_num(s,&n); 118 if (n == 0) { fmtptr = s; return(FMTERR); } 119 curloc = op_gen(STACK,n,0,0,s); 120 return(f_s(s,curloc)); 121 } 122 123 LOCAL 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 break; 176 default: fmtptr = s; return(FMTUNKN); 177 } 178 break; 179 case GLITCH: 180 case '"': 181 case '\'': op_gen(APOS,s-s_init,0,0,s); 182 *p = ap_end(s); 183 return(FMTOK); 184 case 't': 185 switch(low_case[*(s+1)]) 186 { 187 case 'l': s++; x=TL; break; 188 case 'r': s++; x=TR; break; 189 default: x=T; break; 190 } 191 if(isdigit(*(s+1))) {s=gt_num(s+1,&n); s--;} 192 #ifdef KOSHER 193 else { fmtptr = s; return(FMTERR); } 194 #else 195 else n = 0; /* NOT STANDARD FORTRAN, should be error */ 196 #endif 197 op_gen(x,n,1,0,s); 198 break; 199 case 'x': op_gen(X,1,0,0,s); break; 200 case 'p': op_gen(P,0,0,0,s); break; 201 #ifndef KOSHER 202 case 'r': op_gen(R,10,1,0,s); break; /*** NOT STANDARD FORTRAN ***/ 203 #endif 204 205 default: fmtptr = s; return(FMTUNKN); 206 } 207 s++; 208 *p=s; 209 return(FMTOK); 210 } 211 212 LOCAL 213 e_d(s,p) char *s,**p; 214 { int n,w,d,e,x=0, rep_count; 215 char *sv=s; 216 char c; 217 s=gt_num(s,&rep_count); 218 if (rep_count == 0) goto ed_err; 219 c = low_case[*s]; s++; 220 switch(c) 221 { 222 case 'd': 223 case 'e': 224 case 'g': 225 s = gt_num(s, &w); 226 if (w==0) goto ed_err; 227 if(*s=='.') 228 { s++; 229 s=gt_num(s,&d); 230 } 231 else d=0; 232 if(low_case[*s] == 'e' 233 #ifndef KOSHER 234 || *s == '.' /*** '.' is NOT STANDARD FORTRAN ***/ 235 #endif 236 ) 237 { s++; 238 s=gt_num(s,&e); 239 if (e==0 || e>127 || d>127 ) goto ed_err; 240 if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE; 241 op_gen(n,w,d + (e<<8),rep_count,s); 242 } 243 else 244 { 245 if(c=='e') n=E; else if(c=='d') n=D; else n=G; 246 op_gen(n,w,d,rep_count,s); 247 } 248 break; 249 case 'l': 250 s = gt_num(s, &w); 251 if (w==0) goto ed_err; 252 op_gen(L,w,0,rep_count,s); 253 break; 254 case 'a': 255 skip(s); 256 if(isdigit(*s)) 257 { s=gt_num(s,&w); 258 #ifdef KOSHER 259 if (w==0) goto ed_err; 260 #else 261 if (w==0) op_gen(A,0,0,rep_count,s); 262 else 263 #endif 264 op_gen(AW,w,0,rep_count,s); 265 break; 266 } 267 op_gen(A,0,0,rep_count,s); 268 break; 269 case 'f': 270 s = gt_num(s, &w); 271 if (w==0) goto ed_err; 272 if(*s=='.') 273 { s++; 274 s=gt_num(s,&d); 275 } 276 else d=0; 277 op_gen(F,w,d,rep_count,s); 278 break; 279 #ifndef KOSHER 280 case 'o': /*** octal format - NOT STANDARD FORTRAN ***/ 281 case 'z': /*** hex format - NOT STANDARD FORTRAN ***/ 282 #endif 283 case 'i': 284 s = gt_num(s, &w); 285 if (w==0) goto ed_err; 286 if(*s =='.') 287 { 288 s++; 289 s=gt_num(s,&d); 290 x = IM; 291 } 292 else 293 { d = 1; 294 x = I; 295 } 296 #ifndef KOSHER 297 if (c == 'o') 298 op_gen(R,8,1,rep_count,s); 299 else if (c == 'z') 300 op_gen(R,16,1,rep_count,s); 301 #endif 302 op_gen(x,w,d,rep_count,s); 303 #ifndef KOSHER 304 if (c == 'o' || c == 'z') 305 op_gen(R,10,1,rep_count,s); 306 #endif 307 break; 308 default: 309 *p = sv; 310 fmtptr = s; 311 return(FMTUNKN); 312 } 313 *p = s; 314 return(FMTOK); 315 ed_err: 316 fmtptr = --s; 317 return(FMTERR); 318 } 319 320 LOCAL 321 op_gen(a,b,c,rep,s) char *s; 322 { struct syl *p= &syl_ptr[pc]; 323 if(pc>=SYLMX) 324 { fmtptr = s; 325 fatal(F_ERFMT,"format too complex"); 326 } 327 if( b>32767 || c>32767 || rep>32767 ) 328 { fmtptr = s; 329 fatal("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 LOCAL 343 char *gt_num(s,n) char *s; int *n; 344 { int m=0,a_digit=NO; 345 skip(s); 346 while(isdigit(*s) || isspace(*s)) 347 { 348 if (isdigit(*s)) 349 { 350 m = 10*m + (*s)-'0'; 351 a_digit = YES; 352 } 353 s++; 354 } 355 if(a_digit) *n=m; 356 else *n=1; 357 return(s); 358 } 359 360 LOCAL 361 char *ap_end(s) char *s; 362 { 363 char quote; 364 quote = *s++; 365 for(;*s;s++) 366 { 367 if(*s==quote && *++s!=quote) return(s); 368 } 369 fmtptr = s; 370 fatal(F_ERFMT,"bad string"); 371 } 372