Commit 33717d59 by Jerry DeLisle

trans-expr.c (gfc_conv_missing_dummy): Set the type of the dummy argument to…

trans-expr.c (gfc_conv_missing_dummy): Set the type of the dummy argument to default integer if flagged to do so.

2007-11-18  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	* trans-expr.c (gfc_conv_missing_dummy): Set the type of the dummy
	argument to default integer if flagged to do so. Fix typo in comment.
	* resolve.c (gfc_resolve_dim_arg): Whitespace cleanup.
	* iresolve.c (gfc_resolve_cshift): Do not convert type, mark attribute
	for converting the DIM type appropriately in trans-expr.c.
	(gfc_resolve_eoshift): Likewise.
	* check.c (dim_check): Remove pre-existing dead code.
	(gfc_check_cshift): Enable dim_check to allow DIM as an optional.
	(gfc_check_eoshift): Likewise.
	* trans_intrinsic.c (gfc_conv_intrinsic_function_args): Fix whitespace.

From-SVN: r130276
parent 05969da4
2007-11-18 Jerry DeLisle <jvdelisle@gcc.gnu.org>
* trans-expr.c (gfc_conv_missing_dummy): Set the type of the dummy
argument to default integer if flagged to do so. Fix typo in comment.
* resolve.c (gfc_resolve_dim_arg): Whitespace cleanup.
* iresolve.c (gfc_resolve_cshift): Do not convert type, mark attribute
for converting the DIM type appropriately in trans-expr.c.
(gfc_resolve_eoshift): Likewise.
* check.c (dim_check): Remove pre-existing dead code.
(gfc_check_cshift): Enable dim_check to allow DIM as an optional.
(gfc_check_eoshift): Likewise.
* trans_intrinsic.c (gfc_conv_intrinsic_function_args): Fix whitespace.
2007-11-18 Paul Thomas <pault@gcc.gnu.org> 2007-11-18 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31608 PR fortran/31608
......
...@@ -315,13 +315,6 @@ dim_check (gfc_expr *dim, int n, bool optional) ...@@ -315,13 +315,6 @@ dim_check (gfc_expr *dim, int n, bool optional)
if (dim == NULL) if (dim == NULL)
return SUCCESS; return SUCCESS;
if (dim == NULL)
{
gfc_error ("Missing DIM parameter in intrinsic '%s' at %L",
gfc_current_intrinsic, gfc_current_intrinsic_where);
return FAILURE;
}
if (type_check (dim, n, BT_INTEGER) == FAILURE) if (type_check (dim, n, BT_INTEGER) == FAILURE)
return FAILURE; return FAILURE;
...@@ -870,8 +863,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) ...@@ -870,8 +863,7 @@ gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
/* TODO: more requirements on shift parameter. */ /* TODO: more requirements on shift parameter. */
} }
/* FIXME (PR33317): Allow optional DIM=. */ if (dim_check (dim, 2, true) == FAILURE)
if (dim_check (dim, 2, false) == FAILURE)
return FAILURE; return FAILURE;
return SUCCESS; return SUCCESS;
...@@ -1040,8 +1032,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, ...@@ -1040,8 +1032,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
/* TODO: more restrictions on boundary. */ /* TODO: more restrictions on boundary. */
} }
/* FIXME (PR33317): Allow optional DIM=. */ if (dim_check (dim, 4, true) == FAILURE)
if (dim_check (dim, 4, false) == FAILURE)
return FAILURE; return FAILURE;
return SUCCESS; return SUCCESS;
......
...@@ -583,13 +583,10 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, ...@@ -583,13 +583,10 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
gfc_convert_type_warn (shift, &ts, 2, 0); gfc_convert_type_warn (shift, &ts, 2, 0);
} }
if (dim != NULL) /* Mark this for later setting the type in gfc_conv_missing_dummy. */
{ if (dim != NULL && dim->symtree != NULL)
gfc_resolve_dim_arg (dim); dim->symtree->n.sym->attr.untyped = 1;
/* Convert dim to shift's kind, so we don't need so many variations. */
if (dim->ts.kind != shift->ts.kind)
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
}
f->value.function.name f->value.function.name
= gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind, = gfc_get_string (PREFIX ("cshift%d_%d%s"), n, shift->ts.kind,
array->ts.type == BT_CHARACTER ? "_char" : ""); array->ts.type == BT_CHARACTER ? "_char" : "");
...@@ -707,13 +704,9 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, ...@@ -707,13 +704,9 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
gfc_convert_type_warn (shift, &ts, 2, 0); gfc_convert_type_warn (shift, &ts, 2, 0);
} }
if (dim != NULL) /* Mark this for later setting the type in gfc_conv_missing_dummy. */
{ if (dim != NULL && dim->symtree != NULL)
gfc_resolve_dim_arg (dim); dim->symtree->n.sym->attr.untyped = 1;
/* Convert dim to shift's kind, so we don't need so many variations. */
if (dim->ts.kind != shift->ts.kind)
gfc_convert_type_warn (dim, &shift->ts, 2, 0);
}
f->value.function.name f->value.function.name
= gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind, = gfc_get_string (PREFIX ("eoshift%d_%d%s"), n, shift->ts.kind,
......
...@@ -3445,11 +3445,13 @@ gfc_resolve_dim_arg (gfc_expr *dim) ...@@ -3445,11 +3445,13 @@ gfc_resolve_dim_arg (gfc_expr *dim)
return FAILURE; return FAILURE;
} }
if (dim->ts.type != BT_INTEGER) if (dim->ts.type != BT_INTEGER)
{ {
gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where); gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
return FAILURE; return FAILURE;
} }
if (dim->ts.kind != gfc_index_integer_kind) if (dim->ts.kind != gfc_index_integer_kind)
{ {
gfc_typespec ts; gfc_typespec ts;
......
...@@ -152,11 +152,21 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts) ...@@ -152,11 +152,21 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts)
tree tmp; tree tmp;
present = gfc_conv_expr_present (arg->symtree->n.sym); present = gfc_conv_expr_present (arg->symtree->n.sym);
tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
fold_convert (TREE_TYPE (se->expr), integer_zero_node)); /* Make sure the type is at least default integer kind to match certain
runtime library functions. (ie cshift and eoshift). */
if (ts.type == BT_INTEGER && arg->symtree->n.sym->attr.untyped)
{
tmp = gfc_get_int_type (gfc_default_integer_kind);
tmp = fold_convert (tmp, se->expr);
}
else
tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
fold_convert (TREE_TYPE (se->expr), integer_zero_node));
tmp = gfc_evaluate_now (tmp, &se->pre); tmp = gfc_evaluate_now (tmp, &se->pre);
se->expr = tmp; se->expr = tmp;
if (ts.type == BT_CHARACTER) if (ts.type == BT_CHARACTER)
{ {
tmp = build_int_cst (gfc_charlen_type_node, 0); tmp = build_int_cst (gfc_charlen_type_node, 0);
...@@ -3400,7 +3410,7 @@ gfc_conv_expr_val (gfc_se * se, gfc_expr * expr) ...@@ -3400,7 +3410,7 @@ gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
} }
} }
/* Helper to translate and expression and convert it to a particular type. */ /* Helper to translate an expression and convert it to a particular type. */
void void
gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type) gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
{ {
......
...@@ -210,7 +210,7 @@ gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr, ...@@ -210,7 +210,7 @@ gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
/* If an optional argument is itself an optional dummy argument, /* If an optional argument is itself an optional dummy argument,
check its presence and substitute a null if absent. */ check its presence and substitute a null if absent. */
if (e->expr_type ==EXPR_VARIABLE if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional && e->symtree->n.sym->attr.optional
&& formal && formal
&& formal->optional) && formal->optional)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment