static void
-gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
+gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
+ const char *name, locus *where)
{
tree tmp;
tree type;
tree var;
+ tree fault;
gfc_se start;
gfc_se end;
+ char *msg;
type = gfc_get_character_type (kind, ref->u.ss.length);
type = build_pointer_type (type);
gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
gfc_add_block_to_block (&se->pre, &end.pre);
}
+ if (flag_bounds_check)
+ {
+ /* Check lower bound. */
+ fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
+ build_int_cst (gfc_charlen_type_node, 1));
+ if (name)
+ asprintf (&msg, "Substring out of bounds: lower bound of '%s' "
+ "is less than one", name);
+ else
+ asprintf (&msg, "Substring out of bounds: lower bound "
+ "is less than one");
+ gfc_trans_runtime_check (fault, msg, &se->pre, where);
+ gfc_free (msg);
+
+ /* Check upper bound. */
+ fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
+ se->string_length);
+ if (name)
+ asprintf (&msg, "Substring out of bounds: upper bound of '%s' "
+ "exceeds string length", name);
+ else
+ asprintf (&msg, "Substring out of bounds: upper bound "
+ "exceeds string length");
+ gfc_trans_runtime_check (fault, msg, &se->pre, where);
+ gfc_free (msg);
+ }
+
tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
build_int_cst (gfc_charlen_type_node, 1),
start.expr);
break;
case REF_SUBSTRING:
- gfc_conv_substring (se, ref, expr->ts.kind);
+ gfc_conv_substring (se, ref, expr->ts.kind,
+ expr->symtree->name, &expr->where);
break;
default:
se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
- gfc_conv_substring(se,ref,expr->ts.kind);
+ gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where);
}