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