From 0e6928d853c6c6a016b31b765ebafce7acbbc65e Mon Sep 17 00:00:00 2001 From: =?utf8?q?Tobias=20Schl=C3=BCter?= Date: Wed, 1 Sep 2004 23:07:39 +0200 Subject: [PATCH] re PR fortran/16400 (Invalid usage of assumed-size arrays is not rejected) fortran/ PR fortran/16400 PR fortran/16404 (port from g95) * resolve.c (resolve_transfer): New function. (resolve_code): Call resolve_transfer in case of EXEC_TRANSFER. testsuite/ PR fortran/16404 * gfortran.dg/der_io_1.f90: XFAIL illegal testcase. From-SVN: r86931 --- gcc/fortran/ChangeLog | 8 +++++ gcc/fortran/resolve.c | 60 +++++++++++++++++++++++++++++++++- gcc/testsuite/ChangeLog | 5 +++ gcc/testsuite/gfortran.dg/der_io_1.f90 | 7 ++-- 4 files changed, 76 insertions(+), 4 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7ec2620..1c792b9 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2004-09-01 Tobias Schlueter + + PR fortran/16400 + PR fortran/16404 + (port from g95) + * resolve.c (resolve_transfer): New function. + (resolve_code): Call resolve_transfer in case of EXEC_TRANSFER. + 2004-08-31 Tobias Schlueter PR fortran/16579 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e310f59..1a7fd80 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2962,6 +2962,61 @@ resolve_select (gfc_code * code) } +/* Resolve a transfer statement. This is making sure that: + -- a derived type being transferred has only non-pointer components + -- a derived type being transferred doesn't have private components + -- we're not trying to transfer a whole assumed size array. */ + +static void +resolve_transfer (gfc_code * code) +{ + gfc_typespec *ts; + gfc_symbol *sym; + gfc_ref *ref; + gfc_expr *exp; + + exp = code->expr; + + if (exp->expr_type != EXPR_VARIABLE) + return; + + sym = exp->symtree->n.sym; + ts = &sym->ts; + + /* Go to actual component transferred. */ + for (ref = code->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + ts = &ref->u.c.component->ts; + + if (ts->type == BT_DERIVED) + { + /* Check that transferred derived type doesn't contain POINTER + components. */ + if (derived_pointer (ts->derived)) + { + gfc_error ("Data transfer element at %L cannot have " + "POINTER components", &code->loc); + return; + } + + if (ts->derived->component_access == ACCESS_PRIVATE) + { + gfc_error ("Data transfer element at %L cannot have " + "PRIVATE components",&code->loc); + return; + } + } + + if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE + && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL) + { + gfc_error ("Data transfer element at %L cannot be a full reference to " + "an assumed-size array", &code->loc); + return; + } +} + + /*********** Toplevel code resolution subroutines ***********/ /* Given a branch to a label and a namespace, if the branch is conforming. @@ -3568,7 +3623,6 @@ resolve_code (gfc_code * code, gfc_namespace * ns) case EXEC_EXIT: case EXEC_CONTINUE: case EXEC_DT_END: - case EXEC_TRANSFER: case EXEC_ENTRY: break; @@ -3754,6 +3808,10 @@ resolve_code (gfc_code * code, gfc_namespace * ns) resolve_branch (code->ext.dt->eor, code); break; + case EXEC_TRANSFER: + resolve_transfer (code); + break; + case EXEC_FORALL: resolve_forall_iterators (code->ext.forall_iterator); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5721b13..ba2a713 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2004-09-01 Tobias Schlueter + + PR fortran/16404 + * gfortran.dg/der_io_1.f90: XFAIL illegal testcase. + 2004-09-01 Richard Kenner PR c/1522 diff --git a/gcc/testsuite/gfortran.dg/der_io_1.f90 b/gcc/testsuite/gfortran.dg/der_io_1.f90 index 8710bf8..4cbbf77 100644 --- a/gcc/testsuite/gfortran.dg/der_io_1.f90 +++ b/gcc/testsuite/gfortran.dg/der_io_1.f90 @@ -1,5 +1,6 @@ -! { dg-do run } -! IO of derived types containing pointers +! { dg-do compile } +! PR 16404 Nr. 8 +! IO of derived types containing pointers is not allowed program der_io_1 type t integer, pointer :: p @@ -10,7 +11,7 @@ program der_io_1 v%p => i i = 42 - write (unit=s, fmt='(I2)') v + write (unit=s, fmt='(I2)') v ! { dg-error "POINTER components" "" } if (s .ne. '42') call abort () end program -- 2.7.4