sources/f2c/lex.c

   1 /****************************************************************
   2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
   3
   4 Permission to use, copy, modify, and distribute this software
   5 and its documentation for any purpose and without fee is hereby
   6 granted, provided that the above copyright notice appear in all
   7 copies and that both that the copyright notice and this
   8 permission notice and warranty disclaimer appear in supporting
   9 documentation, and that the names of AT&T Bell Laboratories or
  10 Bellcore or any of their entities not be used in advertising or
  11 publicity pertaining to distribution of the software without
  12 specific, written prior permission.
  13
  14 AT&T and Bellcore disclaim all warranties with regard to this
  15 software, including all implied warranties of merchantability
  16 and fitness.  In no event shall AT&T or Bellcore be liable for
  17 any special, indirect or consequential damages or any damages
  18 whatsoever resulting from loss of use, data or profits, whether
  19 in an action of contract, negligence or other tortious action,
  20 arising out of or in connection with the use or performance of
  21 this software.
  22 ****************************************************************/
  23
  24 #include "defs.h"
  25 #include "tokdefs.h"
  26 #include "p1defs.h"
  27
  28 # define BLANK  ' '
  29 # define MYQUOTE (2)
  30 # define SEOF 0
  31
  32 /* card types */
  33
  34 # define STEOF 1
  35 # define STINITIAL 2
  36 # define STCONTINUE 3
  37
  38 /* lex states */
  39
  40 #define NEWSTMT 1
  41 #define FIRSTTOKEN      2
  42 #define OTHERTOKEN      3
  43 #define RETEOS  4
  44
  45
  46 LOCAL int stkey;        /* Type of the current statement (DO, END, IF, etc) */
  47 extern char token[];    /* holds the actual token text */
  48 static int needwkey;
  49 ftnint yystno;
  50 flag intonly;
  51 extern int new_dcl;
  52 LOCAL long int stno;
  53 LOCAL long int nxtstno; /* Statement label */
  54 LOCAL int parlev;       /* Parentheses level */
  55 LOCAL int parseen;
  56 LOCAL int expcom;
  57 LOCAL int expeql;
  58 LOCAL char *nextch;
  59 LOCAL char *lastch;
  60 LOCAL char *nextcd      = NULL;
  61 LOCAL char *endcd;
  62 LOCAL long prevlin;
  63 LOCAL long thislin;
  64 LOCAL int code;         /* Card type; INITIAL, CONTINUE or EOF */
  65 LOCAL int lexstate      = NEWSTMT;
  66 LOCAL char sbuf[1390];  /* Main buffer for Fortran source input.  The number
  67                            comes from lines of at most 66 characters, with at
  68                            most 20 continuation cards (or something); this is
  69                            part of the defn of the standard */
  70 LOCAL char *send        = sbuf+20*66;
  71 LOCAL int nincl = 0;    /* Current number of include files */
  72 LOCAL long firstline;
  73 LOCAL char *laststb, *stb0;
  74 extern int addftnsrc;
  75 #define CONTMAX 100     /* max continuation lines for ! processing */
  76 char *linestart[CONTMAX];
  77 LOCAL int ncont;
  78 LOCAL char comstart[256];
  79 #define USC (unsigned char *)
  80
  81 static char anum_buf[256];
  82 #define isalnum_(x) anum_buf[x]
  83 #define isalpha_(x) (anum_buf[x] == 1)
  84
  85 #define COMMENT_BUF_STORE 4088
  86
  87 typedef struct comment_buf {
  88         struct comment_buf *next;
  89         char *last;
  90         char buf[COMMENT_BUF_STORE];
  91         } comment_buf;
  92 static comment_buf *cbfirst, *cbcur;
  93 static char *cbinit, *cbnext, *cblast;
  94 static void flush_comments();
  95
  96
  97 /* Comment buffering data
  98
  99         Comments are kept in a list until the statement before them has
 100    been parsed.  This list is implemented with the above comment_buf
 101    structure and the pointers cbnext and cblast.
 102
 103         The comments are stored with terminating NULL, and no other
 104    intervening space.  The last few bytes of each block are likely to
 105    remain unused.
 106 */
 107
 108 /* struct Inclfile   holds the state information for each include file */
 109 struct Inclfile
 110 {
 111         struct Inclfile *inclnext;
 112         FILEP inclfp;
 113         char *inclname;
 114         int incllno;
 115         char *incllinp;
 116         int incllen;
 117         int inclcode;
 118         ftnint inclstno;
 119 };
 120
 121 LOCAL struct Inclfile *inclp    =  NULL;
 122 LOCAL struct Keylist {
 123         char *keyname;
 124         int keyval;
 125         char notinf66;
 126 };
 127 LOCAL struct Punctlist {
 128         char punchar;
 129         int punval;
 130 };
 131 LOCAL struct Fmtlist {
 132         char fmtchar;
 133         int fmtval;
 134 };
 135 struct Dotlist {
 136         char *dotname;
 137         int dotval;
 138         };
 139 LOCAL struct Keylist *keystart[26], *keyend[26];
 140
 141 /* KEYWORD AND SPECIAL CHARACTER TABLES
 142 */
 143
 144 static struct Punctlist puncts[ ] =
 145 {
 146         '(', SLPAR,
 147         ')', SRPAR,
 148         '=', SEQUALS,
 149         ',', SCOMMA,
 150         '+', SPLUS,
 151         '-', SMINUS,
 152         '*', SSTAR,
 153         '/', SSLASH,
 154         '$', SCURRENCY,
 155         ':', SCOLON,
 156         '<', SLT,
 157         '>', SGT,
 158         0, 0 };
 159
 160 LOCAL struct Dotlist  dots[ ] =
 161 {
 162         "and.", SAND,
 163             "or.", SOR,
 164             "not.", SNOT,
 165             "true.", STRUE,
 166             "false.", SFALSE,
 167             "eq.", SEQ,
 168             "ne.", SNE,
 169             "lt.", SLT,
 170             "le.", SLE,
 171             "gt.", SGT,
 172             "ge.", SGE,
 173             "neqv.", SNEQV,
 174             "eqv.", SEQV,
 175             0, 0 };
 176
 177 LOCAL struct Keylist  keys[ ] =
 178 {
 179         { "assign",  SASSIGN  },
 180         { "automatic",  SAUTOMATIC, YES  },
 181         { "backspace",  SBACKSPACE  },
 182         { "blockdata",  SBLOCK  },
 183         { "call",  SCALL  },
 184         { "character",  SCHARACTER, YES  },
 185         { "close",  SCLOSE, YES  },
 186         { "common",  SCOMMON  },
 187         { "complex",  SCOMPLEX  },
 188         { "continue",  SCONTINUE  },
 189         { "data",  SDATA  },
 190         { "dimension",  SDIMENSION  },
 191         { "doubleprecision",  SDOUBLE  },
 192         { "doublecomplex", SDCOMPLEX, YES  },
 193         { "elseif",  SELSEIF, YES  },
 194         { "else",  SELSE, YES  },
 195         { "endfile",  SENDFILE  },
 196         { "endif",  SENDIF, YES  },
 197         { "enddo", SENDDO, YES },
 198         { "end",  SEND  },
 199         { "entry",  SENTRY, YES  },
 200         { "equivalence",  SEQUIV  },
 201         { "external",  SEXTERNAL  },
 202         { "format",  SFORMAT  },
 203         { "function",  SFUNCTION  },
 204         { "goto",  SGOTO  },
 205         { "implicit",  SIMPLICIT, YES  },
 206         { "include",  SINCLUDE, YES  },
 207         { "inquire",  SINQUIRE, YES  },
 208         { "intrinsic",  SINTRINSIC, YES  },
 209         { "integer",  SINTEGER  },
 210         { "logical",  SLOGICAL  },
 211         { "namelist", SNAMELIST, YES },
 212         { "none", SUNDEFINED, YES },
 213         { "open",  SOPEN, YES  },
 214         { "parameter",  SPARAM, YES  },
 215         { "pause",  SPAUSE  },
 216         { "print",  SPRINT  },
 217         { "program",  SPROGRAM, YES  },
 218         { "punch",  SPUNCH, YES  },
 219         { "read",  SREAD  },
 220         { "real",  SREAL  },
 221         { "return",  SRETURN  },
 222         { "rewind",  SREWIND  },
 223         { "save",  SSAVE, YES  },
 224         { "static",  SSTATIC, YES  },
 225         { "stop",  SSTOP  },
 226         { "subroutine",  SSUBROUTINE  },
 227         { "then",  STHEN, YES  },
 228         { "undefined", SUNDEFINED, YES  },
 229         { "while", SWHILE, YES  },
 230         { "write",  SWRITE  },
 231         { 0, 0 }
 232 };
 233
 234 LOCAL void analyz(), crunch(), store_comment();
 235 LOCAL int getcd(), getcds(), getkwd(), gettok();
 236
 237 inilex(name)
 238 char *name;
 239 {
 240         nincl = 0;
 241         inclp = NULL;
 242         doinclude(name);
 243         lexstate = NEWSTMT;
 244         return(NO);
 245 }
 246
 247
 248
 249 /* throw away the rest of the current line */
 250 flline()
 251 {
 252         lexstate = RETEOS;
 253 }
 254
 255
 256
 257 char *lexline(n)
 258 int *n;
 259 {
 260         *n = (lastch - nextch) + 1;
 261         return(nextch);
 262 }
 263
 264
 265
 266
 267
 268 doinclude(name)
 269 char *name;
 270 {
 271         FILEP fp;
 272         struct Inclfile *t;
 273
 274         if(inclp)
 275         {
 276                 inclp->incllno = thislin;
 277                 inclp->inclcode = code;
 278                 inclp->inclstno = nxtstno;
 279                 if(nextcd)
 280                         inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd);
 281                 else
 282                         inclp->incllinp = 0;
 283         }
 284         nextcd = NULL;
 285
 286         if(++nincl >= MAXINCLUDES)
 287                 Fatal("includes nested too deep");
 288         if(name[0] == '\0')
 289                 fp = stdin;
 290         else
 291                 fp = fopen(name, textread);
 292         if (fp)
 293         {
 294                 t = inclp;
 295                 inclp = ALLOC(Inclfile);
 296                 inclp->inclnext = t;
 297                 prevlin = thislin = 0;
 298                 infname = inclp->inclname = name;
 299                 infile = inclp->inclfp = fp;
 300         }
 301         else
 302         {
 303                 fprintf(diagfile, "Cannot open file %s\n", name);
 304                 done(1);
 305         }
 306 }
 307
 308
 309
 310
 311 LOCAL popinclude()
 312 {
 313         struct Inclfile *t;
 314         register char *p;
 315         register int k;
 316
 317         if(infile != stdin)
 318                 clf(&infile, infname, 1);       /* Close the input file */
 319         free(infname);
 320
 321         --nincl;
 322         t = inclp->inclnext;
 323         free( (charptr) inclp);
 324         inclp = t;
 325         if(inclp == NULL) {
 326                 infname = 0;
 327                 return(NO);
 328                 }
 329
 330         infile = inclp->inclfp;
 331         infname = inclp->inclname;
 332         prevlin = thislin = inclp->incllno;
 333         code = inclp->inclcode;
 334         stno = nxtstno = inclp->inclstno;
 335         if(inclp->incllinp)
 336         {
 337                 endcd = nextcd = sbuf;
 338                 k = inclp->incllen;
 339                 p = inclp->incllinp;
 340                 while(--k >= 0)
 341                         *endcd++ = *p++;
 342                 free( (charptr) (inclp->incllinp) );
 343         }
 344         else
 345                 nextcd = NULL;
 346         return(YES);
 347 }
 348
 349  static void
 350 putlineno()
 351 {
 352         static long lastline;
 353         static char *lastfile = "??", *lastfile0 = "?";
 354         static char fbuf[P1_FILENAME_MAX];
 355         extern int gflag;
 356         register char *s0, *s1;
 357
 358         if (gflag) {
 359                 if (lastline) {
 360                         if (lastfile != lastfile0) {
 361                                 p1puts(P1_FILENAME, fbuf);
 362                                 lastfile0 = lastfile;
 363                                 }
 364                         p1_line_number(lastline);
 365                         }
 366                 lastline = firstline;
 367                 if (lastfile != infname)
 368                         if (lastfile = infname) {
 369                                 strncpy(fbuf, lastfile, sizeof(fbuf));
 370                                 fbuf[sizeof(fbuf)-1] = 0;
 371                                 }
 372                         else
 373                                 fbuf[0] = 0;
 374                 }
 375         if (addftnsrc) {
 376                 if (laststb && *laststb) {
 377                         for(s1 = laststb; *s1; s1++) {
 378                                 for(s0 = s1; *s1 != '\n'; s1++)
 379                                         if (*s1 == '*' && s1[1] == '/')
 380                                                 *s1 = '+';
 381                                 *s1 = 0;
 382                                 p1puts(P1_FORTRAN, s0);
 383                                 }
 384                         *laststb = 0;   /* prevent trouble after EOF */
 385                         }
 386                 laststb = stb0;
 387                 }
 388         }
 389
 390
 391 yylex()
 392 {
 393         static int  tokno;
 394         int retval;
 395
 396         switch(lexstate)
 397         {
 398         case NEWSTMT :  /* need a new statement */
 399                 retval = getcds();
 400                 putlineno();
 401                 if(retval == STEOF) {
 402                         retval = SEOF;
 403                         break;
 404                 } /* if getcds() == STEOF */
 405                 crunch();
 406                 tokno = 0;
 407                 lexstate = FIRSTTOKEN;
 408                 yystno = stno;
 409                 stno = nxtstno;
 410                 toklen = 0;
 411                 retval = SLABEL;
 412                 break;
 413
 414 first:
 415         case FIRSTTOKEN :       /* first step on a statement */
 416                 analyz();
 417                 lexstate = OTHERTOKEN;
 418                 tokno = 1;
 419                 retval = stkey;
 420                 break;
 421
 422         case OTHERTOKEN :       /* return next token */
 423                 if(nextch > lastch)
 424                         goto reteos;
 425                 ++tokno;
 426                 if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3)
 427                         goto first;
 428
 429                 if(stkey==SASSIGN && tokno==3 && nextch<lastch &&
 430                     nextch[0]=='t' && nextch[1]=='o')
 431                 {
 432                         nextch+=2;
 433                         retval = STO;
 434                         break;
 435                 }
 436                 retval = gettok();
 437                 break;
 438
 439 reteos:
 440         case RETEOS:
 441                 lexstate = NEWSTMT;
 442                 retval = SEOS;
 443                 break;
 444         default:
 445                 fatali("impossible lexstate %d", lexstate);
 446                 break;
 447         }
 448
 449         if (retval == SEOF)
 450             flush_comments ();
 451
 452         return retval;
 453 }
 454
 455 /* Get Cards.
 456
 457    Returns STEOF or STINITIAL, never STCONTINUE.  Any continuation cards get
 458 merged into one long card (hence the size of the buffer named   sbuf)   */
 459
 460  LOCAL int
 461 getcds()
 462 {
 463         register char *p, *q;
 464
 465         flush_comments ();
 466 top:
 467         if(nextcd == NULL)
 468         {
 469                 code = getcd( nextcd = sbuf, 1 );
 470                 stno = nxtstno;
 471                 prevlin = thislin;
 472         }
 473         if(code == STEOF)
 474                 if( popinclude() )
 475                         goto top;
 476                 else
 477                         return(STEOF);
 478
 479         if(code == STCONTINUE)
 480         {
 481                 lineno = thislin;
 482                 nextcd = NULL;
 483                 goto top;
 484         }
 485
 486 /* Get rid of unused space at the head of the buffer */
 487
 488         if(nextcd > sbuf)
 489         {
 490                 q = nextcd;
 491                 p = sbuf;
 492                 while(q < endcd)
 493                         *p++ = *q++;
 494                 endcd = p;
 495         }
 496
 497 /* Be aware that the input (i.e. the string at the address   nextcd)   is NOT
 498    NULL-terminated */
 499
 500 /* This loop merges all continuations into one long statement, AND puts the next
 501    card to be read at the end of the buffer (i.e. it stores the look-ahead card
 502    when there's room) */
 503
 504         ncont = 0;
 505         do {
 506                 nextcd = endcd;
 507                 if (ncont < CONTMAX)
 508                         linestart[ncont++] = nextcd;
 509                 }
 510                 while(nextcd+66<=send && (code = getcd(nextcd,0))==STCONTINUE);
 511         nextch = sbuf;
 512         lastch = nextcd - 1;
 513
 514 /* Handle buffer overflow by zeroing the 'next' pointer   (nextcd)   so that
 515    the top of this function will initialize it next time it is called */
 516
 517         if(nextcd >= send)
 518                 nextcd = NULL;
 519         lineno = prevlin;
 520         prevlin = thislin;
 521         return(STINITIAL);
 522 }
 523
 524  static void
 525 bang(a,b,c,d,e)         /* save ! comments */
 526  char *a, *b, *c;
 527  register char *d, *e;
 528 {
 529         char buf[COMMENT_BUFFER_SIZE + 1];
 530         register char *p, *pe;
 531
 532         p = buf;
 533         pe = buf + COMMENT_BUFFER_SIZE;
 534         *pe = 0;
 535         while(a < b)
 536                 if (!(*p++ = *a++))
 537                         p[-1] = 0;
 538         if (b < c)
 539                 *p++ = '\t';
 540         while(d < e) {
 541                 if (!(*p++ = *d++))
 542                         p[-1] = ' ';
 543                 if (p == pe) {
 544                         store_comment(buf);
 545                         p = buf;
 546                         }
 547                 }
 548         if (p > buf) {
 549                 while(--p >= buf && *p == ' ');
 550                 p[1] = 0;
 551                 store_comment(buf);
 552                 }
 553         }
 554
 555 /* getcd - Get next input card
 556
 557         This function reads the next input card from global file pointer   infile.
 558 It assumes that   b   points to currently empty storage somewhere in  sbuf  */
 559
 560  LOCAL int
 561 getcd(b, nocont)
 562  register char *b;
 563 {
 564         register int c;
 565         register char *p, *bend;
 566         int speclin;            /* Special line - true when the line is allowed
 567                                    to have more than 66 characters (e.g. the
 568                                    "&" shorthand for continuation, use of a "\t"
 569                                    to skip part of the label columns) */
 570         static char a[6];       /* Statement label buffer */
 571         static char *aend       = a+6;
 572         static char stbuf[3][P1_STMTBUFSIZE], *stb, *stbend;
 573         static int nst;
 574         char *atend, *endcd0;
 575         int amp;
 576         char storage[COMMENT_BUFFER_SIZE + 1];
 577         char *pointer;
 578
 579 top:
 580         endcd = b;
 581         bend = b+66;
 582         amp = speclin = NO;
 583         atend = aend;
 584
 585 /* Handle the continuation shorthand of "&" in the first column, which stands
 586    for "     x" */
 587
 588         if( (c = getc(infile)) == '&')
 589         {
 590                 a[0] = c;
 591                 a[1] = 0;
 592                 a[5] = 'x';
 593                 amp = speclin = YES;
 594                 bend = send;
 595                 p = aend;
 596         }
 597
 598 /* Handle the Comment cards (a 'C', 'c', '*', or '!' in the first column). */
 599
 600         else if(comstart[c & 0xff])
 601         {
 602                 if (feof (infile))
 603                     return STEOF;
 604
 605                 storage[COMMENT_BUFFER_SIZE] = c = '\0';
 606                 pointer = storage;
 607                 while( !feof (infile) && (*pointer++ = c = getc(infile)) != '\n') {
 608
 609 /* Handle obscure end of file conditions on many machines */
 610
 611                         if (feof (infile) && (c == '\377' || c == EOF)) {
 612                             pointer--;
 613                             break;
 614                         } /* if (feof (infile)) */
 615
 616                         if (c == '\0')
 617                                 *(pointer - 1) = ' ';
 618
 619                         if (pointer == &storage[COMMENT_BUFFER_SIZE]) {
 620                                 store_comment (storage);
 621                                 pointer = storage;
 622                         } /* if (pointer == BUFFER_SIZE) */
 623                 } /* while */
 624
 625                 if (pointer > storage) {
 626                     if (c == '\n')
 627
 628 /* Get rid of the newline */
 629
 630                         pointer[-1] = 0;
 631                     else
 632                         *pointer = 0;
 633
 634                     store_comment (storage);
 635                 } /* if */
 636
 637                 if (feof (infile))
 638                     if (c != '\n')      /* To allow the line index to
 639                                            increment correctly */
 640                         return STEOF;
 641
 642                 ++thislin;
 643                 goto top;
 644         }
 645
 646         else if(c != EOF)
 647         {
 648
 649 /* Load buffer   a   with the statement label */
 650
 651                 /* a tab in columns 1-6 skips to column 7 */
 652                 ungetc(c, infile);
 653                 for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; )
 654                         if(c == '\t')
 655
 656 /* The tab character translates into blank characters in the statement label */
 657
 658                         {
 659                                 atend = p;
 660                                 while(p < aend)
 661                                         *p++ = BLANK;
 662                                 speclin = YES;
 663                                 bend = send;
 664                         }
 665                         else
 666                                 *p++ = c;
 667         }
 668
 669 /* By now we've read either a continuation character or the statement label
 670    field */
 671
 672         if(c == EOF)
 673                 return(STEOF);
 674
 675 /* The next 'if' block handles lines that have fewer than 7 characters */
 676
 677         if(c == '\n')
 678         {
 679                 while(p < aend)
 680                         *p++ = BLANK;
 681
 682 /* Blank out the buffer on lines which are not longer than 66 characters */
 683
 684                 endcd0 = endcd;
 685                 if( ! speclin )
 686                         while(endcd < bend)
 687                                 *endcd++ = BLANK;
 688         }
 689         else    {       /* read body of line */
 690                 while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF )
 691                         *endcd++ = c;
 692                 if(c == EOF)
 693                         return(STEOF);
 694
 695 /* Drop any extra characters on the input card; this usually means those after
 696    column 72 */
 697
 698                 if(c != '\n')
 699                 {
 700                         while( (c=getc(infile)) != '\n')
 701                                 if(c == EOF)
 702                                         return(STEOF);
 703                 }
 704
 705                 endcd0 = endcd;
 706                 if( ! speclin )
 707                         while(endcd < bend)
 708                                 *endcd++ = BLANK;
 709         }
 710
 711 /* The flow of control usually gets to this line (unless an earlier RETURN has
 712    been taken) */
 713
 714         ++thislin;
 715
 716         /* Fortran 77 specifies that a 0 in column 6 */
 717         /* does not signify continuation */
 718
 719         if( !isspace(a[5]) && a[5]!='0') {
 720                 if (!amp)
 721                         for(p = a; p < aend;)
 722                                 if (*p++ == '!' && p != aend)
 723                                         goto initcheck;
 724                 if (addftnsrc && stb) {
 725                         if (stbend > stb + 7) { /* otherwise forget col 1-6 */
 726                                 /* kludge around funny p1gets behavior */
 727                                 *stb++ = '$';
 728                                 if (amp)
 729                                         *stb++ = '&';
 730                                 else
 731                                         for(p = a; p < atend;)
 732                                                 *stb++ = *p++;
 733                                 }
 734                         if (endcd0 - b > stbend - stb) {
 735                                 if (stb > stbend)
 736                                         stb = stbend;
 737                                 endcd0 = b + (stbend - stb);
 738                                 }
 739                         for(p = b; p < endcd0;)
 740                                 *stb++ = *p++;
 741                         *stb++ = '\n';
 742                         *stb = 0;
 743                         }
 744                 if (nocont) {
 745                         lineno = thislin;
 746                         errstr("illegal continuation card (starts \"%.6s\")",a);
 747                         }
 748                 else if (!amp && strncmp(a,"     ",5)) {
 749                         lineno = thislin;
 750                         errstr("labeled continuation line (starts \"%.6s\")",a);
 751                         }
 752                 return(STCONTINUE);
 753                 }
 754 initcheck:
 755         for(p=a; p<atend; ++p)
 756                 if( !isspace(*p) ) {
 757                         if (*p++ != '!')
 758                                 goto initline;
 759                         bang(p, atend, aend, b, endcd);
 760                         goto top;
 761                         }
 762         for(p = b ; p<endcd ; ++p)
 763                 if( !isspace(*p) ) {
 764                         if (*p++ != '!')
 765                                 goto initline;
 766                         bang(a, a, a, p, endcd);
 767                         goto top;
 768                         }
 769
 770 /* Skip over blank cards by reading the next one right away */
 771
 772         goto top;
 773
 774 initline:
 775         if (addftnsrc) {
 776                 nst = (nst+1)%3;
 777                 if (!laststb && stb0)
 778                         laststb = stb0;
 779                 stb0 = stb = stbuf[nst];
 780                 *stb++ = '$';   /* kludge around funny p1gets behavior */
 781                 stbend = stb + sizeof(stbuf[0])-2;
 782                 for(p = a; p < atend;)
 783                         *stb++ = *p++;
 784                 if (atend < aend)
 785                         *stb++ = '\t';
 786                 for(p = b; p < endcd0;)
 787                         *stb++ = *p++;
 788                 *stb++ = '\n';
 789                 *stb = 0;
 790                 }
 791
 792 /* Set   nxtstno   equal to the integer value of the statement label */
 793
 794         nxtstno = 0;
 795         bend = a + 5;
 796         for(p = a ; p < bend ; ++p)
 797                 if( !isspace(*p) )
 798                         if(isdigit(*p))
 799                                 nxtstno = 10*nxtstno + (*p - '0');
 800                         else if (*p == '!') {
 801                                 if (!addftnsrc)
 802                                         bang(p+1,atend,aend,b,endcd);
 803                                 endcd = b;
 804                                 break;
 805                                 }
 806                         else    {
 807                                 lineno = thislin;
 808                                 errstr(
 809                                 "nondigit in statement label field \"%.5s\"", a);
 810                                 nxtstno = 0;
 811                                 break;
 812                         }
 813         firstline = thislin;
 814         return(STINITIAL);
 815 }
 816
 817
 818 /* crunch -- deletes all space characters, folds the backslash chars and
 819    Hollerith strings, quotes the Fortran strings */
 820
 821  LOCAL void
 822 crunch()
 823 {
 824         register char *i, *j, *j0, *j1, *prvstr;
 825         int k, ten, nh, quote;
 826
 827         /* i is the next input character to be looked at
 828            j is the next output character */
 829
 830         new_dcl = needwkey = parlev = parseen = 0;
 831         expcom = 0;     /* exposed ','s */
 832         expeql = 0;     /* exposed equal signs */
 833         j = sbuf;
 834         prvstr = sbuf;
 835         k = 0;
 836         for(i=sbuf ; i<=lastch ; ++i)
 837         {
 838                 if(isspace(*i) )
 839                         continue;
 840                 if (*i == '!') {
 841                         while(i >= linestart[k])
 842                                 if (++k >= CONTMAX)
 843                                         Fatal("too many continuations\n");
 844                         j0 = linestart[k];
 845                         if (!addftnsrc)
 846                                 bang(sbuf,sbuf,sbuf,i+1,j0);
 847                         i = j0-1;
 848                         continue;
 849                         }
 850
 851 /* Keep everything in a quoted string */
 852
 853                 if(*i=='\'' ||  *i=='"')
 854                 {
 855                         int len = 0;
 856
 857                         quote = *i;
 858                         *j = MYQUOTE; /* special marker */
 859                         for(;;)
 860                         {
 861                                 if(++i > lastch)
 862                                 {
 863                                         err("unbalanced quotes; closing quote supplied");
 864                                         if (j >= lastch)
 865                                                 j = lastch - 1;
 866                                         break;
 867                                 }
 868                                 if(*i == quote)
 869                                         if(i<lastch && i[1]==quote) ++i;
 870                                         else break;
 871                                 else if(*i=='\\' && i<lastch)
 872                                         switch(*++i)
 873                                         {
 874                                         case 't':
 875                                                 *i = '\t';
 876                                                 break;
 877                                         case 'b':
 878                                                 *i = '\b';
 879                                                 break;
 880                                         case 'n':
 881                                                 *i = '\n';
 882                                                 break;
 883                                         case 'f':
 884                                                 *i = '\f';
 885                                                 break;
 886                                         case 'v':
 887                                                 *i = '\v';
 888                                                 break;
 889                                         case '0':
 890                                                 *i = '\0';
 891                                                 break;
 892                                         default:
 893                                                 break;
 894                                         }
 895                                 if (len + 2 < MAXTOKENLEN)
 896                                     *++j = *i;
 897                                 else if (len + 2 == MAXTOKENLEN)
 898                                     erri
 899             ("String too long, truncating to %d chars", MAXTOKENLEN - 2);
 900                                 len++;
 901                         } /* for (;;) */
 902
 903                         j[1] = MYQUOTE;
 904                         j += 2;
 905                         prvstr = j;
 906                 }
 907                 else if( (*i=='h' || *i=='H')  && j>prvstr)     /* test for Hollerith strings */
 908                 {
 909                         j0 = j - 1;
 910                         if( ! isdigit(*j0)) goto copychar;
 911                         nh = *j0 - '0';
 912                         ten = 10;
 913                         j1 = prvstr;
 914                         if (j1+4 < j)
 915                                 j1 = j-4;
 916                         for(;;) {
 917                                 if (j0-- <= j1)
 918                                         goto copychar;
 919                                 if( ! isdigit(*j0 ) ) break;
 920                                 nh += ten * (*j0-'0');
 921                                 ten*=10;
 922                                 }
 923                         /* a hollerith must be preceded by a punctuation mark.
 924    '*' is possible only as repetition factor in a data statement
 925    not, in particular, in character*2h
 926 */
 927
 928                         if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/'
 929                         && *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.')
 930                                 goto copychar;
 931                         if(i+nh > lastch || nh + 2 > MAXTOKENLEN)
 932                         {
 933                                 erri("%dH too big", nh);
 934                                 nh = lastch - i;
 935                         }
 936                         j0[1] = MYQUOTE; /* special marker */
 937                         j = j0 + 1;
 938                         while(nh-- > 0)
 939                         {
 940                                 if(*++i == '\\')
 941                                         switch(*++i)
 942                                         {
 943                                         case 't':
 944                                                 *i = '\t';
 945                                                 break;
 946                                         case 'b':
 947                                                 *i = '\b';
 948                                                 break;
 949                                         case 'n':
 950                                                 *i = '\n';
 951                                                 break;
 952                                         case 'f':
 953                                                 *i = '\f';
 954                                                 break;
 955                                         case '0':
 956                                                 *i = '\0';
 957                                                 break;
 958                                         default:
 959                                                 break;
 960                                         }
 961                                 *++j = *i;
 962                         }
 963                         j[1] = MYQUOTE;
 964                         j+=2;
 965                         prvstr = j;
 966                 }
 967                 else    {
 968                         if(*i == '(') parseen = ++parlev;
 969                         else if(*i == ')') --parlev;
 970                         else if(parlev == 0)
 971                                 if(*i == '=') expeql = 1;
 972                                 else if(*i == ',') expcom = 1;
 973 copychar:               /*not a string or space -- copy, shifting case if necessary */
 974                         if(shiftcase && isupper(*i))
 975                                 *j++ = tolower(*i);
 976                         else    *j++ = *i;
 977                 }
 978         }
 979         lastch = j - 1;
 980         nextch = sbuf;
 981 }
 982
 983  LOCAL void
 984 analyz()
 985 {
 986         register char *i;
 987
 988         if(parlev != 0)
 989         {
 990                 err("unbalanced parentheses, statement skipped");
 991                 stkey = SUNKNOWN;
 992                 lastch = sbuf - 1; /* prevent double error msg */
 993                 return;
 994         }
 995         if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(')
 996         {
 997                 /* assignment or if statement -- look at character after balancing paren */
 998                 parlev = 1;
 999                 for(i=nextch+3 ; i<=lastch; ++i)
1000                         if(*i == (MYQUOTE))
1001                         {
1002                                 while(*++i != MYQUOTE)
1003                                         ;
1004                         }
1005                         else if(*i == '(')
1006                                 ++parlev;
1007                         else if(*i == ')')
1008                         {
1009                                 if(--parlev == 0)
1010                                         break;
1011                         }
1012                 if(i >= lastch)
1013                         stkey = SLOGIF;
1014                 else if(i[1] == '=')
1015                         stkey = SLET;
1016                 else if( isdigit(i[1]) )
1017                         stkey = SARITHIF;
1018                 else    stkey = SLOGIF;
1019                 if(stkey != SLET)
1020                         nextch += 2;
1021         }
1022         else if(expeql) /* may be an assignment */
1023         {
1024                 if(expcom && nextch<lastch &&
1025                     nextch[0]=='d' && nextch[1]=='o')
1026                 {
1027                         stkey = SDO;
1028                         nextch += 2;
1029                 }
1030                 else    stkey = SLET;
1031         }
1032         else if (parseen && nextch + 7 < lastch
1033                         && nextch[2] != 'u' /* screen out "double..." early */
1034                         && nextch[0] == 'd' && nextch[1] == 'o'
1035                         && ((nextch[2] >= '0' && nextch[2] <= '9')
1036                                 || nextch[2] == ','
1037                                 || nextch[2] == 'w'))
1038                 {
1039                 stkey = SDO;
1040                 nextch += 2;
1041                 needwkey = 1;
1042                 }
1043         /* otherwise search for keyword */
1044         else    {
1045                 stkey = getkwd();
1046                 if(stkey==SGOTO && lastch>=nextch)
1047                         if(nextch[0]=='(')
1048                                 stkey = SCOMPGOTO;
1049                         else if(isalpha(nextch[0]))
1050                                 stkey = SASGOTO;
1051         }
1052         parlev = 0;
1053 }
1054
1055
1056
1057  LOCAL int
1058 getkwd()
1059 {
1060         register char *i, *j;
1061         register struct Keylist *pk, *pend;
1062         int k;
1063
1064         if(! isalpha(nextch[0]) )
1065                 return(SUNKNOWN);
1066         k = letter(nextch[0]);
1067         if(pk = keystart[k])
1068                 for(pend = keyend[k] ; pk<=pend ; ++pk )
1069                 {
1070                         i = pk->keyname;
1071                         j = nextch;
1072                         while(*++i==*++j && *i!='\0')
1073                                 ;
1074                         if(*i=='\0' && j<=lastch+1)
1075                         {
1076                                 nextch = j;
1077                                 if(no66flag && pk->notinf66)
1078                                         errstr("Not a Fortran 66 keyword: %s",
1079                                             pk->keyname);
1080                                 return(pk->keyval);
1081                         }
1082                 }
1083         return(SUNKNOWN);
1084 }
1085
1086 initkey()
1087 {
1088         register struct Keylist *p;
1089         register int i,j;
1090         register char *s;
1091
1092         for(i = 0 ; i<26 ; ++i)
1093                 keystart[i] = NULL;
1094
1095         for(p = keys ; p->keyname ; ++p) {
1096                 j = letter(p->keyname[0]);
1097                 if(keystart[j] == NULL)
1098                         keystart[j] = p;
1099                 keyend[j] = p;
1100                 }
1101         comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] = 1;
1102         s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_";
1103         while(i = *s++)
1104                 anum_buf[i] = 1;
1105         s = "0123456789";
1106         while(i = *s++)
1107                 anum_buf[i] = 2;
1108         }
1109
1110 /* gettok -- moves the right amount of text from   nextch   into the   token
1111    buffer.   token   initially contains garbage (leftovers from the prev token) */
1112
1113  LOCAL int
1114 gettok()
1115 {
1116         int havdot, havexp, havdbl;
1117         int radix, val;
1118         struct Punctlist *pp;
1119         struct Dotlist *pd;
1120         register int ch;
1121
1122         char *i, *j, *n1, *p;
1123
1124         ch = * USC nextch;
1125         if(ch == (MYQUOTE))
1126         {
1127                 ++nextch;
1128                 p = token;
1129                 while(*nextch != MYQUOTE)
1130                         *p++ = *nextch++;
1131                 ++nextch;
1132                 toklen = p - token;
1133                 *p = 0;
1134                 return (SHOLLERITH);
1135         }
1136         /*   The next 40 lines or so were an early attempt to parse FORMAT
1137              statements.  They have been deleted */
1138
1139 /* Not a format statement */
1140
1141         if(needkwd)
1142         {
1143                 needkwd = 0;
1144                 return( getkwd() );
1145         }
1146
1147         for(pp=puncts; pp->punchar; ++pp)
1148                 if(ch == pp->punchar) {
1149                         val = pp->punval;
1150                         if (++nextch <= lastch)
1151                             switch(ch) {
1152                                 case '/':
1153                                         if (*nextch == '/') {
1154                                                 nextch++;
1155                                                 val = SCONCAT;
1156                                                 }
1157                                         else if (new_dcl && parlev == 0)
1158                                                 val = SSLASHD;
1159                                         return val;
1160                                 case '*':
1161                                         if (*nextch == '*') {
1162                                                 nextch++;
1163                                                 return SPOWER;
1164                                                 }
1165                                         break;
1166                                 case '<':
1167                                         if (*nextch == '=') {
1168                                                 nextch++;
1169                                                 val = SLE;
1170                                                 }
1171                                         if (*nextch == '>') {
1172                                                 nextch++;
1173                                                 val = SNE;
1174                                                 }
1175                                         goto extchk;
1176                                 case '=':
1177                                         if (*nextch == '=') {
1178                                                 nextch++;
1179                                                 val = SEQ;
1180                                                 goto extchk;
1181                                                 }
1182                                         break;
1183                                 case '>':
1184                                         if (*nextch == '=') {
1185                                                 nextch++;
1186                                                 val = SGE;
1187                                                 }
1188  extchk:
1189                                         NOEXT("Fortran 8x comparison operator");
1190                                         return val;
1191                                 }
1192                         else if (ch == '/' && new_dcl && parlev == 0)
1193                                 return SSLASHD;
1194                         switch(val) {
1195                                 case SLPAR:
1196                                         ++parlev;
1197                                         break;
1198                                 case SRPAR:
1199                                         --parlev;
1200                                 }
1201                         return(val);
1202                         }
1203         if(ch == '.')
1204                 if(nextch >= lastch) goto badchar;
1205                 else if(isdigit(nextch[1])) goto numconst;
1206                 else    {
1207                         for(pd=dots ; (j=pd->dotname) ; ++pd)
1208                         {
1209                                 for(i=nextch+1 ; i<=lastch ; ++i)
1210                                         if(*i != *j) break;
1211                                         else if(*i != '.') ++j;
1212                                         else    {
1213                                                 nextch = i+1;
1214                                                 return(pd->dotval);
1215                                         }
1216                         }
1217                         goto badchar;
1218                 }
1219         if( isalpha(ch) )
1220         {
1221                 p = token;
1222                 *p++ = *nextch++;
1223                 while(nextch<=lastch)
1224                         if( isalnum_(* USC nextch) )
1225                                 *p++ = *nextch++;
1226                         else break;
1227                 toklen = p - token;
1228                 *p = 0;
1229                 if (needwkey) {
1230                         needwkey = 0;
1231                         if (toklen == 5
1232                                 && nextch <= lastch && *nextch == '(' /*)*/
1233                                 && !strcmp(token,"while"))
1234                         return(SWHILE);
1235                         }
1236                 if(inioctl && nextch<=lastch && *nextch=='=')
1237                 {
1238                         ++nextch;
1239                         return(SNAMEEQ);
1240                 }
1241                 if(toklen>8 && eqn(8,token,"function") && isalpha(token[8]) &&
1242                     nextch<lastch && nextch[0]=='(' &&
1243                     (nextch[1]==')' || isalpha(nextch[1])) )
1244                 {
1245                         nextch -= (toklen - 8);
1246                         return(SFUNCTION);
1247                 }
1248
1249                 if(toklen > 50)
1250                 {
1251                         char buff[100];
1252                         sprintf(buff, toklen >= 60
1253                                 ? "name %.56s... too long, truncated to %.*s"
1254                                 : "name %s too long, truncated to %.*s",
1255                             token, 50, token);
1256                         err(buff);
1257                         toklen = 50;
1258                         token[50] = '\0';
1259                 }
1260                 if(toklen==1 && *nextch==MYQUOTE)
1261                 {
1262                         switch(token[0])
1263                         {
1264                         case 'z':
1265                         case 'Z':
1266                         case 'x':
1267                         case 'X':
1268                                 radix = 16;
1269                                 break;
1270                         case 'o':
1271                         case 'O':
1272                                 radix = 8;
1273                                 break;
1274                         case 'b':
1275                         case 'B':
1276                                 radix = 2;
1277                                 break;
1278                         default:
1279                                 err("bad bit identifier");
1280                                 return(SNAME);
1281                         }
1282                         ++nextch;
1283                         for(p = token ; *nextch!=MYQUOTE ; )
1284                                 if( hextoi(*p++ = *nextch++) >= radix)
1285                                 {
1286                                         err("invalid binary character");
1287                                         break;
1288                                 }
1289                         ++nextch;
1290                         toklen = p - token;
1291                         *p = 0;
1292                         return( radix==16 ? SHEXCON :
1293                             (radix==8 ? SOCTCON : SBITCON) );
1294                 }
1295                 return(SNAME);
1296         }
1297
1298         if (isdigit(ch)) {
1299
1300                 /* Check for NAG's special hex constant */
1301
1302                 if (nextch[1] == '#'
1303                 ||  nextch[2] == '#' && isdigit(nextch[1])) {
1304
1305                     radix = atoi (nextch);
1306                     if (*++nextch != '#')
1307                         nextch++;
1308                     if (radix != 2 && radix != 8 && radix != 16) {
1309                         erri("invalid base %d for constant, defaulting to hex",
1310                                 radix);
1311                         radix = 16;
1312                     } /* if */
1313                     if (++nextch > lastch)
1314                         goto badchar;
1315                     for (p = token; hextoi(*nextch) < radix;) {
1316                         *p++ = *nextch++;
1317                         if (nextch > lastch)
1318                                 break;
1319                         }
1320                     toklen = p - token;
1321                     *p = 0;
1322                     return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON :
1323                             SBITCON);
1324                     }
1325                 }
1326         else
1327                 goto badchar;
1328 numconst:
1329         havdot = NO;
1330         havexp = NO;
1331         havdbl = NO;
1332         for(n1 = nextch ; nextch<=lastch ; ++nextch)
1333         {
1334                 if(*nextch == '.')
1335                         if(havdot) break;
1336                         else if(nextch+2<=lastch && isalpha(nextch[1])
1337                             && isalpha(nextch[2]))
1338                                 break;
1339                         else    havdot = YES;
1340                 else if( !intonly && (*nextch=='d' || *nextch=='e') )
1341                 {
1342                         p = nextch;
1343                         havexp = YES;
1344                         if(*nextch == 'd')
1345                                 havdbl = YES;
1346                         if(nextch<lastch)
1347                                 if(nextch[1]=='+' || nextch[1]=='-')
1348                                         ++nextch;
1349                         if( ! isdigit(*++nextch) )
1350                         {
1351                                 nextch = p;
1352                                 havdbl = havexp = NO;
1353                                 break;
1354                         }
1355                         for(++nextch ;
1356                             nextch<=lastch && isdigit(* USC nextch);
1357                             ++nextch);
1358                         break;
1359                 }
1360                 else if( ! isdigit(* USC nextch) )
1361                         break;
1362         }
1363         p = token;
1364         i = n1;
1365         while(i < nextch)
1366                 *p++ = *i++;
1367         toklen = p - token;
1368         *p = 0;
1369         if(havdbl) return(SDCON);
1370         if(havdot || havexp) return(SRCON);
1371         return(SICON);
1372 badchar:
1373         sbuf[0] = *nextch++;
1374         return(SUNKNOWN);
1375 }
1376
1377 /* Comment buffering code */
1378
1379  static void
1380 store_comment(str)
1381  char *str;
1382 {
1383         int len;
1384         char *Alloc();
1385         comment_buf *ncb;
1386
1387         if (nextcd == sbuf) {
1388                 flush_comments();
1389                 p1_comment(str);
1390                 return;
1391                 }
1392         len = strlen(str) + 1;
1393         if (cbnext + len > cblast) {
1394                 if (!cbcur || !(ncb = cbcur->next)) {
1395                         ncb = (comment_buf *) Alloc(sizeof(comment_buf));
1396                         if (cbcur) {
1397                                 cbcur->last = cbnext;
1398                                 cbcur->next = ncb;
1399                                 }
1400                         else {
1401                                 cbfirst = ncb;
1402                                 cbinit = ncb->buf;
1403                                 }
1404                         ncb->next = 0;
1405                         }
1406                 cbcur = ncb;
1407                 cbnext = ncb->buf;
1408                 cblast = cbnext + COMMENT_BUF_STORE;
1409                 }
1410         strcpy(cbnext, str);
1411         cbnext += len;
1412         }
1413
1414  static void
1415 flush_comments()
1416 {
1417         register char *s, *s1;
1418         register comment_buf *cb;
1419         if (cbnext == cbinit)
1420                 return;
1421         cbcur->last = cbnext;
1422         for(cb = cbfirst;; cb = cb->next) {
1423                 for(s = cb->buf; s < cb->last; s = s1) {
1424                         /* compute s1 = new s value first, since */
1425                         /* p1_comment may insert nulls into s */
1426                         s1 = s + strlen(s) + 1;
1427                         p1_comment(s);
1428                         }
1429                 if (cb == cbcur)
1430                         break;
1431                 }
1432         cbcur = cbfirst;
1433         cbnext = cbinit;
1434         cblast = cbnext + COMMENT_BUF_STORE;
1435         }
1436
1437  void
1438 unclassifiable()
1439 {
1440         register char *s, *se;
1441
1442         s = sbuf;
1443         se = lastch;
1444         if (se < sbuf)
1445                 return;
1446         lastch = s - 1;
1447         if (se - s > 10)
1448                 se = s + 10;
1449         for(; s < se; s++)
1450                 if (*s == MYQUOTE) {
1451                         se = s;
1452                         break;
1453                         }
1454         *se = 0;
1455         errstr("unclassifiable statment (starts \"%s\")", sbuf);
1456         }