2010-11-02 Steven G. Kargl < kargl@gcc.gnu.org>
Tobias Burnus <burnus@net-b.de>
PR fortran/45170
* array.c (gfc_match_array_constructor): Reject deferred type
parameter (DTP) in type-spec.
* decl.c (char_len_param_value, match_char_length,
gfc_match_char_spec): Support DTP.
* expr.c (check_inquiry): Fix check due to support for DTP.
* gfortran.h (gfc_typespec): Add Boolean 'deferred'.
* misc.c (gfc_clear_ts): Set it to false.
* match.c (gfc_match_allocate): Support DTP.
* resolve.c (resolve_allocate_expr): Not-implemented error for DTP.
(resolve_fl_variable): Add DTP constraint check.
* trans-decl.c (gfc_trans_deferred_vars): Add not-implemented
error for DTP.
2010-11-02 Steven G. Kargl < kargl@gcc.gnu.org>
Tobias Burnus <burnus@net-b.de>
PR fortran/45170
* gfortran.dg/deferred_type_param_1.f90: New.
* gfortran.dg/deferred_type_param_2.f90: New.
* gfortran.dg/initialization_1.f90: Update dg-errors.
* gfortran.dg/initialization_9.f90: Update dg-errors.
@@ -1035,6 +1035,13 @@ gfc_match_array_constructor (gfc_expr **result)
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
"including type specification at %C") == FAILURE)
goto cleanup;
+
+ if (ts.deferred)
+ {
+ gfc_error ("Type-spec at %L cannot contain a deferred "
+ "type parameter", &where);
+ goto cleanup;
+ }
}
}
@@ -647,16 +647,27 @@ match_intent_spec (void)
/* Matches a character length specification, which is either a
- specification expression or a '*'. */
+ specification expression, '*', or ':'. */
static match
-char_len_param_value (gfc_expr **expr)
+char_len_param_value (gfc_expr **expr, bool *deferred)
{
match m;
+ *expr = NULL;
+ *deferred = false;
+
if (gfc_match_char ('*') == MATCH_YES)
+ return MATCH_YES;
+
+ if (gfc_match_char (':') == MATCH_YES)
{
- *expr = NULL;
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: deferred type "
+ "parameter at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ *deferred = true;
+
return MATCH_YES;
}
@@ -701,6 +712,7 @@ match_char_length (gfc_expr **expr)
{
int length;
match m;
+ bool deferred = false;
m = gfc_match_char ('*');
if (m != MATCH_YES)
@@ -722,7 +734,7 @@ match_char_length (gfc_expr **expr)
if (gfc_match_char ('(') == MATCH_NO)
goto syntax;
- m = char_len_param_value (expr);
+ m = char_len_param_value (expr, &deferred);
if (m != MATCH_YES && gfc_matching_function)
{
gfc_undo_symbols ();
@@ -2277,11 +2289,13 @@ gfc_match_char_spec (gfc_typespec *ts)
gfc_charlen *cl;
gfc_expr *len;
match m;
+ bool deferred;
len = NULL;
seen_length = 0;
kind = 0;
is_iso_c = 0;
+ deferred = false;
/* Try the old-style specification first. */
old_char_selector = 0;
@@ -2315,7 +2329,7 @@ gfc_match_char_spec (gfc_typespec *ts)
if (gfc_match (" , len =") == MATCH_NO)
goto rparen;
- m = char_len_param_value (&len);
+ m = char_len_param_value (&len, &deferred);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
@@ -2328,7 +2342,7 @@ gfc_match_char_spec (gfc_typespec *ts)
/* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
if (gfc_match (" len =") == MATCH_YES)
{
- m = char_len_param_value (&len);
+ m = char_len_param_value (&len, &deferred);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
@@ -2348,7 +2362,7 @@ gfc_match_char_spec (gfc_typespec *ts)
}
/* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
- m = char_len_param_value (&len);
+ m = char_len_param_value (&len, &deferred);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
@@ -2407,6 +2421,7 @@ done:
ts->u.cl = cl;
ts->kind = kind == 0 ? gfc_default_character_kind : kind;
+ ts->deferred = deferred;
/* We have to know if it was a c interoperable kind so we can
do accurate type checking of bind(c) procs, etc. */
@@ -2292,10 +2292,13 @@ check_inquiry (gfc_expr *e, int not_restricted)
with LEN, as required by the standard. */
if (i == 5 && not_restricted
&& ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
- && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
+ && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
+ || ap->expr->symtree->n.sym->ts.deferred))
{
- gfc_error ("Assumed character length variable '%s' in constant "
- "expression at %L", e->symtree->n.sym->name, &e->where);
+ gfc_error ("Assumed or deferred character length variable '%s' "
+ " in constant expression at %L",
+ ap->expr->symtree->n.sym->name,
+ &ap->expr->where);
return MATCH_ERROR;
}
else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
@@ -885,7 +885,7 @@ typedef struct gfc_charlen
struct gfc_charlen *next;
bool length_from_typespec; /* Length from explicit array ctor typespec? */
tree backend_decl;
- tree passed_length; /* Length argument explicitelly passed. */
+ tree passed_length; /* Length argument explicitly passed. */
int resolved;
}
@@ -910,7 +910,8 @@ typedef struct
struct gfc_symbol *interface; /* For PROCEDURE declarations. */
int is_c_interop;
int is_iso_c;
- bt f90_type;
+ bt f90_type;
+ bool deferred;
}
gfc_typespec;
@@ -2845,12 +2845,12 @@ gfc_match_allocate (void)
gfc_typespec ts;
gfc_symbol *sym;
match m;
- locus old_locus;
- bool saw_stat, saw_errmsg, saw_source, saw_mold, b1, b2, b3;
+ locus old_locus, deferred_locus;
+ bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
head = tail = NULL;
stat = errmsg = source = mold = tmp = NULL;
- saw_stat = saw_errmsg = saw_source = saw_mold = false;
+ saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
@@ -2879,6 +2879,13 @@ gfc_match_allocate (void)
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
"ALLOCATE at %L", &old_locus) == FAILURE)
goto cleanup;
+
+ if (ts.deferred)
+ {
+ gfc_error ("Type-spec at %L cannot contain a deferred "
+ "type parameter", &old_locus);
+ goto cleanup;
+ }
}
else
{
@@ -2912,6 +2919,12 @@ gfc_match_allocate (void)
goto cleanup;
}
+ if (tail->expr->ts.deferred)
+ {
+ saw_deferred = true;
+ deferred_locus = tail->expr->where;
+ }
+
/* The ALLOCATE statement had an optional typespec. Check the
constraints. */
if (ts.type != BT_UNKNOWN)
@@ -3095,7 +3108,6 @@ alloc_opt_list:
break;
}
-
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
@@ -3106,6 +3118,14 @@ alloc_opt_list:
&mold->where, &source->where);
goto cleanup;
}
+
+ /* Check F03:C623, */
+ if (saw_deferred && ts.type == BT_UNKNOWN && !source)
+ {
+ gfc_error ("Allocate-object at %L with a deferred type parameter "
+ "requires either a type-spec or SOURCE tag", &deferred_locus);
+ goto cleanup;
+ }
new_st.op = EXEC_ALLOCATE;
new_st.expr1 = stat;
@@ -77,6 +77,7 @@ gfc_clear_ts (gfc_typespec *ts)
ts->f90_type = BT_UNKNOWN;
/* flag that says whether it's from iso_c_binding or not */
ts->is_iso_c = 0;
+ ts->deferred = false;
}
@@ -6856,6 +6856,12 @@ check_symbols:
}
success:
+ if (e->ts.deferred)
+ {
+ gfc_error ("Support for entity at %L with deferred type parameter "
+ "not yet implemented", &e->where);
+ return FAILURE;
+ }
return SUCCESS;
failure:
@@ -9371,6 +9377,7 @@ resolve_index_expr (gfc_expr *e)
return SUCCESS;
}
+
/* Resolve a charlen structure. */
static gfc_try
@@ -9684,6 +9691,7 @@ apply_default_init_local (gfc_symbol *sym)
build_init_assign (sym, init);
}
+
/* Resolution of common features of flavors variable and procedure. */
static gfc_try
@@ -9847,12 +9855,22 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
return FAILURE;
}
+ /* Constraints on deferred type parameter. */
+ if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
+ {
+ gfc_error ("Entity '%s' at %L has a deferred type parameter and "
+ "requires either the pointer or allocatable attribute",
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
if (sym->ts.type == BT_CHARACTER)
{
/* Make sure that character string variables with assumed length are
dummy arguments. */
e = sym->ts.u.cl->length;
- if (e == NULL && !sym->attr.dummy && !sym->attr.result)
+ if (e == NULL && !sym->attr.dummy && !sym->attr.result
+ && !sym->ts.deferred)
{
gfc_error ("Entity with assumed character length at %L must be a "
"dummy argument or a PARAMETER", &sym->declared_at);
@@ -3416,6 +3416,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
}
+ else if (sym->ts.deferred)
+ gfc_fatal_error ("Deferred type parameter not yet supported");
else if (sym_has_alloc_comp)
gfc_trans_deferred_array (sym, block);
else if (sym->ts.type == BT_CHARACTER)
new file mode 100644
@@ -0,0 +1,10 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR fortran/45170
+!
+! Character deferred type parameter
+!
+implicit none
+character(len=:), allocatable :: str(:) ! { dg-error "Fortran 2003: deferred type parameter" }
+end
new file mode 100644
@@ -0,0 +1,56 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/45170
+!
+! Character deferred type parameter
+!
+
+subroutine one(x, y) ! { dg-error "Entity .y. at .1. has a deferred type parameter" }
+ implicit none
+ character(len=:), pointer :: x
+ character(len=:) :: y
+ character(len=:), allocatable, target :: str2
+ character(len=:), target :: str ! { dg-error "deferred type parameter" }
+end subroutine one
+
+subroutine two()
+ implicit none
+ character(len=:), allocatable, target :: str1(:)
+ character(len=5), save, target :: str2
+ character(len=:), pointer :: pstr => str2
+ character(len=:), pointer :: pstr2(:)
+end subroutine two
+
+subroutine three()
+! implicit none ! Disabled because of PR 46152
+ character(len=:), allocatable, target :: str1(:)
+ character(len=5), save, target :: str2
+ character(len=:), pointer :: pstr
+ character(len=:), pointer :: pstr2(:)
+
+ pstr => str2
+ pstr2 => str1
+ str1 = ["abc"]
+ pstr2 => str1
+
+ allocate (character(len=77) :: str1(1)) ! OK ! { dg-error "not yet implemented" }
+ allocate (pstr, source=str2) ! OK ! { dg-error "not yet implemented" }
+ allocate (pstr, mold=str2) ! { dg-error "requires either a type-spec or SOURCE tag" }
+ allocate (pstr) ! { dg-error "requires either a type-spec or SOURCE tag" }
+ allocate (character(len=:) :: str1(1)) ! { dg-error "cannot contain a deferred type parameter" }
+
+ str1 = [ character(len=2) :: "abc" ]
+ str1 = [ character(len=:) :: "abc" ] ! { dg-error "cannot contain a deferred type parameter" }
+end subroutine three
+
+subroutine four()
+ implicit none
+ character(len=:), allocatable, target :: str
+ character(len=:), pointer :: pstr
+ pstr => str
+ str = "abc"
+ if(len(pstr) /= len(str) .or. len(str)/= 3) call abort()
+ str = "abcd"
+ if(len(pstr) /= len(str) .or. len(str)/= 4) call abort()
+end subroutine four
@@ -24,7 +24,7 @@ contains
real :: z(2, 2)
! However, this gives a warning because it is an initialization expression.
- integer :: l1 = len (ch1) ! { dg-warning "Assumed character length variable" }
+ integer :: l1 = len (ch1) ! { dg-warning "Assumed or deferred character length variable" }
! These are warnings because they are gfortran extensions.
integer :: m3 = size (x, 1) ! { dg-error "Assumed size array" }
@@ -5,7 +5,7 @@
integer function xstrcmp(s1)
character*(*), intent(in) :: s1
- integer :: n1 = len(s1) ! { dg-error "Assumed character length variable" }
+ integer :: n1 = len(s1) ! { dg-error "Assumed or deferred character length variable" }
n1 = 1
return
end function xstrcmp