trans-io.c

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

      gfc_conv_expr (se, e);
    }

  array = sym->backend_decl;
  type = TREE_TYPE (array);

  if (GFC_ARRAY_TYPE_P (type))
    size = GFC_TYPE_ARRAY_SIZE (type);
  else
    {
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
      size = gfc_conv_array_stride (array, rank);
      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
		gfc_conv_array_ubound (array, rank),
		gfc_conv_array_lbound (array, rank));
      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
		gfc_index_one_node);
      size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);      
    }

  gcc_assert (size);

  /* If it is an element, we need the its address and size of the rest.  */
  if (e->ref->u.ar.type == AR_ELEMENT)
    {
      size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
		TREE_OPERAND (se->expr, 1));
      se->expr = gfc_build_addr_expr (NULL, se->expr);
    }

  tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
  size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);

  se->string_length = fold_convert (gfc_charlen_type_node, size);
}


/* Generate code to store a string and its length into the
   st_parameter_XXX structure.  */

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

  gfc_init_se (&se, NULL);

  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);
  io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
	       NULL_TREE);
  len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
		NULL_TREE);

  /* Integer variable assigned a format label.  */
  if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
    {
      gfc_conv_label_variable (&se, e);
      msg =
        gfc_build_cstring_const ("Assigned label is not a format label");
      tmp = GFC_DECL_STRING_LEN (se.expr);
      tmp = build2 (LE_EXPR, boolean_type_node,
		    tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
      gfc_trans_runtime_check (tmp, msg, &se.pre);
      gfc_add_modify_expr (&se.pre, io,
		 fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
      gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
    }
  else
    {
      /* General character.  */
      if (e->ts.type == BT_CHARACTER && e->rank == 0)
	gfc_conv_expr (&se, e);
      /* Array assigned Hollerith constant or character array.  */
      else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
	gfc_convert_array_to_string (&se, e);
      else
	gcc_unreachable ();

      gfc_conv_string_parameter (&se);
      gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
      gfc_add_modify_expr (&se.pre, len, se.string_length);
    }

  gfc_add_block_to_block (block, &se.pre);
  gfc_add_block_to_block (postblock, &se.post);
  return p->mask;
}


/* Generate code to store the character (array) and the character length
   for an internal unit.  */

static unsigned int
set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e)
{
  gfc_se se;
  tree io;
  tree len;
  tree desc;
  tree tmp;
  gfc_st_parameter_field *p;
  unsigned int mask;

  gfc_init_se (&se, NULL);

  p = &st_parameter_field[IOPARM_dt_internal_unit];
  mask = p->mask;
  io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
	       NULL_TREE);
  len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
		NULL_TREE);
  p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
  desc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
		 NULL_TREE);

  gcc_assert (e->ts.type == BT_CHARACTER);

  /* Character scalars.  */
  if (e->rank == 0)
    {
      gfc_conv_expr (&se, e);
      gfc_conv_string_parameter (&se);
      tmp = se.expr;
      se.expr = fold_convert (pchar_type_node, integer_zero_node);
    }

  /* Character array.  */
  else if (e->rank > 0)
    {
      se.ss = gfc_walk_expr (e);

      /* Return the data pointer and rank from the descriptor.  */
      gfc_conv_expr_descriptor (&se, e, se.ss);
      tmp = gfc_conv_descriptor_data_get (se.expr);
      se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
    }
  else
    gcc_unreachable ();

  /* The cast is needed for character substrings and the descriptor
     data.  */
  gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
  gfc_add_modify_expr (&se.pre, len, se.string_length);
  gfc_add_modify_expr (&se.pre, desc, se.expr);

  gfc_add_block_to_block (block, &se.pre);
  return mask;
}

/* Add a case to a IO-result switch.  */

static void
add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
{
  tree tmp, value;

  if (label == NULL)
    return;			/* No label, no case */

  value = build_int_cst (NULL_TREE, label_value);

  /* Make a backend label for this case.  */
  tmp = gfc_build_label_decl (NULL_TREE);

  /* And the case itself.  */
  tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
  gfc_add_expr_to_block (body, tmp);

  /* Jump to the label.  */
  tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
  gfc_add_expr_to_block (body, tmp);
}


/* Generate a switch statement that branches to the correct I/O
   result label.  The last statement of an I/O call stores the
   result into a variable because there is often cleanup that
   must be done before the switch, so a temporary would have to
   be created anyway.  */

static void
io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
	   gfc_st_label * end_label, gfc_st_label * eor_label)
{
  stmtblock_t body;
  tree tmp, rc;
  gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];

  /* If no labels are specified, ignore the result instead
     of building an empty switch.  */
  if (err_label == NULL
      && end_label == NULL
      && eor_label == NULL)
    return;

  /* Build a switch statement.  */
  gfc_start_block (&body);

  /* The label values here must be the same as the values
     in the library_return enum in the runtime library */
  add_case (1, err_label, &body);
  add_case (2, end_label, &body);
  add_case (3, eor_label, &body);

  tmp = gfc_finish_block (&body);

  var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
		var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
  rc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
	       NULL_TREE);
  rc = build2 (BIT_AND_EXPR, TREE_TYPE (rc), rc,
	       build_int_cst (TREE_TYPE (rc), IOPARM_common_libreturn_mask));

  tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);

  gfc_add_expr_to_block (block, tmp);
}


/* Store the current file and line number to variables so that if a
   library call goes awry, we can tell the user where the problem is.  */

static void
set_error_locus (stmtblock_t * block, tree var, locus * where)
{
  gfc_file *f;
  tree str, locus_file;
  int line;
  gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];

  locus_file = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
		       var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
  locus_file = build3 (COMPONENT_REF, TREE_TYPE (p->field), locus_file,
		       p->field, NULL_TREE);
  f = where->lb->file;
  str = gfc_build_cstring_const (f->filename);

  str = gfc_build_addr_expr (pchar_type_node, str);
  gfc_add_modify_expr (block, locus_file, str);

#ifdef USE_MAPPED_LOCATION
  line = LOCATION_LINE (where->lb->location);
#else
  line = where->lb->linenum;
#endif
  set_parameter_const (block, var, IOPARM_common_line, line);
}


/* Translate an OPEN statement.  */

tree
gfc_trans_open (gfc_code * code)
{
  stmtblock_t block, post_block;
  gfc_open *p;
  tree tmp, var;
  unsigned int mask = 0;

  gfc_start_block (&block);
  gfc_init_block (&post_block);

  var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");

  set_error_locus (&block, var, &code->loc);
  p = code->ext.open;

  if (p->unit)
    set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
  else
    set_parameter_const (&block, var, IOPARM_common_unit, 0);

  if (p->file)
    mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);

  if (p->status)
    mask |= set_string (&block, &post_block, var, IOPARM_open_status,
			p->status);

  if (p->access)
    mask |= set_string (&block, &post_block, var, IOPARM_open_access,
			p->access);

  if (p->form)
    mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);

  if (p->recl)
    mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);

  if (p->blank)
    mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
			p->blank);

  if (p->position)
    mask |= set_string (&block, &post_block, var, IOPARM_open_position,
			p->position);

  if (p->action)
    mask |= set_string (&block, &post_block, var, IOPARM_open_action,
			p->action);

  if (p->delim)
    mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
			p->delim);

  if (p->pad)
    mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);

  if (p->iomsg)
    mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
			p->iomsg);

  if (p->iostat)
    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
			       p->iostat);

  if (p->err)
    mask |= IOPARM_common_err;

  if (p->convert)
    mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
			p->convert);

  set_parameter_const (&block, var, IOPARM_common_flags, mask);

  tmp = gfc_build_addr_expr (NULL_TREE, var);
  tmp = gfc_chainon_list (NULL_TREE, tmp);
  tmp = gfc_build_function_call (iocall[IOCALL_OPEN], tmp);
  gfc_add_expr_to_block (&block, tmp);

  gfc_add_block_to_block (&block, &post_block);

  io_result (&block, var, p->err, NULL, NULL);

  return gfc_finish_block (&block);
}


/* Translate a CLOSE statement.  */

tree
gfc_trans_close (gfc_code * code)
{
  stmtblock_t block, post_block;
  gfc_close *p;
  tree tmp, var;
  unsigned int mask = 0;

  gfc_start_block (&block);
  gfc_init_block (&post_block);

  var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");

  set_error_locus (&block, var, &code->loc);
  p = code->ext.close;

  if (p->unit)
    set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
  else
    set_parameter_const (&block, var, IOPARM_common_unit, 0);

  if (p->status)
    mask |= set_string (&block, &post_block, var, IOPARM_close_status,
			p->status);

  if (p->iomsg)
    mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
			p->iomsg);

  if (p->iostat)
    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
			       p->iostat);

  if (p->err)
    mask |= IOPARM_common_err;

  set_parameter_const (&block, var, IOPARM_common_flags, mask);

  tmp = gfc_build_addr_expr (NULL_TREE, var);
  tmp = gfc_chainon_list (NULL_TREE, tmp);
  tmp = gfc_build_function_call (iocall[IOCALL_CLOSE], tmp);
  gfc_add_expr_to_block (&block, tmp);

  gfc_add_block_to_block (&block, &post_block);

  io_result (&block, var, p->err, NULL, NULL);

  return gfc_finish_block (&block);
}


/* Common subroutine for building a file positioning statement.  */

static tree
build_filepos (tree function, gfc_code * code)
{
  stmtblock_t block, post_block;
  gfc_filepos *p;
  tree tmp, var;
  unsigned int mask = 0;

  p = code->ext.filepos;

  gfc_start_block (&block);
  gfc_init_block (&post_block);

  var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
			"filepos_parm");

  set_error_locus (&block, var, &code->loc);

  if (p->unit)
    set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
  else
    set_parameter_const (&block, var, IOPARM_common_unit, 0);

  if (p->iomsg)
    mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
			p->iomsg);

  if (p->iostat)
    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
			       p->iostat);

  if (p->err)
    mask |= IOPARM_common_err;

  set_parameter_const (&block, var, IOPARM_common_flags, mask);

  tmp = gfc_build_addr_expr (NULL_TREE, var);
  tmp = gfc_chainon_list (NULL_TREE, tmp);
  tmp = gfc_build_function_call (function, tmp);
  gfc_add_expr_to_block (&block, tmp);

  gfc_add_block_to_block (&block, &post_block);

  io_result (&block, var, p->err, NULL, NULL);

  return gfc_finish_block (&block);
}


/* Translate a BACKSPACE statement.  */

tree
gfc_trans_backspace (gfc_code * code)
{
  return build_filepos (iocall[IOCALL_BACKSPACE], code);
}


/* Translate an ENDFILE statement.  */

tree
gfc_trans_endfile (gfc_code * code)
{
  return build_filepos (iocall[IOCALL_ENDFILE], code);
}