trans-io.c

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

/* IO Code translation/library interface
   Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   Contributed by Paul Brook

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 "coretypes.h"
#include "tree.h"
#include "tree-gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "real.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-array.h"
#include "trans-types.h"
#include "trans-const.h"


/* Members of the ioparm structure.  */

enum ioparam_type
{
  IOPARM_ptype_common,
  IOPARM_ptype_open,
  IOPARM_ptype_close,
  IOPARM_ptype_filepos,
  IOPARM_ptype_inquire,
  IOPARM_ptype_dt,
  IOPARM_ptype_num
};

enum iofield_type
{
  IOPARM_type_int4,
  IOPARM_type_pint4,
  IOPARM_type_pchar,
  IOPARM_type_parray,
  IOPARM_type_pad,
  IOPARM_type_char1,
  IOPARM_type_char2,
  IOPARM_type_common,
  IOPARM_type_num
};

typedef struct gfc_st_parameter_field GTY(())
{
  const char *name;
  unsigned int mask;
  enum ioparam_type param_type;
  enum iofield_type type;
  tree field;
  tree field_len;
}
gfc_st_parameter_field;

typedef struct gfc_st_parameter GTY(())
{
  const char *name;
  tree type;
}
gfc_st_parameter;

enum iofield
{
#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
#include "ioparm.def"
#undef IOPARM
  IOPARM_field_num
};

static GTY(()) gfc_st_parameter st_parameter[] =
{
  { "common", NULL },
  { "open", NULL },
  { "close", NULL },
  { "filepos", NULL },
  { "inquire", NULL },
  { "dt", NULL }
};

static GTY(()) gfc_st_parameter_field st_parameter_field[] =
{
#define IOPARM(param_type, name, mask, type) \
  { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
#include "ioparm.def"
#undef IOPARM
  { NULL, 0, 0, 0, NULL, NULL }
};

/* Library I/O subroutines */

enum iocall
{
  IOCALL_READ,
  IOCALL_READ_DONE,
  IOCALL_WRITE,
  IOCALL_WRITE_DONE,
  IOCALL_X_INTEGER,
  IOCALL_X_LOGICAL,
  IOCALL_X_CHARACTER,
  IOCALL_X_REAL,
  IOCALL_X_COMPLEX,
  IOCALL_X_ARRAY,
  IOCALL_OPEN,
  IOCALL_CLOSE,
  IOCALL_INQUIRE,
  IOCALL_IOLENGTH,
  IOCALL_IOLENGTH_DONE,
  IOCALL_REWIND,
  IOCALL_BACKSPACE,
  IOCALL_ENDFILE,
  IOCALL_FLUSH,
  IOCALL_SET_NML_VAL,
  IOCALL_SET_NML_VAL_DIM,
  IOCALL_NUM
};

static GTY(()) tree iocall[IOCALL_NUM];

/* Variable for keeping track of what the last data transfer statement
   was.  Used for deciding which subroutine to call when the data
   transfer is complete.  */
static enum { READ, WRITE, IOLENGTH } last_dt;

/* The data transfer parameter block that should be shared by all
   data transfer calls belonging to the same read/write/iolength.  */
static GTY(()) tree dt_parm;
static stmtblock_t *dt_post_end_block;

static void
gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
{
  enum iofield type;
  gfc_st_parameter_field *p;
  char name[64];
  size_t len;
  tree t = make_node (RECORD_TYPE);

  len = strlen (st_parameter[ptype].name);
  gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
  memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
  memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
	  len + 1);
  TYPE_NAME (t) = get_identifier (name);

  for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
    if (p->param_type == ptype)
      switch (p->type)
	{
	case IOPARM_type_int4:
	case IOPARM_type_pint4:
	case IOPARM_type_parray:
	case IOPARM_type_pchar:
	case IOPARM_type_pad:
	  p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
					      get_identifier (p->name),
					      types[p->type]);
	  break;
	case IOPARM_type_char1:
	  p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
					      get_identifier (p->name),
					      pchar_type_node);
	  /* FALLTHROUGH */
	case IOPARM_type_char2:
	  len = strlen (p->name);
	  gcc_assert (len <= sizeof (name) - sizeof ("_len"));
	  memcpy (name, p->name, len);
	  memcpy (name + len, "_len", sizeof ("_len"));
	  p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
						  get_identifier (name),
						  gfc_charlen_type_node);
	  if (p->type == IOPARM_type_char2)
	    p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
						get_identifier (p->name),
						pchar_type_node);
	  break;
	case IOPARM_type_common:
	  p->field
	    = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
				       get_identifier (p->name),
				       st_parameter[IOPARM_ptype_common].type);
	  break;
	case IOPARM_type_num:
	  gcc_unreachable ();
	}

  gfc_finish_type (t);
  st_parameter[ptype].type = t;
}

/* Create function decls for IO library functions.  */

void
gfc_build_io_library_fndecls (void)
{
  tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
  tree parm_type, dt_parm_type;
  tree gfc_c_int_type_node;
  HOST_WIDE_INT pad_size;
  enum ioparam_type ptype;

  types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
  types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
  types[IOPARM_type_parray] = pchar_type_node;
  types[IOPARM_type_pchar] = pchar_type_node;
  pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
  pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
  pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size));
  types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
  gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);

  for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
    gfc_build_st_parameter (ptype, types);

  /* Define the transfer functions.  */

  dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);

  iocall[IOCALL_X_INTEGER] =
    gfc_build_library_function_decl (get_identifier
				     (PREFIX("transfer_integer")),
				     void_type_node, 3, dt_parm_type,
				     pvoid_type_node, gfc_int4_type_node);

  iocall[IOCALL_X_LOGICAL] =
    gfc_build_library_function_decl (get_identifier
				     (PREFIX("transfer_logical")),
				     void_type_node, 3, dt_parm_type,
				     pvoid_type_node, gfc_int4_type_node);

  iocall[IOCALL_X_CHARACTER] =
    gfc_build_library_function_decl (get_identifier
				     (PREFIX("transfer_character")),
				     void_type_node, 3, dt_parm_type,
				     pvoid_type_node, gfc_int4_type_node);

  iocall[IOCALL_X_REAL] =
    gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
				     void_type_node, 3, dt_parm_type,
				     pvoid_type_node, gfc_int4_type_node);

  iocall[IOCALL_X_COMPLEX] =
    gfc_build_library_function_decl (get_identifier
				     (PREFIX("transfer_complex")),
				     void_type_node, 3, dt_parm_type,
				     pvoid_type_node, gfc_int4_type_node);

  iocall[IOCALL_X_ARRAY] =
    gfc_build_library_function_decl (get_identifier
				     (PREFIX("transfer_array")),
				     void_type_node, 4, dt_parm_type,
				     pvoid_type_node, gfc_c_int_type_node,
				     gfc_charlen_type_node);

  /* Library entry points */

  iocall[IOCALL_READ] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
				     void_type_node, 1, dt_parm_type);

  iocall[IOCALL_WRITE] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
				     void_type_node, 1, dt_parm_type);

  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
  iocall[IOCALL_OPEN] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
				     void_type_node, 1, parm_type);


  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
  iocall[IOCALL_CLOSE] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
				     void_type_node, 1, parm_type);

  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
  iocall[IOCALL_INQUIRE] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
				     gfc_int4_type_node, 1, parm_type);

  iocall[IOCALL_IOLENGTH] =
    gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
				    void_type_node, 1, dt_parm_type);

  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
  iocall[IOCALL_REWIND] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
				     gfc_int4_type_node, 1, parm_type);

  iocall[IOCALL_BACKSPACE] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
				     gfc_int4_type_node, 1, parm_type);

  iocall[IOCALL_ENDFILE] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
				     gfc_int4_type_node, 1, parm_type);

  iocall[IOCALL_FLUSH] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
				     gfc_int4_type_node, 1, parm_type);

  /* Library helpers */

  iocall[IOCALL_READ_DONE] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
				     gfc_int4_type_node, 1, dt_parm_type);

  iocall[IOCALL_WRITE_DONE] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
				     gfc_int4_type_node, 1, dt_parm_type);

  iocall[IOCALL_IOLENGTH_DONE] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
				     gfc_int4_type_node, 1, dt_parm_type);


  iocall[IOCALL_SET_NML_VAL] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
				     void_type_node, 6, dt_parm_type,
				     pvoid_type_node, pvoid_type_node,
				     gfc_int4_type_node, gfc_charlen_type_node,
				     gfc_int4_type_node);

  iocall[IOCALL_SET_NML_VAL_DIM] =
    gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
				     void_type_node, 5, dt_parm_type,
				     gfc_int4_type_node, gfc_int4_type_node,
				     gfc_int4_type_node, gfc_int4_type_node);
}


/* Generate code to store an integer constant into the
   st_parameter_XXX structure.  */

static unsigned int
set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
		     unsigned int val)
{
  tree tmp;
  gfc_st_parameter_field *p = &st_parameter_field[type];

  if (p->param_type == IOPARM_ptype_common)
    var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
		  var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
  tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
		NULL_TREE);
  gfc_add_modify_expr (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
  return p->mask;
}


/* Generate code to store a non-string I/O parameter into the
   st_parameter_XXX structure.  This is a pass by value.  */

static unsigned int
set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
		     gfc_expr *e)
{
  gfc_se se;
  tree tmp;
  gfc_st_parameter_field *p = &st_parameter_field[type];

  gfc_init_se (&se, NULL);
  gfc_conv_expr_type (&se, e, TREE_TYPE (p->field));
  gfc_add_block_to_block (block, &se.pre);

  if (p->param_type == IOPARM_ptype_common)
    var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
		  var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
  tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
		NULL_TREE);
  gfc_add_modify_expr (block, tmp, se.expr);
  return p->mask;
}


/* Generate code to store a non-string I/O parameter into the
   st_parameter_XXX structure.  This is pass by reference.  */

static unsigned int
set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
		   tree var, enum iofield type, gfc_expr *e)
{
  gfc_se se;
  tree tmp, addr;
  gfc_st_parameter_field *p = &st_parameter_field[type];

  gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
  gfc_init_se (&se, NULL);
  gfc_conv_expr_lhs (&se, e);

  gfc_add_block_to_block (block, &se.pre);

  if (TYPE_MODE (TREE_TYPE (se.expr))
      == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
    addr = convert (TREE_TYPE (p->field),
		    gfc_build_addr_expr (NULL, se.expr));
  else
    {
      /* The type used by the library has different size
	 from the type of the variable supplied by the user.
	 Need to use a temporary.  */
      tree tmpvar
	= gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
			  st_parameter_field[type].name);
      addr = gfc_build_addr_expr (NULL, tmpvar);
      tmp = convert (TREE_TYPE (se.expr), tmpvar);
      gfc_add_modify_expr (postblock, se.expr, tmp);
    }

  if (p->param_type == IOPARM_ptype_common)
    var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
		  var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
  tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
		NULL_TREE);
  gfc_add_modify_expr (block, tmp, addr);
  return p->mask;
}

/* Given an array expr, find its address and length to get a string. If the
   array is full, the string's address is the address of array's first element
   and the length is the size of the whole array. If it is an element, the
   string's address is the element's address and the length is the rest size of
   the array.
*/

static void
gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
{
  tree tmp;
  tree array;
  tree type;
  tree size;
  int rank;
  gfc_symbol *sym;

  sym = e->symtree->n.sym;
  rank = sym->as->rank - 1;

  if (e->ref->u.ar.type == AR_FULL)
    {
      se->expr = gfc_get_symbol_decl (sym);
      se->expr = gfc_conv_array_data (se->expr);
    }
  else
    {