com.c

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

			 dest_offset));

  if (integer_onep (t))
    return FALSE;		/* Destination follows source. */

  return TRUE;		/* Destination and source overlap. */
}
#endif

/* Check whether dest might overlap any of a list of arguments or is
   in a COMMON area the callee might know about (and thus modify).  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static bool
ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
			  tree args, tree callee_commons,
			  bool scalar_args)
{
  tree arg;
  tree dest_decl;
  tree dest_offset;
  tree dest_size;

  ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
			     dest_tree);

  if (dest_decl == NULL_TREE)
    return FALSE;		/* Seems unlikely! */

  /* If the decl cannot be determined reliably, or if its in COMMON
     and the callee isn't known to not futz with COMMON via other
     means, overlap might happen.  */

  if ((TREE_CODE (dest_decl) == ERROR_MARK)
      || ((callee_commons != NULL_TREE)
	  && TREE_PUBLIC (dest_decl)))
    return TRUE;

  for (; args != NULL_TREE; args = TREE_CHAIN (args))
    {
      if (((arg = TREE_VALUE (args)) != NULL_TREE)
	  && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
			      arg, NULL, scalar_args))
	return TRUE;
    }

  return FALSE;
}
#endif

/* Build a string for a variable name as used by NAMELIST.  This means that
   if we're using the f2c library, we build an uppercase string, since
   f2c does this.  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_build_f2c_string_ (int i, const char *s)
{
  if (!ffe_is_f2c_library ())
    return build_string (i, s);

  {
    char *tmp;
    const char *p;
    char *q;
    char space[34];
    tree t;

    if (((size_t) i) > ARRAY_SIZE (space))
      tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
    else
      tmp = &space[0];

    for (p = s, q = tmp; *p != '\0'; ++p, ++q)
      *q = ffesrc_toupper (*p);
    *q = '\0';

    t = build_string (i, tmp);

    if (((size_t) i) > ARRAY_SIZE (space))
      malloc_kill_ks (malloc_pool_image (), tmp, i);

    return t;
  }
}

#endif
/* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
   type to just get whatever the function returns), handling the
   f2c value-returning convention, if required, by prepending
   to the arglist a pointer to a temporary to receive the return value.	 */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
	      tree type, tree args, tree dest_tree,
	      ffebld dest, bool *dest_used, tree callee_commons,
	      bool scalar_args, tree hook)
{
  tree item;
  tree tempvar;

  if (dest_used != NULL)
    *dest_used = FALSE;

  if (is_f2c_complex)
    {
      if ((dest_used == NULL)
	  || (dest == NULL)
	  || (ffeinfo_basictype (ffebld_info (dest))
	      != FFEINFO_basictypeCOMPLEX)
	  || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
	  || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
	  || ffecom_args_overlapping_ (dest_tree, dest, args,
				       callee_commons,
				       scalar_args))
	{
#ifdef HOHO
	  tempvar = ffecom_make_tempvar (ffecom_tree_type
					 [FFEINFO_basictypeCOMPLEX][kt],
					 FFETARGET_charactersizeNONE,
					 -1);
#else
	  tempvar = hook;
	  assert (tempvar);
#endif
	}
      else
	{
	  *dest_used = TRUE;
	  tempvar = dest_tree;
	  type = NULL_TREE;
	}

      item
	= build_tree_list (NULL_TREE,
			   ffecom_1 (ADDR_EXPR,
				     build_pointer_type (TREE_TYPE (tempvar)),
				     tempvar));
      TREE_CHAIN (item) = args;

      item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
			item, NULL_TREE);

      if (tempvar != dest_tree)
	item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
    }
  else
    item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
		      args, NULL_TREE);

  if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
    item = ffecom_convert_narrow_ (type, item);

  return item;
}
#endif

/* Given two arguments, transform them and make a call to the given
   function via ffecom_call_.  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
		    tree type, ffebld left, ffebld right,
		    tree dest_tree, ffebld dest, bool *dest_used,
		    tree callee_commons, bool scalar_args, tree hook)
{
  tree left_tree;
  tree right_tree;
  tree left_length;
  tree right_length;

  left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
  right_tree = ffecom_arg_ptr_to_expr (right, &right_length);

  left_tree = build_tree_list (NULL_TREE, left_tree);
  right_tree = build_tree_list (NULL_TREE, right_tree);
  TREE_CHAIN (left_tree) = right_tree;

  if (left_length != NULL_TREE)
    {
      left_length = build_tree_list (NULL_TREE, left_length);
      TREE_CHAIN (right_tree) = left_length;
    }

  if (right_length != NULL_TREE)
    {
      right_length = build_tree_list (NULL_TREE, right_length);
      if (left_length != NULL_TREE)
	TREE_CHAIN (left_length) = right_length;
      else
	TREE_CHAIN (right_tree) = right_length;
    }

  return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
		       dest_tree, dest, dest_used, callee_commons,
		       scalar_args, hook);
}
#endif

/* Return ptr/length args for char subexpression

   Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
   subexpressions by constructing the appropriate trees for the ptr-to-
   character-text and length-of-character-text arguments in a calling
   sequence.

   Note that if with_null is TRUE, and the expression is an opCONTER,
   a null byte is appended to the string.  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
{
  tree item;
  tree high;
  ffetargetCharacter1 val;
  ffetargetCharacterSize newlen;

  switch (ffebld_op (expr))
    {
    case FFEBLD_opCONTER:
      val = ffebld_constant_character1 (ffebld_conter (expr));
      newlen = ffetarget_length_character1 (val);
      if (with_null)
	{
	  /* Begin FFETARGET-NULL-KLUDGE.  */
	  if (newlen != 0)
	    ++newlen;
	}
      *length = build_int_2 (newlen, 0);
      TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
      high = build_int_2 (newlen, 0);
      TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
      item = build_string (newlen,
			   ffetarget_text_character1 (val));
      /* End FFETARGET-NULL-KLUDGE.  */
      TREE_TYPE (item)
	= build_type_variant
	  (build_array_type
	   (char_type_node,
	    build_range_type
	    (ffecom_f2c_ftnlen_type_node,
	     ffecom_f2c_ftnlen_one_node,
	     high)),
	   1, 0);
      TREE_CONSTANT (item) = 1;
      TREE_STATIC (item) = 1;
      item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
		       item);
      break;

    case FFEBLD_opSYMTER:
      {
	ffesymbol s = ffebld_symter (expr);

	item = ffesymbol_hook (s).decl_tree;
	if (item == NULL_TREE)
	  {
	    s = ffecom_sym_transform_ (s);
	    item = ffesymbol_hook (s).decl_tree;
	  }
	if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
	  {
	    if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
	      *length = ffesymbol_hook (s).length_tree;
	    else
	      {
		*length = build_int_2 (ffesymbol_size (s), 0);
		TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
	      }
	  }
	else if (item == error_mark_node)
	  *length = error_mark_node;
	else
	  /* FFEINFO_kindFUNCTION.  */
	  *length = NULL_TREE;
	if (!ffesymbol_hook (s).addr
	    && (item != error_mark_node))
	  item = ffecom_1 (ADDR_EXPR,
			   build_pointer_type (TREE_TYPE (item)),
			   item);
      }
      break;

    case FFEBLD_opARRAYREF:
      {
	ffecom_char_args_ (&item, length, ffebld_left (expr));

	if (item == error_mark_node || *length == error_mark_node)
	  {
	    item = *length = error_mark_node;
	    break;
	  }

	item = ffecom_arrayref_ (item, expr, 1);
      }
      break;

    case FFEBLD_opSUBSTR:
      {
	ffebld start;
	ffebld end;
	ffebld thing = ffebld_right (expr);
	tree start_tree;
	tree end_tree;
	char *char_name;
	ffebld left_symter;
	tree array;

	assert (ffebld_op (thing) == FFEBLD_opITEM);
	start = ffebld_head (thing);
	thing = ffebld_trail (thing);
	assert (ffebld_trail (thing) == NULL);
	end = ffebld_head (thing);

	/* Determine name for pretty-printing range-check errors.  */
	for (left_symter = ffebld_left (expr);
	     left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
	     left_symter = ffebld_left (left_symter))
	  ;
	if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
	  char_name = ffesymbol_text (ffebld_symter (left_symter));
	else
	  char_name = "[expr?]";

	ffecom_char_args_ (&item, length, ffebld_left (expr));

	if (item == error_mark_node || *length == error_mark_node)
	  {
	    item = *length = error_mark_node;
	    break;
	  }

	array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));

	/* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */

	if (start == NULL)
	  {
	    if (end == NULL)
	      ;
	    else
	      {
		end_tree = ffecom_expr (end);
		if (ffe_is_subscript_check ())
		  end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
						      char_name);
		end_tree = convert (ffecom_f2c_ftnlen_type_node,
				    end_tree);

		if (end_tree == error_mark_node)
		  {
		    item = *length = error_mark_node;
		    break;
		  }

		*length = end_tree;
	      }
	  }
	else
	  {
	    start_tree = ffecom_expr (start);
	    if (ffe_is_subscript_check ())
	      start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
						    char_name);
	    start_tree = convert (ffecom_f2c_ftnlen_type_node,
				  start_tree);

	    if (start_tree == error_mark_node)
	      {
		item = *length = error_mark_node;
		break;
	      }

	    start_tree = ffecom_save_tree (start_tree);

	    item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
			     item,
			     ffecom_2 (MINUS_EXPR,
				       TREE_TYPE (start_tree),
				       start_tree,
				       ffecom_f2c_ftnlen_one_node));

	    if (end == NULL)
	      {
		*length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
				    ffecom_f2c_ftnlen_one_node,
				    ffecom_2 (MINUS_EXPR,
					      ffecom_f2c_ftnlen_type_node,
					      *length,
					      start_tree));
	      }
	    else
	      {
		end_tree = ffecom_expr (end);
		if (ffe_is_subscript_check ())
		  end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
						      char_name);
		end_tree = convert (ffecom_f2c_ftnlen_type_node,
				    end_tree);

		if (end_tree == error_mark_node)
		  {
		    item = *length = error_mark_node;
		    break;
		  }

		*length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
				    ffecom_f2c_ftnlen_one_node,
				    ffecom_2 (MINUS_EXPR,
					      ffecom_f2c_ftnlen_type_node,
					      end_tree, start_tree));
	      }
	  }
      }
      break;

    case FFEBLD_opFUNCREF:
      {
	ffesymbol s = ffebld_symter (ffebld_left (expr));
	tree tempvar;
	tree args;
	ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
	ffecomGfrt ix;

	if (size == FFETARGET_charactersizeNONE)
	  /* ~~Kludge alert!  This should someday be fixed. */
	  size = 24;

	*length = build_int_2 (size, 0);
	TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;

	if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
	    == FFEINFO_whereINTRINSIC)
	  {
	    if (size == 1)
	      {
		/* Invocation of an intrinsic returning CHARACTER*1.  */
		item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
					       NULL, NULL);
		break;
	      }
	    ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
	    assert (ix != FFECOM_gfrt);
	    item = ffecom_gfrt_tree_ (ix);
	  }
	else
	  {
	    ix = FFECOM_gf