convert.c

gcc-2.95.3 Linux下最常用的C编译器

	  ptr = &element_list;
	}
      for (;;)
	{
	  tree first, last;
	  /* Calculate the first element of the gap. */
	  if (prev_elt == NULL_TREE)
	    first = domain_min;
	  else
	    {
	      first = CONSTRUCTOR_ELT_HI (prev_elt);
	      if (tree_int_cst_equal (first, domain_max))
		break; /* We're done.  Avoid overflow below. */
	      first = copy_node (first);
	      add_double (TREE_INT_CST_LOW (first), TREE_INT_CST_HIGH (first),
			  1, 0,
			  &TREE_INT_CST_LOW (first),
			  &TREE_INT_CST_HIGH (first));
	    }
	  /* Calculate the last element of the gap. */
	  if (*ptr)
	    {
	      /* Actually end up with correct type. */
	      last = size_binop (MINUS_EXPR,
				 CONSTRUCTOR_ELT_LO (*ptr),
				 integer_one_node);
	    }
	  else
	    last = domain_max;
	  if (TREE_CODE (last) == INTEGER_CST && tree_int_cst_lt (last, first))
	    ; /* Empty "gap" - no missing elements. */
	  else if (default_value)
	    {
	      tree purpose;
	      if (tree_int_cst_equal (first, last))
		purpose = first;
	      else
		purpose = build_nt (RANGE_EXPR, first, last);
	      *ptr = tree_cons (purpose, default_value, *ptr);
	    }
	  else
	    {
	      char *err_val_name = display_int_cst (first);
	      if (TREE_CODE (last) != INTEGER_CST)
		error ("dynamic array tuple without (*) or (ELSE)");
	      else if (tree_int_cst_equal (first, last))
		error ("missing array tuple element %s", err_val_name);
	      else
		{
		  char *first_name = (char *)
		    xmalloc (strlen (err_val_name) + 1);
		  strcpy (first_name, err_val_name);
		  err_val_name = display_int_cst (last);
		  error ("missing array tuple elements %s : %s",
			 first_name, err_val_name);
		  free (first_name);
		}
	      errors++;
	    }
	  if (*ptr == NULL_TREE)
	    break;
	  prev_elt = *ptr;
	  ptr = &TREE_CHAIN (*ptr);
	}
    }
  if (errors)
    return error_mark_node;

  element = build (CONSTRUCTOR, type, NULL_TREE, element_list);
  TREE_CONSTANT (element) = is_constant;
  if (is_constant && is_simple)
    TREE_STATIC (element) = 1;
  if (labelled_elements && unlabelled_elements)
    pedwarn ("mixture of labelled and unlabelled tuple elements");
  return element;
}

/* This function is needed because no-op CHILL conversions are not fully
   understood by the initialization machinery.  This function should only
   be called when a conversion truly is a no-op.  */

static tree
convert1 (type, expr)
     tree type, expr;
{
  int was_constant = TREE_CONSTANT (expr);
  STRIP_NOPS (expr);
  was_constant |= TREE_CONSTANT (expr);
  expr = copy_node (expr);
  TREE_TYPE (expr) = type;
  if (TREE_CONSTANT (expr) != was_constant) abort ();
  TREE_CONSTANT (expr) = was_constant;
  return expr;
}

/* Create an expression whose value is that of EXPR,
   converted to type TYPE.  The TREE_TYPE of the value
   is always TYPE.  This function implements all reasonable
   conversions; callers should filter out those that are
   not permitted by the language being compiled.

   In CHILL, we assume that the type is Compatible with the
   Class of expr, and generally complain otherwise.
   However, convert is more general (e.g. allows enum<->int
   conversion), so there should probably be at least two routines.
   Maybe add something like convert_for_assignment.  FIXME. */

tree
convert (type, expr)
     tree type, expr;
{
  register tree e = expr;
  register enum chill_tree_code code;
  int type_varying;

  if (e == NULL_TREE || TREE_CODE (e) == ERROR_MARK)
    return error_mark_node;

  if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
    return error_mark_node;

  code = TREE_CODE (type);

  if (type == TREE_TYPE (e))
    return e;

  if (TREE_TYPE (e) != NULL_TREE
      && TREE_CODE (TREE_TYPE (e)) == REFERENCE_TYPE)
    e = convert_from_reference (e);

  /* Support for converting *to* a reference type is limited;
     it is only here as a convenience for loc-identity declarations,
     and loc parameters. */
  if (code == REFERENCE_TYPE)
    return convert_to_reference (type, e);

  /* if expression was untyped because of its context (an if_expr or case_expr
     in a tuple, perhaps) just apply the type */
  if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == ERROR_MARK)
    {
      TREE_TYPE (e) = type;
      return e;
    }

  /* Turn a NULL keyword into [0, 0] for an instance */
  if (CH_IS_INSTANCE_MODE (type) && expr == null_pointer_node)
    {
      tree field0 = TYPE_FIELDS (type);
      tree field1 = TREE_CHAIN (field0);
      e = build (CONSTRUCTOR, type, NULL_TREE,
		 tree_cons (field0, integer_zero_node,
			    tree_cons (field1, integer_zero_node,
				       NULL_TREE)));
      TREE_CONSTANT (e) = 1;
      TREE_STATIC (e) = 1;
      return e;
    }

  /* Turn a pointer into a function pointer for a procmode */
  if (TREE_CODE (type) == POINTER_TYPE
      && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE
      && expr == null_pointer_node)
    return convert1 (type, expr);

  /* turn function_decl expression into a pointer to 
     that function */
  if (TREE_CODE (expr) == FUNCTION_DECL
      && TREE_CODE (type) == POINTER_TYPE
      && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
    {
      e = build1 (ADDR_EXPR, type, expr);
      TREE_CONSTANT (e) = 1;
      return e;
    }

  if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)
    e = varying_to_slice (e);
  type_varying   = chill_varying_type_p (type);

  /* Convert a char to a singleton string.
     Needed for compatibility with 1984 version of Z.200. */
  if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == CHAR_TYPE
      && (CH_CHARS_ONE_P (type) || type_varying))
    {
      if (TREE_CODE (e) == INTEGER_CST)
	{
	  char ch = TREE_INT_CST_LOW (e);
	  e = build_chill_string (1, &ch);
	}
      else
	e = build (CONSTRUCTOR, string_one_type_node, NULL_TREE,
		   tree_cons (NULL_TREE, e, NULL_TREE));
    }

  /* Convert a Boolean to a singleton bitstring.
     Needed for compatibility with 1984 version of Z.200. */
  if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == BOOLEAN_TYPE
      && (CH_BOOLS_ONE_P (type) || type_varying))
    {
      if (TREE_CODE (e) == INTEGER_CST)
	e = integer_zerop (e) ? bit_zero_node : bit_one_node;
      else
	e = build (COND_EXPR, bitstring_one_type_node,
		   e, bit_one_node, bit_zero_node);
    }

  if (type_varying)
    {
      tree nentries;
      tree field0 = TYPE_FIELDS (type);
      tree field1 = TREE_CHAIN (field0);
      tree orig_e = e;
      tree target_array_type = TREE_TYPE (field1);
      tree needed_padding;
      tree padding_max_size = 0;
      int orig_e_constant = TREE_CONSTANT (orig_e);
      if (TREE_TYPE (e) != NULL_TREE
	  && TREE_CODE (TREE_TYPE (e)) == ARRAY_TYPE)
	{
	  /* Note that array_type_nelts returns 1 less than the size. */
	  nentries = array_type_nelts (TREE_TYPE (e));
	  needed_padding = size_binop (MINUS_EXPR,
				       array_type_nelts (target_array_type),
				       nentries);
	  if (TREE_CODE (needed_padding) != INTEGER_CST)
	    {
	      padding_max_size = size_in_bytes (TREE_TYPE (e));
	      if (TREE_CODE (padding_max_size) != INTEGER_CST)
		padding_max_size = TYPE_ARRAY_MAX_SIZE (TREE_TYPE (e));
	    }
	  nentries = size_binop (PLUS_EXPR, nentries, integer_one_node);
	}
      else if (TREE_CODE (e) == CONSTRUCTOR)
	{
	  HOST_WIDE_INT init_cnt = 0;
	  tree chaser = CONSTRUCTOR_ELTS (e);
	  for ( ; chaser; chaser = TREE_CHAIN (chaser))
	    init_cnt++;               /* count initializer elements */
	  nentries = build_int_2 (init_cnt, 0);
	  needed_padding = integer_zero_node;
	  if (TREE_TYPE (e) == NULL_TREE)
	    e = digest_array_tuple (TREE_TYPE (field1), e, 1);
	  orig_e_constant = TREE_CONSTANT (e);
	}
      else
	{
	  error ("initializer is not an array or string mode");
	  return error_mark_node;
	}
#if 0
      FIXME check that nentries will fit in type;
#endif
      if (!integer_zerop (needed_padding))
	{
	  tree padding, padding_type, padding_range;
	  if (TREE_CODE (needed_padding) == INTEGER_CST
	      && (long)TREE_INT_CST_LOW (needed_padding) < 0)
	    {
	      error ("destination is too small");
	      return error_mark_node;
	    }
	  padding_range = build_chill_range_type (NULL_TREE, integer_one_node,
						  needed_padding);
	  padding_type
	    = build_simple_array_type (TREE_TYPE (target_array_type),
				       padding_range, NULL_TREE);
	  TYPE_ARRAY_MAX_SIZE (padding_type) = padding_max_size;
	  if (CH_CHARS_TYPE_P (target_array_type))
	    MARK_AS_STRING_TYPE (padding_type);
	  padding = build (UNDEFINED_EXPR, padding_type);
	  if (TREE_CONSTANT (e))
	    e = build_chill_binary_op (CONCAT_EXPR, e, padding);
	  else
	    e = build (CONCAT_EXPR, target_array_type, e, padding);
	}
      e = convert (TREE_TYPE (field1), e);
      /* We build this constructor by hand (rather than going through
	 digest_structure_tuple), to avoid some type-checking problem.
	 E.g. type may have non-null novelty, but its field1 will
	 have non-novelty. */
      e = build (CONSTRUCTOR, type, NULL_TREE,
		    tree_cons (field0, nentries,
			       build_tree_list (field1, e)));
      /* following was wrong, cause orig_e never will be TREE_CONSTANT. e
	 may become constant after digest_array_tuple. */
      if (TREE_CONSTANT (nentries) && orig_e_constant) /* TREE_CONSTANT (orig_e)) */
	{
	  TREE_CONSTANT (e) = 1;
	  if (TREE_STATIC (nentries) && TREE_STATIC (orig_e))
	    TREE_STATIC (e) = 1;
	}
    }
  if (TREE_TYPE (e) == NULL_TREE)
    {
      if (TREE_CODE (e) == CONSTRUCTOR)
	{
	  if (TREE_CODE (type) == SET_TYPE)
	    return digest_powerset_tuple (type, e);
	  if (TREE_CODE (type) == RECORD_TYPE)
	    return digest_structure_tuple (type, e);
	  if (TREE_CODE (type) == ARRAY_TYPE)
	    return digest_array_tuple (type, e, 0);
	  fatal ("internal error - bad CONSTRUCTOR passed to convert");
	}
      else if (TREE_CODE (e) == COND_EXPR)
	e = build (COND_EXPR, type,
		   TREE_OPERAND (e, 0),
		   convert (type, TREE_OPERAND (e, 1)),
		   convert (type, TREE_OPERAND (e, 2)));
      else if (TREE_CODE (e) == CASE_EXPR)
	TREE_TYPE (e) = type;
      else
	{
	  error ("internal error:  unknown type of expression");
	  return error_mark_node;
	}
    }

  if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))
      || (CH_NOVELTY (type) != NULL_TREE
	  && CH_NOVELTY (type) == CH_NOVELTY (TREE_TYPE (e))))
    return convert1 (type, e);

  if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
    {
      error ("void value not ignored as it ought to be");
      return error_mark_node;
    }
  if (code == VOID_TYPE)
    return build1 (CONVERT_EXPR, type, e);

  if (code == SET_TYPE)
    return convert1 (type, e);

  if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
    {
      if (flag_old_strings)
	{
	  if (CH_CHARS_ONE_P (TREE_TYPE (e)))
	    e = convert_to_char (char_type_node, e);
	  else if (CH_BOOLS_ONE_P (TREE_TYPE (e)))
	    e = convert_to_boolean (boolean_type_node, e);
	}
      return fold (convert_to_integer (type, e));
    }
  if (code == POINTER_TYPE)
    return fold (convert_to_pointer (type, e));
  if (code == REAL_TYPE)
    return fold (convert_to_real (type, e));
  if (code == BOOLEAN_TYPE)
    return fold (convert_to_boolean (type, e));
  if (code == CHAR_TYPE)
    return fold (convert_to_char (type, e));

  if (code == ARRAY_TYPE && TYPE_MODE (type) != TYPE_MODE (TREE_TYPE (e)))
    {
      /* The mode of the expression is different from that of the type.
	 Earlier checks should have tested against different lengths.
	 But even if the lengths are the same, it is possible that one
	 type is a static type (and hence could be say SImode), while the
	 other type is dynamic type (and hence is BLKmode).
	 This causes problems when emitting instructions.  */
      tree ee = build1 (INDIRECT_REF, type,
			build1 (NOP_EXPR, build_pointer_type (type),
				build1 (ADDR_EXPR,
					build_pointer_type (TREE_TYPE (e)),
					e)));
      TREE_READONLY (ee) = TYPE_READONLY (type);
      return ee;
    }

  /* The default! */
  return convert1 (type, e);
}

/* Return an expression whose value is EXPR, but whose class is CLASS. */

tree
convert_to_class (class, expr)
     struct ch_class class;
     tree expr;
{
  switch (class.kind)
    {
    case CH_NULL_CLASS:
    case CH_ALL_CLASS:
      return expr;
    case CH_DERIVED_CLASS:
      if (TREE_TYPE (expr) != class.mode)
	expr = convert (class.mode, expr);
      if (!CH_DERIVED_FLAG (expr))
	{
	  expr = copy_node (expr);
	  CH_DERIVED_FLAG (expr) = 1;
	}
      return expr;
    case CH_VALUE_CLASS:
    case CH_REFERENCE_CLASS:
      if (TREE_TYPE (expr) != class.mode)
	expr = convert (class.mode, expr);
      if (CH_DERIVED_FLAG (expr))
	{
	  expr = copy_node (expr);
	  CH_DERIVED_FLAG (expr) = 0;
	}
      return expr;
    }
  return expr;
}