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