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