libf2c/libI77/lread.c

   1 #include <ctype.h>
   2 #include "f2c.h"
   3 #include "fio.h"
   4
   5 /* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */
   6 /* marks in namelist input a la the Fortran 8X Draft published in  */
   7 /* the May 1989 issue of Fortran Forum. */
   8
   9
  10 extern char *f__fmtbuf;
  11 extern int f__fmtlen;
  12
  13 #ifdef Allow_TYQUAD
  14 static longint f__llx;
  15 static int quad_read;
  16 #endif
  17
  18 #ifdef KR_headers
  19 extern double atof();
  20 extern char *malloc(), *realloc();
  21 int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
  22 #else
  23 #undef abs
  24 #undef min
  25 #undef max
  26 #include <stdlib.h>
  27 #endif
  28
  29 #include "fmt.h"
  30 #include "lio.h"
  31 #include "fp.h"
  32
  33 #ifndef KR_headers
  34 int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
  35         (*l_ungetc)(int,FILE*);
  36 #endif
  37
  38 int l_eof;
  39
  40 #define isblnk(x) (f__ltab[x+1]&B)
  41 #define issep(x) (f__ltab[x+1]&SX)
  42 #define isapos(x) (f__ltab[x+1]&AX)
  43 #define isexp(x) (f__ltab[x+1]&EX)
  44 #define issign(x) (f__ltab[x+1]&SG)
  45 #define iswhit(x) (f__ltab[x+1]&WH)
  46 #define SX 1
  47 #define B 2
  48 #define AX 4
  49 #define EX 8
  50 #define SG 16
  51 #define WH 32
  52 char f__ltab[128+1] = { /* offset one for EOF */
  53         0,
  54         0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
  55         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  56         SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
  57         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  58         0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  59         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  60         AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  61         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  62 };
  63
  64 #ifdef ungetc
  65  static int
  66 #ifdef KR_headers
  67 un_getc(x,f__cf) int x; FILE *f__cf;
  68 #else
  69 un_getc(int x, FILE *f__cf)
  70 #endif
  71 { return ungetc(x,f__cf); }
  72 #else
  73 #define un_getc ungetc
  74 #ifdef KR_headers
  75  extern int ungetc();
  76 #else
  77 extern int ungetc(int, FILE*);  /* for systems with a buggy stdio.h */
  78 #endif
  79 #endif
  80
  81 t_getc(Void)
  82 {       int ch;
  83         if(f__curunit->uend) return(EOF);
  84         if((ch=getc(f__cf))!=EOF) return(ch);
  85         if(feof(f__cf))
  86                 f__curunit->uend = l_eof = 1;
  87         return(EOF);
  88 }
  89 integer e_rsle(Void)
  90 {
  91         int ch;
  92         f__init = 1;
  93         if(f__curunit->uend) return(0);
  94         while((ch=t_getc())!='\n')
  95                 if (ch == EOF) {
  96                         if(feof(f__cf))
  97                                 f__curunit->uend = l_eof = 1;
  98                         return EOF;
  99                         }
 100         return(0);
 101 }
 102
 103 flag f__lquit;
 104 int f__lcount,f__ltype,nml_read;
 105 char *f__lchar;
 106 double f__lx,f__ly;
 107 #define ERR(x) if(n=(x)) {f__init &= ~2; return(n);}
 108 #define GETC(x) (x=(*l_getc)())
 109 #define Ungetc(x,y) (*l_ungetc)(x,y)
 110
 111  static int
 112 #ifdef KR_headers
 113 l_R(poststar, reqint) int poststar, reqint;
 114 #else
 115 l_R(int poststar, int reqint)
 116 #endif
 117 {
 118         char s[FMAX+EXPMAXDIGS+4];
 119         register int ch;
 120         register char *sp, *spe, *sp1;
 121         long e, exp;
 122         int havenum, havestar, se;
 123
 124         if (!poststar) {
 125                 if (f__lcount > 0)
 126                         return(0);
 127                 f__lcount = 1;
 128                 }
 129 #ifdef Allow_TYQUAD
 130         f__llx = 0;
 131 #endif
 132         f__ltype = 0;
 133         exp = 0;
 134         havestar = 0;
 135 retry:
 136         sp1 = sp = s;
 137         spe = sp + FMAX;
 138         havenum = 0;
 139
 140         switch(GETC(ch)) {
 141                 case '-': *sp++ = ch; sp1++; spe++;
 142                 case '+':
 143                         GETC(ch);
 144                 }
 145         while(ch == '0') {
 146                 ++havenum;
 147                 GETC(ch);
 148                 }
 149         while(isdigit(ch)) {
 150                 if (sp < spe) *sp++ = ch;
 151                 else ++exp;
 152                 GETC(ch);
 153                 }
 154         if (ch == '*' && !poststar) {
 155                 if (sp == sp1 || exp || *s == '-') {
 156                         errfl(f__elist->cierr,112,"bad repetition count");
 157                         }
 158                 poststar = havestar = 1;
 159                 *sp = 0;
 160                 f__lcount = atoi(s);
 161                 goto retry;
 162                 }
 163         if (ch == '.') {
 164 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
 165                 if (reqint)
 166                         errfl(f__elist->cierr,115,"invalid integer");
 167 #endif
 168                 GETC(ch);
 169                 if (sp == sp1)
 170                         while(ch == '0') {
 171                                 ++havenum;
 172                                 --exp;
 173                                 GETC(ch);
 174                                 }
 175                 while(isdigit(ch)) {
 176                         if (sp < spe)
 177                                 { *sp++ = ch; --exp; }
 178                         GETC(ch);
 179                         }
 180                 }
 181         havenum += sp - sp1;
 182         se = 0;
 183         if (issign(ch))
 184                 goto signonly;
 185         if (havenum && isexp(ch)) {
 186 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
 187                 if (reqint)
 188                         errfl(f__elist->cierr,115,"invalid integer");
 189 #endif
 190                 GETC(ch);
 191                 if (issign(ch)) {
 192 signonly:
 193                         if (ch == '-') se = 1;
 194                         GETC(ch);
 195                         }
 196                 if (!isdigit(ch)) {
 197 bad:
 198                         errfl(f__elist->cierr,112,"exponent field");
 199                         }
 200
 201                 e = ch - '0';
 202                 while(isdigit(GETC(ch))) {
 203                         e = 10*e + ch - '0';
 204                         if (e > EXPMAX)
 205                                 goto bad;
 206                         }
 207                 if (se)
 208                         exp -= e;
 209                 else
 210                         exp += e;
 211                 }
 212         (void) Ungetc(ch, f__cf);
 213         if (sp > sp1) {
 214                 ++havenum;
 215                 while(*--sp == '0')
 216                         ++exp;
 217                 if (exp)
 218                         sprintf(sp+1, "e%ld", exp);
 219                 else
 220                         sp[1] = 0;
 221                 f__lx = atof(s);
 222 #ifdef Allow_TYQUAD
 223                 if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) {
 224                         /* Assuming 64-bit longint and 32-bit long. */
 225                         if (exp < 0)
 226                                 sp += exp;
 227                         if (sp1 <= sp) {
 228                                 f__llx = *sp1 - '0';
 229                                 while(++sp1 <= sp)
 230                                         f__llx = 10*f__llx + (*sp1 - '0');
 231                                 }
 232                         while(--exp >= 0)
 233                                 f__llx *= 10;
 234                         if (*s == '-')
 235                                 f__llx = -f__llx;
 236                         }
 237 #endif
 238                 }
 239         else
 240                 f__lx = 0.;
 241         if (havenum)
 242                 f__ltype = TYLONG;
 243         else
 244                 switch(ch) {
 245                         case ',':
 246                         case '/':
 247                                 break;
 248                         default:
 249                                 if (havestar && ( ch == ' '
 250                                                 ||ch == '\t'
 251                                                 ||ch == '\n'))
 252                                         break;
 253                                 if (nml_read > 1) {
 254                                         f__lquit = 2;
 255                                         return 0;
 256                                         }
 257                                 errfl(f__elist->cierr,112,"invalid number");
 258                         }
 259         return 0;
 260         }
 261
 262  static int
 263 #ifdef KR_headers
 264 rd_count(ch) register int ch;
 265 #else
 266 rd_count(register int ch)
 267 #endif
 268 {
 269         if (ch < '0' || ch > '9')
 270                 return 1;
 271         f__lcount = ch - '0';
 272         while(GETC(ch) >= '0' && ch <= '9')
 273                 f__lcount = 10*f__lcount + ch - '0';
 274         Ungetc(ch,f__cf);
 275         return f__lcount <= 0;
 276         }
 277
 278  static int
 279 l_C(Void)
 280 {       int ch, nml_save;
 281         double lz;
 282         if(f__lcount>0) return(0);
 283         f__ltype=0;
 284         GETC(ch);
 285         if(ch!='(')
 286         {
 287                 if (nml_read > 1 && (ch < '0' || ch > '9')) {
 288                         Ungetc(ch,f__cf);
 289                         f__lquit = 2;
 290                         return 0;
 291                         }
 292                 if (rd_count(ch))
 293                         if(!f__cf || !feof(f__cf))
 294                                 errfl(f__elist->cierr,112,"complex format");
 295                         else
 296                                 err(f__elist->cierr,(EOF),"lread");
 297                 if(GETC(ch)!='*')
 298                 {
 299                         if(!f__cf || !feof(f__cf))
 300                                 errfl(f__elist->cierr,112,"no star");
 301                         else
 302                                 err(f__elist->cierr,(EOF),"lread");
 303                 }
 304                 if(GETC(ch)!='(')
 305                 {       Ungetc(ch,f__cf);
 306                         return(0);
 307                 }
 308         }
 309         else
 310                 f__lcount = 1;
 311         while(iswhit(GETC(ch)));
 312         Ungetc(ch,f__cf);
 313         nml_save = nml_read;
 314         nml_read = 0;
 315         if (ch = l_R(1,0))
 316                 return ch;
 317         if (!f__ltype)
 318                 errfl(f__elist->cierr,112,"no real part");
 319         lz = f__lx;
 320         while(iswhit(GETC(ch)));
 321         if(ch!=',')
 322         {       (void) Ungetc(ch,f__cf);
 323                 errfl(f__elist->cierr,112,"no comma");
 324         }
 325         while(iswhit(GETC(ch)));
 326         (void) Ungetc(ch,f__cf);
 327         if (ch = l_R(1,0))
 328                 return ch;
 329         if (!f__ltype)
 330                 errfl(f__elist->cierr,112,"no imaginary part");
 331         while(iswhit(GETC(ch)));
 332         if(ch!=')') errfl(f__elist->cierr,112,"no )");
 333         f__ly = f__lx;
 334         f__lx = lz;
 335 #ifdef Allow_TYQUAD
 336         f__llx = 0;
 337 #endif
 338         nml_read = nml_save;
 339         return(0);
 340 }
 341
 342  static char nmLbuf[256], *nmL_next;
 343  static int (*nmL_getc_save)(Void);
 344 #ifdef KR_headers
 345  static int (*nmL_ungetc_save)(/* int, FILE* */);
 346 #else
 347  static int (*nmL_ungetc_save)(int, FILE*);
 348 #endif
 349
 350  static int
 351 nmL_getc(Void)
 352 {
 353         int rv;
 354         if (rv = *nmL_next++)
 355                 return rv;
 356         l_getc = nmL_getc_save;
 357         l_ungetc = nmL_ungetc_save;
 358         return (*l_getc)();
 359         }
 360
 361  static int
 362 #ifdef KR_headers
 363 nmL_ungetc(x, f) int x; FILE *f;
 364 #else
 365 nmL_ungetc(int x, FILE *f)
 366 #endif
 367 {
 368         f = f;  /* banish non-use warning */
 369         return *--nmL_next = x;
 370         }
 371
 372  static int
 373 #ifdef KR_headers
 374 Lfinish(ch, dot, rvp) int ch, dot, *rvp;
 375 #else
 376 Lfinish(int ch, int dot, int *rvp)
 377 #endif
 378 {
 379         char *s, *se;
 380         static char what[] = "namelist input";
 381
 382         s = nmLbuf + 2;
 383         se = nmLbuf + sizeof(nmLbuf) - 1;
 384         *s++ = ch;
 385         while(!issep(GETC(ch)) && ch!=EOF) {
 386                 if (s >= se) {
 387  nmLbuf_ovfl:
 388                         return *rvp = err__fl(f__elist->cierr,131,what);
 389                         }
 390                 *s++ = ch;
 391                 if (ch != '=')
 392                         continue;
 393                 if (dot)
 394                         return *rvp = err__fl(f__elist->cierr,112,what);
 395  got_eq:
 396                 *s = 0;
 397                 nmL_getc_save = l_getc;
 398                 l_getc = nmL_getc;
 399                 nmL_ungetc_save = l_ungetc;
 400                 l_ungetc = nmL_ungetc;
 401                 nmLbuf[1] = *(nmL_next = nmLbuf) = ',';
 402                 *rvp = f__lcount = 0;
 403                 return 1;
 404                 }
 405         if (dot)
 406                 goto done;
 407         for(;;) {
 408                 if (s >= se)
 409                         goto nmLbuf_ovfl;
 410                 *s++ = ch;
 411                 if (!isblnk(ch))
 412                         break;
 413                 if (GETC(ch) == EOF)
 414                         goto done;
 415                 }
 416         if (ch == '=')
 417                 goto got_eq;
 418  done:
 419         Ungetc(ch, f__cf);
 420         return 0;
 421         }
 422
 423  static int
 424 l_L(Void)
 425 {
 426         int ch, rv, sawdot;
 427         if(f__lcount>0)
 428                 return(0);
 429         f__lcount = 1;
 430         f__ltype=0;
 431         GETC(ch);
 432         if(isdigit(ch))
 433         {
 434                 rd_count(ch);
 435                 if(GETC(ch)!='*')
 436                         if(!f__cf || !feof(f__cf))
 437                                 errfl(f__elist->cierr,112,"no star");
 438                         else
 439                                 err(f__elist->cierr,(EOF),"lread");
 440                 GETC(ch);
 441         }
 442         sawdot = 0;
 443         if(ch == '.') {
 444                 sawdot = 1;
 445                 GETC(ch);
 446                 }
 447         switch(ch)
 448         {
 449         case 't':
 450         case 'T':
 451                 if (nml_read && Lfinish(ch, sawdot, &rv))
 452                         return rv;
 453                 f__lx=1;
 454                 break;
 455         case 'f':
 456         case 'F':
 457                 if (nml_read && Lfinish(ch, sawdot, &rv))
 458                         return rv;
 459                 f__lx=0;
 460                 break;
 461         default:
 462                 if(isblnk(ch) || issep(ch) || ch==EOF)
 463                 {       (void) Ungetc(ch,f__cf);
 464                         return(0);
 465                 }
 466                 if (nml_read > 1) {
 467                         Ungetc(ch,f__cf);
 468                         f__lquit = 2;
 469                         return 0;
 470                         }
 471                 errfl(f__elist->cierr,112,"logical");
 472         }
 473         f__ltype=TYLONG;
 474         while(!issep(GETC(ch)) && ch!=EOF);
 475         (void) Ungetc(ch, f__cf);
 476         return(0);
 477 }
 478
 479 #define BUFSIZE 128
 480
 481  static int
 482 l_CHAR(Void)
 483 {       int ch,size,i;
 484         static char rafail[] = "realloc failure";
 485         char quote,*p;
 486         if(f__lcount>0) return(0);
 487         f__ltype=0;
 488         if(f__lchar!=NULL) free(f__lchar);
 489         size=BUFSIZE;
 490         p=f__lchar = (char *)malloc((unsigned int)size);
 491         if(f__lchar == NULL)
 492                 errfl(f__elist->cierr,113,"no space");
 493
 494         GETC(ch);
 495         if(isdigit(ch)) {
 496                 /* allow Fortran 8x-style unquoted string...    */
 497                 /* either find a repetition count or the string */
 498                 f__lcount = ch - '0';
 499                 *p++ = ch;
 500                 for(i = 1;;) {
 501                         switch(GETC(ch)) {
 502                                 case '*':
 503                                         if (f__lcount == 0) {
 504                                                 f__lcount = 1;
 505 #ifndef F8X_NML_ELIDE_QUOTES
 506                                                 if (nml_read)
 507                                                         goto no_quote;
 508 #endif
 509                                                 goto noquote;
 510                                                 }
 511                                         p = f__lchar;
 512                                         goto have_lcount;
 513                                 case ',':
 514                                 case ' ':
 515                                 case '\t':
 516                                 case '\n':
 517                                 case '/':
 518                                         Ungetc(ch,f__cf);
 519                                         /* no break */
 520                                 case EOF:
 521                                         f__lcount = 1;
 522                                         f__ltype = TYCHAR;
 523                                         return *p = 0;
 524                                 }
 525                         if (!isdigit(ch)) {
 526                                 f__lcount = 1;
 527 #ifndef F8X_NML_ELIDE_QUOTES
 528                                 if (nml_read) {
 529  no_quote:
 530                                         errfl(f__elist->cierr,112,
 531                                                 "undelimited character string");
 532                                         }
 533 #endif
 534                                 goto noquote;
 535                                 }
 536                         *p++ = ch;
 537                         f__lcount = 10*f__lcount + ch - '0';
 538                         if (++i == size) {
 539                                 f__lchar = (char *)realloc(f__lchar,
 540                                         (unsigned int)(size += BUFSIZE));
 541                                 if(f__lchar == NULL)
 542                                         errfl(f__elist->cierr,113,rafail);
 543                                 p = f__lchar + i;
 544                                 }
 545                         }
 546                 }
 547         else    (void) Ungetc(ch,f__cf);
 548  have_lcount:
 549         if(GETC(ch)=='\'' || ch=='"') quote=ch;
 550         else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
 551                 Ungetc(ch,f__cf);
 552                 return 0;
 553                 }
 554 #ifndef F8X_NML_ELIDE_QUOTES
 555         else if (nml_read > 1) {
 556                 Ungetc(ch,f__cf);
 557                 f__lquit = 2;
 558                 return 0;
 559                 }
 560 #endif
 561         else {
 562                 /* Fortran 8x-style unquoted string */
 563                 *p++ = ch;
 564                 for(i = 1;;) {
 565                         switch(GETC(ch)) {
 566                                 case ',':
 567                                 case ' ':
 568                                 case '\t':
 569                                 case '\n':
 570                                 case '/':
 571                                         Ungetc(ch,f__cf);
 572                                         /* no break */
 573                                 case EOF:
 574                                         f__ltype = TYCHAR;
 575                                         return *p = 0;
 576                                 }
 577  noquote:
 578                         *p++ = ch;
 579                         if (++i == size) {
 580                                 f__lchar = (char *)realloc(f__lchar,
 581                                         (unsigned int)(size += BUFSIZE));
 582                                 if(f__lchar == NULL)
 583                                         errfl(f__elist->cierr,113,rafail);
 584                                 p = f__lchar + i;
 585                                 }
 586                         }
 587                 }
 588         f__ltype=TYCHAR;
 589         for(i=0;;)
 590         {       while(GETC(ch)!=quote && ch!='\n'
 591                         && ch!=EOF && ++i<size) *p++ = ch;
 592                 if(i==size)
 593                 {
 594                 newone:
 595                         f__lchar= (char *)realloc(f__lchar,
 596                                         (unsigned int)(size += BUFSIZE));
 597                         if(f__lchar == NULL)
 598                                 errfl(f__elist->cierr,113,rafail);
 599                         p=f__lchar+i-1;
 600                         *p++ = ch;
 601                 }
 602                 else if(ch==EOF) return(EOF);
 603                 else if(ch=='\n')
 604                 {       if(*(p-1) != '\\') continue;
 605                         i--;
 606                         p--;
 607                         if(++i<size) *p++ = ch;
 608                         else goto newone;
 609                 }
 610                 else if(GETC(ch)==quote)
 611                 {       if(++i<size) *p++ = ch;
 612                         else goto newone;
 613                 }
 614                 else
 615                 {       (void) Ungetc(ch,f__cf);
 616                         *p = 0;
 617                         return(0);
 618                 }
 619         }
 620 }
 621 #ifdef KR_headers
 622 c_le(a) cilist *a;
 623 #else
 624 c_le(cilist *a)
 625 #endif
 626 {
 627         if(f__init != 1) f_init();
 628         f__init = 3;
 629         f__fmtbuf="list io";
 630         f__curunit = &f__units[a->ciunit];
 631         f__fmtlen=7;
 632         if(a->ciunit>=MXUNIT || a->ciunit<0)
 633                 err(a->cierr,101,"stler");
 634         f__scale=f__recpos=0;
 635         f__elist=a;
 636         if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
 637                 err(a->cierr,102,"lio");
 638         f__cf=f__curunit->ufd;
 639         if(!f__curunit->ufmt) err(a->cierr,103,"lio");
 640         return(0);
 641 }
 642 #ifdef KR_headers
 643 l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
 644 #else
 645 l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
 646 #endif
 647 {
 648 #define Ptr ((flex *)ptr)
 649         int i,n,ch;
 650         doublereal *yy;
 651         real *xx;
 652         for(i=0;i<*number;i++)
 653         {
 654                 if(f__lquit) return(0);
 655                 if(l_eof)
 656                         err(f__elist->ciend, EOF, "list in");
 657                 if(f__lcount == 0) {
 658                         f__ltype = 0;
 659                         for(;;)  {
 660                                 GETC(ch);
 661                                 switch(ch) {
 662                                 case EOF:
 663                                         err(f__elist->ciend,(EOF),"list in");
 664                                 case ' ':
 665                                 case '\t':
 666                                 case '\n':
 667                                         continue;
 668                                 case '/':
 669                                         f__lquit = 1;
 670                                         goto loopend;
 671                                 case ',':
 672                                         f__lcount = 1;
 673                                         goto loopend;
 674                                 default:
 675                                         (void) Ungetc(ch, f__cf);
 676                                         goto rddata;
 677                                 }
 678                         }
 679                 }
 680         rddata:
 681                 switch((int)type)
 682                 {
 683                 case TYINT1:
 684                 case TYSHORT:
 685                 case TYLONG:
 686 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
 687                         ERR(l_R(0,1));
 688                         break;
 689 #endif
 690                 case TYREAL:
 691                 case TYDREAL:
 692                         ERR(l_R(0,0));
 693                         break;
 694 #ifdef TYQUAD
 695                 case TYQUAD:
 696                         n = l_R(0,2);
 697                         if (n)
 698                                 return n;
 699                         break;
 700 #endif
 701                 case TYCOMPLEX:
 702                 case TYDCOMPLEX:
 703                         ERR(l_C());
 704                         break;
 705                 case TYLOGICAL1:
 706                 case TYLOGICAL2:
 707                 case TYLOGICAL:
 708                         ERR(l_L());
 709                         break;
 710                 case TYCHAR:
 711                         ERR(l_CHAR());
 712                         break;
 713                 }
 714         while (GETC(ch) == ' ' || ch == '\t');
 715         if (ch != ',' || f__lcount > 1)
 716                 Ungetc(ch,f__cf);
 717         loopend:
 718                 if(f__lquit) return(0);
 719                 if(f__cf && ferror(f__cf)) {
 720                         clearerr(f__cf);
 721                         errfl(f__elist->cierr,errno,"list in");
 722                         }
 723                 if(f__ltype==0) goto bump;
 724                 switch((int)type)
 725                 {
 726                 case TYINT1:
 727                 case TYLOGICAL1:
 728                         Ptr->flchar = (char)f__lx;
 729                         break;
 730                 case TYLOGICAL2:
 731                 case TYSHORT:
 732                         Ptr->flshort = (short)f__lx;
 733                         break;
 734                 case TYLOGICAL:
 735                 case TYLONG:
 736                         Ptr->flint = (ftnint)f__lx;
 737                         break;
 738 #ifdef Allow_TYQUAD
 739                 case TYQUAD:
 740                         if (!(Ptr->fllongint = f__llx))
 741                                 Ptr->fllongint = f__lx;
 742                         break;
 743 #endif
 744                 case TYREAL:
 745                         Ptr->flreal=f__lx;
 746                         break;
 747                 case TYDREAL:
 748                         Ptr->fldouble=f__lx;
 749                         break;
 750                 case TYCOMPLEX:
 751                         xx=(real *)ptr;
 752                         *xx++ = f__lx;
 753                         *xx = f__ly;
 754                         break;
 755                 case TYDCOMPLEX:
 756                         yy=(doublereal *)ptr;
 757                         *yy++ = f__lx;
 758                         *yy = f__ly;
 759                         break;
 760                 case TYCHAR:
 761                         b_char(f__lchar,ptr,len);
 762                         break;
 763                 }
 764         bump:
 765                 if(f__lcount>0) f__lcount--;
 766                 ptr += len;
 767                 if (nml_read)
 768                         nml_read++;
 769         }
 770         return(0);
 771 #undef Ptr
 772 }
 773 #ifdef KR_headers
 774 integer s_rsle(a) cilist *a;
 775 #else
 776 integer s_rsle(cilist *a)
 777 #endif
 778 {
 779         int n;
 780
 781         f__reading=1;
 782         f__external=1;
 783         f__formatted=1;
 784         if(n=c_le(a)) return(n);
 785         f__lioproc = l_read;
 786         f__lquit = 0;
 787         f__lcount = 0;
 788         l_eof = 0;
 789         if(f__curunit->uwrt && f__nowreading(f__curunit))
 790                 err(a->cierr,errno,"read start");
 791         if(f__curunit->uend)
 792                 err(f__elist->ciend,(EOF),"read start");
 793         l_getc = t_getc;
 794         l_ungetc = un_getc;
 795         f__doend = xrd_SL;
 796         return(0);
 797 }