home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / fchk294s.zip / ftnchek-2.9.4 / fortran.y < prev    next >
Text File  |  1996-09-13  |  73KB  |  3,188 lines
  1. /*
  2.     fortran.y:
  3.  
  4.       Yacc grammar for Fortran program checker.  Uses the yylex()
  5.       in file FORLEX.C
  6.  
  7. */
  8.  
  9. %{
  10.  
  11. /*
  12.   fortran.c:
  13.  
  14.     Copyright (C) 1992 by Robert K. Moniot.
  15.     This program is free software.  Permission is granted to
  16.     modify it and/or redistribute it.  There is no warranty
  17.     for this program.
  18.  
  19.  
  20.         This grammar is ANSI standard-conforming, except for:
  21.         -- complex constant and a few other ambiguities needing
  22.            significant lookahead cannot be split across lines.
  23.  
  24.         Extensions supported:
  25.             -- Case insensitive.
  26.          -- Hollerith constants.
  27.         -- Variable names may be longer than 6 characters.  Also
  28.            allows underscores and dollar signs in names.
  29.         -- DO ... ENDDO and DO WHILE loop forms allowed.
  30.         -- NAMELIST supported.
  31.         -- TYPE and ACCEPT I/O statements allowed.
  32.         -- Tabs are permitted in input, and (except in character data)
  33.            expand into blanks up to the next column equal to 1 mod 8.
  34.         -- Type declarations INTEGER*2, REAL*8, etc. are allowed.
  35.         -- IMPLICIT NONE allowed.
  36.      */
  37.  
  38. /*  Author: R. Moniot
  39.  *  Date:   August 1988
  40.  *  Last revision: July 1993
  41.  */
  42.  
  43. #include <stdio.h>
  44. #include <string.h>
  45. #include <ctype.h>
  46. #include "ftnchek.h"
  47. #include "symtab.h"
  48.  
  49.     /* The following section is for use with bison-derived
  50.        parser.  Define alloca to be malloc for those cases
  51.        not covered by the cases covered there.  The ifdefs
  52.        are those in the skeleton parser with includes removed */
  53. #ifdef AIXC    /* IBM RS/6000 xlc compiler does it this way */
  54. #pragma alloca
  55. #endif
  56. #ifndef alloca
  57. #ifdef __GNUC__
  58. #else /* Not GNU C.  */
  59. #if (!defined (__STDC__) && defined (sparc)) || defined (__sparc__)
  60. #else /* Not sparc */
  61. #ifdef MSDOS
  62. #endif /* MSDOS */
  63. #endif /* Not sparc.  */
  64. #endif /* Not GNU C.  */
  65. #define alloca malloc
  66. #endif /* alloca now defined.  */
  67.  
  68. #ifndef YYDEBUG    /* If not declared otherwise... */
  69. int yydebug;    /* declare yydebug to satisfy extern in ftnchek.c */
  70. #ifdef DEVELOPMENT
  71. #define YYDEBUG 1        /* For development it is handy */
  72. #else
  73. #define YYDEBUG 0
  74. #endif
  75. #endif
  76.  
  77. #ifdef DEVELOPMENT
  78. #define DEBUG_PARSER
  79. #endif
  80.  
  81. PRIVATE int current_datatype,    /* set when parse type_name or type_stmt */
  82.     current_size_is_adjustable, /* set in CHARACTER declarations */
  83.     current_size_is_expression, /* set in CHARACTER declarations */
  84.     control_item_count;    /* count of items in control_info_list */
  85. int io_internal_file,    /* Flag for catching misuse of internal files */
  86.     io_list_directed,    /* Flag for use in processing io control lists */
  87.     io_warning_given;        /* to prevent multiple warnings */
  88.             /* Flag shared with forlex for lexing hints */
  89. int stmt_sequence_no;   /* set when parsing, reset to 0 at end_stmt */
  90.  
  91. PRIVATE long current_typesize;    /* for type*len declarations: value of len */
  92. PRIVATE char *current_len_text;    /* for type*len declarations: text of len */
  93.  
  94. PRIVATE Token save_token;    /* Holds token shared by productions */
  95.  
  96. extern unsigned prev_stmt_line_num; /* shared with advance */
  97.  
  98. unsigned true_prev_stmt_line_num;    /* shared with symtab.c */
  99.  
  100. PRIVATE int
  101.     current_module_hash = -1,    /* hashtable index of current module name */
  102.     current_module_type,
  103.     executable_stmt=FALSE,
  104.     prev_stmt_class=0,         /* flags for lexer */
  105.     prev_goto=FALSE,
  106.     goto_flag=FALSE;    /* if unconditional GOTO was encountered */
  107.  
  108. int 
  109.     complex_const_allowed=FALSE, /* for help in lookahead for these */
  110.     in_assignment_stmt=FALSE,
  111.     inside_format=FALSE,    /* when inside parens of FORMAT  */
  112.     integer_context=FALSE;    /* says integers-only are to follow */
  113.  
  114.                 /* Defns of private functions */
  115.  
  116. PROTO(PRIVATE Token * add_tree_node,( Token *node, Token *left, Token *right ));
  117. PROTO(PRIVATE Token * append_token,( Token *tlist, Token *t ));
  118. PROTO(PRIVATE void check_stmt_sequence,( Token *t, int seq_num ));
  119. PROTO(PRIVATE void do_binexpr,( Token *l_expr, Token *op, Token *r_expr,
  120.             Token *result ));
  121. PROTO(PRIVATE int do_bounds_type,( Token *t1, Token *t2, Token *t3 ));
  122. PROTO(PRIVATE void do_unexpr,( Token *op, Token *expr, Token *result ));
  123. PROTO(PRIVATE Token * empty_token,( Token *t ));
  124. PROTO(PRIVATE void END_processing,( Token *t ));
  125. PROTO(PRIVATE void init_io_ctrl_list,( void ));
  126. #ifdef DEBUG_PARSER
  127. PROTO(PRIVATE void print_exprlist,( char *s, Token *t ));
  128. PROTO(PRIVATE void print_comlist,( char *s, Token *t ));
  129. #endif
  130.  
  131.         /* Uses of Token fields for nonterminals: */
  132. /* NOTE: As of Aug 1994 these are undergoing revision to separate the
  133.          use of class, subclass fields */
  134. /*
  135.   1. dim_bound_lists: dimensioning info for arrays:
  136.        token.class = no. of dimensions,  --> TOK_dims
  137.        token.subclass = no. of elements  --> TOK_elts
  138.   2. expressions
  139.        token.value.integer = hash index (of identifier)
  140.        token.class = type_byte = storage_class << 4 + datatype  --> TOK_type
  141.        token.subclass = flags: CONST_EXPR, LVALUE_EXPR, etc.    --> TOK_flags
  142.   3. common variable lists
  143.        token.subclass = flag: COMMA_FLAG used to handle extra/missing commas
  144.                                 --> TOK_flags
  145.   4. substring_interval
  146.        token.class = start index  --> TOK_start
  147.        token.subclass = end index --> TOK_end
  148. */
  149.  
  150.  
  151. %}
  152.  
  153. %token tok_identifier
  154. %token tok_array_identifier
  155. %token tok_label
  156. %token tok_integer_const
  157. %token tok_real_const
  158. %token tok_dp_const
  159. %token tok_quad_const
  160. %token tok_complex_const
  161. %token tok_dcomplex_const
  162. %token tok_logical_const
  163. %token tok_string
  164. %token tok_hollerith
  165. %token tok_edit_descriptor
  166. %token tok_letter
  167. %token tok_relop    /* .EQ. .NE. .LT. .LE. .GT. .GE. */
  168. %token tok_AND
  169. %token tok_OR
  170. %token tok_EQV
  171. %token tok_NEQV
  172. %token tok_NOT
  173. %token tok_power    /*   **   */
  174. %token tok_concat    /*   //   */
  175. %token tok_ACCEPT
  176. %token tok_ASSIGN
  177. %token tok_BACKSPACE
  178. %token tok_BLOCK
  179. %token tok_BLOCKDATA
  180. %token tok_BYTE
  181. %token tok_CALL
  182. %token tok_CHARACTER
  183. %token tok_CLOSE
  184. %token tok_COMMON
  185. %token tok_COMPLEX
  186. %token tok_CONTINUE
  187. %token tok_DATA
  188. %token tok_DIMENSION
  189. %token tok_DO
  190. %token tok_DOUBLE
  191. %token tok_DOUBLECOMPLEX
  192. %token tok_DOUBLEPRECISION
  193. %token tok_DOWHILE
  194. %token tok_ELSE
  195. %token tok_ELSEIF
  196. %token tok_END
  197. %token tok_ENDDO
  198. %token tok_ENDFILE
  199. %token tok_ENDIF
  200. %token tok_ENTRY
  201. %token tok_EQUIVALENCE
  202. %token tok_EXTERNAL
  203. %token tok_FILE
  204. %token tok_FORMAT
  205. %token tok_FUNCTION
  206. %token tok_GO
  207. %token tok_GOTO
  208. %token tok_IF
  209. %token tok_IMPLICIT
  210. %token tok_INCLUDE
  211. %token tok_INQUIRE
  212. %token tok_INTEGER
  213. %token tok_INTRINSIC
  214. %token tok_LOGICAL
  215. %token tok_NAMELIST
  216. %token tok_NONE
  217. %token tok_OPEN
  218. %token tok_PARAMETER
  219. %token tok_PAUSE
  220. %token tok_POINTER
  221. %token tok_PRECISION
  222. %token tok_PRINT
  223. %token tok_PROGRAM
  224. %token tok_READ
  225. %token tok_REAL
  226. %token tok_RETURN
  227. %token tok_REWIND
  228. %token tok_SAVE
  229. %token tok_STOP
  230. %token tok_SUBROUTINE
  231. %token tok_THEN
  232. %token tok_TO
  233. %token tok_TYPE
  234. %token tok_WHILE
  235. %token tok_WRITE
  236.  
  237. %token tok_illegal  /* Illegal token unused in grammar: induces syntax error */
  238.  
  239. %token tok_empty    /* For empty tokens used to fill gaps in expr trees */
  240.  
  241. %token EOS    127    /* Character for end of statement.  */
  242.  
  243. %nonassoc tok_relop
  244.  
  245. %left REDUCE ')'    /* Used at unit_io to force a reduction */
  246.  
  247.  
  248. %%
  249.     /*  The following grammar is based on the ANSI manual, diagrams
  250.      *  of section F.  Numbers in the comments refer to the diagram
  251.      *  corresponding to the grammar rule.
  252.      */
  253.  
  254.  
  255. /* 1-5 */
  256.  
  257. prog_body    :    stmt_list
  258.         |    /* empty file */
  259.         ;
  260.  
  261. stmt_list    :    stmt_list_item
  262.         |    stmt_list stmt_list_item
  263.         ;
  264.  
  265.  
  266. stmt_list_item    :    ordinary_stmt
  267.             {
  268.                 /* Create id token for prog if unnamed. */
  269.               if(current_module_hash == -1) {
  270.                 implied_id_token(&($1),unnamed_prog);
  271.                 def_function(
  272.                      type_PROGRAM,    /* type */
  273.                      size_DEFAULT,    /* size */
  274.                      (char *)NULL,    /* size text */
  275.                      &($1),        /* name */
  276.                      (Token*)NULL);    /* args */
  277.                 current_module_hash =
  278.                   def_curr_module(&($1));
  279.                 current_module_type = type_PROGRAM;
  280.               }
  281.  
  282.                     /* Handle END statement */
  283.               if(curr_stmt_class == tok_END) {
  284.                 if(prev_stmt_class != tok_RETURN)
  285.                   do_RETURN(current_module_hash,&($1));
  286.                 END_processing(&($$));
  287.                 goto_flag = prev_goto = FALSE;
  288.               }
  289.               prev_stmt_class = curr_stmt_class;
  290.               integer_context = FALSE;
  291.               true_prev_stmt_line_num = $$.line_num;
  292.             }
  293.          |    include_stmt
  294.         |    EOS    /* "sticky" EOF for needed delay */
  295.         ;
  296.  
  297.             /* Statements: note that ordering by category
  298.                of statement is not enforced in the grammar
  299.                but is deferred to semantic processing.
  300.              */
  301.  
  302. ordinary_stmt    :    stmt
  303.         |    end_stmt
  304.         ;
  305.  
  306. stmt        :    tok_label unlabeled_stmt
  307.             {
  308. #ifdef CHECK_LABELS
  309.               def_label(&($1));
  310. #endif
  311.               if(executable_stmt)
  312.                 prev_goto = goto_flag;
  313.             }
  314.         |    unlabeled_stmt
  315.             {
  316.               if(executable_stmt) {
  317.                 if(prev_goto)
  318.                 syntax_error($1.line_num, NO_COL_NUM,
  319.                     "No path to this statement");
  320.                 prev_goto = goto_flag;
  321.               }
  322.             }
  323.         ;
  324.  
  325. unlabeled_stmt    :    subprogram_header
  326.             {
  327.                 exec_stmt_count = 0;
  328.                 executable_stmt = FALSE;
  329.             }
  330.         |    specification_stmt
  331.             {
  332.                 executable_stmt = FALSE;
  333.             }
  334.         |    executable_stmt
  335.             {    /* handle statement functions correctly */
  336.               if(is_true(STMT_FUNCTION_EXPR, $1.TOK_flags)
  337.                      && stmt_sequence_no <= SEQ_STMT_FUN) {
  338.                 stmt_sequence_no = SEQ_STMT_FUN;
  339.                 executable_stmt = FALSE;
  340.               }
  341.               else {
  342.                 stmt_sequence_no = SEQ_EXEC;
  343.                 ++exec_stmt_count;
  344.                 executable_stmt = TRUE;
  345.               }
  346.             }
  347.         |    restricted_stmt
  348.             {
  349.                 stmt_sequence_no = SEQ_EXEC;
  350.                 ++exec_stmt_count;
  351.                 executable_stmt = TRUE;
  352.             }
  353.         |    error EOS
  354.             {
  355.                 executable_stmt = TRUE;
  356.                 if(stmt_sequence_no == 0)
  357.                   stmt_sequence_no = SEQ_HEADER;
  358.                 complex_const_allowed = FALSE; /* turn off flags */
  359.                 inside_format=FALSE;
  360.                 integer_context = FALSE;
  361.                 in_assignment_stmt = FALSE;
  362.                 $$.line_num = prev_stmt_line_num; /* best guess */
  363.                 yyerrok; /* (error message already given) */
  364.             }
  365.         ;
  366.  
  367. subprogram_header:    prog_stmt
  368.             {
  369.                 current_module_type = type_PROGRAM;
  370.             }
  371.         |    function_stmt
  372.             {
  373.                 current_module_type = type_SUBROUTINE;
  374.             }
  375.         |    subroutine_stmt
  376.             {
  377.                 current_module_type = type_SUBROUTINE;
  378.             }
  379.         |    block_data_stmt
  380.             {
  381.                 current_module_type = type_BLOCK_DATA;
  382.             }
  383.         ;
  384.  
  385. end_stmt    :    unlabeled_end_stmt
  386.         |    tok_label unlabeled_end_stmt
  387.         ;
  388.  
  389. unlabeled_end_stmt:    tok_END EOS
  390.         ;
  391.  
  392. include_stmt    :    tok_INCLUDE tok_string EOS
  393.              {
  394. #ifdef ALLOW_INCLUDE
  395.               if(f77_include) {
  396.                   nonstandard($1.line_num,$1.col_num);
  397.               }
  398.                open_include_file($2.value.string,$1.line_num);
  399. #else
  400.               syntax_error($1.line_num,$1.col_num,
  401.                 "statement not permitted");
  402. #endif
  403.              }
  404.          ;
  405.  
  406. /* 5,6 */
  407.         /* Note that stmt_function_stmt is not distinguished from
  408.            assignment_stmt, but assign (label to variable) is.
  409.            Also, format_stmt w/o label is accepted here.
  410.            ANSI standard for statement sequencing is enforced here. */
  411. specification_stmt:    anywhere_stmt
  412.             {
  413.                  if(stmt_sequence_no < SEQ_IMPLICIT) {
  414.                 stmt_sequence_no = SEQ_IMPLICIT;
  415.                  }
  416.             }
  417.         |    parameter_stmt
  418.             {
  419.                  if(stmt_sequence_no < SEQ_IMPLICIT) {
  420.                    stmt_sequence_no = SEQ_IMPLICIT;
  421.                  }
  422.                  else if(stmt_sequence_no > SEQ_SPECIF) {
  423.                    check_stmt_sequence(&($1),SEQ_SPECIF);
  424.                  }
  425.             }
  426.         |    implicit_stmt
  427.             {
  428.               check_stmt_sequence(&($1),SEQ_IMPLICIT);
  429.             }
  430.         |    data_stmt
  431.             {
  432.                  if(stmt_sequence_no < SEQ_STMT_FUN) {
  433.                 stmt_sequence_no = SEQ_STMT_FUN;
  434.                   }
  435.             }
  436.         |    specif_stmt
  437.             {
  438.               check_stmt_sequence(&($1),SEQ_SPECIF);
  439.             }
  440.         ;
  441.  
  442. anywhere_stmt    :    entry_stmt
  443.             {
  444.                  goto_flag = prev_goto = FALSE;
  445.             }
  446.         |    format_stmt
  447.         ;
  448.  
  449. specif_stmt    :    dimension_stmt
  450.         |    equivalence_stmt
  451.         |    common_stmt
  452.         |    namelist_stmt
  453.         |    type_stmt
  454.         |    external_stmt
  455.         |    intrinsic_stmt
  456.         |    save_stmt
  457.         |       pointer_stmt
  458.         ;
  459.  
  460.  
  461. /* 7 */
  462. executable_stmt:        /* Allowed in logical IF */
  463.             transfer_stmt
  464.             {
  465.                 goto_flag=TRUE;
  466.             }
  467.         |    nontransfer_stmt
  468.             {
  469.                 goto_flag=FALSE;
  470.             }
  471.         ;
  472.  
  473. transfer_stmt    :    unconditional_goto
  474.         |    assigned_goto
  475.         |    arithmetic_if_stmt
  476.         |    stop_stmt
  477.         |    return_stmt
  478.         ;
  479.  
  480. nontransfer_stmt:    assignment_stmt
  481.         |    assign_stmt
  482.         |    computed_goto    /* fallthru allowed */
  483.         |    continue_stmt
  484.         |    pause_stmt
  485.         |    read_stmt
  486.         |    accept_stmt
  487.         |    write_stmt
  488.         |    print_stmt
  489.         |       type_output_stmt
  490.         |    rewind_stmt
  491.         |    backspace_stmt
  492.         |    endfile_stmt
  493.         |    open_stmt
  494.         |    close_stmt
  495.         |    inquire_stmt
  496.         |    call_stmt
  497.         ;
  498.  
  499. restricted_stmt:        /* Disallowed in logical IF */
  500.             restricted_nontransfer_stmt
  501.             {
  502.                 goto_flag=FALSE;
  503.             }
  504.         |    else_or_endif_stmt
  505.             {
  506.                 prev_goto = goto_flag =FALSE;
  507.             }
  508.         ;
  509.  
  510. restricted_nontransfer_stmt:
  511.             logical_if_stmt
  512.         |    block_if_stmt
  513.         |    do_stmt
  514.             {    /* Flag DO w/o label or DO WHILE forms here */
  515.               if(is_true(NONSTD_USAGE_FLAG,$1.TOK_flags))
  516. #ifdef ALLOW_DO_ENDDO
  517.                 if(f77_do_enddo)
  518.                 nonstandard($1.line_num,$1.col_num);
  519. #else
  520.                 syntax_error($1.line_num,$1.col_num,
  521.                     "Nonstandard syntax");
  522. #endif
  523.             }
  524.  
  525.         |    enddo_stmt
  526.             {
  527. #ifdef ALLOW_DO_ENDDO
  528.                 if(f77_do_enddo)
  529.                 nonstandard($1.line_num,$1.col_num);
  530. #else
  531.                 syntax_error($1.line_num,$1.col_num,
  532.                     "Nonstandard syntax");
  533. #endif
  534.             }
  535.         ;
  536.  
  537. else_or_endif_stmt:    else_if_stmt
  538.         |    else_stmt
  539.         |    end_if_stmt
  540.         ;
  541.  
  542. /* 8 */
  543. prog_stmt    :    tok_PROGRAM {check_seq_header(&($1));}
  544.                  symbolic_name EOS
  545.             {
  546.                  def_function(
  547.                       type_PROGRAM,    /* type */
  548.                       size_DEFAULT,    /* size */
  549.                       (char *)NULL,    /* size text */
  550.                       &($3),    /* name */
  551.                       (Token*)NULL);/* args */
  552.                  current_module_hash =
  553.                    def_curr_module(&($3));
  554.             }
  555.         ;
  556.  
  557.             /* Note that function & subroutine entry not
  558.              * distinguished in this grammar.
  559.              */
  560. /* 9 */
  561. entry_stmt    :    tok_ENTRY symbolic_name EOS
  562.             {
  563.               do_ENTRY(&($2),(Token*)NULL
  564.                    ,current_module_hash);
  565.             }
  566.         |    tok_ENTRY symbolic_name '(' dummy_argument_list ')' EOS
  567.             {
  568.               do_ENTRY(&($2),&($4)
  569.                    ,current_module_hash);
  570. #ifdef DEBUG_PARSER
  571.                  if(debug_parser)
  572.                 print_exprlist("entry stmt",&($4));
  573. #endif
  574.             }
  575.         ;
  576.  
  577. /* 10 */
  578. function_stmt    :    unlabeled_function_stmt
  579.         ;
  580.  
  581. unlabeled_function_stmt
  582.         :    typed_function_handle symbolic_name EOS
  583.             {
  584.                  if(f77_function_noparen) {
  585.                 nonstandard($2.line_num,
  586.                  (unsigned)($2.col_num+strlen(token_name($2))));
  587.                 msg_tail(": parentheses required");
  588.                  }
  589.              def_function(
  590.                       current_datatype,
  591.                       current_typesize,
  592.                       current_len_text,
  593.                       &($2),
  594.                       (Token*)NULL);
  595.              current_module_hash=
  596.                def_curr_module(&($2));
  597.             }
  598.         |    typed_function_handle symbolic_name
  599.                 '(' dummy_argument_list ')' EOS
  600.             {
  601.              def_function(
  602.                       current_datatype,
  603.                       current_typesize,
  604.                       current_len_text,
  605.                       &($2),
  606.                       &($4));
  607.              current_module_hash=
  608.                def_curr_module(&($2));
  609. #ifdef DEBUG_PARSER
  610.              if(debug_parser)
  611.                print_exprlist("function stmt",&($4));
  612. #endif
  613.             }
  614.         |    plain_function_handle symbolic_name EOS
  615.             {
  616.                  if(f77_function_noparen) {
  617.                 nonstandard($2.line_num,
  618.                   (unsigned)($2.col_num+strlen(token_name($2))));
  619.                 msg_tail(": parentheses required");
  620.                  }
  621.              def_function(
  622.                       type_UNDECL,
  623.                       size_DEFAULT,
  624.                       (char *)NULL,
  625.                       &($2),
  626.                       (Token*)NULL);
  627.              current_module_hash=
  628.                def_curr_module(&($2));
  629.             }
  630.         |    plain_function_handle symbolic_name
  631.                 '(' dummy_argument_list ')' EOS
  632.             {
  633.              def_function(
  634.                       type_UNDECL,    /* type */
  635.                       size_DEFAULT,    /* size */
  636.                       (char *)NULL,    /* size text */
  637.                       &($2),        /* name */
  638.                       &($4));        /* args */
  639.              current_module_hash=
  640.                def_curr_module(&($2));
  641. #ifdef DEBUG_PARSER
  642.              if(debug_parser)
  643.                print_exprlist("function stmt",&($4));
  644. #endif
  645.             }
  646.         ;
  647.  
  648. typed_function_handle:    type_name function_keyword
  649.         ;
  650.  
  651. plain_function_handle:    function_keyword
  652.         ;
  653.  
  654. function_keyword:    tok_FUNCTION
  655.             {
  656.               check_seq_header(&($1));
  657.             }
  658.         ;
  659.  
  660. type_name    :    arith_type_name
  661.         |    plain_char_type_name
  662.         |    char_type_name
  663.         ;
  664.  
  665.  
  666. /* 11 not present: see 9 */
  667.  
  668. /* 12 */
  669. subroutine_stmt    :    unlabeled_subroutine_stmt
  670.         ;
  671.  
  672. unlabeled_subroutine_stmt
  673.         :    subroutine_handle symbolic_name EOS
  674.             {
  675.               def_function(
  676.                        type_SUBROUTINE,
  677.                        size_DEFAULT,
  678.                        (char *)NULL,
  679.                        &($2),
  680.                        (Token*)NULL);
  681.               current_module_hash=
  682.                 def_curr_module(&($2));
  683.             }
  684.         |    subroutine_handle symbolic_name
  685.                 '(' dummy_argument_list ')' EOS
  686.             {
  687.               def_function(
  688.                        type_SUBROUTINE,
  689.                        size_DEFAULT,
  690.                        (char *)NULL,
  691.                        &($2),
  692.                        &($4));
  693.               current_module_hash=
  694.                 def_curr_module(&($2));
  695. #ifdef DEBUG_PARSER
  696.               if(debug_parser)
  697.                 print_exprlist("subroutine stmt",&($4));
  698. #endif
  699.             }
  700.         ;
  701.  
  702. subroutine_handle:    tok_SUBROUTINE
  703.             {
  704.               check_seq_header(&($1));
  705.             }
  706.         ;
  707.  
  708. dummy_argument_list:    /* empty */
  709.             {
  710.                 $$.next_token = (Token*)NULL;
  711.             }
  712.         |    non_empty_arg_list
  713.         ;
  714.  
  715. non_empty_arg_list:    dummy_argument
  716.             {
  717.                 $$.next_token = append_token((Token*)NULL,&($1));
  718.             }
  719.         |    non_empty_arg_list ',' dummy_argument
  720.             {
  721.                 $$.next_token = append_token($1.next_token,&($3));
  722.             }
  723.         ;
  724.  
  725. dummy_argument    :    symbolic_name
  726.             {
  727.                  def_arg_name(&($1));
  728.                  primary_id_expr(&($1),&($$));
  729.             }
  730.         |    '*'
  731.             {
  732.                  $$.TOK_type = type_byte(class_LABEL,type_LABEL);
  733.                  $$.size = size_DEFAULT;
  734.                  $$.TOK_flags = 0;
  735.                  $$.left_token = (Token *)NULL;
  736.             }
  737.         ;
  738.  
  739. /* 13 not present: see 9 */
  740.  
  741. /* 14 */
  742. block_data_stmt    :    block_data_handle EOS
  743.             {
  744.                   /* form name %DATnn */
  745.               ++block_data_number;
  746.               (void)sprintf(unnamed_block_data+4,"%02d",
  747.                     block_data_number%100);
  748.               implied_id_token(&($$),unnamed_block_data);
  749.  
  750.               def_function(
  751.                        type_BLOCK_DATA,
  752.                        size_DEFAULT,
  753.                        (char *)NULL,
  754.                        &($$),
  755.                        (Token*)NULL);
  756.               current_module_hash=
  757.                 def_curr_module(&($$));
  758.             }
  759.         |    block_data_handle symbolic_name EOS
  760.             {
  761.               def_function(
  762.                        type_BLOCK_DATA,
  763.                        size_DEFAULT,
  764.                        (char *)NULL,
  765.                        &($2),
  766.                        (Token*)NULL);
  767.               current_module_hash=
  768.                 def_curr_module(&($2));
  769.             }
  770.         ;
  771.  
  772. block_data_handle:    tok_BLOCK tok_DATA
  773.             {
  774.               check_seq_header(&($2));
  775.             }
  776.         |    tok_BLOCKDATA
  777.             {
  778.               check_seq_header(&($1));
  779.             }
  780.  
  781.         ;
  782. /* 15 */
  783. dimension_stmt    :    tok_DIMENSION array_declarator_list EOS
  784.         ;
  785.  
  786. array_declarator_list:    array_declarator
  787.         |    array_declarator_list ',' array_declarator
  788.         ;
  789.  
  790. /* 16 */
  791. array_declarator:    symbolic_name '(' dim_bound_list ')'
  792.             {
  793.                  def_array_dim(&($1),&($3));
  794.             }
  795.         ;
  796.  
  797. dim_bound_list    :    dim_bound_item      /* token class = no. of dimensions,
  798.                            subclass = no. of elements */
  799.             {
  800.                  $$.TOK_dims = 1;
  801.                  $$.TOK_elts = $1.TOK_elts;
  802.                  $$.next_token = append_token((Token*)NULL,&($1));
  803.             }
  804.         |    dim_bound_list ',' dim_bound_item
  805.             {
  806.                  $$.TOK_dims = $1.TOK_dims + 1; /* one more dimension */
  807.                  $$.TOK_elts = $1.TOK_elts * $3.TOK_elts;
  808.                  $$.next_token = append_token($1.next_token,&($3));
  809.             }
  810.         ;
  811.  
  812. dim_bound_item    :    dim_bound_expr
  813.             {
  814.                   if( datatype_of($1.TOK_type) == type_INTEGER
  815.                  && is_true(EVALUATED_EXPR,$1.TOK_flags) )
  816.                 $$.TOK_elts = $1.value.integer;
  817.                   else
  818.                 $$.TOK_elts = 0;
  819.             }
  820.         |    dim_bound_expr ':' dim_bound_expr
  821.             {    /* avoid getting 0 - 0 + 1 = 1 if bounds nonconstant */
  822.                   if( datatype_of($1.TOK_type) == type_INTEGER
  823.                  && is_true(EVALUATED_EXPR,$1.TOK_flags)
  824.                  && datatype_of($3.TOK_type) == type_INTEGER
  825.                  && is_true(EVALUATED_EXPR,$3.TOK_flags) )
  826.                 $$.TOK_elts = $3.value.integer - $1.value.integer + 1;
  827.                   else
  828.                 $$.TOK_elts = 0;
  829.  
  830.                   $$.left_token = add_tree_node(&($2),&($1),&($3));
  831.             }
  832.         |    '*'
  833.             {
  834.                  $$.TOK_elts = 0;
  835.                  $$.left_token = (Token *)NULL;
  836.             }
  837.         |    dim_bound_expr ':' '*'
  838.             {
  839.                  $$.TOK_elts = 0;
  840.                  $3.left_token = (Token *)NULL;
  841.                  $$.left_token = add_tree_node(&($2),&($1),&($3));
  842.             }
  843.         ;
  844.  
  845. /* 17 */
  846. equivalence_stmt:    tok_EQUIVALENCE {equivalence_flag = TRUE;}
  847.             equivalence_list EOS {equivalence_flag = FALSE;}
  848.         ;
  849.  
  850. equivalence_list:    '(' equivalence_list_item ')'
  851.         |    equivalence_list ',' '(' equivalence_list_item ')'
  852.         ;
  853.  
  854. equivalence_list_item:    equiv_entity ',' equiv_entity
  855.             {
  856.               equivalence(&($1), &($3));
  857.             }
  858.         |    equivalence_list_item ',' equiv_entity
  859.             {
  860.               equivalence(&($1), &($3));
  861.             }
  862.         ;
  863.  
  864. /* 17 */
  865. equiv_entity    :    symbolic_name
  866.             {
  867.                  def_equiv_name(&($1));
  868.             }
  869.         |    array_equiv_name
  870.             {
  871.                  def_equiv_name(&($1));
  872.             }
  873.         |    substring_equiv_name
  874.             {
  875.                  def_equiv_name(&($1));
  876.             }
  877.         ;
  878.  
  879. array_equiv_name:    symbolic_name '(' subscript_list ')'
  880.                 /* should check */
  881.         ;
  882.  
  883. substring_equiv_name:    symbolic_name substring_interval
  884.         |    array_equiv_name substring_interval
  885.         ;
  886.  
  887. /* 19 */
  888. common_stmt    :    tok_COMMON common_variable_list EOS
  889.             {
  890.                  implied_id_token(&($$),blank_com_name);
  891.                  def_com_block(&($$), &($2));
  892.                  if(is_true(COMMA_FLAG,$2.TOK_flags))
  893.                    syntax_error(
  894.                          $2.line_num,$2.col_num,
  895.                          "trailing comma");
  896. #ifdef DEBUG_PARSER
  897.                  if(debug_parser)
  898.                 print_comlist("blank common",&($2));
  899. #endif
  900.  
  901.             }
  902.         |    tok_COMMON common_block_list EOS
  903.             {
  904.                  if(is_true(COMMA_FLAG,$2.TOK_flags))
  905.                 syntax_error(
  906.                          $2.line_num,$2.col_num,
  907.                          "trailing comma");
  908.  
  909.             }
  910.         |    tok_COMMON common_variable_list common_block_list EOS
  911.             {
  912.                  implied_id_token(&($$),blank_com_name);
  913.                  def_com_block(&($$),&($2));
  914.                  if(is_true(COMMA_FLAG,$3.TOK_flags))
  915.                 syntax_error(
  916.                          $3.line_num,$3.col_num,
  917.                          "trailing comma");
  918. #ifdef DEBUG_PARSER
  919.                  if(debug_parser)
  920.                 print_comlist("blank common",&($2));
  921. #endif
  922.             }
  923.         ;
  924.  
  925.     /*  The following defns allow trailing commas and missing commas in
  926.         order to tolerate the optional comma before /blockname/.  The
  927.         token TOK_flags holds comma status to allow errors to be caught. */
  928. common_block_list:    labeled_common_block
  929.             {
  930.                  $$.TOK_flags = $1.TOK_flags;
  931.             }
  932.         |    common_block_list labeled_common_block
  933.             {
  934.                  $$.TOK_flags = $2.TOK_flags;
  935.                  $$.line_num = $2.line_num;
  936.                  $$.col_num = $2.col_num;
  937.             }
  938.         ;
  939.  
  940. labeled_common_block:    common_block_name common_variable_list
  941.             {
  942.                  def_com_block(&($1),&($2));
  943.                  $$.TOK_flags = $2.TOK_flags;
  944.                  $$.line_num = $2.line_num;
  945.                  $$.col_num = $2.col_num;
  946. #ifdef DEBUG_PARSER
  947.                  if(debug_parser)
  948.                 print_comlist("labeled common",&($2));
  949. #endif
  950.             }
  951.         ;
  952.  
  953. common_block_name:    '/' symbolic_name '/'
  954.             {
  955.                  $$ = $2;
  956.             }
  957.  
  958.         |    '/'  '/'        /* block with no name */
  959.             {
  960.                  implied_id_token(&($$),blank_com_name);
  961.             }
  962.         |    tok_concat        /* "//" becomes this */
  963.             {
  964.                  implied_id_token(&($$),blank_com_name);
  965.             }
  966.         ;
  967.  
  968. common_variable_list:    common_list_item
  969.             {
  970.                 $$.TOK_flags = $1.TOK_flags;
  971.                 $$.next_token = append_token((Token*)NULL,&($1));
  972.             }
  973.         |    common_variable_list common_list_item
  974.             {
  975.                 if(!is_true(COMMA_FLAG,$1.TOK_flags))
  976.                 syntax_error(
  977.                     $2.line_num,$2.col_num-1,
  978.                     "missing comma");
  979.                 $$.TOK_flags = $2.TOK_flags;
  980.                 $$.line_num = $2.line_num;
  981.                 $$.col_num = $2.col_num;
  982.                 $$.next_token = append_token($1.next_token,&($2));
  983.             }
  984.         ;
  985.  
  986. common_list_item:    common_entity
  987.             {               /* no comma */
  988.                  $$.TOK_flags = $1.TOK_flags;
  989.                  make_false(COMMA_FLAG,$$.TOK_flags);
  990.             }
  991.         |    common_entity ','
  992.             {               /* has comma */
  993.                  $$.TOK_flags = $1.TOK_flags;
  994.                  make_true(COMMA_FLAG,$$.TOK_flags);
  995.                }
  996.         ;
  997.  
  998. common_entity    :    symbolic_name
  999.             {
  1000.                  def_com_variable(&($1));
  1001.                  primary_id_expr(&($1),&($$));
  1002.             }
  1003.         |    array_declarator
  1004.             {
  1005.                  def_com_variable(&($1));
  1006.                  primary_id_expr(&($1),&($$));
  1007.             }
  1008.         ;
  1009.  
  1010.  
  1011. /* NAMELIST : Not Standard
  1012.    Syntax is:
  1013.     NAMELIST /group/ var [,var...] [[,] /group/ var [,var...]...]
  1014. */
  1015.  
  1016. namelist_stmt    :    tok_NAMELIST namelist_list EOS
  1017.             {
  1018.                 if(is_true(COMMA_FLAG,$2.TOK_flags))
  1019.                 syntax_error($2.line_num,
  1020.                  (unsigned)($2.col_num+strlen(token_name($2))),
  1021.                     "trailing comma");
  1022.                 if(f77_namelist) {
  1023.                 nonstandard($1.line_num,$1.col_num);
  1024.                 }
  1025.             }
  1026.         ;
  1027.  
  1028. namelist_list    :    namelist_decl
  1029.         |    namelist_list namelist_decl
  1030.             {
  1031.                 $$ = $2;
  1032.             }
  1033.         ;
  1034.  
  1035. namelist_decl    :    namelist_name namelist_var_list
  1036.             {
  1037.                  def_namelist(&($1),&($2));
  1038.                  $$ = $2;
  1039.             }
  1040.         ;
  1041.  
  1042. namelist_name    :    '/' symbolic_name '/'
  1043.             {
  1044.                 $$ = $2;
  1045.             }
  1046.         ;
  1047.  
  1048. namelist_var_list:    namelist_item
  1049.             {
  1050.                  $$.next_token = append_token((Token*)NULL,&($1));
  1051.             }
  1052.         |    namelist_var_list namelist_item
  1053.             {
  1054.                 if(!is_true(COMMA_FLAG,$1.TOK_flags))
  1055.                 syntax_error(
  1056.                     $2.line_num,$2.col_num-1,
  1057.                     "missing comma");
  1058.                 $$.TOK_flags = $2.TOK_flags;
  1059.                 $$.line_num = $2.line_num;
  1060.                 $$.col_num = $2.col_num;
  1061.                 $$.next_token = append_token($1.next_token,&($2));
  1062.             }
  1063.         ;
  1064.  
  1065. namelist_item    :    symbolic_name
  1066.             {               /* no comma */
  1067.                  def_namelist_item(&($1));
  1068.                  primary_id_expr(&($1),&($$));
  1069.                  make_false(COMMA_FLAG,$$.TOK_flags);
  1070.             }
  1071.         |    symbolic_name ','
  1072.             {               /* has comma */
  1073.                  def_namelist_item(&($1));
  1074.                  primary_id_expr(&($1),&($$));
  1075.                  make_true(COMMA_FLAG,$$.TOK_flags);
  1076.             }
  1077.         ;
  1078.  
  1079. /* 20 */
  1080. type_stmt    :    arith_type_name arith_type_decl_list EOS
  1081.         |    plain_char_type_name char_type_decl_list EOS
  1082.         |    char_type_name char_type_decl_list EOS
  1083.         |    char_type_name ',' char_type_decl_list EOS
  1084.         ;
  1085.  
  1086. arith_type_name    :    sizeable_type_name
  1087.             {
  1088.               current_typesize = size_DEFAULT;
  1089.               current_len_text = NULL;
  1090.             }
  1091.                 /* Allow *len to modify some arith types */
  1092.         |    sizeable_type_name '*' nonzero_unsigned_int_const
  1093.             {
  1094.                 current_typesize = $3.value.integer;
  1095.                 current_len_text = NULL;
  1096. #if 0 /* defunct feature */
  1097.                 if(local_wordsize > 0) {
  1098.                   /*  recognize REAL*2w as DOUBLE PRECISION */
  1099.                   if(current_datatype == type_REAL
  1100.                  && $3.value.integer == type_size[type_DP])
  1101.                 current_datatype = type_DP;
  1102.                   /*  recognize COMPLEX*4w as DOUBLE COMPLEX */
  1103.                   if(current_datatype == type_COMPLEX
  1104.                  && $3.value.integer==type_size[type_DCOMPLEX])
  1105.                 current_datatype = type_DCOMPLEX;
  1106.                 }
  1107. #endif
  1108.                  if(f77_typesize) {
  1109.                 nonstandard($3.line_num,$3.col_num);
  1110.                  }
  1111.             }
  1112.                 /* Other type disallow *len modifier */
  1113.         |    unsizeable_type_name
  1114.         ;
  1115.  
  1116. sizeable_type_name:    tok_INTEGER
  1117.             {
  1118.                  current_datatype = type_INTEGER;
  1119.                  integer_context = TRUE;
  1120.             }
  1121.         |    tok_REAL
  1122.             {
  1123.                  current_datatype = type_REAL;
  1124.                  integer_context = TRUE;
  1125.             }
  1126.         |    tok_COMPLEX
  1127.             {
  1128.                  current_datatype = type_COMPLEX;
  1129.                  integer_context = TRUE;
  1130.             }
  1131.         |    tok_LOGICAL
  1132.             {
  1133.                  current_datatype = type_LOGICAL;
  1134.                  integer_context = TRUE;
  1135.             }
  1136.         ;
  1137.  
  1138. unsizeable_type_name:    tok_DOUBLE tok_PRECISION
  1139.             {
  1140.                  current_datatype = type_DP;
  1141.                  current_typesize = size_DEFAULT;
  1142.                  current_len_text = NULL;
  1143.             }
  1144.         |    tok_DOUBLEPRECISION
  1145.             {
  1146.                  current_datatype = type_DP;
  1147.                  current_typesize = size_DEFAULT;
  1148.                  current_len_text = NULL;
  1149.             }
  1150.         |    tok_DOUBLE tok_COMPLEX
  1151.             {
  1152.                  current_datatype = type_DCOMPLEX;
  1153.                  current_typesize = size_DEFAULT;
  1154.                  current_len_text = NULL;
  1155.                  if(f77_double_complex) {
  1156.                 nonstandard($2.line_num,$2.col_num);
  1157.                  }
  1158.             }
  1159.         |    tok_DOUBLECOMPLEX
  1160.             {
  1161.                  current_datatype = type_DCOMPLEX;
  1162.                  current_typesize = size_DEFAULT;
  1163.                  current_len_text = NULL;
  1164.                  if(f77_double_complex) {
  1165.                 nonstandard($1.line_num,$1.col_num);
  1166.                  }
  1167.             }
  1168.         |    tok_BYTE /* treate BYTE as a form of integer for now */
  1169.             {
  1170.                  current_datatype = type_INTEGER;
  1171.                  current_typesize = 1;
  1172.                  current_len_text = NULL;
  1173.                  if(f77_byte)
  1174.                    nonstandard($1.line_num,$1.col_num);
  1175.             }
  1176.         ;
  1177.  
  1178. plain_char_type_name:    tok_CHARACTER
  1179.             {
  1180.                  current_datatype = type_STRING;
  1181.                  current_typesize = 1;
  1182.                  current_len_text = NULL;
  1183.                  current_size_is_adjustable = 0;
  1184.                  current_size_is_expression = 0;
  1185.                  integer_context = TRUE;
  1186.             }
  1187.         ;
  1188.  
  1189. char_type_name    :    plain_char_type_name '*' len_specification
  1190.             {
  1191.                  current_typesize = $3.value.integer;
  1192.                  current_size_is_adjustable = $3.size_is_adjustable;
  1193.                  current_size_is_expression = $3.size_is_expression;
  1194.                 /* Save length spec text if expression */
  1195.                  if(current_size_is_expression) {
  1196.                    if($3.left_token == NULL)
  1197.                  current_len_text = new_tree_text(&($3));
  1198.                    else
  1199.                  current_len_text = new_tree_text($3.left_token);
  1200.                  }
  1201.                  else
  1202.                    current_len_text = NULL;
  1203.             }
  1204.         ;
  1205.  
  1206. arith_type_decl_list:    arith_type_decl_item
  1207.         |    arith_type_decl_list ',' arith_type_decl_item
  1208.         ;
  1209.  
  1210. arith_type_decl_item:    symbolic_name
  1211.             {
  1212.                  declare_type(&($1),
  1213.                       current_datatype,
  1214.                       current_typesize,
  1215.                       current_len_text);
  1216.             }
  1217.         |    array_declarator
  1218.             {
  1219.                  declare_type(&($1),
  1220.                       current_datatype,
  1221.                       current_typesize,
  1222.                       current_len_text);
  1223.             }
  1224.         ;
  1225.  
  1226. char_type_decl_list:    char_type_decl_item
  1227.         |    char_type_decl_list ',' char_type_decl_item
  1228.         ;
  1229.  
  1230. char_type_decl_item:    symbolic_name
  1231.             {
  1232.                  $1.size_is_adjustable = current_size_is_adjustable;
  1233.                  $1.size_is_expression = current_size_is_expression;
  1234.                  declare_type(&($1),
  1235.                       current_datatype,
  1236.                       current_typesize,
  1237.                       current_len_text);
  1238.             }
  1239.         |    symbolic_name '*' len_specification
  1240.             {
  1241.                  $1.size_is_adjustable = $3.size_is_adjustable;
  1242.                  $1.size_is_expression = $3.size_is_expression;
  1243.                  declare_type(&($1),
  1244.                       current_datatype,
  1245.                       $3.value.integer,
  1246.                       new_tree_text(
  1247.                          $3.left_token == NULL?
  1248.                          &($3): $3.left_token )
  1249.                       );
  1250.             }
  1251.         |    array_declarator
  1252.             {
  1253.                  $1.size_is_adjustable = current_size_is_adjustable;
  1254.                  $1.size_is_expression = current_size_is_expression;
  1255.                  declare_type(&($1),
  1256.                       current_datatype,
  1257.                       current_typesize,
  1258.                       current_len_text);
  1259.             }
  1260.         |    array_declarator '*' len_specification
  1261.             {
  1262.                  $1.size_is_adjustable = $3.size_is_adjustable;
  1263.                  $1.size_is_expression = $3.size_is_expression;
  1264.                  declare_type(&($1),
  1265.                       current_datatype,
  1266.                       $3.value.integer,
  1267.                       new_tree_text(
  1268.                          $3.left_token == NULL?
  1269.                          &($3): $3.left_token )
  1270.                       );
  1271.             }
  1272.            ;
  1273.  
  1274. /* 21 */
  1275.                 /* implicit_flag helps is_keyword's work */
  1276. implicit_handle    :    tok_IMPLICIT {implicit_flag=TRUE;}
  1277.         ;
  1278.  
  1279. implicit_stmt    :    implicit_handle implicit_decl_list EOS
  1280.             {
  1281.                 implicit_flag=FALSE;
  1282.                 if(implicit_none) {
  1283.                 syntax_error($1.line_num,$1.col_num,
  1284.                      "conflicts with IMPLICIT NONE");
  1285.                 }
  1286.                 else {
  1287.                 implicit_type_given = TRUE;
  1288.                 }
  1289.             }
  1290.                 /* IMPLICIT NONE statement */
  1291.         |    implicit_handle tok_NONE EOS
  1292.             {
  1293.                 implicit_flag=FALSE;
  1294.                 if(implicit_type_given) {
  1295.                     syntax_error($1.line_num,$1.col_num,
  1296.                      "conflicts with IMPLICIT statement");
  1297.                 }
  1298.                 else {
  1299.                     if(f77_implicit_none)
  1300.                       nonstandard($2.line_num,$2.col_num);
  1301.                     implicit_none = TRUE;
  1302.                 }
  1303.             }
  1304.         ;
  1305.  
  1306. implicit_decl_list:    implicit_decl_item
  1307.         |    implicit_decl_list ',' {initial_flag = TRUE;}
  1308.                        implicit_decl_item
  1309.         ;
  1310.  
  1311.         /* implicit_letter_flag tells lexer to treat letters as letters,
  1312.                not as identifiers */
  1313. implicit_decl_item:    type_name '('  {implicit_letter_flag = TRUE;}
  1314.                 letter_list ')'  {implicit_letter_flag = FALSE;}
  1315.         ;
  1316.  
  1317. letter_list    :    letter_list_item
  1318.         |    letter_list ',' letter_list_item
  1319.         ;
  1320.  
  1321. letter_list_item:    tok_letter
  1322.             {
  1323.               int c1 = (int)$1.subclass;
  1324.  
  1325.               if( (f77_dollarsigns && c1=='$')
  1326.                || (f77_underscores && c1=='_') ) {
  1327.                 nonstandard($1.line_num,$1.col_num);
  1328.                 msg_tail(": nonalphabetic character");
  1329.               }
  1330.  
  1331.                set_implicit_type(current_datatype,
  1332.                          current_typesize,
  1333.                          current_len_text,
  1334.                          c1,c1);
  1335.             }
  1336.         |    tok_letter '-' tok_letter
  1337.             {
  1338.               int c1 = (int)$1.subclass,
  1339.                   c2 = (int)$3.subclass;
  1340.  
  1341.               if( (f77_dollarsigns && (c1 == '$' || c2 == '$'))
  1342.                || (f77_underscores && (c1 == '_' || c2 == '_')))
  1343.               {
  1344.                 if(!isalpha(c1))
  1345.                   nonstandard($1.line_num,$1.col_num);
  1346.                 else
  1347.                   nonstandard($3.line_num,$3.col_num);
  1348.                 msg_tail(": nonalphabetic character");
  1349.               }
  1350.  
  1351.                set_implicit_type(current_datatype,
  1352.                          current_typesize,
  1353.                          current_len_text,
  1354.                          c1,c2);
  1355.             }
  1356.         ;
  1357.  
  1358.  
  1359. /* 22 */
  1360. len_specification:    '(' '*' ')'
  1361.             {
  1362.                  $2.left_token = (Token *)NULL;
  1363.                  $$.value.integer = size_ADJUSTABLE;
  1364.                  $$.size_is_adjustable = 1;
  1365.                  $$.size_is_expression = 0;
  1366.                 /* Store as a parenthesized expr tree */
  1367.                  $$.left_token = add_tree_node(&($1),&($2),
  1368.                               (Token*)NULL);
  1369.             }
  1370.         |    nonzero_unsigned_int_const
  1371.             {
  1372.                  $$.value.integer = $1.value.integer;
  1373.                  $$.size_is_adjustable = 0;
  1374.                  $$.size_is_expression = 0;
  1375.             }
  1376.         |    '(' int_constant_expr ')'
  1377.             {
  1378.                  $$ = $2;
  1379.                  $$.size_is_adjustable = 0;
  1380.                  $$.size_is_expression = 1;
  1381.                  if( $$.value.integer <= 0 ){
  1382.                    if(misc_warn) {
  1383.                  warning($2.line_num,$2.col_num,
  1384.                     "invalid length specification");
  1385.                  msg_tail(": substituting 1");
  1386.                    }
  1387.                    $$.value.integer = 1;
  1388.                  }
  1389.                  $$.left_token = add_tree_node(&($1),&($2),
  1390.                               (Token*)NULL);
  1391.             }
  1392.         ;
  1393.  
  1394. /* 23 */
  1395. parameter_stmt    :    tok_PARAMETER '(' parameter_defn_list ')' EOS
  1396.         |    tok_PARAMETER parameter_defn_list  EOS
  1397.             {
  1398.                 if(f77_param_noparen)
  1399.                 nonstandard($1.line_num,$1.col_num);
  1400.             }
  1401.            ;
  1402.  
  1403. parameter_defn_list:    parameter_defn_item
  1404.         |    parameter_defn_list ',' parameter_defn_item
  1405.         ;
  1406.  
  1407. parameter_defn_item:    symbolic_name {complex_const_allowed = TRUE;}
  1408.                 '=' parameter_expr
  1409.             {
  1410.                  def_parameter(&($1),&($4));
  1411.                  primary_id_expr(&($1),&($1));
  1412.                  assignment_stmt_type(&($1),&($3),&($4));
  1413.                  complex_const_allowed = FALSE;
  1414.             }
  1415.         ;
  1416.  
  1417. /* 24 */
  1418. external_stmt    :    tok_EXTERNAL external_name_list EOS
  1419.         ;
  1420.  
  1421. external_name_list:    symbolic_name
  1422.             {
  1423.                  def_ext_name(&($1));
  1424.             }
  1425.         |    external_name_list ',' symbolic_name
  1426.             {
  1427.                  def_ext_name(&($3));
  1428.             }
  1429.         ;
  1430.  
  1431. /* 25 */
  1432. intrinsic_stmt    :    tok_INTRINSIC intrinsic_name_list EOS
  1433.         ;
  1434.  
  1435. intrinsic_name_list:    symbolic_name
  1436.             {
  1437.                  def_intrins_name(&($1));
  1438.             }
  1439.         |    intrinsic_name_list ',' symbolic_name
  1440.             {
  1441.                  def_intrins_name(&($3));
  1442.             }
  1443.         ;
  1444.  
  1445.         /* constructs for POINTER(pointer=pointee) statement */
  1446. pointer_stmt    :       tok_POINTER pointer_item_list EOS
  1447.         {
  1448.           if(f77_cray_pointers)
  1449.             nonstandard($1.line_num,$1.col_num);
  1450.         }
  1451.         ;
  1452.  
  1453. pointer_item_list:      pointer_item
  1454.         |       pointer_item_list ',' pointer_item
  1455.         ;
  1456.  
  1457. pointer_item    :       '(' pointer_name ',' pointee_name ')'
  1458.         ;
  1459.  
  1460. pointer_name    :       symbolic_name
  1461.             {
  1462.                  declare_type(&($1),type_INTEGER,local_wordsize,
  1463.                       NULL );
  1464.             }
  1465.         ;
  1466.  
  1467. pointee_name    :       symbolic_name
  1468.                 {
  1469.                 /* Suppress set/used warnings since
  1470.                    often is accessed only via pointer */
  1471.                      use_lvalue(&($1));
  1472.                      use_variable(&($1));
  1473.                 }
  1474.         |       array_declarator
  1475.                 {
  1476.                      use_lvalue(&($1));
  1477.                      use_variable(&($1));
  1478.                 }
  1479.         ;
  1480.  
  1481. /* 26 */
  1482. save_stmt    :    tok_SAVE EOS
  1483.             {
  1484.               global_save = TRUE;
  1485.             }
  1486.         |    tok_SAVE save_list EOS
  1487.         ;
  1488.  
  1489. save_list    :    save_item
  1490.         |    save_list ',' save_item
  1491.         ;
  1492.  
  1493. save_item    :    symbolic_name
  1494.             {
  1495.                  save_variable(&($1));
  1496.             }
  1497.         |    '/' symbolic_name '/'
  1498.             {
  1499. /***                 def_com_block(&($2),(Token*)NULL);***/
  1500.                  save_com_block(&($2));
  1501.             }
  1502.         ;
  1503.  
  1504. /* 27 */
  1505. data_stmt    :    tok_DATA data_defn_list EOS
  1506.            ;
  1507.  
  1508. data_defn_list    :    data_defn_item
  1509.         |    data_defn_list data_defn_item
  1510.         |    data_defn_list ',' data_defn_item
  1511.         ;
  1512.  
  1513. data_defn_item    :    data_defn_assignee_list '/'
  1514.                 {complex_const_allowed=TRUE;}
  1515.                     data_value_list
  1516.                 {complex_const_allowed=FALSE;}  '/'
  1517.         ;
  1518.  
  1519. data_defn_assignee_list
  1520.         :    data_defn_assignee
  1521.         |    data_defn_assignee_list ',' data_defn_assignee
  1522.         ;
  1523.  
  1524. data_defn_assignee:    lvalue
  1525.             {
  1526.                  use_lvalue(&($1));
  1527.             }
  1528.         |    data_implied_do_list
  1529.         ;
  1530.  
  1531. data_value_list:    data_value
  1532.         |    data_value_list ',' data_value
  1533.         ;
  1534.  
  1535. data_value    :    data_constant_value
  1536.         |    data_repeat_factor '*' data_constant_value
  1537.         ;
  1538.  
  1539. data_repeat_factor:    nonzero_unsigned_int_const
  1540.         |    symbolic_name
  1541.             {
  1542.                  use_parameter(&($1));
  1543.             }
  1544.         ;
  1545.  
  1546. data_constant_value:    data_constant
  1547.         |    symbolic_name
  1548.             {
  1549.                  use_parameter(&($1));
  1550.             }
  1551.         ;
  1552.  
  1553.  
  1554. data_dlist    :    data_dlist_item
  1555.         |    data_dlist ',' data_dlist_item
  1556.         ;
  1557.  
  1558. data_dlist_item    :    array_element_lvalue
  1559.             {
  1560.                  use_lvalue(&($1));
  1561.             }
  1562.         |    data_implied_do_list
  1563.         ;
  1564.  
  1565. data_implied_do_list:  '(' data_dlist ',' symbolic_name
  1566.                 '=' data_do_loop_bounds ')'
  1567.             {
  1568.                 use_implied_do_index(&($4));
  1569.             }
  1570.         ;
  1571.  
  1572. data_do_loop_bounds:    int_constant_expr ',' int_constant_expr
  1573.         | int_constant_expr ',' int_constant_expr ',' int_constant_expr
  1574.         ;
  1575.  
  1576.  
  1577. /* 29 */
  1578. assignment_stmt    :    lvalue '=' {complex_const_allowed = TRUE;
  1579.                     in_assignment_stmt = TRUE;} expr
  1580.             {
  1581.               if( ! (is_true(LVALUE_EXPR,$1.TOK_flags)
  1582.                    || is_true(STMT_FUNCTION_EXPR,$1.TOK_flags) )) {
  1583.                 syntax_error($1.line_num,$1.col_num,
  1584.                      "left side is not assignable");
  1585.               }
  1586.               else {
  1587.                 assignment_stmt_type(&($1),&($2),
  1588.                     &($4));
  1589.               }
  1590.               complex_const_allowed = FALSE;
  1591.               in_assignment_stmt = FALSE;
  1592.             }
  1593.                  EOS
  1594.             {
  1595.                 /* Clear u-b-s flags spuriously set */
  1596.               if(is_true(STMT_FUNCTION_EXPR, $1.TOK_flags)
  1597.                      && stmt_sequence_no <= SEQ_STMT_FUN)
  1598.                  stmt_function_stmt(&($1));
  1599.                 }
  1600.         ;
  1601.  
  1602. lvalue        :    variable_name
  1603.         |    array_element_lvalue
  1604.         |    substring_lvalue
  1605.         |    stmt_function_handle
  1606.         ;
  1607.  
  1608.  
  1609. /* array-element_lvalue is at 88 */
  1610.  
  1611. assign_stmt    :        tok_ASSIGN pre_label label tok_TO variable_name EOS
  1612.             {
  1613.                 do_ASSIGN(&($5));
  1614.             }
  1615.         ;
  1616.  
  1617.  
  1618. /* 31 */
  1619. unconditional_goto:    goto pre_label label EOS
  1620.         ;
  1621.  
  1622. /* 32 */
  1623. computed_goto    :    goto '(' goto_list ')' integer_expr EOS
  1624.         |    goto '(' goto_list ')' ',' integer_expr EOS
  1625.         ;
  1626.  
  1627. /* 33 */
  1628. assigned_goto    :    goto symbolic_name EOS
  1629.             {
  1630.                  do_assigned_GOTO(&($2));
  1631.             }
  1632.         |    goto symbolic_name '(' goto_list ')' EOS
  1633.             {
  1634.                  do_assigned_GOTO(&($2));
  1635.             }
  1636.         |    goto symbolic_name ',' '(' goto_list ')' EOS
  1637.             {
  1638.                  do_assigned_GOTO(&($2));
  1639.             }
  1640.         ;
  1641.  
  1642. goto        :    tok_GOTO
  1643.             {
  1644.                 integer_context=TRUE;
  1645.             }
  1646.         |    tok_GO tok_TO
  1647.             {
  1648.                 integer_context=TRUE;
  1649.             }
  1650.         ;
  1651.  
  1652. goto_list    :    pre_label label
  1653.         |    goto_list ',' pre_label label
  1654.         ;
  1655.  
  1656. /* 34 */
  1657. arithmetic_if_stmt:    if_handle pre_label label ',' pre_label label
  1658.                  ',' pre_label label EOS
  1659.             {
  1660.               int t=datatype_of($1.class);
  1661.               if(t != type_INTEGER && t != type_REAL
  1662.                  && t != type_DP && t != type_ERROR ) {
  1663.                 syntax_error($1.line_num,$1.col_num,
  1664.           "integer, real, or double precision expression required");
  1665.               }
  1666.             }
  1667.         ;
  1668.  
  1669. /* 35 */
  1670. logical_if_stmt    :    if_handle executable_stmt
  1671.             {
  1672.               int t=datatype_of($1.TOK_type);
  1673.               if(t != type_LOGICAL && t != type_ERROR)
  1674.                  syntax_error($1.line_num,$1.col_num,
  1675.                       "logical expression required");
  1676.             }
  1677.         ;
  1678.  
  1679. /* 36 */
  1680. block_if_stmt    :    if_handle tok_THEN EOS
  1681.             {
  1682.               int t=datatype_of($1.TOK_type);
  1683.               if(t != type_LOGICAL && t != type_ERROR)
  1684.                  syntax_error($1.line_num,$1.col_num,
  1685.                       "logical expression required");
  1686.             }
  1687.         ;
  1688.  
  1689. if_handle    :    tok_IF '(' {complex_const_allowed = TRUE;}  expr ')'
  1690.             {
  1691.                 if(is_true(ID_EXPR,$4.TOK_flags)){
  1692.                 use_variable(&($4));
  1693.                 }
  1694.                 complex_const_allowed = FALSE;
  1695.  
  1696.                 initial_flag = TRUE;    /* for is_keyword */
  1697.                 $$ = $4; /* Inherit expr for type checking above */
  1698.             }
  1699.         ;
  1700.  
  1701. /* 37 */
  1702. else_if_stmt    :    tok_ELSE block_if_stmt
  1703.         |    tok_ELSEIF '(' {complex_const_allowed = TRUE;} expr ')'
  1704.             {
  1705.                 if(is_true(ID_EXPR,$4.TOK_flags)){
  1706.                 use_variable(&($4));
  1707.                 }
  1708.                 complex_const_allowed = FALSE;
  1709.  
  1710.                 initial_flag = TRUE;
  1711.             }
  1712.             tok_THEN EOS
  1713.         ;
  1714.  
  1715. /* 38 */
  1716. else_stmt    :    tok_ELSE EOS
  1717.         ;
  1718.  
  1719. /* 39 */
  1720. end_if_stmt    :    tok_ENDIF EOS
  1721.         |    tok_END tok_IF EOS
  1722.         ;
  1723.  
  1724. /* 40 */
  1725.             /* Allow VAX/VMS extensions:
  1726.                DO [label [,]] var = expr , expr [,expr]
  1727.                DO [label [,]] WHILE ( expr )
  1728.                   ...
  1729.                ENDDO
  1730.             */
  1731.  
  1732. do_stmt        :    do_handle variable_name
  1733.                 '=' do_loop_bounds EOS
  1734.             {
  1735.               if( ! is_true(LVALUE_EXPR,$2.TOK_flags) ) {
  1736.                 syntax_error($2.line_num,$2.col_num,
  1737.                      "index is not assignable");
  1738.               }
  1739.               else {
  1740.                  use_lvalue(&($2));
  1741.                  use_variable(&($2));
  1742.               }
  1743.  
  1744.                 /* Check for non-integer DO index or bounds */
  1745.                  if(datatype_of($2.TOK_type) == type_INTEGER
  1746.                 && datatype_of($4.TOK_type) != type_INTEGER) {
  1747.                    if(misc_warn) {
  1748.                  warning($3.line_num,$3.col_num,
  1749.                   "type mismatch between DO index and bounds");
  1750.                    }
  1751.                  }
  1752.                  else if(datatype_of($2.TOK_type) != type_INTEGER)
  1753.                    if(datatype_of($4.TOK_type) != type_INTEGER) {
  1754.                  if(port_real_do)
  1755.                    nonportable($4.line_num,$4.col_num,
  1756.                            "non-integer DO loop bounds");
  1757.                    }
  1758.                    else {
  1759.                  if(trunc_real_do_index)
  1760.                    warning($2.line_num,$2.col_num,
  1761.                        "DO index is not integer");
  1762.                    }
  1763.             }
  1764.         |    do_handle tok_WHILE '('
  1765.                 {complex_const_allowed=TRUE;} expr ')' EOS
  1766.             {
  1767.                 if(is_true(ID_EXPR,$5.TOK_flags)){
  1768.                 use_variable(&($5));
  1769.                 }
  1770.                 complex_const_allowed=FALSE;
  1771.                 make_true(NONSTD_USAGE_FLAG,$$.TOK_flags);
  1772.             }
  1773.         |    tok_DOWHILE '('
  1774.                 {complex_const_allowed=TRUE;} expr ')' EOS
  1775.             {
  1776.                 if(is_true(ID_EXPR,$4.TOK_flags)){
  1777.                 use_variable(&($4));
  1778.                 }
  1779.                 complex_const_allowed=FALSE;
  1780.                 make_true(NONSTD_USAGE_FLAG,$$.TOK_flags);
  1781.             }
  1782.         ;
  1783.  
  1784. do_handle    :    tok_DO pre_label label
  1785.         |    tok_DO pre_label label ','
  1786.         |    tok_DO pre_label
  1787.             {
  1788.                 make_true(NONSTD_USAGE_FLAG,$$.TOK_flags);
  1789.                 integer_context=FALSE;
  1790.             }
  1791.         ;
  1792.  
  1793. do_loop_bounds    :    int_real_dp_expr ',' int_real_dp_expr
  1794.             {
  1795.                 $$.TOK_type=do_bounds_type(&($1),&($3),&($3));
  1796.             }
  1797.         |   int_real_dp_expr ',' int_real_dp_expr ',' int_real_dp_expr
  1798.             {
  1799.                 $$.TOK_type=do_bounds_type(&($1),&($3),&($5));
  1800.             }
  1801.         ;
  1802.  
  1803. enddo_stmt    :    tok_END tok_DO EOS
  1804.         |    tok_ENDDO EOS
  1805.         ;
  1806.  
  1807. /* 41 */
  1808. continue_stmt    :    tok_CONTINUE EOS
  1809.         ;
  1810.  
  1811. /* 42 */
  1812. stop_stmt    :    tok_STOP stop_info EOS
  1813.         ;
  1814.  
  1815. /* 43 */
  1816. pause_stmt    :    tok_PAUSE stop_info EOS
  1817.         ;
  1818.  
  1819. stop_info    :    /* empty */
  1820.         |    tok_integer_const
  1821.         |    symbolic_name
  1822.             {
  1823.                  use_variable(&($1));
  1824.             }
  1825.         |    tok_string
  1826.         ;
  1827.  
  1828. /* 44 */
  1829. write_stmt    :    write_handle
  1830.                 {complex_const_allowed = FALSE;} EOS
  1831.         |    write_handle io_list
  1832.                 {complex_const_allowed = FALSE;} EOS
  1833.         ;
  1834.  
  1835. write_handle    :    tok_WRITE {init_io_ctrl_list();}
  1836.                 '(' control_info_list ')'
  1837.                 {complex_const_allowed = TRUE;}
  1838.         ;
  1839.  
  1840. /* 45 */
  1841.         /* Note that parenthesized format_id's will end up in
  1842.            control_info_list. Disambiguation left to semantic phase.
  1843.            This is why we need the optional comma */
  1844. read_stmt    :    read_handle '(' control_info_list ')' EOS
  1845.         |    read_handle '(' control_info_list ')' io_list EOS
  1846.         |    read_handle '(' control_info_list ')' ',' io_list EOS
  1847.         |    read_handle format_id EOS
  1848.         |    read_handle format_id ',' io_list EOS
  1849.         ;
  1850. read_handle    :    tok_READ {init_io_ctrl_list();}
  1851.         ;
  1852.  
  1853. accept_stmt    :    tok_ACCEPT format_id EOS
  1854.             {
  1855.                 if(f77_accept_type)
  1856.                 nonstandard($1.line_num,$1.col_num);
  1857.             }
  1858.         |    tok_ACCEPT format_id ',' io_list EOS
  1859.             {
  1860.                 if(f77_accept_type)
  1861.                 nonstandard($1.line_num,$1.col_num);
  1862.             }
  1863.         ;
  1864.  
  1865. /* 46 */
  1866. print_stmt    :    tok_PRINT format_id EOS
  1867.            |    tok_PRINT format_id ','
  1868.                 {complex_const_allowed = TRUE;} io_list
  1869.                 {complex_const_allowed = FALSE;}  EOS
  1870.         ;
  1871.  
  1872. type_output_stmt:    tok_TYPE format_id EOS
  1873.             {
  1874.                 if(f77_accept_type)
  1875.                 nonstandard($1.line_num,$1.col_num);
  1876.             }
  1877.            |    tok_TYPE format_id ','
  1878.                 {complex_const_allowed = TRUE;} io_list
  1879.                 {complex_const_allowed = FALSE;}  EOS
  1880.             {
  1881.                 if(f77_accept_type)
  1882.                 nonstandard($1.line_num,$1.col_num);
  1883.             }
  1884.         ;
  1885.  
  1886. /* 47 */
  1887. control_info_list:    control_info_item
  1888.             {
  1889.                 ++control_item_count;
  1890.             }
  1891.         |    control_info_list ',' control_info_item
  1892.             {
  1893.                 ++control_item_count;
  1894.                 if(! io_warning_given) {
  1895.                   if( io_internal_file ) {
  1896.                 if( (curr_stmt_class == tok_WRITE ||
  1897.                      curr_stmt_class == tok_READ) &&
  1898.                     io_list_directed ) {
  1899.                   if(f77_internal_list_io) {
  1900.                     nonstandard($3.line_num,$3.col_num);
  1901.         msg_tail(": internal file cannot be used with list-directed I/O");
  1902.                   }
  1903.                   io_warning_given = TRUE;
  1904.                 }
  1905.                   }
  1906.                 }
  1907.             }
  1908.         ;
  1909.  
  1910.     /* Note that unit id is not distinguished from format id
  1911.        by the grammar. Use sequence no. to tell which is which.
  1912.      */
  1913. control_info_item:    symbolic_name '=' unit_id
  1914.             {
  1915.                 use_io_keyword(&($1),&($3),curr_stmt_class);
  1916.             }
  1917.         |    unit_id
  1918.             {
  1919.                 if( $1.class == '*' ) {
  1920.                   if(control_item_count == 1) /* format id */
  1921.                 {
  1922.                   io_list_directed = TRUE;
  1923.                 }
  1924.                 }
  1925.                 else if( is_true(ID_EXPR,$1.TOK_flags)){
  1926.  
  1927.                     /* Handle special cases */
  1928.                 if(control_item_count == 0 &&
  1929.                  datatype_of($1.TOK_type) == type_STRING) {
  1930.                     /* unit id=char variable is
  1931.                        an internal file.  I/O goes in
  1932.                        and out of the variable. */
  1933.                   io_internal_file = TRUE;
  1934.                   if(curr_stmt_class == tok_WRITE) {
  1935.                     use_lvalue(&($1));
  1936.                   }
  1937.                 }
  1938.  
  1939.                     /* format id=namelist means
  1940.                        I/O with variables of namelist. */
  1941.                 else if( control_item_count == 1 &&
  1942.                  datatype_of($1.TOK_type) == type_NAMELIST) {
  1943.                     ref_namelist(&($1),curr_stmt_class);
  1944.                 }
  1945.  
  1946.                     /* Handle use of variable */
  1947.                 use_variable(&($1));
  1948.                 }
  1949.             }
  1950.         ;
  1951.  
  1952.             /* OPEN stmt needs its own control list defn to
  1953.                allow for VMS READONLY and similar keywords.
  1954.                Special prodn for unit_id as optional 1st item
  1955.                needed to avoid reduce/reduce conflict with
  1956.                later-occurring symbolic_name items.   */
  1957. open_info_list    :    unit_id
  1958.             {
  1959.                 if( $1.class != '*'
  1960.                    && is_true(ID_EXPR,$1.TOK_flags)){
  1961.                 use_variable(&($1));
  1962.                 }
  1963.                 ++control_item_count;
  1964.             }
  1965.         |    symbolic_name '=' unit_id
  1966.             {
  1967.                 use_io_keyword(&($1),&($3),curr_stmt_class);
  1968.                 ++control_item_count;
  1969.             }
  1970.         |    open_info_list ',' open_info_item
  1971.             {
  1972.                 ++control_item_count;
  1973.             }
  1974.         ;
  1975.  
  1976. open_info_item    :    symbolic_name '=' unit_id
  1977.             {
  1978.                 use_io_keyword(&($1),&($3),curr_stmt_class);
  1979.             }
  1980.         |    symbolic_name    /* NOSPANBLOCKS, READONLY or SHARED */
  1981.             {
  1982.                 use_special_open_keywd(&($1));
  1983.             }
  1984.         ;
  1985.  
  1986. /* 48 */
  1987. io_list        :    io_item
  1988.         |    io_list ',' io_item
  1989.         ;
  1990.  
  1991. io_item        :    expr
  1992.             {
  1993.                 if(is_true(ID_EXPR,$1.TOK_flags)){
  1994.                 if( curr_stmt_class == tok_READ ||
  1995.                     curr_stmt_class == tok_ACCEPT )
  1996.                     use_lvalue(&($1));
  1997.                 else
  1998.                     use_variable(&($1));
  1999.                 }
  2000.             }
  2001.         |    io_implied_do_list
  2002.         ;
  2003.  
  2004. /* 49 */
  2005. io_implied_do_list:    '(' io_list ',' variable_name '=' do_loop_bounds ')'
  2006.             {
  2007.               if( ! is_true(LVALUE_EXPR,$4.TOK_flags) ) {
  2008.                 syntax_error($4.line_num,$4.col_num,
  2009.                      "index is not assignable");
  2010.               }
  2011.               else {
  2012.                  use_implied_do_index(&($4));
  2013.               }
  2014.             }
  2015.         ;
  2016.  
  2017. /* 50 */
  2018. open_stmt    :    tok_OPEN {init_io_ctrl_list();}
  2019.                  '(' open_info_list ')' EOS
  2020.         ;
  2021.  
  2022. /* 51 */
  2023. close_stmt    :    tok_CLOSE {init_io_ctrl_list();}
  2024.                 '(' control_info_list ')' EOS
  2025.         ;
  2026.  
  2027. /* 52 */
  2028. inquire_stmt    :    tok_INQUIRE {init_io_ctrl_list();}
  2029.                 '(' control_info_list ')' EOS
  2030.         ;
  2031.  
  2032. /* 53 */
  2033. backspace_stmt    :    backspace_handle unit_id EOS
  2034.             {
  2035.                 if( $2.class != '*'
  2036.                    && is_true(ID_EXPR,$2.TOK_flags)){
  2037.                 use_variable(&($2));
  2038.                 }
  2039.             }
  2040.         |    backspace_handle '(' control_info_list ')' EOS
  2041.         ;
  2042. backspace_handle:    tok_BACKSPACE {init_io_ctrl_list();}
  2043.         ;
  2044.  
  2045. /* 54 */
  2046. endfile_stmt    :    endfile_handle unit_id EOS
  2047.             {
  2048.                 if( $2.class != '*'
  2049.                    && is_true(ID_EXPR,$2.TOK_flags)){
  2050.                 use_variable(&($2));
  2051.                 }
  2052.             }
  2053.         |    endfile_handle '(' control_info_list ')' EOS
  2054.         ;
  2055. endfile_handle    :    tok_ENDFILE {init_io_ctrl_list();}
  2056.         |    tok_END tok_FILE {init_io_ctrl_list();}
  2057.         ;
  2058.  
  2059. /* 55 */
  2060. rewind_stmt    :    rewind_handle unit_id EOS
  2061.             {
  2062.                 if( $2.class != '*'
  2063.                    && is_true(ID_EXPR,$2.TOK_flags)){
  2064.                 use_variable(&($2));
  2065.                 }
  2066.             }
  2067.         |    rewind_handle '(' control_info_list ')' EOS
  2068.         ;
  2069. rewind_handle    :    tok_REWIND {init_io_ctrl_list();}
  2070.         ;
  2071.  
  2072.  
  2073. /* 56 */
  2074.         /* "expr" causes shift/reduce conflict on ')' between
  2075.            red'n  unit_id: expr_  and shift  primary: ( expr_ ).
  2076.            Use "associativity" rule to force reduction */
  2077. unit_id        :    expr        %prec REDUCE
  2078.         |    '*'
  2079.         ;
  2080.  
  2081. /* 57 */
  2082. format_id    :    char_expr
  2083.             {
  2084.                 if(is_true(ID_EXPR,$1.TOK_flags)){
  2085.                  use_variable(&($1));
  2086.                 }
  2087.             }
  2088.         |    '*'
  2089.         ;
  2090.  
  2091. /* 58,59 */
  2092. format_stmt    :    tok_FORMAT {inside_format=TRUE;} '(' format_spec ')' EOS
  2093.             {
  2094.               inside_format=FALSE;
  2095.             }
  2096.         ;
  2097.  
  2098. /* 60-69 */
  2099. format_spec    :        /* EMPTY */
  2100.         |    nonempty_format_spec
  2101.         ;
  2102.  
  2103.  
  2104. nonempty_format_spec:    fmt_spec_item
  2105.         |    nonempty_format_spec fmt_spec_item
  2106.         ;
  2107.  
  2108. fmt_spec_item    :    repeatable_fmt_item
  2109.         |    unrepeatable_fmt_item
  2110.         |    fmt_item_separator
  2111.         ;
  2112.  
  2113. repeatable_fmt_item:    '(' nonempty_format_spec ')'
  2114.         |    tok_edit_descriptor
  2115.         ;
  2116.  
  2117. unrepeatable_fmt_item:    tok_string
  2118.         |    tok_hollerith
  2119.         |    repeat_spec
  2120.         |    variable_fmt_item
  2121.         ;
  2122.  
  2123. fmt_item_separator:    ','
  2124.         |    '/'
  2125.         |    tok_concat    /* since lexer spots "//" */
  2126.         |    ':'
  2127.         |    '.'        /* Occurs when variable w.d is used */
  2128.         |    nonstandard_fmt_item
  2129.             {
  2130.               if(f77_format_dollarsigns)
  2131.                  nonstandard($1.line_num,$1.col_num);
  2132.             }
  2133.         ;
  2134.  
  2135. nonstandard_fmt_item: '$'    /* VMS uses this */
  2136.         ;
  2137.  
  2138. repeat_spec    :    tok_integer_const
  2139.         |    '-' tok_integer_const    /* for kP descriptor */
  2140.         |    '+' tok_integer_const    /* for +kP descriptor */
  2141.         ;
  2142.  
  2143.         /* VMS-style variable format size or repeat spec*/
  2144. variable_fmt_item:    '<' {inside_format=FALSE;} integer_expr
  2145.                 {inside_format=TRUE;} '>'
  2146.             {
  2147.               if(f77_variable_format)
  2148.                  nonstandard($1.line_num,$1.col_num);
  2149.             }
  2150.         ;
  2151.  
  2152. /* 70 handle only: complete defn handled as assignment stmt */
  2153.  
  2154. stmt_function_handle:    scalar_name '(' stmt_function_dummy_list ')'
  2155.             {
  2156.               check_stmt_sequence(&($1),SEQ_STMT_FUN);
  2157.  
  2158.                 def_stmt_function(&($1),&($3));
  2159.                     /* make token info */
  2160.                 primary_id_expr(&($1),&($$));
  2161. #ifdef DEBUG_PARSER
  2162.                 if(debug_parser)
  2163.                   print_exprlist("stmt function",&($3));
  2164. #endif
  2165.             }
  2166.         ;
  2167.  
  2168. stmt_function_dummy_list: /* empty list */
  2169.             {
  2170.                 $$.next_token = (Token*)NULL;
  2171.             }
  2172.         | nonempty_stmt_fun_dummy_list
  2173.         ;
  2174.  
  2175. nonempty_stmt_fun_dummy_list:      stmt_function_dummy_arg
  2176.             {
  2177.                 $$.next_token = append_token((Token*)NULL,&($1));
  2178.             }
  2179.         |      nonempty_stmt_fun_dummy_list ','
  2180.                     stmt_function_dummy_arg
  2181.             {
  2182.                 $$.next_token = append_token($1.next_token,&($3));
  2183.             }
  2184.         ;
  2185.  
  2186. stmt_function_dummy_arg:  variable_name    /* for now: later, handle correctly */
  2187.         ;
  2188.  
  2189. /* 71 */
  2190. call_stmt    :    call_handle
  2191.             {
  2192.                  call_subr(&($1),(Token*)NULL);
  2193.                  complex_const_allowed = FALSE;
  2194.             } EOS
  2195.  
  2196.         |    call_handle '(' ')'
  2197.             {
  2198.                  call_subr(&($1),(Token*)NULL);
  2199.                  complex_const_allowed = FALSE;
  2200.             } EOS
  2201.  
  2202.         |    call_handle '(' subr_arg_list ')'
  2203.             {
  2204.                  call_subr(&($1),&($3));
  2205. #ifdef DEBUG_PARSER
  2206.                  if(debug_parser)
  2207.                 print_exprlist("call stmt",&($3));
  2208. #endif
  2209.                  complex_const_allowed = FALSE;
  2210.             } EOS
  2211.         ;
  2212.  
  2213. call_handle    :    tok_CALL symbolic_name
  2214.             {
  2215.                  complex_const_allowed = TRUE;
  2216.                  $$ = $2;
  2217.             }
  2218.         ;
  2219. subr_arg_list:        subr_arg
  2220.             {
  2221.                 $$.next_token = append_token((Token*)NULL,&($1));
  2222.                 $$.left_token = (Token *)NULL;
  2223.             }
  2224.         |    subr_arg_list ',' subr_arg
  2225.             {
  2226.                 $$.next_token = append_token($1.next_token,&($3));
  2227.             }
  2228.         ;
  2229.  
  2230. subr_arg    :    expr
  2231.             {
  2232.                 if(is_true(ID_EXPR,$1.TOK_flags)){
  2233.                  use_actual_arg(&($1));
  2234.                  use_variable(&($1));
  2235.                 }
  2236.             }
  2237.         |    '*' pre_label label
  2238.             {
  2239.               $$ = $3;
  2240.               $$.left_token = (Token *)NULL;
  2241.             }
  2242.         ;
  2243.  
  2244. /* 72 */
  2245. return_stmt    :    tok_RETURN EOS
  2246.             {
  2247.                  do_RETURN(current_module_hash,&($1));
  2248.             }
  2249.         |    tok_RETURN integer_expr EOS
  2250.             {
  2251.                  do_RETURN(current_module_hash,&($1));
  2252.             }
  2253.         ;
  2254.  
  2255. /* 73 */
  2256. function_reference:    fun_or_substr_handle '(' fun_arg_list ')'
  2257.             {
  2258.                    /* restore context */
  2259.                 if(!is_true(COMPLEX_FLAG,$1.TOK_flags))
  2260.                   complex_const_allowed=FALSE;
  2261.                 if(is_true(IN_ASSIGN,$1.TOK_flags))
  2262.                   in_assignment_stmt = TRUE;
  2263.  
  2264.                   /* Change empty arg list to no arg list */
  2265.                 if($3.next_token == NULL)
  2266.                   call_func(&($1),(Token *)NULL);
  2267.                 else
  2268.                   call_func(&($1),&($3));
  2269.                             /* make token info */
  2270.                 func_ref_expr(&($1),&($3),&($$));
  2271.                 /* Substitute empty token for null arglist */
  2272.                 $$.left_token = add_tree_node(
  2273.                            &($2),&($1),
  2274.                            ($3.next_token == NULL?
  2275.                             empty_token(&($3)) :
  2276.                             $3.next_token) );
  2277. #ifdef DEBUG_PARSER
  2278.                 if(debug_parser)
  2279.                     print_exprlist("function",&($3));
  2280. #endif
  2281.             }
  2282.         ;
  2283.  
  2284. fun_or_substr_handle:    scalar_name
  2285.             {
  2286.               if(complex_const_allowed)/* save context */
  2287.                 make_true(COMPLEX_FLAG,$$.TOK_flags);
  2288.               complex_const_allowed=TRUE;
  2289.               if(in_assignment_stmt)
  2290.                 make_true(IN_ASSIGN,$$.TOK_flags);
  2291.               in_assignment_stmt = FALSE;
  2292.             }
  2293.         ;
  2294. fun_arg_list    :    /* empty */
  2295.             {
  2296.                 $$.class = 0;
  2297.                 $$.next_token = (Token *)NULL;
  2298.                 $$.left_token = (Token *)NULL;
  2299.             }
  2300.         |    nonempty_fun_arg_list
  2301.         ;
  2302.  
  2303. nonempty_fun_arg_list:    expr
  2304.             {
  2305.                 $$.next_token = append_token((Token*)NULL,&($1));
  2306.                 $$.left_token = (Token *)NULL;
  2307.             }
  2308.         |    nonempty_fun_arg_list ',' expr
  2309.             {
  2310.                 $$.next_token = append_token($1.next_token,&($3));
  2311.             }
  2312.  
  2313.         ;
  2314. /* 74 not present: type checking not done at this level */
  2315.  
  2316. /* 75 was constant_expr, but only used by PARAMETER */
  2317. parameter_expr    :    /* arith, char, or logical */ expr
  2318.             {
  2319.               int t=datatype_of($1.TOK_type);
  2320.               if( t != type_ERROR){
  2321.                 if( ! is_const_type(t) ) {
  2322.                   syntax_error($1.line_num,$1.col_num,
  2323.               "arithmetic, char, or logical expression expected");
  2324.                 }
  2325.                 else {
  2326.                   if( !is_true(PARAMETER_EXPR,$1.TOK_flags) ) {
  2327.                 syntax_error($1.line_num,$1.col_num,
  2328.                        "constant expression expected");
  2329.                   }
  2330.                 /* Here we allow, with some warnings, expr
  2331.                    containing intrins func or **REAL in
  2332.                    PARAMETER defn. */
  2333.                   else if( !is_true(CONST_EXPR,$1.TOK_flags) ) {
  2334.                 if(f77_param_intrinsic) {
  2335.                   nonstandard($1.line_num,$1.col_num);
  2336.                   msg_tail(
  2337.              "intrinsic function or **REAL in PARAMETER defn");
  2338.                 }
  2339.                   }
  2340.                 }
  2341.               }
  2342.             }
  2343.         ;
  2344.  
  2345. /* 76 following the text of the standard, not the diagrams */
  2346. expr        :    log_expr
  2347.             {
  2348.                 /* Fix it up in case it is used in expr list */
  2349.               $$.next_token = (Token *) NULL;
  2350. #ifdef DEBUG_PARSER
  2351.                 if(debug_parser) {
  2352.                 (void)fprintf(list_fd,
  2353.                     "\nexpr: class=0x%x subclass=0x%x",
  2354.                     $1.class,
  2355.                     $1.subclass);
  2356.                 }
  2357. #endif
  2358.             }
  2359.         ;
  2360.  
  2361. log_expr    :    log_disjunct
  2362.  
  2363.         |    expr tok_EQV log_disjunct
  2364.             {
  2365.                 do_binexpr(&($1),&($2),&($3)
  2366.                      ,&($$));
  2367.             }
  2368.         |    expr tok_NEQV log_disjunct
  2369.             {
  2370.                 do_binexpr(&($1),&($2),&($3)
  2371.                      ,&($$));
  2372.             }
  2373.         ;
  2374.  
  2375. log_disjunct    :    log_term
  2376.  
  2377.         |    log_disjunct tok_OR log_term
  2378.             {
  2379.                 do_binexpr(&($1),&($2),&($3)
  2380.                      ,&($$));
  2381.             }
  2382.         ;
  2383.  
  2384. log_term    :    log_factor
  2385.  
  2386.         |    log_term tok_AND log_factor
  2387.             {
  2388.                 do_binexpr(&($1),&($2),&($3)
  2389.                      ,&($$));
  2390.             }
  2391.         ;
  2392.  
  2393. log_factor    :    log_primary
  2394.  
  2395.         |    tok_NOT log_primary
  2396.             {
  2397.                 do_unexpr(&($1),&($2),&($$));
  2398.             }
  2399.         ;
  2400.  
  2401. log_primary    :    arith_expr
  2402.  
  2403.         |    log_primary tok_relop log_primary
  2404.             {
  2405.                 do_binexpr(&($1),&($2),&($3)
  2406.                      ,&($$));
  2407.             }
  2408.         ;
  2409.  
  2410.  
  2411. arith_expr    :    term
  2412.  
  2413.         |    '-' term
  2414.             {
  2415.                 do_unexpr(&($1),&($2),&($$));
  2416.             }
  2417.         |    '+' term
  2418.             {
  2419.                 do_unexpr(&($1),&($2),&($$));
  2420.             }
  2421.         |    arith_expr '+' term
  2422.             {
  2423.                 do_binexpr(&($1),&($2),&($3)
  2424.                      ,&($$));
  2425.             }
  2426.         |    arith_expr '-' term
  2427.             {
  2428.                 do_binexpr(&($1),&($2),&($3)
  2429.                      ,&($$));
  2430.             }
  2431.         ;
  2432.  
  2433. term        :    factor
  2434.  
  2435.         |    term '/' factor
  2436.             {
  2437.                 do_binexpr(&($1),&($2),&($3)
  2438.                      ,&($$));
  2439.                 if(div_check &&
  2440.                    !is_true(CONST_EXPR,$3.TOK_flags)){
  2441.                 warning($2.line_num,$2.col_num,
  2442.                     "Possible division by zero");
  2443.                 }
  2444.             }
  2445.         |    term '*' factor
  2446.             {
  2447.                 do_binexpr(&($1),&($2),&($3)
  2448.                      ,&($$));
  2449.             }
  2450.         ;
  2451.  
  2452. factor        :    char_expr
  2453.  
  2454.         |    char_expr tok_power factor
  2455.             {
  2456.                 do_binexpr(&($1),&($2),&($3)
  2457.                      ,&($$));
  2458.             }
  2459.         ;
  2460.  
  2461. char_expr    :    primary
  2462.  
  2463.         |    char_expr tok_concat primary
  2464.             {
  2465.                 do_binexpr(&($1),&($2),&($3)
  2466.                      ,&($$));
  2467.             }
  2468.         ;
  2469.  
  2470. primary        :    variable_name
  2471.  
  2472.         |    array_element_name
  2473.  
  2474.         |    function_reference
  2475.  
  2476.         |    substring_name
  2477.  
  2478.         |    literal_const
  2479.             {
  2480.                 $$.TOK_flags = 0;
  2481.                 $$.left_token = (Token *)NULL;
  2482.                 make_true(CONST_EXPR,$$.TOK_flags);
  2483.                 make_true(PARAMETER_EXPR,$$.TOK_flags);
  2484.                 make_true(LIT_CONST,$$.TOK_flags);
  2485.                 make_true(EVALUATED_EXPR,$$.TOK_flags);
  2486.             }
  2487.         |    '(' expr ')'
  2488.             {
  2489.                 $$ = $2;
  2490.                 /* (identifier) becomes a non-identifier */
  2491.                 if(is_true(LVALUE_EXPR,$2.TOK_flags)) {
  2492.                 if(pretty_parens) {
  2493.                   ugly_code($2.line_num,$2.col_num,
  2494.                       "Extraneous parentheses");
  2495.                 }
  2496.                 use_variable(&($2));
  2497.                 make_false(LVALUE_EXPR,$$.TOK_flags);
  2498.                 make_false(ARRAY_ID_EXPR,$$.TOK_flags);
  2499.                 make_false(ARRAY_ELEMENT_EXPR,$$.TOK_flags);
  2500.                 make_false(ID_EXPR,$$.TOK_flags);
  2501.                 }
  2502.                 /* (expr) becomes tree node with root = '(' */
  2503.                 $$.left_token = add_tree_node(&($1),&($2),
  2504.                               (Token*)NULL);
  2505.             }
  2506.         ;
  2507.  
  2508.                 /* Literal constants are numbers, strings
  2509.                    holleriths, and logical constants */
  2510. literal_const    :    numeric_const
  2511.                 /* (class, size set in numeric_const productions) */
  2512.         |    tok_string
  2513.             {
  2514.                 $$.TOK_type = type_byte(class_VAR,type_STRING);
  2515.                 /* (size is set in get_string) */
  2516.             }
  2517.         |    tok_hollerith
  2518.             {
  2519.                 $$.TOK_type = type_byte(class_VAR,type_HOLLERITH);
  2520.                 /* (size is set in get_hollerith) */
  2521.                 if(port_hollerith) {
  2522.                 warning($1.line_num,$1.col_num,
  2523.                 "hollerith constant may not be portable");
  2524.                 }
  2525.             }
  2526.         |    tok_logical_const
  2527.             {
  2528.                 $$.TOK_type = type_byte(class_VAR,type_LOGICAL);
  2529.                 $$.size = size_DEFAULT;
  2530.             }
  2531.         ;
  2532.  
  2533. numeric_const    :    tok_integer_const
  2534.             {
  2535.                 $$.TOK_type = type_byte(class_VAR,type_INTEGER);
  2536.                 $$.size = size_DEFAULT;
  2537.             }
  2538.         |    tok_real_const
  2539.             {
  2540.                 $$.TOK_type = type_byte(class_VAR,type_REAL);
  2541.                 $$.size = size_DEFAULT;
  2542.             }
  2543.         |    tok_dp_const
  2544.             {
  2545.                 $$.TOK_type = type_byte(class_VAR,type_DP);
  2546.                 $$.size = size_DEFAULT;
  2547.             }
  2548.         |    tok_quad_const
  2549.             {
  2550.                 $$.TOK_type = type_byte(class_VAR,type_QUAD);
  2551.                 $$.size = size_QUAD;
  2552.                             if(f77_quad_constants) {
  2553.                               nonstandard($1.line_num,$1.col_num);
  2554.                               msg_tail(": quad precision constant");
  2555.                             }
  2556.             }
  2557.         |    tok_complex_const
  2558.             {
  2559.                 $$.TOK_type = type_byte(class_VAR,type_COMPLEX);
  2560.                 $$.size = size_DEFAULT;
  2561.             }
  2562.         |    tok_dcomplex_const
  2563.             {
  2564.                 $$.TOK_type = type_byte(class_VAR,type_DCOMPLEX);
  2565.                 $$.size = size_DEFAULT;
  2566.             }
  2567.         ;
  2568.  
  2569. /* 77 */
  2570. integer_expr    :    /* integer */ arith_expr
  2571.             {
  2572.                 if(is_true(ID_EXPR,$1.TOK_flags)){
  2573.                 use_variable(&($1));
  2574.                 }
  2575.                 if(datatype_of($1.TOK_type) != type_INTEGER) {
  2576.                 syntax_error(
  2577.                     $1.line_num,$1.col_num,
  2578.                     "expression must be integer type");
  2579.                 }
  2580.             }
  2581.         ;
  2582.  
  2583. /* 78 */
  2584. int_real_dp_expr:    /* integer, real, or double */ arith_expr
  2585.             {
  2586.                 if(is_true(ID_EXPR,$1.TOK_flags)){
  2587.                 use_variable(&($1));
  2588.                 }
  2589.                 {
  2590.                 int t=datatype_of($1.TOK_type);
  2591.                     if(t != type_INTEGER && t != type_REAL
  2592.                     && t != type_DP ) {
  2593.                     syntax_error(
  2594.                       $1.line_num,$1.col_num,
  2595.         "expression must be integer, real, or double precision type");
  2596.                         }
  2597.                 }
  2598.             }
  2599.         ;
  2600.  
  2601. /* 79 absent */
  2602.  
  2603. /* 80 */
  2604. int_constant_expr:    /* integer const */ arith_expr
  2605.             {
  2606.                 if(is_true(ID_EXPR,$1.TOK_flags)){
  2607.                 use_variable(&($1));
  2608.                 }
  2609.                 if( ! is_true(CONST_EXPR,$1.TOK_flags) ) {
  2610.                 syntax_error(
  2611.                     $1.line_num,$1.col_num,
  2612.                     "constant expression expected");
  2613.                 }
  2614.                 else {
  2615.                   if(datatype_of($1.TOK_type) != type_INTEGER){
  2616.                 syntax_error(
  2617.                     $1.line_num,$1.col_num,
  2618.                     "integer expression expected");
  2619.                   }
  2620.                   else {
  2621.                 $$.value.integer = int_expr_value(&($1));
  2622.                   }
  2623.                 }
  2624.             }
  2625.         ;
  2626.  
  2627. /* 81 */
  2628. dim_bound_expr    :       /* integer */  arith_expr
  2629.             {
  2630.                 if(is_true(ID_EXPR,$1.TOK_flags)){
  2631.                 use_variable(&($1));
  2632.                 }
  2633.  
  2634.                 if( datatype_of($1.TOK_type) != type_INTEGER ){
  2635.                 syntax_error(
  2636.                     $1.line_num,$1.col_num,
  2637.                     "integer dimension expected");
  2638.                 $$.value.integer = 0;
  2639.                 }
  2640.                 else {
  2641.                   if( is_true(EVALUATED_EXPR,$1.TOK_flags) )
  2642.                 $$.value.integer =
  2643.                   int_expr_value(&($1));
  2644.                   else        /* must be dummy */
  2645.                 $$.value.integer = 0;
  2646.                 }
  2647.             }
  2648.         ;
  2649.  
  2650. /* 82-85 absent: no type checking here */
  2651. /* 86-87 absent: see 76 */
  2652.  
  2653. /* 88 */
  2654. array_element_lvalue:    array_name '(' subscript_list ')'
  2655.             {
  2656.                 ref_array(&($1),&($3));
  2657. #ifdef DEBUG_PARSER
  2658.                 if(debug_parser)
  2659.                     print_exprlist("array lvalue",&($3));
  2660. #endif
  2661.                     /* array now becomes scalar */
  2662.                 make_false(ARRAY_ID_EXPR,$$.TOK_flags);
  2663.                 make_true(ARRAY_ELEMENT_EXPR,$$.TOK_flags);
  2664.                 $$.left_token = add_tree_node(
  2665.                            &($2),&($1),$3.next_token);
  2666.                 $$.next_token = (Token *) NULL;
  2667.             }
  2668.         ;
  2669.  
  2670. array_element_name:    array_name '(' subscript_list ')'
  2671.             {
  2672.                 ref_array(&($1),&($3));
  2673. #ifdef DEBUG_PARSER
  2674.                 if(debug_parser)
  2675.                     print_exprlist("array",&($3));
  2676. #endif
  2677.                     /* array now becomes scalar */
  2678.                 make_false(ARRAY_ID_EXPR,$$.TOK_flags);
  2679.                 make_true(ARRAY_ELEMENT_EXPR,$$.TOK_flags);
  2680.                 $$.left_token = add_tree_node(
  2681.                            &($2),&($1),$3.next_token);
  2682.                 $$.next_token = (Token *) NULL;
  2683.             }
  2684.         ;
  2685.  
  2686. subscript_list    :    subscript
  2687.             {
  2688.                 $$.next_token = append_token((Token*)NULL,&($1));
  2689.             }
  2690.         |    subscript_list ',' subscript
  2691.             {
  2692.                 $$.next_token = append_token($1.next_token,&($3));
  2693.             }
  2694.              ;
  2695.  
  2696. subscript    :    expr
  2697.             {
  2698.                 if(is_true(ID_EXPR,$1.TOK_flags)){
  2699.                  use_variable(&($1));
  2700.                 }
  2701.                 /* check subscript exprs for integer type */
  2702.                 if(datatype_of($1.TOK_type) != type_INTEGER)
  2703.                   if(trunc_real_subscript)
  2704.                      warning($1.line_num,$1.col_num,
  2705.                      "subscript is not integer");
  2706.             }
  2707.         ;
  2708.  
  2709. /* 89 */
  2710. substring_name    :    fun_or_substr_handle  substring_interval
  2711.             {
  2712.                    /* restore status of complex flag */
  2713.                 if(!is_true(COMPLEX_FLAG,$1.TOK_flags))
  2714.                   complex_const_allowed=FALSE;
  2715.                 /* set flag to keep more than just id for
  2716.                    arg list text */
  2717.                 if(is_true(ID_EXPR,$1.TOK_flags))
  2718.                    make_true(ARRAY_ELEMENT_EXPR,$$.TOK_flags);
  2719.                 $$.size=substring_size(&($1),&($2));
  2720.                 $$.left_token = add_tree_node(
  2721.                            &save_token,&($1),&($2));
  2722.                 $$.next_token = (Token *) NULL;
  2723.             }
  2724.  
  2725.         |    function_reference  substring_interval
  2726.             {
  2727.                 $$.size=substring_size(&($1),&($2));
  2728.                 $$.left_token = add_tree_node(
  2729.                            &save_token,&($1),&($2));
  2730.                 $$.next_token = (Token *) NULL;
  2731.             }
  2732.  
  2733.         |    array_element_name substring_interval
  2734.             {
  2735.                 $$.size=substring_size(&($1),&($2));
  2736.                 $$.left_token = add_tree_node(
  2737.                            &save_token,&($1),&($2));
  2738.                 $$.next_token = (Token *) NULL;
  2739.             }
  2740.         ;
  2741.  
  2742. substring_lvalue:    scalar_name substring_interval
  2743.             {
  2744.                 $$.size=substring_size(&($1),&($2));
  2745.             }
  2746.         |    array_element_lvalue substring_interval
  2747.             {
  2748.                 $$.size=substring_size(&($1),&($2));
  2749.             }
  2750.         ;
  2751.  
  2752.             /* substring interval: limits go into
  2753.                TOK_start, TOK_end.  */
  2754.  
  2755. substring_interval:    '(' ':' ')'
  2756.             {
  2757.                 $$.TOK_start=1;
  2758.                 $$.TOK_end=0; /* 0 means LEN */
  2759.  
  2760.                 save_token = $1; /* Save the paren for tree node */
  2761.                 $$.left_token =
  2762.                   add_tree_node(&($2),
  2763.                      empty_token(&($1)),empty_token(&($3)));
  2764.                 /* Nullify next_token so it looks like
  2765.                    a tokenlist */
  2766.                 $$.next_token = (Token *)NULL;
  2767.             }
  2768.  
  2769.           |    '(' substr_index_expr ':' ')'
  2770.             {
  2771.                 $$.TOK_start=$2.value.integer;
  2772.                 $$.TOK_end=0; /* 0 means LEN */
  2773.  
  2774.                 save_token = $1; /* Save the paren for tree node */
  2775.                 $$.left_token =
  2776.                   add_tree_node(&($3),&($2),empty_token(&($4)));
  2777.                 $$.next_token = (Token *)NULL;
  2778.             }
  2779.           |    '(' ':' substr_index_expr ')'
  2780.             {
  2781.                 $$.TOK_start=1;
  2782.                 $$.TOK_end=$3.value.integer;
  2783.  
  2784.                 save_token = $1; /* Save the paren for tree node */
  2785.                 $$.left_token =
  2786.                   add_tree_node(&($2),empty_token(&($1)),&($3));
  2787.                 $$.next_token = (Token *)NULL;
  2788.             }
  2789.           |    '(' substr_index_expr ':' substr_index_expr ')'
  2790.             {
  2791.                 $$.TOK_start=$2.value.integer;
  2792.                 $$.TOK_end=$4.value.integer;
  2793.  
  2794.                 save_token = $1; /* Save the paren for tree node */
  2795.                 $$.left_token =
  2796.                   add_tree_node(&($3),&($2),&($4));
  2797.                 $$.next_token = (Token *)NULL;
  2798.             }
  2799.           ;
  2800.  
  2801. substr_index_expr:    arith_expr
  2802.             {
  2803.               if(is_true(ID_EXPR,$1.TOK_flags)){
  2804.                 use_variable(&($1));
  2805.               }
  2806.                 /* check validity and replace nonconst
  2807.                    value by size_UNKNOWN. */
  2808.               if(is_true(CONST_EXPR,$1.TOK_flags)) {
  2809.                 if( ($$.value.integer=int_expr_value(&($1))) < 1) {
  2810.                   syntax_error($1.line_num,$1.col_num,
  2811.                        "invalid substring index");
  2812.                 }
  2813.               }
  2814.               else  /* (no longer need ID hash index) */
  2815.                 $$.value.integer=size_UNKNOWN;
  2816.             }
  2817.         ;
  2818.  
  2819. /* 90-98 absent: name categories not distinguished */
  2820.  
  2821. /* 99 */
  2822. variable_name    :    scalar_name
  2823.         |    array_name
  2824.         ;
  2825.  
  2826. scalar_name    :    tok_identifier
  2827.             {
  2828.                 ref_variable(&($1));
  2829.                 primary_id_expr(&($1),&($$));
  2830.             }
  2831.         ;
  2832.  
  2833. array_name    :    tok_array_identifier
  2834.             {
  2835.                 ref_variable(&($1));
  2836.                 primary_id_expr(&($1),&($$));
  2837.             }
  2838.         ;
  2839.  
  2840.  
  2841. /* symbolic_name refers to a name without making it into an id expr */
  2842. symbolic_name    :    tok_identifier
  2843.         |    tok_array_identifier
  2844.         ;
  2845.  
  2846. /* 100 */
  2847. data_constant    :    numeric_const
  2848.         |    '-' numeric_const
  2849.         |    '+' numeric_const
  2850.         |    tok_logical_const
  2851.            |    tok_string
  2852.         |    tok_hollerith
  2853.         ;
  2854.  
  2855. /* 101-102 absent */
  2856.  
  2857. /* 103 */
  2858. nonzero_unsigned_int_const:
  2859.             tok_integer_const
  2860.             {
  2861.               if($1.value.integer == 0) {
  2862.                 if(misc_warn) {
  2863.                   warning($1.line_num,$1.col_num,
  2864.                     "nonzero integer expected");
  2865.                   msg_tail(": substituting 1");
  2866.                 }
  2867.                 $$.value.integer = 1;
  2868.               }
  2869.               $$.left_token = (Token *)NULL;
  2870.             }
  2871.         ;
  2872.  
  2873. /* 104-109 absent: lexer handles these */
  2874.     /* pre_label prepares for an expected label by setting flag
  2875.        so that lexer won't look for E-format number.  All grammar
  2876.        rules that have "label" precede it with "pre_label" */
  2877. pre_label    :    /* NOTHING */
  2878.             {
  2879.                 integer_context=TRUE;
  2880.             }
  2881.         ;
  2882.  
  2883. /* 110 */
  2884. label        :    tok_integer_const
  2885.             {
  2886.                 integer_context=FALSE;
  2887.                 $$.TOK_type = type_byte(class_LABEL,type_LABEL);
  2888.                 $$.size = size_DEFAULT;
  2889.                 $$.TOK_flags = 0;
  2890.             }
  2891.         ;
  2892.  
  2893. /* 111-116 absent: lexer handles these */
  2894.  
  2895. %%
  2896.  
  2897. void
  2898. init_parser(VOID)            /* Initialize various flags & counters */
  2899. {
  2900.     initial_flag = TRUE;    /* set flag for keyword test */
  2901.     implicit_flag=FALSE;    /* clear flags for IMPLICIT stmt */
  2902.     implicit_letter_flag = FALSE;
  2903.     implicit_type_given = FALSE;
  2904.     implicit_none = FALSE;
  2905.     global_save = FALSE;
  2906.     prev_token_class = EOS;
  2907.     complex_const_allowed = FALSE;
  2908.     stmt_sequence_no = 0;
  2909.     true_prev_stmt_line_num = 0;
  2910. }
  2911.  
  2912.                 /* Handle unary expressions: link
  2913.                    into a tree and propagate type.
  2914.                  */
  2915. PRIVATE void
  2916. #if HAVE_STDC
  2917. do_unexpr(Token *op, Token *expr, Token *result)
  2918. #else /* K&R style */
  2919. do_unexpr(op,expr,result)
  2920.      Token *op,*expr,*result;
  2921. #endif /* HAVE_STDC */
  2922. {
  2923.   unexpr_type(op,expr,result);
  2924.  
  2925.   result->left_token = add_tree_node(op, expr, (Token*)NULL);
  2926. }
  2927.                 /* Handle binary expressions: link
  2928.                    into a tree and propagate type.
  2929.                  */
  2930. PRIVATE void
  2931. #if HAVE_STDC
  2932. do_binexpr(Token *l_expr, Token *op, Token *r_expr, Token *result)
  2933. #else /* K&R style */
  2934. do_binexpr(l_expr,op,r_expr,result)
  2935.      Token *l_expr,*op,*r_expr,*result;
  2936. #endif /* HAVE_STDC */
  2937. {
  2938.   binexpr_type(l_expr,op,r_expr,result); /* Propagate the type */
  2939.  
  2940.   result->left_token = add_tree_node(op, l_expr, r_expr);
  2941. }
  2942.  
  2943.  
  2944.             /* Changes a token to empty and replaces
  2945.                src_text by null string, value by 0.  Other
  2946.                info (line, col, etc.)  unchanged. */
  2947.  
  2948. PRIVATE Token *
  2949. #if HAVE_STDC
  2950. empty_token(Token *t)
  2951. #else /* K&R style */
  2952. empty_token(t)
  2953.      Token *t;
  2954. #endif /* HAVE_STDC */
  2955. {
  2956. #ifdef DEBUG_EMPTY_TOKEN
  2957.   static char *nullstring="(empty)"; /* for debugging.  */
  2958. #else
  2959.   static char *nullstring=""; /* for operation.  */
  2960. #endif
  2961.   t->class = tok_empty;
  2962.   t->subclass = 0;
  2963.   t->value.integer = 0;
  2964.   t->left_token = (Token *) NULL;
  2965.   t->src_text = nullstring;
  2966.  
  2967.   return t;
  2968. }
  2969.  
  2970.         /* Propagate non-integer type if any of DO loop
  2971.            bounds are non-integer. */
  2972. PRIVATE int
  2973. #if HAVE_STDC
  2974. do_bounds_type(Token *t1, Token *t2, Token *t3)
  2975. #else /* K&R style */
  2976. do_bounds_type(t1,t2,t3)
  2977.      Token *t1, *t2, *t3;
  2978. #endif /* HAVE_STDC */
  2979. {
  2980.   int result_type;
  2981.        if(datatype_of(t1->TOK_type) != type_INTEGER)result_type = t1->TOK_type;
  2982.   else if(datatype_of(t2->TOK_type) != type_INTEGER)result_type = t2->TOK_type;
  2983.   else if(datatype_of(t3->TOK_type) != type_INTEGER)result_type = t3->TOK_type;
  2984.   else result_type = t1->TOK_type;
  2985.   return result_type;
  2986. }
  2987.  
  2988.  
  2989. /* Debugging routine: prints the expression list of various productions */
  2990. #ifdef DEBUG_PARSER
  2991. PRIVATE void
  2992. print_exprlist(s,t)
  2993.     char *s;
  2994.     Token *t;
  2995. {
  2996.  
  2997.     (void)fprintf(list_fd,"\n%s arglist: ",s);
  2998.  
  2999.     if(t == NULL)
  3000.         (void)fprintf(list_fd,"(empty)");
  3001.     else {
  3002.           while( (t=t->next_token) != NULL) {
  3003.           fprintf(list_fd,"%s ",type_name[datatype_of(t->TOK_type)]);
  3004.           if( is_true(ID_EXPR,t->TOK_flags) )
  3005.             (void)fprintf(list_fd,"(%s) ",token_name(*t));
  3006.         }
  3007.     }
  3008. }
  3009.  
  3010. PRIVATE void
  3011. print_comlist(s,t)
  3012.     char *s;
  3013.     Token *t;
  3014. {
  3015.  
  3016.     (void)fprintf(list_fd,"\n%s varlist: ",s);
  3017.  
  3018.     if(t == NULL)
  3019.         (void)fprintf(list_fd,"(empty)");
  3020.     else {
  3021.           while( (t=t->next_token) != NULL) {
  3022.           fprintf(list_fd,"%s ",type_name[datatype_of(t->TOK_type)]);
  3023.           if( is_true(ID_EXPR,t->TOK_flags) )
  3024.             (void)fprintf(list_fd,"(%s) ",token_name(*t));
  3025.         }
  3026.       }
  3027. }
  3028. #endif
  3029.  
  3030. /* After having parsed prog_stmt, function_stmt, subroutine_stmt,
  3031.    block_data_stmt, the stmt_sequence_no is set to the value SEQ_HEADER.
  3032. */
  3033.  
  3034. void
  3035. #if HAVE_STDC
  3036. check_seq_header(Token *t)
  3037. #else /* K&R style */
  3038. check_seq_header(t)
  3039.      Token *t;
  3040. #endif /* HAVE_STDC */
  3041. {
  3042.     if(stmt_sequence_no >= SEQ_HEADER) {
  3043.        syntax_error( (t == (Token *) NULL? line_num: t->line_num),
  3044.             NO_COL_NUM,
  3045.             "missing END statement inserted");
  3046.        msg_tail( (t == (Token *) NULL? "at end of file":
  3047.               "prior to statement") );
  3048.  
  3049.        END_processing(t);
  3050.     }
  3051.     stmt_sequence_no = SEQ_HEADER;
  3052. }
  3053.  
  3054. PRIVATE void
  3055. #if HAVE_STDC
  3056. check_stmt_sequence(Token *t, int seq_num)
  3057. #else /* K&R style */
  3058. check_stmt_sequence(t,seq_num)
  3059.      Token *t;
  3060.      int seq_num;
  3061. #endif /* HAVE_STDC */
  3062. {
  3063.     if(stmt_sequence_no > seq_num) {
  3064.       if(f77_stmt_order) {
  3065.     nonstandard(t->line_num, NO_COL_NUM);
  3066.     msg_tail(": Statement out of order.");
  3067.       }
  3068.     }
  3069.             /* If no error, sequence number is updated to new
  3070.                value.  If error, it is rolled back to prevent
  3071.                cascades of error messages.  */
  3072.     stmt_sequence_no = seq_num;
  3073. }
  3074.  
  3075. PRIVATE void
  3076. init_io_ctrl_list(VOID)
  3077. {
  3078.   control_item_count = 0;
  3079.   io_internal_file = FALSE;
  3080.   io_list_directed = FALSE;
  3081.   io_warning_given = FALSE;
  3082. }
  3083.  
  3084.  
  3085.     /* After having parsed end_stmt, common block lists and
  3086.        subprogram argument lists are copied over into global symbol
  3087.        table, the local symbol table is printed out and then cleared,
  3088.        and stmt_sequence_no is set to zero for start of next module.
  3089.     */
  3090.  
  3091. PRIVATE void
  3092. #if HAVE_STDC
  3093. END_processing(Token *t)
  3094. #else /* K&R style */
  3095. END_processing(t)
  3096.     Token *t;
  3097. #endif /* HAVE_STDC */
  3098. {
  3099.   ++tot_module_count;
  3100.   if(current_module_hash != -1) {
  3101.         if(exec_stmt_count == 0 &&
  3102.        current_module_type != type_BLOCK_DATA) {
  3103.       if(misc_warn)
  3104.         warning(t == (Token *)NULL? line_num: t->line_num, NO_COL_NUM,
  3105.           "Module contains no executable statements");
  3106.     }
  3107.     if(do_list && t != (Token *)NULL)
  3108.         (void)flush_line_out(t->line_num);
  3109.     check_loose_ends(current_module_hash);
  3110.     process_lists(current_module_hash);
  3111.     debug_symtabs();
  3112.     print_loc_symbols(current_module_hash);
  3113.     init_symtab();
  3114.   }
  3115.   exec_stmt_count = 0;
  3116.   stmt_sequence_no = 0;
  3117.   current_module_hash = -1;
  3118.   implicit_type_given = FALSE;
  3119.   implicit_none = FALSE;
  3120.   true_prev_stmt_line_num = 0;
  3121.   integer_context = FALSE;
  3122.   global_save = FALSE;
  3123. }
  3124.  
  3125.         /* Routine to create a node for an expr tree.  Returns
  3126.            a pointer to the newly created node.
  3127.          */
  3128. PRIVATE Token *
  3129. #if HAVE_STDC
  3130. add_tree_node(Token *node, Token *left, Token *right)
  3131. #else /* K&R style */
  3132. add_tree_node(node,left,right)
  3133.      Token *node,*left,*right;
  3134. #endif /* HAVE_STDC */
  3135. {
  3136.   Token *new_node, *new_left, *new_right;
  3137.  
  3138.   new_node=new_token();
  3139.  
  3140.   *new_node = *node;        /* Make a permanent copy of root */
  3141.  
  3142.         /* Add the children.  If child's left_token pointer is
  3143.            null, then that expression is a primary.  Otherwise
  3144.            it is the root node of a subtree.
  3145.          */
  3146.   if(left->left_token == (Token *)NULL) {
  3147.     new_left=new_token();
  3148.     *new_left = *left;            /* Copy primary to permanent space */
  3149.   }
  3150.   else {
  3151.     new_left = left->left_token;    /* No copying needed in this case */
  3152.   }
  3153.  
  3154.   if(right == (Token *)NULL) {
  3155.     new_right = (Token *)NULL;        /* No right child */
  3156.   }
  3157.   else if(right->left_token == (Token *)NULL
  3158.       || node->class == '(') { /* Paren means right child is expr list */
  3159.     new_right=new_token();
  3160.     *new_right = *right;        /* Copy primary to permanent space */
  3161.   }
  3162.   else {
  3163.     new_right = right->left_token;    /* No copying needed in this case */
  3164.   }
  3165.  
  3166.   new_node->left_token = new_left;    /* Link children onto the new root */
  3167.   new_node->next_token = new_right;
  3168.   return new_node;
  3169. }
  3170.  
  3171.         /* Routine to add token t to the front of a token list. */
  3172. PRIVATE Token *
  3173. #if HAVE_STDC
  3174. append_token(Token *tlist, Token *t)
  3175. #else /* K&R style */
  3176. append_token(tlist,t)
  3177.      Token *tlist, *t;
  3178. #endif /* HAVE_STDC */
  3179. {
  3180.     Token *tcopy;
  3181.  
  3182.     tcopy=new_token();
  3183.  
  3184.     *tcopy = *t;        /* make permanent copy of token */
  3185.     tcopy->next_token = tlist; /* link it onto front of list */
  3186.     return tcopy;        /* return it as new tlist */
  3187. }
  3188.