lread.c
Go to the documentation of this file.
00001 #include "f2c.h"
00002 #include "fio.h"
00003 
00004 /* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */
00005 /* marks in namelist input a la the Fortran 8X Draft published in  */
00006 /* the May 1989 issue of Fortran Forum. */
00007 
00008 
00009 #ifdef Allow_TYQUAD
00010 static longint f__llx;
00011 #endif
00012 
00013 #ifdef KR_headers
00014 extern double atof();
00015 extern char *malloc(), *realloc();
00016 int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
00017 #else
00018 #undef abs
00019 #undef min
00020 #undef max
00021 #include "stdlib.h"
00022 #endif
00023 
00024 #include "fmt.h"
00025 #include "lio.h"
00026 #include "ctype.h"
00027 #include "fp.h"
00028 #ifdef __cplusplus
00029 extern "C" {
00030 #endif
00031 
00032 #ifdef KR_headers
00033 extern char *f__fmtbuf;
00034 #else
00035 extern const char *f__fmtbuf;
00036 int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
00037         (*l_ungetc)(int,FILE*);
00038 #endif
00039 
00040 int l_eof;
00041 
00042 #define isblnk(x) (f__ltab[x+1]&B)
00043 #define issep(x) (f__ltab[x+1]&SX)
00044 #define isapos(x) (f__ltab[x+1]&AX)
00045 #define isexp(x) (f__ltab[x+1]&EX)
00046 #define issign(x) (f__ltab[x+1]&SG)
00047 #define iswhit(x) (f__ltab[x+1]&WH)
00048 #define SX 1
00049 #define B 2
00050 #define AX 4
00051 #define EX 8
00052 #define SG 16
00053 #define WH 32
00054 char f__ltab[128+1] = { /* offset one for EOF */
00055         0,
00056         0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
00057         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
00058         SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
00059         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
00060         0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
00061         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
00062         AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
00063         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
00064 };
00065 
00066 #ifdef ungetc
00067  static int
00068 #ifdef KR_headers
00069 un_getc(x,f__cf) int x; FILE *f__cf;
00070 #else
00071 un_getc(int x, FILE *f__cf)
00072 #endif
00073 { return ungetc(x,f__cf); }
00074 #else
00075 #define un_getc ungetc
00076 #ifdef KR_headers
00077  extern int ungetc();
00078 #else
00079 extern int ungetc(int, FILE*);  /* for systems with a buggy stdio.h */
00080 #endif
00081 #endif
00082 
00083  int
00084 t_getc(Void)
00085 {       int ch;
00086         if(f__curunit->uend) return(EOF);
00087         if((ch=getc(f__cf))!=EOF) return(ch);
00088         if(feof(f__cf))
00089                 f__curunit->uend = l_eof = 1;
00090         return(EOF);
00091 }
00092 integer e_rsle(Void)
00093 {
00094         int ch;
00095         if(f__curunit->uend) return(0);
00096         while((ch=t_getc())!='\n')
00097                 if (ch == EOF) {
00098                         if(feof(f__cf))
00099                                 f__curunit->uend = l_eof = 1;
00100                         return EOF;
00101                         }
00102         return(0);
00103 }
00104 
00105 flag f__lquit;
00106 int f__lcount,f__ltype,nml_read;
00107 char *f__lchar;
00108 double f__lx,f__ly;
00109 #define ERR(x) if(n=(x)) return(n)
00110 #define GETC(x) (x=(*l_getc)())
00111 #define Ungetc(x,y) (*l_ungetc)(x,y)
00112 
00113  static int
00114 #ifdef KR_headers
00115 l_R(poststar, reqint) int poststar, reqint;
00116 #else
00117 l_R(int poststar, int reqint)
00118 #endif
00119 {
00120         char s[FMAX+EXPMAXDIGS+4];
00121         register int ch;
00122         register char *sp, *spe, *sp1;
00123         long e, exp;
00124         int havenum, havestar, se;
00125 
00126         if (!poststar) {
00127                 if (f__lcount > 0)
00128                         return(0);
00129                 f__lcount = 1;
00130                 }
00131 #ifdef Allow_TYQUAD
00132         f__llx = 0;
00133 #endif
00134         f__ltype = 0;
00135         exp = 0;
00136         havestar = 0;
00137 retry:
00138         sp1 = sp = s;
00139         spe = sp + FMAX;
00140         havenum = 0;
00141 
00142         switch(GETC(ch)) {
00143                 case '-': *sp++ = ch; sp1++; spe++;
00144                 case '+':
00145                         GETC(ch);
00146                 }
00147         while(ch == '0') {
00148                 ++havenum;
00149                 GETC(ch);
00150                 }
00151         while(isdigit(ch)) {
00152                 if (sp < spe) *sp++ = ch;
00153                 else ++exp;
00154                 GETC(ch);
00155                 }
00156         if (ch == '*' && !poststar) {
00157                 if (sp == sp1 || exp || *s == '-') {
00158                         errfl(f__elist->cierr,112,"bad repetition count");
00159                         }
00160                 poststar = havestar = 1;
00161                 *sp = 0;
00162                 f__lcount = atoi(s);
00163                 goto retry;
00164                 }
00165         if (ch == '.') {
00166 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
00167                 if (reqint)
00168                         errfl(f__elist->cierr,115,"invalid integer");
00169 #endif
00170                 GETC(ch);
00171                 if (sp == sp1)
00172                         while(ch == '0') {
00173                                 ++havenum;
00174                                 --exp;
00175                                 GETC(ch);
00176                                 }
00177                 while(isdigit(ch)) {
00178                         if (sp < spe)
00179                                 { *sp++ = ch; --exp; }
00180                         GETC(ch);
00181                         }
00182                 }
00183         havenum += sp - sp1;
00184         se = 0;
00185         if (issign(ch))
00186                 goto signonly;
00187         if (havenum && isexp(ch)) {
00188 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
00189                 if (reqint)
00190                         errfl(f__elist->cierr,115,"invalid integer");
00191 #endif
00192                 GETC(ch);
00193                 if (issign(ch)) {
00194 signonly:
00195                         if (ch == '-') se = 1;
00196                         GETC(ch);
00197                         }
00198                 if (!isdigit(ch)) {
00199 bad:
00200                         errfl(f__elist->cierr,112,"exponent field");
00201                         }
00202 
00203                 e = ch - '0';
00204                 while(isdigit(GETC(ch))) {
00205                         e = 10*e + ch - '0';
00206                         if (e > EXPMAX)
00207                                 goto bad;
00208                         }
00209                 if (se)
00210                         exp -= e;
00211                 else
00212                         exp += e;
00213                 }
00214         (void) Ungetc(ch, f__cf);
00215         if (sp > sp1) {
00216                 ++havenum;
00217                 while(*--sp == '0')
00218                         ++exp;
00219                 if (exp)
00220                         sprintf(sp+1, "e%ld", exp);
00221                 else
00222                         sp[1] = 0;
00223                 f__lx = atof(s);
00224 #ifdef Allow_TYQUAD
00225                 if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) {
00226                         /* Assuming 64-bit longint and 32-bit long. */
00227                         if (exp < 0)
00228                                 sp += exp;
00229                         if (sp1 <= sp) {
00230                                 f__llx = *sp1 - '0';
00231                                 while(++sp1 <= sp)
00232                                         f__llx = 10*f__llx + (*sp1 - '0');
00233                                 }
00234                         while(--exp >= 0)
00235                                 f__llx *= 10;
00236                         if (*s == '-')
00237                                 f__llx = -f__llx;
00238                         }
00239 #endif
00240                 }
00241         else
00242                 f__lx = 0.;
00243         if (havenum)
00244                 f__ltype = TYLONG;
00245         else
00246                 switch(ch) {
00247                         case ',':
00248                         case '/':
00249                                 break;
00250                         default:
00251                                 if (havestar && ( ch == ' '
00252                                                 ||ch == '\t'
00253                                                 ||ch == '\n'))
00254                                         break;
00255                                 if (nml_read > 1) {
00256                                         f__lquit = 2;
00257                                         return 0;
00258                                         }
00259                                 errfl(f__elist->cierr,112,"invalid number");
00260                         }
00261         return 0;
00262         }
00263 
00264  static int
00265 #ifdef KR_headers
00266 rd_count(ch) register int ch;
00267 #else
00268 rd_count(register int ch)
00269 #endif
00270 {
00271         if (ch < '0' || ch > '9')
00272                 return 1;
00273         f__lcount = ch - '0';
00274         while(GETC(ch) >= '0' && ch <= '9')
00275                 f__lcount = 10*f__lcount + ch - '0';
00276         Ungetc(ch,f__cf);
00277         return f__lcount <= 0;
00278         }
00279 
00280  static int
00281 l_C(Void)
00282 {       int ch, nml_save;
00283         double lz;
00284         if(f__lcount>0) return(0);
00285         f__ltype=0;
00286         GETC(ch);
00287         if(ch!='(')
00288         {
00289                 if (nml_read > 1 && (ch < '0' || ch > '9')) {
00290                         Ungetc(ch,f__cf);
00291                         f__lquit = 2;
00292                         return 0;
00293                         }
00294                 if (rd_count(ch))
00295                         if(!f__cf || !feof(f__cf))
00296                                 errfl(f__elist->cierr,112,"complex format");
00297                         else
00298                                 err(f__elist->cierr,(EOF),"lread");
00299                 if(GETC(ch)!='*')
00300                 {
00301                         if(!f__cf || !feof(f__cf))
00302                                 errfl(f__elist->cierr,112,"no star");
00303                         else
00304                                 err(f__elist->cierr,(EOF),"lread");
00305                 }
00306                 if(GETC(ch)!='(')
00307                 {       Ungetc(ch,f__cf);
00308                         return(0);
00309                 }
00310         }
00311         else
00312                 f__lcount = 1;
00313         while(iswhit(GETC(ch)));
00314         Ungetc(ch,f__cf);
00315         nml_save = nml_read;
00316         nml_read = 0;
00317         if (ch = l_R(1,0))
00318                 return ch;
00319         if (!f__ltype)
00320                 errfl(f__elist->cierr,112,"no real part");
00321         lz = f__lx;
00322         while(iswhit(GETC(ch)));
00323         if(ch!=',')
00324         {       (void) Ungetc(ch,f__cf);
00325                 errfl(f__elist->cierr,112,"no comma");
00326         }
00327         while(iswhit(GETC(ch)));
00328         (void) Ungetc(ch,f__cf);
00329         if (ch = l_R(1,0))
00330                 return ch;
00331         if (!f__ltype)
00332                 errfl(f__elist->cierr,112,"no imaginary part");
00333         while(iswhit(GETC(ch)));
00334         if(ch!=')') errfl(f__elist->cierr,112,"no )");
00335         f__ly = f__lx;
00336         f__lx = lz;
00337 #ifdef Allow_TYQUAD
00338         f__llx = 0;
00339 #endif
00340         nml_read = nml_save;
00341         return(0);
00342 }
00343 
00344  static char nmLbuf[256], *nmL_next;
00345  static int (*nmL_getc_save)(Void);
00346 #ifdef KR_headers
00347  static int (*nmL_ungetc_save)(/* int, FILE* */);
00348 #else
00349  static int (*nmL_ungetc_save)(int, FILE*);
00350 #endif
00351 
00352  static int
00353 nmL_getc(Void)
00354 {
00355         int rv;
00356         if (rv = *nmL_next++)
00357                 return rv;
00358         l_getc = nmL_getc_save;
00359         l_ungetc = nmL_ungetc_save;
00360         return (*l_getc)();
00361         }
00362 
00363  static int
00364 #ifdef KR_headers
00365 nmL_ungetc(x, f) int x; FILE *f;
00366 #else
00367 nmL_ungetc(int x, FILE *f)
00368 #endif
00369 {
00370         f = f;  /* banish non-use warning */
00371         return *--nmL_next = x;
00372         }
00373 
00374  static int
00375 #ifdef KR_headers
00376 Lfinish(ch, dot, rvp) int ch, dot, *rvp;
00377 #else
00378 Lfinish(int ch, int dot, int *rvp)
00379 #endif
00380 {
00381         char *s, *se;
00382         static char what[] = "namelist input";
00383 
00384         s = nmLbuf + 2;
00385         se = nmLbuf + sizeof(nmLbuf) - 1;
00386         *s++ = ch;
00387         while(!issep(GETC(ch)) && ch!=EOF) {
00388                 if (s >= se) {
00389  nmLbuf_ovfl:
00390                         return *rvp = err__fl(f__elist->cierr,131,what);
00391                         }
00392                 *s++ = ch;
00393                 if (ch != '=')
00394                         continue;
00395                 if (dot)
00396                         return *rvp = err__fl(f__elist->cierr,112,what);
00397  got_eq:
00398                 *s = 0;
00399                 nmL_getc_save = l_getc;
00400                 l_getc = nmL_getc;
00401                 nmL_ungetc_save = l_ungetc;
00402                 l_ungetc = nmL_ungetc;
00403                 nmLbuf[1] = *(nmL_next = nmLbuf) = ',';
00404                 *rvp = f__lcount = 0;
00405                 return 1;
00406                 }
00407         if (dot)
00408                 goto done;
00409         for(;;) {
00410                 if (s >= se)
00411                         goto nmLbuf_ovfl;
00412                 *s++ = ch;
00413                 if (!isblnk(ch))
00414                         break;
00415                 if (GETC(ch) == EOF)
00416                         goto done;
00417                 }
00418         if (ch == '=')
00419                 goto got_eq;
00420  done:
00421         Ungetc(ch, f__cf);
00422         return 0;
00423         }
00424 
00425  static int
00426 l_L(Void)
00427 {
00428         int ch, rv, sawdot;
00429 
00430         if(f__lcount>0)
00431                 return(0);
00432         f__lcount = 1;
00433         f__ltype=0;
00434         GETC(ch);
00435         if(isdigit(ch))
00436         {
00437                 rd_count(ch);
00438                 if(GETC(ch)!='*')
00439                         if(!f__cf || !feof(f__cf))
00440                                 errfl(f__elist->cierr,112,"no star");
00441                         else
00442                                 err(f__elist->cierr,(EOF),"lread");
00443                 GETC(ch);
00444         }
00445         sawdot = 0;
00446         if(ch == '.') {
00447                 sawdot = 1;
00448                 GETC(ch);
00449                 }
00450         switch(ch)
00451         {
00452         case 't':
00453         case 'T':
00454                 if (nml_read && Lfinish(ch, sawdot, &rv))
00455                         return rv;
00456                 f__lx=1;
00457                 break;
00458         case 'f':
00459         case 'F':
00460                 if (nml_read && Lfinish(ch, sawdot, &rv))
00461                         return rv;
00462                 f__lx=0;
00463                 break;
00464         default:
00465                 if(isblnk(ch) || issep(ch) || ch==EOF)
00466                 {       (void) Ungetc(ch,f__cf);
00467                         return(0);
00468                 }
00469                 if (nml_read > 1) {
00470                         Ungetc(ch,f__cf);
00471                         f__lquit = 2;
00472                         return 0;
00473                         }
00474                 errfl(f__elist->cierr,112,"logical");
00475         }
00476         f__ltype=TYLONG;
00477         while(!issep(GETC(ch)) && ch!=EOF);
00478         Ungetc(ch, f__cf);
00479         return(0);
00480 }
00481 
00482 #define BUFSIZE 128
00483 
00484  static int
00485 l_CHAR(Void)
00486 {       int ch,size,i;
00487         static char rafail[] = "realloc failure";
00488         char quote,*p;
00489         if(f__lcount>0) return(0);
00490         f__ltype=0;
00491         if(f__lchar!=NULL) free(f__lchar);
00492         size=BUFSIZE;
00493         p=f__lchar = (char *)malloc((unsigned int)size);
00494         if(f__lchar == NULL)
00495                 errfl(f__elist->cierr,113,"no space");
00496 
00497         GETC(ch);
00498         if(isdigit(ch)) {
00499                 /* allow Fortran 8x-style unquoted string...    */
00500                 /* either find a repetition count or the string */
00501                 f__lcount = ch - '0';
00502                 *p++ = ch;
00503                 for(i = 1;;) {
00504                         switch(GETC(ch)) {
00505                                 case '*':
00506                                         if (f__lcount == 0) {
00507                                                 f__lcount = 1;
00508 #ifndef F8X_NML_ELIDE_QUOTES
00509                                                 if (nml_read)
00510                                                         goto no_quote;
00511 #endif
00512                                                 goto noquote;
00513                                                 }
00514                                         p = f__lchar;
00515                                         goto have_lcount;
00516                                 case ',':
00517                                 case ' ':
00518                                 case '\t':
00519                                 case '\n':
00520                                 case '/':
00521                                         Ungetc(ch,f__cf);
00522                                         /* no break */
00523                                 case EOF:
00524                                         f__lcount = 1;
00525                                         f__ltype = TYCHAR;
00526                                         return *p = 0;
00527                                 }
00528                         if (!isdigit(ch)) {
00529                                 f__lcount = 1;
00530 #ifndef F8X_NML_ELIDE_QUOTES
00531                                 if (nml_read) {
00532  no_quote:
00533                                         errfl(f__elist->cierr,112,
00534                                                 "undelimited character string");
00535                                         }
00536 #endif
00537                                 goto noquote;
00538                                 }
00539                         *p++ = ch;
00540                         f__lcount = 10*f__lcount + ch - '0';
00541                         if (++i == size) {
00542                                 f__lchar = (char *)realloc(f__lchar,
00543                                         (unsigned int)(size += BUFSIZE));
00544                                 if(f__lchar == NULL)
00545                                         errfl(f__elist->cierr,113,rafail);
00546                                 p = f__lchar + i;
00547                                 }
00548                         }
00549                 }
00550         else    (void) Ungetc(ch,f__cf);
00551  have_lcount:
00552         if(GETC(ch)=='\'' || ch=='"') quote=ch;
00553         else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
00554                 Ungetc(ch,f__cf);
00555                 return 0;
00556                 }
00557 #ifndef F8X_NML_ELIDE_QUOTES
00558         else if (nml_read > 1) {
00559                 Ungetc(ch,f__cf);
00560                 f__lquit = 2;
00561                 return 0;
00562                 }
00563 #endif
00564         else {
00565                 /* Fortran 8x-style unquoted string */
00566                 *p++ = ch;
00567                 for(i = 1;;) {
00568                         switch(GETC(ch)) {
00569                                 case ',':
00570                                 case ' ':
00571                                 case '\t':
00572                                 case '\n':
00573                                 case '/':
00574                                         Ungetc(ch,f__cf);
00575                                         /* no break */
00576                                 case EOF:
00577                                         f__ltype = TYCHAR;
00578                                         return *p = 0;
00579                                 }
00580  noquote:
00581                         *p++ = ch;
00582                         if (++i == size) {
00583                                 f__lchar = (char *)realloc(f__lchar,
00584                                         (unsigned int)(size += BUFSIZE));
00585                                 if(f__lchar == NULL)
00586                                         errfl(f__elist->cierr,113,rafail);
00587                                 p = f__lchar + i;
00588                                 }
00589                         }
00590                 }
00591         f__ltype=TYCHAR;
00592         for(i=0;;)
00593         {       while(GETC(ch)!=quote && ch!='\n'
00594                         && ch!=EOF && ++i<size) *p++ = ch;
00595                 if(i==size)
00596                 {
00597                 newone:
00598                         f__lchar= (char *)realloc(f__lchar,
00599                                         (unsigned int)(size += BUFSIZE));
00600                         if(f__lchar == NULL)
00601                                 errfl(f__elist->cierr,113,rafail);
00602                         p=f__lchar+i-1;
00603                         *p++ = ch;
00604                 }
00605                 else if(ch==EOF) return(EOF);
00606                 else if(ch=='\n')
00607                 {       if(*(p-1) != '\\') continue;
00608                         i--;
00609                         p--;
00610                         if(++i<size) *p++ = ch;
00611                         else goto newone;
00612                 }
00613                 else if(GETC(ch)==quote)
00614                 {       if(++i<size) *p++ = ch;
00615                         else goto newone;
00616                 }
00617                 else
00618                 {       (void) Ungetc(ch,f__cf);
00619                         *p = 0;
00620                         return(0);
00621                 }
00622         }
00623 }
00624 
00625  int
00626 #ifdef KR_headers
00627 c_le(a) cilist *a;
00628 #else
00629 c_le(cilist *a)
00630 #endif
00631 {
00632         if(!f__init)
00633                 f_init();
00634         f__fmtbuf="list io";
00635         f__curunit = &f__units[a->ciunit];
00636         if(a->ciunit>=MXUNIT || a->ciunit<0)
00637                 err(a->cierr,101,"stler");
00638         f__scale=f__recpos=0;
00639         f__elist=a;
00640         if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
00641                 err(a->cierr,102,"lio");
00642         f__cf=f__curunit->ufd;
00643         if(!f__curunit->ufmt) err(a->cierr,103,"lio")
00644         return(0);
00645 }
00646 
00647  int
00648 #ifdef KR_headers
00649 l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
00650 #else
00651 l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
00652 #endif
00653 {
00654 #define Ptr ((flex *)ptr)
00655         int i,n,ch;
00656         doublereal *yy;
00657         real *xx;
00658         for(i=0;i<*number;i++)
00659         {
00660                 if(f__lquit) return(0);
00661                 if(l_eof)
00662                         err(f__elist->ciend, EOF, "list in")
00663                 if(f__lcount == 0) {
00664                         f__ltype = 0;
00665                         for(;;)  {
00666                                 GETC(ch);
00667                                 switch(ch) {
00668                                 case EOF:
00669                                         err(f__elist->ciend,(EOF),"list in")
00670                                 case ' ':
00671                                 case '\t':
00672                                 case '\n':
00673                                         continue;
00674                                 case '/':
00675                                         f__lquit = 1;
00676                                         goto loopend;
00677                                 case ',':
00678                                         f__lcount = 1;
00679                                         goto loopend;
00680                                 default:
00681                                         (void) Ungetc(ch, f__cf);
00682                                         goto rddata;
00683                                 }
00684                         }
00685                 }
00686         rddata:
00687                 switch((int)type)
00688                 {
00689                 case TYINT1:
00690                 case TYSHORT:
00691                 case TYLONG:
00692 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
00693                         ERR(l_R(0,1));
00694                         break;
00695 #endif
00696                 case TYREAL:
00697                 case TYDREAL:
00698                         ERR(l_R(0,0));
00699                         break;
00700 #ifdef TYQUAD
00701                 case TYQUAD:
00702                         n = l_R(0,2);
00703                         if (n)
00704                                 return n;
00705                         break;
00706 #endif
00707                 case TYCOMPLEX:
00708                 case TYDCOMPLEX:
00709                         ERR(l_C());
00710                         break;
00711                 case TYLOGICAL1:
00712                 case TYLOGICAL2:
00713                 case TYLOGICAL:
00714                         ERR(l_L());
00715                         break;
00716                 case TYCHAR:
00717                         ERR(l_CHAR());
00718                         break;
00719                 }
00720         while (GETC(ch) == ' ' || ch == '\t');
00721         if (ch != ',' || f__lcount > 1)
00722                 Ungetc(ch,f__cf);
00723         loopend:
00724                 if(f__lquit) return(0);
00725                 if(f__cf && ferror(f__cf)) {
00726                         clearerr(f__cf);
00727                         errfl(f__elist->cierr,errno,"list in");
00728                         }
00729                 if(f__ltype==0) goto bump;
00730                 switch((int)type)
00731                 {
00732                 case TYINT1:
00733                 case TYLOGICAL1:
00734                         Ptr->flchar = (char)f__lx;
00735                         break;
00736                 case TYLOGICAL2:
00737                 case TYSHORT:
00738                         Ptr->flshort = (short)f__lx;
00739                         break;
00740                 case TYLOGICAL:
00741                 case TYLONG:
00742                         Ptr->flint = (ftnint)f__lx;
00743                         break;
00744 #ifdef Allow_TYQUAD
00745                 case TYQUAD:
00746                         if (!(Ptr->fllongint = f__llx))
00747                                 Ptr->fllongint = f__lx;
00748                         break;
00749 #endif
00750                 case TYREAL:
00751                         Ptr->flreal=f__lx;
00752                         break;
00753                 case TYDREAL:
00754                         Ptr->fldouble=f__lx;
00755                         break;
00756                 case TYCOMPLEX:
00757                         xx=(real *)ptr;
00758                         *xx++ = f__lx;
00759                         *xx = f__ly;
00760                         break;
00761                 case TYDCOMPLEX:
00762                         yy=(doublereal *)ptr;
00763                         *yy++ = f__lx;
00764                         *yy = f__ly;
00765                         break;
00766                 case TYCHAR:
00767                         b_char(f__lchar,ptr,len);
00768                         break;
00769                 }
00770         bump:
00771                 if(f__lcount>0) f__lcount--;
00772                 ptr += len;
00773                 if (nml_read)
00774                         nml_read++;
00775         }
00776         return(0);
00777 #undef Ptr
00778 }
00779 #ifdef KR_headers
00780 integer s_rsle(a) cilist *a;
00781 #else
00782 integer s_rsle(cilist *a)
00783 #endif
00784 {
00785         int n;
00786 
00787         f__reading=1;
00788         f__external=1;
00789         f__formatted=1;
00790         if(n=c_le(a)) return(n);
00791         f__lioproc = l_read;
00792         f__lquit = 0;
00793         f__lcount = 0;
00794         l_eof = 0;
00795         if(f__curunit->uwrt && f__nowreading(f__curunit))
00796                 err(a->cierr,errno,"read start");
00797         if(f__curunit->uend)
00798                 err(f__elist->ciend,(EOF),"read start");
00799         l_getc = t_getc;
00800         l_ungetc = un_getc;
00801         f__doend = xrd_SL;
00802         return(0);
00803 }
00804 #ifdef __cplusplus
00805 }
00806 #endif


swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:55:56