fortran.y

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

/* 14 */
block_data_stmt	:	block_data_handle EOS
			{
				  /* form name %DATnn */
			  ++block_data_number;
			  sprintf(unnamed_block_data+4,"%02d"
				  ,block_data_number%100);
			  implied_id_token(&($$),unnamed_block_data);

			  def_function(
				 type_BLOCK_DATA,size_DEFAULT,
				       &($$),(Token*)NULL);
			  current_module_hash=
			    def_curr_module(&($$));
			}
		|	block_data_handle symbolic_name EOS
			{
			  def_function(
				 type_BLOCK_DATA,size_DEFAULT,
				       &($2),(Token*)NULL);
			  current_module_hash=
			    def_curr_module(&($2));
			}
		;

block_data_handle:	tok_BLOCK tok_DATA
			{
			  check_seq_header(&($2));
			}
		|	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 */
			{
			     $$.class = 1;
			     $$.subclass = $1.subclass;
			}
		|	dim_bound_list ',' dim_bound_item
			{
			     $$.class = $1.class + 1; /* one more dimension */
			     $$.subclass = $1.subclass * $3.subclass;
			}
		;

dim_bound_item	:	dim_bound_expr
			{
			      if( datatype_of($1.class) == type_INTEGER
				 && is_true(EVALUATED_EXPR,$1.subclass) )
				$$.subclass = $1.value.integer;
			      else
				$$.subclass = 0;
			}
		|	dim_bound_expr ':' dim_bound_expr
			{	/* avoid getting 0 - 0 + 1 = 1 if bounds nonconstant */
			      if( datatype_of($1.class) == type_INTEGER
				 && is_true(EVALUATED_EXPR,$1.subclass)
				 && datatype_of($3.class) == type_INTEGER
				 && is_true(EVALUATED_EXPR,$3.subclass) )
				$$.subclass = $3.value.integer - $1.value.integer + 1;
			      else
				$$.subclass = 0;
			}
		|	'*'
			{
			     $$.subclass = 0;
			}
		|	dim_bound_expr ':' '*'
			{
			     $$.subclass = 0;
			}
		;

/* 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 blank_common_block EOS
			{
			     implied_id_token(&($$),blank_com_name);
			     def_com_block(&($$), &($2));
#ifdef DEBUG_PARSER
			     if(debug_parser)
				print_comlist("blank common",&($2));
#endif

			}
		|	tok_COMMON common_block_list EOS
		|	tok_COMMON blank_common_block common_block_list EOS
			{
			     implied_id_token(&($$),blank_com_name);
			     def_com_block(&($$),&($2));
#ifdef DEBUG_PARSER
			     if(debug_parser)
				print_comlist("blank common",&($2));
#endif
			}
		;

blank_common_block :
		{
		;
			if( highlight != -1 )
			{
				put_symbol(PAF_COMMON_DEF,NULL,blank_com_name,
					current_filename,
					line_num,
					curr_index,
					0,0,
					(long)0,NULL,NULL,NULL,
					get_comment(current_filename,line_num),
					0,0,0,0);
			}
		}
			common_variable_list
		{ $$ = $2; }
		;

	/*  The following defns allow trailing commas and missing commas in
	    order to tolerate the optional comma before /blockname/.  The
	    token subclass holds comma status to allow errors to be caught. */
common_block_list:	labeled_common_block
			{
			     $$.subclass = $1.subclass;
			}
		|	common_block_list labeled_common_block
			{
			     $$.subclass = $2.subclass;
			     $$.line_num = $2.line_num;
			     $$.col_num = $2.col_num;
			}
		;

labeled_common_block:	common_block_name
			{
				if( highlight != -1 )
				{
					put_symbol(PAF_COMMON_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);
				}
            	current_common_hash = $1.value.integer;
			}
						common_variable_list
			{
            	current_common_hash = -1;
			     def_com_block(&($1),&($3));
			     $$.subclass = $3.subclass;
			     $$.line_num = $3.line_num;
			     $$.col_num = $3.col_num;
#ifdef DEBUG_PARSER
			     if(debug_parser)
				print_comlist("labeled common",&($3));
#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
			{
			    $$.subclass = $1.subclass;
			    $$.next_token = append_token((Token*)NULL,&($1));
			}
		|	common_variable_list common_list_item
			{
			    $$.subclass = $2.subclass;
			    $$.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 */
			     $$.subclass = $1.subclass;
			     make_false(COMMA_FLAG,$$.subclass);
			}
		|	common_entity ','
			{			   /* has comma */
			     $$.subclass = $1.subclass;
			     make_true(COMMA_FLAG,$$.subclass);
   			}
		;

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
		;

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
			{
			    $$.subclass = $2.subclass;
			    $$.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,$$.subclass);
			}
		|	symbolic_name ','
			{			   /* has comma */
			     def_namelist_item(&($1));
			     primary_id_expr(&($1),&($$));
			     make_true(COMMA_FLAG,$$.subclass);
			}
		;

/* 20 */
type_stmt	:	arith_type_name arith_type_decl_list EOS
			{
				current_record_hash = -1;
			}
		|	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
        |   pointer_type_name pointer_type_decl_list EOS
		;

arith_type_name	:	sizeable_type_name
			{
			  current_typesize = size_DEFAULT;
			}
				/* Allow *len to modify some arith types */
		|	sizeable_type_name '*' nonzero_unsigned_int_const
			{
			    current_typesize = $3.value.integer;
#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
			}
				/* Other type disallow *len modifier */
		|	unsizeable_type_name
		;

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_DOUBLE tok_PRECISION
			{
			     current_datatype = type_DP;
			     current_typesize = size_DEFAULT;
			}
		|	tok_DOUBLEPRECISION
			{
			     current_datatype = type_DP;
			     current_typesize = size_DEFAULT;
			}
		|	tok_DOUBLE tok_COMPLEX
			{
			     current_datatype = type_DCOMPLEX;
			     current_typesize = size_DEFAULT;
			}
		|	tok_DOUBLECOMPLEX
			{
			     current_datatype = type_DCOMPLEX;
			     current_typesize = size_DEFAULT;
			}
		|	tok_BYTE /* treate BYTE as a form of integer for now */
			{
			     current_datatype = type_INTEGER;
			     current_typesize = 1;
			}
        |   tok_RECORD '/' symbolic_name '/'
            {
                current_datatype = type_RECORD;
                current_typesize = size_DEFAULT;
				current_record_hash = $3.value.integer;
            }
		;

plain_char_type_name:	tok_CHARACTER
			{
			     current_datatype = type_STRING;
			     current_typesize = 1;
			     integer_context = TRUE;
			}
		;

char_type_name	:	plain_char_type_name '*' len_specification
			{
			     current_typesize = $3.value.integer;
			}
		;

arith_type_decl_list:	arith_type_decl_item
		|	arith_type_decl_list ',' arith_type_decl_item
		;

arith_type_decl_item:	symbolic_name
			{
			     declare_type(&($1),
					  current_datatype,current_typesize);
			}
		|	array_declarator
			{
			     declare_type(&($1),
					  current_datatype,current_typesize);
			}
		;

char_type_decl_list:	char_type_decl_item
		|	char_type_decl_list ',' char_type_decl_item
		;

char_type_decl_item:	symbolic_name
			{
			     declare_type(&($1),
					  current_datatype,current_typesize);
			}
		|	symbolic_name '*' len_specification
			{
			     declare_type(&($1),
					  current_datatype,$3.value.integer);
			}
		|	array_declarator
			{
			     declare_type(&($1),
					  current_datatype,current_typesize);
			}
		|	array_declarator '*' len_specification
			{
			     declare_type(&($1),
					  current_datatype,$3.value.integer);
			}
   		;

pointer_type_name       :       tok_POINTER
                        {
                             current_datatype = type_POINTER;
                             current_typesize = size_DEFAULT;
                        }
                ;

pointer_type_decl_list: pointer_type_decl_item
                |       pointer_type_decl_list ',' pointer_type_decl_item
                ;

pointer_type_decl_item: '(' symbolic_name ',' symbolic_name ')'
                ;

/* 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) {
			    }
			    else {
				implicit_type_given = TRUE;
			    }
			}
				/* IMPLICIT NONE statement */
		|	implicit_handle tok_NONE EOS
			{
			    implicit_flag=FALSE;
				if(implicit_type_given) {
				}
				else {
				    implicit_none = TRUE;
				}
			}
		;

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.subclass;
			   set_implicit_type(current_datatype,current_typesize,
			     		c1,c1);
			}
		|	tok_letter '-' tok_letter
			{
			  int c1 = (int)$1.subclass,
			      c2 = (int)$3.subclass;
			   set_implicit_type(current_datatype,current_typesize,
					c1,c2);
			}
		;


/* 22 */
len_specification:	'(' '*' ')'
			    {$$.value.integer = size_ADJUSTABLE;}
		|	nonzero_unsigned_int_const
			    {$$.value.integer = $1.value.integer;}
		|	'(' int_constant_expr ')'
			    {
			      if(($$.value.integer = $2.value.integer) <= 0 ){
				warning($2.line_num,$2.col_num,
					"invalid length specification");
				msg_tail(": substituting 1");
				$$.value.integer = 1;
			      }
			    }
		;

/* 23 */
parameter_stmt	:	tok_PARAMETER '(' parameter_defn_list ')' EOS
   		;

parameter_defn_list:	parameter_defn_item
		|	parameter_defn_list ',' parameter_defn_item
		;

parameter_defn_item:	symbolic_name {complex_const_allowed = TRUE;} '='
				expr
			{
			     def_parameter(&($1),&($4));
			     primary_id_expr(&($1),&($1));
			     assignment_stmt_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));
			}
		;

/* 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
			{
			     save_variable(&($1));
			}
		|	'/' symbolic_name '/'
			{
			     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
		|	data_value_list ',' data_value
		;

data_value	:	data_constant_value
		|	data_repeat_factor '*' data_constant_value
		;

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