+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, build_sym, variable_decl,
+ enumerator_decl): 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-01 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/46152
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;
+ }
}
}
/* 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;
}
char_len_param_value in parenthesis. */
static match
-match_char_length (gfc_expr **expr)
+match_char_length (gfc_expr **expr, bool *deferred)
{
int length;
match m;
+ *deferred = false;
m = gfc_match_char ('*');
if (m != MATCH_YES)
return m;
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 ();
/* Function called by variable_decl() that adds a name to the symbol table. */
static gfc_try
-build_sym (const char *name, gfc_charlen *cl,
+build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
gfc_array_spec **as, locus *var_locus)
{
symbol_attribute attr;
return FAILURE;
if (sym->ts.type == BT_CHARACTER)
- sym->ts.u.cl = cl;
+ {
+ sym->ts.u.cl = cl;
+ sym->ts.deferred = cl_deferred;
+ }
/* Add dimension attribute if present. */
if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
gfc_array_spec *as;
gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
gfc_charlen *cl;
+ bool cl_deferred;
locus var_locus;
match m;
gfc_try t;
char_len = NULL;
cl = NULL;
+ cl_deferred = false;
if (current_ts.type == BT_CHARACTER)
{
- switch (match_char_length (&char_len))
+ switch (match_char_length (&char_len, &cl_deferred))
{
case MATCH_YES:
cl = gfc_new_charlen (gfc_current_ns, NULL);
else
cl = current_ts.u.cl;
+ cl_deferred = current_ts.deferred;
+
break;
case MATCH_ERROR:
create a symbol for those yet. If we fail to create the symbol,
bail out. */
if (gfc_current_state () != COMP_DERIVED
- && build_sym (name, cl, &as, &var_locus) == FAILURE)
+ && build_sym (name, cl, cl_deferred, &as, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
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;
- m = match_char_length (&len);
+ m = match_char_length (&len, &deferred);
if (m != MATCH_NO)
{
if (m == MATCH_YES)
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)
/* 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)
}
/* 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)
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. */
/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace. If we fail to create the symbol,
bail out. */
- if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
+ if (build_sym (name, NULL, false, &as, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
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)
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;
}
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;
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;
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
{
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)
break;
}
-
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
&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;
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;
}
}
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:
return SUCCESS;
}
+
/* Resolve a charlen structure. */
static gfc_try
build_init_assign (sym, init);
}
+
/* Resolution of common features of flavors variable and procedure. */
static gfc_try
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);
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)
+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.
+
2010-11-02 Richard Guenther <rguenther@suse.de>
PR tree-optimization/46149
allocate(real(8) :: x4(1)) ! { dg-error "differs from the kind type parameter" }
allocate(real(4) :: x8(1)) ! { dg-error "differs from the kind type parameter" }
allocate(double :: d1(1)) ! { dg-error "Error in type-spec at" }
- allocate(character(:) :: c1(1)) ! { dg-error "Syntax error in CHARACTER declaration" }
+ allocate(character(:) :: c1(1)) ! { dg-error "cannot contain a deferred type parameter" }
allocate(real :: b(1)) ! { dg-error "is type incompatible" }
end subroutine implicit_none_test1
allocate(real(8) :: x4) ! { dg-error "differs from the kind type parameter" }
allocate(real(4) :: x8) ! { dg-error "differs from the kind type parameter" }
allocate(double :: d1) ! { dg-error "Error in type-spec at" }
- allocate(character(:) :: c1) ! { dg-error "Syntax error in CHARACTER declaration" }
+ allocate(character(:) :: c1) ! { dg-error "cannot contain a deferred type parameter" }
allocate(real :: b) ! { dg-error "is type incompatible" }
end subroutine implicit_none_test2
allocate(real(8) :: x4(1)) ! { dg-error "differs from the kind type parameter" }
allocate(real(4) :: x8(1)) ! { dg-error "differs from the kind type parameter" }
allocate(double :: d1(1)) ! { dg-error "Error in type-spec" }
- allocate(character(:) :: c1(1)) ! { dg-error "Syntax error in CHARACTER declaration" }
+ allocate(character(:) :: c1(1)) ! { dg-error "cannot contain a deferred type parameter" }
allocate(real :: b(1)) ! { dg-error "is type incompatible" }
end subroutine implicit_test3
allocate(real(8) :: x4) ! { dg-error "differs from the kind type parameter" }
allocate(real(4) :: x8) ! { dg-error "differs from the kind type parameter" }
allocate(double :: d1) ! { dg-error "Error in type-spec at" }
- allocate(character(:) :: c1) ! { dg-error "Syntax error in CHARACTER declaration" }
+ allocate(character(:) :: c1) ! { dg-error "cannot contain a deferred type parameter" }
allocate(real :: b) ! { dg-error "is type incompatible" }
end subroutine implicit_test4
--- /dev/null
+! { 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" }
+
+character(len=4) :: str2*(:) ! { dg-error "Fortran 2003: deferred type parameter" }
+end
--- /dev/null
+! { 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
+
+subroutine five()
+character(len=4) :: str*(:)
+allocatable :: str
+end subroutine five
+
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" }
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
projects / thirdparty / gcc.git / commitdiff
