scanner.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

	      c = next_char ();
	      if (c == '\n')
		return;
	    }
	}
      if (gfc_at_eof ())
	break;
    }
}


/* Read ahead until the next character to be read is not whitespace.  */

void
gfc_gobble_whitespace (void)
{
  locus old_loc;
  int c;

  do
    {
      old_loc = gfc_current_locus;
      c = gfc_next_char_literal (0);
    }
  while (gfc_is_whitespace (c));

  gfc_current_locus = old_loc;
}


/* Load a single line into pbuf.

   If pbuf points to a NULL pointer, it is allocated.
   We truncate lines that are too long, unless we're dealing with
   preprocessor lines or if the option -ffixed-line-length-none is set,
   in which case we reallocate the buffer to fit the entire line, if
   need be.
   In fixed mode, we expand a tab that occurs within the statement
   label region to expand to spaces that leave the next character in
   the source region.
   load_line returns whether the line was truncated.  */

static int
load_line (FILE * input, char **pbuf, int *pbuflen)
{
  int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
  int trunc_flag = 0;
  char *buffer;

  /* Determine the maximum allowed line length.
     The default for free-form is GFC_MAX_LINE, for fixed-form or for
     unknown form it is 72. Refer to the documentation in gfc_option_t.  */
  if (gfc_current_form == FORM_FREE)
    {
      if (gfc_option.free_line_length == -1)
	maxlen = GFC_MAX_LINE;
      else
	maxlen = gfc_option.free_line_length;
    }
  else if (gfc_current_form == FORM_FIXED)
    {
      if (gfc_option.fixed_line_length == -1)
	maxlen = 72;
      else
	maxlen = gfc_option.fixed_line_length;
    }
  else
    maxlen = 72;

  if (*pbuf == NULL)
    {
      /* Allocate the line buffer, storing its length into buflen.  */
      if (maxlen > 0)
	buflen = maxlen;
      else
	buflen = GFC_MAX_LINE;

      *pbuf = gfc_getmem (buflen + 1);
    }

  i = 0;
  buffer = *pbuf;

  preprocessor_flag = 0;
  c = fgetc (input);
  if (c == '#')
    /* In order to not truncate preprocessor lines, we have to
       remember that this is one.  */
    preprocessor_flag = 1;
  ungetc (c, input);

  for (;;)
    {
      c = fgetc (input);

      if (c == EOF)
	break;
      if (c == '\n')
	break;

      if (c == '\r')
	continue;		/* Gobble characters.  */
      if (c == '\0')
	continue;

      if (c == '\032')
	{
	  /* Ctrl-Z ends the file.  */
	  while (fgetc (input) != EOF);
	  break;
	}

      if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
	{			/* Tab expansion.  */
	  while (i <= 6)
	    {
	      *buffer++ = ' ';
	      i++;
	    }

	  continue;
	}

      *buffer++ = c;
      i++;

      if (maxlen == 0 || preprocessor_flag)
	{
	  if (i >= buflen)
	    {
	      /* Reallocate line buffer to double size to hold the
	         overlong line.  */
	      buflen = buflen * 2;
	      *pbuf = xrealloc (*pbuf, buflen + 1);
	      buffer = (*pbuf)+i;
	    }
	}
      else if (i >= maxlen)
	{
	  /* Truncate the rest of the line.  */
	  for (;;)
	    {
	      c = fgetc (input);
	      if (c == '\n' || c == EOF)
		break;

	      trunc_flag = 1;
	    }

	  ungetc ('\n', input);
	}
    }

  /* Pad lines to the selected line length in fixed form.  */
  if (gfc_current_form == FORM_FIXED
      && gfc_option.fixed_line_length != 0
      && !preprocessor_flag
      && c != EOF)
    {
      while (i++ < maxlen)
	*buffer++ = ' ';
    }

  *buffer = '\0';
  *pbuflen = buflen;

  return trunc_flag;
}


/* Get a gfc_file structure, initialize it and add it to
   the file stack.  */

static gfc_file *
get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
{
  gfc_file *f;

  f = gfc_getmem (sizeof (gfc_file));

  f->filename = gfc_getmem (strlen (name) + 1);
  strcpy (f->filename, name);

  f->next = file_head;
  file_head = f;

  f->included_by = current_file;
  if (current_file != NULL)
    f->inclusion_line = current_file->line;

#ifdef USE_MAPPED_LOCATION
  linemap_add (&line_table, reason, false, f->filename, 1);
#endif

  return f;
}

/* Deal with a line from the C preprocessor. The
   initial octothorp has already been seen.  */

static void
preprocessor_line (char *c)
{
  bool flag[5];
  int i, line;
  char *filename;
  gfc_file *f;
  int escaped, unescape;

  c++;
  while (*c == ' ' || *c == '\t')
    c++;

  if (*c < '0' || *c > '9')
    goto bad_cpp_line;

  line = atoi (c);

  c = strchr (c, ' ');
  if (c == NULL)
    {
      /* No file name given.  Set new line number.  */
      current_file->line = line;
      return;
    }

  /* Skip spaces.  */
  while (*c == ' ' || *c == '\t')
    c++;

  /* Skip quote.  */
  if (*c != '"')
    goto bad_cpp_line;
  ++c;

  filename = c;

  /* Make filename end at quote.  */
  unescape = 0;
  escaped = false;
  while (*c && ! (! escaped && *c == '"'))
    {
      if (escaped)
        escaped = false;
      else if (*c == '\\')
	{
	  escaped = true;
	  unescape++;
	}
      ++c;
    }

  if (! *c)
    /* Preprocessor line has no closing quote.  */
    goto bad_cpp_line;

  *c++ = '\0';

  /* Undo effects of cpp_quote_string.  */
  if (unescape)
    {
      char *s = filename;
      char *d = gfc_getmem (c - filename - unescape);

      filename = d;
      while (*s)
	{
	  if (*s == '\\')
	    *d++ = *++s;
	  else
	    *d++ = *s;
	  s++;
	}
      *d = '\0';
    }

  /* Get flags.  */

  flag[1] = flag[2] = flag[3] = flag[4] = false;

  for (;;)
    {
      c = strchr (c, ' ');
      if (c == NULL)
	break;

      c++;
      i = atoi (c);

      if (1 <= i && i <= 4)
	flag[i] = true;
    }

  /* Interpret flags.  */

  if (flag[1]) /* Starting new file.  */
    {
      f = get_file (filename, LC_RENAME);
      f->up = current_file;
      current_file = f;
    }

  if (flag[2]) /* Ending current file.  */
    {
      if (!current_file->up
	  || strcmp (current_file->up->filename, filename) != 0)
	{
	  gfc_warning_now ("%s:%d: file %s left but not entered",
			   current_file->filename, current_file->line,
			   filename);
	  if (unescape)
	    gfc_free (filename);
	  return;
	}
      current_file = current_file->up;
    }

  /* The name of the file can be a temporary file produced by
     cpp. Replace the name if it is different.  */

  if (strcmp (current_file->filename, filename) != 0)
    {
      gfc_free (current_file->filename);
      current_file->filename = gfc_getmem (strlen (filename) + 1);
      strcpy (current_file->filename, filename);
    }

  /* Set new line number.  */
  current_file->line = line;
  if (unescape)
    gfc_free (filename);
  return;

 bad_cpp_line:
  gfc_warning_now ("%s:%d: Illegal preprocessor directive",
		   current_file->filename, current_file->line);
  current_file->line++;
}


static try load_file (const char *, bool);

/* include_line()-- Checks a line buffer to see if it is an include
   line.  If so, we call load_file() recursively to load the included
   file.  We never return a syntax error because a statement like
   "include = 5" is perfectly legal.  We return false if no include was
   processed or true if we matched an include.  */

static bool
include_line (char *line)
{
  char quote, *c, *begin, *stop;
  
  c = line;
  while (*c == ' ' || *c == '\t')
    c++;

  if (strncasecmp (c, "include", 7))
      return false;

  c += 7;
  while (*c == ' ' || *c == '\t')
    c++;

  /* Find filename between quotes.  */
  
  quote = *c++;
  if (quote != '"' && quote != '\'')
    return false;

  begin = c;

  while (*c != quote && *c != '\0')
    c++;

  if (*c == '\0')
    return false;

  stop = c++;
  
  while (*c == ' ' || *c == '\t')
    c++;

  if (*c != '\0' && *c != '!')
    return false;

  /* We have an include line at this point.  */

  *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
		   read by anything else.  */

  load_file (begin, false);
  return true;
}

/* Load a file into memory by calling load_line until the file ends.  */

static try
load_file (const char *filename, bool initial)
{
  char *line;
  gfc_linebuf *b;
  gfc_file *f;
  FILE *input;
  int len, line_len;

  for (f = current_file; f; f = f->up)
    if (strcmp (filename, f->filename) == 0)
      {
	gfc_error_now ("File '%s' is being included recursively", filename);
	return FAILURE;
      }

  if (initial)
    {
      if (gfc_src_file)
	{
	  input = gfc_src_file;
	  gfc_src_file = NULL;
	}
      else
	input = gfc_open_file (filename);
      if (input == NULL)
	{
	  gfc_error_now ("Can't open file '%s'", filename);
	  return FAILURE;
	}
    }
  else
    {
      input = gfc_open_included_file (filename, false);
      if (input == NULL)
	{
	  gfc_error_now ("Can't open included file '%s'", filename);
	  return FAILURE;
	}
    }

  /* Load the file.  */

  f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
  f->up = current_file;
  current_file = f;
  current_file->line = 1;
  line = NULL;
  line_len = 0;

  if (initial && gfc_src_preprocessor_lines[0])
    {
      preprocessor_line (gfc_src_preprocessor_lines[0]);
      gfc_free (gfc_src_preprocessor_lines[0]);
      gfc_src_preprocessor_lines[0] = NULL;
      if (gfc_src_preprocessor_lines[1])
	{
	  preprocessor_line (gfc_src_preprocessor_lines[1]);
	  gfc_free (gfc_src_preprocessor_lines[1]);
	  gfc_src_preprocessor_lines[1] = NULL;
	}
    }

  for (;;)
    {
      int trunc = load_line (input, &line, &line_len);

      len = strlen (line);
      if (feof (input) && len == 0)
	break;

      /* There are three things this line can be: a line of Fortran
	 source, an include line or a C preprocessor directive.  */

      if (line[0] == '#')
	{
	  preprocessor_line (line);
	  continue;
	}

      if (include_line (line))
	{
	  current_file->line++;
	  continue;
	}

      /* Add line.  */

      b = gfc_getmem (gfc_linebuf_header_size + len + 1);

#ifdef USE_MAPPED_LOCATION
      b->location
	= linemap_line_start (&line_table, current_file->line++, 120);
#else
      b->linenum = current_file->line++;
#endif
      b->file = current_file;
      b->truncated = trunc;
      strcpy (b->line, line);

      if (line_head == NULL)
	line_head = b;
      else
	line_tail->next = b;

      line_tail = b;
    }

  /* Release the line buffer allocated in load_line.  */
  gfc_free (line);

  fclose (input);

  current_file = current_file->up;
#ifdef USE_MAPPED_LOCATION
  linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
#endif
  return SUCCESS;
}


/* Open a new file and start scanning from that file. Returns SUCCESS
   if everything went OK, FAILURE otherwise.  If form == FORM_UKNOWN
   it tries to determine the source form from the filename, defaulting
   to free form.  */

try
gfc_new_file (void)
{
  try result;

  result = load_file (gfc_source_file, true);

  gfc_current_locus.lb = line_head;
  gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;

#if 0 /* Debugging aid.  */
  for (; line_head; line_head = line_head->next)
    gfc_status ("%s:%3d %s\n", line_head->file->filename, 
#ifdef USE_MAPPED_LOCATION
		LOCATION_LINE (line_head->location),
#else
		line_head->linenum,
#endif
		line_head->line);

  exit (0);
#endif

  return result;
}

static char *
unescape_filename (const char *ptr)
{
  const char *p = ptr, *s;
  char *d, *ret;
  int escaped, unescape = 0;

  /* Make filename end at quote.  */
  escaped = false;
  while (*p && ! (! escaped && *p == '"'))
    {
      if (escaped)
	escaped = false;
      else if (*p == '\\')
	{
	  escaped = true;
	  unescape++;
	}
      ++p;
    }

  if (! *p || p[1])
    return NULL;

  /* Undo effects of cpp_quote_string.  */
  s = ptr;
  d = gfc_getmem (p + 1 - ptr - unescape);
  ret = d;

  while (s != p)
    {
      if (*s == '\\')
	*d++ = *++s;
      else
	*d++ = *s;
      s++;
    }
  *d = '\0';
  return ret;
}

/* For preprocessed files, if the first tokens are of the form # NUM.
   handle the directives so we know the original file name.  */

const char *
gfc_read_orig_filename (const char *filename, const char **canon_source_file)
{
  int c, len;
  char *dirname;

  gfc_src_file = gfc_open_file (filename);
  if (gfc_src_file == NULL)
    return NULL;

  c = fgetc (gfc_src_file);
  ungetc (c, gfc_src_file);

  if (c != '#')
    return NULL;

  len = 0;
  load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len);

  if (strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
    return NULL;

  filename = unescape_filename (gfc_src_preprocessor_lines[0] + 5);
  if (filename == NULL)
    return NULL;

  c = fgetc (gfc_src_file);
  ungetc (c, gfc_src_file);

  if (c != '#')
    return filename;

  len = 0;
  load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len);

  if (strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
    return filename;

  dirname = unescape_filename (gfc_src_preprocessor_lines[1] + 5);
  if (dirname == NULL)
    return filename;

  len = strlen (dirname);
  if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
    {
      gfc_free (dirname);
      return filename;
    }
  dirname[len - 2] = '\0';
  set_src_pwd (dirname);

  if (! IS_ABSOLUTE_PATH (filename))
    {
      char *p = gfc_getmem (len + strlen (filename));

      memcpy (p, dirname, len - 2);
      p[len - 2] = '/';
      strcpy (p + len - 1, filename);
      *canon_source_file = p;
    }

  gfc_free (dirname);
  return filename;
}