home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / fchk294s.zip / ftnchek-2.9.4 / forlex.c < prev    next >
C/C++ Source or Header  |  1996-05-17  |  95KB  |  3,585 lines
  1. /* forlex.c:
  2.  
  3.     Tokenizing routines for Fortran program checker.
  4.  
  5.     Copyright (C) 1993 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.  Part I. yylex()  -- gives tokens to the parser.
  12.  Part II. advance() -- bottom-level scanning of input stream.
  13.  
  14. */
  15.  
  16.     /* Declarations shared by all modules */
  17.  
  18. #include <stdio.h>
  19. #include <ctype.h>
  20. #include <string.h>
  21.  
  22. #include "ftnchek.h"
  23. #define FORLEX
  24. #include "symtab.h"
  25. #include "tokdefs.h"
  26.  
  27. /* lexdefs.h:
  28.         Macros and shared info for lexical analysis routines
  29. */
  30.  
  31. #define LEX_SHARED PRIVATE
  32.  
  33. #define EOL     '\n'    /* Character for end of line, not of statement */
  34.  
  35. extern YYSTYPE yylval;      /* Lexical value for Yacc */
  36.  
  37.  
  38.     /* Since EOS is special, need special macros for it */
  39. #define makeupper(C) (((C) != EOS && islower((int)(C)))? toupper((int)(C)):(C))
  40. #define iswhitespace(C) ( (C) != EOS && isspace((int)(C)) )
  41. #define isadigit(C)     ( (C) != EOS && isdigit((int)(C)) )
  42. #define isaletter(C)    ( (C) != EOS && isalpha((int)(C)) )
  43. #define ishex(C) ((C) != EOS && (isdigit((int)(C)) ||\
  44.             (toupper((int)(C))>='A' && toupper((int)(C))<='F') ))
  45.  
  46.     /* Define isidletter to allow underscore and/or dollar sign.
  47.        Nonstandardness is handled later. */
  48. #define isidletter(C)    ( (C) != EOS && ( isalpha((int)(C)) || \
  49.                        (C)=='_' || (C)=='$' ) )
  50.  
  51.         /* lead-in to a string: standard is ' but allow " too*/
  52. #ifdef ALLOW_QUOTEMARKS
  53. #define isaquote(C) ((C) == '\'' || (C) == '"')
  54. #else
  55. #define isaquote(C) ((C) == '\'')
  56. #endif
  57.  
  58. #define BCD(C) ((C)-'0')    /* Binary value of digit */
  59. #define HEX(C) (isdigit(C)?BCD(C):(makeupper(C)-'A'+10)) /* Hex value */
  60.  
  61.                 /* Blank-insensitive advance */
  62. #define bi_advance()    do {advance();} while(iswhitespace(curr_char))
  63.  
  64. LEX_SHARED int
  65.     inside_string,        /* TRUE when reading a string or hollerith */
  66.     inside_hollerith,    /* TRUE when reading a hollerith */
  67.     quote_char,        /* string delimiter: ' or "  */
  68.     WHILE_expected,        /* DO seen and WHILE is coming up */
  69.     contin_count,        /* Number of continuation lines of stmt */
  70.     prev_char,        /* shared between forlex.c and advance.c */
  71.     curr_char,        /* Current input character */
  72.     next_char;        /* Lookahead character */
  73.  
  74. #ifdef ALLOW_UNIX_CPP
  75. LEX_SHARED char
  76.     *next_filename;
  77. LEX_SHARED int
  78.     cpp_handled;
  79. #endif
  80.  
  81. extern int complex_const_allowed,    /* shared flags operated by fortran.y */
  82.        inside_format,
  83.        integer_context;
  84. extern int stmt_sequence_no;    /* shared with fortran.y */
  85.  
  86.  
  87.  
  88. PROTO(extern char * add_ext,( char *s, char *ext ));
  89. PROTO(extern int has_extension,( char *name, char *ext ));
  90.  
  91. PROTO(LEX_SHARED void advance,( void ));
  92. PROTO(LEX_SHARED int is_keyword,( int i ));
  93. PROTO(LEX_SHARED int looking_at_cplx,( void ));
  94. PROTO(LEX_SHARED int looking_at_keywd,( int token_class ));
  95. PROTO(LEX_SHARED int looking_at_relop,( void ));
  96.  
  97.  
  98.  
  99. LEX_SHARED
  100.  char src_text_buf[MAX_SRC_TEXT];
  101. LEX_SHARED
  102.  int src_text_len;
  103.  
  104. #ifdef DEBUG_INCLUDE
  105. LEX_SHARED
  106. int debug_include=FALSE;
  107. #endif
  108.  
  109. /*
  110.  
  111. Part I. yylex()
  112.  
  113.    Shared functions defined:
  114.     yylex()            Returns next token.  Called from yyparse().
  115.     implied_id_token(t,s)    Creates token for blank common declaration.
  116.  
  117. Note: compilation options LEX_STORE_STRINGS and LEX_STORE_HOLLERITHS:
  118.   Define the macro name LEX_STORE_STRINGS to build a version of ftnchek that
  119.   stores string constants, and LEX_STORE_HOLLERITHS to store hollerith
  120.   constants.  Now that INCLUDE statements are supported, strings must
  121.   be stored.  Holleriths are not used, so they need not be stored.
  122. */
  123. #define LEX_STORE_STRINGS
  124.  
  125. #ifdef DEVELOPMENT        /* For maintaining the program */
  126. #define LEX_STORE_HOLLERITHS
  127. #define DEBUG_FORLEX
  128. #endif
  129.  
  130. #include <math.h>
  131.  
  132.  
  133.  
  134.     /* The following macro says whether a given character is legal,
  135.      * i.e. one of the stream control chars or a valid ANSI Fortran
  136.      * character.  Lower case letters are considered legal too.
  137.      * Nondigits in columns 1-6 (except EOF,EOS) are illegal.
  138.      * Hopefully this works for EBCDIC too.
  139.      */
  140. #define islegal(C) ( ((C) == EOF) || ((C) == EOS) || \
  141.     ( (col_num >= 6 || isdigit(C)) && \
  142.      (toascii((int)(C)) >= toascii(' ') && \
  143.       toascii((int)(C)) <= toascii('z') && \
  144.       legal_chars[toascii((int)(C))-toascii(' ')] == (C))) )
  145.  
  146.         /* Array has x where ASCII character is not valid.
  147.            This defn is not standard f77, since it includes
  148.            supported extensions: $ and _ in variable names,
  149.            <> in variable formats, and " in strings.
  150.          */
  151. PRIVATE char legal_chars[]=
  152. " x\"x$xx'()*+,-./0123456789:x<=>xx\
  153. ABCDEFGHIJKLMNOPQRSTUVWXYZxxxx_xabcdefghijklmnopqrstuvwxyz";
  154.  
  155. #if 0
  156.         /* Routines to alter the default status of characters,
  157.            to support various extensions to f77. Not used now.*/
  158.  
  159. PROTO(void make_legal_char,( char *s ));
  160. PROTO(void make_illegal_char,( char *s ));
  161.  
  162. void
  163. make_legal_char(s)
  164.      char *s;            /* List of legal chars */
  165. {
  166.   int i;
  167.   while( *s != '\0' ) {
  168.     i = toascii((int)(*s));
  169.     if(i >= toascii(' ') && i <= toascii('z')) {
  170.       legal_chars[i-' '] = *s;
  171.     }
  172.     s++;
  173.   }
  174. }
  175.  
  176. void
  177. make_illegal_char(s)
  178.      char *s;            /* List of illegal chars */
  179. {
  180.   int i;
  181.   while( *s != '\0' ) {
  182.     i = toascii((int)(*s));
  183.     if(i >= toascii(' ') && i <= toascii('z')) {
  184.     legal_chars[i-toascii(' ')] = ( (*s != 'x')? 'x': 'X');
  185.     }
  186.     s++;
  187.   }
  188. }
  189. #endif
  190.  
  191.  
  192.         /* local functions defined */
  193.  
  194.  
  195. PROTO(PRIVATE void closeup,( void ));
  196.  
  197. PROTO(PRIVATE void get_binary_const,( Token *token, int c ));
  198.  
  199. PROTO(PRIVATE void get_complex_const,( Token *token ));
  200.  
  201. #ifdef ALLOW_UNIX_CPP
  202. PROTO(PRIVATE void get_cpp_directive,( void ));
  203. #endif
  204.  
  205. PROTO(PRIVATE void get_dot,( Token *token ));
  206.  
  207. PROTO(PRIVATE void get_dotted_keyword,( Token *token));
  208.  
  209. PROTO(PRIVATE void get_edit_descriptor,( Token *token ));
  210.  
  211. PROTO(PRIVATE void get_hollerith,( Token *token, int n ));
  212.  
  213. PROTO(PRIVATE void get_identifier,( Token *token ));
  214.  
  215. PROTO(PRIVATE void get_illegal_token,( Token *token ));
  216.  
  217. PROTO(PRIVATE void get_label,( Token *token ));
  218.  
  219. PROTO(PRIVATE void get_letter,( Token *token ));
  220.  
  221. PROTO(PRIVATE void get_number,( Token *token ));
  222.  
  223. PROTO(PRIVATE void get_punctuation,( Token *token ));
  224.  
  225. PROTO(PRIVATE void get_simple_punctuation,( Token *token ));
  226.  
  227. PROTO(PRIVATE void get_string,( Token *token ));
  228.  
  229.  
  230.  
  231.         /*  Gets next token for Yacc.  Return value is token.class,
  232.          *  and a copy of the token is stored in yylval.
  233.          */
  234. int
  235. yylex(VOID)
  236. {
  237.     Token token;
  238.  
  239.         /* Initialize token fields to scratch. */
  240. #if 0
  241. #ifndef TOK_type
  242.     token.TOK_type = 0;
  243. #endif
  244.     token.subclass = 0;
  245. #ifndef TOK_flags
  246.     token.TOK_flags = 0;
  247. #endif
  248.     token.value.integer = 0;
  249.     token.src_text = (char *) NULL;
  250. #else
  251. #if defined(__STDC__) || defined(VAXC)
  252.     (void)memset(&token,0,sizeof(token));
  253. #else
  254.     bzero((char *)&token,sizeof(token));
  255. #endif
  256. #endif
  257.     src_text_len = 0;
  258.  
  259.     if(curr_char == EOF) {
  260.     token.class = EOF;
  261.     token.line_num = line_num;
  262.     token.col_num = col_num;
  263.     }
  264.     else /* not EOF */ {
  265.  
  266.  
  267.         /* Skip leading spaces, and give error message if non-ANSI
  268.          * characters are found.
  269.          */
  270.  
  271.     while(iswhitespace(curr_char) || (! islegal(curr_char))  ) {
  272.       if(!iswhitespace(curr_char)) {
  273. #ifdef ALLOW_UNIX_CPP
  274.         if(curr_char == '#' && col_num == 1) {
  275.            get_cpp_directive();    /* turn # line into EOS */
  276.            break;
  277.         }
  278.         else
  279. #endif
  280.         yyerror("Illegal character");
  281.       }
  282.       advance();
  283.     }
  284.  
  285.     token.line_num = line_num;
  286.     token.col_num = col_num;
  287.  
  288.     if(inside_format) {    /* Handle format stuff here to avoid trouble */
  289.       get_edit_descriptor(&token);
  290.     }
  291.     else if(isadigit(curr_char)) {
  292.         if(col_num < 6)
  293.             get_label(&token);      /* Stmt label */
  294.         else
  295.             get_number(&token);     /* Numeric or hollerith const */
  296.     }
  297.     else if(isidletter(curr_char)) {
  298.         if(implicit_letter_flag)
  299.             get_letter(&token);    /* letter in IMPLICIT list */
  300.         else
  301.             get_identifier(&token); /* Identifier or keyword */
  302.     }
  303.     else if(isaquote(curr_char)) {
  304.             get_string(&token);    /* Quoted string */
  305.     }
  306.     else if(curr_char == '.') {
  307.             get_dot(&token);     /* '.' lead-in */
  308.     }
  309.     else {
  310.             get_punctuation(&token);  /* Punctuation character or EOS */
  311.     }
  312.     }/*end not EOF*/
  313.  
  314.     if(token.class == EOS) {
  315.     implicit_flag=FALSE;    /* in case of errors, reset flags */
  316.     implicit_letter_flag = FALSE;
  317.     }
  318.  
  319.  
  320.     prev_token_class = token.class;
  321.  
  322.     yylval = token;
  323.     return token.class;
  324.  
  325. } /* yylex */
  326.  
  327.  
  328.     /* Fills argument with token for an identifer, as if an identifer
  329.      * with name given by string s had been lexed.  This will
  330.      * be called by parser when blank common declaration is seen,
  331.      * and when a main prog without program statement is found,
  332.      * and when an unnamed block data statement is found,
  333.      * so processing of named and unnamed cases can be handled uniformly.
  334.     */
  335. void
  336. #if HAVE_STDC
  337. implied_id_token(Token *t, char *s)
  338. #else /* K&R style */
  339. implied_id_token(t,s)
  340.     Token *t;
  341.     char *s;
  342. #endif /* HAVE_STDC */
  343. {
  344.     int h;
  345.     unsigned long hnum;
  346.  
  347.     hnum = hash(s);
  348.     while( h=hnum%HASHSZ, hashtab[h].name != NULL &&
  349.         strcmp(hashtab[h].name,s) != 0)
  350.             hnum = rehash(hnum);
  351.     if(hashtab[h].name == NULL) {    /* not seen before */
  352.         hashtab[h].name = s;
  353.         hashtab[h].loc_symtab = NULL;
  354.         hashtab[h].glob_symtab = NULL;
  355.         hashtab[h].com_loc_symtab = NULL;
  356.         hashtab[h].com_glob_symtab = NULL;
  357.     }
  358.     t->class = tok_identifier;
  359.     t->value.integer = h;
  360.     t->src_text = new_src_text("",0);
  361. } /* implied_id_token */
  362.  
  363. #ifdef ALLOW_UNIX_CPP
  364.         /* This does not create a token but just performs the
  365.            actions needed when a cpp directive is seen.  It
  366.            advances curr_char to the EOS.  The setting of
  367.            filename is delayed to this point because it is not
  368.            stored in tokens but is external, so changing it
  369.            must wait till the previous statement is fully
  370.            parsed and any error messages printed and arg or
  371.            com list headers completed.
  372.          */
  373. PRIVATE void
  374. get_cpp_directive(VOID)
  375. {
  376.   if(next_filename != (char *)NULL) {
  377.     current_filename = next_filename;
  378.     if(incdepth == 0)
  379.       top_filename = next_filename;
  380.   }
  381.   do {            /* Skip to end of directive.  It will become an EOS */
  382.     advance();
  383.   } while( curr_char != EOS);
  384.  
  385.   if(f77_unix_cpp || !cpp_handled) {
  386.     nonstandard(line_num,col_num);
  387.     msg_tail(": preprocessor directive");
  388.     if(!cpp_handled)
  389.       msg_tail("(not processed)");
  390.   }
  391. }/*get_cpp_directive*/
  392. #endif
  393.  
  394. PRIVATE void
  395. #if HAVE_STDC
  396. get_dot(Token *token)
  397. #else /* K&R style */
  398. get_dot(token)
  399.     Token *token;
  400. #endif /* HAVE_STDC */
  401. {
  402.     if(src_text_len < MAX_SRC_TEXT)
  403.       src_text_buf[src_text_len++] = curr_char;
  404.  
  405.     closeup();        /* Advance till nonspace char in next_char */
  406.  
  407.     if(isadigit(next_char))
  408.         get_number(token);        /* Numeric const */
  409.     else if(isaletter(next_char))
  410.         get_dotted_keyword(token);    /* .EQ. etc. */
  411.     else
  412.         get_simple_punctuation(token);    /* "." out of place */
  413. }
  414.  
  415.  
  416. PRIVATE struct {
  417.     char *name;
  418.     int class,subclass;
  419.  } dotted_keywords[]={
  420.             {".EQ.",tok_relop,relop_EQ},
  421.             {".NE.",tok_relop,relop_NE},
  422.             {".LE.",tok_relop,relop_LE},
  423.             {".LT.",tok_relop,relop_LT},
  424.             {".GE.",tok_relop,relop_GE},
  425.             {".GT.",tok_relop,relop_GT},
  426.             {".AND.",tok_AND,0},
  427.             {".OR.",tok_OR,0},
  428.             {".NOT.",tok_NOT,0},
  429.             {".FALSE.",tok_logical_const,FALSE},
  430.             {".TRUE.",tok_logical_const,TRUE},
  431.             {".EQV.",tok_EQV,0},
  432.             {".NEQV.",tok_NEQV,0},
  433.             {NULL,0,0}
  434.             };
  435.  
  436.  
  437. PRIVATE void
  438. #if HAVE_STDC
  439. get_dotted_keyword(Token *token)
  440. #else /* K&R style */
  441. get_dotted_keyword(token)
  442.     Token *token;
  443. #endif /* HAVE_STDC */
  444. {
  445.     int i=0,
  446.         has_embedded_space,    /* Spaces inside keyword */
  447.         space_seen_lately;    /* Flag for catching embedded space */
  448.     initial_flag = FALSE;
  449.                 /* Watch for embedded space, but not
  450.                    between dots and letters of keyword.
  451.                    I.e.  ". eq ." is OK, but not ".e q." */
  452.     has_embedded_space = FALSE;
  453.     space_seen_lately = FALSE;
  454.  
  455.     bi_advance();      /* gobble the initial '.' */
  456.  
  457.     while(isaletter(curr_char)) {
  458.  
  459.        if(src_text_len < MAX_SRC_TEXT)
  460.          src_text_buf[src_text_len++] = (char)makeupper(curr_char);
  461.  
  462.       if(space_seen_lately)
  463.         has_embedded_space = TRUE;
  464.  
  465.        bi_advance();
  466.  
  467.        space_seen_lately = iswhitespace(prev_char);
  468.     }
  469.  
  470.     if(src_text_len < MAX_SRC_TEXT)
  471.       src_text_buf[src_text_len++] = '.'; /* make it complete */
  472.  
  473.     if(curr_char != '.') {
  474.         yyerror("Badly formed logical/relational operator or constant");
  475.     }
  476.     else {
  477.         advance();      /* gobble the final '.' */
  478.     }
  479.     if(pretty_extra_space && has_embedded_space) {
  480.           ugly_code(token->line_num,token->col_num,
  481.             "keyword has embedded space");
  482.     }
  483.  
  484.     for(i=0; dotted_keywords[i].name != NULL; i++) {
  485.       if(strncmp(src_text_buf+1, /* only compare the significant parts */
  486.              dotted_keywords[i].name+1,
  487.              src_text_len-2) == 0) {
  488.         token->class = dotted_keywords[i].class;
  489.         token->subclass = dotted_keywords[i].subclass;
  490.         token->value.string = token->src_text = dotted_keywords[i].name;
  491. #ifdef DEBUG_FORLEX
  492.             if(debug_lexer)
  493.                (void)fprintf(list_fd,"\nDotted keyword:\t\t%s",
  494.                         token->src_text);
  495. #endif
  496.             return;
  497.         }
  498.     }
  499.             /* Match not found: signal an error */
  500.     yyerror("Unknown logical/relational operator or constant");
  501.     get_illegal_token(token);
  502.  
  503. } /* get_dotted_keyword */
  504.  
  505. PRIVATE void
  506. #if HAVE_STDC
  507. get_edit_descriptor(Token *token)
  508. #else /* K&R style */
  509. get_edit_descriptor(token)
  510.     Token *token;
  511. #endif /* HAVE_STDC */
  512. {
  513.     int c;
  514.     long repeat_spec;
  515.  
  516.     if(isadigit(curr_char)) {    /* Digit: repeat spec or holl or kP or nX */
  517.       repeat_spec = 0;
  518.       do {
  519.     if(src_text_len < MAX_SRC_TEXT)
  520.       src_text_buf[src_text_len++] = curr_char;
  521.     repeat_spec = repeat_spec*10L + (long)BCD(curr_char);
  522.     if( makeupper(next_char) == 'H' )
  523.       inside_hollerith = TRUE;/* get ready for hollerith*/
  524.     bi_advance();
  525.       } while(isadigit(curr_char));
  526.  
  527.       if( makeupper(curr_char) == 'H' ) {
  528.                 /* nH... pass off to hollerith routine */
  529.     get_hollerith(token, (int)repeat_spec);
  530.     return;
  531.       }
  532.       else {
  533.                 /* Otherwise it is a repeat spec or the
  534.                    numeric part of kP or nX which we treat
  535.                    as repeat specs too */
  536.     token->class = tok_integer_const;
  537.     token->value.integer = repeat_spec;
  538.     token->src_text = new_src_text(src_text_buf,src_text_len);
  539. #ifdef DEBUG_FORLEX
  540. if(debug_lexer)
  541. (void)fprintf(list_fd,"\nInteger const:\t\t%d (from %s)",
  542.           repeat_spec,
  543.               token->src_text);
  544. #endif
  545.       }
  546.     }/* end if digit */
  547.  
  548.     else if(isaletter(curr_char)) {
  549.       c = makeupper(curr_char);
  550.       if(src_text_len < MAX_SRC_TEXT)
  551.     src_text_buf[src_text_len++] = c;
  552.       bi_advance();
  553.       switch(c) {
  554.  
  555.     case 'P':        /* P of kP  k seen previously */
  556.       if(prev_token_class != tok_integer_const) {
  557.         if(f77_format_extensions){
  558.           nonstandard(token->line_num,token->col_num);
  559.           msg_tail(": P must follow a number");
  560.         }
  561.       }
  562.       break;
  563.  
  564.     case 'X':        /* X or nX */
  565.       break;
  566.  
  567.     case 'S':        /* S or SP or SS */
  568.       c = makeupper(curr_char);
  569.       if(c == 'S' || c == 'P') {
  570.         if(src_text_len < MAX_SRC_TEXT)
  571.           src_text_buf[src_text_len++] = c;
  572.         bi_advance();
  573.       }
  574.       break;
  575.  
  576.     case 'B':        /* BN or BZ */
  577.       c = makeupper(curr_char);
  578.       if(c == 'N' || c == 'Z') {
  579.         if(src_text_len < MAX_SRC_TEXT)
  580.           src_text_buf[src_text_len++] = c;
  581.         bi_advance();
  582.       }
  583.       else {
  584.         if(f77_format_extensions){
  585.           nonstandard(token->line_num,token->col_num);
  586.           msg_tail(": N or Z expected after B");
  587.         }
  588.       }
  589.       break;
  590.  
  591.     case 'T':        /* Tc or TLc or TRc */
  592.       c = makeupper(curr_char);
  593.       if(c == 'L' || c == 'R') {
  594.         if(src_text_len < MAX_SRC_TEXT)
  595.           src_text_buf[src_text_len++] = c;
  596.         bi_advance();
  597.       }
  598.       goto get_w_d;
  599.                 /* Iw, Ew.c and similar forms */
  600.     case 'A':    case 'D':    case 'E':
  601.     case 'F':    case 'G':    case 'L':
  602.     case 'I':
  603. get_w_d:                /* Get the w field if any */
  604.       while( isadigit(curr_char) ){
  605.         if(src_text_len < MAX_SRC_TEXT)
  606.           src_text_buf[src_text_len++] = curr_char;
  607.         bi_advance();
  608.       }
  609.             /* Include any dot followed by number (e.g. F10.5)
  610.             */
  611.       if( curr_char == '.' ) {
  612.         do {
  613.           if(src_text_len < MAX_SRC_TEXT)
  614.         src_text_buf[src_text_len++] = curr_char;
  615.           bi_advance();
  616.         } while( isadigit(curr_char) );
  617.       }
  618.       break;
  619.  
  620.     default:
  621.       if(f77_format_extensions) {
  622.         nonstandard(token->line_num,token->col_num);
  623.         msg_tail(": edit descriptor");
  624.         src_text_buf[src_text_len++] = '\0';
  625.         msg_tail(src_text_buf);
  626.       }
  627.       goto get_w_d;
  628.       }/*end switch*/
  629.  
  630.       token->class = tok_edit_descriptor;
  631.       token->value.string = NULL;
  632.       token->src_text = new_src_text(src_text_buf,src_text_len);
  633.  
  634. #ifdef DEBUG_FORLEX
  635. if(debug_lexer)
  636. (void)fprintf(list_fd,"\nEdit descriptor:\t%s",token->src_text);
  637. #endif
  638.     }/*end else if isaletter*/
  639.  
  640.             /* Apostrophe or quote mark means a string. */
  641.     else if( isaquote(curr_char) ) {
  642.       get_string(token);
  643.     }
  644.                 /* Otherwise it is mere punctuation. Handle
  645.                    it here ourself to avoid complications. */
  646.     else {
  647.       src_text_buf[src_text_len++] = curr_char;
  648.       get_simple_punctuation(token);
  649.     }
  650. }
  651.  
  652. PRIVATE void
  653. #if HAVE_STDC
  654. get_hollerith(Token *token, int n)  /* Gets string of form nHaaaa */
  655. #else /* K&R style */
  656. get_hollerith(token,n)  /* Gets string of form nHaaaa */
  657.     Token *token;
  658.     int n;
  659. #endif /* HAVE_STDC */
  660. {
  661.     int i, last_col_num, last_line_num;
  662.  
  663.         /* strsize = length of only the string being defined
  664.            fullsize = length of whole hollerith const, which includes
  665.            length spec already stored in src_text_buf plus the
  666.            H plus the text plus final nul. */
  667.     int strsize=n,
  668.         leadin=src_text_len+1,
  669.         fullsize=leadin+strsize+1;
  670.     char *s;
  671.  
  672.     initial_flag = FALSE;
  673.  
  674.     s = new_src_text_alloc(fullsize);
  675.  
  676.     for(i=0; i<src_text_len; i++) /* Copy the leadin already saved */
  677.       s[i] = src_text_buf[i];
  678.     s[i++] = 'H';        /* store the 'H' */
  679.  
  680.     if(n==1)
  681.       inside_hollerith=FALSE;/* turn off flag ahead of next_char */
  682.     advance();/* Gobble the 'H' */
  683.  
  684.     last_col_num = col_num;
  685.     last_line_num = line_num;
  686.  
  687.     for(i=0; i<n; i++) {
  688.       while(curr_char == EOL) {
  689.             /* Treat short line as if extended with blanks */
  690.         int col;
  691.         for(col=last_col_num; i<n && col<max_stmt_col; i++,col++) {
  692.         s[leadin+i] = ' ';
  693.         }
  694.         last_col_num = col_num;
  695.         advance();
  696.       }
  697.       if(i==n) break;
  698.  
  699.       if(curr_char == EOS || curr_char == EOF) {
  700.         int col;
  701.         for(col=last_col_num; i<n && col<max_stmt_col; i++,col++) {
  702.           if(i < strsize)
  703.         s[leadin+i] = ' ';
  704.         }
  705.         if(i < n) {        /* If it did not fill up */
  706.           syntax_error((unsigned)last_line_num,(unsigned)last_col_num,
  707.                "Hollerith constant ends prematurely");
  708.           strsize=i;
  709.         }
  710.         break;
  711.       }
  712.       else {
  713.         s[leadin+i] = curr_char;
  714.         last_col_num = col_num;
  715.         last_line_num = line_num;
  716.         if(i==n-2)/* turn flag off ahead of next_char*/
  717.           inside_hollerith = FALSE;
  718.         advance();
  719.       }
  720.     }
  721.  
  722.     if(strsize > 0)
  723.       s[leadin+strsize] = '\0';
  724.  
  725.     inside_hollerith = FALSE;
  726.     token->class = tok_hollerith;
  727.     token->value.string = s + leadin;
  728.     token->size = n;
  729.     token->src_text = s;
  730. #ifdef DEBUG_FORLEX
  731.     if(debug_lexer)
  732.         (void)fprintf(list_fd,"\nHollerith:\t\t%s (from %s)",
  733.                   token->value.string,
  734.                   token->src_text);
  735. #endif
  736.  
  737. } /* get_hollerith */
  738.  
  739. #include "keywords.h"
  740.  
  741.     /* get_identifier reads a string of characters satisfying
  742.        isidletter.  As they are read and as long as they are
  743.        alphabetic, it looks for a match to a keyword, and
  744.        whenever one is found, checks with is_keyword to see
  745.        if the context is right.  If so, it returns the keyword.
  746.        Otherwise it keeps going and eventually returns the id.
  747.      */
  748. PRIVATE void
  749. #if HAVE_STDC
  750. get_identifier(Token *token)
  751. #else /* K&R style */
  752. get_identifier(token)
  753.     Token *token;
  754. #endif /* HAVE_STDC */
  755. {
  756.     int c,        /* Uppercase version of current letter */
  757.         preceding_c,/* Char preceding latest id */
  758.         has_embedded_space,    /* Spaces inside keyword or id */
  759.         space_seen_lately,    /* Flag for catching embedded space */
  760.         lo,hi,    /* Indices in keyword table where match may be */
  761.         klen,    /* Length of id read so far (after keyword test) */
  762.         keywd_class;/* Class number returned by is_keyword */
  763.     int possible_keyword;
  764.  
  765.     token->class = tok_identifier;
  766.     keywd_class = FALSE;
  767.  
  768.     klen = 0;
  769.     lo = 0;
  770.     hi = NUM_KEYWORDS-1;
  771.  
  772.     /* Define shorthand for the keyword letter under study */
  773. #define KN(i) keywords[i].name
  774. #define KL(i) keywords[i].name[klen]
  775.  
  776.     possible_keyword = TRUE;
  777.     preceding_c = prev_char;
  778.     has_embedded_space = FALSE;
  779.     space_seen_lately = FALSE;
  780.  
  781.             /* This loop gets  letter [letter|digit]* forms */
  782.     while(isidletter(curr_char) || isadigit(curr_char)) {
  783.       c = makeupper(curr_char); /* Get the next char of id */
  784.       if(src_text_len < MAX_SRC_TEXT)
  785.         src_text_buf[src_text_len++] = (int)makeupper(curr_char);
  786.  
  787.       if(space_seen_lately)
  788.         has_embedded_space = TRUE;
  789.  
  790.       bi_advance();        /* Pull in the next character */
  791.  
  792.       space_seen_lately = iswhitespace(prev_char);
  793.  
  794.                 /* As long as it may yet be a keyword,
  795.                    keep track of whether to invoke is_keyword.
  796.                  */
  797.       if(possible_keyword) {
  798.  
  799.         if(!isaletter(c)    /* If not alphabetic, cannot be keyword */
  800.            || klen >= sizeof(keywords[0].name)-1) /* or overlength */
  801.         {
  802. #ifdef DEBUG_IS_KEYWORD
  803. if(debug_lexer && getenv("BISECTION")) {
  804. src_text_buf[src_text_len] = '\0';
  805. (void)fprintf(list_fd,"\n%s not a keyword because",src_text_buf);
  806. if(!isaletter(c))
  807.   (void)fprintf(list_fd," non-letter at %c",c);
  808. if(klen >= sizeof(keywords[0].name)-1)
  809.   (void)fprintf(list_fd,"length %d >= max %d",klen,sizeof(keywords[0].name)-1);
  810. }
  811. #endif
  812.           possible_keyword = FALSE;
  813.         }
  814.         else {
  815.           int mid;
  816. #ifdef DEBUG_IS_KEYWORD
  817. if(debug_lexer && getenv("BISECTION")) {
  818. (void)fprintf(list_fd,"\nklen=%d c=%c",klen,c);
  819. (void)fprintf(list_fd,"\nBisecting [lo,hi]=[%d,%d] \"%s\"..\"%s\"",
  820.        lo,hi,KN(lo),KN(hi));
  821. }
  822. #endif
  823.                 /* Bisect lo .. hi looking for match
  824.                    on characters found so far. */
  825.           while(lo <= hi) {
  826.         mid = (lo + hi)/2;
  827.         if( KL(mid) < c ) {    /* No match in lower half */
  828.           lo = mid+1;
  829.         }
  830.         else if( KL(mid) > c ) {/* No match in upper half */
  831.           hi = mid-1;
  832.         }
  833.         else {        /* Match at midpoint: Bisect each
  834.                    half to find the new subinterval. */
  835.           int midlo=mid, midhi=mid;
  836.                 /* Bisect lo .. mid */
  837.           while( lo < midlo-1 &&  KL(lo) != c) {
  838.             mid = (lo + midlo)/2;
  839.             if(  KL(mid) < c ) {
  840.               lo = mid+1;
  841.             }
  842.             else {    /* equal */
  843.               midlo = mid;
  844.             }
  845.           }
  846.           if( KL(lo) != c )
  847.             lo = midlo;
  848.                 /* Bisect mid .. hi */
  849.           while( midhi < hi-1 && KL(hi) != c ) {
  850.             mid = (midhi + hi)/2;
  851.             if( KL(mid) > c ) {
  852.               hi = mid-1;
  853.             }
  854.             else {    /* equal */
  855.               midhi = mid;
  856.             }
  857.           }
  858.           if( KL(hi) != c )
  859.             hi = midhi;
  860.  
  861.           break;    /* After bisecting each half, we are done */
  862.         }        /* end else KL(mid) == c */
  863.           }            /* end while(lo <= hi) */
  864.  
  865.           klen++;        /* Now increment the length */
  866.  
  867. #ifdef DEBUG_IS_KEYWORD
  868. if(debug_lexer && getenv("BISECTION")) {
  869. (void)fprintf(list_fd,"\nNew [lo,hi]=[%d,%d] \"%s\"..\"%s\"",
  870.        lo,hi,KN(lo),KN(hi));
  871. }
  872. #endif
  873.             /* If range is null, a match has been ruled out. */
  874.           if(lo > hi) {
  875. #ifdef DEBUG_IS_KEYWORD
  876. if(debug_lexer && getenv("BISECTION")) {
  877. src_text_buf[src_text_len] = '\0';
  878. (void)fprintf(list_fd,"\nKeyword ruled out for %s at length %d since lo %d > hi %d",
  879.        src_text_buf,klen,lo,hi);
  880. }
  881. #endif
  882.         possible_keyword = FALSE;
  883.           }
  884.             /* If length of first keyword in range is equal
  885.                to the new length, then we have a match at
  886.                this point.  Check it out with is_keyword.
  887.              */
  888.           else if(KN(lo)[klen] == '\0') {
  889.         if( (keywd_class = is_keyword(lo)) != FALSE) {
  890.           token->class = keywd_class;    /* It's a keyword */
  891.           token->value.string = NULL;
  892.           token->src_text = KN(lo);
  893.           break;    /* Quit the input loop */
  894.         }
  895.         else if(lo == hi) {    /* Match is unique and ruled out */
  896.           possible_keyword = FALSE;
  897.         }
  898.           }
  899.         }/* end else isaletter(c) */
  900.       }/* end if(possible_keyword) */
  901.     }/* end while(isidletter || isadigit) */
  902.  
  903.     if(keywd_class == FALSE) {        /* it is an identifier */
  904.  
  905.                 /* Identifier: find its hashtable entry or
  906.                    create a new entry.    */
  907.             int h;
  908.             Lsymtab *symt;
  909. #ifdef ALLOW_TYPELESS_CONSTANTS
  910.                 /* Watch out for const like X'nnn' */
  911.             if(src_text_len == 1 && isaquote(curr_char)) {
  912.                 /* Read the string, append the trailing quote
  913.                    then invoke routine to interpret it. */
  914.               get_string(token);
  915. #ifndef LEX_RAWSTRINGS
  916.               if(src_text_len < MAX_SRC_TEXT)
  917.             src_text_buf[src_text_len++] = quote_char;
  918. #endif
  919.               get_binary_const(token,src_text_buf[0]);
  920.               return;
  921.             }
  922. #endif
  923.  
  924.             if(src_text_len < MAX_SRC_TEXT)
  925.               src_text_buf[src_text_len] = '\0';
  926.             token->value.integer = h = hash_lookup(src_text_buf);
  927.             token->src_text = hashtab[h].name;
  928.                 /* If it is an array give it a special token
  929.                    class, so that arrays can be distinguished
  930.                    from functions in the grammar. */
  931.             if((symt=hashtab[h].loc_symtab) != NULL
  932.                && symt->array_var) {
  933.               token->class = tok_array_identifier;
  934.  
  935.       }
  936.     }
  937.                 /* Check identifiers for being juxtaposed
  938.                    to keywords or having internal space.
  939.                    Keywords are immune to warning since
  940.                    want to allow both GOTO and GO TO, etc.
  941.                  */
  942.  
  943.  
  944.     if((token->class==tok_identifier || token->class==tok_array_identifier)
  945.        && ( (pretty_no_space &&
  946.          (isidletter(preceding_c) || isadigit(preceding_c)))
  947.            || (pretty_extra_space && has_embedded_space) ) ) {
  948.  
  949.           ugly_code(token->line_num,token->col_num,"identifier");
  950.           msg_tail(hashtab[token->value.integer].name);
  951. #if 0    /* Keywords immune for now */
  952.           ugly_code(token->line_num,token->col_num,"keyword");
  953.           msg_tail(keywords[keytab_index[keywd_class-keytab_offset]].name);
  954. #endif
  955.       if(has_embedded_space)
  956.         msg_tail("has embedded space");
  957.       else
  958.         msg_tail("not clearly separated from context");
  959.     }
  960.  
  961. #ifdef DEBUG_FORLEX
  962.     if(debug_lexer){
  963.         switch(token->class) {
  964.         case tok_identifier:
  965.             (void)fprintf(list_fd,"\nIdentifier:\t\t%s",
  966.                       token->src_text);
  967.             break;
  968.         case tok_array_identifier:
  969.             (void)fprintf(list_fd,"\nArray_identifier:\t%s",
  970.                       token->src_text);
  971.             break;
  972.         default:
  973.             (void)fprintf(list_fd,"\nKeyword:\t\ttok_%s",
  974.                       token->src_text);
  975.             break;
  976.         }
  977.     }
  978. #endif
  979. } /* get_identifier */
  980.  
  981. /*  iskeyword:
  982.     Determines (to the best of its current ability) whether a given
  983.     identifier is a keyword or not.  Hopefully now no keywords are
  984.     reserved.
  985.  
  986.     Method uses context from start of statement up to and including
  987.     the character following the putative keyword to eliminate as
  988.     many cases as possible.  Any non-IK keywords (those that need not
  989.     be in the initial series of keywords of statement) have special
  990.     code to handle them.  Any IK's that are always the second word of a
  991.     pair are accepted if the predecessor was just seen.  The rest are
  992.     handed off to looking_at_keywd which tries to see if
  993.     it is an assignment statement.
  994.  
  995.     Note that some rules that could be used if F77 Standard were
  996.     adhered to strictly are not used here.  The idea is to allow
  997.     extensions, and leave catching syntax errors in the parser.
  998.     For example, specification-statement keywords are not excluded
  999.     after the first executable statement has been seen.  The status
  1000.     of a variable as declared array or character type is not consulted
  1001.     in ruling out an assignment statement if following parentheses
  1002.     are present.  Etc.
  1003. */
  1004.  
  1005.  
  1006.         /* Macro to test if all the specified bits are set */
  1007. #define MATCH(CONTEXT) ((keywords[i].context & (CONTEXT)) == (CONTEXT))
  1008.  
  1009.  
  1010. LEX_SHARED int
  1011. #if HAVE_STDC
  1012. is_keyword(int i)
  1013.                        /* Index in keywords table */
  1014. #else /* K&R style */
  1015. is_keyword(i)
  1016.      int i;            /* Index in keywords table */
  1017. #endif /* HAVE_STDC */
  1018. {
  1019.   int ans = FALSE;
  1020.   int putative_keyword_class;    /* Class of the supposed keyword */
  1021.   extern int stmt_sequence_no;    /* set by parser */
  1022.  
  1023.   while(iswhitespace(curr_char))          /* Move to lookahead char */
  1024.     advance();
  1025.  
  1026. #ifdef DEBUG_IS_KEYWORD
  1027.   if(debug_lexer){
  1028.     (void)fprintf(list_fd,
  1029.         "\nkeyword %s: initialflag=%d implicitflag=%d ",
  1030.         keywords[i].name,initial_flag,implicit_flag);
  1031.     (void)fprintf(list_fd,
  1032.         "context=%o, next char=%c %o",keywords[i].context,
  1033.                         curr_char,curr_char);
  1034.   }
  1035. #endif
  1036.  
  1037.   putative_keyword_class = keywords[i].class;
  1038.  
  1039.   if( !initial_flag && MATCH(IK) ) {
  1040.             /* Dispose of keywords which can only occur in initial
  1041.                part of statement, if found elsewhere. */
  1042.     ans = FALSE;
  1043.   }
  1044.  
  1045. #if 0 /* This does not work: curr_stmt_class not cleared beforehand */
  1046.   else if(curr_stmt_class == tok_IF && MATCH(NI)) {
  1047.             /* Dispose of keywords which cannot occur in stmt
  1048.                field of logical IF if that is where we are.
  1049.              */
  1050.     ans = FALSE;
  1051.   }
  1052. #endif
  1053.  
  1054.   else if(MATCH(NA) && isalpha(curr_char)) {
  1055.             /* Dispose of keywords which cannot be followed
  1056.                by alphabetic character if that is so.
  1057.  
  1058.                Handle variant unparenthesized PARAMETER stmt.
  1059.                Reject if it follows a stmt fun or executable stmt.
  1060.              */
  1061.     if(putative_keyword_class != tok_PARAMETER
  1062.        || stmt_sequence_no > SEQ_SPECIF) {
  1063.       ans = FALSE;
  1064.     }
  1065.     else {          /* non-paren form _should_ look like an assignment */
  1066.       ans = ! looking_at_keywd(putative_keyword_class);
  1067.     }
  1068.   }
  1069.  
  1070.   else if(putative_keyword_class == tok_TO) {/* A non-IK case */
  1071.                 /* TO always follows the word GO or
  1072.                    is followed by a variable
  1073.                    name (in ASSIGN statement).
  1074.                  */
  1075. #ifdef SPLIT_KEYWORDS
  1076.  
  1077. #define in_assign_stmt (curr_stmt_class == tok_ASSIGN)
  1078.     ans = (prev_token_class == (in_assign_stmt?
  1079.                   tok_integer_const:
  1080.                   tok_GO));
  1081. #else
  1082.     ans = ( curr_stmt_class == tok_ASSIGN
  1083.        && prev_token_class == tok_integer_const);
  1084. #endif
  1085.   }
  1086.   else if(putative_keyword_class == tok_FUNCTION /* A non-IK case */
  1087.     && (stmt_sequence_no != 0 /* not the first statement of module */
  1088.  
  1089.     || !(initial_flag  /* if not initial can only be preceded by type */
  1090.          || is_a_type_token(curr_stmt_class)) )) {
  1091.     ans = FALSE; /* otherwise it will be handled correctly by looking_at */
  1092.   }
  1093.   else if(putative_keyword_class == tok_WHILE) { /* A non-IK case */
  1094.     ans = WHILE_expected; /* Only occurs in DO label [,] WHILE */
  1095.     WHILE_expected = FALSE;
  1096.   }
  1097.         /* Remaining cases are IK in initial part */
  1098.  
  1099.             /*   Eliminate those which can never be followed
  1100.                  by '(' or '=' if that is what we have.
  1101.              */
  1102.   else if(MATCH(NP) &&
  1103.       (curr_char == '(' || curr_char == '=') ) {
  1104.     ans = FALSE;
  1105.   }
  1106.  
  1107.             /* Likewise with those that must be followed by
  1108.                '(' but aren't  */
  1109.   else if(MATCH(MP) && curr_char != '(') {
  1110.     ans = FALSE;
  1111.   }
  1112.  
  1113.                 /* PRECISION always follows the word DOUBLE */
  1114.   else if( putative_keyword_class == tok_PRECISION ){
  1115.     ans = (prev_token_class == tok_DOUBLE);
  1116.   }
  1117.  
  1118.                 /* END DO: handle its DO here */
  1119.   else if( putative_keyword_class == tok_DO && curr_char == EOS ) {
  1120.     /* Also must have prev_token_class == tok_END, but
  1121.        no need to check since end-of-statement suffices. */
  1122.     ans = TRUE;
  1123.   }
  1124.  
  1125.  
  1126.                 /* Other type names always follow the word
  1127.                    IMPLICIT */
  1128.   else if( implicit_flag ) {
  1129.     ans =  MATCH(TY);
  1130.   }
  1131.  
  1132.   else {
  1133.              /* Remaining cases are keywords that must be in
  1134.             initial position. If followed by '=' must be an
  1135.             identifier.  If followed by '(' then may be an array
  1136.             or character lvalue, so use looking_at to scan ahead
  1137.             to see if this is an assignment statement. */
  1138.       ans =  looking_at_keywd(putative_keyword_class);
  1139.   }
  1140.  
  1141.  
  1142.             /* Save initial token class for use by parser.
  1143.                Either set it to keyword token or to id for
  1144.                assignment stmt. */
  1145.   if(initial_flag) {
  1146.     curr_stmt_class = (ans? keywords[i].class: tok_identifier);
  1147.   }
  1148.  
  1149.         /* Turn off the initial-keyword flag if this is a
  1150.            keyword that cannot be followed by another keyword
  1151.            or if it is not a keyword.
  1152.         */
  1153.   if(ans) {
  1154.     if(keywords[i].context & EK)
  1155.       initial_flag = FALSE;
  1156.     return keywords[i].class;
  1157.   }
  1158.   else {    /* If no more letters follow, then keyword here
  1159.            is ruled out.  Turn off initial_flag. */
  1160.     if( ! isalpha(curr_char) )
  1161.       initial_flag = FALSE;
  1162.     return 0;    /* Not found in list */
  1163.   }
  1164. }/* End of is_keyword */
  1165.  
  1166.  
  1167. /*    init_keyhashtab:
  1168. */
  1169.         /* Hashing is no longer used.  This guy now only
  1170.            initializes the table of indices that allow
  1171.            keywords to be looked up by their token class*/
  1172. void
  1173. init_keyhashtab(VOID)
  1174. {
  1175.   int i,k,kmin,kmax;
  1176.   kmin = kmax = keywords[0].class;    /* Find min and max token classes */
  1177.   for(i=1; i<NUM_KEYWORDS; i++) {
  1178.     k = keywords[i].class;
  1179.     if(k < kmin)  kmin = k;
  1180.     if(k > kmax)  kmax = k;
  1181.   }
  1182.  
  1183.   keytab_offset = kmin;    /* Index table from [kmin..kmax] -> [0..size-1] */
  1184.   keytab_size = (unsigned) (kmax-kmin+1);
  1185.   if( (keytab_index=(short *)calloc(keytab_size,sizeof(keytab_index[0])))
  1186.      == (short *)NULL) {
  1187.     oops_message(OOPS_FATAL,NO_LINE_NUM,NO_COL_NUM,
  1188.        "cannot allocate space for keytab_index");
  1189.   }
  1190.  
  1191.                 /* Now fill in the lookup table, indexed
  1192.                    by class - offset */
  1193.   for(i=0; i<NUM_KEYWORDS; i++) {
  1194.     k = keywords[i].class;
  1195.     keytab_index[k - keytab_offset] = i;
  1196.   }
  1197. }
  1198.  
  1199.  
  1200. PRIVATE void
  1201. #if HAVE_STDC
  1202. get_illegal_token(Token *token)    /* Handle an illegal input situation */
  1203. #else /* K&R style */
  1204. get_illegal_token(token)    /* Handle an illegal input situation */
  1205.     Token *token;
  1206. #endif /* HAVE_STDC */
  1207. {
  1208.     token->class = tok_illegal;
  1209.     token->src_text = new_src_text("",0);
  1210. #ifdef DEBUG_FORLEX
  1211.     if(debug_lexer)
  1212.          (void)fprintf(list_fd,"\nILLEGAL TOKEN");
  1213. #endif
  1214.  
  1215. } /* get_illegal_token */
  1216.  
  1217.  
  1218.  
  1219.         /* Read a label from label field. */
  1220. PRIVATE void
  1221. #if HAVE_STDC
  1222. get_label(Token *token)
  1223. #else /* K&R style */
  1224. get_label(token)
  1225.     Token *token;
  1226. #endif /* HAVE_STDC */
  1227. {
  1228.     int value=0;
  1229.     int space_seen=FALSE, has_embedded_space=FALSE;
  1230.     while( isadigit(curr_char) && col_num < 6 ) {
  1231.       if(space_seen)
  1232.         has_embedded_space = TRUE;
  1233.       value = value*10 + BCD(curr_char);
  1234.       src_text_buf[src_text_len++] = curr_char;
  1235.       advance();
  1236.       while(curr_char==' ' && col_num < 6) {
  1237.         space_seen = TRUE;
  1238.         advance();
  1239.       }
  1240.     }
  1241.     if(pretty_extra_space && has_embedded_space) {
  1242.           ugly_code(token->line_num,token->col_num,
  1243.             "label has embedded space");
  1244.     }
  1245.     token->class = tok_label;
  1246.     token->value.integer = value;
  1247.     token->src_text = new_src_text(src_text_buf,src_text_len);
  1248. #ifdef DEBUG_FORLEX
  1249.     if(debug_lexer)
  1250.         (void)fprintf(list_fd,"\nLabel:\t\t\t%d (from %s)",
  1251.                   value,
  1252.                   token->src_text);
  1253. #endif
  1254.  
  1255. } /* get_label */
  1256.  
  1257.  
  1258. PRIVATE void
  1259. #if HAVE_STDC
  1260. get_letter(Token *token)        /* Gets letter in IMPLICIT list */
  1261. #else /* K&R style */
  1262. get_letter(token)        /* Gets letter in IMPLICIT list */
  1263.     Token *token;
  1264. #endif /* HAVE_STDC */
  1265. {
  1266.     token->class = tok_letter;
  1267.     src_text_buf[src_text_len++] = 
  1268.       token->subclass = makeupper(curr_char);
  1269.     token->src_text = new_src_text(src_text_buf,src_text_len);
  1270.  
  1271. #ifdef DEBUG_FORLEX
  1272.     if(debug_lexer)
  1273.     (void)fprintf(list_fd,"\nLetter:\t\t\t%s",token->src_text);
  1274. #endif
  1275.  
  1276.     advance();
  1277.  
  1278. } /* get_letter */
  1279.  
  1280.  
  1281.     /* get_number reads a number and determines data type: integer,
  1282.      * real, or double precision.
  1283.      */
  1284. /* This belongs in ftnchek.h, perhaps.  Defines number of significant
  1285.    figures that are reasonable for a single-precision real constant.
  1286.    Works out to 9 for wordsize=4, 21 for wordsize=8. These allow
  1287.    for a couple of extra digits for rounding. Used in -trunc warning. */
  1288. #define REAL_SIGFIGS (local_wordsize==0? 8: (local_wordsize-1)*3)
  1289.  
  1290. PRIVATE int getting_complex_const=FALSE;
  1291.  
  1292. PRIVATE void
  1293. #if HAVE_STDC
  1294. get_number(Token *token)
  1295. #else /* K&R style */
  1296. get_number(token)
  1297.     Token *token;
  1298. #endif /* HAVE_STDC */
  1299. {
  1300.     DBLVAL dvalue,leftside,rightside,pwr_of_ten;
  1301.     int exponent,datatype,c;
  1302. #ifdef DEBUG_FORLEX
  1303.     int expsign;
  1304. #endif
  1305.     int numdigits,    /* Count of digits in integer, significant or not */
  1306.         sigfigs;    /* Count of significant digits */
  1307.  
  1308.     initial_flag = FALSE;
  1309.  
  1310.     leftside = (DBLVAL)0;
  1311.     numdigits = sigfigs = 0;
  1312.     datatype = tok_integer_const;
  1313.     while(isadigit(curr_char)) {
  1314.         leftside = leftside*(DBLVAL)10 + (DBLVAL)BCD(curr_char);
  1315.         ++numdigits;
  1316.             /* Do not count leading zeroes as significant */
  1317.         if(sigfigs > 0 || curr_char != '0')
  1318.           ++sigfigs;
  1319.         if( !integer_context && makeupper(next_char) == 'H' )
  1320.           inside_hollerith = TRUE;/* get ready for hollerith*/
  1321.  
  1322.         if(src_text_len < MAX_SRC_TEXT)
  1323.           src_text_buf[src_text_len++] = curr_char;
  1324.                 /* Embedded space is worth preserving since
  1325.                    it is often used in long numbers.  Any
  1326.                    amount of blanks + tabs -> 1 blank.
  1327.                    Exception: integer_context says upcoming
  1328.                    item is a label or datatype length spec. */
  1329.         if(! integer_context &&
  1330.            (next_char == ' ' || next_char == '\t'))
  1331.           if(src_text_len < MAX_SRC_TEXT)
  1332.             src_text_buf[src_text_len++] = ' ';
  1333.  
  1334.         bi_advance();
  1335.     }
  1336.  
  1337.         /* If context specifies integer expected, skip to end.
  1338.            Otherwise scan on ahead for more. */
  1339.     if( integer_context) {
  1340.         if(numdigits == 0) {
  1341.         yyerror("integer expected");
  1342.         advance();    /* gobble something to avoid infinite loop */
  1343.     }
  1344.     }
  1345.     else {/* not integer_context */
  1346.     if( makeupper(curr_char) == 'H' ){      /* nnH means hollerith */
  1347.         if(leftside == (DBLVAL)0) {
  1348.             yyerror("Zero-length hollerith constant");
  1349.             inside_hollerith = FALSE;
  1350.             advance();
  1351.             get_illegal_token(token);
  1352.         }
  1353.         else {
  1354.             if(src_text_buf[src_text_len-1] == ' ')
  1355.               --src_text_len;
  1356.             get_hollerith(token, (int)leftside);
  1357.         }
  1358.         return;
  1359.     }
  1360.  
  1361.     rightside = (DBLVAL)0;
  1362.     pwr_of_ten = (DBLVAL)1;
  1363.     closeup();        /* Pull in the lookahead character */
  1364.     if( curr_char == '.' &&
  1365.                 /* don't be fooled by 1.eq.N or
  1366.                    I.eq.1.and. etc */
  1367.        !looking_at_relop() ) {
  1368.         datatype = tok_real_const;
  1369.         if(numdigits > 0) /* if dot is initial it is already stored */
  1370.           if(src_text_len < MAX_SRC_TEXT)
  1371.             src_text_buf[src_text_len++] = curr_char;
  1372.         bi_advance();
  1373.         while(isadigit(curr_char)) {
  1374.             rightside = rightside*(DBLVAL)10 + (DBLVAL)BCD(curr_char);
  1375.             ++numdigits;
  1376.             if(sigfigs > 0 || curr_char != '0')
  1377.               ++sigfigs;
  1378.             pwr_of_ten /= (DBLVAL)10;
  1379.  
  1380.             if(src_text_len < MAX_SRC_TEXT)
  1381.               src_text_buf[src_text_len++] = curr_char;
  1382.             if(next_char == ' ' || next_char == '\t')
  1383.               if(src_text_len < MAX_SRC_TEXT)
  1384.                 src_text_buf[src_text_len++] = ' ';
  1385.  
  1386.             bi_advance();
  1387.         }
  1388.     }
  1389. #ifdef DEBUG_FORLEX
  1390. if(debug_lexer)
  1391.     dvalue = leftside + rightside*pwr_of_ten;
  1392. else
  1393. #endif
  1394.     dvalue = (DBLVAL)0;
  1395.  
  1396.     exponent = 0;
  1397. #ifdef DEBUG_FORLEX
  1398.     expsign = 1;
  1399. #endif
  1400.         /* Integer followed by E or D gives a real/d.p constant.
  1401.            We also accept Q for quad (real*16) constants. */
  1402.  
  1403.     if( ( (c = makeupper(curr_char)) == 'E' || c == 'D' || c == 'Q') )
  1404.     {
  1405.         datatype = ((c == 'E')? tok_real_const:
  1406.                 ((c == 'D')? tok_dp_const:
  1407.                 tok_quad_const));
  1408.         if(src_text_len < MAX_SRC_TEXT)
  1409.           src_text_buf[src_text_len++] = c;
  1410.         bi_advance();
  1411.         if(curr_char == '+') {
  1412. #ifdef DEBUG_FORLEX
  1413.             expsign = 1;
  1414. #endif
  1415.             if(src_text_len < MAX_SRC_TEXT)
  1416.               src_text_buf[src_text_len++] = curr_char;
  1417.             bi_advance();
  1418.         }
  1419.         else if(curr_char == '-') {
  1420. #ifdef DEBUG_FORLEX
  1421.             expsign = -1;
  1422. #endif
  1423.             if(src_text_len < MAX_SRC_TEXT)
  1424.               src_text_buf[src_text_len++] = curr_char;
  1425.             bi_advance();
  1426.         }
  1427.         if(!isadigit(curr_char)) {
  1428.             yyerror("Badly formed real constant");
  1429.         }
  1430.         else while(isadigit(curr_char)) {
  1431.             exponent = exponent*10 + (curr_char-'0');
  1432.             if(src_text_len < MAX_SRC_TEXT)
  1433.               src_text_buf[src_text_len++] = curr_char;
  1434.             bi_advance();
  1435.         }
  1436.  
  1437.     /*  Compute real value only if debugging. If it exceeds max magnitude,
  1438.         computing it may cause crash. At this time, value of real const
  1439.         is not used for anything. */
  1440. #ifdef DEBUG_FORLEX
  1441. if(debug_lexer)
  1442.           dvalue *= pow(10.0, (double)(exponent*expsign));
  1443. else
  1444. #endif
  1445.           dvalue = (DBLVAL)0;
  1446.  
  1447.     }
  1448.     }/* end if(!integer_context) */
  1449.  
  1450.         if(src_text_buf[src_text_len-1] == ' ')    /* remove any trailing blank */
  1451.       --src_text_len;
  1452.  
  1453.     token->class = datatype;
  1454.                 /* If this is part of complex const,
  1455.                    do not store src_text but arrange
  1456.                    so debugging works. */
  1457.     if(!getting_complex_const) {
  1458.       token->src_text = new_src_text(src_text_buf,src_text_len);
  1459.     }
  1460. #ifdef DEBUG_FORLEX
  1461.       else {
  1462.         src_text_buf[src_text_len] = '\0';
  1463.         token->src_text = src_text_buf;
  1464.       }
  1465. #endif
  1466.     switch(datatype) {
  1467.        case tok_integer_const:
  1468.         token->value.integer = (long)leftside;
  1469. #ifdef DEBUG_FORLEX
  1470. if(debug_lexer)
  1471. (void)fprintf(list_fd,"\nInteger const:\t\t%ld (from %s)",
  1472.           token->value.integer,
  1473.           token->src_text);
  1474. #endif
  1475.         break;
  1476.        case tok_real_const:
  1477.             /* store single as double lest it overflow */
  1478.         token->value.dbl = dvalue;
  1479.         if(trunc_sigfigs && sigfigs >= REAL_SIGFIGS) {
  1480.           warning(token->line_num,token->col_num,
  1481.     "Single-precision real constant has more digits than are stored");
  1482.         }
  1483. #ifdef DEBUG_FORLEX
  1484. if(debug_lexer)
  1485. (void)fprintf(list_fd,"\nReal const:\t\t%g (from %s)",
  1486.           (double)token->value.dbl,
  1487.           token->src_text);
  1488. #endif
  1489.         break;
  1490.        case tok_dp_const:
  1491.         token->value.dbl = dvalue;
  1492. #ifdef DEBUG_FORLEX
  1493. if(debug_lexer)
  1494. (void)fprintf(list_fd,"\nDouble const:\t\t%lg (from %s)",
  1495.           (double)token->value.dbl,
  1496.           token->src_text);
  1497. #endif
  1498.         break;
  1499.     }
  1500.  
  1501. } /* get_number */
  1502.  
  1503.      /* get_complex_constant reads an entity of the form (num,num)
  1504.       where num is any [signed] numeric constant.  It will only be
  1505.       called when looking_at() has guaranteed that there is one there.
  1506.       The token receives the real part as a number.  The imaginary part
  1507.       is not stored.  Whitespace is allowed between ( and num, around
  1508.       the comma, and between num and ) but not within num. */
  1509.  
  1510. PRIVATE void
  1511. #if HAVE_STDC
  1512. get_complex_const(Token *token)
  1513. #else /* K&R style */
  1514. get_complex_const(token)
  1515.     Token *token;
  1516. #endif /* HAVE_STDC */
  1517. {
  1518.     Token imag_part;    /* temporary to hold imag part */
  1519. #ifdef DEBUG_FORLEX
  1520.     double sign=(DBLVAL)1;
  1521. #endif
  1522.     int dble_size=FALSE;    /* flag to set if parts are D floats */
  1523.     int imag_dble_size=FALSE;/* if imaginary part D float */
  1524.     unsigned comma_line_num,comma_col_num;
  1525.     getting_complex_const = TRUE;
  1526.     initial_flag = FALSE;
  1527.  
  1528.  
  1529.  
  1530.     bi_advance();    /* skip over the initial paren (already stored) */
  1531.  
  1532.  
  1533.     if(curr_char == '+' || curr_char == '-') {
  1534. #ifdef DEBUG_FORLEX
  1535.       if(curr_char == '-') sign = (DBLVAL)(-1);
  1536. #endif
  1537.       if(src_text_len < MAX_SRC_TEXT)
  1538.         src_text_buf[src_text_len++] = curr_char;
  1539.  
  1540.       bi_advance();
  1541.     }
  1542.  
  1543. #ifdef DEBUG_FORLEX
  1544. if(debug_lexer){
  1545. (void)fprintf(list_fd,"\nComplex const:(");
  1546. if(sign < 0.0) (void)fprintf(list_fd," -");
  1547. }
  1548. #endif
  1549.     get_number(token);
  1550.     switch((short)token->class) {
  1551.        case tok_integer_const:
  1552. #ifdef DEBUG_FORLEX
  1553. if(debug_lexer)
  1554.         token->value.dbl = sign*(double)token->value.integer;
  1555. else
  1556. #endif
  1557.         token->value.dbl = (DBLVAL)0;
  1558.         break;
  1559.        case tok_dp_const:
  1560.         dble_size=TRUE;
  1561.             /*FALLTHRU*/
  1562.        case tok_real_const:
  1563. #ifdef DEBUG_FORLEX
  1564. if(debug_lexer)
  1565.         token->value.dbl = sign*token->value.dbl;
  1566. else
  1567. #endif
  1568.         token->value.dbl = (DBLVAL)0;
  1569.         break;
  1570.     }
  1571.  
  1572.     while(iswhitespace(curr_char))
  1573.       advance();
  1574.  
  1575.  
  1576.     comma_line_num = line_num;
  1577.     comma_col_num = col_num;
  1578.  
  1579.     if(src_text_len < MAX_SRC_TEXT)
  1580.       src_text_buf[src_text_len++] = curr_char;
  1581.     if(next_char == ' ' || next_char == '\t') /* preserve space after , */
  1582.       if(src_text_len < MAX_SRC_TEXT)
  1583.         src_text_buf[src_text_len++] = ' ';
  1584.  
  1585.     bi_advance();        /* skip over the comma */
  1586.  
  1587.     if(curr_char == '+' || curr_char == '-') {
  1588. #ifdef DEBUG_FORLEX
  1589.          if(curr_char == '-') sign = (DBLVAL)(-1);
  1590. #endif
  1591.          if(src_text_len < MAX_SRC_TEXT)
  1592.         src_text_buf[src_text_len++] = curr_char;
  1593.  
  1594.          bi_advance();
  1595.     }
  1596. #ifdef DEBUG_FORLEX
  1597. if(debug_lexer){
  1598. (void)fprintf(list_fd,"\n,");
  1599. if(sign < 0.0) (void)fprintf(list_fd," -");
  1600. }
  1601. #endif
  1602.     get_number(&imag_part);
  1603.     imag_dble_size = (imag_part.class == tok_dp_const);
  1604.  
  1605.     if(dble_size != imag_dble_size) {
  1606.         warning(comma_line_num,comma_col_num,
  1607.           "different precision in real and imaginary parts");
  1608.     }
  1609.     else if(f77_double_complex) {
  1610.       if(dble_size)
  1611.         warning(token->line_num,token->col_num,
  1612.           "nonstandard double precision complex constant");
  1613.     }
  1614.  
  1615.     dble_size = (dble_size || imag_dble_size);
  1616.  
  1617.     while(iswhitespace(curr_char))
  1618.        advance();
  1619.  
  1620.  
  1621.     if(src_text_len < MAX_SRC_TEXT)
  1622.       src_text_buf[src_text_len++] = curr_char;
  1623.  
  1624.     advance();    /* skip over final paren */
  1625.  
  1626.     if(dble_size)
  1627.       token->class = tok_dcomplex_const;
  1628.     else
  1629.       token->class = tok_complex_const;
  1630.  
  1631.     token->src_text = new_src_text(src_text_buf,src_text_len);
  1632.  
  1633. #ifdef DEBUG_FORLEX
  1634. if(debug_lexer) {
  1635. (void)fprintf(list_fd,"\n\t\t\tsource text=%s",
  1636.           token->src_text);
  1637. (void)fprintf(list_fd,"\n)");
  1638. }
  1639. #endif
  1640.  
  1641.     getting_complex_const = FALSE;
  1642. }
  1643.  
  1644. #ifdef ALLOW_TYPELESS_CONSTANTS
  1645.         /* Routine to get constants of the forms:
  1646.             B'nnnn' 'nnnn'B  -- binary
  1647.             O'nnnn' 'nnnn'O  -- octal
  1648.             X'nnnn' Z'nnnn' 'nnnn'X 'nnnn'Z  -- hex
  1649.            No check of whether digits are less than base.
  1650.            Nonstandard warning is issued here since the constant
  1651.            looks like a normal integer by the time the parser sees it.
  1652.          */
  1653. PRIVATE void
  1654. #if HAVE_STDC
  1655. get_binary_const(Token *token, int c)
  1656.                        /* base character: madeupper'ed by caller */
  1657. #else /* K&R style */
  1658. get_binary_const(token,c)
  1659.      Token *token;
  1660.      int c;            /* base character: madeupper'ed by caller */
  1661. #endif /* HAVE_STDC */
  1662. {
  1663.   long value=0;
  1664.   int base,digit;
  1665.   int i,j;            /* indices in src_text_buf for repacking */
  1666.   if(c == 'O')  base = 8;
  1667.   else if(c == 'X' || c == 'Z')  base = 16;
  1668.   else if(c == 'B') base = 2;
  1669.   else {
  1670.     syntax_error(token->line_num,token->col_num,
  1671.          "Unknown base for typeless constant -- octal assumed");
  1672.     base = 8;
  1673.   }
  1674.  
  1675.                 /* Advance i to starting digit */
  1676.   i = 0;
  1677.   while( ! isaquote(src_text_buf[i]) ) {
  1678.     ++i;
  1679.   }
  1680.   j = ++i;    /* Input = Output to start */
  1681.  
  1682.                 /* Scan the string, moving chars down
  1683.                    to change multi spaces to single
  1684.                    blanks, and converting digits. */
  1685.   while( ! isaquote(src_text_buf[i]) ) {
  1686.     digit=src_text_buf[i++];
  1687.     if( ishex(digit) ){
  1688.       value = value*base + HEX(digit);
  1689.       src_text_buf[j++] = digit;
  1690.     }
  1691.     else {            /* Anything else should be space */
  1692.       if( isspace(digit) ) {
  1693.     src_text_buf[j++] = ' ';
  1694.     while( isspace(src_text_buf[i]) ) {
  1695.       ++i;
  1696.     }
  1697.       }
  1698.       else {
  1699.     syntax_error(token->line_num,token->col_num,
  1700.              "badly formed typeless constant");
  1701.       }
  1702.     }
  1703.   }
  1704.  
  1705.   while(i < src_text_len)
  1706.     src_text_buf[j++] = src_text_buf[i++]; /* Copy the rest over */
  1707.  
  1708.   src_text_len = j;
  1709.  
  1710. #ifdef OLD_GET_BINARY_CONST
  1711.         /* Old arg: */
  1712.      char *s;            /* string of digits, or NULL */
  1713.  
  1714.     /* Two forms: X'nnnn' and 'nnnn'X. For the first, string has not
  1715.        been scanned yet, and s is null.  For second, s=digit string. */
  1716.   if(s == NULL) {
  1717.     if(src_text_len < MAX_SRC_TEXT)
  1718.       src_text_buf[src_text_len++] = curr_char;
  1719.     bi_advance();        /* gobble the leading quote */
  1720.  
  1721.     while(ishex(curr_char)){
  1722.       value = value*base + HEX(curr_char);
  1723.  
  1724.       if(src_text_len < MAX_SRC_TEXT)
  1725.     src_text_buf[src_text_len++] = curr_char;
  1726.       if(next_char == ' ' || next_char == '\t')
  1727.     if(src_text_len < MAX_SRC_TEXT)
  1728.       src_text_buf[src_text_len++] = ' ';
  1729.  
  1730.       bi_advance();
  1731.     }
  1732.     if(curr_char != '\'') {
  1733.       syntax_error(line_num,col_num, "Closing quote missing");
  1734.     }
  1735.     else {
  1736.       advance();        /* gobble the trailing quote */
  1737.     }
  1738.     if(src_text_len < MAX_SRC_TEXT)
  1739.       src_text_buf[src_text_len++] = '\''; /* put the quote there */
  1740.   }
  1741.   else {            /* Use the given string */
  1742.     if(src_text_len < MAX_SRC_TEXT)
  1743.       src_text_buf[src_text_len++] = '\''; /* put the leading quote */
  1744.     while(*s != '\0') {
  1745.       if(!isspace(*s)) {    /* skip blanks */
  1746.     value = value*base + HEX(*s);
  1747.  
  1748.     if(src_text_len < MAX_SRC_TEXT)
  1749.       src_text_buf[src_text_len++] = *s;
  1750.     s++;
  1751.       }
  1752.       else {
  1753.     if(src_text_len < MAX_SRC_TEXT)
  1754.       src_text_buf[src_text_len++] = ' ';
  1755.     do{ s++; } while(*s != '\0' && isspace(*s));
  1756.       }
  1757.     }
  1758.     if(src_text_len < MAX_SRC_TEXT)
  1759.       src_text_buf[src_text_len++] = '\''; /* put the trailing quote */
  1760.   }
  1761. #endif/*OLD_GET_BINARY_CONST*/
  1762.  
  1763.   token->class = tok_integer_const;
  1764.   token->value.integer = value;
  1765.   token->src_text = new_src_text(src_text_buf,src_text_len);
  1766.  
  1767.   if(f77_typeless_constants) {
  1768.     nonstandard(token->line_num,token->col_num);
  1769.   }
  1770.  
  1771. #ifdef DEBUG_FORLEX
  1772. if(debug_lexer)
  1773. (void)fprintf(list_fd,"\nInteger const:\t\t%d (from %s)",
  1774.           token->value.integer,
  1775.           token->src_text);
  1776. #endif
  1777.  
  1778. }/*get_binary_const*/
  1779.  
  1780. #endif/*ALLOW_TYPELESS_CONSTANTS*/
  1781.  
  1782.  
  1783. PRIVATE void
  1784. #if HAVE_STDC
  1785. get_punctuation(Token *token)
  1786. #else /* K&R style */
  1787. get_punctuation(token)
  1788.     Token *token;
  1789. #endif /* HAVE_STDC */
  1790. {
  1791.     src_text_buf[src_text_len++] = curr_char;
  1792.     initial_flag = FALSE;
  1793.     closeup();
  1794.     if(curr_char == '*' && next_char == '*') {
  1795.         token->class = tok_power;
  1796.         advance();
  1797.         src_text_buf[src_text_len++] = curr_char;
  1798.     }
  1799.     else if(curr_char == '/' && next_char == '/' ) {
  1800.         token->class = tok_concat;
  1801.         advance();
  1802.         src_text_buf[src_text_len++] = curr_char;
  1803.     }
  1804.         /* paren can be the start of complex constant if everything
  1805.            is just right. Maybe more tests needed here. */
  1806.     else if(complex_const_allowed && curr_char == '(' &&
  1807.          (  (prev_token_class<256 && ispunct(prev_token_class))
  1808.           || prev_token_class == tok_relop
  1809.           || prev_token_class == tok_power )
  1810.          && looking_at_cplx()) {
  1811.         get_complex_const(token);
  1812.         return;
  1813.     }
  1814.     else
  1815.         token->class = curr_char;
  1816.     token->src_text = new_src_text(src_text_buf,src_text_len);
  1817.     advance();
  1818.  
  1819. #ifdef DEBUG_FORLEX
  1820. if(debug_lexer) {
  1821.     if(token->class == EOS)
  1822.         (void)fprintf(list_fd,"\n\t\t\tEOS");
  1823.     else
  1824.         (void)fprintf(list_fd,"\nPunctuation:\t\t%s",token->src_text);
  1825.  }
  1826. #endif
  1827. } /* get_punctuation */
  1828.  
  1829.  
  1830. PRIVATE void
  1831. #if HAVE_STDC
  1832. get_simple_punctuation(Token *token)
  1833. #else /* K&R style */
  1834. get_simple_punctuation(token)
  1835.     Token *token;
  1836. #endif /* HAVE_STDC */
  1837. {
  1838.         /* Like get_punctuation but lacks special cases.  Just
  1839.            gets the punctuation character. Text is already in
  1840.            src_text_buf. */
  1841.  
  1842.     token->class = curr_char;
  1843.     token->src_text = new_src_text(src_text_buf,src_text_len);
  1844.     advance();
  1845. #ifdef DEBUG_FORLEX
  1846. if(debug_lexer) {
  1847.     if(token->class == EOS)
  1848.         (void)fprintf(list_fd,"\n\t\t\tEOS");
  1849.     else
  1850.         (void)fprintf(list_fd,"\nPunctuation:\t\t%s",token->src_text);
  1851. }
  1852. #endif
  1853. } /* get_simple_punctuation */
  1854.  
  1855.  
  1856. PRIVATE void
  1857. #if HAVE_STDC
  1858. get_string(Token *token)       /* Gets string of form 'aaaa' */
  1859. #else /* K&R style */
  1860. get_string(token)       /* Gets string of form 'aaaa' */
  1861.     Token *token;
  1862. #endif /* HAVE_STDC */
  1863. {
  1864.     int len,last_col_num;
  1865.     int has_backslash = FALSE; /* for portability check */
  1866.  
  1867.     quote_char = curr_char; /* remember the delimiter */
  1868.     initial_flag = FALSE;
  1869.     inside_string = TRUE;
  1870.     last_col_num=col_num;
  1871.     src_text_buf[src_text_len++] = curr_char; /* store leading quote */
  1872.     advance();      /* Gobble leading quote */
  1873.     len = 0;
  1874.     for(;;) {
  1875.         while(curr_char == EOL) {
  1876.             /* Treat short line as if extended with blanks */
  1877.             int col;
  1878.             for(col=last_col_num; col<max_stmt_col; col++) {
  1879.  
  1880.               if(src_text_len < MAX_SRC_TEXT)
  1881.             src_text_buf[src_text_len++] = ' ';
  1882.  
  1883.               ++len;
  1884.             }
  1885.           last_col_num=col_num;
  1886.           advance();
  1887.         }
  1888.         if(curr_char == EOS || curr_char == EOF) {
  1889.             yyerror("Closing quote missing from string");
  1890.             break;
  1891.         }
  1892.         if(curr_char == quote_char) {
  1893.             inside_string = FALSE;/* assume so for now */
  1894.  
  1895. /* If LEX_RAWSTRINGS defined, stores doubled quotes and final quote.
  1896.    Otherwise initial quote is stored and doubled quotes are reduced to one. */
  1897. #ifdef LEX_RAWSTRINGS
  1898.                 /* Store the quote */
  1899.             if(src_text_len < MAX_SRC_TEXT)
  1900.               src_text_buf[src_text_len++] = curr_char;
  1901. #endif
  1902.  
  1903.                     /* Handle possible continuation */
  1904.             if(next_char == EOL && col_num == max_stmt_col)
  1905.               advance();
  1906.  
  1907.             last_col_num=col_num;
  1908.             advance();
  1909.  
  1910.             if(curr_char == quote_char){/* '' becomes ' in string */
  1911.                 inside_string = TRUE; /* not a closing quote */
  1912.  
  1913.                 if(src_text_len < MAX_SRC_TEXT)
  1914.                   src_text_buf[src_text_len++] = curr_char;
  1915.  
  1916.                 ++len;
  1917.                 last_col_num=col_num;
  1918.                 advance();
  1919.             }
  1920.             else {
  1921.                 break;  /* It was a closing quote after all */
  1922.             }
  1923.         }
  1924.         else {        /* ordinary character within quotes */
  1925.             int value=curr_char;
  1926.  
  1927.             if(curr_char == '\\') {
  1928.               if(!has_backslash) {/* only warn once per string */
  1929.                 if(port_backslash)
  1930.                   nonportable(line_num,col_num,
  1931.                "backslash treated incompatibly by some compilers");
  1932.               }
  1933.               has_backslash = TRUE;
  1934.  
  1935. #ifdef ALLOW_UNIX_BACKSLASH    /* This has problems: undigesting
  1936.                    a string gets complicated. */
  1937.               if(unix_backslash) {
  1938.                 if(f77_unix_backslash) {
  1939.                   nonstandard(line_num,col_num);
  1940.                   msg_tail(": backslash escape sequence");
  1941.                 }
  1942. #ifdef LEX_RAWSTRINGS
  1943.                 /* Store the backslash */
  1944.                 if(src_text_len < MAX_SRC_TEXT)
  1945.                   src_text_buf[src_text_len++] = curr_char;
  1946. #endif
  1947.                 inside_string = FALSE;/* so inline_comment works */
  1948.                 advance(); /* gobble the backslash */
  1949.                 inside_string = TRUE;
  1950. #ifdef LEX_RAWSTRINGS
  1951.                 value = curr_char;
  1952. #else /* !LEX_RAWSTRINGS*/
  1953.                 if(isadigit(curr_char)) { /* \octal digits */
  1954.                   value = BCD(curr_char);
  1955.                   while(isadigit(next_char)) {
  1956.                 advance();
  1957.                 value = value*8 + BCD(curr_char);
  1958.                   }
  1959.                 }
  1960.                 else if(curr_char == 'x') {
  1961.                   advance(); /* gobble the 'x' */
  1962.                   value = HEX(curr_char);
  1963.                   while(ishex(next_char)) {
  1964.                 advance();
  1965.                 value = value*16 + HEX(curr_char);
  1966.                   }
  1967.                 }/* end if octal or hex */
  1968.                 else switch(curr_char) {
  1969. #if __STDC__ + 0
  1970.                   case 'a': value = '\a'; break; /* alarm */
  1971. #else
  1972.                   case 'a': value = '\007'; break; /* alarm */
  1973. #endif
  1974.                   case 'b': value = '\b'; break; /* backspace */
  1975.                   case 'f': value = '\f'; break; /* formfeed */
  1976.                   case 'n': value = '\n'; break; /* newline */
  1977.                   case 'r': value = '\r'; break; /* carr return */
  1978.                   case 't': value = '\t'; break; /* h tab */
  1979.                   case 'v': value = '\v'; break; /* v tab */
  1980.                   case EOS: value = '\n'; break; /* a no-no */
  1981.                 /* All others: \c --> c */
  1982.                   default:  value = curr_char; break;
  1983.                 }
  1984. #endif /* !LEX_RAWSTRINGS*/
  1985.               }/* end if unix_backslash */
  1986. #endif /*ALLOW_UNIX_BACKSLASH*/
  1987.  
  1988.             }/* end if curr_char == backslash */
  1989.  
  1990.             if(src_text_len < MAX_SRC_TEXT)
  1991.               src_text_buf[src_text_len++] = value;
  1992.  
  1993.             ++len;
  1994.             last_col_num=col_num;
  1995.             advance();
  1996.         }
  1997.     }
  1998.  
  1999. #ifdef ALLOW_TYPELESS_CONSTANTS
  2000.                 /* Watch for const like 'nnn'X */
  2001.     if(!inside_format) {
  2002.       while(iswhitespace(curr_char))
  2003.         advance();
  2004.       if(isaletter(curr_char)) {
  2005.         int c=makeupper(curr_char);
  2006. #ifndef LEX_RAWSTRINGS
  2007.         if(src_text_len < MAX_SRC_TEXT)
  2008.           src_text_buf[src_text_len++] = quote_char;
  2009. #endif
  2010.         if(src_text_len < MAX_SRC_TEXT)
  2011.           src_text_buf[src_text_len++] = c;
  2012.         advance();        /* Gobble the base character */
  2013.         get_binary_const(token,c);
  2014.         return;
  2015.       }
  2016.     }
  2017. #endif /*ALLOW_TYPELESS_CONSTANTS*/
  2018.  
  2019.     if(len == 0) {
  2020.         warning(line_num,col_num,
  2021.             "Zero-length string not allowed\n");
  2022.         len = 1;
  2023.     }
  2024.  
  2025.     if(quote_char != '\'') { /* Warn if quote is used instead of apost */
  2026.       if(f77_quotemarks) {
  2027.         nonstandard(token->line_num,token->col_num);
  2028.         msg_tail(": character string should be delimited by apostrophes");
  2029.       }
  2030.     }
  2031.  
  2032.     inside_string = FALSE;
  2033.  
  2034.     token->class = tok_string;
  2035.     token->size = len;
  2036.     token->src_text = new_src_text(src_text_buf,src_text_len);
  2037. #ifdef LEX_RAWSTRINGS
  2038.     token->value.string = token->src_text; /* Includes the initial quote */
  2039. #else
  2040.     token->value.string = token->src_text+1; /* Skips the initial quote */
  2041. #endif
  2042.                 /* Under -port warn if char size > 255 */
  2043.     if(port_long_string) {
  2044.       if(len > 255)
  2045.         nonportable(line_num,col_num,
  2046.             "character constant length exceeds 255");
  2047.     }
  2048.  
  2049. #ifdef DEBUG_FORLEX
  2050.     if(debug_lexer
  2051.        && src_text_buf[0] == quote_char) { /* skip if doing X'nnnn' */
  2052.         (void)fprintf(list_fd,"\nString:\t\t\t%s",token->value.string);
  2053.         (void)fprintf(list_fd,"\n\t\t(from\t%s)",token->src_text);
  2054.     }
  2055. #endif
  2056.  
  2057. } /* get_string */
  2058.  
  2059.  
  2060. /* End of Forlex module */
  2061.  
  2062. /*
  2063. II. Advance
  2064. */
  2065.  
  2066. /* advance.c:
  2067.  
  2068.     Low-level input routines for Fortran program checker.
  2069.  
  2070.     Shared functions defined:
  2071.         init_scan()    Initializes an input stream.
  2072.         finish_scan()    Finishes processing an input stream.
  2073.         advance()    Reads next char, removing comments and
  2074.                 handling continuation lines.
  2075.             looking_at_x Handles lookahead up to end of line:
  2076.         looking_at_cplx() Identifies complex constant.
  2077.         looking_at_keywd() Identifies assgnmt stmts vs keywords.
  2078.         looking_at_relop() Distinguishes .EQ. from .Eexp .
  2079.         flush_line_out(n) Prints lines up to line n if not already
  2080.                 printed, so error messages come out looking OK.
  2081. */
  2082.  
  2083.  
  2084.     /* Define tab stops: nxttab[col_num] is column of next tab stop */
  2085.  
  2086. #define do8(X) X,X,X,X,X,X,X,X
  2087. PRIVATE int nxttab[]={ 0, do8(9), do8(17), do8(25), do8(33),
  2088.         do8(41), do8(49), do8(57), do8(65), do8(73), do8(81)};
  2089.  
  2090. PRIVATE int
  2091.     next_index,        /* Index in line of next_char */
  2092.     prev_comment_line,    /* True if previous line was comment */
  2093.     curr_comment_line,    /* True if current line is comment */
  2094.     noncomment_line_count,    /* Number of noncomment lines read so far */
  2095.     line_is_printed,    /* True if line has been flushed (printed) */
  2096.     prev_line_is_printed,    /* True if line has been flushed (printed) */
  2097.     sticky_EOF;        /* Signal to delay EOF a bit for sake
  2098.                    of error messages in include files. */
  2099. PRIVATE unsigned
  2100.     prev_line_num;        /* line number of previous input line */
  2101.  
  2102. unsigned prev_stmt_line_num;    /* line number of previous noncomment */
  2103.  
  2104.  
  2105. PRIVATE char
  2106.     lineA[MAXLINE+1],lineB[MAXLINE+1],  /* Buffers holding input lines */
  2107.     *prev_line,*line;            /* Pointers to input buffers */
  2108.  
  2109.  
  2110.     /* Lookahead routines that scan the input
  2111.        line for various things.  The is_whatever routines take a
  2112.        string as argument and return TRUE if it satisfies the
  2113.        criterion. The skip_whatever routines take an index and
  2114.        string as argument and return the index of the next
  2115.        nonspace character in the string after the expected thing,
  2116.        which must be there in a syntactically correct program.
  2117.        The given index points at the character after a known
  2118.        lead-in (except for see_a_number, which can be given the
  2119.        index of 1st char of number).  The see_whatever routines
  2120.        are similar but return -1 if the expected thing is not
  2121.        seen, which it need not be. */
  2122.  
  2123.  
  2124. PROTO(PRIVATE char * getstrn,( char s[], int n, FILE *fd ));
  2125.  
  2126. PROTO(PRIVATE int is_comment,( char s[] ));
  2127.  
  2128. PROTO(PRIVATE int is_continuation,( char s[], int *cont_index, unsigned *cont_col_num ));
  2129.  
  2130. PROTO(PRIVATE int is_overlength,( char *s, int maxcol ));
  2131.  
  2132. PROTO(PRIVATE int see_a_number,( int i, char s[], int can_be_holl ));
  2133.  
  2134. PROTO(PRIVATE int see_dowhile,( int indx, char ll[] ));
  2135.  
  2136. PROTO(PRIVATE int see_expression,( int indx, char ll[] ));
  2137.  
  2138. PROTO(PRIVATE int see_keyword,( int indx, char ll[], char *matchstr ));
  2139.  
  2140. PROTO(PRIVATE int skip_balanced_parens,( int indx, char ll[] ));
  2141.  
  2142. PROTO(PRIVATE int skip_idletters,( int indx, char ll[] ));
  2143.  
  2144. PROTO(PRIVATE int skip_quoted_string,( int indx, char ll[] ));
  2145.  
  2146. PROTO(PRIVATE int skip_hollerith,( int i, char s[] ));
  2147.  
  2148. #ifdef ALLOW_UNIX_CPP
  2149. PROTO(PRIVATE int take_cpp_line,( char *s ));
  2150. #endif
  2151.  
  2152.  
  2153.  
  2154.  
  2155. #ifdef ALLOW_INCLUDE
  2156. /* Definition of structure for saving the input stream parameters while
  2157.    processing an include file.
  2158. */
  2159.  
  2160. typedef struct {
  2161.   FILE     *input_fd;
  2162.   char       *fname;
  2163.   char     line[MAXLINE];  /* MAXLINE is defined in ftnchek.h */
  2164.   int      curr_char;
  2165.   int      next_char;
  2166.   int       next_index;
  2167.   int       col_num;
  2168.   int       next_col_num;
  2169.   int       line_is_printed;
  2170.   int       do_list;
  2171.   unsigned line_num;
  2172.   unsigned next_line_num;
  2173. } IncludeFileStack;
  2174.  
  2175. PRIVATE IncludeFileStack include_stack[MAX_INCLUDE_DEPTH];
  2176.  
  2177. #endif /*ALLOW_INCLUDE*/
  2178.  
  2179.  
  2180. #ifdef ALLOW_INCLUDE
  2181. PROTO(PRIVATE FILE* find_include,( char **fname, char *mode ));
  2182. PROTO(PRIVATE FILE * fopen_with_path,( char *include_path, char **fname, char
  2183.                    *mode ));
  2184. #endif
  2185.  
  2186. PROTO(PRIVATE void init_stream,( void ));
  2187. PROTO(PRIVATE int pop_include_file,( void ));
  2188. PROTO(PRIVATE int push_include_file,( char *fname, FILE *fd, unsigned
  2189.                   include_line_num ));
  2190.  
  2191.  
  2192.  
  2193.  
  2194.  
  2195. #ifdef ALLOW_INCLUDE        /* defns of include-file handlers */
  2196.  
  2197. PRIVATE int
  2198. #if HAVE_STDC
  2199. push_include_file(char *fname, FILE *fd, unsigned int include_line_num)
  2200. #else /* K&R style */
  2201. push_include_file(fname,fd,include_line_num)
  2202.     char *fname;
  2203.     FILE *fd;
  2204.     unsigned include_line_num;
  2205. #endif /* HAVE_STDC */
  2206. {
  2207.      if (incdepth == MAX_INCLUDE_DEPTH) {
  2208.        oops_message(OOPS_NONFATAL,line_num,NO_COL_NUM,
  2209.             "include files nested too deep");
  2210.        return FALSE;
  2211.      }
  2212.  
  2213. #ifdef DEBUG_INCLUDE
  2214. if(debug_include){
  2215. (void)fprintf(list_fd,"\npush_include_file: curr_char=%c (%d)",curr_char,curr_char);
  2216. }
  2217. #endif
  2218.  
  2219.      if(incdepth == 0) /* Save line num of outermost include */
  2220.        top_file_line_num = include_line_num;
  2221.  
  2222.      include_stack[incdepth].input_fd = input_fd;
  2223.      input_fd = fd;
  2224.  
  2225.      include_stack[incdepth].fname = current_filename;
  2226.      current_filename = fname;
  2227.  
  2228.      (void)strcpy(include_stack[incdepth].line,line);
  2229.      include_stack[incdepth].curr_char = curr_char;
  2230.      include_stack[incdepth].next_char = next_char;
  2231.      include_stack[incdepth].next_index = next_index;
  2232.      include_stack[incdepth].col_num = col_num;
  2233.      include_stack[incdepth].next_col_num = next_col_num;
  2234.      include_stack[incdepth].line_is_printed = line_is_printed;
  2235.      include_stack[incdepth].line_num = line_num;
  2236.      include_stack[incdepth].next_line_num = next_line_num;
  2237.      include_stack[incdepth].do_list = do_list;
  2238.  
  2239.      incdepth++;
  2240.  
  2241.      init_stream();
  2242.  
  2243.      return TRUE;
  2244. }
  2245.  
  2246. PRIVATE int
  2247. pop_include_file(VOID)
  2248. {
  2249. #ifdef DEBUG_INCLUDE
  2250. if(debug_include){
  2251. (void)fprintf(list_fd,"\npop_include_file: line %u = %s depth %d",line_num,line,
  2252. incdepth);
  2253. }
  2254. #endif
  2255.  
  2256.      if (incdepth == 0) {    /* Stack empty: no include file to pop. */
  2257.        return FALSE;
  2258.      }
  2259.      incdepth--;
  2260.  
  2261.  
  2262.      if(do_list) {
  2263.        (void)flush_line_out(next_line_num);
  2264.        (void)fprintf(list_fd,"\nResuming file %s:",
  2265.            include_stack[incdepth].fname);
  2266.      }
  2267.  
  2268.      (void)fclose(input_fd);
  2269.      input_fd = include_stack[incdepth].input_fd;
  2270.  
  2271.      current_filename = include_stack[incdepth].fname;
  2272.  
  2273.      (void)strcpy(line,include_stack[incdepth].line);
  2274.      curr_char = include_stack[incdepth].curr_char;
  2275.      next_char = include_stack[incdepth].next_char;
  2276.      next_index = include_stack[incdepth].next_index;
  2277.      col_num = include_stack[incdepth].col_num;
  2278.      next_col_num = include_stack[incdepth].next_col_num;
  2279.      line_is_printed = include_stack[incdepth].line_is_printed;
  2280.      line_num = include_stack[incdepth].line_num;
  2281.      next_line_num = include_stack[incdepth].next_line_num;
  2282.      do_list = include_stack[incdepth].do_list;
  2283.  
  2284.      curr_comment_line = FALSE;
  2285.      prev_line_is_printed = TRUE;
  2286.      initial_flag = TRUE;
  2287.      sticky_EOF = TRUE;
  2288.  
  2289.      return TRUE;
  2290. }
  2291.  
  2292.  
  2293. void
  2294. #if HAVE_STDC
  2295. open_include_file(char *fname, unsigned int include_line_num)
  2296. #else /* K&R style */
  2297. open_include_file(fname,include_line_num)
  2298.      char *fname;
  2299.      unsigned include_line_num;
  2300. #endif /* HAVE_STDC */
  2301. {
  2302.   FILE *fd;
  2303.   int list_option=FALSE;    /* /[NO]LIST qualifier: default=NOLIST */
  2304.  
  2305.                 /* for VMS: default extension is .for */
  2306.   if(vms_include) {
  2307.     if(has_extension(fname,"/nolist")) {
  2308.       list_option = FALSE;
  2309.       fname[strlen(fname)-strlen("/nolist")] = '\0'; /* trim off qualifier */
  2310.     }
  2311.     else if(has_extension(fname,"/list")) {
  2312.       list_option = TRUE;
  2313.       fname[strlen(fname)-strlen("/list")] = '\0'; /* trim off qualifier */
  2314.     }
  2315.     fname = add_ext(fname, DEF_INC_EXTENSION);
  2316.   }
  2317.  
  2318.         /* Need to put the name in permanent space */
  2319.   fname = new_global_string(fname);
  2320.  
  2321.   if ((fd = find_include(&fname,"r")) == NULL) {
  2322.     (void)fprintf(stderr,"\nerror opening include file %s\n",fname);
  2323.     return;
  2324.   }
  2325.  
  2326.             /* Print the INCLUDE line if do_list */
  2327.   if(do_list)
  2328.     (void)flush_line_out(prev_line_num);
  2329.  
  2330.             /* Report inclusion of file */
  2331.   if(!quiet || do_list)
  2332.     (void)fprintf(list_fd,"\nIncluding file %s:",fname);
  2333.  
  2334.         /* Save the current input stream and then open
  2335.            the include file as input stream. */
  2336.   if( push_include_file(fname,fd,include_line_num) ) {
  2337.     if(vms_include) {
  2338.     /* put /[NO]LIST option into effect */
  2339.       if(do_list != list_option)
  2340.     (void)fprintf(list_fd," (listing %s)", list_option? "on":"off");
  2341.       do_list = list_option;
  2342.     }
  2343.   }
  2344.   else
  2345.     (void)fclose(fd);
  2346. }
  2347.  
  2348. PRIVATE FILE*
  2349. #if HAVE_STDC
  2350. find_include(char **fname, char *mode)    /* looks for file locally or in include dir */
  2351.                           /* If found, fname is returned with full path*/
  2352. #else /* K&R style */
  2353. find_include(fname,mode)    /* looks for file locally or in include dir */
  2354.      char **fname,        /* If found, fname is returned with full path*/
  2355.      *mode;
  2356. #endif /* HAVE_STDC */
  2357. {
  2358.   FILE *fp;
  2359.   char *env_include_var;
  2360.   IncludePathNode *p;
  2361.  
  2362.             /* Look first for bare filename */
  2363.   if( (fp=fopen(*fname,mode)) != NULL)
  2364.     return fp;
  2365.  
  2366.               /* If not found, look in directories given
  2367.              by include_path_list from -include options */
  2368.  
  2369.   for(p=include_path_list; p!=NULL; p=p->link) {
  2370.     if( (fp=fopen_with_path(p->include_path,fname,mode)) != (FILE *)NULL)
  2371.       return fp;
  2372.   }
  2373.  
  2374.               /* If not found, look in directory given by
  2375.              env variable ENV_INCLUDE_VAR (e.g. set by
  2376.              % setenv INCLUDE ~/myinclude ) */
  2377.  
  2378.   if( (env_include_var=getenv(ENV_INCLUDE_VAR)) != NULL) {
  2379.     if( (fp=fopen_with_path(env_include_var,fname,mode)) != (FILE *)NULL)
  2380.       return fp;
  2381.   }
  2382.  
  2383.             /* Still not found: look in systemwide
  2384.                default directory */
  2385.  
  2386. #ifdef DEFAULT_INCLUDE_DIR
  2387.   if( (fp=fopen_with_path(DEFAULT_INCLUDE_DIR,fname,mode)) != NULL)
  2388.     return fp;
  2389. #endif/* DEFAULT_INCLUDE_DIR */
  2390.  
  2391.                 /* Not found anywhere: fail */
  2392.   return (FILE *)NULL;
  2393. }/*find_include*/
  2394.  
  2395.         /* Routine to open file with name given by include_path
  2396.            followed by fname.  If successful, fname is replaced
  2397.            by pointer to full name.  */
  2398. PRIVATE FILE *
  2399. #if HAVE_STDC
  2400. fopen_with_path(char *include_path, char **fname, char *mode)
  2401. #else /* K&R style */
  2402. fopen_with_path(include_path,fname,mode)
  2403.      char *include_path, **fname, *mode;
  2404. #endif /* HAVE_STDC */
  2405. {
  2406.     FILE *fp;
  2407.     char tmpname[256];        /* holds name with path prepended */
  2408.  
  2409.     (void)strcpy(tmpname,include_path);
  2410.                 /* Add "/" or "\" if not provided */
  2411. #ifdef UNIX
  2412.     if(tmpname[strlen(tmpname)-1] != '/')
  2413.       (void)strcat(tmpname,"/");
  2414. #endif
  2415. #ifdef MSDOS
  2416.     if(tmpname[strlen(tmpname)-1] != '\\')
  2417.       (void)strcat(tmpname,"\\");
  2418. #endif
  2419.     (void)strcat(tmpname,*fname);
  2420.  
  2421.     if( (fp=fopen(tmpname,mode)) != (FILE *)NULL) {
  2422.             /* Found: save new name in permanent space */
  2423.     *fname = new_global_string(tmpname);
  2424.     }
  2425.  
  2426.     return fp;
  2427. }/*fopen_with_path*/
  2428.  
  2429. #else /* no ALLOW_INCLUDE */
  2430.                 /* disabled forms of include handlers */
  2431. PRIVATE int
  2432. push_include_file(fname,fd,include_line_num)
  2433.     char *fname;
  2434.     FILE *fd;
  2435.     unsigned include_line_num;
  2436. {return FALSE;}
  2437.  
  2438. PRIVATE int
  2439. pop_include_file()
  2440. {return FALSE;}
  2441.  
  2442. void
  2443. open_include_file(fname,include_line_num)
  2444.      char *fname;
  2445.      unsigned include_line_num;
  2446. {}
  2447.  
  2448. #endif /*ALLOW_INCLUDE*/
  2449.  
  2450. PRIVATE int line_is_overlength, prev_line_overlength;
  2451.  
  2452. void
  2453. init_scan(VOID)            /* Starts reading a file */
  2454. {
  2455.     tab_filename = NULL;
  2456.     incdepth = 0;
  2457.     top_file_line_num = 1;
  2458.  
  2459.     line = lineA;        /* Start out reading into buffer A */
  2460.     prev_line = lineB;
  2461.  
  2462.     init_stream();
  2463. }
  2464.  
  2465. PRIVATE void
  2466. init_stream(VOID)        /* Initializes a new input stream */
  2467. {
  2468.     curr_comment_line = FALSE;
  2469.     inside_string = FALSE;
  2470.     inside_hollerith = FALSE;
  2471.     line_is_printed = TRUE;
  2472.     prev_line_is_printed = TRUE;
  2473.     line_is_overlength = prev_line_overlength = FALSE;
  2474.     noncomment_line_count = 0;
  2475.  
  2476.     next_index = -1;    /* Startup as if just read a blank line */
  2477.     next_char = EOS;
  2478.     curr_char = EOS;
  2479.     next_col_num = 0;
  2480.     next_line_num = 0;
  2481.     prev_line_num = prev_stmt_line_num = 0;
  2482.     sticky_EOF = TRUE;
  2483.     contin_count = 0;
  2484.  
  2485.     line[0] = '\0';
  2486.     advance();        /* put 1st two chars in the pipeline */
  2487.     advance();
  2488.     advance();        /* gobble the artificial initial EOS */
  2489. }
  2490.  
  2491.  
  2492. void
  2493. finish_scan(VOID)
  2494. {
  2495.         /* clean up if no END statement at EOF */
  2496.     check_seq_header((Token *)NULL);
  2497.         /* print last line if not already done */
  2498.     if(do_list)
  2499.         (void)flush_line_out(line_num);
  2500. }
  2501.  
  2502. #ifdef INLINE_COMMENT_CHAR
  2503.     /* macro is used on next_char: must look at curr_char to avoid
  2504.        being fooled by '!' without messing up on 'xxx'! either.
  2505.        Also don't be fooled by '''!''' which is the string '!'
  2506.        Note that inside_string does not yet reflect curr_char.
  2507.        Test is that inside_string is true but about to become false,
  2508.        or false and not about to become true. Think about it. */
  2509.  
  2510. #define inline_comment(c) ( ((c)==INLINE_COMMENT_CHAR) &&\
  2511.     (inside_string? (curr_char == quote_char) : !isaquote(curr_char)) &&\
  2512.     (!inside_hollerith) )
  2513. #endif
  2514.  
  2515.     /* closeup: Advances input stream till next_char is nonspace.  Fudges
  2516.        things so that curr_char remains as it was. */
  2517. PRIVATE void
  2518. closeup(VOID)
  2519. {
  2520.   int
  2521.     save_curr_char = curr_char,
  2522.     save_prev_char = prev_char,
  2523.     save_line_num = line_num,
  2524.     save_col_num = col_num;
  2525.  
  2526.   while(iswhitespace(next_char))
  2527.     advance();
  2528.  
  2529.   curr_char = save_curr_char;
  2530.   prev_char = save_prev_char;
  2531.   line_num = save_line_num;
  2532.   col_num = save_col_num;
  2533. }
  2534.  
  2535.  
  2536. LEX_SHARED void
  2537. advance(VOID)
  2538. {
  2539. #ifdef EOLSKIP
  2540.     int eol_skip = FALSE;
  2541. #endif
  2542.     prev_char = curr_char;
  2543. #ifdef EOLSKIP
  2544.     do{
  2545. #endif
  2546.     if(next_char == EOF) {      /* Don't advance past EOF */
  2547.         if(curr_char == EOS || curr_char == EOF) {
  2548.  
  2549.              /* Pause to allow parse actions at end of stmt
  2550.                 to have correct file context before popping
  2551.                 the include file.  Effect is to send an extra
  2552.                 EOS to parser at end of file. */
  2553.           if(sticky_EOF) {
  2554.             sticky_EOF = FALSE;
  2555.             return;
  2556.           }
  2557.                 /* At EOF: close include file if any,
  2558.                    otherwise yield an EOF character. */
  2559.           if( ! pop_include_file() ) {
  2560.             curr_char = EOF;
  2561.           }
  2562.           return;
  2563.         }
  2564.         else {
  2565.           curr_char = EOS;
  2566.           return;
  2567.         }
  2568.     }
  2569.  
  2570.     if(curr_char == EOS)
  2571.         initial_flag = TRUE;
  2572.  
  2573. #ifdef EOLSKIP
  2574.     if(! eol_skip) {
  2575. #endif
  2576.         curr_char = next_char;      /* Step to next char of input */
  2577.         col_num = next_col_num;
  2578.         line_num = next_line_num;
  2579.         if(col_num > 72 && !iswhitespace(curr_char)) {
  2580.            line_is_overlength = TRUE;
  2581.          }
  2582. #ifdef EOLSKIP
  2583.     }
  2584. #endif
  2585.  
  2586.     if(next_char == '\t'){       /* Handle tabs in input */
  2587.  
  2588. #ifdef DEC_TABS    /* support for DEC tab formatting */
  2589.         if(dec_tabs && next_col_num < 7) {
  2590.           next_col_num = 7; /* initial DEC tab -> col 7  */
  2591.         }
  2592.         else
  2593. #endif
  2594.         {
  2595.           next_col_num = nxttab[next_col_num];
  2596.         }
  2597.  
  2598.         if( ! (inside_string || inside_hollerith) )
  2599.             if(tab_filename == NULL)
  2600.               tab_filename = current_filename;    /*  for portability warning */
  2601.     }
  2602.     else {
  2603.         next_col_num++;
  2604.     }
  2605.  
  2606.     next_char = line[++next_index];
  2607.  
  2608.             /* If end of line is reached, input a new line.
  2609.              */
  2610.     while(next_col_num > max_stmt_col || next_char == '\0'
  2611. #ifdef INLINE_COMMENT_CHAR
  2612.     || inline_comment(next_char)
  2613. #endif
  2614.     ){
  2615.         do{
  2616.             if(do_list) /* print prev line if not printed yet */
  2617.               (void)flush_line_out(prev_line_num);
  2618.  
  2619.                 /* Warn if stmt field has been extended
  2620.                    and the extended part has been used. */
  2621.             if(!prev_comment_line) {
  2622.               if( ((f77_overlength)
  2623.                    && max_stmt_col>72)
  2624.                  && prev_line_overlength){
  2625.                   nonstandard(prev_line_num,(unsigned)73);
  2626.                   msg_tail(
  2627.                    ": significant characters past 72 columns");
  2628.               }
  2629.                 /* Otherwise warn if any chars past 72 cols */
  2630.               else if(pretty_overlength
  2631.                  && is_overlength(prev_line,MAXLINE)) {
  2632.                    ugly_code(prev_line_num,(unsigned)73,
  2633.                   "characters past 72 columns");
  2634.               }
  2635.             }
  2636. #ifdef INLINE_COMMENT_CHAR
  2637.             if( f77_inline_comment) {
  2638.               if( !curr_comment_line && inline_comment(next_char)){
  2639.                   nonstandard(next_line_num,next_col_num);
  2640.                   msg_tail(": inline comment");
  2641.               }
  2642.             }
  2643. #endif
  2644.  
  2645.                 /* Swap input buffers to get ready for new line.
  2646.                    But throw away comment lines if do_list is
  2647.                    false, so error messages will work right.
  2648.                  */
  2649.             if(do_list || ! curr_comment_line) {
  2650.                 char *temp=line;
  2651.                 line = prev_line;
  2652.                 prev_line=temp;
  2653.                 if(! curr_comment_line)
  2654.                   prev_stmt_line_num = line_num;
  2655.                 prev_line_num = next_line_num;
  2656.                 prev_line_is_printed = line_is_printed;
  2657.                 prev_line_overlength = line_is_overlength;
  2658.                 line_is_overlength = FALSE;
  2659.             }
  2660.  
  2661.             ++next_line_num;
  2662.             line_is_printed = FALSE;
  2663.             if( getstrn(line,MAXLINE+1,input_fd) == NULL ) {
  2664.                 next_char = EOF;
  2665.                 line_is_printed = TRUE;
  2666.                 return;
  2667.             }
  2668. #ifdef ALLOW_UNIX_CPP
  2669.             else
  2670.               if(line[0] == '#')
  2671.                 cpp_handled = take_cpp_line(line);
  2672. #endif
  2673.             ++tot_line_count; /* count lines processed */
  2674.  
  2675.             /*  Keep track of prior-comment-line situation */
  2676.             prev_comment_line = curr_comment_line;
  2677.  
  2678.         } while( (curr_comment_line = is_comment(line)) != FALSE);
  2679.         ++tot_stmt_line_count;
  2680.         ++noncomment_line_count;
  2681.  
  2682.             /* Handle continuation lines */
  2683.         if( is_continuation(line,&next_index,&next_col_num) ) {
  2684.                 /* It is a continuation */
  2685. #ifdef EOLSKIP
  2686.             if(eol_is_space) {
  2687. #endif
  2688.             next_char = EOL;
  2689. #ifdef EOLSKIP
  2690.             }
  2691.             else {
  2692.             next_char = line[++next_index];
  2693.             next_col_num = 7;
  2694.             eol_skip = TRUE; /* skip continued leading space */
  2695.             }
  2696. #endif
  2697.                 /* Issue warnings if contin in funny places */
  2698.             if(noncomment_line_count == 1)
  2699.                 warning(next_line_num,(unsigned)6,
  2700.             "Continuation mark found in first statement of file");
  2701.             if( pretty_contin && prev_comment_line )
  2702.                 ugly_code(next_line_num,(unsigned)6,
  2703.             "Continuation follows comment or blank line");
  2704.             if(contin_count++ == 19)
  2705.               if(f77_20_continue) {
  2706.                 nonstandard(next_line_num,(unsigned)6);
  2707.                 msg_tail(": > 19 continuation lines");
  2708.               }
  2709.         }
  2710.         else {
  2711.                 /* It is not a continuation */
  2712.             next_char = EOS;
  2713.             next_col_num = 0;
  2714.             next_index = -1;
  2715.             contin_count = 0;
  2716.         }
  2717.     }/*end while( end of line reached )*/
  2718.  
  2719.         /* Avoid letting a '0' in column 6 become a token */
  2720.     if(next_col_num == 6 && next_char == '0')
  2721.         next_char = ' ';
  2722.  
  2723. #ifdef EOLSKIP
  2724.             /* elide EOL and following space of continued
  2725.                stmts if requested */
  2726.     eol_skip = (eol_skip && isspace(next_char));
  2727.    }while(eol_skip);/*end do*/
  2728. #endif
  2729.  
  2730. }/* end advance */
  2731.  
  2732.  
  2733.     /*  Function which returns 0 if line is not a comment, 1 if it is.
  2734.      *  Comment is ANSI standard: C or c or * in column 1, or blank line.
  2735.      */
  2736.  
  2737. PRIVATE int
  2738. #if HAVE_STDC
  2739. is_comment(char *s)
  2740. #else /* K&R style */
  2741. is_comment(s)
  2742.     char s[];
  2743. #endif /* HAVE_STDC */
  2744. {
  2745.     int i,c= makeupper(s[0]);
  2746.     unsigned col;
  2747.  
  2748.                 /* Handle standard comments here. */
  2749.     if( c == 'C' || c == '*' )
  2750.         return TRUE;
  2751.  
  2752.                 /* Tolerate D comment lines.  There is
  2753.                    no provision for optionally
  2754.                    treating them as source code lines.
  2755.                  */
  2756.     if( c == 'D' ) {
  2757.         if(f77_d_comment) {
  2758.           nonstandard(next_line_num,1);
  2759.           msg_tail(": D in column 1 (treated as comment)");
  2760.         }
  2761.         return TRUE;
  2762.     }
  2763.  
  2764.                 /* Now see if line is blank or only contains
  2765.                    an inline comment.
  2766.                  */
  2767.     for(i=0,col=1; s[i] != '\0'; i++)
  2768.         if( !isspace(s[i]))
  2769. #ifdef INLINE_COMMENT_CHAR
  2770.         /* Initial "!" starts a comment, except in col. 6 it
  2771.            must be taken as continuation mark */
  2772.              if(s[i]==INLINE_COMMENT_CHAR && col != 6) {
  2773.                  if(f77_inline_comment) {
  2774.                  nonstandard(next_line_num,col);
  2775.                  msg_tail(": inline comment");
  2776.                  }
  2777.                  return TRUE;
  2778.               }
  2779.               else
  2780.                   return FALSE;
  2781.         else
  2782.               if(s[i] == '\t') col = nxttab[col];
  2783.               else           col++;
  2784. #else
  2785.             return FALSE;
  2786. #endif
  2787.     return TRUE;        /* blank line */
  2788. }
  2789.  
  2790.     /* Here we handle Unix preprocessor lines.  The only ones
  2791.        processed now are those that set the line number and filename.
  2792.          Form 1: # line 10 "filename"
  2793.          Form 2: # 10 "filename"
  2794.        We replace next_filename and next_line_num by the
  2795.        given values.
  2796.      */
  2797. #ifdef ALLOW_UNIX_CPP
  2798. PRIVATE int
  2799. #if HAVE_STDC
  2800. take_cpp_line(char *s)
  2801. #else /* K&R style */
  2802. take_cpp_line(s)
  2803.      char *s;
  2804. #endif /* HAVE_STDC */
  2805. {
  2806.   int linenum, nchars, handled;
  2807.   char *filename;
  2808.  
  2809.   handled=FALSE;
  2810.  
  2811.   do { ++s; } while( isspace(*s) );    /* Skip space after the '#' */
  2812.  
  2813.   if(strncmp(s,"line",4) == 0) {    /* Look for the keyword "line" */
  2814.     s += 4;            /* Skip the word "line" */
  2815.     while( isspace(*s) ) ++s;    /* Skip space after the word "line" */
  2816.   }
  2817.  
  2818.   if( isdigit(*s) ) {        /* See that we are now looking at a number */
  2819.     handled = TRUE;
  2820.  
  2821.             /* Get the line number */
  2822.     linenum=0;
  2823.     while( isdigit(*s) )
  2824.       linenum = linenum*10 + BCD(*s++);
  2825.  
  2826.             /* Now find the filename */
  2827.  
  2828.     filename = (char *)NULL;
  2829.     while( isspace(*s) ) ++s;    /* Skip space after the line number */
  2830.  
  2831.     if( *s == '"') {        /* Filename must be preceded by " */
  2832.  
  2833.       ++s;            /* Skip the " */
  2834.  
  2835.       nchars = 0;        /* Count chars in the filename */
  2836.       while( s[nchars] != '"' && s[nchars] != '\0')
  2837.     ++nchars;
  2838.  
  2839.       if( s[nchars] == '"') {    /* Filename must be followed by " */
  2840.  
  2841.     s[nchars] = '\0';/* terminate it temporarily */
  2842.  
  2843.     filename = new_global_string(s); /* put it in permanent space */
  2844.  
  2845.     s[nchars] = '"'; /* restore line as it was */
  2846.  
  2847.       }
  2848.     }
  2849.   }/*end handling #line */
  2850.  
  2851.   if(handled) {
  2852.     next_line_num = linenum-1;
  2853.     next_filename = filename;
  2854.   }
  2855.  
  2856.   return handled;        /* Return TRUE if it was a #line category */
  2857.  
  2858. }/*take_cpp_line*/
  2859. #endif
  2860.  
  2861.     /* Function which returns FALSE if line is a not continuation
  2862.      *  line.  If line is a continuation, returns TRUE.  In either
  2863.      *  case, sets cont_index to index in line of the continuation
  2864.      *  mark and cont_col_num to corresponding column number.  If
  2865.      *  dec_tabs in effect, tab moves to column 7 and a nonzero
  2866.      *  digit there implies continuation.  */
  2867. PRIVATE int
  2868. #if HAVE_STDC
  2869. is_continuation(char *s, int *cont_index, unsigned int *cont_col_num)
  2870. #else /* K&R style */
  2871. is_continuation(s,cont_index,cont_col_num)
  2872.     char s[];
  2873.         int *cont_index;
  2874.     unsigned *cont_col_num;
  2875. #endif /* HAVE_STDC */
  2876. {
  2877.     int col,i,c;
  2878.  
  2879.                 /* Handle DEC tabs: <tab><digit> is a
  2880.                    continuation card */
  2881. #ifdef DEC_TABS
  2882.     if( dec_tabs && s[0] == '\t' ) {
  2883.       if( isadigit((int)s[1]) && s[1] != '0' ) {
  2884.         if(f77_dec_tabs) {
  2885.           nonstandard(next_line_num,7);
  2886.           msg_tail(": continuation mark not in column 6");
  2887.         }
  2888.         (*cont_index) = 1;
  2889.         (*cont_col_num) = 7;
  2890.         return TRUE;
  2891.       }
  2892.       else {        /* Tab then non-digit: regular stmt */
  2893.         (*cont_index) = 0;
  2894.         (*cont_col_num) = 7; /* (not used) */
  2895.         return FALSE;
  2896.       }
  2897.     }
  2898. #endif
  2899.                 /* skip to col 6 */
  2900.     for(i=0,col=1; col < 6 && s[i] != '\0'; i++) {
  2901.         if(s[i] == '\t')
  2902.             col = nxttab[col];
  2903.         else
  2904.             col++;
  2905.     }
  2906.     c = s[i];
  2907.  
  2908.     if ( col == 6 && c != '\0' && !isspace(c) && c != '0'
  2909. #ifdef ALLOW_UNIX_CPP
  2910.                 /* Veto if it is a preprocessor line */
  2911.         && s[0] != '#'
  2912. #endif
  2913.         ) {
  2914.            (*cont_index) = i;
  2915.            (*cont_col_num) = 6;
  2916.            return TRUE;
  2917.     }
  2918.     else {
  2919.            (*cont_index) = 0;
  2920.            (*cont_col_num) = -1; /* (not used) */
  2921.            return FALSE;
  2922.     }
  2923. }
  2924.  
  2925. int
  2926. #if HAVE_STDC
  2927. flush_line_out(unsigned int n)    /* Prints lines up to line #n if not yet printed */
  2928.                        /* Returns TRUE if line was printed, else FALSE */
  2929. #else /* K&R style */
  2930. flush_line_out(n)    /* Prints lines up to line #n if not yet printed */
  2931.     unsigned n;        /* Returns TRUE if line was printed, else FALSE */
  2932. #endif /* HAVE_STDC */
  2933. {
  2934.             /* Print previous line only if do_list TRUE */
  2935.     if( !prev_line_is_printed
  2936.      && ((n == prev_line_num) || (n > prev_line_num && do_list)) ) {
  2937.        print_a_line(list_fd,prev_line,prev_line_num);
  2938.        prev_line_is_printed = TRUE;
  2939.     }
  2940.     if(n >= next_line_num && !line_is_printed) {
  2941.        print_a_line(list_fd,line,next_line_num);
  2942.        line_is_printed = TRUE;
  2943.     }
  2944.     return ( do_list ||
  2945.          (prev_line_is_printed && n == prev_line_num) ||
  2946.          (line_is_printed && n == next_line_num) );
  2947. }
  2948.  
  2949.  
  2950.     /*  Function to read n-1 characters, or up to newline, whichever
  2951.      *  comes first.  Differs from fgets in that the newline is replaced
  2952.      *  by null, and characters up to newline (if any) past the n-1st
  2953.      *  are read and thrown away.
  2954.      *  Returns NULL when end-of-file or error is encountered.
  2955.      */
  2956. PRIVATE char *
  2957. #if HAVE_STDC
  2958. getstrn(char *s, int n, FILE *fd)
  2959. #else /* K&R style */
  2960. getstrn(s,n,fd)
  2961.     char s[];
  2962.     int n;
  2963.     FILE *fd;
  2964. #endif /* HAVE_STDC */
  2965. {
  2966.     int i=0,c;
  2967.  
  2968.     while( (c=getc(fd)) != '\n' ) {
  2969.         if(c == EOF)
  2970.             return NULL;
  2971.  
  2972.         if(i < n-1)
  2973.             s[i++] = c;
  2974.     }
  2975.     s[i] = '\0';
  2976.     return s;
  2977. }
  2978.  
  2979.  
  2980.     /* Functions which look ahead as far as end of line to see if input
  2981.        cursor is sitting at start of a token of the given class.  Used
  2982.        to resolve ambiguities that need more than one token of lookahead.
  2983.        */
  2984.  
  2985. LEX_SHARED int
  2986. looking_at_cplx(VOID)
  2987. {
  2988.     int indx;
  2989.  
  2990.     if( next_char != EOS )    /* Looking at next line already */
  2991.     {
  2992.     indx = next_index;
  2993.  
  2994.     if( (indx = see_a_number(indx,line,FALSE)) < 0 )
  2995.       return FALSE;
  2996.     while(line[indx] != '\0' && isspace(line[indx]))
  2997.       indx++;
  2998.  
  2999.     if( line[indx] != ',' )
  3000.       return FALSE;
  3001.     ++indx;
  3002.  
  3003.     if( (indx = see_a_number(indx,line,FALSE)) < 0 )
  3004.       return FALSE;
  3005.     while(line[indx] != '\0' && isspace(line[indx]))
  3006.       indx++;
  3007.  
  3008.     if(line[indx] != ')')
  3009.       return FALSE;
  3010.     }
  3011.  
  3012.     return TRUE;    /* passed all the tests */
  3013.  
  3014. }
  3015.  
  3016. LEX_SHARED int
  3017. #if HAVE_STDC
  3018. looking_at_keywd(int token_class)
  3019.                         /* Keyword class to be checked out */
  3020. #else /* K&R style */
  3021. looking_at_keywd(token_class)
  3022.     int token_class;    /* Keyword class to be checked out */
  3023. #endif /* HAVE_STDC */
  3024. {
  3025.                 /* Distinguishing identifier from keyword.
  3026.                    If not sure, assumes true.   Ambiguity
  3027.                    must be resolved in current line. */
  3028.     int indx;
  3029.     int c;
  3030.  
  3031.     if( next_char != EOS )    /* Looking at next line already */
  3032.     {
  3033. #ifdef DEBUG_IS_KEYWORD
  3034. if(debug_lexer && getenv("VERBOSE"))
  3035. (void)fprintf(list_fd,"\nlooking_at: curr_char=%c then %c",
  3036. curr_char,line[next_index]);
  3037. #endif
  3038.                 /* Skip over leading
  3039.                    stuff that could be rest of identifier */
  3040.  
  3041.     if(isidletter(curr_char) || isdigit(curr_char) ||
  3042.        isspace(curr_char)){
  3043.       indx = skip_idletters(next_index,line);
  3044.       c = line[indx];    /* Store following character in c */
  3045.       ++indx;   /* Leave index pointing at char after c */
  3046.     }
  3047.     else {
  3048.       c = curr_char;    /* Otherwise next input char is c */
  3049.       indx = next_index;
  3050.     }
  3051.  
  3052. #ifdef DEBUG_IS_KEYWORD
  3053. if(debug_lexer && getenv("VERBOSE"))
  3054. (void)fprintf(list_fd," c=%c then %c",c,line[indx]);
  3055. #endif
  3056.  
  3057.     if(token_class == tok_DO) {
  3058.       int opt_comma = FALSE;
  3059.  
  3060.         /* DO: we must by now have skipped over optional label
  3061.           to optional comma or over optional label and
  3062.           variable name to = sign.  Look for expression and comma.
  3063.           DOWHILE will be found as single keyword, but we have
  3064.           to spot DO label WHILE(expr) here.  DO of END DO
  3065.           is not seen here. */
  3066.  
  3067.       WHILE_expected = FALSE; /* most cases do not use it */
  3068.  
  3069.       if(c == ',' && isdigit(curr_char)) {
  3070.                 /* Skip optional comma after label.
  3071.                    First, back up and check that we saw
  3072.                    only digits so far. Do it here since
  3073.                    this is rare and not worth cluttering
  3074.                    the foregoing code. */
  3075.         int i=next_index;
  3076.         while(isdigit(line[i]) || isspace(line[i]))
  3077.           ++i;
  3078.         if(line[i] != ',')
  3079.           return FALSE;
  3080.                 /* Checks out OK: */
  3081.         indx = skip_idletters(indx,line);    /* skip DO index or WHILE */
  3082.         c = line[indx];
  3083.         ++indx;
  3084.         opt_comma = TRUE;
  3085.       }
  3086.  
  3087.       if(c == '=') {    /* Traditional DO form */
  3088.         indx = see_expression(indx,line);
  3089.         return (indx != -1 && line[indx] == ',') || opt_comma;
  3090.       }
  3091.       else {        /* Nonstandard variants */
  3092.         if(c == '(') {
  3093.                 /* DO label WHILE (expr): rescan from the
  3094.                    word DO to see if it fits. */
  3095.           if( see_dowhile(next_index,line) != -1 )
  3096.         WHILE_expected = TRUE;
  3097.           return WHILE_expected || opt_comma;
  3098.         }
  3099.         else
  3100.           return opt_comma;    /* The comma is found only in DO forms */
  3101.       }
  3102.     }/* end of tok_DO forms */
  3103.  
  3104.         /* Otherwise, look for an assignment statement.  If there
  3105.            is no left paren, then must be an equals sign here
  3106.            if it is an assignment statement. */
  3107.     if(c != '(') {
  3108. #ifdef DEBUG_IS_KEYWORD
  3109. if(debug_lexer && getenv("VERBOSE"))
  3110. (void)fprintf(list_fd,"\n Conclude %s",
  3111.     (c != '=')? "keyword": "assignment stmt");
  3112. #endif
  3113.           return (c != '=');
  3114.     }
  3115.  
  3116.     else {            /* sitting at parenthesis */
  3117.  
  3118.         /* Skip to end of balancing parenthesis. Then if = sign, it
  3119.            must be an assignment statement.  If ( is found,
  3120.            presumably it is an array substring assignment. So skip
  3121.            once more to check for the = sign.) */
  3122.  
  3123.  
  3124.     indx = skip_balanced_parens(indx,line);
  3125.  
  3126. #ifdef DEBUG_IS_KEYWORD
  3127. if(debug_lexer && getenv("VERBOSE"))
  3128. (void)fprintf(list_fd," to %c",line[indx]);
  3129. #endif
  3130.  
  3131.     if(line[indx] == '(') {
  3132.       ++indx;        /* Move past the paren */
  3133.       indx = skip_balanced_parens(indx,line);
  3134.  
  3135. #ifdef DEBUG_IS_KEYWORD
  3136. if(debug_lexer && getenv("VERBOSE"))
  3137. (void)fprintf(list_fd," to %c",line[indx]);
  3138. #endif
  3139.  
  3140.     }
  3141.  
  3142. #ifdef DEBUG_IS_KEYWORD
  3143. if(debug_lexer && getenv("VERBOSE"))
  3144. (void)fprintf(list_fd," conclude %s",line[indx]!= '='?"keyword":"variable");
  3145. #endif
  3146.  
  3147.     return (line[indx] != '=');
  3148.       }
  3149.     }
  3150.                 /* End of line: must be a keyword */
  3151.     return TRUE;
  3152.  
  3153. }/*looking_at_keywd*/
  3154.  
  3155.         /* This guy is called when an integer is followed by '.'
  3156.            in cases where a real number or expression is allowed.
  3157.            When an integer is followed by .E, it can either be a real
  3158.            like 1.E10, or a comparison like (1.EQ.I).  This requires
  3159.            looking for the 'Q' after the 'E'.  The other cases,
  3160.            like ... 1.AND. ... are resolved by looking at next_char
  3161.            to see if it is the 'D' of a d.p. constant or not.
  3162.           */
  3163. LEX_SHARED int
  3164. looking_at_relop(VOID)
  3165. {
  3166.     int indx;
  3167.     int c;
  3168.  
  3169.  
  3170.     if( next_char != EOS )    /* Looking at next line already */
  3171.     {
  3172.  
  3173. #if 0                /* With closeup() this is no longer valid */
  3174.     if( eol_is_space && line_num != next_line_num )
  3175.     return FALSE;    /* Looking at next line already */
  3176. #endif
  3177.     indx = next_index;/* Start at next_char */
  3178.  
  3179.     while( (c=line[indx]) != '\0' && isspace(c))
  3180.       ++indx;
  3181.  
  3182.     if( !isaletter( c ) )    /* next char must be letter */
  3183.         return FALSE;
  3184.     c = makeupper(c);
  3185.     if( c == 'D' )    /* D.P. exponent */
  3186.       return FALSE;    /* No dotted keywords start with D */
  3187.     if( c == 'Q' )    /* Q.P. exponent */
  3188.       return FALSE;    /* No dotted keywords start with Q */
  3189.  
  3190.             /* If next char is any other letter but 'E', cannot be
  3191.                 exponent.  If it is 'E', must be EQ or EQV to
  3192.                 be a relop.  So look ahead for the 'Q'. */
  3193.     else if( c == 'E' ) {
  3194.       do {
  3195.         ++indx;
  3196.       } while( (c=line[indx]) != '\0' && isspace(c));
  3197.  
  3198.       c = makeupper(c);
  3199.       return (c == 'Q');
  3200.     }
  3201.     else        /* Next char not D or E: must be a dotted keyword */
  3202.       return TRUE;
  3203.     }
  3204.                 /* If EOS, then it is stmt like x=1. */
  3205.     return FALSE;
  3206.  
  3207. }
  3208.  
  3209.     /* see_a_number returns -1 if there is no valid numeric constant
  3210.        in string s starting at index i.  If valid number found, it
  3211.        returns the index of the next character after the constant.
  3212.        Leading whitespace in s is skipped.*/
  3213.  
  3214.  
  3215. #define SKIP_SPACE    while(s[i] != '\0' && isspace(s[i])) i++
  3216.  
  3217. PRIVATE int
  3218. #if HAVE_STDC
  3219. see_a_number(int i, char *s, int can_be_holl)
  3220.                    /* context indication */
  3221. #else /* K&R style */
  3222. see_a_number(i,s,can_be_holl)
  3223.    int i;
  3224.    char s[];
  3225.    int can_be_holl;/* context indication */
  3226. #endif /* HAVE_STDC */
  3227. {
  3228.    int digit_seen = FALSE;
  3229.    int isave;
  3230.    while(s[i] != '\0' && isspace(s[i]))
  3231.      i++;
  3232.  
  3233.             /* move past optional preceding sign */
  3234.    if(s[i] == '-' || s[i] == '+' ) {
  3235.      i++;
  3236.      SKIP_SPACE;
  3237.      can_be_holl = FALSE;
  3238.    }
  3239.    isave=i;
  3240.  
  3241.         /* move past ddd or ddd. or .ddd or ddd.ddd */
  3242.    if(isdigit(s[i]))
  3243.      digit_seen = TRUE;
  3244.    while(isdigit(s[i])) {
  3245.      i++;
  3246.      SKIP_SPACE;
  3247.    }
  3248.    if(s[i] == 'H' && can_be_holl) {
  3249.      return skip_hollerith(isave,s);
  3250.    }
  3251.    if(s[i] == '.') {
  3252.      i++;
  3253.      SKIP_SPACE;
  3254.      if(isdigit(s[i]))
  3255.        digit_seen = TRUE;
  3256.      while(isdigit(s[i])) {
  3257.        i++;
  3258.        SKIP_SPACE;
  3259.      }
  3260.    }
  3261.  
  3262.         /* no digits seen: bail out now */
  3263.    if(! digit_seen)
  3264.      return -1;
  3265.  
  3266.         /* look for exponential part.  The standard does not
  3267.            allow D or Q, but we will, just in case. */
  3268.    if(makeupper(s[i]) == 'E' || makeupper(s[i]) == 'D' ||
  3269.       makeupper(s[i]) == 'Q') {
  3270.      i++;
  3271.      SKIP_SPACE;
  3272.      if(s[i] == '+' || s[i] == '-') {
  3273.        i++;
  3274.        SKIP_SPACE;
  3275.      }
  3276.      if(!isdigit(s[i]))
  3277.        return -1;
  3278.      while(isdigit(s[i]) || isspace(s[i]))
  3279.        i++;
  3280.    }
  3281.  
  3282.    return i;
  3283. }/*see_a_number*/
  3284.  
  3285.     /* see_dowhile returns TRUE only if the stuff following the initial
  3286.        DO is a label and the word WHILE followed by a parenthesized expr.
  3287.        If not resolved on current line, assumes TRUE (how many arrays
  3288.        are named DO10WHILE?).  The "DO WHILE" form is not handled
  3289.        here so that DOWHILE will be gotten as a single token later.
  3290.      */
  3291. PRIVATE int
  3292. #if HAVE_STDC
  3293. see_dowhile(int indx, char *ll)
  3294. #else /* K&R style */
  3295. see_dowhile(indx,ll)
  3296.      int indx;
  3297.      char ll[];
  3298. #endif /* HAVE_STDC */
  3299. {
  3300.     int c;
  3301.                 /* Skip over the label */
  3302.     while(isdigit(c=ll[indx]) || isspace(c) )
  3303.       ++indx;
  3304.  
  3305.     if(c == ',')        /* Skip optional comma */
  3306.       ++indx;
  3307.  
  3308.     indx = see_keyword(indx,ll,"WHILE");
  3309.  
  3310.     if( indx == -1 || ll[indx] != '(')  /* Look for the opening paren */
  3311.       return -1;
  3312.  
  3313.     ++indx;            /* skip the opening paren */
  3314.     indx = skip_balanced_parens(indx,ll);
  3315.                 /* Only = sign can follow the parens if this
  3316.                   is not a do-while. */
  3317.     return (ll[indx] != '=')? indx: -1;
  3318. }/*see_dowhile*/
  3319.  
  3320.  
  3321.     /* Crude routine to scan forward past arithmetic expressions.
  3322.        Function invocations and array or character elements will
  3323.        have their parentheses skipped by skip_balanced_parens;
  3324.        outside parens a comma will cause a halt.  Returns the index
  3325.        of the nonblank character following the expression, or
  3326.        -1 if something non-kosher was found (e.g. a faulty number)
  3327.        It can be confused by holleriths containing significant
  3328.        characters, i.e. ( ) ' !  and occurring outside parentheses.
  3329.      */
  3330. PRIVATE int
  3331. #if HAVE_STDC
  3332. see_expression(int indx, char *ll)
  3333. #else /* K&R style */
  3334. see_expression(indx,ll)
  3335.      int indx;
  3336.      char ll[];
  3337. #endif /* HAVE_STDC */
  3338. {
  3339.     int c;
  3340.     while(indx != -1 && (c=ll[indx]) != '=' && c != '\0') {
  3341.     if(isidletter(c))
  3342.       indx = skip_idletters(indx,ll);
  3343.     else if(isdigit(c))
  3344.       indx = see_a_number(indx,ll,TRUE);
  3345.     else if(isspace(c))
  3346.       ++indx;
  3347.     else if(c == '(')
  3348.       indx = skip_balanced_parens(indx+1,ll);
  3349.     else if(c == '+' || c == '-' || c == '/' || c == '*' || c == '.')
  3350.       ++indx;
  3351.     else if(c == '\'')    /* embedded strings confuse things */
  3352.       indx = skip_quoted_string(indx+1,ll);
  3353.     else break;
  3354.     }
  3355.     return indx;
  3356. }/*see_expression*/
  3357.  
  3358.     /* see_keyword returns -1 if the line (ignoring blanks and
  3359.        uppercasing alphabetics) does not match the given string
  3360.        matchstr.  If it does match, returns index of next nonspace
  3361.        character. Note that index must be at start of keyword. */
  3362.  
  3363. PRIVATE int
  3364. #if HAVE_STDC
  3365. see_keyword(int indx, char *ll, char *matchstr)
  3366. #else /* K&R style */
  3367. see_keyword(indx,ll,matchstr)
  3368.      int indx;
  3369.      char ll[];
  3370.      char *matchstr;
  3371. #endif /* HAVE_STDC */
  3372. {
  3373.     int c;
  3374.     while(*matchstr != 0 && (c=ll[indx]) != '\0') {
  3375.       if(! isspace(c) ) {
  3376.     if(makeupper(c) != *matchstr++)
  3377.       return -1;
  3378.       }
  3379.       ++indx;
  3380.     }
  3381.     if(*matchstr == '\0') {    /* Match found */
  3382.       while(isspace(ll[indx]))
  3383.     ++indx;
  3384.       return indx;
  3385.     }
  3386.     else            /* No match */
  3387.       return -1;
  3388. }/*see_keyword*/
  3389.  
  3390.         /* skip_balanced_parens returns index of the nonspace character
  3391.            following the closing ')' that balances the opening
  3392.            '(' preceding ll[indx], or of final nul if the
  3393.            parentheses are not balanced within the line.
  3394.         */
  3395. PRIVATE int
  3396. #if HAVE_STDC
  3397. skip_balanced_parens(int indx, char *ll)
  3398. #else /* K&R style */
  3399. skip_balanced_parens(indx,ll)
  3400.      int indx;
  3401.      char ll[];
  3402. #endif /* HAVE_STDC */
  3403. {
  3404.   int depth=1;        /* nesting depth in parens */
  3405.   int prevchar = '+';    /* arbitrary punctuation */
  3406. #ifdef DEBUG_IS_KEYWORD
  3407. if(debug_lexer && getenv("VERBOSE"))
  3408. (void)fprintf(list_fd,"\nskipping ()...");
  3409. #endif
  3410.  
  3411.   while(ll[indx] != '\0' && depth > 0) {
  3412. #ifdef INLINE_COMMENT_CHAR
  3413.     if(ll[indx] == INLINE_COMMENT_CHAR) /* inline comment ends line */
  3414.       break;
  3415. #endif
  3416.     if(ll[indx] == '\'') {    /* embedded strings confuse things */
  3417.       indx = skip_quoted_string(indx+1,ll);
  3418.       prevchar = 'X';    /* Arbitrary non punctuation */
  3419.     }
  3420.     else if(ispunct(prevchar) && isdigit(ll[indx])) {
  3421.       indx = skip_hollerith(indx,ll); /* Skip hollerith or number */
  3422.       prevchar = ll[indx];
  3423.     }
  3424.     else {
  3425.                 /* Keep track of nesting */
  3426.       if     (ll[indx] == '(') ++depth;
  3427.       else if(ll[indx] == ')') --depth;
  3428.  
  3429.       if(! isspace(ll[indx]) )
  3430.     prevchar = ll[indx];
  3431.  
  3432.       ++indx;
  3433.     }
  3434.   }
  3435.  
  3436.                 /* We are now past the closing paren */
  3437.   while(ll[indx] != '\0' && isspace(ll[indx]))
  3438.     indx++;        /* skip trailing space */
  3439.  
  3440.   return indx;
  3441. }/*skip_balanced_parens*/
  3442.  
  3443.  
  3444.         /* skip_idletters returns index of the nonspace character
  3445.            following a string of idletters: alphabetic characters
  3446.            or digits, or underscore or dollar if those options are
  3447.            enabled.  It does not look out for hollerith constants.
  3448.         */
  3449. PRIVATE int
  3450. #if HAVE_STDC
  3451. skip_idletters(int indx, char *ll)
  3452. #else /* K&R style */
  3453. skip_idletters(indx,ll)
  3454.      int indx;
  3455.      char ll[];
  3456. #endif /* HAVE_STDC */
  3457. {
  3458.     int c;
  3459. #ifdef DEBUG_IS_KEYWORD
  3460. if(debug_lexer && getenv("VERBOSE"))
  3461. (void)fprintf(list_fd,": skipping letters...");
  3462. #endif
  3463.     while(isidletter(c=ll[indx])
  3464.           || isadigit(c) || isspace(c))
  3465.       ++indx;
  3466.     return indx;
  3467. }/*skip_idletters*/
  3468.  
  3469.         /* Returns index of nonspace character following
  3470.            quote mark that closes string whose opening quote
  3471.            mark is before index. */
  3472. PRIVATE int
  3473. #if HAVE_STDC
  3474. skip_quoted_string(int indx, char *ll)
  3475. #else /* K&R style */
  3476. skip_quoted_string(indx,ll)
  3477.      int indx;
  3478.      char ll[];
  3479. #endif /* HAVE_STDC */
  3480. {
  3481.   while(ll[indx] != '\0') {
  3482.     if(ll[indx] == '\'') {    /* Closing quote? */
  3483.       if(ll[++indx] != '\'') /* Quoted quote? */
  3484.     break;
  3485.     }
  3486.     ++indx;
  3487.   }
  3488.  
  3489.                 /* We are now past the closing quote mark */
  3490.   while(ll[indx] != '\0' && isspace(ll[indx]))
  3491.     indx++;        /* skip trailing space */
  3492.  
  3493.   return indx;
  3494. }/*skip_quoted_string*/
  3495.  
  3496.  
  3497.             /* Skips holleriths.  Note: treats tabs within
  3498.                hollerith as single characters. */
  3499. PRIVATE int
  3500. #if HAVE_STDC
  3501. skip_hollerith(int i, char *s)
  3502. #else /* K&R style */
  3503. skip_hollerith(i,s)
  3504.    int i;
  3505.    char s[];
  3506. #endif /* HAVE_STDC */
  3507. {
  3508.   int len=0;
  3509.   while(isdigit(s[i])) {
  3510.     len = len*10 + BCD(s[i]);
  3511.     i++;
  3512.     SKIP_SPACE;
  3513.   }
  3514. #ifdef DEBUG_IS_KEYWORD
  3515. if(debug_lexer && getenv("VERBOSE"))
  3516.   (void)fprintf(list_fd,"\nskip_hollerith: %d then %c:",
  3517. len,s[i]);
  3518. #endif
  3519.   if(makeupper(s[i]) != 'H')
  3520.     return i;
  3521.  
  3522.   i++;                /* Skip the 'H' */
  3523.  
  3524.   while(s[i] != '\0' && len > 0){ /* Move forward len characters */
  3525.  
  3526. #ifdef DEBUG_IS_KEYWORD
  3527. if(debug_lexer && getenv("VERBOSE"))
  3528.   (void)fprintf(list_fd,"%c",s[i]);
  3529. #endif
  3530.     --len; i++;
  3531.   }
  3532. #ifdef DEBUG_IS_KEYWORD
  3533. if(debug_lexer && getenv("VERBOSE"))
  3534.   (void)fprintf(list_fd," to %c",s[i]);
  3535. #endif
  3536.   return i;
  3537. }/*skip_hollerith*/
  3538.  
  3539.  
  3540. PRIVATE int
  3541. #if HAVE_STDC
  3542. is_overlength(char *s, int maxcol)    /* checks line for having nonblanks past col 72 */
  3543.                     /* The line to check */
  3544.                        /* Max columns to check to */
  3545. #else /* K&R style */
  3546. is_overlength(s,maxcol)    /* checks line for having nonblanks past col 72 */
  3547.     char *s;        /* The line to check */
  3548.     int maxcol;        /* Max columns to check to */
  3549. #endif /* HAVE_STDC */
  3550. {
  3551.     int i=0,col=1;
  3552.  
  3553. #ifdef DEC_TABS    /* support for DEC tab formatting */
  3554.     if(dec_tabs && s[i] == '\t') {
  3555.       ++i;
  3556.       if( isadigit((int)s[i]) )
  3557.         col = 6; /* continuation column */
  3558.       else
  3559.         col = 7; /* start of statement */
  3560.     }
  3561. #endif
  3562.  
  3563.     for( ; col<=maxcol && s[i] != '\0'; i++) {
  3564.             /* Inline comments are allowed to run past 72
  3565.                columns without complaint.  The following test
  3566.                will be fooled by ! in quote or hollerith, but
  3567.                it isn't worth the trouble to catch those.  */
  3568. #ifdef INLINE_COMMENT_CHAR
  3569.         if(col != 6 && s[i] == INLINE_COMMENT_CHAR)
  3570.           return FALSE;
  3571. #endif
  3572.         if(col > 72 && !isspace(s[i]))
  3573.         return TRUE;
  3574.  
  3575.             /* Count columns taking tabs into consideration */
  3576.         if(s[i] == '\t')
  3577.         col = nxttab[col];
  3578.         else
  3579.         ++col;
  3580.     }
  3581.     return FALSE;
  3582. }/*is_overlength*/
  3583.  
  3584. /* End of module Advance */
  3585.