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