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