![[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] / 43BSDTahoe / usr.lib / libI77|
Return to fmt.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / usr.lib / libI77 |
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: * @(#)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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.