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