fortran.y

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

		|	'+' term
			{
			    unexpr_type(&($1),&($2),&($$));
			}
		|	arith_expr '+' term
			{
			    binexpr_type(&($1),&($2),&($3)
					 ,&($$));
			}
		|	arith_expr '-' term
			{
			    binexpr_type(&($1),&($2),&($3)
					 ,&($$));
			}
		;

term		:	factor

		|	term '/' factor
			{
			    binexpr_type(&($1),&($2),&($3)
					 ,&($$));
			    if(div_check &&
			       !is_true(CONST_EXPR,$3.subclass)){
				warning($2.line_num,$2.col_num,
					"Possible division by zero");
			    }
			}
		|	term '*' factor
			{
			    binexpr_type(&($1),&($2),&($3)
					 ,&($$));
			}
		;

factor		:	char_expr

		|	char_expr tok_power factor
			{
			    binexpr_type(&($1),&($2),&($3)
					 ,&($$));
			}
		;

char_expr	:	primary

		|	primary '.' char_expr
			{
			    $$.dot_token = token_dup(&($3)); /* rigo */
/* 			    $$.next_token = append_token($1.next_token,&($3)); */
			}
		|	char_expr tok_concat primary
			{
			    binexpr_type(&($1),&($2),&($3)
					 ,&($$));
			}
		;

primary		:	variable_name

		|	array_element_name

		|	function_reference

		|	substring_name

		|	literal_const
			{
			    $$.subclass = 0;
			    make_true(CONST_EXPR,$$.subclass);
			    make_true(PARAMETER_EXPR,$$.subclass);
			    make_true(LIT_CONST,$$.subclass);
			    make_true(EVALUATED_EXPR,$$.subclass);
			}
		|	'(' expr ')'
			{
			    $$ = $2;
				/* (identifier) becomes a non-identifier */
			    if(is_true(LVALUE_EXPR,$2.subclass)) {
				use_variable(&($2));
				make_false(LVALUE_EXPR,$$.subclass);
				make_false(ARRAY_ID_EXPR,$$.subclass);
				make_false(ID_EXPR,$$.subclass);
			    }
			}
		;

				/* Literal constants are numbers, strings
				   holleriths, and logical constants */
literal_const	:	numeric_const
			{
			    /* (class is set in numeric_const productions) */
			    $$.size = size_DEFAULT;
			}
		|	tok_string
			{
			    $$.class = type_byte(class_VAR,type_STRING);
			    /* (size is set in get_string) */
			}
		|	tok_hollerith
			{
			    $$.class = type_byte(class_VAR,type_HOLLERITH);
			    /* (size is set in get_hollerith) */
			    if(port_check && hollerith_check) {
				warning($1.line_num,$1.col_num,
				"hollerith constant may not be portable");
			    }
			}
		|	tok_logical_const
			{
			    $$.class = type_byte(class_VAR,type_LOGICAL);
			    $$.size = size_DEFAULT;
			}
		;

numeric_const	:	tok_integer_const
			{
			    $$.class = type_byte(class_VAR,type_INTEGER);
			}
		|	tok_real_const
			{
			    $$.class = type_byte(class_VAR,type_REAL);
			}
		|	tok_dp_const
			{
			    $$.class = type_byte(class_VAR,type_DP);
			}
		|	tok_complex_const
			{
			    $$.class = type_byte(class_VAR,type_COMPLEX);
			}
		|	tok_dcomplex_const
			{
			    $$.class = type_byte(class_VAR,type_DCOMPLEX);
			}
		;

/* 77 */
integer_expr	:	/* integer */ arith_expr
			{
			    if(is_true(ID_EXPR,$1.subclass)){
				use_variable(&($1));
			    }
			}
		;

/* 78 */
int_real_dp_expr:	/* integer, real, or double */ arith_expr
			{
			    if(is_true(ID_EXPR,$1.subclass)){
				use_variable(&($1));
			    }
			}
		;

/* 79 absent */

/* 80 */
int_constant_expr:	/* integer const */ arith_expr
			{
			    if(is_true(ID_EXPR,$1.subclass)){
				use_variable(&($1));
			    }
			    if( is_true(CONST_EXPR,$1.subclass) ) {
			      if(datatype_of($1.class) == type_INTEGER){
				$$.value.integer = int_expr_value(&($1));
			      }
			    }
			}
		;

/* 81 */
dim_bound_expr	:       /* integer */  arith_expr
			{
			    if(is_true(ID_EXPR,$1.subclass)){
				use_variable(&($1));
			    }

			    if( datatype_of($1.class) != type_INTEGER ){
				$$.value.integer = 0;
			    }
			    else {
			      if( is_true(EVALUATED_EXPR,$1.subclass) )
				$$.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,$$.subclass);
			}
		;

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,$$.subclass);
			}
		;

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.subclass)){
				 use_variable(&($1));
			    }
				/* check subscript exprs for integer type */
			    if(datatype_of($1.class) != type_INTEGER)
			      if(trunc_check)
			         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.subclass))
				  complex_const_allowed=FALSE;
			    $$.size=substring_size(&($1),&($2));
			}

		|	array_element_name substring_interval
			{
			    $$.size=substring_size(&($1),&($2));
			}
		;

substring_lvalue:	scalar_name substring_interval
			{
			    $$.size=substring_size(&($1),&($2));
			}
		|	array_element_lvalue substring_interval
			{
			    $$.size=substring_size(&($1),&($2));
			}
		;
			/* substring interval: limits go into class,subclass */
substring_interval:	'(' ':' ')'
			{
			    $$.class=1;
			    $$.subclass=0; /* 0 means LEN */
			}

		  |	'(' substr_index_expr ':' ')'
			{
			    $$.class=$2.value.integer;
			    $$.subclass=0; /* 0 means LEN */
			}
		  |	'(' ':' substr_index_expr ')'
			{
			    $$.class=1;
			    $$.subclass=$3.value.integer;
			}
		  |	'(' substr_index_expr ':' substr_index_expr ')'
			{
			      $$.class=$2.value.integer;
			      $$.subclass=$4.value.integer;
			}
		  ;

substr_index_expr:	arith_expr
			{
			  if(is_true(ID_EXPR,$1.subclass)){
			    use_variable(&($1));
			  }
				/* check validity and replace nonconst
				   value by size_UNKNOWN. */
			  if(is_true(CONST_EXPR,$1.subclass)) {
			    $$.value.integer=int_expr_value(&($1));
			  }
			  else  /* (no longer need ID hash index) */
			    $$.value.integer=size_UNKNOWN;
			}
		;

/* 90-98 absent: name categories not distinguished */

/* 99 */
variable_name	:	scalar_name
		|	array_name
		;

scalar_name	:	tok_identifier
			{
/* 				printf( "Scalar name: %d <%s>\n" */
/* 					  , $1.value.integer */
/* 					  , hashtab[$1.value.integer].name ); */
			    ref_variable(&($1));
			    primary_id_expr(&($1),&($$));

				if( highlight != -1 && hashtab[$1.value.integer].define )
				{
					put_cross_ref(PAF_REF_TO_CONSTANT,
						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_READ);
				}
			}
		;

array_name	:	tok_array_identifier
			{
/* 				printf( "Array name: <%s>\n", hashtab[$1.value.integer].name ); */
			    ref_variable(&($1));
			    primary_id_expr(&($1),&($$));

				if( highlight != -1 && hashtab[$1.value.integer].define )
				{
					put_symbol(PAF_CONS_DEF,NULL,
						hashtab[$1.value.integer].name,
						current_filename,
						$1.line_num,
						$1.curr_index,
						0,0,
						(long)0,NULL,NULL,NULL,
						get_comment(current_filename,$1.line_num),
						0,0,0,0);
				}
			}
		;


/* symbolic_name refers to a name without making it into an id expr */
symbolic_name	:	tok_identifier
			{
				if( highlight != -1 && hashtab[$1.value.integer].define )
				{
					put_symbol(PAF_CONS_DEF,NULL,
						hashtab[$1.value.integer].name,
						current_filename,
						$1.line_num,
						$1.curr_index,
						0,0,
						(long)0,NULL,NULL,NULL,
						get_comment(current_filename,$1.line_num),
						0,0,0,0);
				}
			}
		|	tok_array_identifier
			{
				if( highlight != -1 && hashtab[$1.value.integer].define )
				{
					put_symbol(PAF_CONS_DEF,NULL,
						hashtab[$1.value.integer].name,
						current_filename,
						$1.line_num,
						$1.curr_index,
						0,0,
						(long)0,NULL,NULL,NULL,
						get_comment(current_filename,$1.line_num),
						0,0,0,0);
				}
			}
		;

/* 100 */
data_constant	:	numeric_const
		|	'-' numeric_const
		|	'+' numeric_const
		|	tok_logical_const
   		|	tok_string
		|	tok_hollerith
		;

/* 101-102 absent */

/* 103 */
nonzero_unsigned_int_const:
			tok_integer_const
			{
			  if($1.value.integer == 0) {
			    warning($1.line_num,$1.col_num,
				    "nonzero integer expected");
			    msg_tail(": substituting 1");
			    $$.value.integer = 1;
			  }
			}
		;

/* 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
			{
				integer_context=FALSE;
				$$.class = type_byte(class_LABEL,type_LABEL);
				$$.subclass = 0;
			}
		;

/* 111-116 absent: lexer handles these */

%%
void
init_parser()			/* 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;
	true_prev_stmt_line_num = 0;
}

		/* Propagate non-integer type if any of DO loop
		   bounds are non-integer. */
PRIVATE int
do_bounds_type(t1,t2,t3)
     Token *t1, *t2, *t3;
{
  int result_class;
       if(datatype_of(t1->class) != type_INTEGER) result_class = t1->class;
  else if(datatype_of(t2->class) != type_INTEGER) result_class = t2->class;
  else if(datatype_of(t3->class) != type_INTEGER) result_class = t3->class;
  else result_class = t1->class;
  return result_class;
}


/* Debugging routine: prints the expression list of various productions */

#ifdef DEBUG_PARSER
PRIVATE void
print_exprlist(s,t)
	char *s;
	Token *t;
{

	fprintf(list_fd,"\n%s arglist: ",s);

	if(t == NULL)
		fprintf(list_fd,"(empty)");
	else {
  	    while( (t=t->next_token) != NULL) {
		  fprintf(list_fd,"%s ",type_name[datatype_of(t->class)]);
		  if( is_true(ID_EXPR,t->subclass) )
			fprintf(list_fd,"(%s) ",token_name(*t));
	    }
	}
}
#endif /* DEBUG_PARSER */

#ifdef DEBUG_PARSER
PRIVATE void
print_comlist(s,t)
	char *s;
	Token *t;
{

	fprintf(list_fd,"\n%s varlist: ",s);

	if(t == NULL)
		fprintf(list_fd,"(empty)");
	else {
  	    while( (t=t->next_token) != NULL) {
		  fprintf(list_fd,"%s ",type_name[datatype_of(t->class)]);
		  if( is_true(ID_EXPR,t->subclass) )
			fprintf(list_fd,"(%s) ",token_name(*t));
		}
	  }
}
#endif /* DEBUG_PARSER */

/* After having parsed prog_stmt, function_stmt, subroutine_stmt,
   block_data_stmt, the stmt_sequence_no is set to the value SEQ_HEADER.
*/

void
check_seq_header(t)
     Token *t;
{
	if(stmt_sequence_no >= SEQ_HEADER) {
	   END_processing(t);
	}
	stmt_sequence_no = SEQ_HEADER;
}

void
check_stmt_sequence(t,seq_num)
     Token *t;
     int seq_num;
{
    if(stmt_sequence_no <= seq_num) {
	stmt_sequence_no = seq_num;
    }
}

	/* 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
END_processing(t)
	Token *t;
{
  if(current_module_hash != -1) {
	if(do_list && t != (Token *)NULL)
	    flush_line_out(t->line_num);
/* 	check_loose_ends(current_module_hash); */
	process_lists(current_module_hash);
	debug_symtabs();
#ifdef ERROR_MESS
#endif
	print_loc_symbols(current_module_hash);
	init_symtab();
  }
  exec_stmt_count = 0;
  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;
}

		/* Routine to add token t to the front of a token list. */
PRIVATE Token *
append_token(tlist,t)
     Token *tlist, *t;
{
	Token *tcopy;
	if((tcopy=new_token()) == (Token *)NULL){
	  oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
#ifdef LARGE_MACHINE
"Out of token space\nRecompile me with larger TOKENSPACESZ value"
#else
"Out of token space\nRecompile me with LARGE_MACHINE option"
#endif
		       );
	}

	*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 add token t to the front of a dot_token list. */
#if 0
PRIVATE Token *
append_dot_token(tlist,t)
     Token *tlist, *t;
{
	Token *tcopy;
	if((tcopy=new_token()) == (Token *)NULL){
	  oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
#ifdef LARGE_MACHINE
"Out of token space\nRecompile me with larger TOKENSPACESZ value"
#else
"Out of token space\nRecompile me with LARGE_MACHINE option"
#endif
		       );
	}

	*tcopy = *t;		/* make permanent copy of token */
	tcopy->dot_token = tlist; /* link it onto front of list */
	return tcopy;		/* return it as new tlist */
}
#endif

char *print_line_num( int line_num )
{
	static char ac[100];

	if( strcmp( current_filename, top_filename ))
	{
		sprintf( ac, "%d %s", line_num, current_filename );
	}
	else
	{
		sprintf( ac, "%d", line_num );
	}

	return ac;
}

static Token *token_dup( Token *t )
{
	Token *tcopy;

	if((tcopy=new_token()) == (Token *)NULL){
	  oops_message(OOPS_FATAL,line_num,NO_COL_NUM,
#ifdef LARGE_MACHINE
"Out of token space\nRecompile me with larger TOKENSPACESZ value"
#else
"Out of token space\nRecompile me with LARGE_MACHINE option"
#endif
		       );
	}

	*tcopy = *t;		/* make permanent copy of token */

	return tcopy;
}

#ifdef NO_DATABASE

int put_cross_ref( int typ, int scope_type, int scope, char *name1, char *name2, char *name3, char *name4, char *filename, int lineno, int mode )
{
	FILE *sym_fp = stdout;

	fprintf( sym_fp,"%d", typ );
	fprintf( sym_fp," %d #", scope );
	if( name1 ) fprintf( sym_fp," %s", name1 );
	if( name2 ) fprintf( sym_fp," %s", name2 );
	if( name3 ) fprintf( sym_fp," %s", name3 );
	if( name4 ) fprintf( sym_fp," %s", name4 );
	if( filename ) fprintf( sym_fp," %s", filename );
	fprintf( sym_fp," %d", lineno );
	fprintf( sym_fp," %d", mode );
	fprintf( sym_fp, "\n" );
	return 0;
}

int put_symbol( int typ, char *function, char *name, char *filename, int lineno , int colpos, long l, void *x1, void *x2, void *x3)
{
	FILE *sym_fp = stdout;

	fprintf( sym_fp,"%d #", typ );
	if( function ) fprintf( sym_fp," %s", function );
	if( name ) fprintf( sym_fp," %s", name );
	if( filename ) fprintf( sym_fp," %s", filename );
	fprintf( sym_fp," %d.%d", lineno,colpos);
	fprintf( sym_fp, "\n" );
}

int put_symbol_comment( char *class, char *function, char *current_filename, char *comment, int start_line, int start_char, int end_line, int end_char )
{
	printf( "comment: <%s>\n", comment );
}

int put_comment( char *class_name, char *func_name, char *filename, char *comment, int line_num, int col_num )
{
}

#endif