com.c

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

   `expr' is the original opARRAYREF expression, which is transformed
     if `item' is NULL_TREE.
   `want_ptr' is non-zero if a pointer to the element, instead of
     the element itself, is to be returned.  */

static tree
ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
{
  ffebld dims[FFECOM_dimensionsMAX];
  int i;
  int total_dims;
  int flatten = ffe_is_flatten_arrays ();
  int need_ptr;
  tree array;
  tree element;
  tree tree_type;
  tree tree_type_x;
  char *array_name;
  ffetype type;
  ffebld list;

  if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
    array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
  else
    array_name = "[expr?]";

  /* Build up ARRAY_REFs in reverse order (since we're column major
     here in Fortran land). */

  for (i = 0, list = ffebld_right (expr);
       list != NULL;
       ++i, list = ffebld_trail (list))
    {
      dims[i] = ffebld_head (list);
      type = ffeinfo_type (ffebld_basictype (dims[i]),
			   ffebld_kindtype (dims[i]));
      if (! flatten
	  && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
	  && ffetype_size (type) > ffecom_typesize_integer1_)
	/* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
	   pointers and 32-bit integers.  Do the full 64-bit pointer
	   arithmetic, for codes using arrays for nonstandard heap-like
	   work.  */
	flatten = 1;
    }

  total_dims = i;

  need_ptr = want_ptr || flatten;

  if (! item)
    {
      if (need_ptr)
	item = ffecom_ptr_to_expr (ffebld_left (expr));
      else
	item = ffecom_expr (ffebld_left (expr));

      if (item == error_mark_node)
	return item;

      if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
	  && ! mark_addressable (item))
	return error_mark_node;
    }

  if (item == error_mark_node)
    return item;

  if (need_ptr)
    {
      tree min;

      for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
	   i >= 0;
	   --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
	{
	  min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
	  element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
	  if (ffe_is_subscript_check ())
	    element = ffecom_subscript_check_ (array, element, i, total_dims,
					       array_name);
	  if (element == error_mark_node)
	    return element;

	  /* Widen integral arithmetic as desired while preserving
	     signedness.  */
	  tree_type = TREE_TYPE (element);
	  tree_type_x = tree_type;
	  if (tree_type
	      && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
	      && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
	    tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);

	  if (TREE_TYPE (min) != tree_type_x)
	    min = convert (tree_type_x, min);
	  if (TREE_TYPE (element) != tree_type_x)
	    element = convert (tree_type_x, element);

	  item = ffecom_2 (PLUS_EXPR,
			   build_pointer_type (TREE_TYPE (array)),
			   item,
			   size_binop (MULT_EXPR,
				       size_in_bytes (TREE_TYPE (array)),
				       fold (build (MINUS_EXPR,
						    tree_type_x,
						    element,
						    min))));
	}
      if (! want_ptr)
	{
	  item = ffecom_1 (INDIRECT_REF,
			   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
			   item);
	}
    }
  else
    {
      for (--i;
	   i >= 0;
	   --i)
	{
	  array = TYPE_MAIN_VARIANT (TREE_TYPE (item));

	  element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
	  if (ffe_is_subscript_check ())
	    element = ffecom_subscript_check_ (array, element, i, total_dims,
					       array_name);
	  if (element == error_mark_node)
	    return element;

	  /* Widen integral arithmetic as desired while preserving
	     signedness.  */
	  tree_type = TREE_TYPE (element);
	  tree_type_x = tree_type;
	  if (tree_type
	      && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
	      && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
	    tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);

	  element = convert (tree_type_x, element);

	  item = ffecom_2 (ARRAY_REF,
			   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
			   item,
			   element);
	}
    }

  return item;
}

/* This is like gcc's stabilize_reference -- in fact, most of the code
   comes from that -- but it handles the situation where the reference
   is going to have its subparts picked at, and it shouldn't change
   (or trigger extra invocations of functions in the subtrees) due to
   this.  save_expr is a bit overzealous, because we don't need the
   entire thing calculated and saved like a temp.  So, for DECLs, no
   change is needed, because these are stable aggregates, and ARRAY_REF
   and such might well be stable too, but for things like calculations,
   we do need to calculate a snapshot of a value before picking at it.  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_stabilize_aggregate_ (tree ref)
{
  tree result;
  enum tree_code code = TREE_CODE (ref);

  switch (code)
    {
    case VAR_DECL:
    case PARM_DECL:
    case RESULT_DECL:
      /* No action is needed in this case.  */
      return ref;

    case NOP_EXPR:
    case CONVERT_EXPR:
    case FLOAT_EXPR:
    case FIX_TRUNC_EXPR:
    case FIX_FLOOR_EXPR:
    case FIX_ROUND_EXPR:
    case FIX_CEIL_EXPR:
      result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
      break;

    case INDIRECT_REF:
      result = build_nt (INDIRECT_REF,
			 stabilize_reference_1 (TREE_OPERAND (ref, 0)));
      break;

    case COMPONENT_REF:
      result = build_nt (COMPONENT_REF,
			 stabilize_reference (TREE_OPERAND (ref, 0)),
			 TREE_OPERAND (ref, 1));
      break;

    case BIT_FIELD_REF:
      result = build_nt (BIT_FIELD_REF,
			 stabilize_reference (TREE_OPERAND (ref, 0)),
			 stabilize_reference_1 (TREE_OPERAND (ref, 1)),
			 stabilize_reference_1 (TREE_OPERAND (ref, 2)));
      break;

    case ARRAY_REF:
      result = build_nt (ARRAY_REF,
			 stabilize_reference (TREE_OPERAND (ref, 0)),
			 stabilize_reference_1 (TREE_OPERAND (ref, 1)));
      break;

    case COMPOUND_EXPR:
      result = build_nt (COMPOUND_EXPR,
			 stabilize_reference_1 (TREE_OPERAND (ref, 0)),
			 stabilize_reference (TREE_OPERAND (ref, 1)));
      break;

    case RTL_EXPR:
      result = build1 (INDIRECT_REF, TREE_TYPE (ref),
		       save_expr (build1 (ADDR_EXPR,
					  build_pointer_type (TREE_TYPE (ref)),
					  ref)));
      break;


    default:
      return save_expr (ref);

    case ERROR_MARK:
      return error_mark_node;
    }

  TREE_TYPE (result) = TREE_TYPE (ref);
  TREE_READONLY (result) = TREE_READONLY (ref);
  TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
  TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
  TREE_RAISES (result) = TREE_RAISES (ref);

  return result;
}
#endif

/* A rip-off of gcc's convert.c convert_to_complex function,
   reworked to handle complex implemented as C structures
   (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_convert_to_complex_ (tree type, tree expr)
{
  register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
  tree subtype;

  assert (TREE_CODE (type) == RECORD_TYPE);

  subtype = TREE_TYPE (TYPE_FIELDS (type));
  
  if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
    {
      expr = convert (subtype, expr);
      return ffecom_2 (COMPLEX_EXPR, type, expr,
		       convert (subtype, integer_zero_node));
    }

  if (form == RECORD_TYPE)
    {
      tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
      if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
	return expr;
      else
	{
	  expr = save_expr (expr);
	  return ffecom_2 (COMPLEX_EXPR,
			   type,
			   convert (subtype,
				    ffecom_1 (REALPART_EXPR,
					      TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
					      expr)),
			   convert (subtype,
				    ffecom_1 (IMAGPART_EXPR,
					      TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
					      expr)));
	}
    }

  if (form == POINTER_TYPE || form == REFERENCE_TYPE)
    error ("pointer value used where a complex was expected");
  else
    error ("aggregate value used where a complex was expected");
  
  return ffecom_2 (COMPLEX_EXPR, type,
		   convert (subtype, integer_zero_node),
		   convert (subtype, integer_zero_node));
}
#endif

/* Like gcc's convert(), but crashes if widening might happen.  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_convert_narrow_ (type, expr)
     tree type, expr;
{
  register tree e = expr;
  register enum tree_code code = TREE_CODE (type);

  if (type == TREE_TYPE (e)
      || TREE_CODE (e) == ERROR_MARK)
    return e;
  if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
    return fold (build1 (NOP_EXPR, type, e));
  if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
      || code == ERROR_MARK)
    return error_mark_node;
  if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
    {
      assert ("void value not ignored as it ought to be" == NULL);
      return error_mark_node;
    }
  assert (code != VOID_TYPE);
  if ((code != RECORD_TYPE)
      && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
    assert ("converting COMPLEX to REAL" == NULL);
  assert (code != ENUMERAL_TYPE);
  if (code == INTEGER_TYPE)
    {
      assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
	       && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
	      || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
		  && (TYPE_PRECISION (type)
		      == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
      return fold (convert_to_integer (type, e));
    }
  if (code == POINTER_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
      return fold (convert_to_pointer (type, e));
    }
  if (code == REAL_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
      assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
      return fold (convert_to_real (type, e));
    }
  if (code == COMPLEX_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
      assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
      return fold (convert_to_complex (type, e));
    }
  if (code == RECORD_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
      /* Check that at least the first field name agrees.  */
      assert (DECL_NAME (TYPE_FIELDS (type))
	      == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
      assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
	      <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
      if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
	  == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
	return e;
      return fold (ffecom_convert_to_complex_ (type, e));
    }

  assert ("conversion to non-scalar type requested" == NULL);
  return error_mark_node;
}
#endif

/* Like gcc's convert(), but crashes if narrowing might happen.  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_convert_widen_ (type, expr)
     tree type, expr;
{
  register tree e = expr;
  register enum tree_code code = TREE_CODE (type);

  if (type == TREE_TYPE (e)
      || TREE_CODE (e) == ERROR_MARK)
    return e;
  if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
    return fold (build1 (NOP_EXPR, type, e));
  if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
      || code == ERROR_MARK)
    return error_mark_node;
  if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
    {
      assert ("void value not ignored as it ought to be" == NULL);
      return error_mark_node;
    }
  assert (code != VOID_TYPE);
  if ((code != RECORD_TYPE)
      && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
    assert ("narrowing COMPLEX to REAL" == NULL);
  assert (code != ENUMERAL_TYPE);
  if (code == INTEGER_TYPE)
    {
      assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
	       && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
	      || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
		  && (TYPE_PRECISION (type)
		      == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
      return fold (convert_to_integer (type, e));
    }
  if (code == POINTER_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
      return fold (convert_to_pointer (type, e));
    }
  if (code == REAL_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
      assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
      return fold (convert_to_real (type, e));
    }
  if (code == COMPLEX_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
      assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
      return fold (convert_to_complex (type, e));
    }
  if (code == RECORD_TYPE)
    {
      assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
      /* Check that at least the first field name agrees.  */
      assert (DECL_NAME (TYPE_FIELDS (type))
	      == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
      assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
	      >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
      if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
	  == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
	return e;
      return fold (ffecom_convert_to_complex_ (type, e));
    }

  assert ("conversion to non-scalar type requested" == NULL);
  return error_mark_node;
}
#endif

/* Handles making a COMPLEX type, either the standard
   (but buggy?) gbe way, or the safer (but less elegant?)
   f2c way.  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_make_complex_type_ (tree subtype)
{
  tree type;
  tree realfield;
  tree imagfield;