home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / FTNCHK32.ZIP / fortran.y < prev    next >
Text File  |  1993-02-16  |  59KB  |  2,646 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.         -- Sensitive to whitespace, which is used in lexical analysis
  22.            to separate keywords and identifiers from context.  This
  23.            is a design feature.  Rules are the same as for Pascal.
  24.            (Of course stmt fields and end-of-line still honored.)
  25.            Note: a complex constant cannot be split across lines.
  26.         -- Currently, some keywords are partially reserved: may
  27.            only be used for scalar variables.  (See keywords.c)  This
  28.            is the fault of the lexical analyzer (too little lookahead).
  29.  
  30.         Extensions supported:
  31.             -- Case insensitive.
  32.          -- Hollerith constants.
  33.         -- Variable names may be longer than 6 characters.  Also
  34.            allows underscores in names.
  35.         -- DO ... ENDDO and DO WHILE loop forms allowed.
  36.         -- NAMELIST supported.
  37.         -- TYPE and ACCEPT I/O statements allowed.
  38.         -- Tabs are permitted in input, and (except in character data)
  39.            expand into blanks up to the next column equal to 1 mod 8.
  40.         -- Type declarations INTEGER*2, REAL*8, etc. are allowed.
  41.            REAL*8 becomes DOUBLE PRECISION.  For others, length spec
  42.            is ignored.
  43.         -- IMPLICIT NONE allowed.
  44.      */
  45.  
  46. /*  Author: R. Moniot
  47.  *  Date:   August 1988
  48.  *  Last revision: January 1992
  49.  */
  50.  
  51. #include <stdio.h>
  52. #include <string.h>
  53. #include "ftnchek.h"
  54. #include "symtab.h"
  55. void exit();
  56.  
  57.  
  58.  
  59. int current_datatype,    /* set when parse type_name or type_stmt */
  60.     stmt_sequence_no,   /* set when parsing, reset to 0 at end_stmt */
  61.     control_item_count;    /* count of items in control_info_list */
  62.  
  63. extern unsigned prev_stmt_line_num; /* shared with advance */
  64.  
  65. int current_module_hash = -1,    /* hashtable index of current module name */
  66.     current_module_type,
  67.     executable_stmt=FALSE,
  68.     prev_stmt_class=0,
  69.          /* flags for lexer */
  70.     complex_const_allowed=FALSE, /* for help in lookahead for these */
  71.     inside_format=FALSE,    /* when inside parens of FORMAT  */
  72.     integer_context=FALSE,    /* says integers-only are to follow */
  73.     prev_goto=FALSE,
  74.     goto_flag=FALSE;    /* if unconditional GOTO was encountered */
  75.  
  76. long exec_stmt_count=0;    /* count of executable stmts in program */
  77.  
  78. PRIVATE void
  79. print_comlist(), print_exprlist(), END_processing();
  80. PRIVATE Token *
  81.   append_token();
  82. PRIVATE int
  83.   do_bounds_type();
  84.         /* Uses of Token fields for nonterminals: */
  85. /*
  86.   1. dim_bound_lists: dimensioning info for arrays:
  87.        token.class = no. of dimensions,
  88.        token.subclass = no. of elements
  89.   2. expressions
  90.        token.value.integer = hash index (of identifier)
  91.        token.class = type_byte = storage_class << 4 + datatype
  92.        token.subclass = flags: CONST_EXPR, LVALUE_EXPR, etc.
  93.   3. common variable lists
  94.        token.subclass = flag: COMMA_FLAG used to handle extra/missing commas
  95. */
  96.  
  97. #define seq_header   1
  98. #define seq_implicit 2
  99. #define seq_specif   3
  100. #define seq_stmt_fun 4
  101. #define seq_exec     5
  102. #define seq_end      6
  103.  
  104. #define DBG(S)    if(debug_parser) fprintf(list_fd,"\nproduction: S");
  105. #define DBGstr(S,str) \
  106.     if(debug_parser) fprintf(list_fd,"\nproduction: S%s",str);
  107.  
  108. %}
  109.  
  110. %token tok_identifier
  111. %token tok_array_identifier
  112. %token tok_label
  113. %token tok_integer_const
  114. %token tok_real_const
  115. %token tok_dp_const
  116. %token tok_complex_const
  117. %token tok_logical_const
  118. %token tok_string
  119. %token tok_hollerith
  120. %token tok_edit_descriptor
  121. %token tok_letter
  122. %token tok_relop    /* .EQ. .NE. .LT. .LE. .GT. .GE. */
  123. %token tok_AND
  124. %token tok_OR
  125. %token tok_EQV
  126. %token tok_NEQV
  127. %token tok_NOT
  128. %token tok_power    /*   **   */
  129. %token tok_concat    /*   //   */
  130. %token tok_ASSIGN
  131. %token tok_ACCEPT
  132. %token tok_BACKSPACE
  133. %token tok_BLOCK
  134. %token tok_BLOCKDATA
  135. %token tok_CALL
  136. %token tok_CHARACTER
  137. %token tok_CLOSE
  138. %token tok_COMMON
  139. %token tok_COMPLEX
  140. %token tok_CONTINUE
  141. %token tok_BYTE
  142. %token tok_DATA
  143. %token tok_DIMENSION
  144. %token tok_DO
  145. %token tok_DOUBLE
  146. %token tok_DOUBLEPRECISION
  147. %token tok_DOWHILE
  148. %token tok_ELSE
  149. %token tok_ELSEIF
  150. %token tok_END
  151. %token tok_ENDDO
  152. %token tok_ENDFILE
  153. %token tok_ENDIF
  154. %token tok_ENTRY
  155. %token tok_EQUIVALENCE
  156. %token tok_EXTERNAL
  157. %token tok_FILE
  158. %token tok_FORMAT
  159. %token tok_FUNCTION
  160. %token tok_GO
  161. %token tok_GOTO
  162. %token tok_IF
  163. %token tok_IMPLICIT
  164. %token tok_INCLUDE
  165. %token tok_INQUIRE
  166. %token tok_INTEGER
  167. %token tok_INTRINSIC
  168. %token tok_LOGICAL
  169. %token tok_NAMELIST
  170. %token tok_OPEN
  171. %token tok_PARAMETER
  172. %token tok_PAUSE
  173. %token tok_PRECISION
  174. %token tok_PRINT
  175. %token tok_PROGRAM
  176. %token tok_READ
  177. %token tok_REAL
  178. %token tok_RETURN
  179. %token tok_REWIND
  180. %token tok_SAVE
  181. %token tok_STOP
  182. %token tok_SUBROUTINE
  183. %token tok_TO
  184. %token tok_TYPE
  185. %token tok_THEN
  186. %token tok_WHILE
  187. %token tok_WRITE
  188.  
  189. %token tok_illegal  /* Illegal token unused in grammar: induces syntax error */
  190.  
  191. %token EOS    127    /* Character for end of statement.  */
  192.  
  193. %nonassoc tok_relop
  194.  
  195. %left REDUCE ')'    /* Used at unit_io to force a reduction */
  196.  
  197.  
  198. %%
  199.     /*  The following grammar is based on the ANSI manual, diagrams
  200.      *  of section F.  Numbers in the comments refer to the diagram
  201.      *  corresponding to the grammar rule.
  202.      */
  203.  
  204.  
  205. /* 1-5 */
  206.  
  207. prog_body    :    stmt_list
  208.         |    /* empty file */
  209.         ;
  210.  
  211. stmt_list    :    stmt_list_item
  212.         |    stmt_list stmt_list_item
  213.         ;
  214.  
  215. stmt_list_item    :    stmt
  216.             {
  217.                 /* Create id token for prog if unnamed. */
  218.               if(current_module_hash == -1) {
  219.                 implied_id_token(&($1),unnamed_prog);
  220.                 def_function(
  221.                 type_PROGRAM,&($1),(Token*)NULL);
  222.                 current_module_hash =
  223.                   def_curr_module(&($1));
  224.                 current_module_type = type_PROGRAM;
  225.               }
  226.               prev_stmt_class = curr_stmt_class;
  227.               integer_context = FALSE;
  228.             }
  229.         |    end_stmt
  230.             {
  231.               if(current_module_hash == -1) {
  232.                 implied_id_token(&($1),unnamed_prog);
  233.                 def_function(
  234.                 type_PROGRAM,&($1),(Token*)NULL);
  235.                 current_module_hash =
  236.                   def_curr_module(&($1));
  237.                 current_module_type = type_PROGRAM;
  238.               }
  239.               if(prev_stmt_class != tok_RETURN)
  240.                 do_RETURN(current_module_hash,&($1));
  241.               END_processing(&($$));
  242.               goto_flag = prev_goto = FALSE;
  243.               prev_stmt_class = curr_stmt_class;
  244.             }
  245.          |    include_stmt
  246.         |    EOS    /* "sticky" EOF for needed delay */
  247.         ;
  248.  
  249.             /* Statements: note that ordering by category
  250.                of statement is not enforced in the grammar
  251.                but is deferred to semantic processing.
  252.              */
  253.  
  254. stmt        :    tok_label unlabeled_stmt
  255.             {
  256. #ifdef CHECK_LABELS
  257.               def_label(&($1));
  258. #endif
  259.               if(executable_stmt)
  260.                 prev_goto = goto_flag;
  261.             }
  262.         |    unlabeled_stmt
  263.             {
  264.               if(executable_stmt) {
  265.                 if(prev_goto)
  266.                 syntax_error($1.line_num, NO_COL_NUM,
  267.                     "No path to this statement");
  268.                 prev_goto = goto_flag;
  269.               }
  270.             }
  271.         ;
  272.  
  273. unlabeled_stmt    :    subprogram_header
  274.             {
  275.                 exec_stmt_count = 0;
  276.                 executable_stmt = FALSE;
  277.             }
  278.         |    specification_stmt
  279.             {
  280.                 executable_stmt = FALSE;
  281.             }
  282.         |    executable_stmt
  283.             {    /* handle statement functions correctly */
  284.               if(is_true(STMT_FUNCTION_EXPR, $1.subclass)
  285.                      && stmt_sequence_no <= seq_stmt_fun) {
  286.                 stmt_sequence_no = seq_stmt_fun;
  287.                 executable_stmt = FALSE;
  288.               }
  289.               else {
  290.                 stmt_sequence_no = seq_exec;
  291.                 ++exec_stmt_count;
  292.                 executable_stmt = TRUE;
  293.               }
  294.             }
  295.         |    restricted_stmt
  296.             {
  297.                 stmt_sequence_no = seq_exec;
  298.                 ++exec_stmt_count;
  299.                 executable_stmt = TRUE;
  300.             }
  301.         |    error EOS
  302.             {
  303.                 executable_stmt = TRUE;
  304.                 if(stmt_sequence_no == 0)
  305.                   stmt_sequence_no = seq_header;
  306.                 complex_const_allowed = FALSE; /* turn off flags */
  307.                 inside_format=FALSE;
  308.                 integer_context = FALSE;
  309.                 $$.line_num = prev_stmt_line_num; /* best guess */
  310.                 yyerrok; /* (error message already given) */
  311.             }
  312.         ;
  313.  
  314. subprogram_header:    prog_stmt
  315.             {
  316.                 current_module_type = type_PROGRAM;
  317.             }
  318.         |    function_stmt
  319.             {
  320.                 current_module_type = type_SUBROUTINE;
  321.             }
  322.         |    subroutine_stmt
  323.             {
  324.                 current_module_type = type_SUBROUTINE;
  325.             }
  326.         |    block_data_stmt
  327.             {
  328.                 current_module_type = type_BLOCK_DATA;
  329.             }
  330.         ;
  331.  
  332. end_stmt    :    unlabeled_end_stmt
  333.         |    tok_label unlabeled_end_stmt
  334.         ;
  335.  
  336. unlabeled_end_stmt:    tok_END EOS
  337.         ;
  338.  
  339. include_stmt    :    tok_INCLUDE tok_string EOS
  340.              {
  341. #ifdef ALLOW_INCLUDE
  342.               if(f77_standard) {
  343.                   nonstandard($1.line_num,$1.col_num);
  344.               }
  345.                open_include_file($2.value.string);
  346. #else
  347.               syntax_error($1.line_num,$1.col_num,
  348.                 "statement not permitted");
  349. #endif
  350.              }
  351.          ;
  352.  
  353. /* 5,6 */
  354.         /* Note that stmt_function_stmt is not distinguished from
  355.            assignment_stmt, but assign (label to variable) is.
  356.            Also, format_stmt w/o label is accepted here.
  357.            ANSI standard for statement sequencing is enforced here. */
  358. specification_stmt:
  359.             entry_stmt
  360.             {
  361.                  if(stmt_sequence_no < seq_implicit) {
  362.                    stmt_sequence_no = seq_implicit;
  363.                  }
  364.                  goto_flag = prev_goto = FALSE;
  365.             }
  366.         |    format_stmt
  367.             {
  368.                  if(stmt_sequence_no < seq_implicit) {
  369.                 stmt_sequence_no = seq_implicit;
  370.                  }
  371.             }
  372.         |    parameter_stmt
  373.             {
  374.                  if(stmt_sequence_no > seq_specif) {
  375.                    syntax_error($1.line_num, NO_COL_NUM,
  376.                     "Statement out of order.");
  377.                  }
  378.                  else {
  379.                 if(stmt_sequence_no < seq_implicit) {
  380.                    stmt_sequence_no = seq_implicit;
  381.                 }
  382.                  }
  383.             }
  384.         |    implicit_stmt
  385.             {
  386.                  if(stmt_sequence_no > seq_implicit) {
  387.                  syntax_error($1.line_num, NO_COL_NUM,
  388.                     "Statement out of order.");
  389.                  }
  390.                  else {
  391.                     stmt_sequence_no = seq_implicit;
  392.                  }
  393.             }
  394.         |    data_stmt
  395.             {
  396.                  if(stmt_sequence_no < seq_stmt_fun) {
  397.                 stmt_sequence_no = seq_stmt_fun;
  398.                   }
  399.             }
  400.         |    dimension_stmt
  401.             {
  402.                 if(stmt_sequence_no > seq_specif) {
  403.                 syntax_error($1.line_num, NO_COL_NUM,
  404.                     "Statement out of order.");
  405.                 }
  406.                 else {
  407.                 stmt_sequence_no = seq_specif;
  408.                 }
  409.             }
  410.         |    equivalence_stmt
  411.             {
  412.                 if(stmt_sequence_no > seq_specif) {
  413.                 syntax_error($1.line_num, NO_COL_NUM,
  414.                     "Statement out of order.");
  415.                 }
  416.                 else {
  417.                 stmt_sequence_no = seq_specif;
  418.                 }
  419.             }
  420.         |    common_stmt
  421.             {
  422.                 if(stmt_sequence_no > seq_specif) {
  423.                 syntax_error($1.line_num, NO_COL_NUM,
  424.                     "Statement out of order.");
  425.                 }
  426.                 else {
  427.                 stmt_sequence_no = seq_specif;
  428.                 }
  429.             }
  430.         |    namelist_stmt
  431.             {
  432.                 if(stmt_sequence_no > seq_specif) {
  433.                 syntax_error($1.line_num, NO_COL_NUM,
  434.                     "Statement out of order.");
  435.                 }
  436.                 else {
  437.                 stmt_sequence_no = seq_specif;
  438.                 }
  439.             }
  440.         |    type_stmt
  441.             {
  442.                 if(stmt_sequence_no > seq_specif) {
  443.                 syntax_error($1.line_num, NO_COL_NUM,
  444.                     "Statement out of order.");
  445.                 }
  446.                 else {
  447.                 stmt_sequence_no = seq_specif;
  448.                 }
  449.             }
  450.         |    external_stmt
  451.             {
  452.                 if(stmt_sequence_no > seq_specif) {
  453.                 syntax_error($1.line_num, NO_COL_NUM,
  454.                     "Statement out of order.");
  455.                 }
  456.                 else {
  457.                 stmt_sequence_no = seq_specif;
  458.                 }
  459.             }
  460.         |    intrinsic_stmt
  461.             {
  462.                 if(stmt_sequence_no > seq_specif) {
  463.                 syntax_error($1.line_num, NO_COL_NUM,
  464.                     "Statement out of order.");
  465.                 }
  466.                 else {
  467.                 stmt_sequence_no = seq_specif;
  468.                 }
  469.             }
  470.         |    save_stmt
  471.             {
  472.                 if(stmt_sequence_no > seq_specif) {
  473.                 syntax_error($1.line_num, NO_COL_NUM,
  474.                     "Statement out of order.");
  475.                 }
  476.                 else {
  477.                 stmt_sequence_no = seq_specif;
  478.                 }
  479.             }
  480.         ;
  481.  
  482.  
  483. /* 7 */
  484. executable_stmt:        /* Allowed in logical IF */
  485.             assignment_stmt
  486.             {
  487.                 goto_flag=FALSE;
  488.             }
  489.         |    assign_stmt
  490.             {
  491.                 goto_flag=FALSE;
  492.             }
  493.         |    unconditional_goto
  494.             {
  495.                 goto_flag=TRUE;
  496.             }
  497.         |    computed_goto
  498.             {
  499.                 goto_flag=FALSE;    /* fallthru allowed */
  500.             }
  501.         |    assigned_goto
  502.             {
  503.                 goto_flag=TRUE;
  504.             }
  505.         |    arithmetic_if_stmt
  506.             {
  507.                 goto_flag=TRUE;
  508.             }
  509.         |    continue_stmt
  510.             {
  511.                 goto_flag=FALSE;
  512.             }
  513.         |    stop_stmt
  514.             {
  515.                 goto_flag=TRUE;
  516.             }
  517.         |    pause_stmt
  518.             {
  519.                 goto_flag=FALSE;
  520.             }
  521.         |    read_stmt
  522.             {
  523.                 goto_flag=FALSE;
  524.             }
  525.         |    accept_stmt
  526.             {
  527.                 goto_flag=FALSE;
  528.             }
  529.         |    write_stmt
  530.             {
  531.                 goto_flag=FALSE;
  532.             }
  533.         |    print_stmt
  534.             {
  535.                 goto_flag=FALSE;
  536.             }
  537.         |       type_output_stmt
  538.             {
  539.                 goto_flag=FALSE;
  540.             }
  541.         |    rewind_stmt
  542.             {
  543.                 goto_flag=FALSE;
  544.             }
  545.         |    backspace_stmt
  546.             {
  547.                 goto_flag=FALSE;
  548.             }
  549.         |    endfile_stmt
  550.             {
  551.                 goto_flag=FALSE;
  552.             }
  553.         |    open_stmt
  554.             {
  555.                 goto_flag=FALSE;
  556.             }
  557.         |    close_stmt
  558.             {
  559.                 goto_flag=FALSE;
  560.             }
  561.         |    inquire_stmt
  562.             {
  563.                 goto_flag=FALSE;
  564.             }
  565.         |    call_stmt
  566.             {
  567.                 goto_flag=FALSE;
  568.             }
  569.         |    return_stmt
  570.             {
  571.                 goto_flag=TRUE;
  572.             }
  573.         ;
  574.  
  575. restricted_stmt:        /* Disallowed in logical IF */
  576.             logical_if_stmt
  577.             {
  578.                 goto_flag=FALSE;
  579.             }
  580.         |    block_if_stmt
  581.             {
  582.                 goto_flag=FALSE;
  583.             }
  584.         |    else_if_stmt
  585.             {
  586.                 prev_goto = goto_flag =FALSE;
  587.             }
  588.         |    else_stmt
  589.             {
  590.                 prev_goto = goto_flag =FALSE;
  591.             }
  592.         |    end_if_stmt
  593.             {
  594.                 prev_goto = goto_flag =FALSE;
  595.             }
  596.         |    do_stmt
  597.             {
  598.                 goto_flag=FALSE;
  599.             }
  600.         |    enddo_stmt
  601.             {
  602.                 goto_flag=FALSE;
  603.             }
  604.         ;
  605.  
  606. /* 8 */
  607. prog_stmt    :    tok_PROGRAM {check_seq_header(&($1));}
  608.                  symbolic_name EOS
  609.             {
  610.                  def_function(
  611.                 type_PROGRAM,&($3),(Token*)NULL);
  612.                  current_module_hash =
  613.                    def_curr_module(&($3));
  614.             }
  615.         ;
  616.  
  617.             /* Note that function & subroutine entry not
  618.              * distinguished in this grammar.
  619.              */
  620. /* 9 */
  621. entry_stmt    :    tok_ENTRY symbolic_name EOS
  622.             {
  623.               do_ENTRY(&($2),(Token*)NULL
  624.                    ,current_module_hash);
  625.             }
  626.         |    tok_ENTRY symbolic_name '(' dummy_argument_list ')' EOS
  627.             {
  628.               do_ENTRY(&($2),&($4)
  629.                    ,current_module_hash);
  630.                  if(debug_parser)
  631.                 print_exprlist("entry stmt",&($4));
  632.             }
  633.         ;
  634.  
  635. /* 10 */
  636. function_stmt    :    unlabeled_function_stmt
  637.         ;
  638.  
  639. unlabeled_function_stmt
  640.         :    typed_function_handle symbolic_name EOS
  641.             {
  642.                  if(f77_standard) {
  643.                 nonstandard($2.line_num,
  644.                   $2.col_num+strlen(token_name($2)));
  645.                 msg_tail(": parentheses required");
  646.                  }
  647.              def_function(
  648.                 current_datatype,&($2),(Token*)NULL);
  649.              current_module_hash=
  650.                def_curr_module(&($2));
  651.             }
  652.         |    typed_function_handle symbolic_name
  653.                 '(' dummy_argument_list ')' EOS
  654.             {
  655.              def_function(
  656.                 current_datatype,&($2),&($4));
  657.              current_module_hash=
  658.                def_curr_module(&($2));
  659.              if(debug_parser)
  660.                print_exprlist("function stmt",&($4));
  661.             }
  662.         |    plain_function_handle symbolic_name EOS
  663.             {
  664.                  if(f77_standard) {
  665.                 nonstandard($2.line_num,
  666.                   $2.col_num+strlen(token_name($2)));
  667.                 msg_tail(": parentheses required");
  668.                  }
  669.              def_function(
  670.                 type_UNDECL,&($2),(Token*)NULL);
  671.              current_module_hash=
  672.                def_curr_module(&($2));
  673.             }
  674.         |    plain_function_handle symbolic_name
  675.                 '(' dummy_argument_list ')' EOS
  676.             {
  677.              def_function(
  678.                 type_UNDECL,&($2),&($4));
  679.              current_module_hash=
  680.                def_curr_module(&($2));
  681.              if(debug_parser)
  682.                print_exprlist("function stmt",&($4));
  683.             }
  684.         ;
  685.  
  686. typed_function_handle
  687.         :    type_name tok_FUNCTION
  688.             {
  689.               check_seq_header(&($2));
  690.             }
  691.         ;
  692.  
  693. plain_function_handle
  694.         :    tok_FUNCTION
  695.             {
  696.               check_seq_header(&($1));
  697.             }
  698.         ;
  699.  
  700. type_name    :    arith_type_name
  701.         |    plain_char_type_name
  702.         |    char_type_name
  703.         ;
  704.  
  705.  
  706. /* 11 not present: see 9 */
  707.  
  708. /* 12 */
  709. subroutine_stmt    :    unlabeled_subroutine_stmt
  710.         ;
  711.  
  712. unlabeled_subroutine_stmt
  713.         :    subroutine_handle symbolic_name EOS
  714.             {
  715.               def_function(
  716.                  type_SUBROUTINE,&($2),(Token*)NULL);
  717.               current_module_hash=
  718.                 def_curr_module(&($2));
  719.             }
  720.         |    subroutine_handle symbolic_name
  721.                 '(' dummy_argument_list ')' EOS
  722.             {
  723.               def_function(
  724.                  type_SUBROUTINE,&($2),&($4));
  725.               current_module_hash=
  726.                 def_curr_module(&($2));
  727.               if(debug_parser)
  728.                 print_exprlist("subroutine stmt",&($4));
  729.             }
  730.         ;
  731.  
  732. subroutine_handle:    tok_SUBROUTINE
  733.             {
  734.               check_seq_header(&($1));
  735.             }
  736.         ;
  737.  
  738. dummy_argument_list:    /* empty */
  739.             {
  740.                 $$.next_token = (Token*)NULL;
  741.             }
  742.         |    non_empty_arg_list
  743.         ;
  744.  
  745. non_empty_arg_list:    dummy_argument
  746.             {
  747.                 $$.next_token = append_token((Token*)NULL,&($1));
  748.             }
  749.         |    non_empty_arg_list ',' dummy_argument
  750.             {
  751.                 $$.next_token = append_token($1.next_token,&($3));
  752.             }
  753.         ;
  754.  
  755. dummy_argument    :    symbolic_name
  756.             {
  757.                  def_arg_name(&($1));
  758.                  primary_id_expr(&($1),&($$));
  759.             }
  760.         |    '*'
  761.             {
  762.                  $$.class = type_byte(class_LABEL,type_LABEL);
  763.                  $$.subclass = 0;
  764.             }
  765.         ;
  766.  
  767. /* 13 not present: see 9 */
  768.  
  769. /* 14 */
  770. block_data_stmt    :    block_data_handle EOS
  771.             {
  772.                   /* form name %DATnn */
  773.               ++block_data_number;
  774.               sprintf(unnamed_block_data+4,"%02d"
  775.                   ,block_data_number%100);
  776.               implied_id_token(&($$),unnamed_block_data);
  777.  
  778.               def_function(
  779.                  type_BLOCK_DATA,&($$),(Token*)NULL);
  780.               current_module_hash=
  781.                 def_curr_module(&($$));
  782.             }
  783.         |    block_data_handle symbolic_name EOS
  784.             {
  785.               def_function(
  786.                  type_BLOCK_DATA,&($2),(Token*)NULL);
  787.               current_module_hash=
  788.                 def_curr_module(&($2));
  789.             }
  790.         ;
  791.  
  792. block_data_handle:    tok_BLOCK tok_DATA
  793.             {
  794.               check_seq_header(&($2));
  795.             }
  796.         |    tok_BLOCKDATA
  797.             {
  798.               check_seq_header(&($1));
  799.             }
  800.  
  801.         ;
  802. /* 15 */
  803. dimension_stmt    :    tok_DIMENSION array_declarator_list EOS
  804.         ;
  805.  
  806. array_declarator_list:    array_declarator
  807.         |    array_declarator_list ',' array_declarator
  808.         ;
  809.  
  810. /* 16 */
  811. array_declarator:    symbolic_name '(' dim_bound_list ')'
  812.             {
  813.                  def_array_dim(&($1),&($3));
  814.             }
  815.         ;
  816.  
  817. dim_bound_list    :    dim_bound_item      /* token class = no. of dimensions,
  818.                            subclass = no. of elements */
  819.             {
  820.                  $$.class = 1;
  821.                  $$.subclass = $1.subclass;
  822.             }
  823.         |    dim_bound_list ',' dim_bound_item
  824.             {
  825.                  $$.class = $1.class + 1; /* one more dimension */
  826.                  $$.subclass = $1.subclass * $3.subclass;
  827.             }
  828.         ;
  829.  
  830. dim_bound_item    :    dim_bound_expr
  831.             {
  832.                   $$.subclass = $1.value.integer;
  833.             }
  834.         |    dim_bound_expr ':' dim_bound_expr
  835.             {    /* avoid getting 0 - 0 + 1 = 1 if bounds nonconstant */
  836.                   if( datatype_of($1.class) == type_INTEGER
  837.                  && is_true(CONST_EXPR,$1.subclass)
  838.                  && datatype_of($3.class) == type_INTEGER
  839.                  && is_true(CONST_EXPR,$3.subclass) )
  840.                 $$.subclass = $3.value.integer - $1.value.integer + 1;
  841.                   else
  842.                 $$.subclass = 0;
  843.             }
  844.         |    '*'
  845.             {
  846.                  $$.subclass = 0;
  847.             }
  848.         |    dim_bound_expr ':' '*'
  849.             {
  850.                  $$.subclass = 0;
  851.             }
  852.         ;
  853.  
  854. /* 17 */
  855. equivalence_stmt:    tok_EQUIVALENCE {equivalence_flag = TRUE;}
  856.             equivalence_list EOS {equivalence_flag = FALSE;}
  857.         ;
  858.  
  859. equivalence_list:    '(' equivalence_list_item ')'
  860.         |    equivalence_list ',' '(' equivalence_list_item ')'
  861.         ;
  862.  
  863. equivalence_list_item:    equiv_entity ',' equiv_entity
  864.             {
  865.               equivalence(&($1), &($3));
  866.             }
  867.         |    equivalence_list_item ',' equiv_entity
  868.             {
  869.               equivalence(&($1), &($3));
  870.             }
  871.         ;
  872.  
  873. /* 17 */
  874. equiv_entity    :    symbolic_name
  875.             {
  876.                  def_equiv_name(&($1));
  877.             }
  878.         |    array_equiv_name
  879.             {
  880.                  def_equiv_name(&($1));
  881.             }
  882.         |    substring_equiv_name
  883.             {
  884.                  def_equiv_name(&($1));
  885.             }
  886.         ;
  887.  
  888. array_equiv_name:    symbolic_name '(' subscript_list ')'
  889.                 /* should check */
  890.         ;
  891.  
  892. substring_equiv_name:    symbolic_name substring_interval
  893.         |    array_equiv_name substring_interval
  894.         ;
  895.  
  896. /* 19 */
  897. common_stmt    :    tok_COMMON common_variable_list EOS
  898.             {
  899.                  implied_id_token(&($$),blank_com_name);
  900.                  def_com_block(&($$), &($2));
  901.                  if(is_true(COMMA_FLAG,$2.subclass))
  902.                    syntax_error(
  903.                          $2.line_num,$2.col_num,
  904.                          "trailing comma");
  905.                  if(debug_parser)
  906.                 print_comlist("blank common",&($2));
  907.  
  908.             }
  909.         |    tok_COMMON common_block_list EOS
  910.             {
  911.                  if(is_true(COMMA_FLAG,$2.subclass))
  912.                 syntax_error(
  913.                          $2.line_num,$2.col_num,
  914.                          "trailing comma");
  915.  
  916.             }
  917.         |    tok_COMMON common_variable_list common_block_list EOS
  918.             {
  919.                  implied_id_token(&($$),blank_com_name);
  920.                  def_com_block(&($$),&($2));
  921.                  if(is_true(COMMA_FLAG,$3.subclass))
  922.                 syntax_error(
  923.                          $3.line_num,$3.col_num,
  924.                          "trailing comma");
  925.                  if(debug_parser)
  926.                 print_comlist("blank common",&($2));
  927.  
  928.             }
  929.         ;
  930.  
  931.     /*  The following defns allow trailing commas and missing commas in
  932.         order to tolerate the optional comma before /blockname/.  The
  933.         token subclass holds comma status to allow errors to be caught. */
  934. common_block_list:    labeled_common_block
  935.             {
  936.                  $$.subclass = $1.subclass;
  937.             }
  938.         |    common_block_list labeled_common_block
  939.             {
  940.                  $$.subclass = $2.subclass;
  941.                  $$.line_num = $2.line_num;
  942.                  $$.col_num = $2.col_num;
  943.             }
  944.         ;
  945.  
  946. labeled_common_block:    common_block_name common_variable_list
  947.             {
  948.                  def_com_block(&($1),&($2));
  949.                  $$.subclass = $2.subclass;
  950.                  $$.line_num = $2.line_num;
  951.                  $$.col_num = $2.col_num;
  952.                  if(debug_parser)
  953.                 print_comlist("labeled common",&($2));
  954.             }
  955.         ;
  956.  
  957. common_block_name:    '/' symbolic_name '/'
  958.             {
  959.                  $$ = $2;
  960.             }
  961.  
  962.         |    '/'  '/'        /* block with no name */
  963.             {
  964.                  implied_id_token(&($$),blank_com_name);
  965.             }
  966.         |    tok_concat        /* "//" becomes this */
  967.             {
  968.                  implied_id_token(&($$),blank_com_name);
  969.             }
  970.         ;
  971.  
  972. common_variable_list:    common_list_item
  973.             {
  974.                 $$.subclass = $1.subclass;
  975.                 $$.next_token = append_token((Token*)NULL,&($1));
  976.             }
  977.         |    common_variable_list common_list_item
  978.             {
  979.                 if(!is_true(COMMA_FLAG,$1.subclass))
  980.                 syntax_error(
  981.                     $2.line_num,$2.col_num-1,
  982.                     "missing comma");
  983.                 $$.subclass = $2.subclass;
  984.                 $$.line_num = $2.line_num;
  985.                 $$.col_num = $2.col_num;
  986.                 $$.next_token = append_token($1.next_token,&($2));
  987.             }
  988.         ;
  989.  
  990. common_list_item:    common_entity
  991.             {               /* no comma */
  992.                  $$.subclass = $1.subclass;
  993.                  make_false(COMMA_FLAG,$$.subclass);
  994.             }
  995.         |    common_entity ','
  996.             {               /* has comma */
  997.                  $$.subclass = $1.subclass;
  998.                  make_true(COMMA_FLAG,$$.subclass);
  999.                }
  1000.         ;
  1001.  
  1002. common_entity    :    symbolic_name
  1003.             {
  1004.                  def_com_variable(&($1));
  1005.                  primary_id_expr(&($1),&($$));
  1006.             }
  1007.         |    array_declarator
  1008.             {
  1009.                  def_com_variable(&($1));
  1010.                  primary_id_expr(&($1),&($$));
  1011.             }
  1012.         ;
  1013.  
  1014.  
  1015. /* NAMELIST : Not Standard
  1016.    Syntax is:
  1017.     NAMELIST /group/ var [,var...] [[,] /group/ var [,var...]...]
  1018. */
  1019.  
  1020. namelist_stmt    :    tok_NAMELIST namelist_list EOS
  1021.             {
  1022.                 if(is_true(COMMA_FLAG,$2.subclass))
  1023.                 syntax_error(
  1024.                  $2.line_num,$2.col_num+strlen(token_name($2)),
  1025.                     "trailing comma");
  1026.                 if(f77_standard) {
  1027.                 nonstandard($1.line_num,$1.col_num);
  1028.                 }
  1029.             }
  1030.         ;
  1031.  
  1032. namelist_list    :    namelist_decl
  1033.         |    namelist_list namelist_decl
  1034.             {
  1035.                 $$ = $2;
  1036.             }
  1037.         ;
  1038.  
  1039. namelist_decl    :    namelist_name namelist_var_list
  1040.             {
  1041.                  def_namelist(&($1),&($2));
  1042.                  $$ = $2;
  1043.             }
  1044.         ;
  1045.  
  1046. namelist_name    :    '/' symbolic_name '/'
  1047.             {
  1048.                 $$ = $2;
  1049.             }
  1050.         ;
  1051.  
  1052. namelist_var_list:    namelist_item
  1053.             {
  1054.                  $$.next_token = append_token((Token*)NULL,&($1));
  1055.             }
  1056.         |    namelist_var_list namelist_item
  1057.             {
  1058.                 if(!is_true(COMMA_FLAG,$1.subclass))
  1059.                 syntax_error(
  1060.                     $2.line_num,$2.col_num-1,
  1061.                     "missing comma");
  1062.                 $$.subclass = $2.subclass;
  1063.                 $$.line_num = $2.line_num;
  1064.                 $$.col_num = $2.col_num;
  1065.                 $$.next_token = append_token($1.next_token,&($2));
  1066.             }
  1067.         ;
  1068.  
  1069. namelist_item    :    symbolic_name
  1070.             {               /* no comma */
  1071.                  def_namelist_item(&($1));
  1072.                  primary_id_expr(&($1),&($$));
  1073.                  make_false(COMMA_FLAG,$$.subclass);
  1074.             }
  1075.         |    symbolic_name ','
  1076.             {               /* has comma */
  1077.                  def_namelist_item(&($1));
  1078.                  primary_id_expr(&($1),&($$));
  1079.                  make_true(COMMA_FLAG,$$.subclass);
  1080.             }
  1081.         ;
  1082.  
  1083. /* 20 */
  1084. type_stmt    :    arith_type_name arith_type_decl_list EOS
  1085.         |    plain_char_type_name char_type_decl_list EOS
  1086.         |    char_type_name char_type_decl_list EOS
  1087.         |    char_type_name ',' char_type_decl_list EOS
  1088.         ;
  1089.  
  1090. arith_type_name    :    sizeable_type_name
  1091.  
  1092.                 /* Allow *len to modify some arith types */
  1093.         |    sizeable_type_name '*' nonzero_unsigned_int_const
  1094.             {
  1095.                 /* Only REAL*8 is actually recognized */
  1096.                 if(current_datatype == type_REAL
  1097.                    && $3.value.integer == 8)
  1098.                 current_datatype = type_DP;
  1099.  
  1100.                  if(f77_standard) {
  1101.                 nonstandard($3.line_num,$3.col_num);
  1102.                  }
  1103.             }
  1104.                 /* Other type disallow *len modifier */
  1105.         |    unsizeable_type_name
  1106.         ;
  1107.  
  1108. sizeable_type_name:    tok_INTEGER
  1109.             {
  1110.                  current_datatype = type_INTEGER;
  1111.                  integer_context = TRUE;
  1112.             }
  1113.         |    tok_REAL
  1114.             {
  1115.                  current_datatype = type_REAL;
  1116.                  integer_context = TRUE;
  1117.             }
  1118.         |    tok_COMPLEX
  1119.             {
  1120.                  current_datatype = type_COMPLEX;
  1121.                  integer_context = TRUE;
  1122.             }
  1123.         |    tok_LOGICAL
  1124.             {
  1125.                  current_datatype = type_LOGICAL;
  1126.                  integer_context = TRUE;
  1127.             }
  1128.         ;
  1129.  
  1130. unsizeable_type_name:    tok_DOUBLE tok_PRECISION
  1131.             {
  1132.                  current_datatype = type_DP;
  1133.             }
  1134.         |    tok_DOUBLEPRECISION
  1135.             {
  1136.                  current_datatype = type_DP;
  1137.             }
  1138.         |    tok_BYTE /* treate BYTE as a form of integer for now */
  1139.             {
  1140.                  current_datatype = type_INTEGER;
  1141.                  if(f77_standard)
  1142.                    nonstandard($1.line_num,$1.col_num);
  1143.             }
  1144.         ;
  1145.  
  1146. plain_char_type_name:    tok_CHARACTER
  1147.             {
  1148.                  current_datatype = type_STRING;
  1149.                  integer_context = TRUE;
  1150.             }
  1151.         ;
  1152.  
  1153. char_type_name    :    plain_char_type_name '*' len_specification
  1154.             {
  1155.                  current_datatype = type_STRING;
  1156.             }
  1157.         ;
  1158.  
  1159. arith_type_decl_list:    arith_type_decl_item
  1160.         |    arith_type_decl_list ',' arith_type_decl_item
  1161.         ;
  1162.  
  1163. arith_type_decl_item:    symbolic_name
  1164.             {
  1165.                  declare_type(&($1),current_datatype);
  1166.             }
  1167.         |    array_declarator
  1168.             {
  1169.                  declare_type(&($1),current_datatype);
  1170.             }
  1171.         ;
  1172.  
  1173. char_type_decl_list:    char_type_decl_item
  1174.         |    char_type_decl_list ',' char_type_decl_item
  1175.         ;
  1176.  
  1177. char_type_decl_item:    symbolic_name
  1178.             {
  1179.                  declare_type(&($1),current_datatype);
  1180.             }
  1181.         |    symbolic_name '*' len_specification
  1182.             {
  1183.                  declare_type(&($1),current_datatype);
  1184.             }
  1185.         |    array_declarator
  1186.             {
  1187.                  declare_type(&($1),current_datatype);
  1188.             }
  1189.         |    array_declarator '*' len_specification
  1190.             {
  1191.                  declare_type(&($1),current_datatype);
  1192.             }
  1193.            ;
  1194.  
  1195. /* 21 */
  1196.                 /* implicit_flag helps is_keyword's work */
  1197. implicit_handle    :    tok_IMPLICIT {implicit_flag=TRUE;}
  1198.         ;
  1199.  
  1200. implicit_stmt    :    implicit_handle implicit_decl_list EOS
  1201.             {
  1202.                 {implicit_flag=FALSE;}
  1203.                 if(implicit_none) {
  1204.                 syntax_error($1.line_num,$1.col_num,
  1205.                      "conflicts with IMPLICIT NONE");
  1206.                 }
  1207.                 else {
  1208.                 implicit_type_given = TRUE;
  1209.                 }
  1210.             }
  1211.         |    implicit_handle tok_identifier EOS
  1212.             {
  1213.                 int h=$2.value.integer;
  1214.                 {implicit_flag=FALSE;}
  1215.                 if( strcmp(hashtab[h].name,"NONE") == 0 ) {
  1216.                 if(implicit_type_given) {
  1217.                     syntax_error($1.line_num,$1.col_num,
  1218.                      "conflicts with IMPLICIT statement");
  1219.                 }
  1220.                 else {
  1221.                     if(f77_standard)
  1222.                       nonstandard($2.line_num,$2.col_num);
  1223.                     implicit_none = TRUE;
  1224.                 }
  1225.                 }
  1226.                 else {
  1227.                 syntax_error($2.line_num,$2.col_num,
  1228.                      "unknown keyword -- ignored");
  1229.                 }
  1230.             }
  1231.         ;
  1232.  
  1233. implicit_decl_list:    implicit_decl_item
  1234.         |    implicit_decl_list ',' {initial_flag = TRUE;}
  1235.                        implicit_decl_item
  1236.         ;
  1237.  
  1238.         /* implicit_letter_flag tells lexer to treat letters as letters,
  1239.                not as identifiers */
  1240. implicit_decl_item:    type_name '('  {implicit_letter_flag = TRUE;}
  1241.                 letter_list ')'  {implicit_letter_flag = FALSE;}
  1242.         ;
  1243.  
  1244. letter_list    :    letter_list_item
  1245.         |    letter_list ',' letter_list_item
  1246.         ;
  1247.  
  1248. letter_list_item:    tok_letter
  1249.             {
  1250.                  set_implicit_type(current_datatype,
  1251.                          (int)$1.subclass,(int)$1.subclass);
  1252.             }
  1253.         |    tok_letter '-' tok_letter
  1254.             {
  1255.                  set_implicit_type(current_datatype,
  1256.                     (int)$1.subclass,(int)$3.subclass);
  1257.             }
  1258.         ;
  1259.  
  1260.  
  1261. /* 22 */
  1262. len_specification:    '(' '*' ')'
  1263.         |    nonzero_unsigned_int_const
  1264.         |    '(' int_constant_expr ')'
  1265.         ;
  1266.  
  1267. /* 23 */
  1268. parameter_stmt    :    tok_PARAMETER '(' parameter_defn_list ')' EOS
  1269.            ;
  1270.  
  1271. parameter_defn_list:    parameter_defn_item
  1272.         |    parameter_defn_list ',' parameter_defn_item
  1273.         ;
  1274.  
  1275. parameter_defn_item:    symbolic_name  {complex_const_allowed = TRUE;} '='
  1276.                 parameter_expr
  1277.             {
  1278.                  def_parameter(&($1),&($4));
  1279.                  complex_const_allowed = FALSE;
  1280.             }
  1281.         ;
  1282.  
  1283. /* 24 */
  1284. external_stmt    :    tok_EXTERNAL external_name_list EOS
  1285.         ;
  1286.  
  1287. external_name_list:    symbolic_name
  1288.             {
  1289.                  def_ext_name(&($1));
  1290.             }
  1291.         |    external_name_list ',' symbolic_name
  1292.             {
  1293.                  def_ext_name(&($3));
  1294.             }
  1295.         ;
  1296.  
  1297. /* 25 */
  1298. intrinsic_stmt    :    tok_INTRINSIC intrinsic_name_list EOS
  1299.         ;
  1300.  
  1301. intrinsic_name_list:    symbolic_name
  1302.             {
  1303.                  def_intrins_name(&($1));
  1304.             }
  1305.         |    intrinsic_name_list ',' symbolic_name
  1306.             {
  1307.                  def_intrins_name(&($3));
  1308.             }
  1309.         ;
  1310.  
  1311. /* 26 */
  1312. save_stmt    :    tok_SAVE EOS
  1313.         |    tok_SAVE save_list EOS
  1314.         ;
  1315.  
  1316. save_list    :    save_item
  1317.         |    save_list ',' save_item
  1318.         ;
  1319.  
  1320. save_item    :    symbolic_name
  1321.             {
  1322.                  ref_variable(&($1));
  1323.             }
  1324.         |    '/' symbolic_name '/'
  1325.             {
  1326.                  def_com_block(&($2),(Token*)NULL);
  1327.             }
  1328.         ;
  1329.  
  1330. /* 27 */
  1331. data_stmt    :    tok_DATA data_defn_list EOS
  1332.            ;
  1333.  
  1334. data_defn_list    :    data_defn_item
  1335.         |    data_defn_list data_defn_item
  1336.         |    data_defn_list ',' data_defn_item
  1337.         ;
  1338.  
  1339. data_defn_item    :    data_defn_assignee_list '/'
  1340.                 {complex_const_allowed=TRUE;}
  1341.                     data_value_list
  1342.                 {complex_const_allowed=FALSE;}  '/'
  1343.         ;
  1344.  
  1345. data_defn_assignee_list
  1346.         :    data_defn_assignee
  1347.         |    data_defn_assignee_list ',' data_defn_assignee
  1348.         ;
  1349.  
  1350. data_defn_assignee:    lvalue
  1351.             {
  1352.                  use_lvalue(&($1));
  1353.             }
  1354.         |    data_implied_do_list
  1355.         ;
  1356.  
  1357. data_value_list:    data_value
  1358.         |    data_value_list ',' data_value
  1359.         ;
  1360.  
  1361. data_value    :    data_constant_value
  1362.         |    data_repeat_factor '*' data_constant_value
  1363.         ;
  1364.  
  1365. data_repeat_factor:    nonzero_unsigned_int_const
  1366.         |    symbolic_name
  1367.             {
  1368.                  use_parameter(&($1));
  1369.             }
  1370.         ;
  1371.  
  1372. data_constant_value:    constant
  1373.         |    symbolic_name
  1374.             {
  1375.                  use_parameter(&($1));
  1376.             }
  1377.         ;
  1378.  
  1379.  
  1380. data_dlist    :    data_dlist_item
  1381.         |    data_dlist ',' data_dlist_item
  1382.         ;
  1383.  
  1384. data_dlist_item    :    array_element_lvalue
  1385.             {
  1386.                  use_lvalue(&($1));
  1387.             }
  1388.         |    data_implied_do_list
  1389.         ;
  1390.  
  1391. data_implied_do_list:  '(' data_dlist ',' symbolic_name
  1392.                 '=' data_do_loop_bounds ')'
  1393.             {
  1394.                 use_implied_do_index(&($4));
  1395.             }
  1396.         ;
  1397.  
  1398. data_do_loop_bounds:    int_constant_expr ',' int_constant_expr
  1399.         | int_constant_expr ',' int_constant_expr ',' int_constant_expr
  1400.         ;
  1401.  
  1402.  
  1403. /* 29 */
  1404. assignment_stmt    :    lvalue '=' {complex_const_allowed = TRUE;} expr
  1405.             {
  1406.               assignment_stmt_type(&($1),&($2),
  1407.                     &($4));
  1408.               complex_const_allowed = FALSE;
  1409.             }
  1410.                  EOS
  1411.             {
  1412.                 /* Clear u-b-s flags spuriously set */
  1413.               if(is_true(STMT_FUNCTION_EXPR, $1.subclass)
  1414.                      && stmt_sequence_no <= seq_stmt_fun)
  1415.                  stmt_function_stmt(&($1));
  1416.                 }
  1417.         ;
  1418.  
  1419. lvalue        :    variable_name
  1420.         |    array_element_lvalue
  1421.         |    substring_lvalue
  1422.         |    stmt_function_handle
  1423.         ;
  1424.  
  1425.  
  1426. /* array-element_lvalue is at 88 */
  1427.  
  1428. assign_stmt    :        tok_ASSIGN pre_label label tok_TO variable_name EOS
  1429.             {
  1430.                 do_ASSIGN(&($5));
  1431.             }
  1432.         ;
  1433.  
  1434.  
  1435. /* 31 */
  1436. unconditional_goto:    goto pre_label label EOS
  1437.         ;
  1438.  
  1439. /* 32 */
  1440. computed_goto    :    goto '(' goto_list ')' integer_expr EOS
  1441.         |    goto '(' goto_list ')' ',' integer_expr EOS
  1442.         ;
  1443.  
  1444. /* 33 */
  1445. assigned_goto    :    goto symbolic_name EOS
  1446.             {
  1447.                  do_assigned_GOTO(&($2));
  1448.             }
  1449.         |    goto symbolic_name '(' goto_list ')' EOS
  1450.             {
  1451.                  do_assigned_GOTO(&($2));
  1452.             }
  1453.         |    goto symbolic_name ',' '(' goto_list ')' EOS
  1454.             {
  1455.                  do_assigned_GOTO(&($2));
  1456.             }
  1457.         ;
  1458.  
  1459. goto        :    tok_GOTO
  1460.         |    tok_GO tok_TO
  1461.         ;
  1462.  
  1463. goto_list    :    pre_label label
  1464.         |    goto_list ',' pre_label label
  1465.         ;
  1466.  
  1467. /* 34 */
  1468. arithmetic_if_stmt:    if_handle pre_label label ',' pre_label label
  1469.                  ',' pre_label label EOS
  1470.             {
  1471.               int t=datatype_of($1.class);
  1472.               if(t != type_INTEGER && t != type_REAL
  1473.                  && t != type_DP && t != type_ERROR ) {
  1474.                 syntax_error($1.line_num,$1.col_num,
  1475.           "integer, real, or double precision expression required");
  1476.               }
  1477.             }
  1478.         ;
  1479.  
  1480. /* 35 */
  1481. logical_if_stmt    :    if_handle executable_stmt
  1482.             {
  1483.               int t=datatype_of($1.class);
  1484.               if(t != type_LOGICAL && t != type_ERROR)
  1485.                  syntax_error($1.line_num,$1.col_num,
  1486.                       "logical expression required");
  1487.             }
  1488.         ;
  1489.  
  1490. /* 36 */
  1491. block_if_stmt    :    if_handle tok_THEN EOS
  1492.             {
  1493.               int t=datatype_of($1.class);
  1494.               if(t != type_LOGICAL && t != type_ERROR)
  1495.                  syntax_error($1.line_num,$1.col_num,
  1496.                       "logical expression required");
  1497.             }
  1498.         ;
  1499.  
  1500. if_handle    :    tok_IF '(' {complex_const_allowed = TRUE;}  expr ')'
  1501.             {
  1502.                 if(is_true(ID_EXPR,$4.subclass)){
  1503.                 use_variable(&($4));
  1504.                 }
  1505.                 complex_const_allowed = FALSE;
  1506.  
  1507.                 initial_flag = TRUE;    /* for is_keyword */
  1508.                 $$ = $4; /* Inherit expr for type checking above */
  1509.             }
  1510.         ;
  1511.  
  1512. /* 37 */
  1513. else_if_stmt    :    tok_ELSE block_if_stmt
  1514.         |    tok_ELSEIF '(' {complex_const_allowed = TRUE;} expr ')'
  1515.             {
  1516.                 if(is_true(ID_EXPR,$4.subclass)){
  1517.                 use_variable(&($4));
  1518.                 }
  1519.                 complex_const_allowed = FALSE;
  1520.  
  1521.                 initial_flag = TRUE;
  1522.             }
  1523.             tok_THEN EOS
  1524.         ;
  1525.  
  1526. /* 38 */
  1527. else_stmt    :    tok_ELSE EOS
  1528.         ;
  1529.  
  1530. /* 39 */
  1531. end_if_stmt    :    tok_ENDIF EOS
  1532.         |    tok_END tok_IF EOS
  1533.         ;
  1534.  
  1535. /* 40 */
  1536.             /* Allow VAX/VMS extensions:
  1537.                DO [label [,]] var = expr , expr [,expr]
  1538.                DO [label [,]] WHILE ( expr )
  1539.                   ...
  1540.                ENDDO
  1541.             */
  1542.  
  1543. do_stmt        :    do_handle variable_name
  1544.                 '=' do_loop_bounds EOS
  1545.             {
  1546.                  use_lvalue(&($2));
  1547.                  use_variable(&($2));
  1548.  
  1549.                 /* Check for non-integer DO index or bounds */
  1550.                  if(datatype_of($2.class) == type_INTEGER
  1551.                 && datatype_of($4.class) != type_INTEGER)
  1552.                    warning($3.line_num,$2.col_num,
  1553.                   "type mismatch between DO index and bounds");
  1554.  
  1555.                  else if(datatype_of($2.class) != type_INTEGER)
  1556.                    if(datatype_of($4.class) != type_INTEGER) {
  1557.                  if(port_check)
  1558.                    nonportable($4.line_num,$4.col_num,
  1559.                            "non-integer DO loop bounds");
  1560.                    }
  1561.                    else {
  1562.                  if(trunc_check)
  1563.                    warning($2.line_num,$2.col_num,
  1564.                        "DO index is not integer");
  1565.                    }
  1566.             }
  1567.         |    do_handle tok_WHILE '('
  1568.                 {complex_const_allowed=TRUE;} expr ')' EOS
  1569.             {
  1570.                 if(is_true(ID_EXPR,$5.subclass)){
  1571.                 use_variable(&($5));
  1572.                 }
  1573.                 complex_const_allowed=FALSE;
  1574.                 /* (N.B. nonportability flagged in do_handle) */
  1575.             }
  1576.         |    tok_DOWHILE '('
  1577.                 {complex_const_allowed=TRUE;} expr ')' EOS
  1578.             {
  1579.                 if(is_true(ID_EXPR,$4.subclass)){
  1580.                 use_variable(&($4));
  1581.                 }
  1582.                 complex_const_allowed=FALSE;
  1583. #ifdef ALLOW_DO_ENDO
  1584.                 if(f77_standard)
  1585.                 nonstandard($1.line_num,$1.col_num);
  1586. #else
  1587.                 syntax_error($1.line_num,$1.col_num,
  1588.                     "Nonstandard syntax");
  1589. #endif
  1590.             }
  1591.         ;
  1592.  
  1593. do_handle    :    tok_DO pre_label label
  1594.         |    tok_DO pre_label label ','
  1595.         |    tok_DO pre_label
  1596.             {
  1597. #ifdef ALLOW_DO_ENDO
  1598.                 if(f77_standard)
  1599.                 nonstandard($1.line_num,$1.col_num);
  1600. #else
  1601.                 syntax_error($1.line_num,$1.col_num,
  1602.                     "Nonstandard syntax");
  1603. #endif
  1604.                 integer_context=FALSE;
  1605.             }
  1606.         ;
  1607.  
  1608. do_loop_bounds    :    int_real_dp_expr ',' int_real_dp_expr
  1609.             {
  1610.                 $$.class=do_bounds_type(&($1),&($3),&($3));
  1611.             }
  1612.         |   int_real_dp_expr ',' int_real_dp_expr ',' int_real_dp_expr
  1613.             {
  1614.                 $$.class=do_bounds_type(&($1),&($3),&($5));
  1615.             }
  1616.         ;
  1617.  
  1618. enddo_stmt    :    tok_END tok_DO EOS
  1619.             {
  1620. #ifdef ALLOW_DO_ENDO
  1621.                 if(f77_standard)
  1622.                 nonstandard($2.line_num,$2.col_num);
  1623. #else
  1624.                 syntax_error($2.line_num,$2.col_num,
  1625.                     "Nonstandard syntax");
  1626. #endif
  1627.             }
  1628.         |    tok_ENDDO EOS
  1629.             {
  1630. #ifdef ALLOW_DO_ENDO
  1631.                 if(f77_standard)
  1632.                 nonstandard($1.line_num,$1.col_num);
  1633. #else
  1634.                 syntax_error($1.line_num,$1.col_num,
  1635.                     "Nonstandard syntax");
  1636. #endif
  1637.             }
  1638.         ;
  1639.  
  1640. /* 41 */
  1641. continue_stmt    :    tok_CONTINUE EOS
  1642.         ;
  1643.  
  1644. /* 42 */
  1645. stop_stmt    :    tok_STOP stop_info EOS
  1646.         ;
  1647.  
  1648. /* 43 */
  1649. pause_stmt    :    tok_PAUSE stop_info EOS
  1650.         ;
  1651.  
  1652. stop_info    :    /* empty */
  1653.         |    tok_integer_const
  1654.         |    symbolic_name
  1655.             {
  1656.                  use_variable(&($1));
  1657.             }
  1658.         |    tok_string
  1659.         ;
  1660.  
  1661. /* 44 */
  1662. write_stmt    :    write_handle
  1663.                 {complex_const_allowed = FALSE;} EOS
  1664.         |    write_handle io_list
  1665.                 {complex_const_allowed = FALSE;} EOS
  1666.         ;
  1667.  
  1668. write_handle    :    tok_WRITE {control_item_count = 0;}
  1669.                 '(' control_info_list ')'
  1670.                 {complex_const_allowed = TRUE;}
  1671.         ;
  1672.  
  1673. /* 45 */
  1674.         /* Note that parenthesized format_id's will end up in
  1675.            control_info_list. Disambiguation left to semantic phase.
  1676.            This is why we need the optional comma */
  1677. read_stmt    :    read_handle '(' control_info_list ')' EOS
  1678.         |    read_handle '(' control_info_list ')' io_list EOS
  1679.         |    read_handle '(' control_info_list ')' ',' io_list EOS
  1680.         |    read_handle format_id EOS
  1681.         |    read_handle format_id ',' io_list EOS
  1682.         ;
  1683. read_handle    :    tok_READ {control_item_count = 0;}
  1684.         ;
  1685.  
  1686. accept_stmt    :    tok_ACCEPT format_id EOS
  1687.             {
  1688.                 if(f77_standard)
  1689.                 nonstandard($1.line_num,$1.col_num);
  1690.             }
  1691.         |    tok_ACCEPT format_id ',' io_list EOS
  1692.             {
  1693.                 if(f77_standard)
  1694.                 nonstandard($1.line_num,$1.col_num);
  1695.             }
  1696.         ;
  1697.  
  1698. /* 46 */
  1699. print_stmt    :    tok_PRINT format_id EOS
  1700.            |    tok_PRINT format_id ','
  1701.                 {complex_const_allowed = TRUE;} io_list
  1702.                 {complex_const_allowed = FALSE;}  EOS
  1703.         ;
  1704.  
  1705. type_output_stmt:    tok_TYPE format_id EOS
  1706.             {
  1707.                 if(f77_standard)
  1708.                 nonstandard($1.line_num,$1.col_num);
  1709.             }
  1710.            |    tok_TYPE format_id ','
  1711.                 {complex_const_allowed = TRUE;} io_list
  1712.                 {complex_const_allowed = FALSE;}  EOS
  1713.             {
  1714.                 if(f77_standard)
  1715.                 nonstandard($1.line_num,$1.col_num);
  1716.             }
  1717.         ;
  1718.  
  1719. /* 47 */
  1720. control_info_list:    control_info_item
  1721.             {
  1722.                 ++control_item_count;
  1723.             }
  1724.         |    control_info_list ',' control_info_item
  1725.             {
  1726.                 ++control_item_count;
  1727.             }
  1728.         ;
  1729.  
  1730.     /* Note that unit id is not distinguished from format id
  1731.        by the grammar. Use sequence no. to tell which is which.
  1732.      */
  1733. control_info_item:    symbolic_name '=' unit_id
  1734.             {
  1735.                 use_io_keyword(&($1),&($3),curr_stmt_class);
  1736.             }
  1737.         |    unit_id
  1738.             {
  1739.                 if( $1.class != '*'
  1740.                    && is_true(ID_EXPR,$1.subclass)){
  1741.                     /* WRITE(string,...) means store
  1742.                        output in the string */
  1743.                 if(curr_stmt_class == tok_WRITE
  1744.                  && control_item_count == 0
  1745.                  && datatype_of($1.class) == type_STRING)
  1746.                     use_lvalue(&($1));
  1747.                     /* READ/WRITE(..,namelist) means
  1748.                        I/O with variables of namelist. */
  1749.                 else if( control_item_count == 1
  1750.                     && datatype_of($1.class) == type_NAMELIST)
  1751.                     ref_namelist(&($1),curr_stmt_class);
  1752.  
  1753.                 use_variable(&($1));
  1754.                 }
  1755.             }
  1756.         ;
  1757.  
  1758.             /* OPEN stmt needs its own control list defn to
  1759.                allow for VMS READONLY and similar keywords.
  1760.                Special prodn for unit_id as optional 1st item
  1761.                needed to avoid reduce/reduce conflict with
  1762.                later-occurring symbolic_name items.   */
  1763. open_info_list    :    unit_id
  1764.             {
  1765.                 if( $1.class != '*'
  1766.                    && is_true(ID_EXPR,$1.subclass)){
  1767.                 use_variable(&($1));
  1768.                 }
  1769.                 ++control_item_count;
  1770.             }
  1771.         |    symbolic_name '=' unit_id
  1772.             {
  1773.                 use_io_keyword(&($1),&($3),curr_stmt_class);
  1774.                 ++control_item_count;
  1775.             }
  1776.         |    open_info_list ',' open_info_item
  1777.             {
  1778.                 ++control_item_count;
  1779.             }
  1780.         ;
  1781.  
  1782. open_info_item    :    symbolic_name '=' unit_id
  1783.             {
  1784.                 use_io_keyword(&($1),&($3),curr_stmt_class);
  1785.             }
  1786.         |    symbolic_name    /* NOSPANBLOCKS, READONLY or SHARED */
  1787.             {
  1788.                 use_special_open_keywd(&($1));
  1789.             }
  1790.         ;
  1791.  
  1792. /* 48 */
  1793. io_list        :    io_item
  1794.         |    io_list ',' io_item
  1795.         ;
  1796.  
  1797. io_item        :    expr
  1798.             {
  1799.                 if(is_true(ID_EXPR,$1.subclass)){
  1800.                 if( curr_stmt_class == tok_READ ||
  1801.                     curr_stmt_class == tok_ACCEPT )
  1802.                     use_lvalue(&($1));
  1803.                 else
  1804.                     use_variable(&($1));
  1805.                 }
  1806.             }
  1807.         |    io_implied_do_list
  1808.         ;
  1809.  
  1810. /* 49 */
  1811. io_implied_do_list:    '(' io_list ',' variable_name '=' do_loop_bounds ')'
  1812.             {
  1813.                  use_implied_do_index(&($4));
  1814.             }
  1815.         ;
  1816.  
  1817. /* 50 */
  1818. open_stmt    :    tok_OPEN {control_item_count = 0;}
  1819.                  '(' open_info_list ')' EOS
  1820.         ;
  1821.  
  1822. /* 51 */
  1823. close_stmt    :    tok_CLOSE {control_item_count = 0;}
  1824.                 '(' control_info_list ')' EOS
  1825.         ;
  1826.  
  1827. /* 52 */
  1828. inquire_stmt    :    tok_INQUIRE {control_item_count = 0;}
  1829.                 '(' control_info_list ')' EOS
  1830.         ;
  1831.  
  1832. /* 53 */
  1833. backspace_stmt    :    backspace_handle unit_id EOS
  1834.         |    backspace_handle '(' control_info_list ')' EOS
  1835.         ;
  1836. backspace_handle:    tok_BACKSPACE {control_item_count = 0;}
  1837.         ;
  1838.  
  1839. /* 54 */
  1840. endfile_stmt    :    endfile_handle unit_id EOS
  1841.         |    endfile_handle '(' control_info_list ')' EOS
  1842.         ;
  1843. endfile_handle    :    tok_ENDFILE {control_item_count = 0;}
  1844.         |    tok_END tok_FILE {control_item_count = 0;}
  1845.         ;
  1846.  
  1847. /* 55 */
  1848. rewind_stmt    :    rewind_handle unit_id EOS
  1849.         |    rewind_handle '(' control_info_list ')' EOS
  1850.         ;
  1851. rewind_handle    :    tok_REWIND {control_item_count = 0;}
  1852.         ;
  1853.  
  1854.  
  1855. /* 56 */
  1856.         /* "expr" causes shift/reduce conflict on ')' between
  1857.            red'n  unit_id: expr_  and shift  primary: ( expr_ ).
  1858.            Use "associativity" rule to force reduction */
  1859. unit_id        :    expr        %prec REDUCE
  1860.         |    '*'
  1861.         ;
  1862.  
  1863. /* 57 */
  1864. format_id    :    char_expr
  1865.             {
  1866.                 if(is_true(ID_EXPR,$1.subclass)){
  1867.                  use_variable(&($1));
  1868.                 }
  1869.             }
  1870.         |    '*'
  1871.         ;
  1872.  
  1873. /* 58,59 */
  1874. format_stmt    :    tok_FORMAT {inside_format=TRUE;} '(' format_spec ')' EOS
  1875.             {
  1876.               inside_format=FALSE;
  1877.             }
  1878.         ;
  1879.  
  1880. /* 60-69 */
  1881. format_spec    :        /* EMPTY */
  1882.         |    format_spec fmt_spec_item
  1883.         |    format_spec ',' fmt_spec_item
  1884.         ;
  1885.  
  1886. fmt_spec_item    :    repeatable_fmt_item
  1887.         |    repeat_spec repeatable_fmt_item
  1888.         |    unrepeatable_fmt_item
  1889.         ;
  1890.  
  1891. repeatable_fmt_item:    '(' format_spec ')'
  1892.         |    tok_edit_descriptor
  1893.         ;
  1894.  
  1895. unrepeatable_fmt_item:    tok_string
  1896.         |    tok_hollerith
  1897.         |    '/'
  1898.         |    tok_concat    /* since lexer spots "//" */
  1899.         |    ':'
  1900.         |    nonstandard_fmt_item
  1901.             {
  1902.               if(f77_standard)
  1903.                  nonstandard($1.line_num,$1.col_num);
  1904.             }
  1905.         ;
  1906.  
  1907. nonstandard_fmt_item: '$'    /* VMS uses this */
  1908.         ;
  1909.  
  1910. repeat_spec    :    tok_integer_const
  1911.         |    '-' tok_integer_const    /* for kP descriptor */
  1912.         |    '+' tok_integer_const    /* for +kP descriptor */
  1913.         ;
  1914.  
  1915. /* 70 handle only: complete defn handled as assignment stmt */
  1916.  
  1917. stmt_function_handle:    scalar_name '(' stmt_function_dummy_list ')'
  1918.             {
  1919.                 if(stmt_sequence_no > seq_stmt_fun) {
  1920.                     syntax_error(
  1921.                     $1.line_num, NO_COL_NUM,
  1922.                         "statement out of order");
  1923.                  }
  1924.                 def_stmt_function(&($1),&($3));
  1925.                     /* make token info */
  1926.                 primary_id_expr(&($1),&($$));
  1927.                 if(debug_parser)
  1928.                   print_exprlist("stmt function",&($3));
  1929.             }
  1930.         ;
  1931.  
  1932. stmt_function_dummy_list: stmt_function_dummy_arg
  1933.             {
  1934.                 $$.next_token = append_token((Token*)NULL,&($1));
  1935.             }
  1936.         |      stmt_function_dummy_list ',' stmt_function_dummy_arg
  1937.             {
  1938.                 $$.next_token = append_token($1.next_token,&($3));
  1939.             }
  1940.         ;
  1941.  
  1942. stmt_function_dummy_arg:  variable_name    /* for now: later, handle correctly */
  1943.         ;
  1944.  
  1945. /* 71 */
  1946. call_stmt    :    call_handle
  1947.             {
  1948.                  call_subr(&($1),(Token*)NULL);
  1949.                  complex_const_allowed = FALSE;
  1950.             } EOS
  1951.  
  1952.         |    call_handle '(' ')'
  1953.             {
  1954.                  call_subr(&($1),(Token*)NULL);
  1955.                  complex_const_allowed = FALSE;
  1956.             } EOS
  1957.  
  1958.         |    call_handle '(' expr_list ')'
  1959.             {
  1960.                  call_subr(&($1),&($3));
  1961.                  if(debug_parser)
  1962.                 print_exprlist("call stmt",&($3));
  1963.                  complex_const_allowed = FALSE;
  1964.             } EOS
  1965.         ;
  1966.  
  1967. call_handle    :    tok_CALL symbolic_name
  1968.             {
  1969.                  complex_const_allowed = TRUE;
  1970.                  $$ = $2;
  1971.             }
  1972.         ;
  1973. expr_list    :    expr
  1974.             {
  1975.                 if(is_true(ID_EXPR,$1.subclass)){
  1976.                  use_actual_arg(&($1));
  1977.                  use_variable(&($1));
  1978.                 }
  1979.                 $$.next_token = append_token((Token*)NULL,&($1));
  1980.             }
  1981.         |    '*' pre_label label
  1982.             {
  1983.                 $$.next_token = append_token((Token*)NULL,&($3));
  1984.             }
  1985.         |    expr_list ',' expr
  1986.             {
  1987.                 if(is_true(ID_EXPR,$3.subclass)){
  1988.                  use_actual_arg(&($3));
  1989.                  use_variable(&($3));
  1990.                 }
  1991.                 $$.next_token = append_token($1.next_token,&($3));
  1992.             }
  1993.         |    expr_list ',' '*' pre_label label
  1994.             {
  1995.                 $$.next_token = append_token($1.next_token,&($5));
  1996.             }
  1997.         ;
  1998.  
  1999. /* 72 */
  2000. return_stmt    :    tok_RETURN EOS
  2001.             {
  2002.                  do_RETURN(current_module_hash,&($1));
  2003.             }
  2004.         |    tok_RETURN integer_expr EOS
  2005.             {
  2006.                  do_RETURN(current_module_hash,&($1));
  2007.             }
  2008.         ;
  2009.  
  2010. /* 73 */
  2011. function_reference:    fun_or_substr_handle '(' fun_arg_list ')'
  2012.             {
  2013.                    /* restore status of complex flag */
  2014.                 if(!is_true(COMPLEX_FLAG,$1.subclass))
  2015.                   complex_const_allowed=FALSE;
  2016.                 call_func(&($1),&($3));
  2017.                             /* make token info */
  2018.                 func_ref_expr(&($1),&($3),&($$));
  2019.                 if(debug_parser)
  2020.                     print_exprlist("function",&($3));
  2021.             }
  2022.         ;
  2023.  
  2024. fun_or_substr_handle:    scalar_name
  2025.             {
  2026.               if(complex_const_allowed)/* save context */
  2027.                 make_true(COMPLEX_FLAG,$$.subclass);
  2028.               complex_const_allowed=TRUE;
  2029.             }
  2030.         ;
  2031. fun_arg_list    :    /* empty */
  2032.             {
  2033.                 $$.class = 0;
  2034.                 $$.next_token = NULL;
  2035.             }
  2036.         |    nonempty_fun_arg_list
  2037.         ;
  2038.  
  2039. nonempty_fun_arg_list:    expr
  2040.             {
  2041.                 $$.next_token = append_token((Token*)NULL,&($1));
  2042.             }
  2043.         |    fun_arg_list ',' expr
  2044.             {
  2045.                 $$.next_token = append_token($1.next_token,&($3));
  2046.             }
  2047.  
  2048. /* 74 not present: type checking not done at this level */
  2049.  
  2050. /* 75 was constant_expr, but only used by PARAMETER */
  2051. parameter_expr    :    /* arith, char, or logical */ expr
  2052.             {
  2053.               if(datatype_of($1.class) != type_ERROR){
  2054.                 if( ! is_const_type($1.class) ) {
  2055.                   syntax_error($1.line_num,$1.col_num,
  2056.               "arithmetic, char, or logical expression expected");
  2057.                 }
  2058.                 else {
  2059.                   if( !is_true(PARAMETER_EXPR,$1.subclass) ) {
  2060.                 syntax_error($1.line_num,$1.col_num,
  2061.                        "constant expression expected");
  2062.                   }
  2063.                 /* Here we allow, with some warnings, expr
  2064.                    containing intrins func or **REAL in
  2065.                    PARAMETER defn. */
  2066.                   else if( !is_true(CONST_EXPR,$1.subclass) ) {
  2067.                 if(f77_standard) {
  2068.                   nonstandard($1.line_num,$1.col_num);
  2069.                   msg_tail(
  2070.              "\n    intrinsic func or **REAL in PARAMETER defn");
  2071.                 }
  2072.                   }
  2073.                 }
  2074.               }
  2075.             }
  2076.         ;
  2077.  
  2078. /* 76 following the text of the standard, not the diagrams */
  2079. expr        :    log_expr
  2080.             {
  2081.                 if(debug_parser) {
  2082.                 fprintf(list_fd,
  2083.                     "\nexpr: class=0x%x subclass=0x%x",
  2084.                     $1.class,
  2085.                     $1.subclass);
  2086.                 }
  2087.             }
  2088.         ;
  2089.  
  2090. log_expr    :    log_disjunct
  2091.  
  2092.         |    expr tok_EQV log_disjunct
  2093.             {
  2094.                 binexpr_type(&($1),&($2),&($3)
  2095.                      ,&($$));
  2096.             }
  2097.         |    expr tok_NEQV log_disjunct
  2098.             {
  2099.                 binexpr_type(&($1),&($2),&($3)
  2100.                      ,&($$));
  2101.             }
  2102.         ;
  2103.  
  2104. log_disjunct    :    log_term
  2105.  
  2106.         |    log_disjunct tok_OR log_term
  2107.             {
  2108.                 binexpr_type(&($1),&($2),&($3)
  2109.                      ,&($$));
  2110.             }
  2111.         ;
  2112.  
  2113. log_term    :    log_factor
  2114.  
  2115.         |    log_term tok_AND log_factor
  2116.             {
  2117.                 binexpr_type(&($1),&($2),&($3)
  2118.                      ,&($$));
  2119.             }
  2120.         ;
  2121.  
  2122. log_factor    :    log_primary
  2123.  
  2124.         |    tok_NOT log_primary
  2125.             {
  2126.                 unexpr_type(&($1),&($2),&($$));
  2127.             }
  2128.         ;
  2129.  
  2130. log_primary    :    arith_expr
  2131.  
  2132.         |    log_primary tok_relop log_primary
  2133.             {
  2134.                 binexpr_type(&($1),&($2),&($3)
  2135.                      ,&($$));
  2136.             }
  2137.         ;
  2138.  
  2139.  
  2140. arith_expr    :    term
  2141.  
  2142.         |    '-' term
  2143.             {
  2144.                 unexpr_type(&($1),&($2),&($$));
  2145.             }
  2146.         |    '+' term
  2147.             {
  2148.                 unexpr_type(&($1),&($2),&($$));
  2149.             }
  2150.         |    arith_expr '+' term
  2151.             {
  2152.                 binexpr_type(&($1),&($2),&($3)
  2153.                      ,&($$));
  2154.             }
  2155.         |    arith_expr '-' term
  2156.             {
  2157.                 binexpr_type(&($1),&($2),&($3)
  2158.                      ,&($$));
  2159.             }
  2160.         ;
  2161.  
  2162. term        :    factor
  2163.  
  2164.         |    term '/' factor
  2165.             {
  2166.                 binexpr_type(&($1),&($2),&($3)
  2167.                      ,&($$));
  2168.                 if(div_check &&
  2169.                    !is_true(CONST_EXPR,$3.subclass)){
  2170.                 warning($2.line_num,$2.col_num,
  2171.                     "Possible division by zero");
  2172.                 }
  2173.             }
  2174.         |    term '*' factor
  2175.             {
  2176.                 binexpr_type(&($1),&($2),&($3)
  2177.                      ,&($$));
  2178.             }
  2179.         ;
  2180.  
  2181. factor        :    char_expr
  2182.  
  2183.         |    char_expr tok_power factor
  2184.             {
  2185.                 binexpr_type(&($1),&($2),&($3)
  2186.                      ,&($$));
  2187.             }
  2188.         ;
  2189.  
  2190. char_expr    :    primary
  2191.  
  2192.         |    char_expr tok_concat primary
  2193.             {
  2194.                 binexpr_type(&($1),&($2),&($3)
  2195.                      ,&($$));
  2196.             }
  2197.         ;
  2198.  
  2199. primary        :    variable_name
  2200.             {
  2201.                 DBGstr(primary<--id=,token_name($1));
  2202.             }
  2203.         |    array_element_name
  2204.  
  2205.         |    function_reference
  2206.  
  2207.         |    substring_name
  2208.  
  2209.         |    numeric_const
  2210.             {
  2211.                 make_true(CONST_EXPR,$$.subclass);
  2212.                 make_true(PARAMETER_EXPR,$$.subclass);
  2213.                 make_true(NUM_CONST,$$.subclass);
  2214.             }
  2215.         |    tok_string
  2216.             {
  2217.                 DBGstr(primary<--str=,$1.value.string)
  2218.                 $$.class = type_byte(class_VAR,type_STRING);
  2219.                 $$.subclass = 0;
  2220.                 make_true(CONST_EXPR,$$.subclass);
  2221.                 make_true(PARAMETER_EXPR,$$.subclass);
  2222.             }
  2223.         |    tok_hollerith
  2224.             {
  2225.                 DBGstr(primary<--h=,$1.value.string)
  2226.                 $$.class = type_byte(class_VAR,type_HOLLERITH);
  2227.                 $$.subclass = 0;
  2228.                 make_true(CONST_EXPR,$$.subclass);
  2229.                 make_true(PARAMETER_EXPR,$$.subclass);
  2230.                 if(port_check && hollerith_check) {
  2231.                 warning($1.line_num,$1.col_num,
  2232.                 "hollerith constant may not be portable");
  2233.                 }
  2234.             }
  2235.         |    tok_logical_const
  2236.             {
  2237.                 DBGstr(primary<--log=,$1.value.string)
  2238.                 $$.class = type_byte(class_VAR,type_LOGICAL);
  2239.                 $$.subclass = 0;
  2240.                 make_true(CONST_EXPR,$$.subclass);
  2241.                 make_true(PARAMETER_EXPR,$$.subclass);
  2242.             }
  2243.         |    '(' expr ')'
  2244.             {
  2245.                 $$ = $2;
  2246.             }
  2247.         ;
  2248.  
  2249. numeric_const    :    tok_integer_const
  2250.             {
  2251.                 $$.class = type_byte(class_VAR,type_INTEGER);
  2252.                 $$.subclass = 0;
  2253.             }
  2254.         |    tok_real_const
  2255.             {
  2256.                 $$.class = type_byte(class_VAR,type_REAL);
  2257.                 $$.subclass = 0;
  2258.             }
  2259.         |    tok_dp_const
  2260.             {
  2261.                 $$.class = type_byte(class_VAR,type_DP);
  2262.                 $$.subclass = 0;
  2263.             }
  2264.         |    tok_complex_const
  2265.             {
  2266.                 $$.class = type_byte(class_VAR,type_COMPLEX);
  2267.                 $$.subclass = 0;
  2268.             }
  2269.         ;
  2270.  
  2271. /* 77 */
  2272. integer_expr    :    /* integer */ arith_expr
  2273.             {
  2274.                 if(is_true(ID_EXPR,$1.subclass)){
  2275.                 use_variable(&($1));
  2276.                 }
  2277.                 if(datatype_of($1.class) != type_INTEGER) {
  2278.                 syntax_error(
  2279.                     $1.line_num,$1.col_num,
  2280.                     "expression must be integer type");
  2281.                 }
  2282.             }
  2283.         ;
  2284.  
  2285. /* 78 */
  2286. int_real_dp_expr:    /* integer, real, or double */ arith_expr
  2287.             {
  2288.                 if(is_true(ID_EXPR,$1.subclass)){
  2289.                 use_variable(&($1));
  2290.                 }
  2291.                 {
  2292.                 int t=datatype_of($1.class);
  2293.                     if(t != type_INTEGER && t != type_REAL
  2294.                     && t != type_DP ) {
  2295.                     syntax_error(
  2296.                       $1.line_num,$1.col_num,
  2297.         "expression must be integer, real, or double precision type");
  2298.                         }
  2299.                 }
  2300.             }
  2301.         ;
  2302.  
  2303. /* 79 absent */
  2304.  
  2305. /* 80 */
  2306. int_constant_expr:    /* integer const */ arith_expr
  2307.             {
  2308.                 if(is_true(ID_EXPR,$1.subclass)){
  2309.                 use_variable(&($1));
  2310.                 }
  2311.                 if( ! is_true(CONST_EXPR,$1.subclass) ) {
  2312.                 syntax_error(
  2313.                     $1.line_num,$1.col_num,
  2314.                     "constant expression expected");
  2315.                 }
  2316.                 else
  2317.                   if(datatype_of($1.class) != type_INTEGER){
  2318.                 syntax_error(
  2319.                     $1.line_num,$1.col_num,
  2320.                     "integer expression expected");
  2321.                 }
  2322.  
  2323.             }
  2324.         ;
  2325.  
  2326. /* 81 */
  2327. dim_bound_expr    :       /* integer */  arith_expr
  2328.             {
  2329.                 if(is_true(ID_EXPR,$1.subclass)){
  2330.                 use_variable(&($1));
  2331.                 }
  2332.  
  2333.                 if( datatype_of($1.class) != type_INTEGER ){
  2334.                 syntax_error(
  2335.                     $1.line_num,$1.col_num,
  2336.                     "integer dimension expected");
  2337.                 $$.value.integer = 0;
  2338.                 }
  2339.                 else {
  2340.                   if( is_true(CONST_EXPR,$1.subclass) )
  2341.                 $$.value.integer =
  2342.                   int_expr_value(&($1));
  2343.                   else        /* must be dummy */
  2344.                 $$.value.integer = 0;
  2345.                 }
  2346.             }
  2347.         ;
  2348.  
  2349. /* 82-85 absent: no type checking here */
  2350. /* 86-87 absent: see 76 */
  2351.  
  2352. /* 88 */
  2353. array_element_lvalue:    array_name '(' subscript_list ')'
  2354.             {
  2355.                 ref_array(&($1),&($3));
  2356.                 if(debug_parser)
  2357.                     print_exprlist("array lvalue",&($3));
  2358.                     /* array now becomes scalar */
  2359.                 make_false(ARRAY_ID_EXPR,$$.subclass);
  2360.             }
  2361.         ;
  2362.  
  2363. array_element_name:    array_name '(' subscript_list ')'
  2364.             {
  2365.                 ref_array(&($1),&($3));
  2366.                 if(debug_parser)
  2367.                     print_exprlist("array",&($3));
  2368.                     /* array now becomes scalar */
  2369.                 make_false(ARRAY_ID_EXPR,$$.subclass);
  2370.             }
  2371.         ;
  2372.  
  2373. subscript_list    :    subscript
  2374.             {
  2375.                 $$.next_token = append_token((Token*)NULL,&($1));
  2376.             }
  2377.         |    subscript_list ',' subscript
  2378.             {
  2379.                 $$.next_token = append_token($1.next_token,&($3));
  2380.             }
  2381.              ;
  2382.  
  2383. subscript    :    expr
  2384.             {
  2385.                 if(is_true(ID_EXPR,$1.subclass)){
  2386.                  use_variable(&($1));
  2387.                 }
  2388.                 /* check subscript exprs for integer type */
  2389.                 if(datatype_of($1.class) != type_INTEGER)
  2390.                   if(trunc_check)
  2391.                      warning($1.line_num,$1.col_num,
  2392.                      "subscript is not integer");
  2393.             }
  2394.         ;
  2395.  
  2396. /* 89 */
  2397. substring_name    :    fun_or_substr_handle  substring_interval
  2398.             {
  2399.                    /* restore status of complex flag */
  2400.                 if(!is_true(COMPLEX_FLAG,$1.subclass))
  2401.                   complex_const_allowed=FALSE;
  2402.             }
  2403.         |    array_element_name substring_interval
  2404.         ;
  2405.  
  2406. substring_lvalue:    scalar_name substring_interval
  2407.         |    array_element_lvalue substring_interval
  2408.         ;
  2409.  
  2410. substring_interval:    '(' ':' ')'
  2411.           |    '(' arith_expr ':' ')'
  2412.             {
  2413.                 if(is_true(ID_EXPR,$2.subclass)){
  2414.                 use_variable(&($2));
  2415.                 }
  2416.             }
  2417.           |    '(' ':' arith_expr ')'
  2418.             {
  2419.                 if(is_true(ID_EXPR,$3.subclass)){
  2420.                 use_variable(&($3));
  2421.                 }
  2422.             }
  2423.           |    '(' arith_expr ':' arith_expr ')'
  2424.             {
  2425.                 if(is_true(ID_EXPR,$2.subclass)){
  2426.                 use_variable(&($2));
  2427.                 }
  2428.                 if(is_true(ID_EXPR,$4.subclass)){
  2429.                 use_variable(&($4));
  2430.                 }
  2431.  
  2432.             }
  2433.           ;
  2434.  
  2435. /* 90-98 absent: name categories not distinguished */
  2436.  
  2437. /* 99 */
  2438. variable_name    :    scalar_name
  2439.         |    array_name
  2440.         ;
  2441.  
  2442. scalar_name    :    tok_identifier
  2443.             {
  2444.                 ref_variable(&($1));
  2445.                 primary_id_expr(&($1),&($$));
  2446.             }
  2447.         ;
  2448.  
  2449. array_name    :    tok_array_identifier
  2450.             {
  2451.                 ref_variable(&($1));
  2452.                 primary_id_expr(&($1),&($$));
  2453.             }
  2454.         ;
  2455.  
  2456.  
  2457. /* symbolic_name refers to a name without making it into an id expr */
  2458. symbolic_name    :    tok_identifier
  2459.         |    tok_array_identifier
  2460.         ;
  2461.  
  2462. /* 100 */
  2463. constant    :    numeric_const
  2464.         |    '-' numeric_const
  2465.         |    '+' numeric_const
  2466.         |    tok_logical_const
  2467.            |    tok_string
  2468.         |    tok_hollerith
  2469.         ;
  2470.  
  2471. /* 101-102 absent */
  2472.  
  2473. /* 103 */
  2474. nonzero_unsigned_int_const:
  2475.             tok_integer_const
  2476.         ;
  2477.  
  2478. /* 104-109 absent: lexer handles these */
  2479.     /* pre_label prepares for an expected label by setting flag
  2480.        so that lexer won't look for E-format number.  All grammar
  2481.        rules that have "label" precede it with "pre_label" */
  2482. pre_label    :    /* NOTHING */
  2483.             {
  2484.                 integer_context=TRUE;
  2485.             }
  2486.         ;
  2487.  
  2488. /* 110 */
  2489. label        :    tok_integer_const
  2490.             {
  2491.                 integer_context=FALSE;
  2492.                 $$.class = type_byte(class_LABEL,type_LABEL);
  2493.                 $$.subclass = 0;
  2494.             }
  2495.         ;
  2496.  
  2497. /* 111-116 absent: lexer handles these */
  2498.  
  2499. %%
  2500. void
  2501. init_parser()            /* Initialize various flags & counters */
  2502. {
  2503.     initial_flag = TRUE;    /* set flag for keyword test */
  2504.     implicit_flag=FALSE;    /* clear flags for IMPLICIT stmt */
  2505.     implicit_letter_flag = FALSE;
  2506.     implicit_type_given = FALSE;
  2507.     implicit_none = FALSE;
  2508.     prev_token_class = EOS;
  2509.     complex_const_allowed = FALSE;
  2510.     stmt_sequence_no = 0;
  2511. }
  2512.  
  2513.         /* Propagate non-integer type if any of DO loop
  2514.            bounds are non-integer. */
  2515. PRIVATE int
  2516. do_bounds_type(t1,t2,t3)
  2517.      Token *t1, *t2, *t3;
  2518. {
  2519.   int result_class;
  2520.        if(datatype_of(t1->class) != type_INTEGER) result_class = t1->class;
  2521.   else if(datatype_of(t2->class) != type_INTEGER) result_class = t2->class;
  2522.   else if(datatype_of(t3->class) != type_INTEGER) result_class = t3->class;
  2523.   else result_class = t1->class;
  2524.   return result_class;
  2525. }
  2526.  
  2527.  
  2528. /* Debugging routine: prints the expression list of various productions */
  2529.  
  2530. PRIVATE void
  2531. print_exprlist(s,t)
  2532.     char *s;
  2533.     Token *t;
  2534. {
  2535.  
  2536.     fprintf(list_fd,"\n%s arglist: ",s);
  2537.  
  2538.     if(t == NULL)
  2539.         fprintf(list_fd,"(empty)");
  2540.     else {
  2541.           while( (t=t->next_token) != NULL) {
  2542.           fprintf(list_fd,"%s ",type_name[datatype_of(t->class)]);
  2543.           if( is_true(ID_EXPR,t->subclass) )
  2544.             fprintf(list_fd,"(%s) ",token_name(*t));
  2545.         }
  2546.     }
  2547. }
  2548.  
  2549. PRIVATE void
  2550. print_comlist(s,t)
  2551.     char *s;
  2552.     Token *t;
  2553. {
  2554.  
  2555.     fprintf(list_fd,"\n%s varlist: ",s);
  2556.  
  2557.     if(t == NULL)
  2558.         fprintf(list_fd,"(empty)");
  2559.     else {
  2560.           while( (t=t->next_token) != NULL) {
  2561.           fprintf(list_fd,"%s ",type_name[datatype_of(t->class)]);
  2562.           if( is_true(ID_EXPR,t->subclass) )
  2563.             fprintf(list_fd,"(%s) ",token_name(*t));
  2564.         }
  2565.       }
  2566. }
  2567.  
  2568. /* After having parsed prog_stmt, function_stmt, subroutine_stmt,
  2569.    block_data_stmt, the stmt_sequence_no is set to the value seq_header.
  2570. */
  2571.  
  2572. void
  2573. check_seq_header(t)
  2574.      Token *t;
  2575. {
  2576.     if(stmt_sequence_no >= seq_header) {
  2577.        syntax_error( (t == (Token *) NULL? line_num: t->line_num),
  2578.             NO_COL_NUM,
  2579.             "missing END statement inserted");
  2580.        msg_tail( (t == (Token *) NULL? "at end of file":
  2581.               "prior to statement") );
  2582.  
  2583.        END_processing(t);
  2584.     }
  2585.     stmt_sequence_no = seq_header;
  2586. }
  2587.  
  2588.  
  2589.  
  2590.  
  2591.     /* After having parsed end_stmt, common block lists and
  2592.        subprogram argument lists are copied over into global symbol
  2593.        table, the local symbol table is printed out and then cleared,
  2594.        and stmt_sequence_no is set to zero for start of next module.
  2595.     */
  2596.  
  2597. PRIVATE void
  2598. END_processing(t)
  2599.     Token *t;
  2600. {
  2601.   if(current_module_hash != -1) {
  2602.         if(exec_stmt_count == 0 &&
  2603.        current_module_type != type_BLOCK_DATA) {
  2604.       warning(t == (Token *)NULL? line_num: t->line_num, NO_COL_NUM,
  2605.           "Module contains no executable statements");
  2606.     }
  2607.  
  2608.     if(do_list && t != (Token *)NULL)
  2609.         flush_line_out(t->line_num);
  2610.     process_lists(current_module_hash);
  2611.     debug_symtabs();
  2612.     print_loc_symbols(current_module_hash);
  2613.     init_symtab();
  2614.   }
  2615.   exec_stmt_count = 0;
  2616.   stmt_sequence_no = 0;
  2617.   current_module_hash = -1;
  2618.   implicit_type_given = FALSE;
  2619.   implicit_none = FALSE;
  2620. }
  2621.  
  2622.         /* Routine to add token t to the front of a token list. */
  2623. PRIVATE Token *
  2624. append_token(tlist,t)
  2625.      Token *tlist, *t;
  2626. {
  2627.     Token *tcopy;
  2628.     if((tcopy=new_token()) == (Token *)NULL){
  2629.         fprintf(stderr,
  2630.             "Oops--Out of token space at line %u\n",
  2631.             line_num);
  2632. #ifdef LARGE_MACHINE
  2633.         fprintf(stderr,
  2634.             "Recompile me with larger TOKENSPACESZ value\n");
  2635. #else
  2636.         fprintf(stderr,
  2637.             "Recompile me with LARGE_MACHINE option\n");
  2638. #endif
  2639.         exit(1);
  2640.     }
  2641.  
  2642.     *tcopy = *t;        /* make permanent copy of token */
  2643.     tcopy->next_token = tlist; /* link it onto front of list */
  2644.     return tcopy;        /* return it as new tlist */
  2645. }
  2646.