forlex.c

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

						get_comment(current_filename,my_line_num),
						0,0,0,0);
				}
			}
        }
	}
}

#endif

PRIVATE void
get_dot(token)
	Token *token;
{
	closeup();		/* Advance till nonspace char in next_char */

	if(isadigit(next_char))
		get_number(token);		/* Numeric const */
	else if(isaletter(next_char))
		get_dotted_keyword(token);	/* .EQ. etc. */
	else
		get_simple_punctuation(token);	/* "." out of place */
}

#define MAX_DOTTED_KEYWD (sizeof(".FALSE.")/sizeof(char))

struct {
	char *name;
	int class,subclass;
 } dotted_keywords[]={
			{"EQ",tok_relop,relop_EQ},
			{"NE",tok_relop,relop_NE},
			{"LE",tok_relop,relop_LE},
			{"LT",tok_relop,relop_LT},
			{"GE",tok_relop,relop_GE},
			{"GT",tok_relop,relop_GT},
			{"AND",tok_AND,0},
			{"OR",tok_OR,0},
			{"NOT",tok_NOT,0},
			{"FALSE",tok_logical_const,FALSE},
			{"TRUE",tok_logical_const,TRUE},
			{"EQV",tok_EQV,0},
			{"NEQV",tok_NEQV,0},
			{NULL,0,0}
		    };


PRIVATE void
get_dotted_keyword(token)
	Token *token;
{
	char s[8];
	int i=0,
	    has_embedded_space,	/* Spaces inside keyword */
	    space_seen_lately;	/* Flag for catching embedded space */
	int j=0;

	initial_flag = FALSE;
				/* Watch for embedded space, but not
				   between dots and letters of keyword.
				   I.e.  ". eq ." is OK, but not ".e q." */
	has_embedded_space = FALSE;
	space_seen_lately = FALSE;

	bi_advance();      /* gobble the initial '.' */

	Symbol_line_num   = line_num;
	Symbol_col_num    = col_num;
	Symbol_curr_index = curr_index;

/* 	while(isaletter(curr_char)) { */
	while(isidletter(curr_char) || isadigit(curr_char)) {
	  if( i<7 )
	    s[i++] = makeupper(curr_char);

#ifdef CASE_SENSITIVE
	  acSymbol[j++] = curr_char;
#else
	  acSymbol[j++] = makeupper(curr_char);
#endif

	  if(space_seen_lately)
	    has_embedded_space = TRUE;

	   bi_advance();

	   space_seen_lately = iswhitespace(prev_char);
	}
	s[i]        = '\0';
	acSymbol[j] = '\0';

/* 	printf( "***** <%s>\n", acSymbol ); */

	for(i=0; dotted_keywords[i].name != NULL; i++) {
		if(strcmp(s,dotted_keywords[i].name) == 0) {
			token->class = dotted_keywords[i].class;
			token->subclass = dotted_keywords[i].subclass;
			token->value.string = dotted_keywords[i].name;
			if(curr_char != '.') {
				yyerror("Badly formed logical/relational operator or constant");
			}
			else {
				advance();      /* gobble the final '.' */
				acSymbol[0] = 0;
			}
			return;
		}
	}

	/* keyword not found */

	token->class = '.';

} /* get_dotted_keyword */

static void get_edit_descriptor(token)
Token *token;
{
    while( curr_char != EOS && curr_char != EOF )
    {
	advance();
    };
    token->class = EOS;
}

#ifdef rigo
PRIVATE void
get_edit_descriptor(token)
	Token *token;
{
    int i=0,c;
    long repeat_spec;
    char s[MAXIDSIZE+1];	/* string holding the descriptor: NOT STORED */

    if(isadigit(curr_char)) {	/* Digit: repeat spec or holl or kP or nX */
      repeat_spec = 0;
      do {
	repeat_spec = repeat_spec*10L + (long)BCD(curr_char);
	if( makeupper(next_char) == 'H' )
	  inside_hollerith = TRUE;/* get ready for hollerith*/
	bi_advance();
      } while(isadigit(curr_char));

      if( makeupper(curr_char) == 'H' ) {
				/* nH... pass off to hollerith routine */
	get_hollerith(token, (int)repeat_spec);
	return;
      }
      else {
				/* Otherwise it is a repeat spec or the
				   numeric part of kP or nX which we treat
				   as repeat specs too */
	token->class = tok_integer_const;
	token->value.integer = repeat_spec;
#ifdef DEBUG_FORLEX
if(debug_lexer)
fprintf(list_fd,"\nInteger const:\t\t%d",repeat_spec);
#endif
      }
    }/* end if digit */

    else if(isaletter(curr_char)) {
      c = makeupper(curr_char);
      s[i++] = c;
      bi_advance();
      switch(c) {

	case 'P':		/* P of kP  k seen previously */
	  if(prev_token_class != tok_integer_const) {
	    if(f77_standard){
	      nonstandard(token->line_num,token->col_num);
	      msg_tail(": P must follow a number");
	    }
	  }
	  break;

	case 'X':		/* X or nX */
	  break;

	case 'S':		/* S or SP or SS */
	  c = makeupper(curr_char);
	  if(c == 'S' || c == 'P') {
	    s[i++] = c;
	    bi_advance();
	  }
	  break;

	case 'B':		/* BN or BZ */
	  c = makeupper(curr_char);
	  if(c == 'N' || c == 'Z') {
	    s[i++] = c;
	    bi_advance();
	  }
	  else {
	    if(f77_standard){
	      nonstandard(token->line_num,token->col_num);
	      msg_tail(": N or Z expected after B");
	    }
	  }
	  break;

	case 'T':		/* Tc or TLc or TRc */
	  c = makeupper(curr_char);
	  if(c == 'L' || c == 'R') {
	    s[i++] = c;
	    bi_advance();
	  }
	  goto get_w_d;
				/* Iw, Ew.c and similar forms */
	case 'A':	case 'D':	case 'E':
	case 'F':	case 'G':	case 'L':
	case 'I':
get_w_d:				/* Get the w field if any */
	  while( isadigit(curr_char) ){
	    if(i < MAXIDSIZE)	/* Store it temporarily (up to a point) */
	      s[i++] = curr_char;
	    bi_advance();
	  }
			/* Include any dot followed by number (e.g. F10.5)
			*/
      	  if( curr_char == '.' ) {
	    do {
	      if(i < MAXIDSIZE)
		s[i++] = curr_char;
	      bi_advance();
	    } while( isadigit(curr_char) );
	  }
	  break;

	default:
	  if(f77_standard) {
	    nonstandard(token->line_num,token->col_num);
	    msg_tail(": edit descriptor");
	    s[i] = '\0';
	    msg_tail(s);
	  }
	  goto get_w_d;
      }/*end switch*/

      token->class = tok_edit_descriptor;
      token->value.string = NULL;
      s[i++] = '\0';
#ifdef DEBUG_FORLEX
if(debug_lexer)
fprintf(list_fd,"\nEdit descriptor:\t%s",s);
#endif
    }/*end else if isaletter*/

				/* Apostrophe means a string */
    else if( curr_char == '\'' || curr_char == '"' ) {
      get_string(token);
    }
				/* Otherwise it is mere punctuation. Handle
				   it here ourself to avoid complications. */
    else {
      get_simple_punctuation(token);
    }
}
#endif

PRIVATE void
get_hollerith(token,n)  /* Gets string of form nHaaaa */
	Token *token;
	int n;
{
	int i,last_col_num;
/* Holl. consts are not stored unless the macro name LEX_STORE_HOLLERITHS
   is defined. */
#ifdef LEX_STORE_HOLLERITHS
	int strsize=n;
	char *s;
#else
       	char *s = "Not stored";
#endif
	initial_flag = FALSE;
#ifdef LEX_STORE_HOLLERITHS
	if( (s=(char *)ckalloc((unsigned)(strsize+1))) == (char *)NULL ) {
	  oops_message(OOPS_NONFATAL,line_num,col_num,
		       "Out of string space for hollerith constant");
	  strsize=0;
	}
	memset (s, 0, (strsize+1));
#endif
	if(n==1)
	  inside_hollerith=FALSE;/* turn off flag ahead of next_char */
	advance();/* Gobble the 'H' */

	last_col_num = col_num;
	for(i=0; i<n; i++) {
	  while(curr_char == EOL) {
			/* Treat short line as if extended with blanks */
	    int col;
	    for(col=last_col_num; i<n && col<max_stmt_col; i++,col++) {
#ifdef LEX_STORE_HOLLERITHS
	      if(i < strsize)
		s[i] = ' ';
#endif
	    }
	    last_col_num = col_num;
	    advance();
	  }
	  if(i==n) break;

	  if(curr_char == EOS || curr_char == EOF) {
	    int col;
	    for(col=last_col_num; i<n && col<max_stmt_col; i++,col++) {
#ifdef LEX_STORE_HOLLERITHS
	      if(i < strsize)
		s[i] = ' ';
#endif
	    }
#ifdef LEX_STORE_HOLLERITHS
	    strsize=i;		/* in case it did not fill up */
#endif
	    break;
	  }
	  else {
#ifdef LEX_STORE_HOLLERITHS
	    s[i] = curr_char;
#endif
	    last_col_num = col_num;
	    if(i==n-2)/* turn flag off ahead of next_char*/
	      inside_hollerith = FALSE;
	    advance();
	  }
	}

#ifdef LEX_STORE_HOLLERITHS
	if(strsize > 0)
	  s[strsize] = '\0';
#endif

	inside_hollerith = FALSE;
	token->class = tok_hollerith;
	token->value.string = s;
	token->size = n;
#ifdef DEBUG_FORLEX
	if(debug_lexer)
		fprintf(list_fd,"\nHollerith:\t\t%s",s);
#endif

} /* get_hollerith */

#include "keywords.h"

	/* get_identifier reads a string of characters satisfying
	   isidletter.  As they are read and as long as they are
	   alphabetic, it looks for a match to a keyword, and
	   whenever one is found, checks with is_keyword to see
	   if the context is right.  If so, it returns the keyword.
	   Otherwise it keeps going and eventually returns the id.
	 */
PRIVATE void
get_identifier(token)
	Token *token;
{
	char s_upper[MAXIDSIZE+1];	/* string holding the identifier */
	char s_lower[MAXIDSIZE+1];	/* string holding the identifier */
	int c,		/* Uppercase version of current letter */
	    preceding_c,/* Char preceding latest id */
	    has_embedded_space,	/* Spaces inside keyword or id */
	    space_seen_lately,	/* Flag for catching embedded space */
	    i,		/* Index in s of current letter */
	    lo,hi,	/* Indices in keyword table where match may be */
	    klen,	/* Length of id read so far (after keyword test) */
	    keywd_class;/* Class number returned by is_keyword */
	int possible_keyword;
	int i_white;

	token->class = tok_identifier;
	keywd_class = FALSE;

	i = klen = 0;
	lo = 0;
	hi = NUM_KEYWORDS-1;
	i_white = 0;

	/* Define shorthand for the keyword letter under study */
#define KN(i) keywords[i].name
#define KL(i) keywords[i].name[klen]

	possible_keyword = TRUE;
	preceding_c = prev_char;
	has_embedded_space = FALSE;
	space_seen_lately = FALSE;

			/* This loop gets  letter [letter|digit]* forms */
	while(isidletter(curr_char) || isadigit(curr_char)) {
	  c = makeupper(curr_char); /* Get the next char of id */
	  if(i < MAXIDSIZE)	/* Store it (up to a point) */
	  {
	    s_upper[i] = c;
	    s_lower[i] = curr_char;
		i++;
	  }

	  if(space_seen_lately)
	  {
	    has_embedded_space = TRUE;
	  }

	  bi_advanceX();		/* Pull in the next character */

	  space_seen_lately = iswhitespace(prev_char);

				/* As long as it may yet be a keyword,
				   keep track of whether to invoke is_keyword.
				 */
	  if(possible_keyword) {

	    if(!isaletter(c)	/* If not alphabetic, cannot be keyword */
	       || klen >= sizeof(keywords[0].name)-1) /* or overlength */
	    {
#ifdef DEBUG_IS_KEYWORD
if(debug_lexer && getenv("BISECTION")) {
s[i] = '\0';
fprintf(list_fd,"\n%s not a keyword because",s);
if(!isaletter(c))
  fprintf(list_fd," non-letter at %c",c);
if(klen >= sizeof(keywords[0].name)-1)
  fprintf(list_fd,"length %d >= max %d",klen,sizeof(keywords[0].name)-1);
}
#endif
	      possible_keyword = FALSE;
	    }
	    else {
	      int mid;
#ifdef DEBUG_IS_KEYWORD
if(debug_lexer && getenv("BISECTION")) {
fprintf(list_fd,"\nklen=%d c=%c",klen,c);
fprintf(list_fd,"\nBisecting [lo,hi]=[%d,%d] \"%s\"..\"%s\"",
	   lo,hi,KN(lo),KN(hi));
}
#endif
				/* Bisect lo .. hi looking for match
				   on characters found so far. */
	      while(lo <= hi) {
		mid = (lo + hi)/2;
		if( KL(mid) < c ) {	/* No match in lower half */
		  lo = mid+1;
		}
		else if( KL(mid) > c ) {/* No match in upper half */
		  hi = mid-1;
		}
		else {		/* Match at midpoint: Bisect each
				   half to find the new subinterval. */
		  int midlo=mid, midhi=mid;
				/* Bisect lo .. mid */
		  while( lo < midlo-1 &&  KL(lo) != c) {
		    mid = (lo + midlo)/2;
		    if(  KL(mid) < c ) {
		      lo = mid+1;
		    }
		    else {	/* equal */
		      midlo = mid;
		    }
		  }
		  if( KL(lo) != c )
		    lo = midlo;
				/* Bisect mid .. hi */
		  while( midhi < hi-1 && KL(hi) != c ) {
		    mid = (midhi + hi)/2;
		    if( KL(mid) > c ) {
		      hi = mid-1;
		    }
		    else {	/* equal */
		      midhi = mid;
		    }
		  }
		  if( KL(hi) != c )
		    hi = midhi;

		  break;	/* After bisecting each half, we are done */
		}		/* end else KL(mid) == c */
	      }			/* end while(lo <= hi) */

	      klen++;		/* Now increment the length */

#ifdef DEBUG_IS_KEYWORD
if(debug_lexer && getenv("BISECTION")) {
fprintf(list_fd,"\nNew [lo,hi]=[%d,%d] \"%s\"..\"%s\"",
	   lo,hi,KN(lo),KN(hi));
}
#endif
			/* If range is null, a match has been ruled out. */
	      if(lo > hi) {
#ifdef DEBUG_IS_KEYWORD
if(debug_lexer && getenv("BISECTION")) {
s[i]='\0';
fprintf(list_fd,"\nKeyword ruled out for %s at length %d since lo %d > hi %d",
	   s,klen,lo,hi);
}
#endif
		possible_keyword = FALSE;
	      }
			/* If length of first keyword in range is equal
			   to the new length, then we have a match at
			   this point.  Check it out with is_keyword.
			 */
	      else if(KN(lo)[klen] == '\0') {
		if( (keywd_class = is_keyword(lo)) != FALSE) {
		  token->class = keywd_class;	/* It's a keyword */
		  token->value.string = NULL;
		  s_upper[i] = 0;
		  s_lower[i] = 0;
          i++;
		  if( hig_fp )
		  {
			if( strcmp( current_filename, top_filename ) == 0 )
			{
 				fprintf( hig_fp, "%d key %d.%d %d.%d\n"
					   , PAF_HIGH
					   , token->line_num
					   , token->curr_index
					   , token->line_num
					   , token->curr_index + i_white
					   ); 
			}
		  }
		  break;	/* Quit the input loop */
		}
		else if(lo == hi) {	/* Match is unique and ruled out */
		  possible_keyword = FALSE;