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