trans-intrinsic.c

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

  tree tmp;
  tree width;
  tree num_bits;
  tree cond;
  tree lshift;
  tree rshift;

  arg = gfc_conv_intrinsic_function_args (se, expr);
  arg2 = TREE_VALUE (TREE_CHAIN (arg));
  arg = TREE_VALUE (arg);
  type = TREE_TYPE (arg);
  utype = gfc_unsigned_type (type);

  width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);

  /* Left shift if positive.  */
  lshift = fold_build2 (LSHIFT_EXPR, type, arg, width);

  /* Right shift if negative.
     We convert to an unsigned type because we want a logical shift.
     The standard doesn't define the case of shifting negative
     numbers, and we try to be compatible with other compilers, most
     notably g77, here.  */
  rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype, 
				       convert (utype, arg), width));

  tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2,
		     build_int_cst (TREE_TYPE (arg2), 0));
  tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);

  /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
     gcc requires a shift width < BIT_SIZE(I), so we have to catch this
     special case.  */
  num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type));
  cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);

  se->expr = fold_build3 (COND_EXPR, type, cond,
			  build_int_cst (type, 0), tmp);
}

/* Circular shift.  AKA rotate or barrel shift.  */
static void
gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
{
  tree arg;
  tree arg2;
  tree arg3;
  tree type;
  tree tmp;
  tree lrot;
  tree rrot;
  tree zero;

  arg = gfc_conv_intrinsic_function_args (se, expr);
  arg2 = TREE_CHAIN (arg);
  arg3 = TREE_CHAIN (arg2);
  if (arg3)
    {
      /* Use a library function for the 3 parameter version.  */
      tree int4type = gfc_get_int_type (4);

      type = TREE_TYPE (TREE_VALUE (arg));
      /* We convert the first argument to at least 4 bytes, and
	 convert back afterwards.  This removes the need for library
	 functions for all argument sizes, and function will be
	 aligned to at least 32 bits, so there's no loss.  */
      if (expr->ts.kind < 4)
	{
	  tmp = convert (int4type, TREE_VALUE (arg));
	  TREE_VALUE (arg) = tmp;
	}
      /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
         need loads of library  functions.  They cannot have values >
	 BIT_SIZE (I) so the conversion is safe.  */
      TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
      TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));

      switch (expr->ts.kind)
	{
	case 1:
	case 2:
	case 4:
	  tmp = gfor_fndecl_math_ishftc4;
	  break;
	case 8:
	  tmp = gfor_fndecl_math_ishftc8;
	  break;
	case 16:
	  tmp = gfor_fndecl_math_ishftc16;
	  break;
	default:
	  gcc_unreachable ();
	}
      se->expr = gfc_build_function_call (tmp, arg);
      /* Convert the result back to the original type, if we extended
	 the first argument's width above.  */
      if (expr->ts.kind < 4)
	se->expr = convert (type, se->expr);

      return;
    }
  arg = TREE_VALUE (arg);
  arg2 = TREE_VALUE (arg2);
  type = TREE_TYPE (arg);

  /* Rotate left if positive.  */
  lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2);

  /* Rotate right if negative.  */
  tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
  rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp);

  zero = build_int_cst (TREE_TYPE (arg2), 0);
  tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero);
  rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);

  /* Do nothing if shift == 0.  */
  tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero);
  se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot);
}

/* The length of a character string.  */
static void
gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
{
  tree len;
  tree type;
  tree decl;
  gfc_symbol *sym;
  gfc_se argse;
  gfc_expr *arg;

  gcc_assert (!se->ss);

  arg = expr->value.function.actual->expr;

  type = gfc_typenode_for_spec (&expr->ts);
  switch (arg->expr_type)
    {
    case EXPR_CONSTANT:
      len = build_int_cst (NULL_TREE, arg->value.character.length);
      break;

    default:
	if (arg->expr_type == EXPR_VARIABLE
	    && (arg->ref == NULL || (arg->ref->next == NULL
				     && arg->ref->type == REF_ARRAY)))
	  {
	    /* This doesn't catch all cases.
	       See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
	       and the surrounding thread.  */
	    sym = arg->symtree->n.sym;
	    decl = gfc_get_symbol_decl (sym);
	    if (decl == current_function_decl && sym->attr.function
		&& (sym->result == sym))
	      decl = gfc_get_fake_result_decl (sym);

	    len = sym->ts.cl->backend_decl;
	    gcc_assert (len);
	  }
	else
	  {
	    /* Anybody stupid enough to do this deserves inefficient code.  */
	    gfc_init_se (&argse, se);
	    gfc_conv_expr (&argse, arg);
	    gfc_add_block_to_block (&se->pre, &argse.pre);
	    gfc_add_block_to_block (&se->post, &argse.post);
	    len = argse.string_length;
	}
      break;
    }
  se->expr = convert (type, len);
}

/* The length of a character string not including trailing blanks.  */
static void
gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
{
  tree args;
  tree type;

  args = gfc_conv_intrinsic_function_args (se, expr);
  type = gfc_typenode_for_spec (&expr->ts);
  se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args);
  se->expr = convert (type, se->expr);
}


/* Returns the starting position of a substring within a string.  */

static void
gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
{
  tree logical4_type_node = gfc_get_logical_type (4);
  tree args;
  tree back;
  tree type;
  tree tmp;

  args = gfc_conv_intrinsic_function_args (se, expr);
  type = gfc_typenode_for_spec (&expr->ts);
  tmp = gfc_advance_chain (args, 3);
  if (TREE_CHAIN (tmp) == NULL_TREE)
    {
      back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
			NULL_TREE);
      TREE_CHAIN (tmp) = back;
    }
  else
    {
      back = TREE_CHAIN (tmp);
      TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
    }

  se->expr = gfc_build_function_call (gfor_fndecl_string_index, args);
  se->expr = convert (type, se->expr);
}

/* The ascii value for a single character.  */
static void
gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
{
  tree arg;
  tree type;

  arg = gfc_conv_intrinsic_function_args (se, expr);
  arg = TREE_VALUE (TREE_CHAIN (arg));
  gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
  arg = build1 (NOP_EXPR, pchar_type_node, arg);
  type = gfc_typenode_for_spec (&expr->ts);

  se->expr = gfc_build_indirect_ref (arg);
  se->expr = convert (type, se->expr);
}


/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */

static void
gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
{
  tree arg;
  tree tsource;
  tree fsource;
  tree mask;
  tree type;
  tree len;

  arg = gfc_conv_intrinsic_function_args (se, expr);
  if (expr->ts.type != BT_CHARACTER)
    {
      tsource = TREE_VALUE (arg);
      arg = TREE_CHAIN (arg);
      fsource = TREE_VALUE (arg);
      mask = TREE_VALUE (TREE_CHAIN (arg));
    }
  else
    {
      /* We do the same as in the non-character case, but the argument
	 list is different because of the string length arguments. We
	 also have to set the string length for the result.  */
      len = TREE_VALUE (arg);
      arg = TREE_CHAIN (arg);
      tsource = TREE_VALUE (arg);
      arg = TREE_CHAIN (TREE_CHAIN (arg));
      fsource = TREE_VALUE (arg);
      mask = TREE_VALUE (TREE_CHAIN (arg));

      se->string_length = len;
    }
  type = TREE_TYPE (tsource);
  se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
}


static void
gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
{
  gfc_actual_arglist *actual;
  tree args;
  tree type;
  tree fndecl;
  gfc_se argse;
  gfc_ss *ss;

  gfc_init_se (&argse, NULL);
  actual = expr->value.function.actual;

  ss = gfc_walk_expr (actual->expr);
  gcc_assert (ss != gfc_ss_terminator);
  argse.want_pointer = 1;
  gfc_conv_expr_descriptor (&argse, actual->expr, ss);
  gfc_add_block_to_block (&se->pre, &argse.pre);
  gfc_add_block_to_block (&se->post, &argse.post);
  args = gfc_chainon_list (NULL_TREE, argse.expr);

  actual = actual->next;
  if (actual->expr)
    {
      gfc_init_se (&argse, NULL);
      gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
      gfc_add_block_to_block (&se->pre, &argse.pre);
      args = gfc_chainon_list (args, argse.expr);
      fndecl = gfor_fndecl_size1;
    }
  else
    fndecl = gfor_fndecl_size0;

  se->expr = gfc_build_function_call (fndecl, args);
  type = gfc_typenode_for_spec (&expr->ts);
  se->expr = convert (type, se->expr);
}


/* Intrinsic string comparison functions.  */

  static void
gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
{
  tree type;
  tree args;
  tree arg2;

  args = gfc_conv_intrinsic_function_args (se, expr);
  arg2 = TREE_CHAIN (TREE_CHAIN (args));

  se->expr = gfc_build_compare_string (TREE_VALUE (args),
		TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
		TREE_VALUE (TREE_CHAIN (arg2)));
 
  type = gfc_typenode_for_spec (&expr->ts);
  se->expr = fold_build2 (op, type, se->expr,
		     build_int_cst (TREE_TYPE (se->expr), 0));
}

/* Generate a call to the adjustl/adjustr library function.  */
static void
gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
{
  tree args;
  tree len;
  tree type;
  tree var;
  tree tmp;

  args = gfc_conv_intrinsic_function_args (se, expr);
  len = TREE_VALUE (args);

  type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
  var = gfc_conv_string_tmp (se, type, len);
  args = tree_cons (NULL_TREE, var, args);

  tmp = gfc_build_function_call (fndecl, args);
  gfc_add_expr_to_block (&se->pre, tmp);
  se->expr = var;
  se->string_length = len;
}


/* Scalar transfer statement.
   TRANSFER (source, mold) = *(typeof<mold> *)&source.  */

static void
gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
{
  gfc_actual_arglist *arg;
  gfc_se argse;
  tree type;
  tree ptr;
  gfc_ss *ss;

  gcc_assert (!se->ss);

  /* Get a pointer to the source.  */
  arg = expr->value.function.actual;
  ss = gfc_walk_expr (arg->expr);
  gfc_init_se (&argse, NULL);
  if (ss == gfc_ss_terminator)
    gfc_conv_expr_reference (&argse, arg->expr);
  else
    gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
  gfc_add_block_to_block (&se->pre, &argse.pre);
  gfc_add_block_to_block (&se->post, &argse.post);
  ptr = argse.expr;

  arg = arg->next;
  type = gfc_typenode_for_spec (&expr->ts);
  ptr = convert (build_pointer_type (type), ptr);
  if (expr->ts.type == BT_CHARACTER)
    {
      gfc_init_se (&argse, NULL);
      gfc_conv_expr (&argse, arg->expr);
      gfc_add_block_to_block (&se->pre, &argse.pre);
      gfc_add_block_to_block (&se->post, &argse.post);
      se->expr = ptr;
      se->string_length = argse.string_length;
    }
  else
    {
      se->expr = gfc_build_indirect_ref (ptr);
    }
}


/* Generate code for the ALLOCATED intrinsic.
   Generate inline code that directly check the address of the argument.  */

static void
gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
{
  gfc_actual_arglist *arg1;
  gfc_se arg1se;
  gfc_ss *ss1;
  tree tmp;

  gfc_init_se (&arg1se, NULL);
  arg1 = expr->value.function.actual;
  ss1 = gfc_walk_expr (arg1->expr);
  arg1se.descriptor_only = 1;
  gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);

  tmp = gfc_conv_descriptor_data_get (arg1se.expr);
  tmp = build2 (NE_EXPR, boolean_type_node, tmp,
		fold_convert (TREE_TYPE (tmp), null_pointer_node));
  se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
}


/* Generate code for the ASSOCIATED intrinsic.
   If both POINTER and TARGET are arrays, generate a call to library function
   _gfor_associated, and pass descriptors of POINTER and TARGET to it.
   In other cases, generate inline code that directly compare the address of
   POINTER with the address of TARGET.  */

static void
gfc_conv_associated (gfc_se *se, gfc_expr *expr)
{
  gfc_actual_arglist *arg1;
  gfc_actual_arglist *arg2;
  gfc_se arg1se;
  gfc_se arg2se;
  tree tmp2;
  tree tmp;
  tree args, fndecl;
  gfc_ss *ss1, *ss2;

  gfc_init_se (&arg1se, NULL);
  gfc_init_se (&arg2se, NULL);
  arg1 = expr->value.function.actual;
  arg2 = arg1->next;
  ss1 = gfc_walk_expr (arg1->expr);

  if (!arg2->expr)
    {
      /* No optional target.  */
      if (ss1 == gfc_ss_terminator)
        {
          /* A pointer to a scalar.  */
          arg1se.want_pointer = 1;
          gfc_conv_expr (&arg1se, arg1->expr);
          tmp2 = arg1se.expr;
        }
      else
        {
          /* A pointer to an array.  */
          arg1se.descriptor_only = 1;
          gfc_conv_expr_lhs (&arg1se, arg1->expr);
          tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
        }
      tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
		    fold_convert (TREE_TYPE (tmp2), null_pointer_node));
      se->expr = tmp;
    }
  else
    {
      /* An optional target.  */
      ss2 = gfc_walk_expr (arg2->expr);
      if (ss1 == gfc_ss_terminator)
        {
          /* A pointer to a scalar.  */
          gcc_assert (ss2 == gfc_ss_terminator);
          arg1se.want_pointer = 1;
          gfc_conv_expr (&arg1se, arg1->expr);
          arg2se.want_pointer = 1;