fortran.y

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

/*

Copyright (c) 2000, Red Hat, Inc.

This file is part of Source-Navigator.

Source-Navigator is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as published
by the Free Software Foundation; either version 2, or (at your option)
any later version.

Source-Navigator is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License along
with Source-Navigator; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
MA 02111-1307, USA.



*/

%{

/*
    fortran.y

    Copyright (C) 1992 by Robert K. Moniot.
    This program is free software.  Permission is granted to
    modify it and/or redistribute it.  There is no warranty
    for this program.


	    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.
*/

#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include "ftnchek.h"
#include "symtab.h"
#include <tcl.h>
#include "sn.h"

	/* The following section is for use with bison-derived
	   parser.  Define alloca to be ckalloc 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 ckalloc
#endif /* alloca now defined.  */

extern	int	highlight;
void exit();

#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

int current_datatype,	/* set when parse type_name or type_stmt */
    stmt_sequence_no,   /* set when parsing, reset to 0 at end_stmt */
    control_item_count;	/* count of items in control_info_list */
long current_typesize;	/* for type*len declarations */

extern unsigned prev_stmt_line_num; /* shared with advance */

unsigned true_prev_stmt_line_num;	/* shared with symtab.c */

int current_struct_hash = -1;
int current_common_hash = -1;
int current_record_hash = -1;

int current_module_hash = -1,	/* hashtable index of current module name */
    current_module_type,
    executable_stmt=FALSE,
    prev_stmt_class=0,
		 /* flags for lexer */
    complex_const_allowed=FALSE, /* for help in lookahead for these */
    in_assignment_stmt=FALSE,
    inside_format=FALSE,	/* when inside parens of FORMAT  */
    integer_context=FALSE;	/* says integers-only are to follow */

long exec_stmt_count=0;	/* count of executable stmts in program */
int	cross_scope_type = PAF_SUBR_DEF;

#ifdef DEBUG_PARSER
PRIVATE void
print_comlist(), print_exprlist();
#endif

PRIVATE void	END_processing();

PRIVATE Token *
  append_token();
#if 0
PRIVATE Token *
  append_dot_token();
#endif
PRIVATE int
  do_bounds_type();

static Token *token_dup( Token *t );

		/* Uses of Token fields for nonterminals: */
/*
  1. dim_bound_lists: dimensioning info for arrays:
       token.class = no. of dimensions,
       token.subclass = no. of elements
  2. expressions
       token.value.integer = hash index (of identifier)
       token.class = type_byte = storage_class << 4 + datatype
       token.subclass = flags: CONST_EXPR, LVALUE_EXPR, etc.
  3. common variable lists
       token.subclass = flag: COMMA_FLAG used to handle extra/missing commas
*/

enum {
	SEQ_HEADER = 1,
	SEQ_IMPLICIT,
	SEQ_SPECIF,
	SEQ_STMT_FUN,
	SEQ_EXEC,
	SEQ_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_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_ACCEPT
%token tok_ASSIGN
%token tok_BACKSPACE
%token tok_BLOCK
%token tok_BLOCKDATA
%token tok_BYTE
%token tok_CALL
%token tok_CHARACTER
%token tok_CLOSE
%token tok_COMMON
%token tok_COMPLEX
%token tok_CONTINUE
%token tok_DATA
%token tok_DIMENSION
%token tok_DO
%token tok_DOUBLE
%token tok_DOUBLECOMPLEX
%token tok_DOUBLEPRECISION
%token tok_DOWHILE
%token tok_ELSE
%token tok_ELSEIF
%token tok_END
%token tok_ENDDO
%token tok_ENDFILE
%token tok_ENDIF
%token tok_ENDMAP
%token tok_ENDSTRUCTURE
%token tok_ENDUNION
%token tok_ENTRY
%token tok_EQUIVALENCE
%token tok_EXTERNAL
%token tok_FILE
%token tok_FORMAT
%token tok_FUNCTION
%token tok_GO
%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_MAP
%token tok_NAMELIST
%token tok_NONE
%token tok_OPEN
%token tok_PARAMETER
%token tok_PAUSE
%token tok_POINTER
%token tok_PRECISION
%token tok_PRINT
%token tok_PROGRAM
%token tok_READ
%token tok_REAL
%token tok_RECORD
%token tok_RETURN
%token tok_REWIND
%token tok_SAVE
%token tok_STOP
%token tok_STRUCTURE
%token tok_SUBROUTINE
%token tok_UNION
%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 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. */
			  if(current_module_hash == -1) {
			    implied_id_token(&($1),unnamed_prog);
			    def_function(
				type_PROGRAM,size_DEFAULT,&($1),(Token*)NULL);
			    current_module_hash =
			      def_curr_module(&($1));
			    current_module_type = type_PROGRAM;
			  }

					/* Handle END statement */
			  if(curr_stmt_class == tok_END) {
			    if(prev_stmt_class != tok_RETURN)
			      do_RETURN(current_module_hash,&($1));
			    END_processing(&($$));
			  }
			  prev_stmt_class = curr_stmt_class;
			  integer_context = 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
		;

stmt		:	tok_label unlabeled_stmt
			{
#ifdef CHECK_LABELS
			  def_label(&($1));
#endif
			}
		|	unlabeled_stmt
		;

unlabeled_stmt	:	subprogram_header
			{
			    exec_stmt_count = 0;
			    executable_stmt = FALSE;
			}
		|	specification_stmt
			{
			    executable_stmt = FALSE;
			}
		|	executable_stmt
			{	/* handle statement functions correctly */
			  if(is_true(STMT_FUNCTION_EXPR, $1.subclass)
				     && stmt_sequence_no <= SEQ_STMT_FUN) {
			    stmt_sequence_no = SEQ_STMT_FUN;
			    executable_stmt = FALSE;
			  }
			  else {
			    stmt_sequence_no = SEQ_EXEC;
			    ++exec_stmt_count;
			    executable_stmt = TRUE;
			  }
			}
		|	restricted_stmt
			{
			    stmt_sequence_no = SEQ_EXEC;
			    ++exec_stmt_count;
			    executable_stmt = TRUE;
			}
		|	error EOS
			{
			    executable_stmt = TRUE;
			    if(stmt_sequence_no == 0)
			      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 */
			    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
		;

unlabeled_end_stmt:	tok_END EOS
		;

include_stmt	:	tok_INCLUDE tok_string EOS
 			{
#ifdef ALLOW_INCLUDE
 			  open_include_file($2.value.string);
#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;
			     }
			}
		|	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);
			     }
			}
		|	implicit_stmt
			{
			  check_stmt_sequence(&($1),SEQ_IMPLICIT);
			}
		|	data_stmt
			{
			     if(stmt_sequence_no < SEQ_STMT_FUN) {
				stmt_sequence_no = SEQ_STMT_FUN;
		 	     }
			}
		|	specif_stmt
			{
			  check_stmt_sequence(&($1),SEQ_SPECIF);
			}
		;

anywhere_stmt	:	entry_stmt
		|	format_stmt
		;

specif_stmt	:	dimension_stmt
		|	equivalence_stmt
		|	common_stmt
		|	namelist_stmt
		|	type_stmt
		|	external_stmt
		|	intrinsic_stmt
		|	save_stmt
        |   struct_stmt
		;

struct_stmt :    tok_STRUCTURE '/' symbolic_name '/' EOS
        {
			if( highlight != -1 )
			{
				put_symbol(PAF_CLASS_DEF,NULL,
					hashtab[$3.value.integer].name,
					current_filename,
					$3.line_num,
					$3.curr_index,
					0,0,
					(long)0,NULL,NULL,NULL,
					get_comment(current_filename,$3.line_num),
					0,0,0,0);
			}
            current_struct_hash = $3.value.integer;
        }
            struct_list tok_ENDSTRUCTURE EOS
        {
            current_struct_hash = -1;
        }
        ;

struct_list     :       struct_item
                |       struct_list struct_item
                ;

struct_item     :       type_stmt
                ;


/* 7 */
executable_stmt:		/* Allowed in logical IF */
			transfer_stmt
		|	nontransfer_stmt
		;

transfer_stmt	:	unconditional_goto
		|	assigned_goto
		|	arithmetic_if_stmt
		|	stop_stmt
		|	return_stmt
		;

nontransfer_stmt:	assignment_stmt
		|	assign_stmt
		|	computed_goto	/* fallthru allowed */
		|	continue_stmt
		|	pause_stmt
		|	read_stmt
		|	accept_stmt
		|	write_stmt
		|	print_stmt
		|       type_output_stmt
		|	rewind_stmt
		|	backspace_stmt
		|	endfile_stmt
		|	open_stmt
		|	close_stmt
		|	inquire_stmt
		|	call_stmt
		;

restricted_stmt:		/* Disallowed in logical IF */
			restricted_nontransfer_stmt
		|	else_or_endif_stmt
		;

restricted_nontransfer_stmt:
			logical_if_stmt
		|	block_if_stmt
		|	do_stmt
		|	enddo_stmt
		;

else_or_endif_stmt:	else_if_stmt
		|	else_stmt
		|	end_if_stmt
		;

/* 8 */
prog_stmt	:	tok_PROGRAM {check_seq_header(&($1));}
				 symbolic_name EOS
			{
			     def_function(
				type_PROGRAM,size_DEFAULT,&($3),(Token*)NULL);
			     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
		:	typed_function_handle symbolic_name EOS
			{
			 def_function(
				current_datatype,current_typesize,
				      &($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,
				      &($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
			{
			 def_function(
				type_UNDECL,size_DEFAULT,&($2),(Token*)NULL);
			 current_module_hash=
			   def_curr_module(&($2));
			}
		|	plain_function_handle symbolic_name
				'(' dummy_argument_list ')' EOS
			{
			 def_function(
				type_UNDECL,size_DEFAULT,&($2),&($4));
			 current_module_hash=
			   def_curr_module(&($2));
#ifdef DEBUG_PARSER
			 if(debug_parser)
			   print_exprlist("function stmt",&($4));
#endif
			}
		;

typed_function_handle:	type_name tok_FUNCTION
			{
			  check_seq_header(&($2));
			}
		;

plain_function_handle:	tok_FUNCTION
			{
			  check_seq_header(&($1));
			}
		;

type_name	:	arith_type_name
			{
				current_record_hash = -1;
			}
		|	plain_char_type_name
		|	char_type_name
		;


/* 11 not present: see 9 */

/* 12 */

subroutine_stmt
		:	subroutine_handle symbolic_name EOS
			{
			  def_function(
				 type_SUBROUTINE,size_DEFAULT,
				       &($2),(Token*)NULL);
			  current_module_hash=
			    def_curr_module(&($2));
			}
		|	subroutine_handle symbolic_name
				'(' dummy_argument_list ')' EOS
			{
			  def_function(
				 type_SUBROUTINE,size_DEFAULT,&($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),&($$));
			}
		|	'*'
			{
			     $$.class = type_byte(class_LABEL,type_LABEL);
			     $$.subclass = 0;
			}
		;

/* 13 not present: see 9 */