lang/fortran/lib/libI77/lread.c

   1 #include "f2c.h"
   2 #include "fio.h"
   3 #include "fmt.h"
   4 #include "lio.h"
   5 #include "ctype.h"
   6 #include "fp.h"
   7
   8 extern char *fmtbuf;
   9 extern char *malloc(), *realloc();
  10 int (*lioproc)(), (*l_getc)(), (*l_ungetc)();
  11 int l_eof;
  12
  13 #define isblnk(x) (ltab[x+1]&B)
  14 #define issep(x) (ltab[x+1]&SX)
  15 #define isapos(x) (ltab[x+1]&AX)
  16 #define isexp(x) (ltab[x+1]&EX)
  17 #define issign(x) (ltab[x+1]&SG)
  18 #define iswhit(x) (ltab[x+1]&WH)
  19 #define SX 1
  20 #define B 2
  21 #define AX 4
  22 #define EX 8
  23 #define SG 16
  24 #define WH 32
  25 char ltab[128+1] = {    /* offset one for EOF */
  26         0,
  27         0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
  28         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  29         SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
  30         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  31         0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  32         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  33         AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  34         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  35 };
  36
  37 t_getc()
  38 {       int ch;
  39         if(curunit->uend) return(EOF);
  40         if((ch=getc(cf))!=EOF) return(ch);
  41         if(feof(cf))
  42                 l_eof = curunit->uend = 1;
  43         return(EOF);
  44 }
  45 integer e_rsle()
  46 {
  47         int ch;
  48         if(curunit->uend) return(0);
  49         while((ch=t_getc())!='\n' && ch!=EOF);
  50         return(0);
  51 }
  52
  53 flag lquit;
  54 int lcount,ltype;
  55 char *lchar;
  56 double lx,ly;
  57 #define ERR(x) if(n=(x)) return(n)
  58 #define GETC(x) (x=(*l_getc)())
  59 #define Ungetc(x,y) (*l_ungetc)(x,y)
  60
  61 l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
  62 {
  63 #define Ptr ((flex *)ptr)
  64         int i,n,ch;
  65         doublereal *yy;
  66         real *xx;
  67         for(i=0;i<*number;i++)
  68         {
  69                 if(lquit) return(0);
  70                 if(l_eof)
  71                         err(elist->ciend, EOF, "list in")
  72                 if(lcount == 0) {
  73                         ltype = 0;
  74                         for(;;)  {
  75                                 GETC(ch);
  76                                 switch(ch) {
  77                                 case EOF:
  78                                         goto loopend;
  79                                 case ' ':
  80                                 case '\t':
  81                                 case '\n':
  82                                         continue;
  83                                 case '/':
  84                                         lquit = 1;
  85                                         goto loopend;
  86                                 case ',':
  87                                         lcount = 1;
  88                                         goto loopend;
  89                                 default:
  90                                         (void) Ungetc(ch, cf);
  91                                         goto rddata;
  92                                 }
  93                         }
  94                 }
  95         rddata:
  96                 switch((int)type)
  97                 {
  98                 case TYSHORT:
  99                 case TYLONG:
 100                 case TYREAL:
 101                 case TYDREAL:
 102                         ERR(l_R(0));
 103                         break;
 104                 case TYCOMPLEX:
 105                 case TYDCOMPLEX:
 106                         ERR(l_C());
 107                         break;
 108                 case TYLOGICAL:
 109                         ERR(l_L());
 110                         break;
 111                 case TYCHAR:
 112                         ERR(l_CHAR());
 113                         break;
 114                 }
 115         while (GETC(ch) == ' ' || ch == '\t');
 116         if (ch != ',')
 117                 Ungetc(ch,cf);
 118         loopend:
 119                 if(lquit) return(0);
 120                 if(cf) {
 121                         if (feof(cf))
 122                                 err(elist->ciend,(EOF),"list in")
 123                         else if(ferror(cf)) {
 124                                 clearerr(cf);
 125                                 err(elist->cierr,errno,"list in")
 126                                 }
 127                         }
 128                 if(ltype==0) goto bump;
 129                 switch((int)type)
 130                 {
 131                 case TYSHORT:
 132                         Ptr->flshort=lx;
 133                         break;
 134                 case TYLOGICAL:
 135                 case TYLONG:
 136                         Ptr->flint=lx;
 137                         break;
 138                 case TYREAL:
 139                         Ptr->flreal=lx;
 140                         break;
 141                 case TYDREAL:
 142                         Ptr->fldouble=lx;
 143                         break;
 144                 case TYCOMPLEX:
 145                         xx=(real *)ptr;
 146                         *xx++ = lx;
 147                         *xx = ly;
 148                         break;
 149                 case TYDCOMPLEX:
 150                         yy=(doublereal *)ptr;
 151                         *yy++ = lx;
 152                         *yy = ly;
 153                         break;
 154                 case TYCHAR:
 155                         b_char(lchar,ptr,len);
 156                         break;
 157                 }
 158         bump:
 159                 if(lcount>0) lcount--;
 160                 ptr += len;
 161         }
 162         return(0);
 163 #undef Ptr
 164 }
 165 l_R(poststar)
 166  int poststar;
 167 {
 168         char s[FMAX+EXPMAXDIGS+4];
 169         register int ch;
 170         register char *sp, *spe, *sp1;
 171         long e, exp;
 172         double atof();
 173         int havenum, se;
 174
 175         if (!poststar) {
 176                 if (lcount > 0)
 177                         return(0);
 178                 lcount = 1;
 179                 }
 180         ltype = 0;
 181         exp = 0;
 182 retry:
 183         sp1 = sp = s;
 184         spe = sp + FMAX;
 185         havenum = 0;
 186
 187         switch(GETC(ch)) {
 188                 case '-': *sp++ = ch; sp1++; spe++;
 189                 case '+':
 190                         GETC(ch);
 191                 }
 192         while(ch == '0') {
 193                 ++havenum;
 194                 GETC(ch);
 195                 }
 196         while(isdigit(ch)) {
 197                 if (sp < spe) *sp++ = ch;
 198                 else ++exp;
 199                 GETC(ch);
 200                 }
 201         if (ch == '*' && !poststar) {
 202                 if (sp == sp1 || exp || *s == '-') {
 203                         err(elist->cierr,112,"bad repetition count")
 204                         }
 205                 poststar = 1;
 206                 *sp = 0;
 207                 lcount = atoi(s);
 208                 goto retry;
 209                 }
 210         if (ch == '.') {
 211                 GETC(ch);
 212                 if (sp == sp1)
 213                         while(ch == '0') {
 214                                 ++havenum;
 215                                 --exp;
 216                                 GETC(ch);
 217                                 }
 218                 while(isdigit(ch)) {
 219                         if (sp < spe)
 220                                 { *sp++ = ch; --exp; }
 221                         GETC(ch);
 222                         }
 223                 }
 224         se = 0;
 225         if (issign(ch))
 226                 goto signonly;
 227         if (isexp(ch)) {
 228                 GETC(ch);
 229                 if (issign(ch)) {
 230 signonly:
 231                         if (ch == '-') se = 1;
 232                         GETC(ch);
 233                         }
 234                 if (!isdigit(ch)) {
 235 bad:
 236                         err(elist->cierr,112,"exponent field")
 237                         }
 238
 239                 e = ch - '0';
 240                 while(isdigit(GETC(ch))) {
 241                         e = 10*e + ch - '0';
 242                         if (e > EXPMAX)
 243                                 goto bad;
 244                         }
 245                 if (se)
 246                         exp -= e;
 247                 else
 248                         exp += e;
 249                 }
 250         (void) Ungetc(ch, cf);
 251         if (sp > sp1) {
 252                 ++havenum;
 253                 while(*--sp == '0')
 254                         ++exp;
 255                 if (exp)
 256                         sprintf(sp+1, "e%ld", exp);
 257                 else
 258                         sp[1] = 0;
 259                 lx = atof(s);
 260                 }
 261         else
 262                 lx = 0.;
 263         if (havenum)
 264                 ltype = TYLONG;
 265         else
 266                 switch(ch) {
 267                         case ',':
 268                         case '/':
 269                                 break;
 270                         default:
 271                                 err(elist->cierr,112,"invalid number")
 272                         }
 273         return 0;
 274         }
 275
 276  static int
 277 rd_count(ch)
 278  register int ch;
 279 {
 280         if (ch < '0' || ch > '9')
 281                 return 1;
 282         lcount = ch - '0';
 283         while(GETC(ch) >= '0' && ch <= '9')
 284                 lcount = 10*lcount + ch - '0';
 285         Ungetc(ch,cf);
 286         return 0;
 287         }
 288
 289 l_C()
 290 {       int ch;
 291         double lz;
 292         if(lcount>0) return(0);
 293         ltype=0;
 294         GETC(ch);
 295         if(ch!='(')
 296         {
 297                 if (rd_count(ch))
 298                         if(!cf || !feof(cf))
 299                                 err(elist->cierr,112,"complex format")
 300                         else
 301                                 err(elist->cierr,(EOF),"lread");
 302                 if(GETC(ch)!='*')
 303                 {
 304                         if(!cf || !feof(cf))
 305                                 err(elist->cierr,112,"no star")
 306                         else
 307                                 err(elist->cierr,(EOF),"lread");
 308                 }
 309                 if(GETC(ch)!='(')
 310                 {       (void) Ungetc(ch,cf);
 311                         return(0);
 312                 }
 313         }
 314         else
 315                 lcount = 1;
 316         while(iswhit(GETC(ch)));
 317         (void) Ungetc(ch,cf);
 318         if (ch = l_R(1))
 319                 return ch;
 320         if (!ltype)
 321                 err(elist->cierr,112,"no real part");
 322         lz = lx;
 323         while(iswhit(GETC(ch)));
 324         if(ch!=',')
 325         {       (void) Ungetc(ch,cf);
 326                 err(elist->cierr,112,"no comma");
 327         }
 328         while(iswhit(GETC(ch)));
 329         (void) Ungetc(ch,cf);
 330         if (ch = l_R(1))
 331                 return ch;
 332         if (!ltype)
 333                 err(elist->cierr,112,"no imaginary part");
 334         while(iswhit(GETC(ch)));
 335         if(ch!=')') err(elist->cierr,112,"no )");
 336         ly = lx;
 337         lx = lz;
 338         return(0);
 339 }
 340 l_L()
 341 {
 342         int ch;
 343         if(lcount>0) return(0);
 344         ltype=0;
 345         GETC(ch);
 346         if(isdigit(ch))
 347         {
 348                 rd_count(ch);
 349                 if(GETC(ch)!='*')
 350                         if(!cf || !feof(cf))
 351                                 err(elist->cierr,112,"no star")
 352                         else
 353                                 err(elist->cierr,(EOF),"lread");
 354                 GETC(ch);
 355         }
 356         if(ch == '.') GETC(ch);
 357         switch(ch)
 358         {
 359         case 't':
 360         case 'T':
 361                 lx=1;
 362                 break;
 363         case 'f':
 364         case 'F':
 365                 lx=0;
 366                 break;
 367         default:
 368                 if(isblnk(ch) || issep(ch) || ch==EOF)
 369                 {       (void) Ungetc(ch,cf);
 370                         return(0);
 371                 }
 372                 else    err(elist->cierr,112,"logical");
 373         }
 374         ltype=TYLONG;
 375         lcount = 1;
 376         while(!issep(GETC(ch)) && ch!=EOF);
 377         (void) Ungetc(ch, cf);
 378         return(0);
 379 }
 380 #define BUFSIZE 128
 381 l_CHAR()
 382 {       int ch,size,i;
 383         char quote,*p;
 384         if(lcount>0) return(0);
 385         ltype=0;
 386         if(lchar!=NULL) free(lchar);
 387         size=BUFSIZE;
 388         p=lchar=malloc((unsigned int)size);
 389         if(lchar==NULL) err(elist->cierr,113,"no space");
 390
 391         GETC(ch);
 392         if(isdigit(ch)) {
 393                 /* allow Fortran 8x-style unquoted string...    */
 394                 /* either find a repetition count or the string */
 395                 lcount = ch - '0';
 396                 *p++ = ch;
 397                 for(i = 1;;) {
 398                         switch(GETC(ch)) {
 399                                 case '*':
 400                                         if (lcount == 0) {
 401                                                 lcount = 1;
 402                                                 goto noquote;
 403                                                 }
 404                                         p = lchar;
 405                                         goto have_lcount;
 406                                 case ',':
 407                                 case ' ':
 408                                 case '\t':
 409                                 case '\n':
 410                                 case '/':
 411                                         Ungetc(ch,cf);
 412                                         /* no break */
 413                                 case EOF:
 414                                         lcount = 1;
 415                                         ltype = TYCHAR;
 416                                         return *p = 0;
 417                                 }
 418                         if (!isdigit(ch)) {
 419                                 lcount = 1;
 420                                 goto noquote;
 421                                 }
 422                         *p++ = ch;
 423                         lcount = 10*lcount + ch - '0';
 424                         if (++i == size) {
 425                                 lchar = realloc(lchar,
 426                                         (unsigned int)(size += BUFSIZE));
 427                                 p = lchar + i;
 428                                 }
 429                         }
 430                 }
 431         else    (void) Ungetc(ch,cf);
 432  have_lcount:
 433         if(GETC(ch)=='\'' || ch=='"') quote=ch;
 434         else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
 435         {       (void) Ungetc(ch,cf);
 436                 return(0);
 437         }
 438         else {
 439                 /* Fortran 8x-style unquoted string */
 440                 *p++ = ch;
 441                 for(i = 1;;) {
 442                         switch(GETC(ch)) {
 443                                 case ',':
 444                                 case ' ':
 445                                 case '\t':
 446                                 case '\n':
 447                                 case '/':
 448                                         Ungetc(ch,cf);
 449                                         /* no break */
 450                                 case EOF:
 451                                         ltype = TYCHAR;
 452                                         return *p = 0;
 453                                 }
 454  noquote:
 455                         *p++ = ch;
 456                         if (++i == size) {
 457                                 lchar = realloc(lchar,
 458                                         (unsigned int)(size += BUFSIZE));
 459                                 p = lchar + i;
 460                                 }
 461                         }
 462                 }
 463         ltype=TYCHAR;
 464         for(i=0;;)
 465         {       while(GETC(ch)!=quote && ch!='\n'
 466                         && ch!=EOF && ++i<size) *p++ = ch;
 467                 if(i==size)
 468                 {
 469                 newone:
 470                         lchar= realloc(lchar, (unsigned int)(size += BUFSIZE));
 471                         p=lchar+i-1;
 472                         *p++ = ch;
 473                 }
 474                 else if(ch==EOF) return(EOF);
 475                 else if(ch=='\n')
 476                 {       if(*(p-1) != '\\') continue;
 477                         i--;
 478                         p--;
 479                         if(++i<size) *p++ = ch;
 480                         else goto newone;
 481                 }
 482                 else if(GETC(ch)==quote)
 483                 {       if(++i<size) *p++ = ch;
 484                         else goto newone;
 485                 }
 486                 else
 487                 {       (void) Ungetc(ch,cf);
 488                         *p = 0;
 489                         return(0);
 490                 }
 491         }
 492 }
 493 integer s_rsle(a) cilist *a;
 494 {
 495         int n;
 496         extern int ungetc();
 497
 498         if(!init) f_init();
 499         if(n=c_le(a)) return(n);
 500         reading=1;
 501         external=1;
 502         formatted=1;
 503         lioproc = l_read;
 504         lquit = 0;
 505         lcount = 0;
 506         l_eof = 0;
 507         if(curunit->uwrt && nowreading(curunit))
 508                 err(a->cierr,errno,"read start");
 509         l_getc = t_getc;
 510         l_ungetc = ungetc;
 511         return(0);
 512 }
 513 c_le(a) cilist *a;
 514 {
 515         fmtbuf="list io";
 516         if(a->ciunit>=MXUNIT || a->ciunit<0)
 517                 err(a->cierr,101,"stler");
 518         scale=recpos=0;
 519         elist=a;
 520         curunit = &units[a->ciunit];
 521         if(curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
 522                 err(a->cierr,102,"lio");
 523         cf=curunit->ufd;
 524         if(!curunit->ufmt) err(a->cierr,103,"lio")
 525         return(0);
 526 }