true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
+#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
+ { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+ END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+ false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
+ NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
+
static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
{
/* Functions built into gcc itself. */
#include "mathbuiltins.def"
+ /* Functions in libgfortran. */
+ LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
+
/* End the list. */
- { GFC_ISYM_NONE, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS,
- END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS,
- true, false, true, NULL, NULL_TREE, NULL_TREE, NULL_TREE,
- NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
+ LIB_FUNCTION (NONE, NULL, false)
+
};
+#undef LIB_FUNCTION
#undef DEFINE_MATH_BUILTIN
#undef DEFINE_MATH_BUILTIN_C
gcc_assert (expr->value.function.actual->expr);
gfc_conv_intrinsic_function_args (se, expr, args, nargs);
+ /* Conversion between character kinds involves a call to a library
+ function. */
+ if (expr->ts.type == BT_CHARACTER)
+ {
+ tree fndecl, var, addr, tmp;
+
+ if (expr->ts.kind == 1
+ && expr->value.function.actual->expr->ts.kind == 4)
+ fndecl = gfor_fndecl_convert_char4_to_char1;
+ else if (expr->ts.kind == 4
+ && expr->value.function.actual->expr->ts.kind == 1)
+ fndecl = gfor_fndecl_convert_char1_to_char4;
+ else
+ gcc_unreachable ();
+
+ /* Create the variable storing the converted value. */
+ type = gfc_get_pchar_type (expr->ts.kind);
+ var = gfc_create_var (type, "str");
+ addr = gfc_build_addr_expr (build_pointer_type (type), var);
+
+ /* Call the library function that will perform the conversion. */
+ gcc_assert (nargs >= 2);
+ tmp = build_call_expr (fndecl, 3, addr, args[0], args[1]);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Free the temporary afterwards. */
+ tmp = gfc_call_free (var);
+ gfc_add_expr_to_block (&se->post, tmp);
+
+ se->expr = var;
+ se->string_length = args[0];
+
+ return;
+ }
+
/* Conversion from complex to non-complex involves taking the real
component of the value. */
if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
gfc_index_one_node);
+ se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
+ gfc_index_zero_node);
}
else
se->expr = gfc_index_one_node;
static void
gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
{
- tree arg;
+ tree arg[2];
tree var;
tree type;
+ unsigned int num_args;
- gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
- /* We currently don't support character types != 1. */
- gcc_assert (expr->ts.kind == 1);
- type = gfc_character1_type_node;
+ type = gfc_get_char_type (expr->ts.kind);
var = gfc_create_var (type, "char");
- arg = convert (type, arg);
- gfc_add_modify_expr (&se->pre, var, arg);
+ arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
+ gfc_add_modify_expr (&se->pre, var, arg[0]);
se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
se->string_length = integer_one_node;
}
tree var;
tree len;
tree tmp;
- tree type;
tree cond;
- tree gfc_int8_type_node = gfc_get_int_type (8);
tree fndecl;
tree *args;
unsigned int num_args;
num_args = gfc_intrinsic_argument_list_length (expr) + 2;
args = alloca (sizeof (tree) * num_args);
- type = build_pointer_type (gfc_character1_type_node);
- var = gfc_create_var (type, "pstr");
- len = gfc_create_var (gfc_int8_type_node, "len");
+ var = gfc_create_var (pchar_type_node, "pstr");
+ len = gfc_create_var (gfc_get_int_type (8), "len");
gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
args[0] = build_fold_addr_expr (var);
tree var;
tree len;
tree tmp;
- tree type;
tree cond;
- tree gfc_int4_type_node = gfc_get_int_type (4);
tree fndecl;
tree *args;
unsigned int num_args;
num_args = gfc_intrinsic_argument_list_length (expr) + 2;
args = alloca (sizeof (tree) * num_args);
- type = build_pointer_type (gfc_character1_type_node);
- var = gfc_create_var (type, "pstr");
- len = gfc_create_var (gfc_int4_type_node, "len");
+ var = gfc_create_var (pchar_type_node, "pstr");
+ len = gfc_create_var (gfc_get_int_type (4), "len");
gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
args[0] = build_fold_addr_expr (var);
tree var;
tree len;
tree tmp;
- tree type;
tree cond;
tree fndecl;
- tree gfc_int4_type_node = gfc_get_int_type (4);
tree *args;
unsigned int num_args;
num_args = gfc_intrinsic_argument_list_length (expr) + 2;
args = alloca (sizeof (tree) * num_args);
- type = build_pointer_type (gfc_character1_type_node);
- var = gfc_create_var (type, "pstr");
- len = gfc_create_var (gfc_int4_type_node, "len");
+ var = gfc_create_var (pchar_type_node, "pstr");
+ len = gfc_create_var (gfc_get_int_type (4), "len");
gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
args[0] = build_fold_addr_expr (var);
gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
{
tree *args;
- tree var, len, fndecl, tmp, cond;
+ tree var, len, fndecl, tmp, cond, function;
unsigned int nargs;
nargs = gfc_intrinsic_argument_list_length (expr);
/* Create the result variables. */
len = gfc_create_var (gfc_charlen_type_node, "len");
args[0] = build_fold_addr_expr (len);
- var = gfc_create_var (build_pointer_type (gfc_character1_type_node), "pstr");
+ var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
args[2] = build_int_cst (NULL_TREE, op);
args[3] = build_int_cst (NULL_TREE, nargs / 2);
+ if (expr->ts.kind == 1)
+ function = gfor_fndecl_string_minmax;
+ else if (expr->ts.kind == 4)
+ function = gfor_fndecl_string_minmax_char4;
+ else
+ gcc_unreachable ();
+
/* Make the function call. */
- fndecl = build_addr (gfor_fndecl_string_minmax, current_function_decl);
- tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_minmax)),
- fndecl, nargs + 4, args);
+ fndecl = build_addr (function, current_function_decl);
+ tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
+ nargs + 4, args);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
/* Remember where we are. An offset must be added to the loop
counter to obtain the required position. */
- if (loop.temp_dim)
- tmp = build_int_cst (gfc_array_index_type, 1);
+ if (loop.from[0])
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, loop.from[0]);
else
- tmp =fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, loop.from[0]);
+ tmp = build_int_cst (gfc_array_index_type, 1);
+
gfc_add_modify_expr (&block, offset, tmp);
tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
static void
gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
{
- tree args[2];
- tree type;
+ int kind = expr->value.function.actual->expr->ts.kind;
+ tree args[2], type, fndecl;
gfc_conv_intrinsic_function_args (se, expr, args, 2);
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]);
+
+ if (kind == 1)
+ fndecl = gfor_fndecl_string_len_trim;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_string_len_trim_char4;
+ else
+ gcc_unreachable ();
+
+ se->expr = build_call_expr (fndecl, 2, args[0], args[1]);
se->expr = convert (type, se->expr);
}
static void
gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
{
- tree args[2];
- tree type;
+ tree args[2], type, pchartype;
gfc_conv_intrinsic_function_args (se, expr, args, 2);
gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
- args[1] = fold_build1 (NOP_EXPR, pchar_type_node, args[1]);
+ pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
+ args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
type = gfc_typenode_for_spec (&expr->ts);
se->expr = build_fold_indirect_ref (args[1]);
}
+/* Helper function to compute the size of a character variable,
+ excluding the terminating null characters. The result has
+ gfc_array_index_type type. */
+
+static tree
+size_of_string_in_bytes (int kind, tree string_length)
+{
+ tree bytesize;
+ int i = gfc_validate_kind (BT_CHARACTER, kind, false);
+
+ bytesize = build_int_cst (gfc_array_index_type,
+ gfc_character_kinds[i].bit_size / 8);
+
+ return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
+ fold_convert (gfc_array_index_type, string_length));
+}
+
+
static void
gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
{
tree tmp;
tree lower;
tree upper;
- /*tree stride;*/
int n;
arg = expr->value.function.actual->expr;
/* Obtain the source word length. */
if (arg->ts.type == BT_CHARACTER)
- source_bytes = fold_convert (gfc_array_index_type,
- argse.string_length);
+ source_bytes = size_of_string_in_bytes (arg->ts.kind,
+ argse.string_length);
else
source_bytes = fold_convert (gfc_array_index_type,
size_in_bytes (type));
/* Obtain the argument's word length. */
if (arg->ts.type == BT_CHARACTER)
- tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
else
tmp = fold_convert (gfc_array_index_type,
size_in_bytes (type));
gfc_conv_intrinsic_function_args (se, expr, args, 4);
- se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]);
+ se->expr
+ = gfc_build_compare_string (args[0], args[1], args[2], args[3],
+ expr->value.function.actual->expr->ts.kind);
se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
build_int_cst (TREE_TYPE (se->expr), 0));
}
/* Obtain the source word length. */
if (arg->expr->ts.type == BT_CHARACTER)
- tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ tmp = size_of_string_in_bytes (arg->expr->ts.kind,
+ argse.string_length);
else
tmp = fold_convert (gfc_array_index_type,
size_in_bytes (source_type));
/* Obtain the source word length. */
if (arg->expr->ts.type == BT_CHARACTER)
- tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ tmp = size_of_string_in_bytes (arg->expr->ts.kind,
+ argse.string_length);
else
tmp = fold_convert (gfc_array_index_type,
size_in_bytes (source_type));
if (arg->expr->ts.type == BT_CHARACTER)
{
- tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
}
else
}
+/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
+
+static void
+gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
+{
+ tree args[2];
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ se->expr = build_call_expr (gfor_fndecl_sc_kind, 2, args[0], args[1]);
+ se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
+}
+
+
/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
static void
static void
gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
{
- tree gfc_int4_type_node = gfc_get_int_type (4);
tree var;
tree len;
tree addr;
tree tmp;
- tree type;
tree cond;
tree fndecl;
+ tree function;
tree *args;
unsigned int num_args;
num_args = gfc_intrinsic_argument_list_length (expr) + 2;
args = alloca (sizeof (tree) * num_args);
- type = build_pointer_type (gfc_character1_type_node);
- var = gfc_create_var (type, "pstr");
+ var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
addr = gfc_build_addr_expr (ppvoid_type_node, var);
- len = gfc_create_var (gfc_int4_type_node, "len");
+ len = gfc_create_var (gfc_get_int_type (4), "len");
gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
args[0] = build_fold_addr_expr (len);
args[1] = addr;
- fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl);
- tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)),
- fndecl, num_args, args);
+ if (expr->ts.kind == 1)
+ function = gfor_fndecl_string_trim;
+ else if (expr->ts.kind == 4)
+ function = gfor_fndecl_string_trim_char4;
+ else
+ gcc_unreachable ();
+
+ fndecl = build_addr (function, current_function_decl);
+ tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
+ num_args, args);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
{
tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
tree type, cond, tmp, count, exit_label, n, max, largest;
+ tree size;
stmtblock_t block, body;
int i;
+ /* We store in charsize the size of a character. */
+ i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
+ size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
+
/* Get the arguments. */
gfc_conv_intrinsic_function_args (se, expr, args, 3);
slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
cond);
gfc_trans_runtime_check (cond, &se->pre, &expr->where,
"Argument NCOPIES of REPEAT intrinsic is too large");
-
/* Compute the destination length. */
dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
/* Generate the code to do the repeat operation:
for (i = 0; i < ncopies; i++)
- memmove (dest + (i * slen), src, slen); */
+ memmove (dest + (i * slen * size), src, slen*size); */
gfc_start_block (&block);
count = gfc_create_var (ncopies_type, "count");
gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
- /* Call memmove (dest + (i*slen), src, slen). */
+ /* Call memmove (dest + (i*slen*size), src, slen*size). */
tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
fold_convert (gfc_charlen_type_node, slen),
fold_convert (gfc_charlen_type_node, count));
- tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
- fold_convert (pchar_type_node, dest),
+ tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
+ tmp, fold_convert (gfc_charlen_type_node, size));
+ tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
+ fold_convert (pvoid_type_node, dest),
fold_convert (sizetype, tmp));
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
- tmp, src, slen);
+ tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
+ fold_build2 (MULT_EXPR, size_type_node, slen,
+ fold_convert (size_type_node, size)));
gfc_add_expr_to_block (&body, tmp);
/* Increment count. */
{
gfc_intrinsic_sym *isym;
const char *name;
- int lib;
+ int lib, kind;
+ tree fndecl;
isym = expr->value.function.isym;
gfc_conv_intrinsic_trim (se, expr);
break;
+ case GFC_ISYM_SC_KIND:
+ gfc_conv_intrinsic_sc_kind (se, expr);
+ break;
+
case GFC_ISYM_SI_KIND:
gfc_conv_intrinsic_si_kind (se, expr);
break;
break;
case GFC_ISYM_SCAN:
- gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_scan);
+ kind = expr->value.function.actual->expr->ts.kind;
+ if (kind == 1)
+ fndecl = gfor_fndecl_string_scan;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_string_scan_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
break;
case GFC_ISYM_VERIFY:
- gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_verify);
+ kind = expr->value.function.actual->expr->ts.kind;
+ if (kind == 1)
+ fndecl = gfor_fndecl_string_verify;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_string_verify_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
break;
case GFC_ISYM_ALLOCATED:
break;
case GFC_ISYM_ADJUSTL:
- gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
+ if (expr->ts.kind == 1)
+ fndecl = gfor_fndecl_adjustl;
+ else if (expr->ts.kind == 4)
+ fndecl = gfor_fndecl_adjustl_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_adjust (se, expr, fndecl);
break;
case GFC_ISYM_ADJUSTR:
- gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
+ if (expr->ts.kind == 1)
+ fndecl = gfor_fndecl_adjustr;
+ else if (expr->ts.kind == 4)
+ fndecl = gfor_fndecl_adjustr_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_adjust (se, expr, fndecl);
break;
case GFC_ISYM_AIMAG:
break;
case GFC_ISYM_INDEX:
- gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_index);
+ kind = expr->value.function.actual->expr->ts.kind;
+ if (kind == 1)
+ fndecl = gfor_fndecl_string_index;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_string_index_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
break;
case GFC_ISYM_IOR:
OSDN Git Service
