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