lex.c

gcc-2.95.3 Linux下最常用的C编译器

/* Implementation of Fortran lexer
   Copyright (C) 1995-1998 Free Software Foundation, Inc.
   Contributed by James Craig Burley.

This file is part of GNU Fortran.

GNU Fortran 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.

GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.  */

#include "proj.h"
#include "top.h"
#include "bad.h"
#include "com.h"
#include "lex.h"
#include "malloc.h"
#include "src.h"
#if FFECOM_targetCURRENT == FFECOM_targetGCC
#include "flags.j"
#include "input.j"
#include "toplev.j"
#include "tree.j"
#include "output.j"  /* Must follow tree.j so TREE_CODE is defined! */
#endif

#ifdef DWARF_DEBUGGING_INFO
void dwarfout_resume_previous_source_file (register unsigned);
void dwarfout_start_new_source_file (register char *);
void dwarfout_define (register unsigned, register char *);
void dwarfout_undef (register unsigned, register char *);
#endif DWARF_DEBUGGING_INFO

static void ffelex_append_to_token_ (char c);
static int ffelex_backslash_ (int c, ffewhereColumnNumber col);
static void ffelex_bad_1_ (ffebad errnum, ffewhereLineNumber ln0,
			   ffewhereColumnNumber cn0);
static void ffelex_bad_2_ (ffebad errnum, ffewhereLineNumber ln0,
			   ffewhereColumnNumber cn0, ffewhereLineNumber ln1,
			   ffewhereColumnNumber cn1);
static void ffelex_bad_here_ (int num, ffewhereLineNumber ln0,
			      ffewhereColumnNumber cn0);
static void ffelex_finish_statement_ (void);
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static int ffelex_get_directive_line_ (char **text, FILE *finput);
static int ffelex_hash_ (FILE *f);
#endif
static ffewhereColumnNumber ffelex_image_char_ (int c,
						ffewhereColumnNumber col);
static void ffelex_include_ (void);
static bool ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col);
static bool ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col);
static void ffelex_next_line_ (void);
static void ffelex_prepare_eos_ (void);
static void ffelex_send_token_ (void);
static ffelexHandler ffelex_swallow_tokens_ (ffelexToken t);
static ffelexToken ffelex_token_new_ (void);

/* Pertaining to the geometry of the input file.  */

/* Initial size for card image to be allocated.  */
#define FFELEX_columnINITIAL_SIZE_ 255

/* The card image itself, which grows as source lines get longer.  It
   has room for ffelex_card_size_ + 8 characters, and the length of the
   current image is ffelex_card_length_.  (The + 8 characters are made
   available for easy handling of tabs and such.)  */
static char *ffelex_card_image_;
static ffewhereColumnNumber ffelex_card_size_;
static ffewhereColumnNumber ffelex_card_length_;

/* Max width for free-form lines (ISO F90).  */
#define FFELEX_FREE_MAX_COLUMNS_ 132

/* True if we saw a tab on the current line, as this (currently) means
   the line is therefore treated as though final_nontab_column_ were
   infinite.  */
static bool ffelex_saw_tab_;

/* TRUE if current line is known to be erroneous, so don't bother
   expanding room for it just to display it.  */
static bool ffelex_bad_line_ = FALSE;

/* Last column for vanilla, i.e. non-tabbed, line.  Usually 72 or 132. */
static ffewhereColumnNumber ffelex_final_nontab_column_;

/* Array for quickly deciding what kind of line the current card has,
   based on its first character.  */
static ffelexType ffelex_first_char_[256];

/* Pertaining to file management.  */

/* The wf argument of the most recent active ffelex_file_(fixed,free)
   function.  */
static ffewhereFile ffelex_current_wf_;

/* TRUE if an INCLUDE statement can be processed (ffelex_set_include
   can be called).  */
static bool ffelex_permit_include_;

/* TRUE if an INCLUDE statement is pending (ffelex_set_include has been
   called).  */
static bool ffelex_set_include_;

/* Information on the pending INCLUDE file.  */
static FILE *ffelex_include_file_;
static bool ffelex_include_free_form_;
static ffewhereFile ffelex_include_wherefile_;

/* Current master line count.  */
static ffewhereLineNumber ffelex_linecount_current_;
/* Next master line count.  */
static ffewhereLineNumber ffelex_linecount_next_;

/* ffewhere info on the latest (currently active) line read from the
   active source file.  */
static ffewhereLine ffelex_current_wl_;
static ffewhereColumn ffelex_current_wc_;

/* Pertaining to tokens in general.  */

/* Initial capacity for text in a CHARACTER/HOLLERITH/NAME/NAMES/NUMBER
   token.  */
#define FFELEX_columnTOKEN_SIZE_ 63
#if FFELEX_columnTOKEN_SIZE_ < FFEWHERE_indexMAX
#error "token size too small!"
#endif

/* Current token being lexed.  */
static ffelexToken ffelex_token_;

/* Handler for current token.  */
static ffelexHandler ffelex_handler_;

/* TRUE if fixed-form lexer is to generate NAMES instead of NAME tokens.  */
static bool ffelex_names_;

/* TRUE if both lexers are to generate NAMES instead of NAME tokens.  */
static bool ffelex_names_pure_;

/* TRUE if 0-9 starts a NAME token instead of NUMBER, for parsing hex
   numbers.  */
static bool ffelex_hexnum_;

/* For ffelex_swallow_tokens().  */
static ffelexHandler ffelex_eos_handler_;

/* Number of tokens sent since last EOS or beginning of input file
   (include INCLUDEd files).  */
static unsigned long int ffelex_number_of_tokens_;

/* Number of labels sent (as NUMBER tokens) since last reset of
   ffelex_number_of_tokens_ to 0, should be 0 or 1 in most cases.
   (Fixed-form source only.)  */
static unsigned long int ffelex_label_tokens_;

/* Metering for token management, to catch token-memory leaks.  */
static long int ffelex_total_tokens_ = 0;
static long int ffelex_old_total_tokens_ = 1;
static long int ffelex_token_nextid_ = 0;

/* Pertaining to lexing CHARACTER and HOLLERITH tokens.  */

/* >0 if a Hollerith constant of that length might be in mid-lex, used
   when the next character seen is 'H' or 'h' to enter HOLLERITH lexing
   mode (see ffelex_raw_mode_).  */
static long int ffelex_expecting_hollerith_;

/* -3: Backslash (escape) sequence being lexed in CHARACTER.
   -2: Possible closing apostrophe/quote seen in CHARACTER.
   -1: Lexing CHARACTER.
    0: Not lexing CHARACTER or HOLLERITH.
   >0: Lexing HOLLERITH, value is # chars remaining to expect.  */
static long int ffelex_raw_mode_;

/* When lexing CHARACTER, open quote/apostrophe (either ' or ").  */
static char ffelex_raw_char_;

/* TRUE when backslash processing had to use most recent character
   to finish its state engine, but that character is not part of
   the backslash sequence, so must be reconsidered as a "normal"
   character in CHARACTER/HOLLERITH lexing.  */
static bool ffelex_backslash_reconsider_ = FALSE;

/* Characters preread before lexing happened (might include EOF).  */
static int *ffelex_kludge_chars_ = NULL;

/* Doing the kludge processing, so not initialized yet.  */
static bool ffelex_kludge_flag_ = FALSE;

/* The beginning of a (possible) CHARACTER/HOLLERITH token.  */
static ffewhereLine ffelex_raw_where_line_;
static ffewhereColumn ffelex_raw_where_col_;


/* Call this to append another character to the current token.	If it isn't
   currently big enough for it, it will be enlarged.  The current token
   must be a CHARACTER, HOLLERITH, NAME, NAMES, or NUMBER.  */

static void
ffelex_append_to_token_ (char c)
{
  if (ffelex_token_->text == NULL)
    {
      ffelex_token_->text
	= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
			  FFELEX_columnTOKEN_SIZE_ + 1);
      ffelex_token_->size = FFELEX_columnTOKEN_SIZE_;
      ffelex_token_->length = 0;
    }
  else if (ffelex_token_->length >= ffelex_token_->size)
    {
      ffelex_token_->text
	= malloc_resize_ksr (malloc_pool_image (),
			     ffelex_token_->text,
			     (ffelex_token_->size << 1) + 1,
			     ffelex_token_->size + 1);
      ffelex_token_->size <<= 1;
      assert (ffelex_token_->length < ffelex_token_->size);
    }
#ifdef MAP_CHARACTER
Sorry, MAP_CHARACTER is not going to work as expected in GNU Fortran,
please contact [e-mail] if you wish to fund work to
port g77 to non-ASCII machines.
#endif
  ffelex_token_->text[ffelex_token_->length++] = c;
}

/* Do backslash (escape) processing for a CHARACTER/HOLLERITH token
   being lexed.  */

static int
ffelex_backslash_ (int c, ffewhereColumnNumber col)
{
  static int state = 0;
  static unsigned int count;
  static int code;
  static unsigned int firstdig = 0;
  static int nonnull;
  static ffewhereLineNumber line;
  static ffewhereColumnNumber column;

  /* See gcc/c-lex.c readescape() for a straightforward version
     of this state engine for handling backslashes in character/
     hollerith constants.  */

#define wide_flag 0
#define warn_traditional 0
#define flag_traditional 0

  switch (state)
    {
    case 0:
      if ((c == '\\')
	  && (ffelex_raw_mode_ != 0)
	  && ffe_is_backslash ())
	{
	  state = 1;
	  column = col + 1;
	  line = ffelex_linecount_current_;
	  return EOF;
	}
      return c;

    case 1:
      state = 0;		/* Assume simple case. */
      switch (c)
	{
	case 'x':
	  if (warn_traditional)
	    {
	      ffebad_start_msg_lex ("The meaning of `\\x' (at %0) varies with -traditional",
				    FFEBAD_severityWARNING);
	      ffelex_bad_here_ (0, line, column);
	      ffebad_finish ();
	    }

	  if (flag_traditional)
	    return c;

	  code = 0;
	  count = 0;
	  nonnull = 0;
	  state = 2;
	  return EOF;

	case '0':  case '1':  case '2':  case '3':  case '4':
	case '5':  case '6':  case '7':
	  code = c - '0';
	  count = 1;
	  state = 3;
	  return EOF;

	case '\\': case '\'': case '"':
	  return c;

#if 0	/* Inappropriate for Fortran. */
	case '\n':
	  ffelex_next_line_ ();
	  *ignore_ptr = 1;
	  return 0;
#endif

	case 'n':
	  return TARGET_NEWLINE;

	case 't':
	  return TARGET_TAB;

	case 'r':
	  return TARGET_CR;

	case 'f':
	  return TARGET_FF;

	case 'b':
	  return TARGET_BS;

	case 'a':
	  if (warn_traditional)
	    {
	      ffebad_start_msg_lex ("The meaning of `\\a' (at %0) varies with -traditional",
				    FFEBAD_severityWARNING);
	      ffelex_bad_here_ (0, line, column);
	      ffebad_finish ();
	    }

	  if (flag_traditional)
	    return c;
	  return TARGET_BELL;

	case 'v':
#if 0 /* Vertical tab is present in common usage compilers.  */
	  if (flag_traditional)
	    return c;
#endif
	  return TARGET_VT;

	case 'e':
	case 'E':
	case '(':
	case '{':
	case '[':
	case '%':
	  if (pedantic)
	    {
	      char m[2];

	      m[0] = c;
	      m[1] = '\0';
	      ffebad_start_msg_lex ("Non-ANSI-C-standard escape sequence `\\%A' at %0",
				    FFEBAD_severityPEDANTIC);
	      ffelex_bad_here_ (0, line, column);
	      ffebad_string (m);
	      ffebad_finish ();
	    }
	  return (c == 'E' || c == 'e') ? 033 : c;

	case '?':
	  return c;

	default:
	  if (c >= 040 && c < 0177)
	    {
	      char m[2];

	      m[0] = c;
	      m[1] = '\0';
	      ffebad_start_msg_lex ("Unknown escape sequence `\\%A' at %0",
				    FFEBAD_severityPEDANTIC);
	      ffelex_bad_here_ (0, line, column);
	      ffebad_string (m);
	      ffebad_finish ();
	    }
	  else if (c == EOF)
	    {
	      ffebad_start_msg_lex ("Unterminated escape sequence `\\' at %0",
				    FFEBAD_severityPEDANTIC);
	      ffelex_bad_here_ (0, line, column);
	      ffebad_finish ();
	    }
	  else
	    {
	      char m[20];

	      sprintf (&m[0], "%x", c);
	      ffebad_start_msg_lex ("Unknown escape sequence `\\' followed by char code 0x%A at %0",
				    FFEBAD_severityPEDANTIC);
	      ffelex_bad_here_ (0, line, column);
	      ffebad_string (m);
	      ffebad_finish ();
	    }
	}
      return c;

    case 2:
      if ((c >= 'a' && c <= 'f')
	  || (c >= 'A' && c <= 'F')
	  || (c >= '0' && c <= '9'))
	{
	  code *= 16;
	  if (c >= 'a' && c <= 'f')
	    code += c - 'a' + 10;
	  if (c >= 'A' && c <= 'F')
	    code += c - 'A' + 10;
	  if (c >= '0' && c <= '9')
	    code += c - '0';
	  if (code != 0 || count != 0)
	    {
	      if (count == 0)
		firstdig = code;
	      count++;
	    }
	  nonnull = 1;
	  return EOF;
	}

      state = 0;

      if (! nonnull)
	{
	  ffebad_start_msg_lex ("\\x used at %0 with no following hex digits",
				FFEBAD_severityFATAL);
	  ffelex_bad_here_ (0, line, column);
	  ffebad_finish ();
	}
      else if (count == 0)
	/* Digits are all 0's.  Ok.  */
	;
      else if ((count - 1) * 4 >= TYPE_PRECISION (integer_type_node)
	       || (count > 1
		   && ((1 << (TYPE_PRECISION (integer_type_node) - (count - 1) * 4))
		       <= (int) firstdig)))
	{
	  ffebad_start_msg_lex ("Hex escape at %0 out of range",
				FFEBAD_severityPEDANTIC);
	  ffelex_bad_here_ (0, line, column);
	  ffebad_finish ();
	}
      break;

    case 3:
      if ((c <= '7') && (c >= '0') && (count++ < 3))
	{
	  code = (code * 8) + (c - '0');
	  return EOF;
	}
      state = 0;
      break;

    default:
      assert ("bad backslash state" == NULL);
      abort ();
    }

  /* Come here when code has a built character, and c is the next
     character that might (or might not) be the next one in the constant.  */

  /* Don't bother doing this check for each character going into
     CHARACTER or HOLLERITH constants, just the escaped-value ones.
     gcc apparently checks every single character, which seems
     like it'd be kinda slow and not worth doing anyway.  */

  if (!wide_flag
      && TYPE_PRECISION (char_type_node) < HOST_BITS_PER_INT
      && code >= (1 << TYPE_PRECISION (char_type_node)))
    {
      ffebad_start_msg_lex ("Escape sequence at %0 out of range for character",
			    FFEBAD_severityFATAL);
      ffelex_bad_here_ (0, line, column);
      ffebad_finish ();
    }