![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fmt.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / usr.bin / f77 / src / f77pass1|
Return to fmt.c CVS log | Up to [CSRG BSD Unix] / 43BSD / usr.bin / f77 / src / f77pass1 |
1.1 ! root 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 vax ! 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.