libf2c/libI77/rdfmt.c

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