list_read.c

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

/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   Contributed by Andy Vaught
   Namelist input contributed by Paul Thomas

This file is part of the GNU Fortran 95 runtime library (libgfortran).

Libgfortran 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.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

Libgfortran 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 Libgfortran; see the file COPYING.  If not, write to
the Free Software Foundation, 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */


#include "config.h"
#include <string.h>
#include <ctype.h>
#include "libgfortran.h"
#include "io.h"


/* List directed input.  Several parsing subroutines are practically
   reimplemented from formatted input, the reason being that there are
   all kinds of small differences between formatted and list directed
   parsing.  */


/* Subroutines for reading characters from the input.  Because a
   repeat count is ambiguous with an integer, we have to read the
   whole digit string before seeing if there is a '*' which signals
   the repeat count.  Since we can have a lot of potential leading
   zeros, we have to be able to back up by arbitrary amount.  Because
   the input might not be seekable, we have to buffer the data
   ourselves.  */

#define CASE_DIGITS   case '0': case '1': case '2': case '3': case '4': \
                      case '5': case '6': case '7': case '8': case '9'

#define CASE_SEPARATORS  case ' ': case ',': case '/': case '\n': case '\t': \
                         case '\r'

/* This macro assumes that we're operating on a variable.  */

#define is_separator(c) (c == '/' ||  c == ',' || c == '\n' || c == ' ' \
                         || c == '\t' || c == '\r')

/* Maximum repeat count.  Less than ten times the maximum signed int32.  */

#define MAX_REPEAT 200000000


/* Save a character to a string buffer, enlarging it as necessary.  */

static void
push_char (st_parameter_dt *dtp, char c)
{
  char *new;

  if (dtp->u.p.saved_string == NULL)
    {
      if (dtp->u.p.scratch == NULL)
	dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
      dtp->u.p.saved_string = dtp->u.p.scratch;
      memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
      dtp->u.p.saved_length = SCRATCH_SIZE;
      dtp->u.p.saved_used = 0;
    }

  if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
    {
      dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
      new = get_mem (2 * dtp->u.p.saved_length);

      memset (new, 0, 2 * dtp->u.p.saved_length);

      memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
      if (dtp->u.p.saved_string != dtp->u.p.scratch)
	free_mem (dtp->u.p.saved_string);

      dtp->u.p.saved_string = new;
    }

  dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
}


/* Free the input buffer if necessary.  */

static void
free_saved (st_parameter_dt *dtp)
{
  if (dtp->u.p.saved_string == NULL)
    return;

  if (dtp->u.p.saved_string != dtp->u.p.scratch)
    free_mem (dtp->u.p.saved_string);

  dtp->u.p.saved_string = NULL;
  dtp->u.p.saved_used = 0;
}


static char
next_char (st_parameter_dt *dtp)
{
  int length;
  gfc_offset record;
  char c, *p;

  if (dtp->u.p.last_char != '\0')
    {
      dtp->u.p.at_eol = 0;
      c = dtp->u.p.last_char;
      dtp->u.p.last_char = '\0';
      goto done;
    }

  length = 1;

  /* Handle the end-of-record condition for internal array unit */
  if (is_array_io(dtp) && dtp->u.p.current_unit->bytes_left == 0)
    {
      c = '\n';
      record = next_array_record (dtp, dtp->u.p.current_unit->ls);

      /* Check for "end-of-file condition */      
      if (record == 0)
        longjmp (*dtp->u.p.eof_jump, 1);

      record *= dtp->u.p.current_unit->recl;
      
      if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
	longjmp (*dtp->u.p.eof_jump, 1);

      dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
      goto done;
    }

  /* Get the next character and handle end-of-record conditions */
  p = salloc_r (dtp->u.p.current_unit->s, &length);

  if (is_internal_unit(dtp))
    {
      if (is_array_io(dtp))
	{
	  /* End of record is handled in the next pass through, above.  The
	     check for NULL here is cautionary. */
	  if (p == NULL)
	    {
	      generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
	      return '\0';
	    }

	  dtp->u.p.current_unit->bytes_left--;
	  c = *p;
	}
      else
	{
	  if (p == NULL)
	    longjmp (*dtp->u.p.eof_jump, 1);
	  if (length == 0)
	    c = '\n';
	  else
	    c = *p;
	}
    }
  else
    {
      if (p == NULL)
	{
	  generate_error (&dtp->common, ERROR_OS, NULL);
	  return '\0';
	}
      if (length == 0)
	longjmp (*dtp->u.p.eof_jump, 1);
      c = *p;
    }
done:
  dtp->u.p.at_eol = (c == '\n' || c == '\r');
  return c;
}


/* Push a character back onto the input.  */

static void
unget_char (st_parameter_dt *dtp, char c)
{
  dtp->u.p.last_char = c;
}


/* Skip over spaces in the input.  Returns the nonspace character that
   terminated the eating and also places it back on the input.  */

static char
eat_spaces (st_parameter_dt *dtp)
{
  char c;

  do
    {
      c = next_char (dtp);
    }
  while (c == ' ' || c == '\t');

  unget_char (dtp, c);
  return c;
}


/* Skip over a separator.  Technically, we don't always eat the whole
   separator.  This is because if we've processed the last input item,
   then a separator is unnecessary.  Plus the fact that operating
   systems usually deliver console input on a line basis.

   The upshot is that if we see a newline as part of reading a
   separator, we stop reading.  If there are more input items, we
   continue reading the separator with finish_separator() which takes
   care of the fact that we may or may not have seen a comma as part
   of the separator.  */

static void
eat_separator (st_parameter_dt *dtp)
{
  char c, n;

  eat_spaces (dtp);
  dtp->u.p.comma_flag = 0;

  c = next_char (dtp);
  switch (c)
    {
    case ',':
      dtp->u.p.comma_flag = 1;
      eat_spaces (dtp);
      break;

    case '/':
      dtp->u.p.input_complete = 1;
      break;

    case '\r':
      n = next_char(dtp);
      if (n == '\n')
	dtp->u.p.at_eol = 1;
      else
        {
	  unget_char (dtp, n);
	  unget_char (dtp, c);
        } 
      break;

    case '\n':
      dtp->u.p.at_eol = 1;
      break;

    case '!':
      if (dtp->u.p.namelist_mode)
	{			/* Eat a namelist comment.  */
	  do
	    c = next_char (dtp);
	  while (c != '\n');

	  break;
	}

      /* Fall Through...  */

    default:
      unget_char (dtp, c);
      break;
    }
}


/* Finish processing a separator that was interrupted by a newline.
   If we're here, then another data item is present, so we finish what
   we started on the previous line.  */

static void
finish_separator (st_parameter_dt *dtp)
{
  char c;

 restart:
  eat_spaces (dtp);

  c = next_char (dtp);
  switch (c)
    {
    case ',':
      if (dtp->u.p.comma_flag)
	unget_char (dtp, c);
      else
	{
	  c = eat_spaces (dtp);
	  if (c == '\n' || c == '\r')
	    goto restart;
	}

      break;

    case '/':
      dtp->u.p.input_complete = 1;
      if (!dtp->u.p.namelist_mode) next_record (dtp, 0);
      break;

    case '\n':
    case '\r':
      goto restart;

    case '!':
      if (dtp->u.p.namelist_mode)
	{
	  do
	    c = next_char (dtp);
	  while (c != '\n');

	  goto restart;
	}

    default:
      unget_char (dtp, c);
      break;
    }
}

/* This function is needed to catch bad conversions so that namelist can
   attempt to see if dtp->u.p.saved_string contains a new object name rather
   than a bad value.  */

static int
nml_bad_return (st_parameter_dt *dtp, char c)
{
  if (dtp->u.p.namelist_mode)
    {
      dtp->u.p.nml_read_error = 1;
      unget_char (dtp, c);
      return 1;
    }
  return 0;
}

/* Convert an unsigned string to an integer.  The length value is -1
   if we are working on a repeat count.  Returns nonzero if we have a
   range problem.  As a side effect, frees the dtp->u.p.saved_string.  */

static int
convert_integer (st_parameter_dt *dtp, int length, int negative)
{
  char c, *buffer, message[100];
  int m;
  GFC_INTEGER_LARGEST v, max, max10;

  buffer = dtp->u.p.saved_string;
  v = 0;

  max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
  max10 = max / 10;

  for (;;)
    {
      c = *buffer++;
      if (c == '\0')
	break;
      c -= '0';

      if (v > max10)
	goto overflow;
      v = 10 * v;

      if (v > max - c)
	goto overflow;
      v += c;
    }

  m = 0;

  if (length != -1)
    {
      if (negative)
	v = -v;
      set_integer (dtp->u.p.value, v, length);
    }
  else
    {
      dtp->u.p.repeat_count = v;

      if (dtp->u.p.repeat_count == 0)
	{
	  st_sprintf (message, "Zero repeat count in item %d of list input",
		      dtp->u.p.item_count);

	  generate_error (&dtp->common, ERROR_READ_VALUE, message);
	  m = 1;
	}
    }

  free_saved (dtp);
  return m;

 overflow:
  if (length == -1)
    st_sprintf (message, "Repeat count overflow in item %d of list input",
		dtp->u.p.item_count);
  else
    st_sprintf (message, "Integer overflow while reading item %d",
		dtp->u.p.item_count);

  free_saved (dtp);
  generate_error (&dtp->common, ERROR_READ_VALUE, message);

  return 1;
}


/* Parse a repeat count for logical and complex values which cannot
   begin with a digit.  Returns nonzero if we are done, zero if we
   should continue on.  */

static int
parse_repeat (st_parameter_dt *dtp)
{
  char c, message[100];
  int repeat;

  c = next_char (dtp);
  switch (c)
    {
    CASE_DIGITS:
      repeat = c - '0';
      break;

    CASE_SEPARATORS:
      unget_char (dtp, c);
      eat_separator (dtp);
      return 1;

    default:
      unget_char (dtp, c);
      return 0;
    }

  for (;;)
    {
      c = next_char (dtp);
      switch (c)
	{
	CASE_DIGITS:
	  repeat = 10 * repeat + c - '0';

	  if (repeat > MAX_REPEAT)
	    {
	      st_sprintf (message,
			  "Repeat count overflow in item %d of list input",
			  dtp->u.p.item_count);

	      generate_error (&dtp->common, ERROR_READ_VALUE, message);
	      return 1;
	    }

	  break;

	case '*':
	  if (repeat == 0)
	    {
	      st_sprintf (message,
			  "Zero repeat count in item %d of list input",
			  dtp->u.p.item_count);

	      generate_error (&dtp->common, ERROR_READ_VALUE, message);
	      return 1;
	    }

	  goto done;

	default:
	  goto bad_repeat;
	}
    }

 done:
  dtp->u.p.repeat_count = repeat;
  return 0;

 bad_repeat:
  st_sprintf (message, "Bad repeat count in item %d of list input",
	      dtp->u.p.item_count);

  generate_error (&dtp->common, ERROR_READ_VALUE, message);
  return 1;
}


/* Read a logical character on the input.  */

static void
read_logical (st_parameter_dt *dtp, int length)
{
  char c, message[100];
  int v;

  if (parse_repeat (dtp))
    return;

  c = next_char (dtp);
  switch (c)
    {
    case 't':
    case 'T':
      v = 1;
      break;
    case 'f':
    case 'F':
      v = 0;
      break;

    case '.':
      c = next_char (dtp);
      switch (c)
	{
	case 't':
	case 'T':
	  v = 1;
	  break;
	case 'f':
	case 'F':
	  v = 0;
	  break;
	default:
	  goto bad_logical;
	}

      break;

    CASE_SEPARATORS:
      unget_char (dtp, c);
      eat_separator (dtp);
      return;			/* Null value.  */

    default:
      goto bad_logical;
    }

  dtp->u.p.saved_type = BT_LOGICAL;
  dtp->u.p.saved_length = length;

  /* Eat trailing garbage.  */
  do
    {
      c = next_char (dtp);
    }
  while (!is_separator (c));

  unget_char (dtp, c);
  eat_separator (dtp);
  free_saved (dtp);
  set_integer ((int *) dtp->u.p.value, v, length);

  return;

 bad_logical:

  if (nml_bad_return (dtp, c))
    return;

  st_sprintf (message, "Bad logical value while reading item %d",
	      dtp->u.p.item_count);

  generate_error (&dtp->common, ERROR_READ_VALUE, message);
}


/* Reading integers is tricky because we can actually be reading a
   repeat count.  We have to store the characters in a buffer because
   we could be reading an integer that is larger than the default int
   used for repeat counts.  */

static void
read_integer (st_parameter_dt *dtp, int length)
{
  char c, message[100];
  int negative;

  negative = 0;

  c = next_char (dtp);
  switch (c)
    {
    case '-':
      negative = 1;
      /* Fall through...  */

    case '+':
      c = next_char (dtp);