trans-types.c

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

    case RECORD_TYPE:
      n = GFC_DTYPE_DERIVED;
      break;

    case ARRAY_TYPE:
      n = GFC_DTYPE_CHARACTER;
      break;

    default:
      /* TODO: Don't do dtype for temporary descriptorless arrays.  */
      /* We can strange array types for temporary arrays.  */
      return gfc_index_zero_node;
    }

  gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
  size = TYPE_SIZE_UNIT (etype);

  i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
  if (size && INTEGER_CST_P (size))
    {
      if (tree_int_cst_lt (gfc_max_array_element_size, size))
	internal_error ("Array element size too big");

      i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
    }
  dtype = build_int_cst (gfc_array_index_type, i);

  if (size && !INTEGER_CST_P (size))
    {
      tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
      tmp  = fold_build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp);
      dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
    }
  /* If we don't know the size we leave it as zero.  This should never happen
     for anything that is actually used.  */
  /* TODO: Check this is actually true, particularly when repacking
     assumed size parameters.  */

  GFC_TYPE_ARRAY_DTYPE (type) = dtype;
  return dtype;
}


/* Build an array type for use without a descriptor.  Valid values of packed
   are 0=no, 1=partial, 2=full, 3=static.  */

tree
gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
{
  tree range;
  tree type;
  tree tmp;
  int n;
  int known_stride;
  int known_offset;
  mpz_t offset;
  mpz_t stride;
  mpz_t delta;
  gfc_expr *expr;

  mpz_init_set_ui (offset, 0);
  mpz_init_set_ui (stride, 1);
  mpz_init (delta);

  /* We don't use build_array_type because this does not include include
     lang-specific information (i.e. the bounds of the array) when checking
     for duplicates.  */
  type = make_node (ARRAY_TYPE);

  GFC_ARRAY_TYPE_P (type) = 1;
  TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
    ggc_alloc_cleared (sizeof (struct lang_type));

  known_stride = (packed != 0);
  known_offset = 1;
  for (n = 0; n < as->rank; n++)
    {
      /* Fill in the stride and bound components of the type.  */
      if (known_stride)
	tmp =  gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
      else
        tmp = NULL_TREE;
      GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;

      expr = as->lower[n];
      if (expr->expr_type == EXPR_CONSTANT)
        {
          tmp = gfc_conv_mpz_to_tree (expr->value.integer,
                                  gfc_index_integer_kind);
        }
      else
        {
          known_stride = 0;
          tmp = NULL_TREE;
        }
      GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;

      if (known_stride)
	{
          /* Calculate the offset.  */
          mpz_mul (delta, stride, as->lower[n]->value.integer);
          mpz_sub (offset, offset, delta);
	}
      else
	known_offset = 0;

      expr = as->upper[n];
      if (expr && expr->expr_type == EXPR_CONSTANT)
        {
	  tmp = gfc_conv_mpz_to_tree (expr->value.integer,
			          gfc_index_integer_kind);
        }
      else
        {
          tmp = NULL_TREE;
          known_stride = 0;
        }
      GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;

      if (known_stride)
        {
          /* Calculate the stride.  */
          mpz_sub (delta, as->upper[n]->value.integer,
	           as->lower[n]->value.integer);
          mpz_add_ui (delta, delta, 1);
          mpz_mul (stride, stride, delta);
        }

      /* Only the first stride is known for partial packed arrays.  */
      if (packed < 2)
        known_stride = 0;
    }

  if (known_offset)
    {
      GFC_TYPE_ARRAY_OFFSET (type) =
        gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
    }
  else
    GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;

  if (known_stride)
    {
      GFC_TYPE_ARRAY_SIZE (type) =
        gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
    }
  else
    GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;

  GFC_TYPE_ARRAY_RANK (type) = as->rank;
  GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
  range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
			    NULL_TREE);
  /* TODO: use main type if it is unbounded.  */
  GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
    build_pointer_type (build_array_type (etype, range));

  if (known_stride)
    {
      mpz_sub_ui (stride, stride, 1);
      range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
    }
  else
    range = NULL_TREE;

  range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
  TYPE_DOMAIN (type) = range;

  build_pointer_type (etype);
  TREE_TYPE (type) = etype;

  layout_type (type);

  mpz_clear (offset);
  mpz_clear (stride);
  mpz_clear (delta);

  if (packed < 3 || !known_stride)
    {
      /* For dummy arrays and automatic (heap allocated) arrays we
	 want a pointer to the array.  */
      type = build_pointer_type (type);
      GFC_ARRAY_TYPE_P (type) = 1;
      TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
    }
  return type;
}

/* Return or create the base type for an array descriptor.  */

static tree
gfc_get_array_descriptor_base (int dimen)
{
  tree fat_type, fieldlist, decl, arraytype;
  char name[16 + GFC_RANK_DIGITS + 1];

  gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
  if (gfc_array_descriptor_base[dimen - 1])
    return gfc_array_descriptor_base[dimen - 1];

  /* Build the type node.  */
  fat_type = make_node (RECORD_TYPE);

  sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
  TYPE_NAME (fat_type) = get_identifier (name);

  /* Add the data member as the first element of the descriptor.  */
  decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node);

  DECL_CONTEXT (decl) = fat_type;
  fieldlist = decl;

  /* Add the base component.  */
  decl = build_decl (FIELD_DECL, get_identifier ("offset"),
		     gfc_array_index_type);
  DECL_CONTEXT (decl) = fat_type;
  fieldlist = chainon (fieldlist, decl);

  /* Add the dtype component.  */
  decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
		     gfc_array_index_type);
  DECL_CONTEXT (decl) = fat_type;
  fieldlist = chainon (fieldlist, decl);

  /* Build the array type for the stride and bound components.  */
  arraytype =
    build_array_type (gfc_get_desc_dim_type (),
		      build_range_type (gfc_array_index_type,
					gfc_index_zero_node,
					gfc_rank_cst[dimen - 1]));

  decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
  DECL_CONTEXT (decl) = fat_type;
  fieldlist = chainon (fieldlist, decl);

  /* Finish off the type.  */
  TYPE_FIELDS (fat_type) = fieldlist;

  gfc_finish_type (fat_type);

  gfc_array_descriptor_base[dimen - 1] = fat_type;
  return fat_type;
}

/* Build an array (descriptor) type with given bounds.  */

tree
gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
			   tree * ubound, int packed)
{
  char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
  tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
  const char *typename;
  int n;

  base_type = gfc_get_array_descriptor_base (dimen);
  fat_type = build_variant_type_copy (base_type);

  tmp = TYPE_NAME (etype);
  if (tmp && TREE_CODE (tmp) == TYPE_DECL)
    tmp = DECL_NAME (tmp);
  if (tmp)
    typename = IDENTIFIER_POINTER (tmp);
  else
    typename = "unknown";
  sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
	   GFC_MAX_SYMBOL_LEN, typename);
  TYPE_NAME (fat_type) = get_identifier (name);

  GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
  TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
    ggc_alloc_cleared (sizeof (struct lang_type));

  GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
  GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;

  /* Build an array descriptor record type.  */
  if (packed != 0)
    stride = gfc_index_one_node;
  else
    stride = NULL_TREE;
  for (n = 0; n < dimen; n++)
    {
      GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;

      if (lbound)
	lower = lbound[n];
      else
	lower = NULL_TREE;

      if (lower != NULL_TREE)
	{
	  if (INTEGER_CST_P (lower))
	    GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
	  else
	    lower = NULL_TREE;
	}

      upper = ubound[n];
      if (upper != NULL_TREE)
	{
	  if (INTEGER_CST_P (upper))
	    GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
	  else
	    upper = NULL_TREE;
	}

      if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
	{
	  tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
	  tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
			     gfc_index_one_node);
	  stride =
	    fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
	  /* Check the folding worked.  */
	  gcc_assert (INTEGER_CST_P (stride));
	}
      else
	stride = NULL_TREE;
    }
  GFC_TYPE_ARRAY_SIZE (fat_type) = stride;

  /* TODO: known offsets for descriptors.  */
  GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;

  /* We define data as an unknown size array. Much better than doing
     pointer arithmetic.  */
  arraytype =
    build_array_type (etype, gfc_array_range_type);
  arraytype = build_pointer_type (arraytype);
  GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;

  return fat_type;
}

/* Build a pointer type. This function is called from gfc_sym_type().  */

static tree
gfc_build_pointer_type (gfc_symbol * sym, tree type)
{
  /* Array pointer types aren't actually pointers.  */
  if (sym->attr.dimension)
    return type;
  else
    return build_pointer_type (type);
}

/* Return the type for a symbol.  Special handling is required for character
   types to get the correct level of indirection.
   For functions return the return type.
   For subroutines return void_type_node.
   Calling this multiple times for the same symbol should be avoided,
   especially for character and array types.  */

tree
gfc_sym_type (gfc_symbol * sym)
{
  tree type;
  int byref;

  if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
    return void_type_node;

  if (sym->backend_decl)
    {
      if (sym->attr.function)
	return TREE_TYPE (TREE_TYPE (sym->backend_decl));
      else
	return TREE_TYPE (sym->backend_decl);
    }

  type = gfc_typenode_for_spec (&sym->ts);
  if (gfc_option.flag_f2c
      && sym->attr.function
      && sym->ts.type == BT_REAL
      && sym->ts.kind == gfc_default_real_kind
      && !sym->attr.always_explicit)
    {
      /* Special case: f2c calling conventions require that (scalar) 
	 default REAL functions return the C type double instead.  */
      sym->ts.kind = gfc_default_double_kind;
      type = gfc_typenode_for_spec (&sym->ts);
      sym->ts.kind = gfc_default_real_kind;
    }

  if (sym->attr.dummy && !sym->attr.function)
    byref = 1;
  else
    byref = 0;

  if (sym->attr.dimension)
    {
      if (gfc_is_nodesc_array (sym))
        {
	  /* If this is a character argument of unknown length, just use the
	     base type.  */
	  if (sym->ts.type != BT_CHARACTER
	      || !(sym->attr.dummy || sym->attr.function)
	      || sym->ts.cl->backend_decl)
	    {
	      type = gfc_get_nodesc_array_type (type, sym->as,
						byref ? 2 : 3);
	      byref = 0;
	    }
        }
      else
	type = gfc_build_array_type (type, sym->as);
    }
  else
    {
      if (sym->attr.allocatable || sym->attr.pointer)
	type = gfc_build_pointer_type (sym, type);
    }

  /* We currently pass all parameters by reference.
     See f95_get_function_decl.  For dummy function parameters return the
     function type.  */
  if (byref)
    {
      /* We must use pointer types for potentially absent variables.  The
	 optimizers assume a reference type argument is never NULL.  */
      if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
	type = build_pointer_type (type);
      else
	type = build_reference_type (type);
    }

  return (type);
}

/* Layout and output debug info for a record type.  */

void
gfc_finish_type (tree type)
{
  tree decl;

  decl = build_decl (TYPE_DECL, NULL_TREE, type);
  TYPE_STUB_DECL (type) = decl;
  layout_type (type);
  rest_of_type_compilation (type, 1);
  rest_of_decl_compilation (decl, 1, 0);
}

/* Add a field of given NAME and TYPE to the context of a UNION_TYPE
   or RECORD_TYPE pointed to by STYPE.  The new field is chained
   to the fieldlist pointed to by FIELDLIST.

   Returns a pointer to the new field.  */

tree
gfc_add_field_to_struct (tree *fieldlist, tree context,
			 tree name, tree type)
{
  tree decl;

  decl = build_decl (FIELD_DECL, name, type);

  DECL_CONTEXT (decl) = context;
  DECL_INITIAL (decl) = 0;
  DECL_ALIGN (decl) = 0;
  DECL_USER_ALIGN (decl) = 0;
  TREE_CHAIN (decl) = NULL_TREE;
  *fieldlist = chainon (*fieldlist, decl);