/* $Id: fortran.y,v 1.64 2004/11/18 02:06:04 moniot Exp $ fortran.y: Yacc grammar for Fortran program checker. Uses the yylex() in file FORLEX.C */ %{ /* fortran.c: Copyright (c) 2001 by Robert K. Moniot. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. Acknowledgement: the above permission notice is what is known as the "MIT License." */ /* This grammar is ANSI standard-conforming, except for: -- complex constant and a few other ambiguities needing significant lookahead cannot be split across lines. Extensions supported: -- Case insensitive. -- Hollerith constants. -- Variable names may be longer than 6 characters. Also allows underscores and dollar signs in names. -- DO ... ENDDO and DO WHILE loop forms allowed. -- NAMELIST supported. -- TYPE and ACCEPT I/O statements allowed. -- Tabs are permitted in input, and (except in character data) expand into blanks up to the next column equal to 1 mod 8. -- Type declarations INTEGER*2, REAL*8, etc. are allowed. -- IMPLICIT NONE allowed. -- CASE construct supported */ #include #include #include #include "ftnchek.h" #include "symtab.h" /* The following section is for use with bison-derived parser. Define alloca to be malloc for those cases not covered by the cases covered there. The ifdefs are those in the skeleton parser with includes removed */ #ifdef AIXC /* IBM RS/6000 xlc compiler does it this way */ #pragma alloca #endif #ifndef alloca #ifdef __GNUC__ #else /* Not GNU C. */ #if (!defined (__STDC__) && defined (sparc)) || defined (__sparc__) #else /* Not sparc */ #ifdef MSDOS #endif /* MSDOS */ #endif /* Not sparc. */ #endif /* Not GNU C. */ #define alloca malloc #endif /* alloca now defined. */ #ifndef YYDEBUG /* If not declared otherwise... */ int yydebug; /* declare yydebug to satisfy extern in ftnchek.c */ #ifdef DEVELOPMENT #define YYDEBUG 1 /* For development it is handy */ #else #define YYDEBUG 0 #endif #endif #ifdef DEVELOPMENT #define DEBUG_PARSER #endif PRIVATE int current_datatype, /* set when parse type_name or type_stmt */ current_size_is_adjustable, /* set in CHARACTER declarations */ current_size_is_expression, /* set in CHARACTER declarations */ current_save_attr, /* set if SAVE attribute given in type decl */ current_external_attr, /* set if EXTERNAL attr given */ current_intrinsic_attr, /* set if INTRINSIC attr given */ current_parameter_attr, /* set if PARAMETER attr given */ current_pointer_attr, /* set if POINTER attr given */ current_target_attr, /* set if TARGET attr given */ current_allocatable_attr, /* set if ALLOCATABLE attr given */ label_dummy_arg_count, /* number of labels in dummy argument list */ len_selector_given, /* flag for use in processing CHARACTER decls */ len_spec_item_count,/* count of items in CHARACTER len-selector list */ control_item_count; /* count of items in control_info_list */ PRIVATE Token *current_dim_bound_list; /* attr-based dim bound tokenlist */ /* Information about the current I/O statement */ int current_io_unit_id; /* hashnum of unit id of current I/O operation */ int current_io_unit_no; /* unit number of current I/O operation */ IO_ACCESS_TYPE current_io_access;/* access mode (direct/sequential) */ IO_FORM_TYPE current_io_form; /* form (formatted/unformatted) */ int io_internal_file, /* Flag for catching misuse of internal files */ io_list_directed, /* Flag for use in processing io control lists */ io_warning_given; /* to prevent multiple warnings */ /* Flag shared with forlex for lexing hints */ int stmt_sequence_no, /* set when parsing, reset to 0 at end_stmt */ f90_stmt_sequence_no; PRIVATE long current_typesize; /* for type*len declarations: value of len */ PRIVATE char *current_len_text; /* for type*len declarations: text of len */ PRIVATE int kind_warning_given=FALSE; /* to say "not interpreted" only once */ PRIVATE Token save_token, /* Holds token shared by productions */ len_spec_token, /* Holds character length spec temporarily */ dim_bound_token; /* Holds attr-based dim-bound list header */ extern LINENO_t prev_stmt_line_num; /* shared with advance */ LINENO_t true_prev_stmt_line_num; /* shared with symtab.c */ PRIVATE int current_module_type, executable_stmt=FALSE, prev_stmt_class=0, /* flags for lexer */ labeled_stmt_type, /* for label handling */ if_line_num, if_col_num, /* for picky construct-usage warnings */ prev_goto=FALSE, goto_flag=FALSE; /* if unconditional GOTO was encountered */ int complex_const_allowed=FALSE, /* for help in lookahead for these */ construct_name_seen=FALSE, /* for help recognizing DO */ param_noparen=FALSE, /* for different PARAMETER stmt semantics */ in_assignment_stmt=FALSE, in_attrbased_typedecl=FALSE,/* help is_keyword lex type, attr :: list */ inside_format=FALSE, /* when inside parens of FORMAT */ integer_context=FALSE; /* says integers-only are to follow */ /* Macro for initializing attributes of type decl. */ #define reset_type_attrs() (\ current_save_attr = FALSE, \ current_external_attr = FALSE, \ current_intrinsic_attr = FALSE, \ current_parameter_attr = FALSE, \ current_pointer_attr = FALSE, \ current_target_attr = FALSE, \ current_allocatable_attr = FALSE, \ current_dim_bound_list = NULL ) /* Define stuff for checking block nesting */ #define MAX_BLOCK_DEPTH 100 /* maximum depth of nesting blocks */ /* USE_YYTNAME allows messages to incorporate token names from the yytname array. This option should be enabled if bison is used to generate parser, not otherwise. Enabling it also assumes fortran.c has been edited to remove "tok_" from token names (see Makefile). */ #ifndef NO_YYTNAME #if defined( YYDEBUG ) && defined( YYBISON ) #define USE_YYTNAME #endif #endif /* Convenience typedef for category of block */ typedef enum {subprog, construct} BLOCK_TYPE; typedef struct { int sclass; /* stmt_class of block opener */ char *name; /* name of block or subprogram */ LABEL_t label; /* label of closing statement for DO */ LINENO_t first_line; /* line number of block opener */ BLOCK_TYPE blocktype; /* category for wording of warnings */ int do_var_hash; /* hash index for index variable of DO block */ } BlockStack; PRIVATE BlockStack block_stack[MAX_BLOCK_DEPTH]; PRIVATE char * curr_stmt_name; /* subprog or END-subprog name; DO, IF construct name*/ PRIVATE int block_depth=0; /* depth of nesting of current block */ /* Defns of private functions */ PROTO(PRIVATE void push_block,(Token *t, int stmt_class, BLOCK_TYPE blocktype, char *name, LABEL_t label)); PROTO(PRIVATE void pop_block,(Token *t, int stmt_class, char *name, LABEL_t label)); PROTO(PRIVATE void check_construct_name_match,(Token *stmt, char *name)); PROTO(PRIVATE Token * add_tree_node,( Token *node, Token *left, Token *right )); PROTO(PRIVATE Token * append_token,( Token *tlist, Token *t )); PROTO(PRIVATE void check_stmt_sequence,( Token *t, int seq_num )); PROTO(PRIVATE void check_f90_stmt_sequence,( Token *t, int f90_seq_num )); PROTO(PRIVATE void do_binexpr,( Token *l_expr, Token *op, Token *r_expr, Token *result )); PROTO(PRIVATE int do_bounds_type,( Token *t1, Token *t2, Token *t3 )); PROTO(PRIVATE void do_unexpr,( Token *op, Token *expr, Token *result )); PROTO(PRIVATE Token * empty_token,( Token *t )); PROTO(PRIVATE void END_processing,( Token *t )); PROTO(PRIVATE void init_io_ctrl_list,( void )); PROTO(PRIVATE void record_default_io,( void )); PROTO(PRIVATE void process_attrs,(Token *t,Token *dim_bounds)); PROTO(PRIVATE void give_kind_warning,(Token *t)); #ifdef DEBUG_PARSER PROTO(PRIVATE void print_exprlist,( char *s, Token *t )); PROTO(PRIVATE void print_comlist,( char *s, Token *t )); #endif /* Uses of Token fields for nonterminals: */ /* NOTE: As of Aug 1994 these are undergoing revision to separate the use of class, subclass fields */ /* 1. dim_bound_lists: dimensioning info for arrays: token.class = no. of dimensions, --> TOK_dims token.subclass = no. of elements --> TOK_elts 2. expressions token.value.integer = hash index (of identifier) token.TOK_type = type_byte = storage_class << 4 + datatype token.TOK_flags: CONST_EXPR, LVALUE_EXPR, etc. token.TOK_flags: COMMA_FLAG used to handle extra/missing commas 4. substring_interval token.class = start index --> TOK_start token.subclass = end index --> TOK_end */ %} %token tok_identifier %token tok_array_identifier %token tok_label %token tok_integer_const %token tok_real_const %token tok_dp_const %token tok_quad_const %token tok_complex_const %token tok_dcomplex_const %token tok_logical_const %token tok_string %token tok_hollerith %token tok_edit_descriptor %token tok_letter %token tok_relop /* .EQ. .NE. .LT. .LE. .GT. .GE. */ %token tok_AND %token tok_OR %token tok_EQV %token tok_NEQV %token tok_NOT %token tok_power /* ** */ %token tok_concat /* // */ %token tok_lparen /* special left paren to avoid s/r conflicts */ %token tok_pointer_assignment /* => */ %token tok_ACCEPT %token tok_ALLOCATABLE %token tok_ALLOCATE %token tok_ASSIGN %token tok_BACKSPACE %token tok_BLOCKDATA %token tok_BYTE %token tok_CALL %token tok_CASE %token tok_CASEDEFAULT %token tok_CHARACTER %token tok_CLOSE %token tok_COMMON %token tok_COMPLEX %token tok_CONTINUE %token tok_CYCLE %token tok_DATA %token tok_DEALLOCATE %token tok_DIMENSION %token tok_DO %token tok_DOUBLECOMPLEX %token tok_DOUBLEPRECISION %token tok_DOWHILE %token tok_ELSE %token tok_END %token tok_ENDBLOCKDATA %token tok_ENDDO %token tok_ENDFILE %token tok_ENDFUNCTION %token tok_ENDIF %token tok_ENDPROGRAM %token tok_ENDSELECT %token tok_ENDSUBROUTINE %token tok_ENTRY %token tok_EQUIVALENCE %token tok_EXTERNAL %token tok_EXIT %token tok_FORMAT %token tok_FUNCTION %token tok_GOTO %token tok_IF %token tok_IMPLICIT %token tok_INCLUDE %token tok_INQUIRE %token tok_INTEGER %token tok_INTRINSIC %token tok_LOGICAL %token tok_NAMELIST %token tok_NONE %token tok_NULLIFY %token tok_OPEN %token tok_PARAMETER %token tok_PAUSE %token tok_POINTER %token tok_PRINT %token tok_PROGRAM %token tok_READ %token tok_REAL %token tok_RETURN %token tok_REWIND %token tok_SAVE %token tok_SELECTCASE %token tok_STOP %token tok_SUBROUTINE %token tok_TARGET %token tok_THEN %token tok_TO %token tok_TYPE %token tok_WHILE %token tok_WRITE %token tok_illegal /* Illegal token unused in grammar: induces syntax error */ %token tok_empty /* For empty tokens used to fill gaps in expr trees */ %token EOS 127 /* Character for end of statement. */ %nonassoc tok_relop %left REDUCE ')' /* Used at unit_io to force a reduction */ %% /* The following grammar is based on the ANSI manual, diagrams * of section F. Numbers in the comments refer to the diagram * corresponding to the grammar rule. */ /* 1-5 */ prog_body : stmt_list | /* empty file */ ; stmt_list : stmt_list_item | stmt_list stmt_list_item ; stmt_list_item : ordinary_stmt { /* Create id token for prog if unnamed. NOTE: this clobbers $1.class, value, src_text. */ if(current_module_hash == -1) { implied_id_token(&($1),unnamed_prog); def_function( type_PROGRAM, /* type */ size_DEFAULT, /* size */ (char *)NULL, /* size text */ &($1), /* name */ (Token*)NULL); /* args */ current_module_hash = def_curr_module(&($1)); current_module_type = type_PROGRAM; /* Pretend this is a PROGRAM statement */ if(style_req_prog_stmt) { warning($1.line_num,$1.col_num, "Program does not start with a PROGRAM statement"); } push_block(&($$),tok_PROGRAM,subprog, hashtab[current_module_hash].name, NO_LABEL); /* It is possible for a block construct to be the initial statement, and if so it has earlier been pushed onto stack. Detect this situation and swap stack entries to make them nest correctly. */ if(block_depth > 1 && block_stack[block_depth-2].first_line == $1.line_num) { BlockStack temp = block_stack[block_depth-1]; block_stack[block_depth-1] = block_stack[block_depth-2]; block_stack[block_depth-2] = temp; } } /* Handle END statement. Note that curr_stmt_class of structured END stmts have been merged into tok_END. */ if(curr_stmt_class == tok_END) { if(prev_stmt_class != tok_RETURN) (void)do_RETURN(current_module_hash,&($1)); pop_block(&($$),$$.tclass, curr_stmt_name,NO_LABEL); END_processing(&($$)); goto_flag = prev_goto = FALSE; } prev_stmt_class = curr_stmt_class; integer_context = FALSE; in_attrbased_typedecl = FALSE; true_prev_stmt_line_num = $$.line_num; } | include_stmt | EOS /* "sticky" EOF for needed delay */ ; /* Statements: note that ordering by category of statement is not enforced in the grammar but is deferred to semantic processing. */ ordinary_stmt : stmt | end_stmt { /* Treat END PROGRAM et al as plain END */ curr_stmt_class = tok_END; } ; stmt : tok_label unlabeled_stmt { /* Put definition of label into table, and if it marks end of a DO range, pop block. */ int do_label = def_label(&($1),labeled_stmt_type); if( do_label || $2.tclass == tok_ENDDO ) { if(is_true(NOT_DO_TERMINAL_STMT,$2.TOK_flags)) { syntax_error($2.line_num,$2.col_num, "statement cannot be terminal statement of a DO loop"); } else { pop_block(&($2),$2.tclass,curr_stmt_name, do_label? (LABEL_t)($1.value.integer): NO_LABEL); } } /* Issue picky warnings about labeled statements. FORMAT has an excuse for existing, so warnings for it are separately controlled. */ if( style_labeled_exec && curr_stmt_class != tok_FORMAT ) { warning($1.line_num,$1.col_num, "obsolescent feature: labeled statement"); } else if( style_labeled_format && curr_stmt_class == tok_FORMAT ) { warning($2.line_num,$2.col_num, "obsolescent feature: FORMAT statement"); } if(executable_stmt) prev_goto = goto_flag; $$ = $2; } | unlabeled_stmt { if(executable_stmt) { if(prev_goto) syntax_error($1.line_num, NO_COL_NUM, "No path to this statement"); prev_goto = goto_flag; } if( curr_stmt_class == tok_FORMAT && misc_warn ) { syntax_error($1.line_num,$1.col_num, "FORMAT statement has no label"); } if( $1.tclass == tok_ENDDO ) pop_block(&($1),$1.tclass,curr_stmt_name,NO_LABEL); } ; unlabeled_stmt : subprogram_header { exec_stmt_count = 0; executable_stmt = FALSE; labeled_stmt_type = LAB_SPECIFICATION; push_block(&($1),$1.tclass,subprog, hashtab[current_module_hash].name, NO_LABEL); } | specification_stmt { executable_stmt = FALSE; /* labeled_stmt_type set in lower productions */ } | executable_stmt { /* handle statement functions correctly */ if(is_true(STMT_FUNCTION_EXPR, $1.TOK_flags) && stmt_sequence_no <= SEQ_STMT_FUN) { stmt_sequence_no = SEQ_STMT_FUN; f90_stmt_sequence_no = F90_SEQ_SPECIF; executable_stmt = FALSE; } else { stmt_sequence_no = SEQ_EXEC; f90_stmt_sequence_no = F90_SEQ_EXEC; ++exec_stmt_count; executable_stmt = TRUE; } labeled_stmt_type = LAB_EXECUTABLE; } | restricted_stmt { stmt_sequence_no = SEQ_EXEC; f90_stmt_sequence_no = F90_SEQ_EXEC; ++exec_stmt_count; executable_stmt = TRUE; labeled_stmt_type = LAB_EXECUTABLE; } | error EOS { executable_stmt = TRUE; if(stmt_sequence_no == 0) stmt_sequence_no = SEQ_HEADER; if(f90_stmt_sequence_no == 0) f90_stmt_sequence_no = SEQ_HEADER; complex_const_allowed = FALSE; /* turn off flags */ inside_format=FALSE; integer_context = FALSE; in_assignment_stmt = FALSE; $$.line_num = prev_stmt_line_num; /* best guess */ labeled_stmt_type = LAB_EXECUTABLE; yyerrok; /* (error message already given) */ } ; subprogram_header: prog_stmt { current_module_type = type_PROGRAM; } | function_stmt { current_module_type = type_SUBROUTINE; } | subroutine_stmt { current_module_type = type_SUBROUTINE; } | block_data_stmt { current_module_type = type_BLOCK_DATA; } ; end_stmt : unlabeled_end_stmt | tok_label unlabeled_end_stmt { if( def_label(&($1),LAB_EXECUTABLE) ) { syntax_error($2.line_num,$2.col_num, "statement cannot be terminal statement of a DO loop"); /* Pop it anyway to keep stack consistent */ pop_block(&($2),$2.tclass,curr_stmt_name, (LABEL_t)($1.value.integer)); } $$ = $2; } ; /* Various END statements not checked for balance */ unlabeled_end_stmt: unnamed_end_stmt { curr_stmt_name = NULL; } | named_end_stmt ; unnamed_end_stmt: tok_END EOS | end_subprog_token EOS ; named_end_stmt: end_subprog_token symbolic_name EOS { curr_stmt_name = hashtab[$2.value.integer].name; } ; end_subprog_token: tok_ENDBLOCKDATA | tok_ENDFUNCTION | tok_ENDPROGRAM | tok_ENDSUBROUTINE ; include_stmt : tok_INCLUDE tok_string EOS { #ifdef ALLOW_INCLUDE if(f77_include) { nonstandard($1.line_num,$1.col_num,0,0); } open_include_file($2.value.string,$1.line_num); #else syntax_error($1.line_num,$1.col_num, "statement not permitted"); #endif } ; /* 5,6 */ /* Note that stmt_function_stmt is not distinguished from assignment_stmt, but assign (label to variable) is. Also, format_stmt w/o label is accepted here. ANSI standard for statement sequencing is enforced here. */ specification_stmt: anywhere_stmt { if(stmt_sequence_no < SEQ_IMPLICIT) { stmt_sequence_no = SEQ_IMPLICIT; } if(f90_stmt_sequence_no < F90_SEQ_IMPLICIT_NONE) { stmt_sequence_no = F90_SEQ_IMPLICIT_NONE; } /* labeled_stmt_type set below */ } | parameter_stmt { if(stmt_sequence_no < SEQ_IMPLICIT) { stmt_sequence_no = SEQ_IMPLICIT; } else if(stmt_sequence_no > SEQ_SPECIF) { check_stmt_sequence(&($1),SEQ_SPECIF); } if(f90_stmt_sequence_no < F90_SEQ_IMPLICIT) { f90_stmt_sequence_no = F90_SEQ_IMPLICIT; } else if(f90_stmt_sequence_no > F90_SEQ_SPECIF) { check_f90_stmt_sequence(&($1),F90_SEQ_SPECIF); } labeled_stmt_type = LAB_SPECIFICATION; } | implicit_stmt { check_stmt_sequence(&($1),SEQ_IMPLICIT); /* f90 seq checks done at implicit_stmt */ labeled_stmt_type = LAB_SPECIFICATION; } | data_stmt { if(stmt_sequence_no < SEQ_STMT_FUN) { stmt_sequence_no = SEQ_STMT_FUN; } if(f90_stmt_sequence_no <= F90_SEQ_SPECIF) { f90_stmt_sequence_no = F90_SEQ_SPECIF; } else { check_f90_stmt_sequence(&($1),F90_SEQ_EXEC); } labeled_stmt_type = LAB_SPECIFICATION; } | specif_stmt { check_stmt_sequence(&($1),SEQ_SPECIF); check_f90_stmt_sequence(&($1),F90_SEQ_SPECIF); labeled_stmt_type = LAB_SPECIFICATION; } ; anywhere_stmt : entry_stmt { goto_flag = prev_goto = FALSE; labeled_stmt_type = LAB_SPECIFICATION; } | format_stmt { labeled_stmt_type = LAB_FORMAT; } ; specif_stmt : dimension_stmt | equivalence_stmt | common_stmt | namelist_stmt | type_stmt | attrbased_type_stmt | external_stmt | intrinsic_stmt | save_stmt | cray_pointer_stmt | pointer_stmt | target_stmt | allocatable_stmt ; /* 7 */ executable_stmt: /* Allowed in logical IF */ transfer_stmt { goto_flag=TRUE; make_true(NOT_DO_TERMINAL_STMT,$$.TOK_flags); } | nontransfer_stmt { goto_flag=FALSE; } ; transfer_stmt : unconditional_goto | assigned_goto { if( f95_assign ) { nonstandard($1.line_num,$1.col_num,0,f95_assign); msg_tail(": assigned GOTO"); } } | arithmetic_if_stmt { if(style_req_block_if) { warning(if_line_num, if_col_num, "non-structured IF statement"); } } | cycle_or_exit_stmt { check_construct_name_match(&($1), curr_stmt_name); } | stop_stmt | return_stmt ; nontransfer_stmt: assignment_stmt | assign_stmt | call_stmt | computed_goto /* fallthru allowed */ | continue_stmt | pause_stmt | io_stmt { record_io_usage(&($1)); } | allocate_stmt | deallocate_stmt | nullify_stmt ; io_stmt: read_stmt { /* If form not defined by now, READ is unformatted. If no REC=num was seen, then it is sequential. */ if(current_io_form == IO_FORM_DEFAULT) current_io_form = IO_FORM_UNFORMATTED; if(current_io_access == IO_ACCESS_DEFAULT) current_io_access = IO_ACCESS_SEQUENTIAL; } | accept_stmt | write_stmt { if(current_io_form == IO_FORM_DEFAULT) current_io_form = IO_FORM_UNFORMATTED; if(current_io_access == IO_ACCESS_DEFAULT) current_io_access = IO_ACCESS_SEQUENTIAL; } | print_stmt | type_output_stmt | open_stmt { /* In OPEN, default ACCESS is SEQUENTIAL, and default FORM is FORMATTED for ACCESS=SEQUENTIAL, UNFORMATTED for ACCESS=DIRECT. */ if(current_io_access == IO_ACCESS_DEFAULT) current_io_access = IO_ACCESS_SEQUENTIAL; if(current_io_form == IO_FORM_DEFAULT) { if(current_io_access == IO_ACCESS_SEQUENTIAL) current_io_form = IO_FORM_FORMATTED; else current_io_form = IO_FORM_UNFORMATTED; } } | close_stmt | inquire_stmt | io_positioning_stmt { /* These statements only apply to sequential access */ current_io_access = IO_ACCESS_SEQUENTIAL; } ; io_positioning_stmt: rewind_stmt | backspace_stmt | endfile_stmt ; restricted_stmt: /* Disallowed in logical IF */ restricted_nontransfer_stmt { goto_flag=FALSE; } | else_or_endif_stmt { prev_goto = goto_flag = FALSE; make_true(NOT_DO_TERMINAL_STMT,$$.TOK_flags); } | select_case_stmt { goto_flag = TRUE; make_true(NOT_DO_TERMINAL_STMT,$$.TOK_flags); } | case_or_endselect_stmt { prev_goto = goto_flag = FALSE; make_true(NOT_DO_TERMINAL_STMT,$$.TOK_flags); } ; restricted_nontransfer_stmt: logical_if_stmt | block_if_stmt { /* Note that $1 at this point is expr, not tok_IF. This is undesirable for our purpose here, but needed for more important stuff elsewhere. */ push_block(&($1),tok_IF,construct,curr_stmt_name,NO_LABEL); make_true(NOT_DO_TERMINAL_STMT,$$.TOK_flags); } | do_stmt { /* Flag DO w/o label or DO WHILE forms here */ if(is_true(NONSTD_USAGE_FLAG,$1.TOK_flags)) #ifdef ALLOW_DO_ENDDO if(f77_do_enddo) nonstandard($1.line_num,$1.col_num,0,0); #else syntax_error($1.line_num,$1.col_num, "Nonstandard syntax"); #endif push_block(&($1),tok_DO,construct,curr_stmt_name, (LABEL_t)($1.tsubclass)); make_true(NOT_DO_TERMINAL_STMT,$$.TOK_flags); /* Record hash index of DO variable in the block stack entry for this statement. */ block_stack[block_depth-1].do_var_hash = $1.value.integer; } | enddo_stmt { #ifdef ALLOW_DO_ENDDO if(f77_do_enddo) nonstandard($1.line_num,$1.col_num,0,0); #else syntax_error($1.line_num,$1.col_num, "Nonstandard syntax"); #endif /* pop_block is done at stmt production, where optional label can be checked for match. */ } ; else_or_endif_stmt: else_if_stmt { pop_block(&($1),$1.tclass,curr_stmt_name,NO_LABEL); push_block(&($1),$1.tclass,construct,curr_stmt_name,NO_LABEL); } | else_stmt { pop_block(&($1),$1.tclass,curr_stmt_name,NO_LABEL); push_block(&($1),$1.tclass,construct,curr_stmt_name,NO_LABEL); } | end_if_stmt { pop_block(&($1),$1.tclass,curr_stmt_name,NO_LABEL); } ; case_or_endselect_stmt: case_stmt { pop_block(&($1),$1.tclass,curr_stmt_name,NO_LABEL); push_block(&($1),$1.tclass,construct,curr_stmt_name,NO_LABEL); } | case_default_stmt { pop_block(&($1),tok_CASE,curr_stmt_name,NO_LABEL); push_block(&($1),tok_CASE,construct,curr_stmt_name,NO_LABEL); } | end_select_stmt { pop_block(&($1),$1.tclass,curr_stmt_name,NO_LABEL); } ; /* 8 */ prog_stmt : tok_PROGRAM {check_seq_header(&($1));} symbolic_name EOS { def_function( type_PROGRAM, /* type */ size_DEFAULT, /* size */ (char *)NULL, /* size text */ &($3), /* name */ (Token*)NULL);/* args */ current_module_hash = def_curr_module(&($3)); } ; /* Note that function & subroutine entry not * distinguished in this grammar. */ /* 9 */ entry_stmt : tok_ENTRY symbolic_name EOS { do_ENTRY(&($2),(Token*)NULL ,current_module_hash); } | tok_ENTRY symbolic_name '(' dummy_argument_list ')' EOS { do_ENTRY(&($2),&($4) ,current_module_hash); #ifdef DEBUG_PARSER if(debug_parser) print_exprlist("entry stmt",&($4)); #endif } ; /* 10 */ function_stmt : unlabeled_function_stmt ; unlabeled_function_stmt : typed_function_handle symbolic_name EOS { if(f77_function_noparen || f90_function_noparen) { nonstandard($2.line_num, (unsigned)($2.col_num+strlen(token_name(&$2))), f90_function_noparen,0); msg_tail(": parentheses required"); } def_function( current_datatype, current_typesize, current_len_text, &($2), (Token*)NULL); current_module_hash= def_curr_module(&($2)); } | typed_function_handle symbolic_name '(' dummy_argument_list ')' EOS { def_function( current_datatype, current_typesize, current_len_text, &($2), &($4)); current_module_hash= def_curr_module(&($2)); #ifdef DEBUG_PARSER if(debug_parser) print_exprlist("function stmt",&($4)); #endif } | plain_function_handle symbolic_name EOS { if(f77_function_noparen || f90_function_noparen) { nonstandard($2.line_num, (unsigned)($2.col_num+strlen(token_name(&$2))), f90_function_noparen,0); msg_tail(": parentheses required"); } def_function( type_UNDECL, size_DEFAULT, (char *)NULL, &($2), (Token*)NULL); current_module_hash= def_curr_module(&($2)); } | plain_function_handle symbolic_name '(' dummy_argument_list ')' EOS { def_function( type_UNDECL, /* type */ size_DEFAULT, /* size */ (char *)NULL, /* size text */ &($2), /* name */ &($4)); /* args */ current_module_hash= def_curr_module(&($2)); #ifdef DEBUG_PARSER if(debug_parser) print_exprlist("function stmt",&($4)); #endif } ; typed_function_handle: type_name function_keyword { $$ = $2; /* needed for block opener info */ } ; plain_function_handle: function_keyword ; function_keyword: tok_FUNCTION { check_seq_header(&($1)); } ; type_name : arith_type_name | plain_char_type_name | char_type_name ; /* 11 not present: see 9 */ /* 12 */ subroutine_stmt : unlabeled_subroutine_stmt ; unlabeled_subroutine_stmt : subroutine_handle symbolic_name EOS { def_function( type_SUBROUTINE, size_DEFAULT, (char *)NULL, &($2), (Token*)NULL); current_module_hash= def_curr_module(&($2)); } | subroutine_handle symbolic_name '(' dummy_argument_list ')' EOS { def_function( type_SUBROUTINE, size_DEFAULT, (char *)NULL, &($2), &($4)); current_module_hash= def_curr_module(&($2)); #ifdef DEBUG_PARSER if(debug_parser) print_exprlist("subroutine stmt",&($4)); #endif } ; subroutine_handle: tok_SUBROUTINE { check_seq_header(&($1)); } ; dummy_argument_list: /* empty */ { $$.next_token = (Token*)NULL; } | non_empty_arg_list ; non_empty_arg_list: dummy_argument { $$.next_token = append_token((Token*)NULL,&($1)); } | non_empty_arg_list ',' dummy_argument { $$.next_token = append_token($1.next_token,&($3)); } ; dummy_argument : symbolic_name { def_arg_name(&($1)); primary_id_expr(&($1),&($$)); } | '*' { $$.TOK_type = type_byte(class_LABEL,type_LABEL); $$.size = size_DEFAULT; $$.TOK_flags = 0; $$.left_token = (Token *)NULL; label_dummy_arg_count++; } ; /* 13 not present: see 9 */ /* 14 */ block_data_stmt : block_data_handle EOS { /* form name %DATnn */ ++block_data_number; (void)sprintf(unnamed_block_data+4,"%02d", block_data_number%100); implied_id_token(&($1),unnamed_block_data); def_function( type_BLOCK_DATA, size_DEFAULT, (char *)NULL, &($1), (Token*)NULL); current_module_hash= def_curr_module(&($1)); } | block_data_handle symbolic_name EOS { def_function( type_BLOCK_DATA, size_DEFAULT, (char *)NULL, &($2), (Token*)NULL); current_module_hash= def_curr_module(&($2)); } ; block_data_handle: tok_BLOCKDATA { check_seq_header(&($1)); } ; /* 15 */ dimension_stmt : tok_DIMENSION array_declarator_list EOS ; array_declarator_list: array_declarator | array_declarator_list ',' array_declarator ; /* 16 */ array_declarator: symbolic_name '(' dim_bound_list ')' { def_array_dim(&($1),&($3)); } ; dim_bound_list : dim_bound_item /* token class = no. of dimensions, subclass = no. of elements */ { $$.TOK_dims = 1; $$.TOK_elts = $1.TOK_elts; $$.next_token = append_token((Token*)NULL,&($1)); } | dim_bound_list ',' dim_bound_item { $$.TOK_dims = $1.TOK_dims + 1; /* one more dimension */ $$.TOK_elts = $1.TOK_elts * $3.TOK_elts; $$.next_token = append_token($1.next_token,&($3)); } ; dim_bound_item : dim_bound_expr { if( datatype_of($1.TOK_type) == type_INTEGER && is_true(EVALUATED_EXPR,$1.TOK_flags) ) $$.TOK_elts = $1.value.integer; else $$.TOK_elts = 0; } | dim_bound_expr ':' dim_bound_expr { /* avoid getting 0 - 0 + 1 = 1 if bounds nonconstant */ if( datatype_of($1.TOK_type) == type_INTEGER && is_true(EVALUATED_EXPR,$1.TOK_flags) && datatype_of($3.TOK_type) == type_INTEGER && is_true(EVALUATED_EXPR,$3.TOK_flags) ) $$.TOK_elts = $3.value.integer - $1.value.integer + 1; else $$.TOK_elts = 0; $$.left_token = add_tree_node(&($2),&($1),&($3)); } | '*' { $$.TOK_elts = 0; $$.left_token = (Token *)NULL; } | dim_bound_expr ':' '*' { $$.TOK_elts = 0; $3.left_token = (Token *)NULL; $$.left_token = add_tree_node(&($2),&($1),&($3)); } | ':' { if( f77_pointers ) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail(": deferred-shape array spec"); } } ; /* 17 */ equivalence_stmt: tok_EQUIVALENCE {equivalence_flag = TRUE;} equivalence_list EOS {equivalence_flag = FALSE;} ; equivalence_list: '(' equivalence_list_item ')' | equivalence_list ',' '(' equivalence_list_item ')' ; equivalence_list_item: equiv_entity ',' equiv_entity { equivalence(&($1), &($3)); } | equivalence_list_item ',' equiv_entity { equivalence(&($1), &($3)); } ; /* 17 */ equiv_entity : symbolic_name { def_equiv_name(&($1)); } | array_equiv_name { def_equiv_name(&($1)); } | substring_equiv_name { def_equiv_name(&($1)); } ; array_equiv_name: symbolic_name '(' subscript_list ')' /* should check */ ; substring_equiv_name: symbolic_name substring_interval | array_equiv_name substring_interval ; /* 19 */ common_stmt : tok_COMMON common_variable_list EOS { implied_id_token(&($$),blank_com_name); def_com_block(&($$), &($2)); if(is_true(COMMA_FLAG,$2.TOK_flags)) syntax_error( $2.line_num,$2.col_num, "trailing comma"); #ifdef DEBUG_PARSER if(debug_parser) print_comlist("blank common",&($2)); #endif } | tok_COMMON common_block_list EOS { if(is_true(COMMA_FLAG,$2.TOK_flags)) syntax_error( $2.line_num,$2.col_num, "trailing comma"); } | tok_COMMON common_variable_list common_block_list EOS { implied_id_token(&($$),blank_com_name); def_com_block(&($$),&($2)); if(is_true(COMMA_FLAG,$3.TOK_flags)) syntax_error( $3.line_num,$3.col_num, "trailing comma"); #ifdef DEBUG_PARSER if(debug_parser) print_comlist("blank common",&($2)); #endif } ; /* The following defns allow trailing commas and missing commas in order to tolerate the optional comma before /blockname/. The token TOK_flags holds comma status to allow errors to be caught. */ common_block_list: labeled_common_block { $$.TOK_flags = $1.TOK_flags; } | common_block_list labeled_common_block { $$.TOK_flags = $2.TOK_flags; $$.line_num = $2.line_num; $$.col_num = $2.col_num; } ; labeled_common_block: common_block_name common_variable_list { def_com_block(&($1),&($2)); $$.TOK_flags = $2.TOK_flags; $$.line_num = $2.line_num; $$.col_num = $2.col_num; #ifdef DEBUG_PARSER if(debug_parser) print_comlist("labeled common",&($2)); #endif } ; common_block_name: '/' symbolic_name '/' { $$ = $2; } | '/' '/' /* block with no name */ { implied_id_token(&($$),blank_com_name); } | tok_concat /* "//" becomes this */ { implied_id_token(&($$),blank_com_name); } ; common_variable_list: common_list_item { $$.TOK_flags = $1.TOK_flags; $$.next_token = append_token((Token*)NULL,&($1)); } | common_variable_list common_list_item { if(!is_true(COMMA_FLAG,$1.TOK_flags)) syntax_error( $2.line_num,$2.col_num-1, "missing comma"); $$.TOK_flags = $2.TOK_flags; $$.line_num = $2.line_num; $$.col_num = $2.col_num; $$.next_token = append_token($1.next_token,&($2)); } ; common_list_item: common_entity { /* no comma */ $$.TOK_flags = $1.TOK_flags; make_false(COMMA_FLAG,$$.TOK_flags); } | common_entity ',' { /* has comma */ $$.TOK_flags = $1.TOK_flags; make_true(COMMA_FLAG,$$.TOK_flags); } ; common_entity : symbolic_name { def_com_variable(&($1)); primary_id_expr(&($1),&($$)); } | array_declarator { def_com_variable(&($1)); primary_id_expr(&($1),&($$)); } ; /* NAMELIST : Not Standard Syntax is: NAMELIST /group/ var [,var...] [[,] /group/ var [,var...]...] */ namelist_stmt : tok_NAMELIST namelist_list EOS { if(is_true(COMMA_FLAG,$2.TOK_flags)) syntax_error($2.line_num, (unsigned)($2.col_num+strlen(token_name(&$2))), "trailing comma"); if(f77_namelist) { nonstandard($1.line_num,$1.col_num,0,0); } } ; namelist_list : namelist_decl | namelist_list namelist_decl { $$ = $2; } ; namelist_decl : namelist_name namelist_var_list { def_namelist(&($1),&($2)); $$ = $2; } ; namelist_name : '/' symbolic_name '/' { $$ = $2; } ; namelist_var_list: namelist_item { $$.next_token = append_token((Token*)NULL,&($1)); } | namelist_var_list namelist_item { if(!is_true(COMMA_FLAG,$1.TOK_flags)) syntax_error( $2.line_num,$2.col_num-1, "missing comma"); $$.TOK_flags = $2.TOK_flags; $$.line_num = $2.line_num; $$.col_num = $2.col_num; $$.next_token = append_token($1.next_token,&($2)); } ; namelist_item : symbolic_name { /* no comma */ def_namelist_item(&($1)); primary_id_expr(&($1),&($$)); make_false(COMMA_FLAG,$$.TOK_flags); } | symbolic_name ',' { /* has comma */ def_namelist_item(&($1)); primary_id_expr(&($1),&($$)); make_true(COMMA_FLAG,$$.TOK_flags); } ; /* 20 */ type_stmt : arith_type_name arith_type_decl_list EOS | plain_char_type_name char_type_decl_list EOS | char_type_name char_type_decl_list EOS | char_type_name ',' char_type_decl_list EOS ; /* Attribute-based type declarations */ attrbased_type_stmt: arith_attrbased_type_handle ':' ':' arith_type_decl_list EOS { if(f77_attrbased_typedecl) { nonstandard($2.line_num, $2.col_num,0,0); msg_tail(": attribute-based variable declaration"); } } | char_attrbased_type_handle ':' ':' char_type_decl_list EOS { if(f77_attrbased_typedecl) { nonstandard($2.line_num, $2.col_num,0,0); msg_tail(": attribute-based variable declaration"); } } ; arith_attrbased_type_handle: arith_type_name | arith_type_name ',' attr_list ; char_attrbased_type_handle: plain_char_type_name | plain_char_type_name ',' attr_list | char_type_name | char_type_name ',' attr_list ; attr_list : type_attr | attr_list ',' type_attr ; type_attr : tok_DIMENSION '(' dim_bound_list ')' { /* turn back on flags turned off by punct */ in_attrbased_typedecl = initial_flag = TRUE; dim_bound_token = $3; /* save copy of header */ current_dim_bound_list = &dim_bound_token; } | tok_SAVE { current_save_attr = TRUE; } | tok_EXTERNAL { current_external_attr = TRUE; } | tok_INTRINSIC { current_intrinsic_attr = TRUE; } | tok_PARAMETER { current_parameter_attr = TRUE; } | tok_POINTER { current_pointer_attr = TRUE; } | tok_TARGET { current_target_attr = TRUE; } | tok_ALLOCATABLE { current_allocatable_attr = TRUE; } ; arith_type_name : sizeable_type_name { current_typesize = size_DEFAULT; current_len_text = NULL; reset_type_attrs(); } /* Allow *len to modify some arith types */ | sizeable_type_name '*' nonzero_unsigned_int_const { current_typesize = $3.value.integer; current_len_text = NULL; reset_type_attrs(); #if 0 /* defunct feature */ if(local_wordsize > 0) { /* recognize REAL*2w as DOUBLE PRECISION */ if(current_datatype == type_REAL && $3.value.integer == type_size[type_DP]) current_datatype = type_DP; /* recognize COMPLEX*4w as DOUBLE COMPLEX */ if(current_datatype == type_COMPLEX && $3.value.integer==type_size[type_DCOMPLEX]) current_datatype = type_DCOMPLEX; } #endif if(f77_typesize || f90_typesize) { nonstandard($3.line_num,$3.col_num,f90_typesize,0); } /* Give hint to lexer to continue taking attrs as keywords despite non-initial position */ if(see_double_colon()) in_attrbased_typedecl = TRUE; } /* Parse KIND selectors although we don't yet support them. */ | sizeable_type_name left_paren kind_selector ')' { /* Treat all KINDs as default */ current_typesize = size_DEFAULT; current_len_text = NULL; reset_type_attrs(); } /* Other type disallow *len modifier */ | unsizeable_type_name { reset_type_attrs(); } ; sizeable_type_name: tok_INTEGER { current_datatype = type_INTEGER; integer_context = TRUE; } | tok_REAL { current_datatype = type_REAL; integer_context = TRUE; } | tok_COMPLEX { current_datatype = type_COMPLEX; integer_context = TRUE; } | tok_LOGICAL { current_datatype = type_LOGICAL; integer_context = TRUE; } ; unsizeable_type_name: tok_DOUBLEPRECISION { current_datatype = type_DP; current_typesize = size_DEFAULT; current_len_text = NULL; reset_type_attrs(); } | tok_DOUBLECOMPLEX { current_datatype = type_DCOMPLEX; current_typesize = size_DEFAULT; current_len_text = NULL; reset_type_attrs(); if(f77_double_complex || f90_double_complex) { nonstandard($1.line_num,$1.col_num,f90_double_complex,0); } } | tok_BYTE /* treate BYTE as a form of integer for now */ { current_datatype = type_INTEGER; current_typesize = 1; current_len_text = NULL; reset_type_attrs(); if(f77_byte || f90_byte) nonstandard($1.line_num,$1.col_num,f90_byte,0); } ; /* When F90 kind intrinsics are supported, expr should become int_constant_expr. For now, keep it lax to avoid spurious warnings. */ kind_selector : expr { if(!kind_warning_given) give_kind_warning(&($1)); if(f77_attrbased_typedecl) { nonstandard($1.line_num, $1.col_num,0,0); msg_tail(": F90-style declaration"); } } | symbolic_name '=' expr { int erroneous=FALSE; if( strcmp(hashtab[$1.value.integer].name,"KIND") == 0 ) { if(!kind_warning_given) give_kind_warning(&($1)); } else { syntax_error($1.line_num,$1.col_num, "unrecognized keyword"); msg_tail(hashtab[$1.value.integer].name); erroneous=TRUE; } if(!erroneous && f77_attrbased_typedecl) { nonstandard($1.line_num, $1.col_num,0,0); msg_tail(": F90-style declaration"); } } ; plain_char_type_name: tok_CHARACTER { current_datatype = type_STRING; current_typesize = 1; current_len_text = NULL; current_size_is_adjustable = 0; current_size_is_expression = 0; reset_type_attrs(); integer_context = TRUE; len_selector_given = FALSE; } ; char_type_name : plain_char_type_name char_selector { current_typesize = $2.value.integer; current_size_is_adjustable = $2.size_is_adjustable; current_size_is_expression = $2.size_is_expression; /* Save length spec text if expression */ if(current_size_is_expression) { if($2.left_token == NULL) current_len_text = new_tree_text(&($2)); else current_len_text = new_tree_text($2.left_token); } else current_len_text = NULL; reset_type_attrs(); /* Give hint to lexer to continue taking attrs as keywords despite non-initial position */ if(see_double_colon()) in_attrbased_typedecl = TRUE; } ; char_selector : '*' len_specification { $$ = $2; } /* This production uses a special left paren to avoid a shift/reduce conflict with IMPLICIT CHARACTER(letter_list) The lexer knows when to produce this special left paren. */ | left_paren {len_spec_item_count = 0;} len_spec_list ')' { if( len_selector_given ) { $$ = len_spec_token; /* Recover spec saved below */ /* Store as a parenthesized expr tree */ $$.left_token = add_tree_node(&($1), &len_spec_token, (Token*)NULL); } /* If len_spec_list does not specify a LEN, use the current default values. */ else { $$.left_token = (Token *)NULL; $$.value.integer = current_typesize; $$.size_is_adjustable = current_size_is_adjustable; $$.size_is_expression = current_size_is_expression; } if(f77_attrbased_typedecl) { nonstandard($1.line_num, $1.col_num,0,0); msg_tail(": F90-style variable declaration"); } } ; /* This production simply turns the special left paren back into a regular paren in case it matters somewhere. The grammar still knows it's special. */ left_paren : tok_lparen { $$.tclass = '('; /* make it a regular paren */ } ; arith_type_decl_list: arith_type_decl_item | arith_type_decl_list ',' arith_type_decl_item ; /* Allow the combined type declaration and data value form. */ arith_type_decl_item: scalar_type_decl_entity { if( current_parameter_attr) { syntax_error($1.line_num,$1.col_num, "PARAMETER lacks initializer"); } } /* Handle bastard initializers (combined type decl and data statement) here. */ | scalar_type_decl_entity '/' {integer_context=FALSE;complex_const_allowed=TRUE;} data_value_list {integer_context=TRUE;complex_const_allowed=FALSE;} '/' { if(f77_initializers || f90_initializers) { nonstandard($2.line_num,$2.col_num, f90_initializers,0); msg_tail(": combined type declaration and data-style initializer"); } primary_id_expr(&($1),&($1)); check_initializer_type(&($1),&($2),&($4)); } /* Handle F90 initializers here. Note that this production will not be reached in non attribute-based type declarations since it will be lexed as an assignment statement. */ | scalar_type_decl_entity {integer_context=FALSE;complex_const_allowed = TRUE;} '=' parameter_expr { if(current_parameter_attr) def_parameter(&($1),&($4),FALSE); else use_lvalue(&($1)); if(f77_initializers) { nonstandard($3.line_num,$3.col_num, 0,0); msg_tail(": F90-style initializer"); } primary_id_expr(&($1),&($1)); check_initializer_type(&($1),&($3),&($4)); integer_context=TRUE; complex_const_allowed = FALSE; } /* Note: array initializers not supported since syntax for array constructors is not yet implemented. */ | array_declarator { declare_type(&($1), current_datatype, current_typesize, current_len_text); process_attrs(&($1),(Token *)NULL); } /* Handle bastard initializers here. Not checked for assignment compatibility. */ | array_declarator '/' {integer_context=FALSE;complex_const_allowed=TRUE;} data_value_list {integer_context=TRUE;complex_const_allowed=FALSE;} '/' { declare_type(&($1), current_datatype, current_typesize, current_len_text); process_attrs(&($1),(Token *)NULL); if(f77_initializers || f90_initializers) { nonstandard($2.line_num,$2.col_num, f90_initializers,0); msg_tail(": combined type declaration and data-style initializer"); } use_lvalue(&($1)); primary_id_expr(&($1),&($1)); check_initializer_type(&($1),&($2),&($4)); } ; scalar_type_decl_entity:symbolic_name { declare_type(&($1), current_datatype, current_typesize, current_len_text); process_attrs(&($1),current_dim_bound_list); } ; char_type_decl_list: char_type_decl_item | char_type_decl_list ',' char_type_decl_item ; char_type_decl_item: char_type_decl_entity { if( current_parameter_attr) { syntax_error($1.line_num,$1.col_num, "PARAMETER lacks initializer"); } } /* Handle bastard initializers here */ | char_type_decl_entity '/' {integer_context=FALSE;complex_const_allowed=TRUE;} data_value_list {integer_context=TRUE;complex_const_allowed=FALSE;} '/' { if(f77_initializers || f90_initializers) { nonstandard($2.line_num,$2.col_num, f90_initializers,0); msg_tail(": combined type declaration and data-style initializer"); } primary_id_expr(&($1),&($1)); check_initializer_type(&($1),&($2),&($4)); } /* Handle F90 initializers here */ | char_type_decl_entity '=' parameter_expr { if(current_parameter_attr) def_parameter(&($1),&($3),FALSE); else use_lvalue(&($1)); primary_id_expr(&($1),&($1)); if(f77_initializers) { nonstandard($2.line_num,$2.col_num, 0,0); msg_tail(": F90-style initializer"); } check_initializer_type(&($1),&($2),&($3)); } | array_declarator { $1.size_is_adjustable = current_size_is_adjustable; $1.size_is_expression = current_size_is_expression; declare_type(&($1), current_datatype, current_typesize, current_len_text); process_attrs(&($1),(Token *)NULL); } | array_declarator '*' len_specification { $1.size_is_adjustable = $3.size_is_adjustable; $1.size_is_expression = $3.size_is_expression; declare_type(&($1), current_datatype, $3.value.integer, new_tree_text( $3.left_token == NULL? &($3): $3.left_token ) ); process_attrs(&($1),(Token *)NULL); } | array_declarator '/' {integer_context=FALSE;complex_const_allowed=TRUE;} data_value_list {integer_context=TRUE;complex_const_allowed=FALSE;} '/' { $1.size_is_adjustable = current_size_is_adjustable; $1.size_is_expression = current_size_is_expression; declare_type(&($1), current_datatype, current_typesize, current_len_text); process_attrs(&($1),(Token *)NULL); if(f77_initializers || f90_initializers) { nonstandard($2.line_num,$2.col_num, f90_initializers,0); msg_tail(": combined type declaration and data-style initializer"); } use_lvalue(&($1)); } | array_declarator '*' len_specification '/' {integer_context=FALSE;complex_const_allowed=TRUE;} data_value_list {integer_context=TRUE;complex_const_allowed=FALSE;} '/' { $1.size_is_adjustable = $3.size_is_adjustable; $1.size_is_expression = $3.size_is_expression; declare_type(&($1), current_datatype, $3.value.integer, new_tree_text( $3.left_token == NULL? &($3): $3.left_token ) ); process_attrs(&($1),(Token *)NULL); if(f77_initializers || f90_initializers) { nonstandard($4.line_num,$4.col_num, f90_initializers,0); msg_tail(": combined type declaration and data-style initializer"); } use_lvalue(&($1)); } ; char_type_decl_entity:symbolic_name { $1.size_is_adjustable = current_size_is_adjustable; $1.size_is_expression = current_size_is_expression; declare_type(&($1), current_datatype, current_typesize, current_len_text); process_attrs(&($1),current_dim_bound_list); } | symbolic_name '*' len_specification { $1.size_is_adjustable = $3.size_is_adjustable; $1.size_is_expression = $3.size_is_expression; declare_type(&($1), current_datatype, $3.value.integer, new_tree_text( $3.left_token == NULL? &($3): $3.left_token ) ); process_attrs(&($1),current_dim_bound_list); } ; /* 21 */ /* implicit_flag helps is_keyword's work */ implicit_handle : tok_IMPLICIT {implicit_flag=TRUE;} ; implicit_stmt : implicit_handle implicit_decl_list EOS { implicit_flag=FALSE; if(implicit_none) { syntax_error($1.line_num,$1.col_num, "conflicts with IMPLICIT NONE"); } else { implicit_type_given = TRUE; } check_f90_stmt_sequence(&($1),F90_SEQ_IMPLICIT); } /* IMPLICIT NONE statement */ | implicit_handle tok_NONE EOS { implicit_flag=FALSE; if(implicit_type_given) { syntax_error($1.line_num,$1.col_num, "conflicts with IMPLICIT statement"); } else { if(f77_implicit_none) nonstandard($2.line_num,$2.col_num,0,0); implicit_none = TRUE; } check_f90_stmt_sequence(&($1),F90_SEQ_IMPLICIT_NONE); } ; implicit_decl_list: implicit_decl_item | implicit_decl_list ',' {initial_flag = TRUE;} implicit_decl_item ; /* implicit_letter_flag tells lexer to treat letters as letters, not as identifiers */ implicit_decl_item: type_name '(' {implicit_letter_flag = TRUE;} letter_list ')' {implicit_letter_flag = FALSE;} ; letter_list : letter_list_item | letter_list ',' letter_list_item ; letter_list_item: tok_letter { int c1 = (int)$1.tsubclass; /* kluge to allow other non-alpha chars: treate anything except _ as $. */ if( !isalpha(c1) && c1 != '_' ) c1 = '$'; if( ((f77_dollarsigns||f90_dollarsigns) && c1=='$') || (f77_underscores && c1=='_') ) { nonstandard($1.line_num,$1.col_num, f90_dollarsigns&&c1=='$',0); msg_tail(": nonalphabetic character"); } set_implicit_type(current_datatype, current_typesize, current_len_text, c1,c1); } | tok_letter '-' tok_letter { int c1 = (int)$1.tsubclass, c2 = (int)$3.tsubclass; if( !isalpha(c1) && c1 != '_' ) c1 = '$'; if( !isalpha(c2) && c2 != '_' ) c2 = '$'; if( ((f77_dollarsigns||f90_dollarsigns) && (c1 == '$' || c2 == '$')) || (f77_underscores && (c1 == '_' || c2 == '_'))) { if(!isalpha(c1)) nonstandard($1.line_num,$1.col_num, f90_dollarsigns&&(c1=='$'||c2=='$'),0); else nonstandard($3.line_num,$3.col_num, f90_dollarsigns&&(c1=='$'||c2=='$'),0); msg_tail(": nonalphabetic character"); } set_implicit_type(current_datatype, current_typesize, current_len_text, c1,c2); } ; /* 22 */ len_specification: nonneg_unsigned_int_const { $$.value.integer = $1.value.integer; $$.size_is_adjustable = 0; $$.size_is_expression = 0; } | '(' len_spec_expr ')' { $$.value.integer = $2.value.integer; $$.size_is_adjustable = $2.size_is_adjustable; $$.size_is_expression = $2.size_is_expression; /* Store as a parenthesized expr tree */ $$.left_token = add_tree_node(&($1), &($2), (Token*)NULL); } ; /* To keep grammar simple, the syntax rules for CHARACTER length-selector are relaxed, leaving checking to the semantic processing. Legal variations are CHARACTER*(length) CHARACTER*(LEN=length) CHARACTER*(length,kind) CHARACTER*(length,KIND=kind) CHARACTER*(LEN=length,KIND=kind) CHARACTER*(KIND=kind,LEN=length) where length is * or a specification-expr, and kind is a scalar-int-initialization-expr. The * can be omitted in all of these. The grammar rules here accept anything of the form CHARACTER*([KEYWORD=]value[, ...]) where value is * or int_constant_expr. When the LEN keyword is seen, the len_spec_item token is copied to len_spec_token to be used in higher-level productions. */ len_spec_list : len_spec_item { ++len_spec_item_count; } | len_spec_list ',' len_spec_item { ++len_spec_item_count; } ; len_spec_item : len_spec_expr { /* Non-keyword form: 1st item is LEN */ if(len_spec_item_count == 0) { len_spec_token = $1; len_selector_given = TRUE; } /* 2nd item is KIND */ else if(len_spec_item_count == 1) { if(!kind_warning_given) give_kind_warning(&($1)); } else if(len_spec_item_count == 2) { syntax_error($1.line_num,$1.col_num, "too many specifiers in list"); } } | symbolic_name '=' len_spec_expr { int erroneous=FALSE; if( strcmp(hashtab[$1.value.integer].name,"LEN") == 0 ) { len_spec_token = $3; len_selector_given = TRUE; } else if( strcmp(hashtab[$1.value.integer].name,"KIND") == 0 ) { if(!kind_warning_given) give_kind_warning(&($1)); } else { syntax_error($1.line_num,$1.col_num, "unrecognized keyword"); msg_tail(hashtab[$1.value.integer].name); erroneous=TRUE; } if(!erroneous && f77_attrbased_typedecl) { nonstandard($2.line_num, $2.col_num,0,0); msg_tail(": F90-style declaration"); } } ; len_spec_expr : '*' { $$.left_token = (Token *)NULL; $$.value.integer = size_ADJUSTABLE; $$.size_is_adjustable = 1; $$.size_is_expression = 0; } | int_constant_expr { $$.size_is_adjustable = 0; $$.size_is_expression = 1; if($1.value.integer <= 0) { if($1.value.integer < 0) { if(misc_warn || f77_char_extension) { warning($1.line_num,$1.col_num, "non-negative integer value expected"); msg_tail(": substituting 0"); } $$.value.integer = 0; } else if(f77_char_extension) { warning($1.line_num,$1.col_num, "nonzero integer value expected"); } } } ; /* 23 */ parameter_stmt : std_parameter_stmt | parenless_parameter_stmt ; std_parameter_stmt: tok_PARAMETER '(' parameter_defn_list ')' EOS ; parenless_parameter_stmt:tok_PARAMETER {param_noparen=TRUE;} parameter_defn_list {param_noparen=FALSE;} EOS { if(f77_param_noparen || f90_param_noparen) { nonstandard($1.line_num,$1.col_num,f90_param_noparen,0); msg_tail(" : PARAMETER declaration without parentheses"); } } ; parameter_defn_list: parameter_defn_item | parameter_defn_list ',' parameter_defn_item ; parameter_defn_item: symbolic_name {complex_const_allowed = TRUE;} '=' parameter_expr { def_parameter(&($1),&($4),param_noparen); primary_id_expr(&($1),&($1)); check_initializer_type(&($1),&($3),&($4)); complex_const_allowed = FALSE; } ; /* 24 */ external_stmt : tok_EXTERNAL external_name_list EOS ; external_name_list: symbolic_name { def_ext_name(&($1)); } | external_name_list ',' symbolic_name { def_ext_name(&($3)); } ; /* 25 */ intrinsic_stmt : tok_INTRINSIC intrinsic_name_list EOS ; intrinsic_name_list: symbolic_name { def_intrins_name(&($1)); } | intrinsic_name_list ',' symbolic_name { def_intrins_name(&($3)); } ; /* construct for allocatable statement */ allocatable_stmt: tok_ALLOCATABLE attr_decl_list EOS { if( f77_pointers ) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail(": ALLOCATABLE statement"); } } ; /* construct for f90 target statement */ target_stmt : tok_TARGET attr_decl_list EOS { if( f77_pointers ) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail(": TARGET statement"); } } ; /* construct for f90 pointer statement */ pointer_stmt : tok_POINTER attr_decl_list EOS { if( f77_pointers ) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail(": POINTER statement"); } } ; attr_decl_list : attr_decl_item | ':' ':' attr_decl_item | attr_decl_list ',' attr_decl_item ; attr_decl_item : symbolic_name { apply_attr(&($1),curr_stmt_class); } | array_declarator { apply_attr(&($1),curr_stmt_class); } ; /* constructs for nonstd Cray POINTER(pointer=pointee) statement */ cray_pointer_stmt: tok_POINTER cray_pointer_item_list EOS { if(f77_cray_pointers || f90_cray_pointers) { nonstandard($1.line_num,$1.col_num,f90_cray_pointers,0); } } ; cray_pointer_item_list: cray_pointer_item | cray_pointer_item_list ',' cray_pointer_item ; cray_pointer_item: '(' pointer_name ',' pointee_name ')' ; pointer_name : symbolic_name { declare_type(&($1),type_INTEGER,local_ptrsize, NULL ); } ; pointee_name : symbolic_name { /* Suppress set/used warnings since often is accessed only via pointer */ use_lvalue(&($1)); use_variable(&($1)); } | array_declarator { use_lvalue(&($1)); use_variable(&($1)); } ; allocate_stmt : tok_ALLOCATE '(' allocate_item_list ')' EOS { if( f77_pointers ) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail(": ALLOCATE statement"); } } ; deallocate_stmt : tok_DEALLOCATE '(' deallocate_item_list ')' EOS { if( f77_pointers ) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail(": DEALLOCATE statement"); } } ; allocate_item_list: allocate_item | allocate_item_list ',' allocate_item ; allocate_item : variable_name | array_name '(' dim_bound_list ')' | symbolic_name '=' variable_name | symbolic_name '=' array_element_name ; deallocate_item_list: deallocate_item | deallocate_item_list ',' allocate_item ; deallocate_item : variable_name | array_name '(' dim_bound_list ')' | symbolic_name '=' variable_name | symbolic_name '=' array_element_name ; nullify_stmt : tok_NULLIFY '(' variable_name_list ')' EOS { if( f77_pointers ) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail(": NULLIFY statement"); } } ; variable_name_list: variable_name | variable_name_list ',' variable_name ; /* 26 */ save_stmt : tok_SAVE EOS { global_save = TRUE; } | tok_SAVE save_list EOS ; save_list : save_item | save_list ',' save_item ; save_item : symbolic_name { apply_attr(&($1),tok_SAVE); } | '/' symbolic_name '/' { /*** def_com_block(&($2),(Token*)NULL);***/ save_com_block(&($2)); } ; /* 27 */ data_stmt : tok_DATA data_defn_list EOS ; data_defn_list : data_defn_item | data_defn_list data_defn_item | data_defn_list ',' data_defn_item ; data_defn_item : data_defn_assignee_list '/' {complex_const_allowed=TRUE;} data_value_list {complex_const_allowed=FALSE;} '/' ; data_defn_assignee_list : data_defn_assignee | data_defn_assignee_list ',' data_defn_assignee ; data_defn_assignee: lvalue { use_lvalue(&($1)); } | data_implied_do_list ; data_value_list: data_value { $$.next_token = append_token((Token*)NULL,&($1)); } | data_value_list ',' data_value { $$.next_token = append_token($1.next_token,&($3)); } ; data_value : data_constant_value { $$.left_token = (Token*)NULL; } | data_repeat_factor '*' data_constant_value { /* Save data repeat factor in a permanent token pointed to by left_token. */ Token *tcopy = new_token(); *tcopy = $1; /* copy the repeat factor token */ $$ = $3; /* pass data_value up the parse tree */ $$.left_token = tcopy; } ; data_repeat_factor: nonzero_unsigned_int_const | symbolic_name { use_parameter(&($1)); } ; data_constant_value: data_constant | symbolic_name { use_parameter(&($1)); } ; data_dlist : data_dlist_item | data_dlist ',' data_dlist_item ; data_dlist_item : array_element_lvalue { use_lvalue(&($1)); } | data_implied_do_list ; data_implied_do_list: '(' data_dlist ',' symbolic_name '=' data_do_loop_bounds ')' { use_implied_do_index(&($4)); } ; data_do_loop_bounds: int_constant_expr ',' int_constant_expr | int_constant_expr ',' int_constant_expr ',' int_constant_expr ; /* 29 */ assignment_stmt : lvalue assignment_op {complex_const_allowed = TRUE; in_assignment_stmt = TRUE;} expr { if( ! (is_true(LVALUE_EXPR,$1.TOK_flags) || is_true(STMT_FUNCTION_EXPR,$1.TOK_flags) )) { syntax_error($1.line_num,$1.col_num, "left side is not assignable"); if(is_true(CONST_EXPR,$1.TOK_flags)) msg_tail(": it is a constant"); } else { int array_lhs, array_rhs; array_lhs = (($1.TOK_flags&(ARRAY_ID_EXPR|ARRAY_ELEMENT_EXPR)) == ARRAY_ID_EXPR); array_rhs = (($4.TOK_flags&(ARRAY_ID_EXPR|ARRAY_ELEMENT_EXPR)) == ARRAY_ID_EXPR); if( array_lhs || array_rhs ) { if( (! array_lhs) && misc_warn) { warning($1.line_num,$1.col_num, "array assigned to scalar"); } else if( f77_assignment ) { nonstandard($2.line_num,$2.col_num,0,0); msg_tail(": assignment involving whole array"); } } assignment_stmt_type(&($1),&($2), &($4)); } complex_const_allowed = FALSE; in_assignment_stmt = FALSE; } EOS { /* Clear u-b-s flags spuriously set */ if(is_true(STMT_FUNCTION_EXPR, $1.TOK_flags) && stmt_sequence_no <= SEQ_STMT_FUN) stmt_function_stmt(&($1)); } ; lvalue : variable_name | array_element_lvalue | substring_lvalue | stmt_function_handle ; assignment_op : '=' /* normal assignment */ | tok_pointer_assignment /* pointer assignment */ { if( f77_pointers ) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail(": pointer assignment"); } } ; /* array-element_lvalue is at 88 */ assign_stmt : tok_ASSIGN pre_label label tok_TO variable_name EOS { do_ASSIGN(&($5)); if( f95_assign ) { nonstandard($1.line_num,$1.col_num,0,f95_assign); msg_tail(": ASSIGN statement"); } ref_label(&($3),LAB_ASSIGN); } ; /* 31 */ unconditional_goto: goto pre_label label EOS { ref_label(&($3),LAB_GOTO); } ; /* 32 */ computed_goto : goto '(' goto_list ')' integer_expr EOS | goto '(' goto_list ')' ',' integer_expr EOS ; /* 33 */ assigned_goto : goto symbolic_name EOS { do_assigned_GOTO(&($2)); } | goto symbolic_name '(' goto_list ')' EOS { do_assigned_GOTO(&($2)); } | goto symbolic_name ',' '(' goto_list ')' EOS { do_assigned_GOTO(&($2)); } ; goto : tok_GOTO { integer_context=TRUE; /* Warn if GOTO considered harmful */ if( style_goto ) { warning($1.line_num,$1.col_num, "obsolescent feature: GOTO statement"); } } ; goto_list : pre_label label { ref_label(&($2), LAB_GOTO); } | goto_list ',' pre_label label { ref_label(&($4), LAB_GOTO); } ; /* 34 */ arithmetic_if_stmt: if_handle pre_label label ',' pre_label label ',' pre_label label EOS { int t=datatype_of($1.TOK_type); if(t != type_INTEGER && t != type_REAL && t != type_DP && t != type_ERROR ) { syntax_error($1.line_num,$1.col_num, "integer, real, or double precision expression required"); } ref_label(&($3), LAB_GOTO); ref_label(&($6), LAB_GOTO); ref_label(&($9), LAB_GOTO); } ; /* 35 */ logical_if_stmt : if_handle executable_stmt { int t=datatype_of($1.TOK_type); if(t != type_LOGICAL && t != type_ERROR) syntax_error($1.line_num,$1.col_num, "logical expression required"); } ; /* 36 */ block_if_stmt : if_handle tok_THEN EOS { int t=datatype_of($1.TOK_type); if(t != type_LOGICAL && t != type_ERROR) syntax_error($1.line_num,$1.col_num, "logical expression required"); /* In picky mode warn if no name tag on block construct. By this time $1 is the expr, not tok_IF, so line and column must be those saved at lower-level productions. */ if(curr_stmt_name == NULL && style_req_construct_name) { warning(if_line_num,if_col_num, "Construct name missing from IF statement"); } } ; if_handle : f77_if_handle { curr_stmt_name = NULL; } | construct_spec f77_if_handle { if(f77_construct_name) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail(": IF construct name"); } construct_name_seen=FALSE; $$ = $2; } ; f77_if_handle : tok_IF '(' {complex_const_allowed = TRUE;} expr ')' { if(is_true(ID_EXPR,$4.TOK_flags)){ use_variable(&($4)); } complex_const_allowed = FALSE; initial_flag = TRUE; /* for is_keyword */ if_line_num = $1.line_num; /* save location */ if_col_num = $1.col_num; /* for picky warnings */ $$ = $4; /* Inherit expr for type checking above */ } ; /* 37 */ else_if_stmt : tok_ELSE tok_IF '(' {complex_const_allowed = TRUE;} expr ')' { int t=datatype_of($5.TOK_type); if(t != type_LOGICAL && t != type_ERROR) syntax_error($5.line_num,$5.col_num, "logical expression required"); if(is_true(ID_EXPR,$5.TOK_flags)){ use_variable(&($5)); } complex_const_allowed = FALSE; initial_flag = TRUE; } else_if_then ; else_if_then : tok_THEN EOS { curr_stmt_name = NULL; } | tok_THEN construct_name EOS { if(f77_construct_name) { nonstandard($2.line_num,$2.col_num,0,0); msg_tail(": IF construct name"); } } ; /* 38 */ else_stmt : tok_ELSE EOS { curr_stmt_name = NULL; } | tok_ELSE construct_name EOS { if(f77_construct_name) { nonstandard($2.line_num,$2.col_num,0,0); msg_tail(": IF construct name"); } } ; /* 39 */ end_if_stmt : tok_ENDIF EOS { curr_stmt_name = NULL; } | tok_ENDIF construct_name EOS { if(f77_construct_name) { nonstandard($2.line_num,$2.col_num,0,0); msg_tail(": IF construct name"); } } ; /* F90 CASE construct: SELECT CASE ( expr ) [ CASE ( case-value [, case-value ...] ) [ ... ] ] [ CASE DEFAULT [ ... ] ] END SELECT */ select_case_stmt: select_handle '(' {complex_const_allowed = TRUE;} expr ')' EOS { int t = datatype_of ($4.TOK_type); if (t != type_ERROR) { if (!is_const_type(t) || is_float_type(t)) { syntax_error($4.line_num,$4.col_num, "integer, character, or logical expression required"); } } if(is_true(ID_EXPR,$4.TOK_flags)){ use_variable(&($4)); } complex_const_allowed = FALSE; push_block(&($1),$1.tclass,construct,curr_stmt_name,NO_LABEL); } ; select_handle : tok_SELECTCASE { curr_stmt_name = NULL; if (f77_case_construct) { nonstandard($1.line_num,$1.col_num,0,0); } if( style_req_construct_name ) { warning($1.line_num,$1.col_num, "Construct name missing from SELECT statement"); } } | construct_spec tok_SELECTCASE { if (f77_case_construct) { nonstandard($2.line_num,$2.col_num,0,0); } $$ = $2; } ; case_stmt : case_handle EOS | case_handle construct_name EOS ; case_handle : tok_CASE '(' case_values ')' ; case_values : case_value | case_values ',' case_value ; case_value : case_value_primary | case_value_primary ':' case_value_primary { int t1 = datatype_of($1.TOK_type), t2 = datatype_of($3.TOK_type); if (t1 == type_LOGICAL || t2 == type_LOGICAL) { syntax_error($2.line_num,$2.col_num, "ranges of type LOGICAL not allowed here"); } if (t1 != t2) { syntax_error($3.line_num,$3.col_num, "range boundaries must have the same type"); } } | ':' case_value_primary { int t = datatype_of($2.TOK_type); if (t == type_LOGICAL) { syntax_error($2.line_num,$2.col_num, "ranges may not have type LOGICAL bounds"); } } | case_value_primary ':' { int t = datatype_of($2.TOK_type); if (t == type_LOGICAL) { syntax_error($2.line_num,$2.col_num, "ranges may not have type LOGICAL bounds"); } } ; case_value_primary: expr { int t = datatype_of($1.TOK_type); if (t != type_ERROR) { if (!is_const_type(t) || is_float_type(t)) { syntax_error($1.line_num,$1.col_num, "integer, character, or logical expression required"); } } if (!is_true(CONST_EXPR, $1.TOK_flags)) { syntax_error($1.line_num,$1.col_num, "expression must evaluate to a compile-time constant"); } $$ = $1; } ; case_default_stmt: tok_CASEDEFAULT EOS | tok_CASEDEFAULT construct_name EOS ; end_select_stmt : tok_ENDSELECT EOS | tok_ENDSELECT construct_name EOS ; /* 40 */ /* Allow F90 extensions: DO [label [,]] var = expr , expr [,expr] DO [label [,]] WHILE ( expr ) ... ENDDO */ do_stmt : do_handle variable_name '=' do_loop_bounds EOS { if( ! is_true(LVALUE_EXPR,$2.TOK_flags) ) { syntax_error($2.line_num,$2.col_num, "index is not assignable"); if(is_true(CONST_EXPR,$2.TOK_flags)) msg_tail(": it is a constant"); $$.value.integer = -1; /* no hash entry */ } else { def_do_variable(&($2)); /* Store hash index of DO index in token for use when pushing block on stack. The value field is not used by keywords, so it is OK to use it this way. */ $$.value.integer = $2.value.integer; } /* Check for non-integer DO index or bounds */ if(datatype_of($2.TOK_type) == type_INTEGER && datatype_of($4.TOK_type) != type_INTEGER) { if( f95_real_do ) { nonstandard($4.line_num,$4.col_num,0,f95_real_do); msg_tail(": DO loop bounds not integer"); } else if(misc_warn) { warning($3.line_num,$3.col_num, "type mismatch between DO index and bounds"); } } else if(datatype_of($2.TOK_type) != type_INTEGER) { if( f95_real_do ) { nonstandard($2.line_num,$2.col_num,0,f95_real_do); msg_tail(": DO index is not integer"); } else if(datatype_of($4.TOK_type) != type_INTEGER) { if(port_real_do) nonportable($4.line_num,$4.col_num, "non-integer DO loop"); } else { if(trunc_real_do_index) { warning($2.line_num,$2.col_num, "DO index is not integer"); } } } } | tok_DOWHILE '(' {complex_const_allowed=TRUE;} expr ')' EOS { if(is_true(ID_EXPR,$4.TOK_flags)){ use_variable(&($4)); } complex_const_allowed=FALSE; make_true(NONSTD_USAGE_FLAG,$$.TOK_flags); $$.value.integer = -1; /* no DO index */ curr_stmt_name = NULL; } /* Normally, the lexer glues DO WHILE together and yields tok_DOWHILE. The following production is needed, however, for e.g. DO 100 WHILE and constructname : DOWHILE */ | do_handle tok_WHILE '(' {complex_const_allowed=TRUE;} expr ')' EOS { if(is_true(ID_EXPR,$5.TOK_flags)){ use_variable(&($5)); } complex_const_allowed=FALSE; make_true(NONSTD_USAGE_FLAG,$$.TOK_flags); $$.value.integer = -1; /* no DO index */ } | do_handle EOS { make_true(NONSTD_USAGE_FLAG,$$.TOK_flags); $$.value.integer = -1; /* no DO index */ } ; do_handle : f77_do_handle { /* In picky mode warn if no name tag on block construct. */ if( style_req_construct_name ) { warning($1.line_num,$1.col_num, "Construct name missing from DO statement"); } curr_stmt_name = NULL; } | construct_spec f77_do_handle { if(f77_construct_name) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail(": DO construct name"); } construct_name_seen=FALSE; $$ = $2; } ; f77_do_handle : tok_DO pre_label label { ref_label(&($3), LAB_DO); def_do_label(&($3)); /* Save label in subclass for push_block */ $$.tsubclass = $3.value.integer; } | tok_DO pre_label label ',' { ref_label(&($3), LAB_DO); def_do_label(&($3)); $$.tsubclass = $3.value.integer; } | tok_DO pre_label { make_true(NONSTD_USAGE_FLAG,$$.TOK_flags); integer_context=FALSE; $$.tsubclass = (long)NO_LABEL; } ; do_loop_bounds : int_real_dp_expr ',' int_real_dp_expr { $$.TOK_type=do_bounds_type(&($1),&($3),&($3)); } | int_real_dp_expr ',' int_real_dp_expr ',' int_real_dp_expr { $$.TOK_type=do_bounds_type(&($1),&($3),&($5)); } ; enddo_stmt : tok_ENDDO EOS { curr_stmt_name = NULL; } | tok_ENDDO construct_name EOS ; /* 41 */ continue_stmt : tok_CONTINUE EOS ; /* F90 CYCLE and EXIT statements. Note: at this time, the optional do-construct-name is not supported. */ cycle_or_exit_stmt: cycle_stmt { if( f77_cycle_exit ) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail(": CYCLE statement"); } } | exit_stmt { if( f77_cycle_exit ) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail(": EXIT statement"); } } ; cycle_stmt : tok_CYCLE EOS | tok_CYCLE construct_name EOS ; exit_stmt : tok_EXIT EOS | tok_EXIT construct_name EOS ; /* 42 */ stop_stmt : tok_STOP stop_info EOS ; /* 43 */ pause_stmt : tok_PAUSE stop_info EOS { if( f95_pause ) { nonstandard($1.line_num,$1.col_num,0,f95_pause); msg_tail(": PAUSE statement"); } } ; stop_info : /* empty */ | tok_integer_const | symbolic_name { use_variable(&($1)); } | tok_string ; /* 44 */ write_stmt : write_handle {complex_const_allowed = FALSE;} EOS | write_handle io_list {complex_const_allowed = FALSE;} EOS ; write_handle : tok_WRITE {init_io_ctrl_list();} '(' control_info_list ')' {complex_const_allowed = TRUE;} ; /* 45 */ /* Note that parenthesized format_id's will end up in control_info_list. Disambiguation left to semantic phase. This is why we need the optional comma */ read_stmt : read_handle '(' control_info_list ')' EOS | read_handle '(' control_info_list ')' io_list EOS | read_handle '(' control_info_list ')' ',' io_list EOS | read_handle format_id EOS { record_default_io(); } | read_handle format_id ',' io_list EOS { record_default_io(); } ; read_handle : tok_READ {init_io_ctrl_list();} ; accept_stmt : tok_ACCEPT format_id EOS { if(f77_accept_type || f90_accept_type) nonstandard($1.line_num,$1.col_num,f90_accept_type,0); record_default_io(); } | tok_ACCEPT format_id ',' io_list EOS { if(f77_accept_type || f90_accept_type) nonstandard($1.line_num,$1.col_num,f90_accept_type,0); record_default_io(); } ; /* 46 */ print_stmt : tok_PRINT format_id EOS { record_default_io(); } | tok_PRINT format_id ',' {complex_const_allowed = TRUE;} io_list {complex_const_allowed = FALSE;} EOS { record_default_io(); } ; type_output_stmt: tok_TYPE format_id EOS { if(f77_accept_type || f90_accept_type) nonstandard($1.line_num,$1.col_num,f90_accept_type,0); record_default_io(); } | tok_TYPE format_id ',' {complex_const_allowed = TRUE;} io_list {complex_const_allowed = FALSE;} EOS { if(f77_accept_type || f90_accept_type) nonstandard($1.line_num,$1.col_num,f90_accept_type,0); record_default_io(); } ; /* 47 */ control_info_list: control_info_item { ++control_item_count; } | control_info_list ',' control_info_item { ++control_item_count; if(! io_warning_given) { if( io_internal_file ) { if( (curr_stmt_class == tok_WRITE || curr_stmt_class == tok_READ) && io_list_directed ) { if(f77_internal_list_io) { nonstandard($3.line_num,$3.col_num,0,0); msg_tail(": internal file cannot be used with list-directed I/O"); } io_warning_given = TRUE; } } } } ; /* Note that unit id is not distinguished from format id by the grammar. Use sequence no. to tell which is which. */ control_info_item: symbolic_name '=' unit_id { use_io_keyword(&($1),&($3),curr_stmt_class); } | unit_id { if(control_item_count == 0) /* unit id */ { /* Handle special cases */ if( datatype_of($1.TOK_type) == type_STRING ) { /* unit id=char variable is an internal file. I/O goes in and out of the variable. */ if( is_true(ID_EXPR,$1.TOK_flags) ) { io_internal_file = TRUE; if(curr_stmt_class == tok_WRITE) { use_lvalue(&($1)); } } else { /* internal unit must be a variable */ syntax_error($1.line_num,$1.col_num, "internal file must be a variable"); } } else { /* Otherwise it is a normal external file unit id */ record_io_unit_id(&$1); } } else if(control_item_count == 1) /* format id */ { if( $1.tclass == '*' ) { io_list_directed = TRUE; } else if( is_true(ID_EXPR,$1.TOK_flags)){ if(datatype_of($1.TOK_type) == type_NAMELIST) { ref_namelist(&($1),curr_stmt_class); } else /* format id=integer variable is assigned format */ if( datatype_of($1.TOK_type) == type_INTEGER) { if( f95_assign ) { nonstandard($1.line_num,$1.col_num,0,f95_assign); msg_tail(": assigned format"); } } } /* An integer at this point is a format label */ else if ( is_true(LIT_CONST,$1.TOK_flags) && $1.TOK_type == type_byte(class_VAR,type_INTEGER)) { ref_label(&($1),LAB_IO); } current_io_form = IO_FORM_FORMATTED; } /* Handle use of variable */ if( is_true(ID_EXPR,$1.TOK_flags)){ use_variable(&($1)); } } ; /* OPEN stmt needs its own control list defn to allow for VMS READONLY and similar keywords. Special prodn for unit_id as optional 1st item needed to avoid reduce/reduce conflict with later-occurring symbolic_name items. */ open_info_list : unit_id { if( $1.tclass != '*' && is_true(ID_EXPR,$1.TOK_flags)){ use_variable(&($1)); } if(control_item_count == 0) { record_io_unit_id(&($1)); } ++control_item_count; } | symbolic_name '=' unit_id { use_io_keyword(&($1),&($3),curr_stmt_class); ++control_item_count; } | open_info_list ',' open_info_item { ++control_item_count; } ; open_info_item : symbolic_name '=' unit_id { use_io_keyword(&($1),&($3),curr_stmt_class); } | symbolic_name /* NOSPANBLOCKS, READONLY or SHARED */ { use_special_open_keywd(&($1)); } ; /* 48 */ io_list : io_item | io_list ',' io_item ; io_item : expr { if( curr_stmt_class == tok_READ || curr_stmt_class == tok_ACCEPT ) { /* Input */ if(is_true(LVALUE_EXPR,$1.TOK_flags)) { use_lvalue(&($1)); } else { syntax_error($1.line_num,$1.col_num, "item is not assignable"); /* Give hint if it is a parameter */ if(is_true(ID_EXPR,$1.TOK_flags) && is_true(CONST_EXPR,$1.TOK_flags)) msg_tail(": it is a constant"); } } else { /* Output */ if(is_true(ID_EXPR,$1.TOK_flags)){ use_variable(&($1)); } } } | io_implied_do_list ; /* 49 */ io_implied_do_list: '(' io_list ',' variable_name '=' do_loop_bounds ')' { if( ! is_true(LVALUE_EXPR,$4.TOK_flags) ) { syntax_error($4.line_num,$4.col_num, "index is not assignable"); if(is_true(CONST_EXPR,$4.TOK_flags)) msg_tail(": it is a constant"); } else { use_implied_do_index(&($4)); } } ; /* 50 */ open_stmt : tok_OPEN {init_io_ctrl_list();} '(' open_info_list ')' EOS ; /* 51 */ close_stmt : tok_CLOSE {init_io_ctrl_list();} '(' control_info_list ')' EOS ; /* 52 */ inquire_stmt : tok_INQUIRE {init_io_ctrl_list();} '(' control_info_list ')' EOS ; /* 53 */ backspace_stmt : backspace_handle unit_id EOS { if( $2.tclass != '*' && is_true(ID_EXPR,$2.TOK_flags)){ use_variable(&($2)); } record_io_unit_id(&$2); } | backspace_handle '(' control_info_list ')' EOS ; backspace_handle: tok_BACKSPACE {init_io_ctrl_list();} ; /* 54 */ endfile_stmt : endfile_handle unit_id EOS { if( $2.tclass != '*' && is_true(ID_EXPR,$2.TOK_flags)){ use_variable(&($2)); } record_io_unit_id(&$2); } | endfile_handle '(' control_info_list ')' EOS ; endfile_handle : tok_ENDFILE {init_io_ctrl_list();} ; /* 55 */ rewind_stmt : rewind_handle unit_id EOS { if( $2.tclass != '*' && is_true(ID_EXPR,$2.TOK_flags)){ use_variable(&($2)); } record_io_unit_id(&$2); } | rewind_handle '(' control_info_list ')' EOS ; rewind_handle : tok_REWIND {init_io_ctrl_list();} ; /* 56 */ /* "expr" causes shift/reduce conflict on ')' between red'n unit_id: expr_ and shift primary: ( expr_ ). Use "associativity" rule to force reduction */ unit_id : expr %prec REDUCE | '*' ; /* 57 */ format_id : char_expr { if(is_true(ID_EXPR,$1.TOK_flags)){ use_variable(&($1)); /* If integer, format_id is assigned format */ if( datatype_of($1.TOK_type) == type_INTEGER ) { if( f95_assign ) { nonstandard($1.line_num,$1.col_num,0,f95_assign); msg_tail(": assigned format"); } } } /* A format label appears here as integer const */ else if(is_true(LIT_CONST,$1.TOK_flags) && $1.TOK_type == type_byte(class_VAR,type_INTEGER)){ ref_label(&($1),LAB_IO); } } | '*' ; /* 58,59 */ format_stmt : tok_FORMAT {inside_format=TRUE;} '(' format_spec ')' EOS { inside_format=FALSE; } ; /* 60-69 */ format_spec : /* EMPTY */ | nonempty_format_spec ; nonempty_format_spec: fmt_spec_item | nonempty_format_spec fmt_spec_item ; fmt_spec_item : repeatable_fmt_item | unrepeatable_fmt_item | fmt_item_separator ; repeatable_fmt_item: '(' nonempty_format_spec ')' | tok_edit_descriptor ; unrepeatable_fmt_item: tok_string | tok_hollerith { if( f95_Hedit ) { nonstandard($1.line_num,$1.col_num,0,f95_Hedit); msg_tail(": H edit descriptor"); } } | repeat_spec | variable_fmt_item ; fmt_item_separator: ',' | '/' | tok_concat /* since lexer spots "//" */ | ':' | '.' /* Occurs when variable w.d is used */ | nonstandard_fmt_item { if(f77_format_dollarsigns || f90_format_dollarsigns) nonstandard($1.line_num,$1.col_num,f90_format_dollarsigns,0); } ; nonstandard_fmt_item: '$' /* VMS uses this */ ; repeat_spec : tok_integer_const | '-' tok_integer_const /* for kP descriptor */ | '+' tok_integer_const /* for +kP descriptor */ ; /* VMS-style variable format size or repeat spec*/ variable_fmt_item: '<' {inside_format=FALSE;} integer_expr {inside_format=TRUE;} '>' { if(f77_variable_format || f90_variable_format) nonstandard($1.line_num,$1.col_num,f90_variable_format,0); } ; /* 70 handle only: complete defn handled as assignment stmt */ stmt_function_handle: scalar_name '(' stmt_function_dummy_list ')' { check_stmt_sequence(&($1),SEQ_STMT_FUN); check_f90_stmt_sequence(&($1),F90_SEQ_SPECIF); def_stmt_function(&($1),&($3)); /* make token info */ primary_id_expr(&($1),&($$)); #ifdef DEBUG_PARSER if(debug_parser) print_exprlist("stmt function",&($3)); #endif } ; stmt_function_dummy_list: /* empty list */ { $$.next_token = (Token*)NULL; } | nonempty_stmt_fun_dummy_list ; nonempty_stmt_fun_dummy_list: stmt_function_dummy_arg { $$.next_token = append_token((Token*)NULL,&($1)); } | nonempty_stmt_fun_dummy_list ',' stmt_function_dummy_arg { $$.next_token = append_token($1.next_token,&($3)); } ; stmt_function_dummy_arg: variable_name /* for now: later, handle correctly */ ; /* 71 */ call_stmt : call_handle { call_subr(&($1),(Token*)NULL); complex_const_allowed = FALSE; } EOS | call_handle '(' ')' { call_subr(&($1),(Token*)NULL); complex_const_allowed = FALSE; } EOS | call_handle '(' subr_arg_list ')' { call_subr(&($1),&($3)); #ifdef DEBUG_PARSER if(debug_parser) print_exprlist("call stmt",&($3)); #endif complex_const_allowed = FALSE; } EOS ; call_handle : tok_CALL symbolic_name { complex_const_allowed = TRUE; $$ = $2; } ; subr_arg_list: subr_arg { $$.next_token = append_token((Token*)NULL,&($1)); $$.left_token = (Token *)NULL; } | subr_arg_list ',' subr_arg { $$.next_token = append_token($1.next_token,&($3)); } ; subr_arg : expr { if(is_true(ID_EXPR,$1.TOK_flags)){ use_actual_arg(&($1)); use_variable(&($1)); } } | '*' pre_label label { ref_label(&($3), LAB_CALL); $$ = $3; $$.left_token = (Token *)NULL; } ; /* 72 */ return_stmt : tok_RETURN EOS { (void)do_RETURN(current_module_hash,&($1)); } | tok_RETURN integer_expr EOS { if( do_RETURN(current_module_hash,&($1)) ) { /* Warn if alternate return value is a constant that is not between 0 and the number of labels that are dummy-arguments. */ if( pretty_alt_return && (is_true(EVALUATED_EXPR,$2.TOK_flags) && ($2.value.integer < 1 || $2.value.integer > label_dummy_arg_count)) ){ warning($2.line_num,$2.col_num, "alternate return value"); msg_tail(ulongtostr($2.value.integer)); if( $2.value.integer < 0 ) { msg_tail("is negative"); } else { msg_tail("exceeds"); msg_tail(ulongtostr(label_dummy_arg_count)); msg_tail("= number of alternative return points"); } } else { /* Style warning is under goto rubric */ if( style_goto ) { warning($1.line_num,$1.col_num, "obsolescent feature: alternate return"); } } } } ; /* 73 */ function_reference: fun_or_substr_handle '(' fun_arg_list ')' { /* restore context */ if(!is_true(COMPLEX_FLAG,$1.TOK_flags)) complex_const_allowed=FALSE; if(is_true(IN_ASSIGN,$1.TOK_flags)) in_assignment_stmt = TRUE; /* Change empty arg list to no arg list */ if($3.next_token == NULL) call_func(&($1),(Token *)NULL); else call_func(&($1),&($3)); /* make token info */ func_ref_expr(&($1),&($3),&($$)); /* Substitute empty token for null arglist */ $$.left_token = add_tree_node( &($2),&($1), ($3.next_token == NULL? empty_token(&($3)) : $3.next_token) ); #ifdef DEBUG_PARSER if(debug_parser) print_exprlist("function",&($3)); #endif } ; fun_or_substr_handle: scalar_name { if(complex_const_allowed)/* save context */ make_true(COMPLEX_FLAG,$$.TOK_flags); complex_const_allowed=TRUE; if(in_assignment_stmt) make_true(IN_ASSIGN,$$.TOK_flags); in_assignment_stmt = FALSE; } ; fun_arg_list : /* empty */ { $$.tclass = 0; $$.next_token = (Token *)NULL; $$.left_token = (Token *)NULL; } | nonempty_fun_arg_list ; nonempty_fun_arg_list: expr { $$.next_token = append_token((Token*)NULL,&($1)); $$.left_token = (Token *)NULL; } | nonempty_fun_arg_list ',' expr { $$.next_token = append_token($1.next_token,&($3)); } ; /* 74 not present: type checking not done at this level */ /* 75 was constant_expr, but only used by PARAMETER */ parameter_expr : /* arith, char, or logical */ expr { int t=datatype_of($1.TOK_type); if( t != type_ERROR){ if( ! is_const_type(t) ) { syntax_error($1.line_num,$1.col_num, "arithmetic, char, or logical expression expected"); } else { if( !is_true(PARAMETER_EXPR,$1.TOK_flags) ) { syntax_error($1.line_num,$1.col_num, "constant expression expected"); } /* Here we allow, with some warnings, expr containing intrins func or **REAL in PARAMETER defn. */ else if( !is_true(CONST_EXPR,$1.TOK_flags) ) { if(f77_param_intrinsic) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail( "intrinsic function or **REAL in PARAMETER defn"); } } } } } ; /* 76 following the text of the standard, not the diagrams */ expr : log_expr { /* Fix it up in case it is used in expr list */ $$.next_token = (Token *) NULL; #ifdef DEBUG_PARSER if(debug_parser) { (void)fprintf(list_fd, "\nexpr: class=0x%lx subclass=0x%lx", $1.tclass, $1.tsubclass); } #endif } ; log_expr : log_disjunct | expr tok_EQV log_disjunct { do_binexpr(&($1),&($2),&($3) ,&($$)); } | expr tok_NEQV log_disjunct { do_binexpr(&($1),&($2),&($3) ,&($$)); } ; log_disjunct : log_term | log_disjunct tok_OR log_term { do_binexpr(&($1),&($2),&($3) ,&($$)); } ; log_term : log_factor | log_term tok_AND log_factor { do_binexpr(&($1),&($2),&($3) ,&($$)); } ; log_factor : log_primary | tok_NOT log_primary { do_unexpr(&($1),&($2),&($$)); } ; log_primary : arith_expr | log_primary tok_relop log_primary { do_binexpr(&($1),&($2),&($3) ,&($$)); } ; arith_expr : term | '-' term { do_unexpr(&($1),&($2),&($$)); } | '+' term { do_unexpr(&($1),&($2),&($$)); } | arith_expr '+' term { do_binexpr(&($1),&($2),&($3) ,&($$)); } | arith_expr '-' term { do_binexpr(&($1),&($2),&($3) ,&($$)); } ; term : factor | term '/' factor { do_binexpr(&($1),&($2),&($3) ,&($$)); if(div_check && !is_true(CONST_EXPR,$3.TOK_flags)){ warning($2.line_num,$2.col_num, "Possible division by zero"); } } | term '*' factor { do_binexpr(&($1),&($2),&($3) ,&($$)); } ; factor : char_expr | char_expr tok_power factor { do_binexpr(&($1),&($2),&($3) ,&($$)); } ; char_expr : primary | char_expr tok_concat primary { do_binexpr(&($1),&($2),&($3) ,&($$)); } ; primary : variable_name { make_true(DIM_BOUND_EXPR,$$.TOK_flags); } | array_element_name | function_reference | substring_name | literal_const { $$.TOK_flags = 0; $$.left_token = (Token *)NULL; make_true(CONST_EXPR,$$.TOK_flags); make_true(PARAMETER_EXPR,$$.TOK_flags); make_true(LIT_CONST,$$.TOK_flags); make_true(EVALUATED_EXPR,$$.TOK_flags); make_true(DIM_BOUND_EXPR,$$.TOK_flags); } | '(' expr ')' { $$ = $2; /* (identifier) becomes a non-identifier */ if(is_true(LVALUE_EXPR,$2.TOK_flags)) { if(pretty_parens) { ugly_code($2.line_num,$2.col_num, "Extraneous parentheses"); } use_variable(&($2)); make_false(LVALUE_EXPR,$$.TOK_flags); make_false(ARRAY_ID_EXPR,$$.TOK_flags); make_false(ARRAY_ELEMENT_EXPR,$$.TOK_flags); make_false(ID_EXPR,$$.TOK_flags); make_false(DO_VARIABLE,$$.TOK_flags); } /* (expr) becomes tree node with root = '(' */ $$.left_token = add_tree_node(&($1),&($2), (Token*)NULL); } ; /* Literal constants are numbers, strings holleriths, and logical constants */ literal_const : numeric_const /* (class, size set in numeric_const productions) */ | tok_string { $$.TOK_type = type_byte(class_VAR,type_STRING); /* (size is set in get_string) */ } | tok_hollerith { $$.TOK_type = type_byte(class_VAR,type_HOLLERITH); /* (size is set in get_hollerith) */ if(port_hollerith) { warning($1.line_num,$1.col_num, "hollerith constant may not be portable"); } } | tok_logical_const { $$.TOK_type = type_byte(class_VAR,type_LOGICAL); $$.size = size_DEFAULT; } ; numeric_const : tok_integer_const { $$.TOK_type = type_byte(class_VAR,type_INTEGER); $$.size = size_DEFAULT; } | tok_real_const { $$.TOK_type = type_byte(class_VAR,type_REAL); $$.size = size_DEFAULT; } | tok_dp_const { $$.TOK_type = type_byte(class_VAR,type_DP); $$.size = size_DEFAULT; } | tok_quad_const { $$.TOK_type = type_byte(class_VAR,type_QUAD); $$.size = size_QUAD; if(f77_quad_constants || f90_quad_constants) { nonstandard($1.line_num,$1.col_num,f90_quad_constants,0); msg_tail(": quad precision constant"); } } | tok_complex_const { $$.TOK_type = type_byte(class_VAR,type_COMPLEX); $$.size = size_DEFAULT; } | tok_dcomplex_const { $$.TOK_type = type_byte(class_VAR,type_DCOMPLEX); $$.size = size_DEFAULT; } ; /* 77 */ integer_expr : /* integer */ arith_expr { if(is_true(ID_EXPR,$1.TOK_flags)){ use_variable(&($1)); } if(datatype_of($1.TOK_type) != type_INTEGER) { syntax_error( $1.line_num,$1.col_num, "expression must be integer type"); } } ; /* 78 */ int_real_dp_expr: /* integer, real, or double */ arith_expr { if(is_true(ID_EXPR,$1.TOK_flags)){ use_variable(&($1)); } { int t=datatype_of($1.TOK_type); if(t != type_INTEGER && t != type_REAL && t != type_DP ) { syntax_error( $1.line_num,$1.col_num, "expression must be integer, real, or double precision type"); } } } ; /* 79 absent */ /* 80 */ int_constant_expr: /* integer const */ arith_expr { if(is_true(ID_EXPR,$1.TOK_flags)){ use_variable(&($1)); } if( ! is_true(CONST_EXPR,$1.TOK_flags) ) { syntax_error( $1.line_num,$1.col_num, "constant expression expected"); } else { if(datatype_of($1.TOK_type) != type_INTEGER){ syntax_error( $1.line_num,$1.col_num, "integer expression expected"); } else { $$.value.integer = int_expr_value(&($1)); } } } ; /* 81 */ dim_bound_expr : /* integer */ arith_expr { if(is_true(ID_EXPR,$1.TOK_flags)){ use_variable(&($1)); } if(f77_array_bounds) { /* Section 5.1.1.1 */ if( !is_true(DIM_BOUND_EXPR,$1.TOK_flags) ) { nonstandard($1.line_num,$1.col_num,0,0); msg_tail( ": array bounds expr cannot have array or function reference"); } } if( datatype_of($1.TOK_type) != type_INTEGER ){ syntax_error( $1.line_num,$1.col_num, "integer dimension expected"); $$.value.integer = 0; } else { if( is_true(EVALUATED_EXPR,$1.TOK_flags) ) $$.value.integer = int_expr_value(&($1)); else /* must be dummy */ $$.value.integer = 0; } } ; /* 82-85 absent: no type checking here */ /* 86-87 absent: see 76 */ /* 88 */ array_element_lvalue: array_name '(' subscript_list ')' { ref_array(&($1),&($3)); #ifdef DEBUG_PARSER if(debug_parser) print_exprlist("array lvalue",&($3)); #endif /* array now becomes scalar */ make_false(ARRAY_ID_EXPR,$$.TOK_flags); make_true(ARRAY_ELEMENT_EXPR,$$.TOK_flags); $$.left_token = add_tree_node( &($2),&($1),$3.next_token); $$.next_token = (Token *) NULL; } ; array_element_name: array_name '(' subscript_list ')' { ref_array(&($1),&($3)); #ifdef DEBUG_PARSER if(debug_parser) print_exprlist("array",&($3)); #endif /* array now becomes scalar */ make_false(ARRAY_ID_EXPR,$$.TOK_flags); make_true(ARRAY_ELEMENT_EXPR,$$.TOK_flags); $$.left_token = add_tree_node( &($2),&($1),$3.next_token); $$.next_token = (Token *) NULL; } ; subscript_list : subscript { $$.next_token = append_token((Token*)NULL,&($1)); } | subscript_list ',' subscript { $$.next_token = append_token($1.next_token,&($3)); } ; subscript : expr { if(is_true(ID_EXPR,$1.TOK_flags)){ use_variable(&($1)); } /* check subscript exprs for integer type */ if(datatype_of($1.TOK_type) != type_INTEGER) if(trunc_real_subscript) warning($1.line_num,$1.col_num, "subscript is not integer"); } ; /* 89 */ substring_name : fun_or_substr_handle substring_interval { /* restore status of complex flag */ if(!is_true(COMPLEX_FLAG,$1.TOK_flags)) complex_const_allowed=FALSE; /* set flag to keep more than just id for arg list text */ if(is_true(ID_EXPR,$1.TOK_flags)) make_true(ARRAY_ELEMENT_EXPR,$$.TOK_flags); $$.size=substring_size(&($1),&($2)); $$.left_token = add_tree_node( &save_token,&($1),&($2)); $$.next_token = (Token *) NULL; } | function_reference substring_interval { $$.size=substring_size(&($1),&($2)); $$.left_token = add_tree_node( &save_token,&($1),&($2)); $$.next_token = (Token *) NULL; } | array_element_name substring_interval { $$.size=substring_size(&($1),&($2)); $$.left_token = add_tree_node( &save_token,&($1),&($2)); $$.next_token = (Token *) NULL; } ; substring_lvalue: scalar_name substring_interval { ref_variable(&($1)); $$.TOK_flags = $1.TOK_flags; $$.size=substring_size(&($1),&($2)); } | array_element_lvalue substring_interval { $$.size=substring_size(&($1),&($2)); } ; /* substring interval: limits go into TOK_start, TOK_end. */ substring_interval: '(' ':' ')' { $$.TOK_start=1; $$.TOK_end=0; /* 0 means LEN */ save_token = $1; /* Save the paren for tree node */ $$.left_token = add_tree_node(&($2), empty_token(&($1)),empty_token(&($3))); /* Nullify next_token so it looks like a tokenlist */ $$.next_token = (Token *)NULL; } | '(' substr_index_expr ':' ')' { $$.TOK_start=$2.value.integer; $$.TOK_end=0; /* 0 means LEN */ save_token = $1; /* Save the paren for tree node */ $$.left_token = add_tree_node(&($3),&($2),empty_token(&($4))); $$.next_token = (Token *)NULL; } | '(' ':' substr_index_expr ')' { $$.TOK_start=1; $$.TOK_end=$3.value.integer; save_token = $1; /* Save the paren for tree node */ $$.left_token = add_tree_node(&($2),empty_token(&($1)),&($3)); $$.next_token = (Token *)NULL; } | '(' substr_index_expr ':' substr_index_expr ')' { $$.TOK_start=$2.value.integer; $$.TOK_end=$4.value.integer; save_token = $1; /* Save the paren for tree node */ $$.left_token = add_tree_node(&($3),&($2),&($4)); $$.next_token = (Token *)NULL; } ; substr_index_expr: arith_expr { if(is_true(ID_EXPR,$1.TOK_flags)){ use_variable(&($1)); } /* check validity and replace nonconst value by size_UNKNOWN. */ if(is_true(CONST_EXPR,$1.TOK_flags)) { if( ($$.value.integer=int_expr_value(&($1))) < 1) { syntax_error($1.line_num,$1.col_num, "invalid substring index"); } } else /* (no longer need ID hash index) */ $$.value.integer=size_UNKNOWN; } ; /* 90-98 absent: name categories not distinguished */ /* 99 */ variable_name : scalar_name { ref_variable(&($1)); $$.TOK_flags = $1.TOK_flags; } | array_name ; scalar_name : tok_identifier { ref_identifier(&($1)); primary_id_expr(&($1),&($$)); } ; array_name : tok_array_identifier { ref_variable(&($1)); primary_id_expr(&($1),&($$)); } ; /* symbolic_name refers to a name without making it into an id expr */ symbolic_name : tok_identifier | tok_array_identifier ; construct_spec : construct_name ':' { construct_name_seen=TRUE; /* remember the name for block balancing */ curr_stmt_name = hashtab[$1.value.integer].name; } ; construct_name : tok_identifier { curr_stmt_name = hashtab[$1.value.integer].name; } | tok_array_identifier { curr_stmt_name = hashtab[$1.value.integer].name; } ; /* 100 */ data_constant : numeric_const | '-' numeric_const { $$ = $2; } | '+' numeric_const { $$ = $2; } | tok_logical_const { $$.TOK_type = type_byte(class_VAR,type_LOGICAL); $$.size = size_DEFAULT; } | tok_string { $$.TOK_type = type_byte(class_VAR,type_STRING); $$.size = size_DEFAULT; } | tok_hollerith { $$.TOK_type = type_byte(class_VAR,type_HOLLERITH); $$.size = size_DEFAULT; } ; /* 101-102 absent */ /* 103 */ nonzero_unsigned_int_const: tok_integer_const { if($1.value.integer == 0) { if(misc_warn) { warning($1.line_num,$1.col_num, "nonzero integer expected"); msg_tail(": substituting 1"); } $$.value.integer = 1; } $$.left_token = (Token *)NULL; } ; /* F77 requires char length spec > 0 but in F90 a length spec 0 is allowed, and negative length is turned into 0. This production handles this. We warn about a negative value just in case. */ nonneg_unsigned_int_const: tok_integer_const { if($1.value.integer <= 0) { if($1.value.integer < 0) { if(misc_warn || f77_char_extension) { warning($1.line_num,$1.col_num, "non-negative integer expected"); msg_tail(": substituting 0"); } $$.value.integer = 0; } else if(f77_char_extension) { warning($1.line_num,$1.col_num, "nonzero integer expected"); } } $$.left_token = (Token *)NULL; } ; /* 104-109 absent: lexer handles these */ /* pre_label prepares for an expected label by setting flag so that lexer won't look for E-format number. All grammar rules that have "label" precede it with "pre_label" */ pre_label : /* NOTHING */ { integer_context=TRUE; } ; /* 110 */ label : tok_integer_const { if( $$.value.integer > 99999 && misc_warn) { syntax_error($1.line_num,$1.col_num, "statement label exceeds 5 digits"); } integer_context=FALSE; $$.TOK_type = type_byte(class_LABEL,type_LABEL); $$.size = size_DEFAULT; $$.TOK_flags = 0; } ; /* 111-116 absent: lexer handles these */ %% void init_parser(VOID) /* Initialize various flags & counters */ { initial_flag = TRUE; /* set flag for keyword test */ implicit_flag=FALSE; /* clear flags for IMPLICIT stmt */ implicit_letter_flag = FALSE; implicit_type_given = FALSE; implicit_none = FALSE; global_save = FALSE; prev_token_class = EOS; complex_const_allowed = FALSE; stmt_sequence_no = 0; f90_stmt_sequence_no = 0; true_prev_stmt_line_num = 0; { int i; /* Reset *_this_file flags for project files */ for(i=0; ileft_token = add_tree_node(op, expr, (Token*)NULL); } /* Handle binary expressions: link into a tree and propagate type. */ PRIVATE void #if HAVE_STDC do_binexpr(Token *l_expr, Token *op, Token *r_expr, Token *result) #else /* K&R style */ do_binexpr(l_expr,op,r_expr,result) Token *l_expr,*op,*r_expr,*result; #endif /* HAVE_STDC */ { binexpr_type(l_expr,op,r_expr,result); /* Propagate the type */ result->left_token = add_tree_node(op, l_expr, r_expr); } /* Changes a token to empty and replaces src_text by null string, value by 0. Other info (line, col, etc.) unchanged. */ PRIVATE Token * #if HAVE_STDC empty_token(Token *t) #else /* K&R style */ empty_token(t) Token *t; #endif /* HAVE_STDC */ { #ifdef DEBUG_EMPTY_TOKEN static char *nullstring="(empty)"; /* for debugging. */ #else static char *nullstring=""; /* for operation. */ #endif t->tclass = tok_empty; t->tsubclass = 0; t->value.integer = 0; t->left_token = (Token *) NULL; t->src_text = nullstring; return t; } /* Propagate non-integer type if any of DO loop bounds are non-integer. */ PRIVATE int #if HAVE_STDC do_bounds_type(Token *t1, Token *t2, Token *t3) #else /* K&R style */ do_bounds_type(t1,t2,t3) Token *t1, *t2, *t3; #endif /* HAVE_STDC */ { int result_type; if(datatype_of(t1->TOK_type) != type_INTEGER)result_type = t1->TOK_type; else if(datatype_of(t2->TOK_type) != type_INTEGER)result_type = t2->TOK_type; else if(datatype_of(t3->TOK_type) != type_INTEGER)result_type = t3->TOK_type; else result_type = t1->TOK_type; return result_type; } /* Debugging routine: prints the expression list of various productions */ #ifdef DEBUG_PARSER PRIVATE void print_exprlist(s,t) char *s; Token *t; { (void)fprintf(list_fd,"\n%s arglist: ",s); if(t == NULL) (void)fprintf(list_fd,"(empty)"); else { while( (t=t->next_token) != NULL) { fprintf(list_fd,"%s ",type_name[datatype_of(t->TOK_type)]); if( is_true(ID_EXPR,t->TOK_flags) ) (void)fprintf(list_fd,"(%s) ",token_name(t)); } } } PRIVATE void print_comlist(s,t) char *s; Token *t; { (void)fprintf(list_fd,"\n%s varlist: ",s); if(t == NULL) (void)fprintf(list_fd,"(empty)"); else { while( (t=t->next_token) != NULL) { fprintf(list_fd,"%s ",type_name[datatype_of(t->TOK_type)]); if( is_true(ID_EXPR,t->TOK_flags) ) (void)fprintf(list_fd,"(%s) ",token_name(t)); } } } #endif /* After having parsed prog_stmt, function_stmt, subroutine_stmt, block_data_stmt, the stmt_sequence_no is set to the value SEQ_HEADER. */ void #if HAVE_STDC check_seq_header(Token *t) #else /* K&R style */ check_seq_header(t) Token *t; #endif /* HAVE_STDC */ { if(stmt_sequence_no >= SEQ_HEADER) { syntax_error( (t == (Token *) NULL? line_num: t->line_num), NO_COL_NUM, "missing END statement inserted"); msg_tail( (t == (Token *) NULL? "at end of file": "prior to statement") ); if( t != (Token *) NULL ) pop_block(t,tok_END,(char *)NULL,NO_LABEL); END_processing(t); } stmt_sequence_no = SEQ_HEADER; f90_stmt_sequence_no = F90_SEQ_HEADER; } PRIVATE void #if HAVE_STDC check_stmt_sequence(Token *t, int seq_num) #else /* K&R style */ check_stmt_sequence(t,seq_num) Token *t; int seq_num; #endif /* HAVE_STDC */ { if(stmt_sequence_no > seq_num) { if(f77_stmt_order) { nonstandard(t->line_num, NO_COL_NUM,0,0); msg_tail(": Statement out of order."); } } /* If no error, sequence number is updated to new value. If error, it is rolled back to prevent cascades of error messages. */ stmt_sequence_no = seq_num; } PRIVATE void #if HAVE_STDC check_f90_stmt_sequence(Token *t, int f90_seq_num) #else /* K&R style */ check_f90_stmt_sequence(t,f90_seq_num) Token *t; int f90_seq_num; #endif /* HAVE_STDC */ { if(f90_stmt_sequence_no > f90_seq_num) { if(f90_stmt_order) { nonstandard(t->line_num, NO_COL_NUM,f90_stmt_order,0); msg_tail(": Statement out of order."); } } /* If no error, sequence number is updated to new value. If error, it is rolled back to prevent cascades of error messages. */ f90_stmt_sequence_no = f90_seq_num; } PRIVATE void init_io_ctrl_list(VOID) { control_item_count = 0; io_internal_file = FALSE; io_list_directed = FALSE; io_warning_given = FALSE; current_io_unit_no = IO_UNIT_UNKNOWN; current_io_unit_id = IO_UNIT_UNKNOWN; current_io_access = IO_ACCESS_DEFAULT; current_io_form = IO_FORM_DEFAULT; } /* Remember the name or number of unit_id for current I/O stmt. This routine is only called by parser productions that have a bare unit_id, so less checking is done than for unit=unit_id specifiers that can refer to other than external files. */ void record_io_unit_id(Token *id) { if( id->tclass == '*' ) { current_io_unit_id = IO_UNIT_DEFAULT; } else if( is_true(ID_EXPR,id->TOK_flags)){ current_io_unit_id = id->value.integer; /* get hash code of identifier */ } else if( is_true(LIT_CONST,id->TOK_flags) && id->TOK_type == type_byte(class_VAR,type_INTEGER)) { current_io_unit_no = id->value.integer; /* get literal int value */ } } /* Set I/O usage parameters for default formatted sequential I/O statement like READ *, X */ PRIVATE void record_default_io(VOID) { current_io_unit_no = IO_UNIT_UNKNOWN; current_io_unit_id = IO_UNIT_DEFAULT; current_io_access = IO_ACCESS_SEQUENTIAL; current_io_form = IO_FORM_FORMATTED; } /* This routine applies the attributes of attr-based type declaration. Set dim_bounds to current_dim_bound_list or to NULL if item has its own array bounds declarator. */ PRIVATE void process_attrs(Token *t,Token *dim_bounds) { if(current_external_attr) def_ext_name(t); if(current_intrinsic_attr) def_intrins_name(t); if(current_allocatable_attr) apply_attr(t,tok_ALLOCATABLE); if(current_pointer_attr) apply_attr(t,tok_POINTER); if(current_save_attr) apply_attr(t,tok_SAVE); if(current_target_attr) apply_attr(t,tok_TARGET); if(dim_bounds != NULL) def_array_dim(t,dim_bounds); } /* After having parsed end_stmt, common block lists and subprogram argument lists are copied over into global symbol table, the local symbol table is printed out and then cleared, and stmt_sequence_no is set to zero for start of next module. */ PRIVATE void #if HAVE_STDC END_processing(Token *t) #else /* K&R style */ END_processing(t) Token *t; #endif /* HAVE_STDC */ { ++tot_module_count; if(current_module_hash != -1) { if(exec_stmt_count == 0 && current_module_type != type_BLOCK_DATA) { if(misc_warn) warning(t == (Token *)NULL? line_num: t->line_num, NO_COL_NUM, "Module contains no executable statements"); } if(do_list && t != (Token *)NULL) { (void)flush_end_stmt(t->line_num); } doing_end_proc = TRUE; /* Set flag for special error message mode */ /* Catch things that had to wait till now */ check_loose_ends(current_module_hash); /* Put arg and com lists into global table */ process_lists(current_module_hash); /* Print symbol table for debug */ debug_symtabs(); /* Print local symbol table and do local warnings */ print_loc_symbols(); /* Reset local symbol table */ init_symtab(); doing_end_proc = FALSE; } exec_stmt_count = 0; stmt_sequence_no = 0; f90_stmt_sequence_no = 0; current_module_hash = -1; implicit_type_given = FALSE; implicit_none = FALSE; true_prev_stmt_line_num = 0; integer_context = FALSE; global_save = FALSE; label_dummy_arg_count = 0; num_io_unit_usages = 0; } /* Routine to create a node for an expr tree. Returns a pointer to the newly created node. */ PRIVATE Token * #if HAVE_STDC add_tree_node(Token *node, Token *left, Token *right) #else /* K&R style */ add_tree_node(node,left,right) Token *node,*left,*right; #endif /* HAVE_STDC */ { Token *new_node, *new_left, *new_right; new_node=new_token(); *new_node = *node; /* Make a permanent copy of root */ /* Add the children. If child's left_token pointer is null, then that expression is a primary. Otherwise it is the root node of a subtree. */ if(left->left_token == (Token *)NULL) { new_left=new_token(); *new_left = *left; /* Copy primary to permanent space */ } else { new_left = left->left_token; /* No copying needed in this case */ } if(right == (Token *)NULL) { new_right = (Token *)NULL; /* No right child */ } else if(right->left_token == (Token *)NULL || node->tclass == '(') { /* Paren means right child is expr list */ new_right=new_token(); *new_right = *right; /* Copy primary to permanent space */ } else { new_right = right->left_token; /* No copying needed in this case */ } new_node->left_token = new_left; /* Link children onto the new root */ new_node->next_token = new_right; return new_node; } /* Routine to add token t to the front of a token list. */ PRIVATE Token * #if HAVE_STDC append_token(Token *tlist, Token *t) #else /* K&R style */ append_token(tlist,t) Token *tlist, *t; #endif /* HAVE_STDC */ { Token *tcopy; tcopy=new_token(); *tcopy = *t; /* make permanent copy of token */ tcopy->next_token = tlist; /* link it onto front of list */ return tcopy; /* return it as new tlist */ } /* Routine to pop closing statement of block off the stack. Note: label should be NO_LABEL even if the statement has a label, except for terminal statement of a labeled DO loop. */ PRIVATE void pop_block(Token *t, int stmt_class, char *name, LABEL_t label) { /* Define lookup table for block matches. This table is generated from tokdefs.h by the Perl script make_blockmatch.pl. This script also generates 4 macro definitions that go here. It defines MIN_BLOCK_TOKEN and MAX_BLOCK_TOKEN used to bound range of valid keytok_name arguments for error messages. It also defines MIN_CLOSER and MAX_CLOSER giving the range of token numbers for closing tokens. The array block_match contains the token numbers for the matching openers. Look up the matching opener class as block_match[closer_class-MIN_CLOSER] Plain END is handled specially since it matches many things. Likewise closing labeled-DO range is handled specially. (ENDDO is handled there if loop is labeled, handled with structured block closers otherwise.) */ static int block_match[] = { #include "block_match.h" }; /* Macro for names of all block keyword tokens. Although no error messages should print "identifier" (only occurs as DO terminator, and mismatch is handled specially), include it for possible debug use. Any other token classes in block_stack mean a bug in ftnchek. */ #define TOKEN_NAME(CLASS) ((CLASS)>=MIN_BLOCK_TOKEN && (CLASS)<=MAX_BLOCK_TOKEN? \ keytok_name(CLASS):((CLASS) == tok_identifier?"identifier":"bogus")) /* Define DBG_TOKNAME for debugging. If possible, use yytname to allow for bogus tokens showing up. This works only for bison parser generator. It would be easy to fix up for byacc too if need be. */ #ifdef DEBUG_BLOCKCHECK #ifdef USE_YYTNAME #define DBG_TOKNAME(CLASS) (char *)(yytname[YYTRANSLATE(CLASS)]) #else #define DBG_TOKNAME(CLASS) TOKEN_NAME(CLASS) #endif #endif #ifdef DEBUG_BLOCKCHECK if(debug_latest) { fprintf(list_fd,"\npopping stmt class %s name %s label %d at line %d", DBG_TOKNAME(stmt_class),name,label,t->line_num); } #endif if(block_depth == 0) { syntax_error(t->line_num,t->col_num,"no construct to end here"); } else { int opener_class, must_check_name=FALSE; BLOCK_TYPE blocktype; --block_depth; opener_class = block_stack[block_depth].sclass; blocktype = block_stack[block_depth].blocktype; #ifdef DEBUG_BLOCKCHECK if(debug_latest) { fprintf(list_fd,"\n opener was class %s name %s label %d at line %d", DBG_TOKNAME(opener_class), block_stack[block_depth].name, block_stack[block_depth].label, block_stack[block_depth].first_line); } #endif /* DO loop terminator */ if( label != NO_LABEL) { int shared_warning = TRUE; /* Mark DO index variable as inactive */ int h=block_stack[block_depth].do_var_hash; if(h != -1) undef_do_variable(h); if( stmt_class == tok_ENDDO ) { must_check_name = TRUE; } else { /* issue picky warnings if not modern DO construct */ if(style_req_enddo) { warning(t->line_num,t->col_num, "DO loop not terminated by ENDDO"); } else if( stmt_class != tok_CONTINUE ) { if(style_req_do_construct) { warning(t->line_num,t->col_num, "DO loop not terminated by CONTINUE or ENDDO"); } } } if( opener_class != tok_DO ) { syntax_error(t->line_num,t->col_num,keytok_name(opener_class)); msg_tail("block not closed when DO loop terminating statement encountered"); } else if( label != block_stack[block_depth].label ) { syntax_error(t->line_num,t->col_num,"Label"); msg_tail(ulongtostr(label)); msg_tail("on DO loop terminator does not match"); if(block_stack[block_depth].label == NO_LABEL ) { msg_tail("label-less DO statement"); } else { msg_tail("corresponding DO label"); msg_tail(ulongtostr(block_stack[block_depth].label)); } msg_tail("above"); } /* If terminator is shared by other DOs, pop them too */ else { while(block_depth > 0 && label == block_stack[block_depth-1].label) { --block_depth; /* Mark DO index variable as inactive */ { int hh=block_stack[block_depth].do_var_hash; if(hh != -1) undef_do_variable(hh); } #ifdef DEBUG_BLOCKCHECK if(debug_latest) { fprintf(list_fd,"\n opener was class %s name %s label %d at line %d", DBG_TOKNAME(opener_class), block_stack[block_depth].name, block_stack[block_depth].label, block_stack[block_depth].first_line); } #endif if(style_shared_do_terminator && shared_warning) { warning(t->line_num,t->col_num, "Obsolescent feature: shared DO terminator"); shared_warning = FALSE; /* don't repeat the warning */ } } } } else if( stmt_class == tok_END ) { /* plain END statement */ if(style_req_structured_end) { warning(t->line_num,t->col_num,"Old-style END statement"); } /* Check that END statement ends subprog block */ if(opener_class != tok_SUBROUTINE && opener_class != tok_FUNCTION && opener_class != tok_PROGRAM && opener_class != tok_BLOCKDATA) { syntax_error(t->line_num,t->col_num, "Block not closed when END statement encountered"); } } else { /* structured block closers */ int matching_class; must_check_name = TRUE; /* Look up the correct matching opener class */ if( stmt_class < MIN_CLOSER || stmt_class > MAX_CLOSER || (matching_class = block_match[stmt_class-MIN_CLOSER]) == 0 ) { fprintf(list_fd,"%d=%s ",stmt_class,keytok_name(stmt_class)); oops_message(OOPS_FATAL,t->line_num,t->col_num, "pop_block called for unrecognized closing token"); } else { /* check if opener matches expected */ if( opener_class != matching_class ) { /* If possible, use token names for better error messages */ syntax_error(t->line_num,t->col_num, keytok_name(stmt_class)); msg_tail("statement does not match"); msg_tail(keytok_name(opener_class)); msg_tail("block it closes"); must_check_name = FALSE; /* name mismatch probably bogus here */ } /* If unlabeled END DO of loop with index variable, mark it inactive. */ if( stmt_class == tok_ENDDO ) { int h=block_stack[block_depth].do_var_hash; if(h != -1) undef_do_variable(h); } } } /* Issue syntax error if name missing from a component of a named construct. In picky mode warn if no name tag on structured END. */ if( must_check_name ) { if( name == (char *)NULL ) { if( blocktype == construct ) { /* IF, DO, SELECT */ if( block_stack[block_depth].name != (char *)NULL ) { syntax_error(t->line_num,t->col_num, "Construct name"); msg_tail(block_stack[block_depth].name); msg_tail("missing"); } } else { /* structured END of subprogram */ if(style_req_end_name) { warning(t->line_num,t->col_num, "Name of subprogram missing from"); msg_tail(keytok_name(stmt_class)); msg_tail("statement"); } } } /* Otherwise check name tag if present */ else { /* OK to compare pointers due to name storage method */ if(name != block_stack[block_depth].name) { /* Opener name can only be missing from a construct, but handle subprog case anyway. */ if(block_stack[block_depth].name == (char *)NULL) { syntax_error(t->line_num,t->col_num, "name found on closing statement of unnamed"); msg_tail(blocktype == construct? "construct": "subprogram"); } else { syntax_error(t->line_num,t->col_num, "Name"); msg_tail(name); msg_tail("does not match"); msg_tail(blocktype == construct? "construct": "subprogram"); msg_tail("name"); msg_tail(block_stack[block_depth].name); } } } } } } /* Check CYCLE and EXIT statements for agreement with enclosing DO loop. */ PRIVATE void check_construct_name_match(Token *t, char *name) { /* If no name on statement, it must at least be inside range of a DO. */ if( name == (char *)NULL ) { int depth; for(depth = block_depth-1; depth >= 0; depth--) { if( block_stack[depth].sclass == tok_DO ) return; } syntax_error(t->line_num,t->col_num, "statement not within range of any DO loop"); } /* If name tag present, it must belong to an enclosing DO. */ else { int depth; for(depth = block_depth-1; depth >= 0; depth--) { if( block_stack[depth].sclass == tok_DO && block_stack[depth].name == name ) return; } syntax_error(t->line_num,t->col_num, "construct name"); msg_tail(name); msg_tail("does not match name of any enclosing DO construct"); } } PRIVATE void push_block(Token *t, int stmt_class, BLOCK_TYPE blocktype, char *name, LABEL_t label) { if(block_depth == MAX_BLOCK_DEPTH) { oops_message(OOPS_FATAL,t->line_num,t->col_num, "blocks nested too deeply"); } else { #ifdef DEBUG_BLOCKCHECK if(debug_latest) { fprintf(list_fd,"\npushing stmt class %s name %s label %d at line %d", DBG_TOKNAME(stmt_class),name,label,t->line_num); } #endif /* ELSE and ELSE IF masquerade here as IF, and CASE and CASEDEFAULT as SELECT, to simplify match code in pop_block. */ block_stack[block_depth].sclass = ((stmt_class == tok_ELSE)? tok_IF: ((stmt_class == tok_CASE)? tok_SELECTCASE: stmt_class)); block_stack[block_depth].name = name; block_stack[block_depth].label = label; block_stack[block_depth].first_line = t->line_num; block_stack[block_depth].blocktype = blocktype; block_stack[block_depth].do_var_hash = -1; /* undefined at this time */ ++block_depth; } } PRIVATE void give_kind_warning(Token *t) { warning(t->line_num,t->col_num, "I do not yet support KIND selectors. \ All KINDs are treated as default KIND. \ Checking of type agreement may be incorrect as a result. \ (This message is only given once.)"); kind_warning_given = TRUE; }