|
|
1.1 ! root 1: /* ! 2: * formatted read routines ! 3: */ ! 4: ! 5: #include "fio.h" ! 6: #include "fmt.h" ! 7: ! 8: #define isdigit(c) (c>='0' && c<='9') ! 9: #define isalpha(c) (c>='a' && c<='z') ! 10: ! 11: rd_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len; ! 12: { int n; ! 13: if(cursor && (n=rd_mvcur())) return(n); ! 14: switch(p->op) ! 15: { ! 16: case I: ! 17: case IM: ! 18: n = (rd_I(ptr,p->p1,len)); ! 19: break; ! 20: case L: ! 21: n = (rd_L(ptr,p->p1)); ! 22: break; ! 23: case A: ! 24: p->p1 = len; /* cheap trick */ ! 25: case AW: ! 26: n = (rd_AW(ptr,p->p1,len)); ! 27: break; ! 28: case E: ! 29: case EE: ! 30: case D: ! 31: case DE: ! 32: case G: ! 33: case GE: ! 34: case F: ! 35: n = (rd_F(ptr,p->p1,p->p2,len)); ! 36: break; ! 37: default: ! 38: return(errno=100); ! 39: } ! 40: if (n < 0) ! 41: { ! 42: if(feof(cf)) return(EOF); ! 43: n = errno; ! 44: clearerr(cf); ! 45: } ! 46: return(n); ! 47: } ! 48: ! 49: rd_ned(p,ptr) char *ptr; struct syl *p; ! 50: { ! 51: switch(p->op) ! 52: { ! 53: /* case APOS: ! 54: /* return(rd_POS(p->p1)); ! 55: /* case H: ! 56: /* return(rd_H(p->p1,p->p2)); */ ! 57: case SLASH: ! 58: return((*donewrec)()); ! 59: case TR: ! 60: case X: ! 61: cursor += p->p1; ! 62: tab = (p->op==TR); ! 63: return(OK); ! 64: case T: ! 65: if(p->p1) cursor = p->p1 - recpos - 1; ! 66: #ifndef KOSHER ! 67: else cursor = 8*p->p2 - recpos%8; /* NOT STANDARD FORT */ ! 68: #endif ! 69: tab = YES; ! 70: return(OK); ! 71: case TL: ! 72: cursor -= p->p1; ! 73: tab = YES; ! 74: return(OK); ! 75: default: ! 76: return(errno=100); ! 77: } ! 78: } ! 79: ! 80: rd_mvcur() ! 81: { int n; ! 82: if(tab) return((*dotab)()); ! 83: while(cursor--) if((n=(*getn)()) < 0) return(n); ! 84: return(cursor=0); ! 85: } ! 86: ! 87: rd_I(n,w,len) ftnlen len; uint *n; ! 88: { long x=0; ! 89: int i,sign=0,ch,c; ! 90: for(i=0;i<w;i++) ! 91: { ! 92: if((ch=(*getn)())<0) return(ch); ! 93: switch(ch=lcase(ch)) ! 94: { ! 95: case ',': goto done; ! 96: case '+': break; ! 97: case '-': ! 98: sign=1; ! 99: break; ! 100: case ' ': ! 101: if(cblank) x *= radix; ! 102: break; ! 103: case '\n': goto done; ! 104: default: ! 105: if(isdigit(ch)) ! 106: { if ((c=(ch-'0')) < radix) ! 107: { x = (x * radix) + c; ! 108: break; ! 109: } ! 110: } ! 111: else if(isalpha(ch)) ! 112: { if ((c=(ch-'a'+10)) < radix) ! 113: { x = (x * radix) + c; ! 114: break; ! 115: } ! 116: } ! 117: return(errno=115); ! 118: } ! 119: } ! 120: done: ! 121: if(sign) x = -x; ! 122: if(len==sizeof(short)) n->is=x; ! 123: else n->il=x; ! 124: return(OK); ! 125: } ! 126: ! 127: rd_L(n,w) ftnint *n; ! 128: { int ch,i,v = -1; ! 129: for(i=0;i<w;i++) ! 130: { if((ch=(*getn)()) < 0) return(ch); ! 131: if((ch=lcase(ch))=='t' && v==-1) v=1; ! 132: else if(ch=='f' && v==-1) v=0; ! 133: else if(ch==',') break; ! 134: } ! 135: if(v==-1) return(errno=116); ! 136: *n=v; ! 137: return(OK); ! 138: } ! 139: ! 140: rd_F(p,w,d,len) ftnlen len; ufloat *p; ! 141: { double x,y; ! 142: int i,sx,sz,ch,dot,ny,z,sawz; ! 143: x=y=0; ! 144: sawz=z=ny=dot=sx=sz=0; ! 145: for(i=0;i<w;) ! 146: { i++; ! 147: if((ch=(*getn)())<0) return(ch); ! 148: ch=lcase(ch); ! 149: if(ch==' ' && !cblank || ch=='+') continue; ! 150: else if(ch=='-') sx=1; ! 151: else if(ch<='9' && ch>='0') ! 152: x=10*x+ch-'0'; ! 153: else if(ch=='e' || ch=='d' || ch=='.') ! 154: break; ! 155: else if(cblank && ch==' ') x*=10; ! 156: else if(ch==',') ! 157: { i=w; ! 158: break; ! 159: } ! 160: else if(ch!='\n') return(errno=115); ! 161: } ! 162: if(ch=='.') dot=1; ! 163: while(i<w && ch!='e' && ch!='d' && ch!='+' && ch!='-') ! 164: { i++; ! 165: if((ch=(*getn)())<0) return(ch); ! 166: ch = lcase(ch); ! 167: if(ch<='9' && ch>='0') ! 168: y=10*y+ch-'0'; ! 169: else if(cblank && ch==' ') ! 170: y *= 10; ! 171: else if(ch==',') {i=w; break;} ! 172: else if(ch==' ') continue; ! 173: else continue; ! 174: ny++; ! 175: } ! 176: if(ch=='-') sz=1; ! 177: while(i<w) ! 178: { i++; ! 179: sawz=1; ! 180: if((ch=(*getn)())<0) return(ch); ! 181: ch = lcase(ch); ! 182: if(ch=='-') sz=1; ! 183: else if(ch<='9' && ch>='0') ! 184: z=10*z+ch-'0'; ! 185: else if(cblank && ch==' ') ! 186: z *= 10; ! 187: else if(ch==',') break; ! 188: else if(ch==' ') continue; ! 189: else if(ch=='+') continue; ! 190: else if(ch!='\n') return(errno=115); ! 191: } ! 192: if(!dot) ! 193: for(i=0;i<d;i++) x /= 10; ! 194: for(i=0;i<ny;i++) y /= 10; ! 195: x=x+y; ! 196: if(sz) ! 197: for(i=0;i<z;i++) x /=10; ! 198: else for(i=0;i<z;i++) x *= 10; ! 199: if(sx) x = -x; ! 200: if(!sawz) ! 201: { ! 202: for(i=scale;i>0;i--) x /= 10; ! 203: for(i=scale;i<0;i++) x *= 10; ! 204: } ! 205: if(len==sizeof(float)) p->pf=x; ! 206: else p->pd=x; ! 207: return(OK); ! 208: } ! 209: ! 210: rd_AW(p,w,len) char *p; ftnlen len; ! 211: { int i,ch; ! 212: if(w >= len) ! 213: { ! 214: for(i=0;i<w-len;i++) GET(ch); ! 215: for(i=0;i<len;i++) ! 216: { GET(ch); ! 217: *p++=VAL(ch); ! 218: } ! 219: } ! 220: else ! 221: { ! 222: for(i=0;i<w;i++) ! 223: { GET(ch); ! 224: *p++=VAL(ch); ! 225: } ! 226: for(i=0;i<len-w;i++) *p++=' '; ! 227: } ! 228: return(OK); ! 229: } ! 230: ! 231: /* THIS IS NOT ALLOWED IN THE NEW STANDARD 'CAUSE IT'S WEIRD */ ! 232: /*rd_H(n,s) char *s; ! 233: /*{ int i,ch; ! 234: /* for(i=0;i<n;i++) ! 235: /* if((ch=(*getn)())<0) return(ch); ! 236: /* else if(ch=='\n') for(;i<n;i++) *s++ = ' '; ! 237: /* else *s++ = ch; ! 238: /* return(OK); ! 239: /*} ! 240: */ ! 241: /*rd_POS(s) char *s; ! 242: /*{ char quote; ! 243: /* int ch; ! 244: /* quote= *s++; ! 245: /* for(;*s;s++) ! 246: /* if(*s==quote && *(s+1)!=quote) break; ! 247: /* else if((ch=(*getn)())<0) return(ch); ! 248: /* else *s = ch=='\n'?' ':ch; ! 249: /* return(OK); ! 250: /*} ! 251: */
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.