fortran.y

这是一个Linux下的集成开发环境

		;

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 '=' {complex_const_allowed = TRUE;
				    in_assignment_stmt = TRUE;} expr
			{
			  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.subclass)
				     && stmt_sequence_no <= SEQ_STMT_FUN)
			     stmt_function_stmt(&($1));
		        }
		;

lvalue		:	variable_name
		|	lvalue '.' lvalue
			{
			    $$.dot_token = token_dup(&($3)); /* rigo */
			}
		|	array_element_lvalue
		|	substring_lvalue
		|	stmt_function_handle
		;


/* array-element_lvalue is at 88 */

assign_stmt	:    	tok_ASSIGN pre_label label tok_TO variable_name EOS
			{
			    do_ASSIGN(&($5));
			}
		;


/* 31 */
unconditional_goto:	goto pre_label label EOS
		;

/* 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;
			}
		|	tok_GO tok_TO
			{
			    integer_context=TRUE;
			}
		;

goto_list	:	pre_label label
		|	goto_list ',' pre_label label
		;

/* 34 */
arithmetic_if_stmt:	if_handle pre_label label ',' pre_label label
				 ',' pre_label label EOS
		;

/* 35 */
logical_if_stmt	:	if_handle executable_stmt
		;

/* 36 */
block_if_stmt	:	if_handle tok_THEN EOS
		;

if_handle	:	tok_IF '(' {complex_const_allowed = TRUE;}  expr ')'
			{
			    if(is_true(ID_EXPR,$4.subclass)){
				use_variable(&($4));
			    }
			    complex_const_allowed = FALSE;

			    initial_flag = TRUE;	/* for is_keyword */
			    $$ = $4; /* Inherit expr for type checking above */
			}
		;

/* 37 */
else_if_stmt	:	tok_ELSE block_if_stmt
		|	tok_ELSEIF '(' {complex_const_allowed = TRUE;} expr ')'
			{
			    if(is_true(ID_EXPR,$4.subclass)){
				use_variable(&($4));
			    }
			    complex_const_allowed = FALSE;

			    initial_flag = TRUE;
			}
			tok_THEN EOS
		;

/* 38 */
else_stmt	:	tok_ELSE EOS
		;

/* 39 */
end_if_stmt	:	tok_ENDIF EOS
		|	tok_END tok_IF EOS
		;

/* 40 */
			/* Allow VAX/VMS extensions:
			   DO [label [,]] var = expr , expr [,expr]
			   DO [label [,]] WHILE ( expr )
			      ...
			   ENDDO
			*/

do_stmt		:	do_handle variable_name
				'=' do_loop_bounds EOS
			{
			     use_lvalue(&($2));
			     use_variable(&($2));

				/* Check for non-integer DO index or bounds */
			     if(datatype_of($2.class) == type_INTEGER
				&& datatype_of($4.class) != type_INTEGER)
			       warning($3.line_num,$3.col_num,
				  "type mismatch between DO index and bounds");

			     else if(datatype_of($2.class) != type_INTEGER)
			       if(datatype_of($4.class) != type_INTEGER) {
				 if(port_check)
				   nonportable($4.line_num,$4.col_num,
					       "non-integer DO loop bounds");
			       }
			       else {
				 if(trunc_check)
				   warning($2.line_num,$2.col_num,
					   "DO index is not integer");
			       }
			}
		|	do_handle tok_WHILE '('
				{complex_const_allowed=TRUE;} expr ')' EOS
			{
			    if(is_true(ID_EXPR,$5.subclass)){
				use_variable(&($5));
			    }
			    complex_const_allowed=FALSE;
			    make_true(NONSTD_USAGE_FLAG,$$.subclass);
			}
		|	tok_DOWHILE '('
				{complex_const_allowed=TRUE;} expr ')' EOS
			{
			    if(is_true(ID_EXPR,$4.subclass)){
				use_variable(&($4));
			    }
			    complex_const_allowed=FALSE;
			    make_true(NONSTD_USAGE_FLAG,$$.subclass);
			}
		;

do_handle	:	tok_DO pre_label label
		|	tok_DO pre_label label ','
		|	tok_DO pre_label
			{
			    make_true(NONSTD_USAGE_FLAG,$$.subclass);
			    integer_context=FALSE;
			}
		;

do_loop_bounds	:	int_real_dp_expr ',' int_real_dp_expr
			{
			    $$.class=do_bounds_type(&($1),&($3),&($3));
			}
		|   int_real_dp_expr ',' int_real_dp_expr ',' int_real_dp_expr
			{
			    $$.class=do_bounds_type(&($1),&($3),&($5));
			}
		;

enddo_stmt	:	tok_END tok_DO EOS
		|	tok_ENDDO EOS
		;

/* 41 */
continue_stmt	:	tok_CONTINUE EOS
		;

/* 42 */
stop_stmt	:	tok_STOP stop_info EOS
		;

/* 43 */
pause_stmt	:	tok_PAUSE stop_info EOS
		;

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 {control_item_count = 0;}
				'(' 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
		|	read_handle format_id ',' io_list EOS
		;
read_handle	:	tok_READ {control_item_count = 0;}
		;

accept_stmt	:	tok_ACCEPT format_id EOS
		|	tok_ACCEPT format_id ',' io_list EOS
		;

/* 46 */
print_stmt	:	tok_PRINT format_id EOS
   		|	tok_PRINT format_id ','
				{complex_const_allowed = TRUE;} io_list
				{complex_const_allowed = FALSE;}  EOS
		;

type_output_stmt:	tok_TYPE format_id EOS
   		|	tok_TYPE format_id ','
				{complex_const_allowed = TRUE;} io_list
				{complex_const_allowed = FALSE;}  EOS
		;

/* 47 */
control_info_list:	control_info_item
			{
			    ++control_item_count;
			}
		|	control_info_list ',' control_info_item
			{
			    ++control_item_count;
			}
		;

	/* 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( $1.class != '*'
			       && is_true(ID_EXPR,$1.subclass)){
					/* WRITE(string,...) means store
					   output in the string */
				if(curr_stmt_class == tok_WRITE
				 && control_item_count == 0
				 && datatype_of($1.class) == type_STRING)
				    use_lvalue(&($1));
					/* READ/WRITE(..,namelist) means
					   I/O with variables of namelist. */
				else if( control_item_count == 1
				    && datatype_of($1.class) == type_NAMELIST)
				    ref_namelist(&($1),curr_stmt_class);

				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.class != '*'
			       && is_true(ID_EXPR,$1.subclass)){
				use_variable(&($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(is_true(ID_EXPR,$1.subclass)){
				if( curr_stmt_class == tok_READ ||
				    curr_stmt_class == tok_ACCEPT )
				    use_lvalue(&($1));
				else
				    use_variable(&($1));
			    }
			}
		|	io_implied_do_list
		;

/* 49 */
io_implied_do_list:	'(' io_list ',' variable_name '=' do_loop_bounds ')'
			{
			     use_implied_do_index(&($4));
			}
		;

/* 50 */
open_stmt	:	tok_OPEN {control_item_count = 0;}
				 '(' open_info_list ')' EOS
		;

/* 51 */
close_stmt	:	tok_CLOSE {control_item_count = 0;}
				'(' control_info_list ')' EOS
		;

/* 52 */
inquire_stmt	:	tok_INQUIRE {control_item_count = 0;}
				'(' control_info_list ')' EOS
		;

/* 53 */
backspace_stmt	:	backspace_handle unit_id EOS
		|	backspace_handle '(' control_info_list ')' EOS
		;
backspace_handle:	tok_BACKSPACE {control_item_count = 0;}
		;

/* 54 */
endfile_stmt	:	endfile_handle unit_id EOS
		|	endfile_handle '(' control_info_list ')' EOS
		;
endfile_handle	:	tok_ENDFILE {control_item_count = 0;}
		|	tok_END tok_FILE {control_item_count = 0;}
		;

/* 55 */
rewind_stmt	:	rewind_handle unit_id EOS
		|	rewind_handle '(' control_info_list ')' EOS
		;
rewind_handle	:	tok_REWIND {control_item_count = 0;}
		;


/* 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.subclass)){
				 use_variable(&($1));
			    }
			}
		|	'*'
		;

/* 58,59 */
format_stmt	:	tok_FORMAT { inside_format=TRUE; } EOS
			{ inside_format=FALSE; }
		;

/* 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);

				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 '(' expr_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
			{
				if( current_module_hash != -1 )
				{
					if( highlight != -1 )
					{
						put_cross_ref(PAF_REF_TO_SUBROUTINE,
							cross_scope_type,
							PAF_REF_SCOPE_GLOBAL,
							NULL,
							hashtab[current_module_hash].name,
							NULL,
							NULL,
							hashtab[$2.value.integer].name,
							NULL,
							current_filename,
							$2.line_num,
							PAF_REF_PASS);
					}
				}
			    complex_const_allowed = TRUE;
			    $$ = $2;
			}
		;

expr_list	:	expr
			{
			    if(is_true(ID_EXPR,$1.subclass)){
				 use_actual_arg(&($1));
				 use_variable(&($1));
			    }
			    $$.next_token = append_token((Token*)NULL,&($1));
			}
		|	'*' pre_label label
			{
			    $$.next_token = append_token((Token*)NULL,&($3));
			}
		|	expr_list ',' expr
			{
			    if(is_true(ID_EXPR,$3.subclass)){
				 use_actual_arg(&($3));
				 use_variable(&($3));
			    }
			    $$.next_token = append_token($1.next_token,&($3));
			}
		|	expr_list ',' '*' pre_label label
			{
			    $$.next_token = append_token($1.next_token,&($5));
			}
		;

/* 72 */
return_stmt	:	tok_RETURN EOS
			{
			     do_RETURN(current_module_hash,&($1));
			}
		|	tok_RETURN integer_expr EOS
			{
			     do_RETURN(current_module_hash,&($1));
			}
		;

/* 73 */
function_reference:	fun_or_substr_handle '(' fun_arg_list ')'
			{
				if( highlight != -1 )
				{
					put_cross_ref(PAF_REF_TO_FUNCTION,
						cross_scope_type,
						PAF_REF_SCOPE_GLOBAL,
						NULL,
						hashtab[current_module_hash].name,
						NULL,
						NULL,
						hashtab[$1.value.integer].name,
						NULL,
						current_filename,
						$1.line_num,
						PAF_REF_PASS);
				}
				   /* restore context */
				if(!is_true(COMPLEX_FLAG,$1.subclass))
				  complex_const_allowed=FALSE;
				if(is_true(IN_ASSIGN,$1.subclass))
				  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),&($$));
#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,$$.subclass);
			    complex_const_allowed=TRUE;
			    if(in_assignment_stmt)
			        make_true(IN_ASSIGN,$$.subclass);
			    in_assignment_stmt = FALSE;
			}
		;

fun_arg_list	:	/* empty */
			{
				$$.class = 0;
				$$.next_token = NULL;
			}
		|	nonempty_fun_arg_list
		;

nonempty_fun_arg_list:	expr
			{
			    if(is_true(ID_EXPR,$1.subclass)){
				 use_actual_arg(&($1));
/* 				 use_variable(&($1)); */
			    }
			    $$.next_token = append_token((Token*)NULL,&($1));
			}
		|	nonempty_fun_arg_list ',' expr
			{
			    if(is_true(ID_EXPR,$3.subclass)){
				 use_actual_arg(&($3));
/* 				 use_variable(&($3)); */
			    }
			    $$.next_token = append_token($1.next_token,&($3));
			}
		;

/* 74 not present: type checking not done at this level */

expr	:	log_disjunct

		|	expr tok_EQV log_disjunct
			{
			    binexpr_type(&($1),&($2),&($3)
					 ,&($$));
			}
		|	expr tok_NEQV log_disjunct
			{
			    binexpr_type(&($1),&($2),&($3)
					 ,&($$));
			}
		;

log_disjunct	:	log_term

		|	log_disjunct tok_OR log_term
			{
			    binexpr_type(&($1),&($2),&($3)
					 ,&($$));
			}
		;

log_term	:	log_factor

		|	log_term tok_AND log_factor
			{
			    binexpr_type(&($1),&($2),&($3)
					 ,&($$));
			}
		;

log_factor	:	log_primary

		|	tok_NOT log_primary
			{
			    unexpr_type(&($1),&($2),&($$));
			}
		;

log_primary	:	arith_expr

		|	log_primary tok_relop log_primary
			{
			    binexpr_type(&($1),&($2),&($3)
					 ,&($$));
			}
		;


arith_expr	:	term

		|	'-' term
			{
			    unexpr_type(&($1),&($2),&($$));
			}