io.c

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

/* Deal with I/O statements & related stuff.
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
   Inc.
   Contributed by Andy Vaught

This file is part of GCC.

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

GCC 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 GCC; 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 "system.h"
#include "flags.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"

gfc_st_label format_asterisk =
  { -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, 0,
    {NULL, NULL}, NULL, NULL};

typedef struct
{
  const char *name, *spec;
  bt type;
}
io_tag;

static const io_tag
	tag_file	= { "FILE", " file = %e", BT_CHARACTER },
	tag_status	= { "STATUS", " status = %e", BT_CHARACTER},
	tag_e_access	= {"ACCESS", " access = %e", BT_CHARACTER},
	tag_e_form	= {"FORM", " form = %e", BT_CHARACTER},
	tag_e_recl	= {"RECL", " recl = %e", BT_INTEGER},
	tag_e_blank	= {"BLANK", " blank = %e", BT_CHARACTER},
	tag_e_position	= {"POSITION", " position = %e", BT_CHARACTER},
	tag_e_action	= {"ACTION", " action = %e", BT_CHARACTER},
	tag_e_delim	= {"DELIM", " delim = %e", BT_CHARACTER},
	tag_e_pad	= {"PAD", " pad = %e", BT_CHARACTER},
	tag_unit	= {"UNIT", " unit = %e", BT_INTEGER},
	tag_advance	= {"ADVANCE", " advance = %e", BT_CHARACTER},
	tag_rec		= {"REC", " rec = %e", BT_INTEGER},
	tag_format	= {"FORMAT", NULL, BT_CHARACTER},
	tag_iomsg	= {"IOMSG", " iomsg = %e", BT_CHARACTER},
	tag_iostat	= {"IOSTAT", " iostat = %v", BT_INTEGER},
	tag_size	= {"SIZE", " size = %v", BT_INTEGER},
	tag_exist	= {"EXIST", " exist = %v", BT_LOGICAL},
	tag_opened	= {"OPENED", " opened = %v", BT_LOGICAL},
	tag_named	= {"NAMED", " named = %v", BT_LOGICAL},
	tag_name	= {"NAME", " name = %v", BT_CHARACTER},
	tag_number	= {"NUMBER", " number = %v", BT_INTEGER},
	tag_s_access	= {"ACCESS", " access = %v", BT_CHARACTER},
	tag_sequential	= {"SEQUENTIAL", " sequential = %v", BT_CHARACTER},
	tag_direct	= {"DIRECT", " direct = %v", BT_CHARACTER},
	tag_s_form	= {"FORM", " form = %v", BT_CHARACTER},
	tag_formatted	= {"FORMATTED", " formatted = %v", BT_CHARACTER},
	tag_unformatted	= {"UNFORMATTED", " unformatted = %v", BT_CHARACTER},
	tag_s_recl	= {"RECL", " recl = %v", BT_INTEGER},
	tag_nextrec	= {"NEXTREC", " nextrec = %v", BT_INTEGER},
	tag_s_blank	= {"BLANK", " blank = %v", BT_CHARACTER},
	tag_s_position	= {"POSITION", " position = %v", BT_CHARACTER},
	tag_s_action	= {"ACTION", " action = %v", BT_CHARACTER},
	tag_read	= {"READ", " read = %v", BT_CHARACTER},
	tag_write	= {"WRITE", " write = %v", BT_CHARACTER},
	tag_readwrite	= {"READWRITE", " readwrite = %v", BT_CHARACTER},
	tag_s_delim	= {"DELIM", " delim = %v", BT_CHARACTER},
	tag_s_pad	= {"PAD", " pad = %v", BT_CHARACTER},
	tag_iolength	= {"IOLENGTH", " iolength = %v", BT_INTEGER},
	tag_convert     = {"CONVERT", " convert = %e", BT_CHARACTER},
	tag_err		= {"ERR", " err = %l", BT_UNKNOWN},
	tag_end		= {"END", " end = %l", BT_UNKNOWN},
	tag_eor		= {"EOR", " eor = %l", BT_UNKNOWN};

static gfc_dt *current_dt;

#define RESOLVE_TAG(x, y) if (resolve_tag(x, y) == FAILURE) return FAILURE;


/**************** Fortran 95 FORMAT parser  *****************/

/* FORMAT tokens returned by format_lex().  */
typedef enum
{
  FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
  FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_POS, FMT_LPAREN,
  FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
  FMT_E, FMT_EXT, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END
}
format_token;

/* Local variables for checking format strings.  The saved_token is
   used to back up by a single format token during the parsing
   process.  */
static char *format_string;
static int format_length, use_last_char;

static format_token saved_token;

static enum
{ MODE_STRING, MODE_FORMAT, MODE_COPY }
mode;


/* Return the next character in the format string.  */

static char
next_char (int in_string)
{
  static char c;

  if (use_last_char)
    {
      use_last_char = 0;
      return c;
    }

  format_length++;

  if (mode == MODE_STRING)
    c = *format_string++;
  else
    {
      c = gfc_next_char_literal (in_string);
      if (c == '\n')
	c = '\0';

      if (mode == MODE_COPY)
	*format_string++ = c;
    }

  c = TOUPPER (c);
  return c;
}


/* Back up one character position.  Only works once.  */

static void
unget_char (void)
{

  use_last_char = 1;
}

/* Eat up the spaces and return a character. */

static char
next_char_not_space(void)
{
  char c;
  do
    {
      c = next_char (0);
    }
  while (gfc_is_whitespace (c));
  return c;
}

static int value = 0;

/* Simple lexical analyzer for getting the next token in a FORMAT
   statement.  */

static format_token
format_lex (void)
{
  format_token token;
  char c, delim;
  int zflag;
  int negative_flag;

  if (saved_token != FMT_NONE)
    {
      token = saved_token;
      saved_token = FMT_NONE;
      return token;
    }

  c = next_char_not_space ();
  
  negative_flag = 0;
  switch (c)
    {
    case '-':
      negative_flag = 1;
    case '+':
      c = next_char_not_space ();
      if (!ISDIGIT (c))
	{
	  token = FMT_UNKNOWN;
	  break;
	}

      value = c - '0';

      do
	{
	  c = next_char_not_space ();
          if(ISDIGIT (c))
            value = 10 * value + c - '0';
	}
      while (ISDIGIT (c) || gfc_is_whitespace(c));

      unget_char ();

      if (negative_flag)
        value = -value;

      token = FMT_SIGNED_INT;
      break;

    case '0':
    case '1':
    case '2':
    case '3':
    case '4':
    case '5':
    case '6':
    case '7':
    case '8':
    case '9':
      zflag = (c == '0');

      value = c - '0';

      do
	{
	  c = next_char_not_space ();
	  if (c != '0')
	    zflag = 0;
          if (ISDIGIT (c))
            value = 10 * value + c - '0';
	}
      while (ISDIGIT (c));

      unget_char ();
      token = zflag ? FMT_ZERO : FMT_POSINT;
      break;

    case '.':
      token = FMT_PERIOD;
      break;

    case ',':
      token = FMT_COMMA;
      break;

    case ':':
      token = FMT_COLON;
      break;

    case '/':
      token = FMT_SLASH;
      break;

    case '$':
      token = FMT_DOLLAR;
      break;

    case 'T':
      c = next_char_not_space ();
      if (c != 'L' && c != 'R')
	unget_char ();

      token = FMT_POS;
      break;

    case '(':
      token = FMT_LPAREN;
      break;

    case ')':
      token = FMT_RPAREN;
      break;

    case 'X':
      token = FMT_X;
      break;

    case 'S':
      c = next_char_not_space ();
      if (c != 'P' && c != 'S')
	unget_char ();

      token = FMT_SIGN;
      break;

    case 'B':
      c = next_char_not_space ();
      if (c == 'N' || c == 'Z')
	token = FMT_BLANK;
      else
	{
	  unget_char ();
	  token = FMT_IBOZ;
	}

      break;

    case '\'':
    case '"':
      delim = c;

      value = 0;

      for (;;)
	{
	  c = next_char (1);
	  if (c == '\0')
	    {
	      token = FMT_END;
	      break;
	    }

	  if (c == delim)
	    {
	      c = next_char (1);

	      if (c == '\0')
		{
		  token = FMT_END;
		  break;
		}

	      if (c != delim)
		{
		  unget_char ();
		  token = FMT_CHAR;
		  break;
		}
	    }
          value++;
	}
      break;

    case 'P':
      token = FMT_P;
      break;

    case 'I':
    case 'O':
    case 'Z':
      token = FMT_IBOZ;
      break;

    case 'F':
      token = FMT_F;
      break;

    case 'E':
      c = next_char_not_space ();
      if (c == 'N' || c == 'S')
	token = FMT_EXT;
      else
	{
	  token = FMT_E;
	  unget_char ();
	}

      break;

    case 'G':
      token = FMT_G;
      break;

    case 'H':
      token = FMT_H;
      break;

    case 'L':
      token = FMT_L;
      break;

    case 'A':
      token = FMT_A;
      break;

    case 'D':
      token = FMT_D;
      break;

    case '\0':
      token = FMT_END;
      break;

    default:
      token = FMT_UNKNOWN;
      break;
    }

  return token;
}


/* Check a format statement.  The format string, either from a FORMAT
   statement or a constant in an I/O statement has already been parsed
   by itself, and we are checking it for validity.  The dual origin
   means that the warning message is a little less than great.  */

static try
check_format (void)
{
  const char *posint_required	  = _("Positive width required");
  const char *period_required	  = _("Period required");
  const char *nonneg_required	  = _("Nonnegative width required");
  const char *unexpected_element  = _("Unexpected element");
  const char *unexpected_end	  = _("Unexpected end of format string");

  const char *error;
  format_token t, u;
  int level;
  int repeat;
  try rv;

  use_last_char = 0;
  saved_token = FMT_NONE;
  level = 0;
  repeat = 0;
  rv = SUCCESS;

  t = format_lex ();
  if (t != FMT_LPAREN)
    {
      error = _("Missing leading left parenthesis");
      goto syntax;
    }

  t = format_lex ();
  if (t == FMT_RPAREN)
    goto finished;		/* Empty format is legal */
  saved_token = t;

format_item:
  /* In this state, the next thing has to be a format item.  */
  t = format_lex ();
format_item_1:
  switch (t)
    {
    case FMT_POSINT:
      repeat = value;
      t = format_lex ();
      if (t == FMT_LPAREN)
	{
	  level++;
	  goto format_item;
	}

      if (t == FMT_SLASH)
	goto optional_comma;

      goto data_desc;

    case FMT_LPAREN:
      level++;
      goto format_item;

    case FMT_SIGNED_INT:
      /* Signed integer can only precede a P format.  */
      t = format_lex ();
      if (t != FMT_P)
	{
	  error = _("Expected P edit descriptor");
	  goto syntax;
	}

      goto data_desc;

    case FMT_P:
      /* P requires a prior number.  */
      error = _("P descriptor requires leading scale factor");
      goto syntax;

    case FMT_X:
      /* X requires a prior number if we're being pedantic.  */
      if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor "
			  "requires leading space count at %C")
	  == FAILURE)
	return FAILURE;
      goto between_desc;

    case FMT_SIGN:
    case FMT_BLANK:
      goto between_desc;

    case FMT_CHAR:
      goto extension_optional_comma;

    case FMT_COLON:
    case FMT_SLASH:
      goto optional_comma;

    case FMT_DOLLAR:
      t = format_lex ();

      if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %C")
          == FAILURE)
        return FAILURE;
      if (t != FMT_RPAREN || level > 0)
	{
	  error = _("$ must be the last specifier");
	  goto syntax;
	}

      goto finished;

    case FMT_POS:
    case FMT_IBOZ:
    case FMT_F:
    case FMT_E:
    case FMT_EXT:
    case FMT_G:
    case FMT_L:
    case FMT_A:
    case FMT_D:
      goto data_desc;

    case FMT_H:
      goto data_desc;

    case FMT_END:
      error = unexpected_end;
      goto syntax;

    default:
      error = unexpected_element;
      goto syntax;
    }

data_desc:
  /* In this state, t must currently be a data descriptor.
     Deal with things that can/must follow the descriptor.  */
  switch (t)
    {
    case FMT_SIGN:
    case FMT_BLANK:
    case FMT_X:
      break;

    case FMT_P:
      if (pedantic)
	{
	  t = format_lex ();
	  if (t == FMT_POSINT)
	    {
	      error = _("Repeat count cannot follow P descriptor");
	      goto syntax;
	    }

	  saved_token = t;
	}

      goto optional_comma;

    case FMT_POS:
    case FMT_L:
      t = format_lex ();
      if (t == FMT_POSINT)
	break;

      error = posint_required;
      goto syntax;

    case FMT_A:
      t = format_lex ();
      if (t != FMT_POSINT)
	saved_token = t;
      break;

    case FMT_D:
    case FMT_E:
    case FMT_G:
    case FMT_EXT:
      u = format_lex ();
      if (u != FMT_POSINT)
	{
	  error = posint_required;
	  goto syntax;
	}

      u = format_lex ();
      if (u != FMT_PERIOD)
	{
	  error = period_required;
	  goto syntax;
	}

      u = format_lex ();
      if (u != FMT_ZERO && u != FMT_POSINT)
	{
	  error = nonneg_required;
	  goto syntax;
	}

      if (t == FMT_D)
	break;

      /* Look for optional exponent.  */
      u = format_lex ();
      if (u != FMT_E)
	{
	  saved_token = u;
	}
      else
	{
	  u = format_lex ();
	  if (u != FMT_POSINT)
	    {
	      error = _("Positive exponent width required");
	      goto syntax;
	    }
	}

      break;

    case FMT_F:
      t = format_lex ();
      if (t != FMT_ZERO && t != FMT_POSINT)
	{
	  error = nonneg_required;
	  goto syntax;
	}

      t = format_lex ();
      if (t != FMT_PERIOD)
	{
	  error = period_required;
	  goto syntax;
	}

      t = format_lex ();
      if (t != FMT_ZERO && t != FMT_POSINT)
	{
	  error = nonneg_required;
	  goto syntax;
	}

      break;

    case FMT_H:
      if(mode == MODE_STRING)
      {
        format_string += value;
        format_length -= value;
      }
      else
      {
        while(repeat >0)
         {
          next_char(1);
          repeat -- ;
         }
      }
     break;

    case FMT_IBOZ:
      t = format_lex ();
      if (t != FMT_ZERO && t != FMT_POSINT)
	{
	  error = nonneg_required;
	  goto syntax;
	}

      t = format_lex ();
      if (t != FMT_PERIOD)
	{
	  saved_token = t;
	}
      else
	{
	  t = format_lex ();
	  if (t != FMT_ZERO && t != FMT_POSINT)
	    {
	      error = nonneg_required;
	      goto syntax;
	    }
	}

      break;

    default:
      error = unexpected_element;
      goto syntax;
    }

between_desc:
  /* Between a descriptor and what comes next.  */
  t = format_lex ();