format.c

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

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

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.  */


/* format.c-- parse a FORMAT string into a binary format suitable for
 * interpretation during I/O statements */

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

#define FARRAY_SIZE 64

typedef struct fnode_array
{
  struct fnode_array *next;
  fnode array[FARRAY_SIZE];
}
fnode_array;

typedef struct format_data
{
  char *format_string, *string;
  const char *error;
  format_token saved_token;
  int value, format_string_len, reversion_ok;
  fnode *avail;
  const fnode *saved_format;
  fnode_array *last;
  fnode_array array;
}
format_data;

static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
				  NULL };

/* Error messages */

static const char posint_required[] = "Positive width required in format",
  period_required[] = "Period required in format",
  nonneg_required[] = "Nonnegative width required in format",
  unexpected_element[] = "Unexpected element in format",
  unexpected_end[] = "Unexpected end of format string",
  bad_string[] = "Unterminated character constant in format",
  bad_hollerith[] = "Hollerith constant extends past the end of the format",
  reversion_error[] = "Exhausted data descriptors in format";


/* next_char()-- Return the next character in the format string.
 * Returns -1 when the string is done.  If the literal flag is set,
 * spaces are significant, otherwise they are not. */

static int
next_char (format_data *fmt, int literal)
{
  int c;

  do
    {
      if (fmt->format_string_len == 0)
	return -1;

      fmt->format_string_len--;
      c = toupper (*fmt->format_string++);
    }
  while (c == ' ' && !literal);

  return c;
}


/* unget_char()-- Back up one character position. */

#define unget_char(fmt) \
  { fmt->format_string--; fmt->format_string_len++; }


/* get_fnode()-- Allocate a new format node, inserting it into the
 * current singly linked list.  These are initially allocated from the
 * static buffer. */

static fnode *
get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
{
  fnode *f;

  if (fmt->avail == &fmt->last->array[FARRAY_SIZE])
    {
      fmt->last->next = get_mem (sizeof (fnode_array));
      fmt->last = fmt->last->next;
      fmt->last->next = NULL;
      fmt->avail = &fmt->last->array[0];
    }
  f = fmt->avail++;
  memset (f, '\0', sizeof (fnode));

  if (*head == NULL)
    *head = *tail = f;
  else
    {
      (*tail)->next = f;
      *tail = f;
    }

  f->format = t;
  f->repeat = -1;
  f->source = fmt->format_string;
  return f;
}


/* free_format_data()-- Free all allocated format data.  */

void
free_format_data (st_parameter_dt *dtp)
{
  fnode_array *fa, *fa_next;
  format_data *fmt = dtp->u.p.fmt;

  if (fmt == NULL)
    return;

  for (fa = fmt->array.next; fa; fa = fa_next)
    {
      fa_next = fa->next;
      free_mem (fa);
    }

  free_mem (fmt);
  dtp->u.p.fmt = NULL;
}


/* format_lex()-- Simple lexical analyzer for getting the next token
 * in a FORMAT string.  We support a one-level token pushback in the
 * fmt->saved_token variable. */

static format_token
format_lex (format_data *fmt)
{
  format_token token;
  int negative_flag;
  int c;
  char delim;

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

  negative_flag = 0;
  c = next_char (fmt, 0);

  switch (c)
    {
    case '-':
      negative_flag = 1;
      /* Fall Through */

    case '+':
      c = next_char (fmt, 0);
      if (!isdigit (c))
	{
	  token = FMT_UNKNOWN;
	  break;
	}

      fmt->value = c - '0';

      for (;;)
	{
	  c = next_char (fmt, 0);
	  if (!isdigit (c))
	    break;

	  fmt->value = 10 * fmt->value + c - '0';
	}

      unget_char (fmt);

      if (negative_flag)
	fmt->value = -fmt->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':
      fmt->value = c - '0';

      for (;;)
	{
	  c = next_char (fmt, 0);
	  if (!isdigit (c))
	    break;

	  fmt->value = 10 * fmt->value + c - '0';
	}

      unget_char (fmt);
      token = (fmt->value == 0) ? 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':
      switch (next_char (fmt, 0))
	{
	case 'L':
	  token = FMT_TL;
	  break;
	case 'R':
	  token = FMT_TR;
	  break;
	default:
	  token = FMT_T;
	  unget_char (fmt);
	  break;
	}

      break;

    case '(':
      token = FMT_LPAREN;
      break;

    case ')':
      token = FMT_RPAREN;
      break;

    case 'X':
      token = FMT_X;
      break;

    case 'S':
      switch (next_char (fmt, 0))
	{
	case 'S':
	  token = FMT_SS;
	  break;
	case 'P':
	  token = FMT_SP;
	  break;
	default:
	  token = FMT_S;
	  unget_char (fmt);
	  break;
	}

      break;

    case 'B':
      switch (next_char (fmt, 0))
	{
	case 'N':
	  token = FMT_BN;
	  break;
	case 'Z':
	  token = FMT_BZ;
	  break;
	default:
	  token = FMT_B;
	  unget_char (fmt);
	  break;
	}

      break;

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

      fmt->string = fmt->format_string;
      fmt->value = 0;		/* This is the length of the string */

      for (;;)
	{
	  c = next_char (fmt, 1);
	  if (c == -1)
	    {
	      token = FMT_BADSTRING;
	      fmt->error = bad_string;
	      break;
	    }

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

	      if (c == -1)
		{
		  token = FMT_BADSTRING;
		  fmt->error = bad_string;
		  break;
		}

	      if (c != delim)
		{
		  unget_char (fmt);
		  token = FMT_STRING;
		  break;
		}
	    }

	  fmt->value++;
	}

      break;

    case 'P':
      token = FMT_P;
      break;

    case 'I':
      token = FMT_I;
      break;

    case 'O':
      token = FMT_O;
      break;

    case 'Z':
      token = FMT_Z;
      break;

    case 'F':
      token = FMT_F;
      break;

    case 'E':
      switch (next_char (fmt, 0))
	{
	case 'N':
	  token = FMT_EN;
	  break;
	case 'S':
	  token = FMT_ES;
	  break;
	default:
	  token = FMT_E;
	  unget_char (fmt);
	  break;
	}

      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 -1:
      token = FMT_END;
      break;

    default:
      token = FMT_UNKNOWN;
      break;
    }

  return token;
}


/* parse_format_list()-- Parse a format list.  Assumes that a left
 * paren has already been seen.  Returns a list representing the
 * parenthesis node which contains the rest of the list. */

static fnode *
parse_format_list (st_parameter_dt *dtp)
{
  fnode *head, *tail;
  format_token t, u, t2;
  int repeat;
  format_data *fmt = dtp->u.p.fmt;

  head = tail = NULL;

  /* Get the next format item */
 format_item:
  t = format_lex (fmt);
 format_item_1:
  switch (t)
    {
    case FMT_POSINT:
      repeat = fmt->value;

      t = format_lex (fmt);
      switch (t)
	{
	case FMT_LPAREN:
	  get_fnode (fmt, &head, &tail, FMT_LPAREN);
	  tail->repeat = repeat;
	  tail->u.child = parse_format_list (dtp);
	  if (fmt->error != NULL)
	    goto finished;

	  goto between_desc;

	case FMT_SLASH:
	  get_fnode (fmt, &head, &tail, FMT_SLASH);
	  tail->repeat = repeat;
	  goto optional_comma;

	case FMT_X:
	  get_fnode (fmt, &head, &tail, FMT_X);
	  tail->repeat = 1;
	  tail->u.k = fmt->value;
	  goto between_desc;

	case FMT_P:
	  goto p_descriptor;

	default:
	  goto data_desc;
	}

    case FMT_LPAREN:
      get_fnode (fmt, &head, &tail, FMT_LPAREN);
      tail->repeat = 1;
      tail->u.child = parse_format_list (dtp);
      if (fmt->error != NULL)
	goto finished;

      goto between_desc;

    case FMT_SIGNED_INT:	/* Signed integer can only precede a P format.  */
    case FMT_ZERO:		/* Same for zero.  */
      t = format_lex (fmt);
      if (t != FMT_P)
	{
	  fmt->error = "Expected P edit descriptor in format";
	  goto finished;
	}

    p_descriptor:
      get_fnode (fmt, &head, &tail, FMT_P);
      tail->u.k = fmt->value;
      tail->repeat = 1;

      t = format_lex (fmt);
      if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
	  || t == FMT_G || t == FMT_E)
	{
	  repeat = 1;
	  goto data_desc;
	}

      fmt->saved_token = t;
      goto optional_comma;

    case FMT_P:		/* P and X require a prior number */
      fmt->error = "P descriptor requires leading scale factor";
      goto finished;

    case FMT_X:
/*
   EXTENSION!

   If we would be pedantic in the library, we would have to reject
   an X descriptor without an integer prefix:

      fmt->error = "X descriptor requires leading space count";
      goto finished;

   However, this is an extension supported by many Fortran compilers,
   including Cray, HP, AIX, and IRIX.  Therefore, we allow it in the
   runtime library, and make the front end reject it if the compiler
   is in pedantic mode.  The interpretation of 'X' is '1X'.
*/
      get_fnode (fmt, &head, &tail, FMT_X);
      tail->repeat = 1;
      tail->u.k = 1;
      goto between_desc;

    case FMT_STRING:
      get_fnode (fmt, &head, &tail, FMT_STRING);

      tail->u.string.p = fmt->string;
      tail->u.string.length = fmt->value;
      tail->repeat = 1;
      goto optional_comma;

    case FMT_S:
    case FMT_SS:
    case FMT_SP:
    case FMT_BN:
    case FMT_BZ:
      get_fnode (fmt, &head, &tail, t);