projects / unix-history / blame
| Commit | Line | Data |
|---|---|---|
| bae7117f WH |
1 | #include "f2c.h" |
| 2 | #include "fio.h" | |
| 3 | #include "fmt.h" | |
| 4 | #include "fp.h" | |
| 5 | ||
| 6 | extern int f__cursor; | |
| 7 | #ifdef KR_headers | |
| 8 | extern double atof(); | |
| 9 | #else | |
| 10 | #undef abs | |
| 11 | #undef min | |
| 12 | #undef max | |
| 13 | #include "stdlib.h" | |
| 14 | #endif | |
| 15 | ||
| 16 | static int | |
| 17 | #ifdef KR_headers | |
| 18 | rd_Z(n,w,len) Uint *n; ftnlen len; | |
| 19 | #else | |
| 20 | rd_Z(Uint *n, int w, ftnlen len) | |
| 21 | #endif | |
| 22 | { | |
| 23 | long x[9]; | |
| 24 | char *s, *s0, *s1, *se, *t; | |
| 25 | int ch, i, w1, w2; | |
| 26 | static char hex[256]; | |
| 27 | static int one = 1; | |
| 28 | int bad = 0; | |
| 29 | ||
| 30 | if (!hex['0']) { | |
| 31 | s = "0123456789"; | |
| 32 | while(ch = *s++) | |
| 33 | hex[ch] = ch - '0' + 1; | |
| 34 | s = "ABCDEF"; | |
| 35 | while(ch = *s++) | |
| 36 | hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11; | |
| 37 | } | |
| 38 | s = s0 = (char *)x; | |
| 39 | s1 = (char *)&x[4]; | |
| 40 | se = (char *)&x[8]; | |
| 41 | if (len > 4*sizeof(long)) | |
| 42 | return errno = 117; | |
| 43 | while (w) { | |
| 44 | GET(ch); | |
| 45 | if (ch==',' || ch=='\n') | |
| 46 | break; | |
| 47 | w--; | |
| 48 | if (ch > ' ') { | |
| 49 | if (!hex[ch & 0xff]) | |
| 50 | bad++; | |
| 51 | *s++ = ch; | |
| 52 | if (s == se) { | |
| 53 | /* discard excess characters */ | |
| 54 | for(t = s0, s = s1; t < s1;) | |
| 55 | *t++ = *s++; | |
| 56 | s = s1; | |
| 57 | } | |
| 58 | } | |
| 59 | } | |
| 60 | if (bad) | |
| 61 | return errno = 115; | |
| 62 | w = (int)len; | |
| 63 | w1 = s - s0; | |
| 64 | w2 = w1+1 >> 1; | |
| 65 | t = (char *)n; | |
| 66 | if (*(char *)&one) { | |
| 67 | /* little endian */ | |
| 68 | t += w - 1; | |
| 69 | i = -1; | |
| 70 | } | |
| 71 | else | |
| 72 | i = 1; | |
| 73 | for(; w > w2; t += i, --w) | |
| 74 | *t = 0; | |
| 75 | if (!w) | |
| 76 | return 0; | |
| 77 | if (w < w2) | |
| 78 | s0 = s - (w << 1); | |
| 79 | else if (w1 & 1) { | |
| 80 | *t = hex[*s0++ & 0xff] - 1; | |
| 81 | if (!--w) | |
| 82 | return 0; | |
| 83 | t += i; | |
| 84 | } | |
| 85 | do { | |
| 86 | *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1; | |
| 87 | t += i; | |
| 88 | s0 += 2; | |
| 89 | } | |
| 90 | while(--w); | |
| 91 | return 0; | |
| 92 | } | |
| 93 | ||
| 94 | static int | |
| 95 | #ifdef KR_headers | |
| 96 | rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base; | |
| 97 | #else | |
| 98 | rd_I(Uint *n, int w, ftnlen len, register int base) | |
| 99 | #endif | |
| 100 | { long x; | |
| 101 | int sign,ch; | |
| 102 | char s[84], *ps; | |
| 103 | ps=s; x=0; | |
| 104 | while (w) | |
| 105 | { | |
| 106 | GET(ch); | |
| 107 | if (ch==',' || ch=='\n') break; | |
| 108 | *ps=ch; ps++; w--; | |
| 109 | } | |
| 110 | *ps='\0'; | |
| 111 | ps=s; | |
| 112 | while (*ps==' ') ps++; | |
| 113 | if (*ps=='-') { sign=1; ps++; } | |
| 114 | else { sign=0; if (*ps=='+') ps++; } | |
| 115 | loop: while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; } | |
| 116 | if (*ps==' ') {if (f__cblank) x *= base; ps++; goto loop;} | |
| 117 | if(sign) x = -x; | |
| 118 | if(len==sizeof(integer)) n->il=x; | |
| 119 | else if(len == sizeof(char)) n->ic = (char)x; | |
| 120 | #ifdef Allow_TYQUAD | |
| 121 | else if (len == sizeof(longint)) n->ili = x; | |
| 122 | #endif | |
| 123 | else n->is = (short)x; | |
| 124 | if (*ps) return(errno=115); else return(0); | |
| 125 | } | |
| 126 | static int | |
| 127 | #ifdef KR_headers | |
| 128 | rd_L(n,w,len) ftnint *n; ftnlen len; | |
| 129 | #else | |
| 130 | rd_L(ftnint *n, int w, ftnlen len) | |
| 131 | #endif | |
| 132 | { int ch, lv; | |
| 133 | char s[84], *ps; | |
| 134 | ps=s; | |
| 135 | while (w) { | |
| 136 | GET(ch); | |
| 137 | if (ch==','||ch=='\n') break; | |
| 138 | *ps=ch; | |
| 139 | ps++; w--; | |
| 140 | } | |
| 141 | *ps='\0'; | |
| 142 | ps=s; while (*ps==' ') ps++; | |
| 143 | if (*ps=='.') ps++; | |
| 144 | if (*ps=='t' || *ps == 'T') | |
| 145 | lv = 1; | |
| 146 | else if (*ps == 'f' || *ps == 'F') | |
| 147 | lv = 0; | |
| 148 | else return(errno=116); | |
| 149 | switch(len) { | |
| 150 | case sizeof(char): *(char *)n = (char)lv; break; | |
| 151 | case sizeof(short): *(short *)n = (short)lv; break; | |
| 152 | default: *n = lv; | |
| 153 | } | |
| 154 | return 0; | |
| 155 | } | |
| 156 | ||
| 157 | #include "ctype.h" | |
| 158 | ||
| 159 | static int | |
| 160 | #ifdef KR_headers | |
| 161 | rd_F(p, w, d, len) ufloat *p; ftnlen len; | |
| 162 | #else | |
| 163 | rd_F(ufloat *p, int w, int d, ftnlen len) | |
| 164 | #endif | |
| 165 | { | |
| 166 | char s[FMAX+EXPMAXDIGS+4]; | |
| 167 | register int ch; | |
| 168 | register char *sp, *spe, *sp1; | |
| 169 | double x; | |
| 170 | int scale1, se; | |
| 171 | long e, exp; | |
| 172 | ||
| 173 | sp1 = sp = s; | |
| 174 | spe = sp + FMAX; | |
| 175 | exp = -d; | |
| 176 | x = 0.; | |
| 177 | ||
| 178 | do { | |
| 179 | GET(ch); | |
| 180 | w--; | |
| 181 | } while (ch == ' ' && w); | |
| 182 | switch(ch) { | |
| 183 | case '-': *sp++ = ch; sp1++; spe++; | |
| 184 | case '+': | |
| 185 | if (!w) goto zero; | |
| 186 | --w; | |
| 187 | GET(ch); | |
| 188 | } | |
| 189 | while(ch == ' ') { | |
| 190 | blankdrop: | |
| 191 | if (!w--) goto zero; GET(ch); } | |
| 192 | while(ch == '0') | |
| 193 | { if (!w--) goto zero; GET(ch); } | |
| 194 | if (ch == ' ' && f__cblank) | |
| 195 | goto blankdrop; | |
| 196 | scale1 = f__scale; | |
| 197 | while(isdigit(ch)) { | |
| 198 | digloop1: | |
| 199 | if (sp < spe) *sp++ = ch; | |
| 200 | else ++exp; | |
| 201 | digloop1e: | |
| 202 | if (!w--) goto done; | |
| 203 | GET(ch); | |
| 204 | } | |
| 205 | if (ch == ' ') { | |
| 206 | if (f__cblank) | |
| 207 | { ch = '0'; goto digloop1; } | |
| 208 | goto digloop1e; | |
| 209 | } | |
| 210 | if (ch == '.') { | |
| 211 | exp += d; | |
| 212 | if (!w--) goto done; | |
| 213 | GET(ch); | |
| 214 | if (sp == sp1) { /* no digits yet */ | |
| 215 | while(ch == '0') { | |
| 216 | skip01: | |
| 217 | --exp; | |
| 218 | skip0: | |
| 219 | if (!w--) goto done; | |
| 220 | GET(ch); | |
| 221 | } | |
| 222 | if (ch == ' ') { | |
| 223 | if (f__cblank) goto skip01; | |
| 224 | goto skip0; | |
| 225 | } | |
| 226 | } | |
| 227 | while(isdigit(ch)) { | |
| 228 | digloop2: | |
| 229 | if (sp < spe) | |
| 230 | { *sp++ = ch; --exp; } | |
| 231 | digloop2e: | |
| 232 | if (!w--) goto done; | |
| 233 | GET(ch); | |
| 234 | } | |
| 235 | if (ch == ' ') { | |
| 236 | if (f__cblank) | |
| 237 | { ch = '0'; goto digloop2; } | |
| 238 | goto digloop2e; | |
| 239 | } | |
| 240 | } | |
| 241 | switch(ch) { | |
| 242 | default: | |
| 243 | break; | |
| 244 | case '-': se = 1; goto signonly; | |
| 245 | case '+': se = 0; goto signonly; | |
| 246 | case 'e': | |
| 247 | case 'E': | |
| 248 | case 'd': | |
| 249 | case 'D': | |
| 250 | if (!w--) | |
| 251 | goto bad; | |
| 252 | GET(ch); | |
| 253 | while(ch == ' ') { | |
| 254 | if (!w--) | |
| 255 | goto bad; | |
| 256 | GET(ch); | |
| 257 | } | |
| 258 | se = 0; | |
| 259 | switch(ch) { | |
| 260 | case '-': se = 1; | |
| 261 | case '+': | |
| 262 | signonly: | |
| 263 | if (!w--) | |
| 264 | goto bad; | |
| 265 | GET(ch); | |
| 266 | } | |
| 267 | while(ch == ' ') { | |
| 268 | if (!w--) | |
| 269 | goto bad; | |
| 270 | GET(ch); | |
| 271 | } | |
| 272 | if (!isdigit(ch)) | |
| 273 | goto bad; | |
| 274 | ||
| 275 | e = ch - '0'; | |
| 276 | for(;;) { | |
| 277 | if (!w--) | |
| 278 | { ch = '\n'; break; } | |
| 279 | GET(ch); | |
| 280 | if (!isdigit(ch)) { | |
| 281 | if (ch == ' ') { | |
| 282 | if (f__cblank) | |
| 283 | ch = '0'; | |
| 284 | else continue; | |
| 285 | } | |
| 286 | else | |
| 287 | break; | |
| 288 | } | |
| 289 | e = 10*e + ch - '0'; | |
| 290 | if (e > EXPMAX && sp > sp1) | |
| 291 | goto bad; | |
| 292 | } | |
| 293 | if (se) | |
| 294 | exp -= e; | |
| 295 | else | |
| 296 | exp += e; | |
| 297 | scale1 = 0; | |
| 298 | } | |
| 299 | switch(ch) { | |
| 300 | case '\n': | |
| 301 | case ',': | |
| 302 | break; | |
| 303 | default: | |
| 304 | bad: | |
| 305 | return (errno = 115); | |
| 306 | } | |
| 307 | done: | |
| 308 | if (sp > sp1) { | |
| 309 | while(*--sp == '0') | |
| 310 | ++exp; | |
| 311 | if (exp -= scale1) | |
| 312 | sprintf(sp+1, "e%ld", exp); | |
| 313 | else | |
| 314 | sp[1] = 0; | |
| 315 | x = atof(s); | |
| 316 | } | |
| 317 | zero: | |
| 318 | if (len == sizeof(real)) | |
| 319 | p->pf = x; | |
| 320 | else | |
| 321 | p->pd = x; | |
| 322 | return(0); | |
| 323 | } | |
| 324 | ||
| 325 | ||
| 326 | static int | |
| 327 | #ifdef KR_headers | |
| 328 | rd_A(p,len) char *p; ftnlen len; | |
| 329 | #else | |
| 330 | rd_A(char *p, ftnlen len) | |
| 331 | #endif | |
| 332 | { int i,ch; | |
| 333 | for(i=0;i<len;i++) | |
| 334 | { GET(ch); | |
| 335 | *p++=VAL(ch); | |
| 336 | } | |
| 337 | return(0); | |
| 338 | } | |
| 339 | static int | |
| 340 | #ifdef KR_headers | |
| 341 | rd_AW(p,w,len) char *p; ftnlen len; | |
| 342 | #else | |
| 343 | rd_AW(char *p, int w, ftnlen len) | |
| 344 | #endif | |
| 345 | { int i,ch; | |
| 346 | if(w>=len) | |
| 347 | { for(i=0;i<w-len;i++) | |
| 348 | GET(ch); | |
| 349 | for(i=0;i<len;i++) | |
| 350 | { GET(ch); | |
| 351 | *p++=VAL(ch); | |
| 352 | } | |
| 353 | return(0); | |
| 354 | } | |
| 355 | for(i=0;i<w;i++) | |
| 356 | { GET(ch); | |
| 357 | *p++=VAL(ch); | |
| 358 | } | |
| 359 | for(i=0;i<len-w;i++) *p++=' '; | |
| 360 | return(0); | |
| 361 | } | |
| 362 | static int | |
| 363 | #ifdef KR_headers | |
| 364 | rd_H(n,s) char *s; | |
| 365 | #else | |
| 366 | rd_H(int n, char *s) | |
| 367 | #endif | |
| 368 | { int i,ch; | |
| 369 | for(i=0;i<n;i++) | |
| 370 | if((ch=(*f__getn)())<0) return(ch); | |
| 371 | else *s++ = ch=='\n'?' ':ch; | |
| 372 | return(1); | |
| 373 | } | |
| 374 | static int | |
| 375 | #ifdef KR_headers | |
| 376 | rd_POS(s) char *s; | |
| 377 | #else | |
| 378 | rd_POS(char *s) | |
| 379 | #endif | |
| 380 | { char quote; | |
| 381 | int ch; | |
| 382 | quote= *s++; | |
| 383 | for(;*s;s++) | |
| 384 | if(*s==quote && *(s+1)!=quote) break; | |
| 385 | else if((ch=(*f__getn)())<0) return(ch); | |
| 386 | else *s = ch=='\n'?' ':ch; | |
| 387 | return(1); | |
| 388 | } | |
| 389 | #ifdef KR_headers | |
| 390 | rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len; | |
| 391 | #else | |
| 392 | rd_ed(struct syl *p, char *ptr, ftnlen len) | |
| 393 | #endif | |
| 394 | { int ch; | |
| 395 | for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch); | |
| 396 | if(f__cursor<0) | |
| 397 | { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/ | |
| 398 | f__cursor = -f__recpos; /* is this in the standard? */ | |
| 399 | if(f__external == 0) { | |
| 400 | extern char *f__icptr; | |
| 401 | f__icptr += f__cursor; | |
| 402 | } | |
| 403 | else if(f__curunit && f__curunit->useek) | |
| 404 | (void) fseek(f__cf,(long) f__cursor,SEEK_CUR); | |
| 405 | else | |
| 406 | err(f__elist->cierr,106,"fmt"); | |
| 407 | f__recpos += f__cursor; | |
| 408 | f__cursor=0; | |
| 409 | } | |
| 410 | switch(p->op) | |
| 411 | { | |
| 412 | default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op); | |
| 413 | sig_die(f__fmtbuf, 1); | |
| 414 | case IM: | |
| 415 | case I: ch = rd_I((Uint *)ptr,p->p1,len, 10); | |
| 416 | break; | |
| 417 | ||
| 418 | /* O and OM don't work right for character, double, complex, */ | |
| 419 | /* or doublecomplex, and they differ from Fortran 90 in */ | |
| 420 | /* showing a minus sign for negative values. */ | |
| 421 | ||
| 422 | case OM: | |
| 423 | case O: ch = rd_I((Uint *)ptr, p->p1, len, 8); | |
| 424 | break; | |
| 425 | case L: ch = rd_L((ftnint *)ptr,p->p1,len); | |
| 426 | break; | |
| 427 | case A: ch = rd_A(ptr,len); | |
| 428 | break; | |
| 429 | case AW: | |
| 430 | ch = rd_AW(ptr,p->p1,len); | |
| 431 | break; | |
| 432 | case E: case EE: | |
| 433 | case D: | |
| 434 | case G: | |
| 435 | case GE: | |
| 436 | case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2,len); | |
| 437 | break; | |
| 438 | ||
| 439 | /* Z and ZM assume 8-bit bytes. */ | |
| 440 | ||
| 441 | case ZM: | |
| 442 | case Z: | |
| 443 | ch = rd_Z((Uint *)ptr, p->p1, len); | |
| 444 | break; | |
| 445 | } | |
| 446 | if(ch == 0) return(ch); | |
| 447 | else if(ch == EOF) return(EOF); | |
| 448 | if (f__cf) | |
| 449 | clearerr(f__cf); | |
| 450 | return(errno); | |
| 451 | } | |
| 452 | #ifdef KR_headers | |
| 453 | rd_ned(p) struct syl *p; | |
| 454 | #else | |
| 455 | rd_ned(struct syl *p) | |
| 456 | #endif | |
| 457 | { | |
| 458 | switch(p->op) | |
| 459 | { | |
| 460 | default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op); | |
| 461 | sig_die(f__fmtbuf, 1); | |
| 462 | case APOS: | |
| 463 | return(rd_POS(*(char **)&p->p2)); | |
| 464 | case H: return(rd_H(p->p1,*(char **)&p->p2)); | |
| 465 | case SLASH: return((*f__donewrec)()); | |
| 466 | case TR: | |
| 467 | case X: f__cursor += p->p1; | |
| 468 | return(1); | |
| 469 | case T: f__cursor=p->p1-f__recpos - 1; | |
| 470 | return(1); | |
| 471 | case TL: f__cursor -= p->p1; | |
| 472 | if(f__cursor < -f__recpos) /* TL1000, 1X */ | |
| 473 | f__cursor = -f__recpos; | |
| 474 | return(1); | |
| 475 | } | |
| 476 | } |