forlex.c

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

		dble_size=TRUE;
			/*fallthru*/
	   case tok_real_const:
		token->value.dbl = sign*token->value.dbl;
		break;
	}

	while(iswhitespace(curr_char))
	  advance();


	comma_line_num = line_num;
	comma_col_num = col_num;
	bi_advance();		/* skip over the comma */

	if(curr_char == '+' || curr_char == '-') {
	     if(curr_char == '-') sign = -1.0;
	     bi_advance();
	}
#ifdef DEBUG_FORLEX
if(debug_lexer){
fprintf(list_fd,"\n,");
if(sign < 0.0) fprintf(list_fd," -");
}
#endif
	get_number(&imag_part);
	imag_dble_size = (imag_part.class == tok_dp_const);

	if(dble_size != imag_dble_size) {
	    warning(comma_line_num,comma_col_num,
		  "different precision in real and imaginary parts");
	}
	else if(f77_standard) {
	  if(dble_size)
	    warning(token->line_num,token->col_num,
		  "nonstandard double precision complex constant");
	}

	dble_size = (dble_size || imag_dble_size);

	while(iswhitespace(curr_char))
	   advance();

	advance();	/* skip over final paren */

	if(dble_size)
	  token->class = tok_dcomplex_const;
	else
	  token->class = tok_complex_const;
#ifdef DEBUG_FORLEX
if(debug_lexer)
fprintf(list_fd,"\n)");
#endif

}

#ifdef TYPELESS_CONSTANTS
		/* Routine to get constants of the forms:
			B'nnnn' 'nnnn'B  -- binary
			O'nnnn' 'nnnn'O  -- octal
		   	X'nnnn' Z'nnnn' 'nnnn'X 'nnnn'Z  -- hex
		   No check of whether digits are less than base.
		   Nonstandard warning is issued here since the constant
		   looks like a normal integer by the time the parser sees it.
		 */
PRIVATE void
get_binary_const(token,c,s)
     Token *token;
     int c;			/* base character: madeupper'ed by caller */
     char *s;			/* string of digits, or NULL */
{
  long value=0;
  int base;
  if(c == 'O')  base = 8;
  else if(c == 'X' || c == 'Z')  base = 16;
  else if(c == 'B') base = 2;
  else {
    syntax_error(token->line_num,token->col_num,
		 "Unknown base for typeless constant -- octal assumed");
    base = 8;
  }
	/* Two forms: X'nnnn' and 'nnnn'X. For the first, string has not
	   been scanned yet, and s is null.  For second, s=digit string. */
  if(s == NULL) {
    bi_advance();		/* gobble the leading quote */
    while(ishex(curr_char)){
      value = value*base + HEX(curr_char);
      bi_advance();
    }
    if(curr_char != '\'') {
      syntax_error(line_num,col_num, "Closing quote missing");
    }
    else
      advance();		/* gobble the trailing quote */
  }
  else {			/* Use the given string */
    while(*s != '\0') {
      if(!isspace(*s))		/* skip blanks */
	value = value*base + HEX(*s);
      s++;
    }
  }

  token->class = tok_integer_const;
  token->value.integer = value;

  if(f77_standard) {
    nonstandard(token->line_num,token->col_num);
  }

#ifdef DEBUG_FORLEX
if(debug_lexer)
fprintf(list_fd,"\nInteger const:\t\t%d",token->value.integer);
#endif

}/*get_binary_const*/

#endif/*TYPELESS_CONSTANTS*/


PRIVATE void
get_punctuation(token)
	Token *token;
{
	initial_flag = FALSE;
	closeup();
	if(curr_char == '*' && next_char == '*') {
		token->class = tok_power;
		advance();
	}
	else if(curr_char == '/' && next_char == '/' ) {
		token->class = tok_concat;
		advance();
	}
		/* paren can be the start of complex constant if everything
		   is just right. Maybe more tests needed here. */
	else if(complex_const_allowed && curr_char == '(' &&
	     (  (prev_token_class<256 && ispunct(prev_token_class))
	      || prev_token_class == tok_relop
	      || prev_token_class == tok_power )
	     && looking_at_cplx()) {
		get_complex_const(token);
		return;
	}
	else
		token->class = curr_char;

	advance();

#ifdef DEBUG_FORLEX
if(debug_lexer) {
	if(token->class == EOS)
		fprintf(list_fd,"\n\t\t\tEOS");
	else if(token->class == tok_power)
		fprintf(list_fd,"\nPunctuation:\t\t**");
	else if(token->class == tok_concat)
		fprintf(list_fd,"\nPunctuation:\t\t//");
	else
		fprintf(list_fd,"\nPunctuation:\t\t%c",token->class);
 }
#endif
} /* get_punctuation */


PRIVATE void
get_simple_punctuation(token)
	Token *token;
{
		/* Like get_punctuation but lacks special cases.  Just
		   gets the punctuation character.  */

	token->class = curr_char;
	advance();
#ifdef DEBUG_FORLEX
if(debug_lexer) {
	if(token->class == EOS)
		fprintf(list_fd,"\n\t\t\tEOS");
	else
		fprintf(list_fd,"\nPunctuation:\t\t%c",token->class);
}
#endif
} /* get_simple_punctuation */


PRIVATE void
get_string(token)       /* Gets string of form 'aaaa' */
	Token *token;
{
	int i,len,last_col_num;
	int first_char = curr_char;

/* String consts are not stored unless the macro name LEX_STORE_STRINGS
   is defined. */
#ifdef LEX_STORE_STRINGS
	char *s;
	char tmpstr[MAXSTR+1];
#else
	char *s = "Not stored";
#endif

	initial_flag = FALSE;
	inside_string = TRUE;
	last_col_num=col_num;
	advance();      /* Gobble leading quote */
	i = len = 0;
	for(;;) {
		while(curr_char == EOL) {
			/* Treat short line as if extended with blanks */
		    int col;
		    for(col=last_col_num; col<max_stmt_col; col++) {
#ifdef LEX_STORE_STRINGS
		      if(i < MAXSTR)
			tmpstr[i++] = ' ';
#endif
		      ++len;
		    }
		  last_col_num=col_num;
		  advance();
		}
		if(curr_char == EOS || curr_char == EOF) {
			yyerror("Closing quote missing from string");
			break;
		}
		if(curr_char == first_char) {
		  	inside_string = FALSE;/* assume so for now */
				    /* Handle possible continuation */
			if(next_char == EOL && col_num == max_stmt_col)
			  advance();

			last_col_num=col_num;
			advance();

			if(curr_char == first_char) { /* '' becomes ' in string */
				inside_string = TRUE; /* not a closing quote */
#ifdef LEX_STORE_STRINGS
				if(i < MAXSTR)
					tmpstr[i++] = curr_char;
#endif
				++len;
				last_col_num=col_num;
				advance();
			}
			else {
				break;  /* It was a closing quote after all */
			}
		}
		else {
#ifdef LEX_STORE_STRINGS
			if(i < MAXSTR)
				tmpstr[i++] = curr_char;
#endif
			++len;
			last_col_num=col_num;
			advance();
		}
	}
#ifdef LEX_STORE_STRINGS
	tmpstr[i++] = '\0';
#ifdef TYPELESS_CONSTANTS
				/* Watch for const like 'nnn'X */
	if(!inside_format) {
	  while(iswhitespace(curr_char))
	    advance();
	  if(isaletter(curr_char)) {
	    int c=makeupper(curr_char);
	    advance();		/* Gobble the base character */
	    get_binary_const(token,c,tmpstr);
	    return;
	  }
	}
#endif
	if( (s=(char *)ckalloc(i)) == (char *)NULL ) {
	  oops_message(OOPS_NONFATAL,line_num,col_num,
		       "Out of string space for character constant");
	}
	else {
		memset (s, 0, i);
		(void) strcpy(s,tmpstr);
	}
#endif
	if(len == 0) {
		warning(line_num,col_num,
			"Zero-length string not allowed\n");
		len = 1;
	}

	inside_string = FALSE;

	token->class = tok_string;
	token->value.string = s;
	token->size = len;
				/* Under -port warn if char size > 255 */
	if(port_check) {
	  if(len > 255)
	    nonportable(line_num,col_num,
			"character constant length exceeds 255");
	}

#ifdef DEBUG_FORLEX
	if(debug_lexer)
		fprintf(list_fd,"\nString:\t\t\t%s",s);
#endif
} /* get_string */


/* End of Forlex module */

/*
II. Advance
*/

/* advance.c:

	Low-level input routines for Fortran program checker.

	Shared functions defined:
		init_scan()	Initializes an input stream.
		finish_scan()	Finishes processing an input stream.
		advance()	Reads next char, removing comments and
				handling continuation lines.
			looking_at_x Handles lookahead up to end of line:
		looking_at_cplx() Identifies complex constant.
		looking_at_keywd() Identifies assgnmt stmts vs keywords.
		looking_at_relop() Distinguishes .EQ. from .Eexp .
		flush_line_out(n) Prints lines up to line n if not already
				printed, so error messages come out looking OK.
*/


	/* Define tab stops: nxttab[col_num] is column of next tab stop */

#define do8(X) X,X,X,X,X,X,X,X
PRIVATE int nxttab[]={ 0, do8(9), do8(17), do8(25), do8(33),
		do8(41), do8(49), do8(57), do8(65), do8(73), do8(81)};

PRIVATE int
	prev_comment_line,	/* True if previous line was comment */
	curr_comment_line,	/* True if current line is comment */
	noncomment_line_count,	/* Number of noncomment lines read so far */
	line_is_printed,	/* True if line has been flushed (printed) */
	prev_line_is_printed,	/* True if line has been flushed (printed) */
	sticky_EOF;		/* Signal to delay EOF a bit for sake
				   of error messages in include files. */
PRIVATE unsigned
	prev_line_num;		/* line number of previous input line */

unsigned prev_stmt_line_num;	/* line number of previous noncomment */

PRIVATE char
	lineA[MAXLINE+1],lineB[MAXLINE+1],  /* Buffers holding input lines */
	*prev_line,*line;		    /* Pointers to input buffers */

PRIVATE char
	*getstrn();

#ifdef UNIX_CPP
PRIVATE int
	take_cpp_line();	/* Reads #line directives and ignores others */
#endif

	/* Lookahead routines that scan the input
	   line for various things.  The is_whatever routines take a
	   string as argument and return TRUE if it satisfies the
	   criterion. The skip_whatever routines take an index and
	   string as argument and return the index of the next
	   nonspace character in the string after the expected thing,
	   which must be there in a syntactically correct program.
	   The given index points at the character after a known
	   lead-in (except for see_a_number, which can be given the
	   index of 1st char of number).  The see_whatever routines
	   are similar but return -1 if the expected thing is not
	   seen, which it need not be. */

PRIVATE int
	is_comment(), is_continuation();
#if 0
PRIVATE int, is_overlength();
#endif

PRIVATE int
	see_a_number(), see_dowhile(), see_expression(), see_keyword();

PRIVATE int
	skip_balanced_parens(), skip_idletters(), skip_quoted_string(),
	skip_hollerith();

#ifdef ALLOW_INCLUDE
/* Definition of structure for saving the input stream parameters while
   processing an include file.
*/

typedef struct {
  FILE     *yyin;
  char	   *fname;
  char     line[MAXLINE];  /* MAXLINE is defined in ftnchek.h */
  int      curr_char;
  int      curr_index;
  int      next_char;
  int	   next_index;
  int	   col_num;
  int	   next_col_num;
  int	   line_is_printed;
  int	   do_list;
  unsigned line_num;
  unsigned next_line_num;
} IncludeFileStack;

PRIVATE IncludeFileStack include_stack[MAX_INCLUDE_DEPTH];
PRIVATE FILE* find_include(), *fopen_with_path();

#endif /*ALLOW_INCLUDE*/

PRIVATE void
	init_stream();
PRIVATE int
	push_include_file(),pop_include_file();

#ifdef ALLOW_INCLUDE		/* defns of include-file handlers */

PRIVATE int
push_include_file(fname,fd)
	char *fname;
	FILE *fd;
{
	 if (incdepth == MAX_INCLUDE_DEPTH) {
	   oops_message(OOPS_NONFATAL,line_num,NO_COL_NUM,
			"include files nested too deep");
	   return FALSE;
	 }

#ifdef DEBUG_INCLUDE
if(debug_include){
fprintf(list_fd,"\npush_include_file: curr_char=%c (%d)",curr_char,curr_char);
}
#endif

	 put_symbol (PAF_INCLUDE_DEF, NULL, fname, current_filename, line_num,
		     col_num, next_line_num, col_num+7, 0, NULL, NULL, NULL, NULL, line_num,
		     col_num, next_line_num, col_num+7);

	 include_stack[incdepth].yyin = yyin;
	 yyin = fd;

	 include_stack[incdepth].fname = current_filename;
	 current_filename = fname;

	 strcpy(include_stack[incdepth].line,line);
	 include_stack[incdepth].curr_char = curr_char;
	 include_stack[incdepth].curr_index = curr_index;
	 include_stack[incdepth].next_char = next_char;
	 include_stack[incdepth].next_index = next_index;
	 include_stack[incdepth].col_num = col_num;
	 include_stack[incdepth].next_col_num = next_col_num;
	 include_stack[incdepth].line_is_printed = line_is_printed;
	 include_stack[incdepth].line_num = line_num;
	 include_stack[incdepth].next_line_num = next_line_num;
	 include_stack[incdepth].do_list = do_list;

	 incdepth++;

	 init_stream();

	 return TRUE;
}

PRIVATE int
pop_include_file()
{
#ifdef DEBUG_INCLUDE
if(debug_include){
fprintf(list_fd,"\npop_include_file: line %u = %s depth %d",line_num,line,
incdepth);
}
#endif

	 if (incdepth == 0) {	/* Stack empty: no include file to pop. */
	   return FALSE;
	 }
	 incdepth--;


	 if(do_list) {
	   flush_line_out(next_line_num);
	   fprintf(list_fd,"\nResuming file %s:",
		   include_stack[incdepth].fname);
	 }

	 fclose(yyin);
	 yyin = include_stack[incdepth].yyin;

	 current_filename = include_stack[incdepth].fname;

	 strcpy(line,include_stack[incdepth].line);
	 curr_char = include_stack[incdepth].curr_char;
	 curr_index = include_stack[incdepth].curr_index;
	 next_char = include_stack[incdepth].next_char;
	 next_index = include_stack[incdepth].next_index;
	 col_num = include_stack[incdepth].col_num;
	 next_col_num = include_stack[incdepth].next_col_num;
	 line_is_printed = include_stack[incdepth].line_is_printed;
	 line_num = include_stack[incdepth].line_num;
	 next_line_num = include_stack[incdepth].next_line_num;
	 do_list = include_stack[incdepth].do_list;

	 curr_comment_line = FALSE;
	 prev_line_is_printed = TRUE;
	 initial_flag = TRUE;
	 sticky_EOF = TRUE;

	 return TRUE;
}


void
open_include_file(fname)
     char *fname;
{
  FILE *fd;
#ifdef VMS_INCLUDE
  int list_option=FALSE;	/* /[NO]LIST qualifier: default=NOLIST */
#endif /*VMS_INCLUDE*/

  if( highlight == -1 ) return;