home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / FTNCHK32.ZIP / forlex.c < prev    next >
C/C++ Source or Header  |  1993-02-16  |  49KB  |  1,928 lines
  1. /* forlex.c:
  2.  
  3.     Tokenizing routines for Fortran program checker.
  4.  
  5.     Copyright (C) 1992 by Robert K. Moniot.
  6.     This program is free software.  Permission is granted to
  7.     modify it and/or redistribute it, retaining this notice.
  8.     No guarantees accompany this software.
  9.  
  10.  
  11. Contains three previously independent modules:
  12.    I. Forlex  -- yylex function which gives tokens to the parser, and
  13.             related functions.
  14.   II. Advance -- bottom-level scanning of input stream.
  15.  III. Keywords -- disambiguates keywords from identifiers.
  16.  
  17.     Scan ahead for the label I. II. or III. to find desired module.
  18. */
  19.  
  20.  
  21.  
  22.     /* Declarations shared by all modules */
  23.  
  24. #include <stdio.h>
  25. #include <ctype.h>
  26. #include <string.h>
  27. #ifdef __STDC__
  28. #include <stdlib.h>
  29. #else
  30. char *calloc(), *getenv();
  31. #endif
  32.  
  33. #include "ftnchek.h"
  34. #include "tokdefs.h"
  35. #include "symtab.h"
  36.  
  37. /* lexdefs.h:
  38.         Macros and shared info for lexical analysis routines
  39. */
  40.  
  41.  
  42. #define EOL     '\n'    /* Character for end of line, not of statement */
  43.  
  44. extern YYSTYPE yylval;      /* Lexical value for Yacc */
  45.  
  46.  
  47.     /* Since EOS is special, need special macros for it */
  48. #define makeupper(C) (((C) != EOS && islower((int)(C)))? toupper((int)(C)):(C))
  49. #define iswhitespace(C) ( (C) != EOS && isspace((int)(C)) )
  50. #define isadigit(C)     ( (C) != EOS && isdigit((int)(C)) )
  51. #define isaletter(C)    ( (C) != EOS && isalpha((int)(C)) )
  52.  
  53.     /* define isidletter to allow underscore and/or dollar sign or not */
  54. #if ALLOW_UNDERSCORES && ALLOW_DOLLARSIGNS
  55.                 /* both underscore and dollar sign */
  56. #define isidletter(C)    ( (C) != EOS && (isalpha((int)(C)) || \
  57.                       (C) == '_' || (C) == '$') )
  58. #else
  59. #if ALLOW_UNDERSCORES        /* underscore and not dollar sign */
  60. #define isidletter(C)    ( (C) != EOS && (isalpha((int)(C))||(C) == '_') )
  61. #else
  62. #if ALLOW_DOLLARSIGNS        /* dollar sign and not underscore */
  63. #define isidletter(C)    ( (C) != EOS && (isalpha((int)(C))||(C) == '$') )
  64. #else                /* neither dollar sign nor underscore */
  65. #define isidletter(C)    isaletter(C)
  66. #endif
  67. #endif
  68. #endif
  69.  
  70.  
  71. PRIVATE int
  72.     inside_string,        /* TRUE when reading a string or hollerith */
  73.     inside_hollerith,    /* TRUE when reading a hollerith */
  74.     contin_count,        /* Number of continuation lines of stmt */
  75.     curr_char,        /* Current input character */
  76.     next_char;        /* Lookahead character */
  77.  
  78. extern int complex_const_allowed,    /* shared flags operated by fortran.y */
  79.        inside_format,
  80.        integer_context;
  81. extern int stmt_sequence_no;    /* shared with fortran.y */
  82.  
  83.         /* Declare shared lexical routines */
  84. void advance();
  85. int is_keyword(), looking_at();
  86.  
  87. int debug_include=FALSE;
  88.  
  89.  
  90. /*
  91.  
  92. I. Forlex
  93.  
  94.    Shared functions defined:
  95.     yylex()            Returns next token.  Called from yyparse().
  96.     implied_id_token(t,s)    Creates token for blank common declaration.
  97.  
  98. Note: compilation options LEX_STORE_STRINGS and LEX_STORE_HOLLERITHS:
  99.   Define the macro name LEX_STORE_STRINGS to build a version of ftnchek that
  100.   stores string constants, and LEX_STORE_HOLLERITHS to store hollerith
  101.   constants.  Now that INCLUDE statements are supported, strings must
  102.   be stored.  Holleriths are not used, so they need not be stored.
  103. */
  104. #define LEX_STORE_STRINGS
  105.  
  106. #include <math.h>
  107.  
  108.  
  109.  
  110.     /* The following macro says whether a given character is legal,
  111.      * i.e. one of the stream control chars or a valid ANSI Fortran
  112.      * character.  Lower case letters are considered legal too.
  113.      * Nondigits in columns 1-6 (except EOF,EOS) are illegal
  114.      */
  115. #define islegal(C) ( ((C) == EOF) || ((C) == EOS) || \
  116.     ( (col_num >= 6 || isdigit(C)) && \
  117.      ((C) >= ' ' && (C) <= 'z' && legal_chars[(C)-' '] == (C))) )
  118.  
  119.         /* Array has x where ASCII character is not valid */
  120. PRIVATE char legal_chars[]=
  121. #ifdef ALLOW_UNDERSCORES
  122. " xxx$xx'()*+,-./0123456789:xx=xxx\
  123. ABCDEFGHIJKLMNOPQRSTUVWXYZxxxx_xabcdefghijklmnopqrstuvwxyz";
  124. #else
  125. " xxx$xx'()*+,-./0123456789:xx=xxx\
  126. ABCDEFGHIJKLMNOPQRSTUVWXYZxxxxxxabcdefghijklmnopqrstuvwxyz";
  127. #endif
  128.  
  129.         /* local functions defined */
  130. PRIVATE void
  131.     get_dotted_keyword(), get_hollerith(),
  132.     get_identifier(), get_illegal_token(), get_label(),
  133.     get_letter(), get_number(), get_punctuation(), get_string(),
  134.     get_complex_const();
  135.  
  136.  
  137.  
  138.  
  139.         /*  Gets next token for Yacc.  Return value is token.class,
  140.          *  and a copy of the token is stored in yylval.
  141.          */
  142. int
  143. yylex()
  144. {
  145.     Token token;
  146.  
  147.         /* Initialize token fields to scratch. */
  148.     token.subclass = 0;
  149.     token.value.integer = 0;
  150.  
  151.     if(curr_char == EOF) {
  152.     token.class = EOF;
  153.     token.line_num = line_num;
  154.     token.col_num = col_num;
  155.     }
  156.     else {
  157.  
  158.         /* Skip leading spaces, and give error message if non-ANSI
  159.          * characters are found.
  160.          */
  161.  
  162.     while(iswhitespace(curr_char) || (! islegal(curr_char))  ) {
  163.       if(!iswhitespace(curr_char))
  164.         yyerror("Illegal character");
  165.       advance();
  166.     }
  167.  
  168.     token.line_num = line_num;
  169.     token.col_num = col_num;
  170.  
  171.     if(isadigit(curr_char)) {
  172.         if(col_num < 6)
  173.             get_label(&token);      /* Stmt label */
  174.         else
  175.             get_number(&token);     /* Numeric or hollerith const */
  176.     }
  177.     else if(isaletter(curr_char)) {
  178.         if(implicit_letter_flag)
  179.             get_letter(&token);    /* letter in IMPLICIT list */
  180.         else
  181.             get_identifier(&token); /* Identifier or keyword */
  182.     }
  183.     else {
  184.        switch(curr_char) {
  185. #ifdef ALLOW_UNDERSCORES
  186.          case '_': get_identifier(&token); /* Identifier with initial _ */
  187.            break;
  188. #endif
  189.          case  '.':
  190.         if(isadigit(next_char))
  191.             get_number(&token);     /* Numeric const */
  192.         else if(isaletter(next_char))
  193.             get_dotted_keyword(&token);     /* .EQ. etc. */
  194.         else {
  195.             get_punctuation(&token);    /* "." out of place */
  196.         }
  197.         break;
  198.  
  199.          case '\'':
  200.             get_string(&token);     /* Quoted string */
  201.         break;
  202.  
  203.  
  204.          default:
  205.             get_punctuation(&token);  /* Punctuation character */
  206.         break;
  207.        }
  208.     }
  209.     }
  210.  
  211.     if(token.class == EOS) {
  212.     implicit_flag=FALSE;    /* in case of errors, reset flags */
  213.     implicit_letter_flag = FALSE;
  214.     }
  215.  
  216.  
  217.     prev_token_class = token.class;
  218.  
  219.     yylval = token;
  220.     return token.class;
  221.  
  222. } /* yylex */
  223.  
  224.  
  225.  
  226.     /* Fills argument with token for an identifer, as if an identifer
  227.      * with name given by string s had been lexed.  This will
  228.      * be called by parser when blank common declaration is seen,
  229.      * and when a main prog without program statement is found,
  230.      * and when an unnamed block data statement is found,
  231.      * so processing of named and unnamed cases can be handled uniformly.
  232.     */
  233. void
  234. implied_id_token(t,s)
  235.     Token *t;
  236.     char *s;
  237. {
  238.     int h;
  239.     unsigned long hnum;
  240.  
  241.     hnum = hash(s);
  242.     while( h=hnum%HASHSZ, hashtab[h].name != NULL &&
  243.         strcmp(hashtab[h].name,s) != 0)
  244.             hnum = rehash(hnum);
  245.     if(hashtab[h].name == NULL) {    /* not seen before */
  246.         hashtab[h].name = s;
  247.         hashtab[h].loc_symtab = NULL;
  248.         hashtab[h].glob_symtab = NULL;
  249.         hashtab[h].com_loc_symtab = NULL;
  250.         hashtab[h].com_glob_symtab = NULL;
  251.     }
  252.     t->class = tok_identifier;
  253.     t->value.integer = h;
  254.  
  255. } /* implied_id_token */
  256.  
  257.  
  258.  
  259. struct {
  260.     char *name;
  261.     int class,subclass;
  262.  } dotted_keywords[]={   {"FALSE",tok_logical_const,FALSE},
  263.             {"TRUE",tok_logical_const,TRUE},
  264.             {"EQ",tok_relop,relop_EQ},
  265.             {"NE",tok_relop,relop_NE},
  266.             {"LE",tok_relop,relop_LE},
  267.             {"LT",tok_relop,relop_LT},
  268.             {"GE",tok_relop,relop_GE},
  269.             {"GT",tok_relop,relop_GT},
  270.             {"AND",tok_AND,0},
  271.             {"OR",tok_OR,0},
  272.             {"EQV",tok_EQV,0},
  273.             {"NEQV",tok_NEQV,0},
  274.             {"NOT",tok_NOT,0},
  275.             {NULL,0,0}
  276.             };
  277.  
  278.  
  279. PRIVATE void
  280. get_dotted_keyword(token)
  281.     Token *token;
  282. {
  283.     char s[8];
  284.     int i=0;
  285.  
  286.     initial_flag = FALSE;
  287.  
  288.     advance();      /* gobble the initial '.' */
  289.     while(isaletter(curr_char)) {
  290.        if(i < 7)
  291.         s[i++] = makeupper(curr_char);
  292.        advance();
  293.     }
  294.     s[i] = '\0';
  295.  
  296.     if(curr_char != '.') {
  297.         yyerror("Badly formed logical/relational operator or constant");
  298.     }
  299.     else {
  300.         advance();      /* gobble the final '.' */
  301.     }
  302.  
  303.     for(i=0; dotted_keywords[i].name != NULL; i++) {
  304.         if(strcmp(s,dotted_keywords[i].name) == 0) {
  305.             token->class = dotted_keywords[i].class;
  306.             token->subclass = dotted_keywords[i].subclass;
  307.             token->value.string = dotted_keywords[i].name;
  308.             if(debug_lexer)
  309.                fprintf(list_fd,"\nDotted keyword:\t\t%s",
  310.                            dotted_keywords[i].name);
  311.             return;
  312.         }
  313.     }
  314.             /* Match not found: signal an error */
  315.     yyerror("Unknown logical/relational operator or constant");
  316.     get_illegal_token(token);
  317.  
  318. } /* get_dotted_keyword */
  319.  
  320.  
  321. PRIVATE void
  322. get_hollerith(token,n)  /* Gets string of form nHaaaa */
  323.     Token *token;
  324.     int n;
  325. {
  326.     int i,last_col_num;
  327. /* Holl. consts are not stored unless the macro name LEX_STORE_HOLLERITHS
  328.    is defined. */
  329. #ifdef LEX_STORE_HOLLERITHS
  330.     int strsize=n;
  331.     char *s;
  332. #else
  333.            char *s = "Not stored";
  334. #endif
  335.     initial_flag = FALSE;
  336. #ifdef LEX_STORE_HOLLERITHS
  337.     if( (s=(char *)calloc((unsigned)(strsize+1),1)) == (char *)NULL ) {
  338.       fprintf(stderr,"Out of string space at line %u\n",line_num);
  339.       strsize=0;
  340.     }
  341. #endif
  342.     if(n==1)
  343.       inside_hollerith=FALSE;/* turn off flag ahead of next_char */
  344.     advance();/* Gobble the 'H' */
  345.  
  346.     last_col_num = col_num;
  347.     for(i=0; i<n; i++) {
  348.       while(curr_char == EOL) {
  349.             /* Treat short line as if extended with blanks */
  350.         int col;
  351.         for(col=last_col_num; i<n && col<max_stmt_col; i++,col++) {
  352. #ifdef LEX_STORE_HOLLERITHS
  353.           if(i < strsize)
  354.         s[i] = ' ';
  355. #endif
  356.         }
  357.         last_col_num = col_num;
  358.         advance();
  359.       }
  360.       if(i==n) break;
  361.  
  362.       if(curr_char == EOS || curr_char == EOF) {
  363.         int col;
  364.         for(col=last_col_num; i<n && col<max_stmt_col; i++,col++) {
  365. #ifdef LEX_STORE_HOLLERITHS
  366.           if(i < strsize)
  367.         s[i] = ' ';
  368. #endif
  369.         }
  370. #ifdef LEX_STORE_HOLLERITHS
  371.         strsize=i;        /* in case it did not fill up */
  372. #endif
  373.         break;
  374.       }
  375.       else {
  376. #ifdef LEX_STORE_HOLLERITHS
  377.         s[i] = curr_char;
  378. #endif
  379.         last_col_num = col_num;
  380.         if(i==n-2)/* turn flag off ahead of next_char*/
  381.           inside_hollerith = FALSE;
  382.         advance();
  383.       }
  384.     }
  385.  
  386. #ifdef LEX_STORE_HOLLERITHS
  387.     if(strsize > 0)
  388.       s[strsize] = '\0';
  389. #endif
  390.  
  391.     inside_hollerith = FALSE;
  392.     token->class = tok_hollerith;
  393.     token->value.string = s;
  394.     if(debug_lexer)
  395.         fprintf(list_fd,"\nHollerith:\t\t%s",s);
  396.  
  397. } /* get_hollerith */
  398.  
  399.  
  400. PRIVATE void
  401. get_identifier(token)
  402.     Token *token;
  403. {
  404.     char s[MAXIDSIZE+1];
  405.     int i=0;
  406.  
  407.             /* This loop gets  letter [letter|digit]* forms */
  408.     while(isidletter(curr_char) || isadigit(curr_char)) {
  409.         if(i < MAXIDSIZE)
  410.             s[i++] = makeupper(curr_char);
  411.         advance();
  412.     }
  413.  
  414.             /* If inside a FORMAT specification, it must be
  415.                a FORMAT edit descriptor.  Include also any dot
  416.                followed by number (e.g. F10.5).
  417.             */
  418.     if(inside_format) {
  419.       if( curr_char == '.' && isadigit(next_char) ) {
  420.         if(i < MAXIDSIZE)
  421.             s[i++] = curr_char;    /* store the '.' */
  422.         advance();
  423.         while( isadigit(curr_char) ) {
  424.             if(i < MAXIDSIZE)
  425.                 s[i++] = curr_char;
  426.             advance();
  427.         }
  428.       }
  429.       token->class = tok_edit_descriptor;
  430.       token->value.string = NULL;
  431.       s[i++] = '\0';
  432.     }
  433.     else {        /* it is an identifier or keyword */
  434.       int keywd_class;
  435.       token->class = tok_identifier;
  436.       s[i++] = '\0';
  437.  
  438.       if( (keywd_class = is_keyword(s)) != 0) {
  439.              token->class = keywd_class;    /* It's a keyword */
  440.              token->value.string = NULL;
  441.       }
  442.       else {
  443.                 /* Identifier: find its hashtable entry or
  444.                    create a new entry.    */
  445.             int h;
  446.             Lsymtab *symt;
  447.             token->value.integer = h = hash_lookup(s);
  448.                 /* If it is an array give it a special token
  449.                    class, so that arrays can be distinguished
  450.                    from functions in the grammar. */
  451.             if((symt=hashtab[h].loc_symtab) != NULL
  452.                && symt->array_var) {
  453.               token->class = tok_array_identifier;
  454.             }
  455.       }
  456.     }
  457.  
  458.     if(debug_lexer){
  459.         switch(token->class) {
  460.         case tok_edit_descriptor:
  461.             fprintf(list_fd,"\nEdit descriptor:\t%s",s);
  462.             break;
  463.         case tok_identifier:
  464.             fprintf(list_fd,"\nIdentifier:\t\t%s",s);
  465.             break;
  466.         case tok_array_identifier:
  467.             fprintf(list_fd,"\nArray_identifier:\t%s",s);
  468.             break;
  469.         default:
  470.             fprintf(list_fd,"\nKeyword:\t\ttok_%s",s);
  471.             break;
  472.         }
  473.     }
  474. } /* get_identifier */
  475.  
  476.  
  477. PRIVATE void
  478. get_illegal_token(token)    /* Handle an illegal input situation */
  479.     Token *token;
  480. {
  481.     token->class = tok_illegal;
  482.     if(debug_lexer)
  483.          fprintf(list_fd,"\nILLEGAL TOKEN");
  484.  
  485. } /* get_illegal_token */
  486.  
  487.  
  488.  
  489.         /* Read a label from label field. */
  490. PRIVATE void
  491. get_label(token)
  492.     Token *token;
  493. {
  494.     int value=0;
  495.     while( isadigit(curr_char) && col_num < 6 ) {
  496.         value = value*10 + (curr_char-'0');
  497.         advance();
  498.     }
  499.     token->class = tok_label;
  500.     token->value.integer = value;
  501.     if(debug_lexer)
  502.         fprintf(list_fd,"\nLabel:\t\t\t%d",value);
  503.  
  504. } /* get_label */
  505.  
  506.  
  507. PRIVATE void
  508. get_letter(token)        /* Gets letter in IMPLICIT list */
  509.     Token *token;
  510. {
  511.     token->class = tok_letter;
  512.     token->subclass = makeupper(curr_char);
  513.  
  514.     if(debug_lexer)
  515.     fprintf(list_fd,"\nLetter:\t\t\t%c",token->subclass);
  516.  
  517.     advance();
  518.  
  519. } /* get_letter */
  520.  
  521.  
  522.     /* get_number reads a number and determines data type: integer,
  523.      * real, or double precision.
  524.      */
  525.  
  526. #ifdef BLANKS_IN_NUMBERS        /* tolerate blanks within numbers */
  527. #define SKIP_SP while(iswhitespace(curr_char)) advance()
  528. #else
  529. #define SKIP_SP
  530. #endif
  531.  
  532.  
  533. PRIVATE void
  534. get_number(token)
  535.     Token *token;
  536. {
  537.     double dvalue,leftside,rightside,pwr_of_ten;
  538.     int exponent,expsign,datatype,c,digit_seen=FALSE;
  539.  
  540.     initial_flag = FALSE;
  541.  
  542.     leftside = 0.0;
  543.     datatype = tok_integer_const;
  544.     while(isadigit(curr_char)) {
  545.         leftside = leftside*10.0 + (double)(curr_char-'0');
  546.         if( !integer_context && makeupper(next_char) == 'H' )
  547.           inside_hollerith = TRUE;/* get ready for hollerith*/
  548.         advance();
  549.         SKIP_SP;
  550.         digit_seen = TRUE;
  551.     }
  552.  
  553.         /* If context specifies integer expected, skip to end.
  554.            Otherwise scan on ahead for more. */
  555.     if( integer_context) {
  556.         if(!digit_seen) {
  557.         yyerror("integer expected");
  558.         advance();    /* gobble something to avoid infinite loop */
  559.     }
  560.     }
  561.     else {/* not integer_context */
  562.     if( makeupper(curr_char) == 'H' ){      /* nnH means hollerith */
  563.         if(leftside == 0.0) {
  564.             yyerror("Zero-length hollerith constant");
  565.             inside_hollerith = FALSE;
  566.             advance();
  567.             get_illegal_token(token);
  568.         }
  569.         else {
  570.             get_hollerith(token, (int)leftside);
  571.         }
  572.         return;
  573.     }
  574.  
  575.     rightside = 0.0;
  576.     pwr_of_ten = 1.0;
  577.     if( curr_char == '.' &&
  578.        ! looking_at(tok_relop) ) { /* don't be fooled by 1.eq.N */
  579.         datatype = tok_real_const;
  580.         advance();
  581.         SKIP_SP;
  582.         while(isadigit(curr_char)) {
  583.             rightside = rightside*10.0 + (double)(curr_char-'0');
  584.             pwr_of_ten *= 0.10;
  585.             advance();
  586.             SKIP_SP;
  587.         }
  588.     }
  589. if(debug_lexer)
  590.     dvalue = leftside + rightside*pwr_of_ten;
  591.  
  592.     exponent = 0;
  593.     expsign = 1;
  594.  
  595. #if 0/* old version */
  596.         /* If we now see E or D, it is a real/d.p. constant, unless
  597.            the E or D is followed by w.d which gives an edit descr */
  598.     if( ( (c = makeupper(curr_char)) == 'E' || c == 'D' )
  599.      && !( datatype==tok_integer_const && looking_at(tok_edit_descriptor)))
  600. #else/* new version */
  601.         /* Integer followed by E or D gives a real/d.p constant
  602.            unless we are inside a format statement, in which
  603.            case we have an edit descriptor. */
  604.     if( ( (c = makeupper(curr_char)) == 'E' || c == 'D' )
  605.      && !( datatype==tok_integer_const && inside_format) )
  606. #endif
  607.     {
  608.         datatype = ((c == 'E')? tok_real_const: tok_dp_const);
  609.         advance();
  610.         if(curr_char == '+') {
  611.             expsign = 1;
  612.             advance();
  613.         }
  614.         else if(curr_char == '-') {
  615.             expsign = -1;
  616.             advance();
  617.         }
  618.         if(!isadigit(curr_char)) {
  619.             yyerror("Badly formed real constant");
  620.         }
  621.         else while(isadigit(curr_char)) {
  622.             exponent = exponent*10 + (curr_char-'0');
  623.             advance();
  624.         }
  625.  
  626.     /*  Compute real value only if debugging. If it exceeds max magnitude,
  627.         computing it may cause crash. At this time, value of real const
  628.         is not used for anything. */
  629. if(debug_lexer)
  630.           dvalue *= pow(10.0, (double)(exponent*expsign));
  631. else
  632.           dvalue = 0.0;
  633.  
  634.     }
  635.     }/* end if(!integer_context) */
  636.     token->class = datatype;
  637.     switch(datatype) {
  638.        case tok_integer_const:
  639.         token->value.integer = (long)leftside;
  640. if(debug_lexer)
  641. fprintf(list_fd,"\nInteger const:\t\t%d",token->value.integer);
  642.         break;
  643.        case tok_real_const:
  644.             /* store single as double lest it overflow */
  645.         token->value.dbl = dvalue;
  646. if(debug_lexer)
  647. fprintf(list_fd,"\nReal const:\t\t%g",token->value.dbl);
  648.         break;
  649.        case tok_dp_const:
  650.         token->value.dbl = dvalue;
  651. if(debug_lexer)
  652. fprintf(list_fd,"\nDouble const:\t\t%lg",token->value.dbl);
  653.         break;
  654.     }
  655.  
  656. } /* get_number */
  657.  
  658.      /* get_complex_constant reads an entity of the form (num,num)
  659.       where num is any [signed] numeric constant.  It will only be
  660.       called when looking_at() has guaranteed that there is one there.
  661.       The token receives the real part as a number.  The imaginary part
  662.       is not stored.  Whitespace is allowed between ( and num, around
  663.       the comma, and between num and ) but not within num. */
  664.  
  665. PRIVATE void
  666. get_complex_const(token)
  667.     Token *token;
  668. {
  669.     Token imag_part;    /* temporary to hold imag part */
  670.     double sign=1.0;
  671.  
  672.     initial_flag = FALSE;
  673.  
  674.     advance();        /* skip over the initial paren */
  675.  
  676.     while(iswhitespace(curr_char))
  677.       advance();
  678.     if(curr_char == '+' || curr_char == '-') {
  679.       if(curr_char == '-') sign = -1.0;
  680.       advance();
  681.       SKIP_SP;
  682.     }
  683.  
  684. if(debug_lexer){
  685. fprintf(list_fd,"\nComplex const:(");
  686. if(sign < 0.0) fprintf(list_fd," -");
  687. }
  688.     get_number(token);
  689.     switch(token->class) {
  690.        case tok_integer_const:
  691.         token->value.dbl = sign*(double)token->value.integer;
  692.         break;
  693.        case tok_real_const:
  694.        case tok_dp_const:
  695.         token->value.dbl = sign*token->value.dbl;
  696.         break;
  697.     }
  698.     token->class = tok_complex_const;
  699.  
  700.     while(iswhitespace(curr_char))
  701.       advance();
  702.  
  703.  
  704.     advance();        /* skip over the comma */
  705.  
  706.     while(iswhitespace(curr_char))
  707.          advance();
  708.     if(curr_char == '+' || curr_char == '-') {
  709.          if(curr_char == '-') sign = -1.0;
  710.          advance();
  711.          SKIP_SP;
  712.     }
  713. if(debug_lexer){
  714. fprintf(list_fd,"\n,");
  715. if(sign < 0.0) fprintf(list_fd," -");
  716. }
  717.     get_number(&imag_part);
  718.  
  719.  
  720.     while(iswhitespace(curr_char))
  721.        advance();
  722.  
  723.     advance();    /* skip over final paren */
  724.  
  725. if(debug_lexer)
  726. fprintf(list_fd,"\n)");
  727.  
  728. }
  729.  
  730. PRIVATE void
  731. get_punctuation(token)
  732.     Token *token;
  733. {
  734.     initial_flag = FALSE;
  735.  
  736.     if(curr_char == '*' && next_char == '*') {
  737.         token->class = tok_power;
  738.         advance();
  739.     }
  740.     else if(curr_char == '/' && next_char == '/' ) {
  741.         token->class = tok_concat;
  742.         advance();
  743.     }
  744.         /* paren can be the start of complex constant if everything
  745.            is just right. Maybe more tests needed here. */
  746.     else if(complex_const_allowed && curr_char == '(' &&
  747.          (prev_token_class != tok_identifier &&
  748.         prev_token_class != tok_array_identifier)
  749.          && looking_at(tok_complex_const)) {
  750.         get_complex_const(token);
  751.         return;
  752.     }
  753.     else
  754.         token->class = curr_char;
  755.  
  756.  
  757. if(debug_lexer) {
  758.     if(token->class == EOS)
  759.         fprintf(list_fd,"\n\t\t\tEOS");
  760.     else if(token->class == tok_power)
  761.         fprintf(list_fd,"\nPunctuation:\t\t**");
  762.     else if(token->class == tok_concat)
  763.         fprintf(list_fd,"\nPunctuation:\t\t//");
  764.     else
  765.         fprintf(list_fd,"\nPunctuation:\t\t%c",token->class);
  766.  }
  767.     advance();
  768. } /* get_punctuation */
  769.  
  770.  
  771.  
  772. PRIVATE void
  773. get_string(token)       /* Gets string of form 'aaaa' */
  774.     Token *token;
  775. {
  776.     int i,len,last_col_num;
  777.  
  778. /* String consts are not stored unless the macro name LEX_STORE_STRINGS
  779.    is defined. */
  780. #ifdef LEX_STORE_STRINGS
  781.     char *s;
  782.     char tmpstr[MAXSTR+1];
  783. #else
  784.     char *s = "Not stored";
  785. #endif
  786.  
  787.     initial_flag = FALSE;
  788.     inside_string = TRUE;
  789.     last_col_num=col_num;
  790.     advance();      /* Gobble leading quote */
  791.     i = len = 0;
  792.     for(;;) {
  793.         while(curr_char == EOL) {
  794.             /* Treat short line as if extended with blanks */
  795.             int col;
  796.             for(col=last_col_num; col<max_stmt_col; col++) {
  797. #ifdef LEX_STORE_STRINGS
  798.               if(i < MAXSTR)
  799.             tmpstr[i++] = ' ';
  800. #endif
  801.               ++len;
  802.             }
  803.           last_col_num=col_num;
  804.           advance();
  805.         }
  806.         if(curr_char == EOS || curr_char == EOF) {
  807.             yyerror("Closing quote missing from string");
  808.             break;
  809.         }
  810.         if(curr_char == '\'') {
  811.               inside_string = FALSE;/* assume so for now */
  812.                     /* Handle possible continuation */
  813.             if(next_char == EOL && col_num == max_stmt_col)
  814.               advance();
  815.  
  816.             last_col_num=col_num;
  817.             advance();
  818.  
  819.             if(curr_char == '\'') { /* '' becomes ' in string */
  820.                 inside_string = TRUE; /* not a closing quote */
  821. #ifdef LEX_STORE_STRINGS
  822.                 if(i < MAXSTR)
  823.                     tmpstr[i++] = curr_char;
  824. #endif
  825.                 ++len;
  826.                 last_col_num=col_num;
  827.                 advance();
  828.             }
  829.             else {
  830.                 break;  /* It was a closing quote after all */
  831.             }
  832.         }
  833.         else {
  834. #ifdef LEX_STORE_STRINGS
  835.             if(i < MAXSTR)
  836.                 tmpstr[i++] = curr_char;
  837. #endif
  838.             ++len;
  839.             last_col_num=col_num;
  840.             advance();
  841.         }
  842.     }
  843. #ifdef LEX_STORE_STRINGS
  844.     tmpstr[i++] = '\0';
  845.     if( (s=(char *)calloc((unsigned)i,1)) == (char *)NULL ) {
  846.         fprintf(stderr,"Out of space at line %u\n",line_num);
  847.     }
  848.     else {
  849.         (void) strcpy(s,tmpstr);
  850.     }
  851. #endif
  852.     if(len == 0) {
  853.         warning(line_num,col_num,
  854.             "Zero-length string not allowed\n");
  855.     }
  856.  
  857.     inside_string = FALSE;
  858.  
  859.     token->class = tok_string;
  860.     token->value.string = s;
  861.     if(debug_lexer)
  862.         fprintf(list_fd,"\nString:\t\t\t%s",s);
  863.  
  864. } /* get_string */
  865.  
  866.  
  867. /* End of Forlex module */
  868.  
  869. /*
  870. II. Advance
  871. */
  872.  
  873. /* advance.c:
  874.  
  875.     Low-level input routines for Fortran program checker.
  876.  
  877.     Shared functions defined:
  878.         init_scan()    Initializes an input stream.
  879.         finish_scan()    Finishes processing an input stream.
  880.         advance()    Reads next char, removing comments and
  881.                 handling continuation lines.
  882.         looking_at()    Handles lookahead up to end of line.
  883.  
  884.         flush_line_out(n) Prints lines up to line n if not already
  885.                 printed, so error messages come out looking OK.
  886. */
  887.  
  888.  
  889.     /* Define tab stops: nxttab[col_num] is column of next tab stop */
  890.  
  891. #define do8(X) X,X,X,X,X,X,X,X
  892. PRIVATE int nxttab[]={ 0, do8(9), do8(17), do8(25), do8(33),
  893.         do8(41), do8(49), do8(57), do8(65), do8(73), do8(81)};
  894.  
  895. PRIVATE int
  896.     next_index,        /* Index in line of next_char */
  897.     prev_comment_line,    /* True if previous line was comment */
  898.     curr_comment_line,    /* True if current line is comment */
  899.     noncomment_line_count,    /* Number of noncomment lines read so far */
  900.     line_is_printed,    /* True if line has been flushed (printed) */
  901.     prev_line_is_printed,    /* True if line has been flushed (printed) */
  902.     sticky_EOF;        /* Signal to delay EOF a bit for sake
  903.                    of error messages in include files. */
  904. PRIVATE unsigned
  905.     prev_line_num;        /* line number of previous input line */
  906.  
  907. unsigned prev_stmt_line_num;    /* line number of previous noncomment */
  908.  
  909. PRIVATE char
  910.     lineA[MAXLINE+1],lineB[MAXLINE+1],  /* Buffers holding input lines */
  911.     *prev_line,*line;            /* Pointers to input buffers */
  912.  
  913. PRIVATE int
  914.     is_comment(), is_continuation(), is_overlength(), see_a_number();
  915. PRIVATE char
  916.     *getstrn();
  917.  
  918.  
  919. #ifdef ALLOW_INCLUDE
  920. /* Definition of structure for saving the input stream parameters while
  921.    processing an include file.
  922. */
  923.  
  924. typedef struct {
  925.   FILE     *input_fd;
  926.   char       *fname;
  927.   char     line[MAXLINE];  /* MAXLINE is defined in ftnchek.h */
  928.   int      curr_char;
  929.   int      next_char;
  930.   int       next_index;
  931.   int       col_num;
  932.   int       next_col_num;
  933.   int       line_is_printed;
  934.   int       do_list;
  935.   unsigned line_num;
  936.   unsigned next_line_num;
  937. } IncludeFileStack;
  938.  
  939. PRIVATE IncludeFileStack include_stack[MAX_INCLUDE_DEPTH];
  940. PRIVATE FILE* find_include(), *fopen_with_path();
  941.  
  942. #endif /*ALLOW_INCLUDE*/
  943.  
  944. PRIVATE void
  945.     init_stream();
  946. PRIVATE int
  947.     push_include_file(),pop_include_file();
  948.  
  949. #ifdef ALLOW_INCLUDE        /* defns of include-file handlers */
  950.  
  951. PRIVATE int
  952. push_include_file(fname,fd)
  953.     char *fname;
  954.     FILE *fd;
  955. {
  956.      if (incdepth == MAX_INCLUDE_DEPTH) {
  957.        yyerror("Oops! include files nested too deep");
  958.        return FALSE;
  959.      }
  960.  
  961. if(debug_include){
  962. fprintf(list_fd,"\npush_include_file: curr_char=%c (%d)",curr_char,curr_char);
  963. }
  964.  
  965.      include_stack[incdepth].input_fd = input_fd;
  966.      input_fd = fd;
  967.  
  968.      include_stack[incdepth].fname = current_filename;
  969.      current_filename = fname;
  970.  
  971.      strcpy(include_stack[incdepth].line,line);
  972.      include_stack[incdepth].curr_char = curr_char;
  973.      include_stack[incdepth].next_char = next_char;
  974.      include_stack[incdepth].next_index = next_index;
  975.      include_stack[incdepth].col_num = col_num;
  976.      include_stack[incdepth].next_col_num = next_col_num;
  977.      include_stack[incdepth].line_is_printed = line_is_printed;
  978.      include_stack[incdepth].line_num = line_num;
  979.      include_stack[incdepth].next_line_num = next_line_num;
  980.      include_stack[incdepth].do_list = do_list;
  981.  
  982.      incdepth++;
  983.  
  984.      init_stream();
  985.  
  986.      return TRUE;
  987. }
  988.  
  989. PRIVATE int
  990. pop_include_file()
  991. {
  992. if(debug_include){
  993. fprintf(list_fd,"\npop_include_file: line %u = %s depth %d",line_num,line,
  994. incdepth);
  995. }
  996.  
  997.      if (incdepth == 0) {    /* Stack empty: no include file to pop. */
  998.        return FALSE;
  999.      }
  1000.      incdepth--;
  1001.  
  1002.  
  1003.      if(do_list) {
  1004.        flush_line_out(next_line_num);
  1005.        fprintf(list_fd,"\nResuming file %s:",
  1006.            include_stack[incdepth].fname);
  1007.      }
  1008.  
  1009.      fclose(input_fd);
  1010.      input_fd = include_stack[incdepth].input_fd;
  1011.  
  1012.      current_filename = include_stack[incdepth].fname;
  1013.  
  1014.      strcpy(line,include_stack[incdepth].line);
  1015.      curr_char = include_stack[incdepth].curr_char;
  1016.      next_char = include_stack[incdepth].next_char;
  1017.      next_index = include_stack[incdepth].next_index;
  1018.      col_num = include_stack[incdepth].col_num;
  1019.      next_col_num = include_stack[incdepth].next_col_num;
  1020.      line_is_printed = include_stack[incdepth].line_is_printed;
  1021.      line_num = include_stack[incdepth].line_num;
  1022.      next_line_num = include_stack[incdepth].next_line_num;
  1023.      do_list = include_stack[incdepth].do_list;
  1024.  
  1025.      curr_comment_line = FALSE;
  1026.      prev_line_is_printed = TRUE;
  1027.      initial_flag = TRUE;
  1028.      sticky_EOF = TRUE;
  1029.  
  1030.      return TRUE;
  1031. }
  1032.  
  1033.  
  1034. void
  1035. open_include_file(fname)
  1036.      char *fname;
  1037. {
  1038.   FILE *fd;
  1039. #ifdef VMS_INCLUDE
  1040.   int list_option=FALSE;    /* /[NO]LIST qualifier: default=NOLIST */
  1041. #endif /*VMS_INCLUDE*/
  1042.  
  1043. #ifdef VMS_INCLUDE /* for VMS: default extension is .for */
  1044.   if(has_extension(fname,"/nolist")) {
  1045.     list_option = FALSE;
  1046.     fname[strlen(fname)-strlen("/nolist")] = '\0'; /* trim off qualifier */
  1047.   }
  1048.   else if(has_extension(fname,"/list")) {
  1049.     list_option = TRUE;
  1050.     fname[strlen(fname)-strlen("/list")] = '\0'; /* trim off qualifier */
  1051.   }
  1052.   fname = add_ext(fname, DEF_SRC_EXTENSION);
  1053. #endif
  1054.  
  1055.   if ((fd = find_include(&fname,"r")) == NULL) {
  1056.     fprintf(stderr,"\nerror opening include file %s\n",fname);
  1057.     return;
  1058.   }
  1059.  
  1060.             /* Print the INCLUDE line if do_list */
  1061.   if(do_list)
  1062.     flush_line_out(prev_line_num);
  1063.  
  1064.             /* Report inclusion of file */
  1065.   if(verbose || do_list)
  1066.     fprintf(list_fd,"\nIncluding file %s:",fname);
  1067.  
  1068.         /* Save the current input stream and then open
  1069.            the include file as input stream. */
  1070.   if( push_include_file(fname,fd) ) {
  1071. #ifdef VMS_INCLUDE
  1072.     /* put /[NO]LIST option into effect */
  1073.       if(do_list != list_option)
  1074.     fprintf(list_fd," (listing %s)", list_option? "on":"off");
  1075.       do_list = list_option;
  1076. #endif /*VMS_INCLUDE*/
  1077.   }
  1078.   else
  1079.     fclose(fd);
  1080. }
  1081.  
  1082. PRIVATE FILE*
  1083. find_include(fname,mode)    /* looks for file locally or in include dir */
  1084.      char **fname,        /* If found, fname is returned with full path*/
  1085.      *mode;
  1086. {
  1087.   FILE *fp;
  1088.   char *env_include_var;
  1089.   IncludePathNode *p;
  1090.  
  1091.             /* Look first for bare filename */
  1092.   if( (fp=fopen(*fname,mode)) != NULL)
  1093.     return fp;
  1094.  
  1095.               /* If not found, look in directories given
  1096.              by include_path_list from -include options */
  1097.  
  1098.   for(p=include_path_list; p!=NULL; p=p->link) {
  1099.     if( (fp=fopen_with_path(p->include_path,fname,mode)) != (FILE *)NULL)
  1100.       return fp;
  1101.   }
  1102.  
  1103.               /* If not found, look in directory given by
  1104.              env variable ENV_INCLUDE_VAR (e.g. set by
  1105.              % setenv INCLUDE ~/myinclude ) */
  1106.  
  1107.   if( (env_include_var=getenv(ENV_INCLUDE_VAR)) != NULL) {
  1108.     if( (fp=fopen_with_path(env_include_var,fname,mode)) != (FILE *)NULL)
  1109.       return fp;
  1110.   }
  1111.  
  1112.             /* Still not found: look in systemwide
  1113.                default directory */
  1114.  
  1115. #ifdef DEFAULT_INCLUDE_DIR
  1116.   if( (fp=fopen_with_path(DEFAULT_INCLUDE_DIR,fname,mode)) != NULL)
  1117.     return fp;
  1118. #endif/* DEFAULT_INCLUDE_DIR */
  1119.  
  1120.                 /* Not found anywhere: fail */
  1121.   return (FILE *)NULL;
  1122. }/*find_include*/
  1123.  
  1124.         /* Routine to open file with name given by include_path
  1125.            followed by fname.  If successful, fname is replaced
  1126.            by pointer to full name.  */
  1127. PRIVATE FILE *
  1128. fopen_with_path(include_path,fname,mode)
  1129.      char *include_path, **fname, *mode;
  1130. {
  1131.     FILE *fp;
  1132.     char tmpname[256];        /* holds name with path prepended */
  1133.  
  1134.     strcpy(tmpname,include_path);
  1135.                 /* Add "/" or "\" if not provided */
  1136. #ifdef UNIX
  1137.     if(tmpname[strlen(tmpname)-1] != '/')
  1138.       strcat(tmpname,"/");
  1139. #endif
  1140. #ifdef MSDOS
  1141.     if(tmpname[strlen(tmpname)-1] != '\\')
  1142.       strcat(tmpname,"\\");
  1143. #endif
  1144.     strcat(tmpname,*fname);
  1145.  
  1146.     if( (fp=fopen(tmpname,mode)) != (FILE *)NULL) {
  1147.             /* Found: save new name in permanent space */
  1148.     *fname=calloc(strlen(tmpname)+1,sizeof(char));
  1149.     strcpy(*fname,tmpname);
  1150.     }
  1151.  
  1152.     return fp;
  1153. }/*fopen_with_path*/
  1154.  
  1155. #else /* no ALLOW_INCLUDE */
  1156.                 /* disabled forms of include handlers */
  1157. PRIVATE int
  1158. push_include_file(fname,fd)
  1159.     char *fname;
  1160.     FILE *fd;
  1161. {return FALSE;}
  1162.  
  1163. PRIVATE int
  1164. pop_include_file()
  1165. {return FALSE;}
  1166.  
  1167. void
  1168. open_include_file(fname)
  1169.      char *fname;
  1170. {}
  1171.  
  1172. #endif /*ALLOW_INCLUDE*/
  1173.  
  1174. void
  1175. init_scan()            /* Starts reading a file */
  1176. {
  1177.     tab_count = 0;
  1178.     incdepth = 0;
  1179.  
  1180.     line = lineA;        /* Start out reading into buffer A */
  1181.     prev_line = lineB;
  1182.  
  1183.     init_stream();
  1184. }
  1185.  
  1186. PRIVATE void
  1187. init_stream()        /* Initializes a new input stream */
  1188. {
  1189.     curr_comment_line = FALSE;
  1190.     inside_string = FALSE;
  1191.     inside_hollerith = FALSE;
  1192.     line_is_printed = TRUE;
  1193.     prev_line_is_printed = TRUE;
  1194.     noncomment_line_count = 0;
  1195.  
  1196.     next_index = -1;    /* Startup as if just read a blank line */
  1197.     next_char = EOS;
  1198.     curr_char = EOS;
  1199.     next_col_num = 0;
  1200.     next_line_num = 0;
  1201.     prev_line_num = prev_stmt_line_num = 0;
  1202.     sticky_EOF = TRUE;
  1203.     contin_count = 0;
  1204.  
  1205.     line[0] = '\0';
  1206.     advance();        /* put 1st two chars in the pipeline */
  1207.     advance();
  1208.     advance();        /* gobble the artificial initial EOS */
  1209. }
  1210.  
  1211.  
  1212. void
  1213. finish_scan()
  1214. {
  1215.         /* clean up if no END statement at EOF */
  1216.     check_seq_header((Token *)NULL);
  1217.         /* print last line if not already done */
  1218.     if(do_list)
  1219.         flush_line_out(line_num);
  1220. }
  1221.  
  1222. #ifdef INLINE_COMMENT_CHAR
  1223.     /* macro is used on next_char: must look at curr_char to avoid
  1224.        being fooled by '!' without messing up on 'xxx'! either.
  1225.        Also don't be fooled by '''!''' which is the string '!'
  1226.        Note that inside_string does not yet reflect curr_char.
  1227.        Test is that inside_string is true but about to become false,
  1228.        or false and not about to become true. Think about it. */
  1229.  
  1230. #define inline_comment(c) ( ((c)==INLINE_COMMENT_CHAR) &&\
  1231.         (inside_string == (curr_char == '\'')) && (!inside_hollerith) )
  1232. #endif
  1233.  
  1234. void
  1235. advance()
  1236. {
  1237.     int eol_skip = FALSE;
  1238.     do{
  1239.     while(next_char == EOF) {      /* Stick at EOF */
  1240.         if(curr_char == EOS || curr_char == EOF) {
  1241.  
  1242.              /* Pause to allow parse actions at end of stmt
  1243.                 to have correct file context before popping
  1244.                 the include file.  Effect is to send an extra
  1245.                 EOS to parser at end of file. */
  1246.           if(sticky_EOF) {
  1247.             sticky_EOF = FALSE;
  1248.             return;
  1249.           }
  1250.                 /* At EOF: close include file if any,
  1251.                    otherwise yield an EOF character. */
  1252.           if( ! pop_include_file() ) {
  1253.             curr_char = EOF;
  1254.             return;
  1255.           }
  1256.         }
  1257.         else {
  1258.           curr_char = EOS;
  1259.           return;
  1260.         }
  1261.     }
  1262.  
  1263.     if(curr_char == EOS)
  1264.         initial_flag = TRUE;
  1265.  
  1266.     if(! eol_skip) {
  1267.         curr_char = next_char;      /* Step to next char of input */
  1268.         col_num = next_col_num;
  1269.         line_num = next_line_num;
  1270.     }
  1271.  
  1272.     if(next_char == '\t'){       /* Handle tabs in input */
  1273.  
  1274.         next_col_num = nxttab[next_col_num];
  1275.  
  1276.         if( ! (inside_string || inside_hollerith) )
  1277.             tab_count++;    /*  for portability warning */
  1278.     }
  1279.     else {
  1280.         next_col_num++;
  1281.     }
  1282.  
  1283.     next_char = line[++next_index];
  1284.  
  1285.             /* If end of line is reached, input a new line.
  1286.              */
  1287.     while(next_col_num > max_stmt_col || next_char == '\0'
  1288. #ifdef INLINE_COMMENT_CHAR
  1289.     || inline_comment(next_char)
  1290. #endif
  1291.     ){
  1292.         do{
  1293.             if(do_list) /* print prev line if not printed yet */
  1294.               flush_line_out(prev_line_num);
  1295.  
  1296.             if( f77_standard ) {
  1297.               if( !prev_comment_line && max_stmt_col>72
  1298.                  && is_overlength(prev_line)){
  1299.                   nonstandard(prev_line_num,(unsigned)73);
  1300.                   msg_tail(": characters past 72 columns");
  1301.               }
  1302. #ifdef INLINE_COMMENT_CHAR
  1303.               if( !curr_comment_line && inline_comment(next_char)){
  1304.                   nonstandard(next_line_num,next_col_num);
  1305.                   msg_tail(": inline comment");
  1306.               }
  1307. #endif
  1308.                 }
  1309.                 /* Swap input buffers to get ready for new line.
  1310.                    But throw away comment lines if do_list is
  1311.                    false, so error messages will work right.
  1312.                  */
  1313.             if(do_list || ! curr_comment_line) {
  1314.                 char *temp=line;
  1315.                 line = prev_line;
  1316.                 prev_line=temp;
  1317.                 if(! curr_comment_line)
  1318.                   prev_stmt_line_num = line_num;
  1319.                 prev_line_num = next_line_num;
  1320.                 prev_line_is_printed = line_is_printed;
  1321.             }
  1322.  
  1323.             ++next_line_num;
  1324.             line_is_printed = FALSE;
  1325.             if( getstrn(line,MAXLINE+1,input_fd) == NULL ) {
  1326.                 next_char = EOF;
  1327.                 line_is_printed = TRUE;
  1328.                 return;
  1329.             }
  1330.  
  1331.             /*  Keep track of prior-comment-line situation */
  1332.             prev_comment_line = curr_comment_line;
  1333.  
  1334.         } while( (curr_comment_line = is_comment(line)) != FALSE);
  1335.         ++noncomment_line_count;
  1336.  
  1337.             /* Handle continuation lines */
  1338.         if( (next_index = is_continuation(line)) != 0) {
  1339.                 /* It is a continuation */
  1340.             if(eol_is_space) {
  1341.             next_char = EOL;
  1342.             next_col_num = 6;
  1343.             }
  1344.             else {
  1345.             next_char = line[++next_index];
  1346.             next_col_num = 7;
  1347.             eol_skip = TRUE; /* skip continued leading space */
  1348.             }
  1349.                 /* Issue warnings if contin in funny places */
  1350.             if(noncomment_line_count == 1)
  1351.                 warning(next_line_num,(unsigned)6,
  1352.             "Continuation mark found in first statement of file");
  1353.             if( pretty_flag && prev_comment_line )
  1354.                 warning(next_line_num,(unsigned)6,
  1355.             "Continuation follows comment or blank line");
  1356.                 if(contin_count++ == 19)
  1357.               if(f77_standard) {
  1358.                 nonstandard(next_line_num,(unsigned)6);
  1359.                 msg_tail(": > 19 continuation lines");
  1360.               }
  1361.         }
  1362.         else {
  1363.                 /* It is not a continuation */
  1364.             next_char = EOS;
  1365.             next_col_num = 0;
  1366.             next_index = -1;
  1367.             contin_count = 0;
  1368.         }
  1369.     }/*end while( end of line reached )*/
  1370.  
  1371.         /* Avoid letting a '0' in column 6 become a token */
  1372.     if(next_col_num == 6 && next_char == '0')
  1373.         next_char = ' ';
  1374.  
  1375.             /* elide EOL and following space of continued
  1376.                stmts if requested */
  1377.     eol_skip = (eol_skip && isspace(next_char));
  1378.  
  1379.    }while(eol_skip);/*end do*/
  1380.  
  1381. }/* end advance */
  1382.  
  1383.  
  1384.     /*  Function which returns 0 if line is not a comment, 1 if it is.
  1385.      *  Comment is ANSI standard: C or c or * in column 1, or blank line.
  1386.      */
  1387.  
  1388. PRIVATE int
  1389. is_comment(s)
  1390.     char s[];
  1391. {
  1392.     int i,c= makeupper(s[0]);
  1393.     unsigned col;
  1394.     if( c == 'C' || c == '*' )
  1395.         return TRUE;
  1396.  
  1397.     for(i=0,col=1; s[i] != '\0'; i++)
  1398.         if( !isspace(s[i]))
  1399. #ifdef INLINE_COMMENT_CHAR
  1400.         /* Initial "!" starts a comment, except in col. 6 it
  1401.            must be taken as continuation mark */
  1402.              if(s[i]==INLINE_COMMENT_CHAR && col != 6) {
  1403.                  if(f77_standard) {
  1404.                  nonstandard(next_line_num,col);
  1405.                  msg_tail(": inline comment");
  1406.                  }
  1407.                  return TRUE;
  1408.               }
  1409.               else
  1410.                   return FALSE;
  1411.         else
  1412.               if(s[i] == '\t') col = nxttab[col];
  1413.               else           col++;
  1414. #else
  1415.             return FALSE;
  1416. #endif
  1417.     return TRUE;        /* blank line */
  1418. }
  1419.  
  1420.  
  1421.     /*  Function which returns 0 if line is a not continuation line.
  1422.      *  If line is a continuation, returns index in line of
  1423.      *  the continuation mark.
  1424.      */
  1425. PRIVATE int
  1426. is_continuation(s)
  1427.     char s[];
  1428. {
  1429.     int col,i,c;
  1430.                 /* skip to col 6 */
  1431.     for(i=0,col=1; col < 6 && s[i] != '\0'; i++) {
  1432.         if(s[i] == '\t')
  1433.             col = nxttab[col];
  1434.         else
  1435.             col++;
  1436.     }
  1437.     c = s[i];
  1438.  
  1439.     if ( col == 6 && c != '\0' && !isspace(c) && c != '0')
  1440.         return i;
  1441.     else
  1442.         return 0;
  1443.  
  1444. }
  1445.  
  1446. int
  1447. flush_line_out(n)    /* Prints lines up to line #n if not yet printed */
  1448.     unsigned n;        /* Returns TRUE if line was printed, else FALSE */
  1449. {
  1450.             /* Print previous line only if do_list TRUE */
  1451.     if( !prev_line_is_printed
  1452.      && ((n == prev_line_num) || (n > prev_line_num && do_list)) ) {
  1453.        print_a_line(list_fd,prev_line,prev_line_num);
  1454.        prev_line_is_printed = TRUE;
  1455.     }
  1456.     if(n >= next_line_num && !line_is_printed) {
  1457.        print_a_line(list_fd,line,next_line_num);
  1458.        line_is_printed = TRUE;
  1459.     }
  1460.     return ( do_list ||
  1461.          (prev_line_is_printed && n == prev_line_num) ||
  1462.                (line_is_printed && n == next_line_num) );
  1463. }
  1464.  
  1465.  
  1466.     /*  Function to read n-1 characters, or up to newline, whichever
  1467.      *  comes first.  Differs from fgets in that the newline is replaced
  1468.      *  by null, and characters up to newline (if any) past the n-1st
  1469.      *  are read and thrown away.
  1470.      *  Returns NULL when end-of-file or error is encountered.
  1471.      */
  1472. PRIVATE char *
  1473. getstrn(s,n,fd)
  1474.     char s[];
  1475.     int n;
  1476.     FILE *fd;
  1477. {
  1478.     int i=0,c;
  1479.     while( (c=getc(fd)) != '\n' ) {
  1480.         if(c == EOF)
  1481.             return NULL;
  1482.  
  1483.         if(i < n-1)
  1484.             s[i++] = c;
  1485.     }
  1486.     s[i] = '\0';
  1487.     return s;
  1488. }
  1489.  
  1490.  
  1491.     /* Function which looks ahead as far as end of line to see if input
  1492.        cursor is sitting at start of a token of the given class. */
  1493.     /* N.B. right now only looks for edit descriptor or relop
  1494.        or complex constant */
  1495. int
  1496. looking_at(token_class)
  1497.     int token_class;
  1498. {
  1499.     int index;
  1500.  
  1501.     if( eol_is_space && line_num != next_line_num )
  1502.     return FALSE;    /* Looking at next line already */
  1503.  
  1504.     switch(token_class) {
  1505.  
  1506. #if 0/* This case is no longer used */
  1507.       case tok_edit_descriptor:
  1508.         if( ! inside_format )    /* Gotta be inside a format spec */
  1509.         return FALSE;
  1510.  
  1511.     index = next_index;    /* Move past the E or D */
  1512.  
  1513.     if( ! isdigit(line[index++]) )
  1514.         return FALSE;        /* Must start with w = integer */
  1515.     while( isdigit(line[index]) ) {
  1516.         ++index;        /* Scan over the w part */
  1517.     }
  1518.  
  1519.     if( line[index++] != '.' )
  1520.         return FALSE;        /* Now must have decimal point */
  1521.  
  1522.     if( ! isdigit(line[index++]) )
  1523.         return FALSE;        /* Must now have d = integer */
  1524.  
  1525.     break;
  1526. #endif
  1527.       case tok_relop:        /* called with curr_char == '.' */
  1528.  
  1529.     if( !isaletter( line[next_index] ) )    /* next char must be letter */
  1530.         return FALSE;
  1531.  
  1532.     if( makeupper( line[next_index] ) == 'D' )    /* D.P. exponent */
  1533.         return FALSE;
  1534.  
  1535.             /* if next char is any other letter but 'E', cannot be
  1536.                 exponent.  If 'E', must be EQ to be relop */
  1537.     if( makeupper( line[next_index] ) == 'E'
  1538.      && makeupper( line[next_index+1] ) != 'Q' )
  1539.         return FALSE;
  1540.  
  1541.     break;
  1542.  
  1543.       case tok_complex_const:
  1544.     index = next_index;
  1545.  
  1546.     if( (index = see_a_number(line,index)) < 0 )
  1547.       return FALSE;
  1548.     while(line[index] != '\0' && isspace(line[index]))
  1549.       index++;
  1550.  
  1551.     if( line[index] != ',' )
  1552.       return FALSE;
  1553.     ++index;
  1554.  
  1555.     if( (index = see_a_number(line,index)) < 0 )
  1556.       return FALSE;
  1557.     while(line[index] != '\0' && isspace(line[index]))
  1558.       index++;
  1559.  
  1560.     if(line[index] != ')')
  1561.       return FALSE;
  1562.  
  1563.     break;
  1564.  
  1565.       default:
  1566.     return FALSE;
  1567.     }
  1568.  
  1569.     return TRUE;    /* passed all the tests */
  1570.  
  1571. }
  1572.  
  1573.     /* see_a_number returns -1 if there is no valid numeric constant
  1574.        in string s starting at index i.  If valid number found, it
  1575.        returns the index of the next character after the constant.
  1576.        Leading whitespace in s is skipped.*/
  1577.  
  1578. #ifdef BLANKS_IN_NUMBERS
  1579. #define SKIP_SPACE    while(s[i] != '\0' && isspace(s[i])) i++
  1580. #else
  1581. #define SKIP_SPACE
  1582. #endif
  1583.  
  1584. PRIVATE int
  1585. see_a_number(s,i)
  1586.    char s[];
  1587.    int i;
  1588. {
  1589.    int j;
  1590.    int digit_seen = FALSE;
  1591.  
  1592.    while(s[i] != '\0' && isspace(s[i]))
  1593.      i++;
  1594.             /* move past optional preceding sign */
  1595.    if(s[i] == '-' || s[i] == '+' ) {
  1596.      i++;
  1597.      SKIP_SPACE;
  1598.    }
  1599.  
  1600.         /* move past ddd or ddd. or .ddd or ddd.ddd */
  1601.    if(isdigit(s[i]))
  1602.      digit_seen = TRUE;
  1603.    while(isdigit(s[i])) {
  1604.      i++;
  1605.      SKIP_SPACE;
  1606.    }
  1607.    if(s[i] == '.') {
  1608.      i++;
  1609.      SKIP_SPACE;
  1610.      if(isdigit(s[i]))
  1611.        digit_seen = TRUE;
  1612.      while(isdigit(s[i])) {
  1613.        i++;
  1614.        SKIP_SPACE;
  1615.      }
  1616.    }
  1617.  
  1618.         /* no digits seen: bail out now */
  1619.    if(! digit_seen)
  1620.      return -1;
  1621.  
  1622.         /* look for exponential part.  The standard does not
  1623.            allow D, but we will, just in case. */
  1624.    if(makeupper(s[i]) == 'E' || makeupper(s[i]) == 'D') {
  1625.      i++;
  1626.      if(s[i] == '+' || s[i] == '-')
  1627.        i++;
  1628.      if(!isdigit(s[i]))
  1629.        return -1;
  1630.      while(isdigit(s[i]))
  1631.        i++;
  1632.    }
  1633.  
  1634.    return i;
  1635. }
  1636.  
  1637. PRIVATE
  1638. int
  1639. is_overlength(s)    /* checks line for having nonblanks past col 72 */
  1640.     char *s;
  1641. {
  1642.     int i,col;
  1643.     for(col=1,i=0; col<=max_stmt_col && s[i] != '\0'; i++) {
  1644.  
  1645.         if(col > 72 && !isspace(s[i]))
  1646.         return TRUE;
  1647.  
  1648.             /* Count columns taking tabs into consideration */
  1649.         if(s[i] == '\t')
  1650.         col = nxttab[col];
  1651.         else
  1652.         ++col;
  1653.     }
  1654.     return FALSE;
  1655. }
  1656.  
  1657. /* End of module Advance */
  1658.  
  1659. /*
  1660.  
  1661. III. Keywords
  1662.  
  1663. */
  1664.  
  1665. /*  keywords.c:
  1666.     Determines (to the best of its current ability) whether a given
  1667.     identifier is a keyword or not.
  1668.  
  1669.     Keywords may be used as variable names subject to the following
  1670.     limitations (see ftnchek.doc for explicit list):
  1671.  
  1672.         Use freely:
  1673.  
  1674.             any keyword with IK | NP flags
  1675.             any keyword with TY flag (data type names)
  1676.             FUNCTION
  1677.             TO
  1678.  
  1679.         Use as scalar variables only (not array, and not char
  1680.         if substring referenced):
  1681.  
  1682.             any keyword with IK flag
  1683.  
  1684.         Reserved:
  1685.  
  1686.             all others  (this is now the empty set)
  1687.  
  1688. */
  1689.  
  1690.  
  1691. #define IK 01    /* initial keyword of a statement */
  1692. #define NP 02    /* not followed by ( or = if initial */
  1693. #define MP 04    /* must be followed by ( */
  1694. #define NI 010    /* disallowed in logical IF */
  1695. #define EK 020    /* cannot be followed by another keyword */
  1696. #define TY 040    /* data type name */
  1697. #define EMPTY 256
  1698.  
  1699. struct {
  1700.     char *name;
  1701.     int class,
  1702.     context;
  1703. } keywords[]={
  1704. {"ASSIGN",    tok_ASSIGN,    IK | NP | EK},
  1705. {"ACCEPT",    tok_ACCEPT,    IK | EK},
  1706. {"BACKSPACE",    tok_BACKSPACE,    IK | EK},
  1707. {"BLOCK",    tok_BLOCK,    IK | NP | NI},
  1708. {"BLOCKDATA",    tok_BLOCKDATA,    IK | EK | NP | NI},
  1709. {"BYTE",    tok_BYTE,    IK | NI | EK | TY},
  1710. {"CALL",    tok_CALL,    IK | NP | EK},
  1711. {"CHARACTER",    tok_CHARACTER,    IK | NI | EK | TY},
  1712. {"CLOSE",    tok_CLOSE,    IK | EK | MP},
  1713. {"COMMON",    tok_COMMON,    IK | NP | NI | EK},
  1714. {"COMPLEX",    tok_COMPLEX,    IK | NI | EK | TY},
  1715. {"CONTINUE",    tok_CONTINUE,    IK | NP | EK},
  1716. {"DATA",    tok_DATA,    IK | NI | EK},
  1717. {"DIMENSION",    tok_DIMENSION,    IK | NP | NI | EK},
  1718. {"DO",        tok_DO,        IK | NP | NI},
  1719. {"DOUBLE",    tok_DOUBLE,    IK | NP | NI},
  1720. {"DOUBLEPRECISION",tok_DOUBLEPRECISION,    IK | NI | EK | TY},
  1721. {"DOWHILE",    tok_DOWHILE,    IK | NI | EK},
  1722. {"ELSE",    tok_ELSE,    IK | NP | NI},
  1723. {"ELSEIF",    tok_ELSEIF,    IK | NI | EK},
  1724. {"END",        tok_END,    IK | NP | NI},
  1725. {"ENDDO",    tok_ENDDO,    IK | NP | NI | EK},
  1726. {"ENDFILE",    tok_ENDFILE,    IK | EK},
  1727. {"ENDIF",    tok_ENDIF,    IK | NP | NI | EK},
  1728. {"ENTRY",    tok_ENTRY,    IK | NP | NI | EK},
  1729. {"EQUIVALENCE",    tok_EQUIVALENCE,IK | NI | EK | MP},
  1730. {"EXTERNAL",    tok_EXTERNAL,    IK | NP | NI | EK},
  1731. {"FILE",    tok_FILE,    IK | EK},
  1732. {"FORMAT",    tok_FORMAT,    IK | NI | EK | MP},
  1733. {"FUNCTION",    tok_FUNCTION,    NP | NI | EK},
  1734. {"GOTO",    tok_GOTO,    IK | EK},
  1735. {"GO",        tok_GO,        IK | NP},
  1736. {"IF",        tok_IF,        IK | NI | EK},
  1737. {"IMPLICIT",    tok_IMPLICIT,    IK | NP | NI},
  1738. {"INCLUDE",    tok_INCLUDE,    IK | NP | NI | EK},
  1739. {"INQUIRE",    tok_INQUIRE,    IK | EK},
  1740. {"INTEGER",    tok_INTEGER,    IK | NI | EK | TY},
  1741. {"INTRINSIC",    tok_INTRINSIC,    IK | NP | NI | EK},
  1742. {"LOGICAL",    tok_LOGICAL,    IK | NI | EK | TY},
  1743. {"NAMELIST",    tok_NAMELIST,    IK | NP | NI | EK},
  1744. {"OPEN",    tok_OPEN,    IK | EK | MP},
  1745. {"PARAMETER",    tok_PARAMETER,    IK | NI | EK | MP},
  1746. {"PAUSE",    tok_PAUSE,    IK | NP | EK},
  1747. {"PRECISION",    tok_PRECISION,    IK | NI | EK | TY},
  1748. {"PRINT",    tok_PRINT,    IK | EK},
  1749. {"PROGRAM",    tok_PROGRAM,    IK | NP | NI | EK},
  1750. {"READ",    tok_READ,    IK | EK},
  1751. {"REAL",    tok_REAL,    IK | NI | EK | TY},
  1752. {"RETURN",    tok_RETURN,    IK | EK},
  1753. {"REWIND",    tok_REWIND,    IK | EK},
  1754. {"SAVE",    tok_SAVE,    IK | NP | NI | EK},
  1755. {"STOP",    tok_STOP,    IK | NP | EK},
  1756. {"SUBROUTINE",    tok_SUBROUTINE,    IK | NP | NI | EK},
  1757. {"TO",        tok_TO,        NI | EK},
  1758. {"THEN",    tok_THEN,    IK | NP | EK},
  1759. {"TYPE",    tok_TYPE,    IK | EK},
  1760. {"WHILE",    tok_WHILE,    IK | NI | EK},
  1761. {"WRITE",    tok_WRITE,    IK | EK | MP},
  1762. {NULL,0,0},
  1763. };
  1764.  
  1765.         /* Macro to test if all the specified bits are set */
  1766. #define MATCH(Context) ((keywords[i].context & (Context)) == (Context))
  1767.  
  1768.  
  1769.     /* Returns keyword token class or 0 if not a keyword.  This
  1770.        version is able to handle those keywords which can only occur
  1771.        at the start of a statement and are never followed by ( or =
  1772.        so that they can be used as variables.
  1773.      */
  1774.  
  1775. #ifdef KEYHASHSZ
  1776. int keyhashtab[KEYHASHSZ];
  1777. #else
  1778. int keyhashtab[1000];
  1779. #endif
  1780.  
  1781. /* Start of is_keyword */
  1782. int
  1783. is_keyword(s)
  1784.     char *s;
  1785. {
  1786.     unsigned h = kwd_hash(s) % KEYHASHSZ,
  1787.          ans = FALSE,
  1788.          i = keyhashtab[h];
  1789.     if( i != EMPTY && strcmp(keywords[i].name,s) == 0) {
  1790.         while(iswhitespace(curr_char))          /* Move to lookahead char */
  1791.          advance();
  1792.  
  1793.     if(debug_lexer){
  1794.     fprintf(list_fd,
  1795.         "\nkeyword %s: initialflag=%d ",keywords[i].name,initial_flag);
  1796.     fprintf(list_fd,
  1797.         "context=%o, next char=%c %o",keywords[i].context,
  1798.                         curr_char,curr_char);
  1799.     }
  1800.  
  1801.         if( !initial_flag && MATCH(IK) ) {
  1802.             /* Dispose of names which can only occur in initial
  1803.                part of statement, if found elsewhere. */
  1804.             ans = FALSE;
  1805.         }
  1806.  
  1807.         else if( MATCH(IK|NP) ) {
  1808.             /* Here we disambiguate keywords found in initial
  1809.                part of statement: those which can only occur in
  1810.                    initial position and never followed by '(' or '='
  1811.              */
  1812.         if( (curr_char != '(') && (curr_char != '=') ) {
  1813.             ans = TRUE;
  1814.         }
  1815.         else {
  1816.             ans = FALSE;
  1817.           }
  1818.         }
  1819.  
  1820.         else if( MATCH(TY) ){
  1821.             /* Handle data type names. */
  1822.  
  1823.         if(keywords[i].class == tok_PRECISION)
  1824.         {
  1825.             ans = (prev_token_class == tok_DOUBLE);
  1826.         }
  1827.         else
  1828.         {
  1829.             if( implicit_flag )
  1830.             ans = TRUE;
  1831.             else
  1832.             ans = (initial_flag &&
  1833.                   (curr_char != '(') && (curr_char != '=') );
  1834.         }
  1835.         }
  1836.  
  1837.         else if(keywords[i].class == tok_FUNCTION) {
  1838.             /*  FUNCTION is handled as a special case.  It must
  1839.                 always be followed by a letter (variable never can)
  1840.              */
  1841.         ans = (isaletter(curr_char));
  1842.         }
  1843.  
  1844.         else if(keywords[i].class == tok_TO) {
  1845.             /* TO is another special case.  Either must follow
  1846.                GO recognized previously or be followed by a
  1847.                variable name (in ASSIGN statement).
  1848.              */
  1849.             if(prev_token_class == tok_GO)
  1850.             ans = TRUE;
  1851.         else
  1852.             ans = ( isaletter(curr_char) );
  1853.         }
  1854.  
  1855.         else if( MATCH(IK) ) {
  1856.             /*  Handle keywords which must be in initial position,
  1857.                 when found in initial position.  For the present,
  1858.                 these are semi-reserved: if used for variables,
  1859.                 must be scalar variables.  Then if used as variable
  1860.                 must be followed by '='
  1861.              */
  1862.         ans = ( curr_char != '=' );
  1863.         }
  1864.         else{
  1865.               /* For now, other keywords are reserved. */
  1866.         ans = TRUE;
  1867.         }
  1868.  
  1869.      }        /* end if(strcmp...) */
  1870.  
  1871.  
  1872.             /* Save initial token class for use by parser.
  1873.                Either set it to keyword token or to id for
  1874.                assignment stmt. */
  1875.      if(initial_flag) {
  1876.     curr_stmt_class = (ans? keywords[i].class: tok_identifier);
  1877.      }
  1878.  
  1879.         /* Turn off the initial-keyword flag if this is a
  1880.            keyword that cannot be followed by another keyword
  1881.            or if it is not a keyword.
  1882.         */
  1883.     if(ans) {
  1884.         if(keywords[i].context & EK)
  1885.             initial_flag = FALSE;
  1886.         return keywords[i].class;
  1887.     }
  1888.     else {
  1889.         initial_flag = FALSE;
  1890.         return 0;    /* Not found in list */
  1891.     }
  1892. }
  1893. /* End of is_keyword */
  1894.  
  1895.  
  1896.  
  1897. /*    init_keyhashtab.c:
  1898.                  Initializes the keyword hash table by clearing it to EMPTY
  1899.                  and then hashes all the keywords into the table.
  1900. */
  1901.  
  1902.  
  1903. void
  1904. init_keyhashtab()
  1905. {
  1906.     unsigned i,h;
  1907.  
  1908.     for(i=0;i<KEYHASHSZ;i++) {
  1909.            keyhashtab[i] = EMPTY;
  1910.     }
  1911.     for(i=0; keywords[i].name != NULL; i++) {
  1912.        h = kwd_hash(keywords[i].name) % KEYHASHSZ;
  1913.        if( keyhashtab[h] == EMPTY ) {
  1914.         keyhashtab[h] = i;
  1915.            }
  1916.        else   {    /* If there is a clash, there is a bug */
  1917. #ifdef KEYHASHSZ
  1918.         fprintf(stderr,"Oops-- Keyword hash clash at %s, %s\n",
  1919.             keywords[i].name,
  1920.             keywords[keyhashtab[h]].name);
  1921.         (void) exit(1);
  1922. #else
  1923.         ++numclashes;    /* for use in finding right key hash size */
  1924. #endif
  1925.        }
  1926.     }
  1927. }
  1928.