libf2c/libI77/rdfmt.c

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