libf2c/libI77/lread.c

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