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