I intend to commit the attached patch on Saturday. 2018-12-02 Steven G. Kargl <ka...@gcc.gnu.org>
PR fortran/87922 * io.c (gfc_match_open): ASYNCHRONOUS must be scalar. PR fortran/87945 * decl.c (var_element): Inquiry parameter cannot be a data object. (match_data_constant): Inquiry parameter can be a data in a data statement. PR fortran/88139 * dump-parse-tree.c (write_proc): Alternate return. PR fortran/88025 * expr.c (gfc_apply_init): Remove asserts and check for valid ts->u.cl->length. PR fortran/88048 * resolve.c (check_data_variable): Convert gfc_internal_error to an gfc_error. Add a nearby missing 'return false;' PR fortran/88116 * simplify.c: Remove internal error and return gfc_bad_expr. PR fortran/88205 * io.c (gfc_match_open): STATUS must be CHARACTER type. PR fortran/88206 * match.c (gfc_match_type_spec): REAL can be an intrinsic function. PR fortran/88228 * expr.c (check_null, check_elemental): Work around -fdec and initialization with logical operators operating on integers. PR fortran/88249 * gfortran.h: Update prototype for gfc_resolve_filepos * io.c (gfc_resolve_filepos): Accept the locus to include in errors. * resolve.c (gfc_resolve_code): Pass locus. PR fortran/88269 * io.c (io_constraint): Update macro. Remove incompatible use of io_constraint and give explicit error. PR fortran/88328 * io.c (resolve_tag_format): Detect zero-sized array. 2018-12-02 Steven G. Kargl <ka...@gcc.gnu.org> PR fortran/87922 * gfortran.dg/pr87922.f90: New test. PR fortran/887945 * gfortran.dg/pr87945_1.f90: New test. * gfortran.dg/pr87945_2.f90: New test. PR fortran/87994 * gfortran.dg/pr87994_1.f90: New test. * gfortran.dg/pr87994_2.f90: New test. * gfortran.dg/pr87994_3.f90: New test. PR fortran/88025 * gfortran.dg/pr88025.f90: New test. PR fortran/88048 * gfortran.dg/pr88048.f90: New test. PR fortran/88116 * gfortran.dg/pr88116_1.f90: New test. * gfortran.dg/pr88116_2.f90: New test. PR fortran/88139 * gfortran.dg/pr88139.f90: New test. PR fortran/88205 * gfortran.dg/pr88205.f90: New test. PR fortran/88206 * gfortran.dg/pr88206.f90: New test. PR fortran/88228 * gfortran.dg/pr88228.f90: New test. PR fortran/88249 * gfortran.dg/pr88249.f90: New test. PR fortran/88269 * gfortran.dg/pr88269.f90: New test. PR fortran/88328 * gfortran.dg/pr88328.f90: New test. -- Steve
Index: gcc/fortran/decl.c =================================================================== --- gcc/fortran/decl.c (revision 266718) +++ gcc/fortran/decl.c (working copy) @@ -281,6 +281,14 @@ var_element (gfc_data_variable *new_var) if (m != MATCH_YES) return m; + if (new_var->expr->expr_type == EXPR_CONSTANT + && new_var->expr->symtree == NULL) + { + gfc_error ("Inquiry parameter cannot appear in a " + "data-stmt-object-list at %C"); + return MATCH_ERROR; + } + sym = new_var->expr->symtree->n.sym; /* Symbol should already have an associated type. */ @@ -391,6 +399,14 @@ match_data_constant (gfc_expr **result) } else if (m == MATCH_YES) { + /* If a parameter inquiry ends up here, symtree is NULL but **result + contains the right constant expression. Check here. */ + if ((*result)->symtree == NULL + && (*result)->expr_type == EXPR_CONSTANT + && ((*result)->ts.type == BT_INTEGER + || (*result)->ts.type == BT_REAL)) + return m; + /* F2018:R845 data-stmt-constant is initial-data-target. A data-stmt-constant shall be ... initial-data-target if and only if the corresponding data-stmt-object has the POINTER Index: gcc/fortran/dump-parse-tree.c =================================================================== --- gcc/fortran/dump-parse-tree.c (revision 266718) +++ gcc/fortran/dump-parse-tree.c (working copy) @@ -3259,6 +3259,14 @@ write_proc (gfc_symbol *sym) { gfc_symbol *s; s = f->sym; + + if (!s) + { + gfc_error_now ("Par %L, \"Nous sommes tous nes pour le mal\"", + &sym->declared_at); + return; + } + rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk, &post, false); if (rok == T_ERROR) Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (revision 266718) +++ gcc/fortran/expr.c (working copy) @@ -2688,6 +2688,9 @@ check_transformational (gfc_expr *e) static match check_null (gfc_expr *e) { + if (flag_dec && e->expr_type == EXPR_CONSTANT) + return MATCH_NO; + if (strcmp ("null", e->symtree->n.sym->name) != 0) return MATCH_NO; @@ -2698,6 +2701,9 @@ check_null (gfc_expr *e) static match check_elemental (gfc_expr *e) { + if (flag_dec && e->expr_type == EXPR_CONSTANT) + return MATCH_NO; + if (!e->value.function.isym || !e->value.function.isym->elemental) return MATCH_NO; @@ -2793,10 +2799,15 @@ gfc_check_init_expr (gfc_expr *e) && (m = check_transformational (e)) == MATCH_NO && (m = check_elemental (e)) == MATCH_NO) { - gfc_error ("Intrinsic function %qs at %L is not permitted " - "in an initialization expression", - e->symtree->n.sym->name, &e->where); - m = MATCH_ERROR; + if (flag_dec && e->expr_type == EXPR_CONSTANT) + return true; + else + { + gfc_error ("Intrinsic function %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + m = MATCH_ERROR; + } } if (m == MATCH_ERROR) @@ -4485,12 +4496,10 @@ gfc_apply_init (gfc_typespec *ts, symbol_attribute *at { if (ts->type == BT_CHARACTER && !attr->pointer && init && ts->u.cl - && ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT) + && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT + && ts->u.cl->length->ts.type == BT_INTEGER) { - gcc_assert (ts->u.cl && ts->u.cl->length); - gcc_assert (ts->u.cl->length->expr_type == EXPR_CONSTANT); - gcc_assert (ts->u.cl->length->ts.type == BT_INTEGER); - HOST_WIDE_INT len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); if (init->expr_type == EXPR_CONSTANT) Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 266718) +++ gcc/fortran/gfortran.h (working copy) @@ -3395,7 +3395,7 @@ bool gfc_resolve_open (gfc_open *); void gfc_free_close (gfc_close *); bool gfc_resolve_close (gfc_close *); void gfc_free_filepos (gfc_filepos *); -bool gfc_resolve_filepos (gfc_filepos *); +bool gfc_resolve_filepos (gfc_filepos *, locus *); void gfc_free_inquire (gfc_inquire *); bool gfc_resolve_inquire (gfc_inquire *); void gfc_free_dt (gfc_dt *); Index: gcc/fortran/io.c =================================================================== --- gcc/fortran/io.c (revision 266718) +++ gcc/fortran/io.c (working copy) @@ -1636,6 +1636,12 @@ resolve_tag_format (gfc_expr *e) gfc_expr *r; gfc_char_t *dest, *src; + if (e->value.constructor == NULL) + { + gfc_error ("FORMAT tag at %C cannot be a zero-sized array"); + return false; + } + n = 0; c = gfc_constructor_first (e->value.constructor); len = c->expr->value.character.length; @@ -2161,6 +2167,12 @@ gfc_match_open (void) if (!open->file && open->status) { + if (open->status->ts.type != BT_CHARACTER) + { + gfc_error ("STATUS must be a default character type at %C"); + goto cleanup; + } + if (open->status->expr_type == EXPR_CONSTANT && gfc_wide_strncasecmp (open->status->value.character.string, "scratch", 7) != 0) @@ -2232,6 +2244,21 @@ gfc_match_open (void) if (!is_char_type ("ASYNCHRONOUS", open->asynchronous)) goto cleanup; + if (open->asynchronous->ts.kind != 1) + { + gfc_error ("ASYNCHRONOUS= specifier at %L must have default " + "CHARACTER kind", &open->asynchronous->where); + return MATCH_ERROR; + } + + if (open->asynchronous->expr_type == EXPR_ARRAY + || open->asynchronous->expr_type == EXPR_STRUCTURE) + { + gfc_error ("ASYNCHRONOUS= specifier at %L must be scalar", + &open->asynchronous->where); + return MATCH_ERROR; + } + if (open->asynchronous->expr_type == EXPR_CONSTANT) { static const char * asynchronous[] = { "YES", "NO", NULL }; @@ -2834,22 +2861,21 @@ cleanup: bool -gfc_resolve_filepos (gfc_filepos *fp) +gfc_resolve_filepos (gfc_filepos *fp, locus *where) { RESOLVE_TAG (&tag_unit, fp->unit); RESOLVE_TAG (&tag_iostat, fp->iostat); RESOLVE_TAG (&tag_iomsg, fp->iomsg); - if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET)) - return false; - if (!fp->unit && (fp->iostat || fp->iomsg)) + if (!fp->unit && (fp->iostat || fp->iomsg || fp->err)) { - locus where; - where = fp->iostat ? fp->iostat->where : fp->iomsg->where; - gfc_error ("UNIT number missing in statement at %L", &where); + gfc_error ("UNIT number missing in statement at %L", where); return false; } + if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET)) + return false; + if (fp->unit->expr_type == EXPR_CONSTANT && fp->unit->ts.type == BT_INTEGER && mpz_sgn (fp->unit->value.integer) < 0) @@ -3231,12 +3257,21 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc) { gfc_expr *e; io_kind k; + locus loc_tmp; /* This is set in any case. */ gcc_assert (dt->dt_io_kind); k = dt->dt_io_kind->value.iokind; - RESOLVE_TAG (&tag_format, dt->format_expr); + loc_tmp = gfc_current_locus; + gfc_current_locus = *loc; + if (!resolve_tag (&tag_format, dt->format_expr)) + { + gfc_current_locus = loc_tmp; + return false; + } + gfc_current_locus = loc_tmp; + RESOLVE_TAG (&tag_rec, dt->rec); RESOLVE_TAG (&tag_spos, dt->pos); RESOLVE_TAG (&tag_advance, dt->advance); @@ -3681,7 +3716,10 @@ check_io_constraints (io_kind k, gfc_dt *dt, gfc_code #define io_constraint(condition,msg,arg)\ if (condition) \ {\ - gfc_error(msg,arg);\ + if ((arg)->lb != NULL) \ + gfc_error(msg,arg);\ + else \ + gfc_error(msg,&gfc_current_locus);\ m = MATCH_ERROR;\ } @@ -3741,11 +3779,14 @@ if (condition) \ if (expr && expr->ts.type != BT_CHARACTER) { - io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE), - "IO UNIT in %s statement at %C must be " + if (gfc_pure (NULL) && (k == M_READ || k == M_WRITE)) + { + gfc_error ("IO UNIT in %s statement at %C must be " "an internal file in a PURE procedure", io_kind_name (k)); - + return MATCH_ERROR; + } + if (k == M_READ || k == M_WRITE) gfc_unset_implicit_pure (NULL); } @@ -3792,6 +3833,21 @@ if (condition) \ if (!is_char_type ("ASYNCHRONOUS", dt->asynchronous)) return MATCH_ERROR; + + if (dt->asynchronous->ts.kind != 1) + { + gfc_error ("ASYNCHRONOUS= specifier at %L must have default " + "CHARACTER kind", &dt->asynchronous->where); + return MATCH_ERROR; + } + + if (dt->asynchronous->expr_type == EXPR_ARRAY + || dt->asynchronous->expr_type == EXPR_STRUCTURE) + { + gfc_error ("ASYNCHRONOUS= specifier at %L must be scalar", + &dt->asynchronous->where); + return MATCH_ERROR; + } if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, NULL, NULL, Index: gcc/fortran/match.c =================================================================== --- gcc/fortran/match.c (revision 266718) +++ gcc/fortran/match.c (working copy) @@ -2225,6 +2225,9 @@ found: return MATCH_NO; } + if (e->expr_type != EXPR_CONSTANT) + goto ohno; + gfc_next_char (); /* Burn the ')'. */ ts->kind = (int) mpz_get_si (e->value.integer); if (gfc_validate_kind (ts->type, ts->kind , true) == -1) @@ -2238,6 +2241,8 @@ found: return MATCH_YES; } } + +ohno: /* If a type is not matched, simply return MATCH_NO. */ gfc_current_locus = old_locus; Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 266718) +++ gcc/fortran/resolve.c (working copy) @@ -11544,7 +11544,7 @@ start: case EXEC_ENDFILE: case EXEC_REWIND: case EXEC_FLUSH: - if (!gfc_resolve_filepos (code->ext.filepos)) + if (!gfc_resolve_filepos (code->ext.filepos, &code->loc)) break; resolve_branch (code->ext.filepos->err, code); @@ -15492,7 +15492,10 @@ check_data_variable (gfc_data_variable *var, locus *wh e = e->value.function.actual->expr; if (e->expr_type != EXPR_VARIABLE) - gfc_internal_error ("check_data_variable(): Bad expression"); + { + gfc_error ("Expecting definable entity near %L", where); + return false; + } sym = e->symtree->n.sym; @@ -15500,6 +15503,7 @@ check_data_variable (gfc_data_variable *var, locus *wh { gfc_error ("BLOCK DATA element %qs at %L must be in COMMON", sym->name, &sym->declared_at); + return false; } if (e->ref == NULL && sym->as) Index: gcc/fortran/simplify.c =================================================================== --- gcc/fortran/simplify.c (revision 266718) +++ gcc/fortran/simplify.c (working copy) @@ -8360,7 +8360,7 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) default: oops: - gfc_internal_error ("gfc_convert_constant(): Unexpected type"); + return &gfc_bad_expr; } result = NULL; Index: gcc/testsuite/gfortran.dg/io_constraints_8.f90 =================================================================== --- gcc/testsuite/gfortran.dg/io_constraints_8.f90 (revision 266718) +++ gcc/testsuite/gfortran.dg/io_constraints_8.f90 (working copy) @@ -14,7 +14,7 @@ integer :: i OPEN(99, access=4_'direct') ! { dg-error "must be a character string of default kind" } OPEN(99, action=4_'read') ! { dg-error "must be a character string of default kind" } -OPEN(99, asynchronous=4_'no') ! { dg-error "must be a character string of default kind" }) +OPEN(99, asynchronous=4_'no') ! { dg-error "must have default CHARACTER kind" }) OPEN(99, blank=4_'null') ! { dg-error "must be a character string of default kind" } OPEN(99, decimal=4_'comma') ! { dg-error "must be a character string of default kind" } OPEN(99, delim=4_'quote') ! { dg-error "must be a character string of default kind" } Index: gcc/testsuite/gfortran.dg/pr87922.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr87922.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr87922.f90 (working copy) @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/87922 +subroutine p + read(1, asynchronous=['no']) ! { dg-error "must be scalar" } + read(1, asynchronous=[character::]) ! { dg-error "must be scalar" } +end +subroutine q + write(1, asynchronous=['no']) ! { dg-error "must be scalar" } + write(1, asynchronous=[character::]) ! { dg-error "must be scalar" } +end Index: gcc/testsuite/gfortran.dg/pr87945_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr87945_1.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr87945_1.f90 (working copy) @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/87945 +program p + character :: a, b + data a%len /1/ ! { dg-error "parameter cannot appear in" } + data b%kind /'b'/ ! { dg-error "parameter cannot appear in" } +end Index: gcc/testsuite/gfortran.dg/pr87945_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr87945_2.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr87945_2.f90 (working copy) @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/87945 +program p + character :: a, b + a%len = 1 ! { dg-error "to a constant expression" } + b%kind = 'b' ! { dg-error "to a constant expression" } +end Index: gcc/testsuite/gfortran.dg/pr87994_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr87994_1.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr87994_1.f90 (working copy) @@ -0,0 +1,7 @@ +! { dg-do run } +! PR fortran/87994 +program p + real :: a, b + data b /a%kind/ + if (b /= kind(a)) stop 1 +end Index: gcc/testsuite/gfortran.dg/pr87994_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr87994_2.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr87994_2.f90 (working copy) @@ -0,0 +1,7 @@ +! { dg-do run } +! PR fortran/87994 +program p + real, parameter :: a = 1.0 + data b /a%kind/ + if (b /= kind(a)) stop 1 +end Index: gcc/testsuite/gfortran.dg/pr87994_3.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr87994_3.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr87994_3.f90 (working copy) @@ -0,0 +1,8 @@ +! { dg-do run } +! PR fortran/87994 +program p + integer, parameter :: a = 1 + integer :: b + data b /a%kind/ + if (b /= kind(a)) stop = 1 +end Index: gcc/testsuite/gfortran.dg/pr88025.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr88025.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr88025.f90 (working copy) @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/88025 +program p + type t + character(('')) :: c = 'c' ! { dg-error "must be of INTEGER type" } + end type +end Index: gcc/testsuite/gfortran.dg/pr88048.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr88048.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr88048.f90 (working copy) @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/88048 +program p + integer, parameter :: a(2) = 1 + data a(2) /a(1)/ ! { dg-error "definable entity" } + print *, a +end Index: gcc/testsuite/gfortran.dg/pr88116_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr88116_1.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr88116_1.f90 (working copy) @@ -0,0 +1,5 @@ +! { dg-do compile } +! PR fortran/88116 +program p + print *, [integer :: 1, [integer(8) :: 2, ['3']]] ! { dg-error "convert" } +end Index: gcc/testsuite/gfortran.dg/pr88116_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr88116_2.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr88116_2.f90 (working copy) @@ -0,0 +1,9 @@ +! { dg-do run } +! PR fortran/88116 +program p + real :: a(2) = [real :: 1, [integer :: (real(k), k=2,1), 2]] + real :: b(1) = [real :: [integer :: (dble(k), k=1,0), 2]] + if (a(1) /= 1 .or. a(2) /= 2) stop 1 + if (b(1) /= 2) stop 2 +end + Index: gcc/testsuite/gfortran.dg/pr88139.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr88139.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr88139.f90 (working copy) @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-fc-prototypes" } +! PR fortran/88139 +module m +contains + subroutine s(*) bind(c, name='f') ! { dg-error "sommes tous nes" } + end +end +! { dg-prune-output "void f" } Index: gcc/testsuite/gfortran.dg/pr88205.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr88205.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr88205.f90 (working copy) @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/88205 +subroutine s1 + real, parameter :: status = 0 + open (newunit=n, status=status) ! { dg-error "be a default character" } +end +subroutine s2 + complex, parameter :: status = 0 + open (newunit=n, status=status) ! { dg-error "be a default character" } +end +program p + logical, parameter :: status = .false. + open (newunit=a, status=status) ! { dg-error "be a default character" } +end Index: gcc/testsuite/gfortran.dg/pr88206.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr88206.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr88206.f90 (working copy) @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/88206 +program p + integer, parameter :: z(4) = [1,2,3,4] + integer :: k = 2 + print *, [real(z(k))] +end + Index: gcc/testsuite/gfortran.dg/pr88228.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr88228.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr88228.f90 (working copy) @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-fdec" } +! PR fortran/88228 +program p + integer :: n = .not. 1 + integer :: j = .true. .or. 1 +end + Index: gcc/testsuite/gfortran.dg/pr88249.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr88249.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr88249.f90 (working copy) @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/88249 +program p + backspace(err=1) ! { dg-error "number missing in statement" } + endfile(err=1) ! { dg-error "number missing in statement" } + flush(err=1) ! { dg-error "number missing in statement" } + rewind(err=1) ! { dg-error "number missing in statement" } +end Index: gcc/testsuite/gfortran.dg/pr88269.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr88269.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr88269.f90 (working copy) @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/88269 +program p + write (end=1e1) ! { dg-error "tag not allowed" } +end + Index: gcc/testsuite/gfortran.dg/pr88328.f90 =================================================================== --- gcc/testsuite/gfortran.dg/pr88328.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/pr88328.f90 (working copy) @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/88328 +program p + character(3), parameter :: a(0) = [character(3)::] + print a ! { dg-error "zero-sized array" } +end