diff options
| author | Tobias Burnus <burnus@net-b.de> | 2013-05-21 19:27:04 +0200 |
|---|---|---|
| committer | Tobias Burnus <burnus@gcc.gnu.org> | 2013-05-21 19:27:04 +0200 |
| commit | 86307f49a77ab3d6ab82a33e1a0729bd68cb0f6a (patch) | |
| tree | 458437d583ebbdbffe828d22fc28a54aecaef1d8 /gcc/fortran/intrinsic.c | |
| parent | ee49aa34fd5e63f0d0d99d58dc66be587236d8c2 (diff) | |
| download | gcc-86307f49a77ab3d6ab82a33e1a0729bd68cb0f6a.zip gcc-86307f49a77ab3d6ab82a33e1a0729bd68cb0f6a.tar.gz gcc-86307f49a77ab3d6ab82a33e1a0729bd68cb0f6a.tar.bz2 | |
re PR fortran/57035 (TS29113's C535b: Wrongly accept DIMENSION(..) to TRANSFER)
2013-05-21 Tobias Burnus <burnus@net-b.de>
PR fortran/57035
* intrinsic.c (do_check): Add contraint check for
NO_ARG_CHECK, assumed rank and assumed type.
* gfortran.texi (NO_ARG_CHECK): Minor wording change,
allow PRESENT intrinsic.
2013-05-21 Tobias Burnus <burnus@net-b.de>
PR fortran/57035
* gfortran.dg/assumed_type_5.f90: New.
* gfortran.dg/assumed_rank_1.f90: Comment invalid statement.
* gfortran.dg/assumed_rank_2.f90: Ditto.
* gfortran.dg/assumed_type_3.f90: Update dg-error.
* gfortran.dg/no_arg_check_3.f90: Ditto.
From-SVN: r199158
Diffstat (limited to 'gcc/fortran/intrinsic.c')
| -rw-r--r-- | gcc/fortran/intrinsic.c | 56 |
1 files changed, 56 insertions, 0 deletions
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 688332f..ddf9d80 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -182,10 +182,66 @@ static bool do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) { gfc_expr *a1, *a2, *a3, *a4, *a5; + gfc_actual_arglist *a; if (arg == NULL) return (*specific->check.f0) (); + /* Check TS29113, C407b for assumed type and C535b for assumed-rank, + and a likewise check for NO_ARG_CHECK. */ + for (a = arg; a; a = a->next) + { + if (!a->expr) + continue; + + if (a->expr->expr_type == EXPR_VARIABLE + && (a->expr->symtree->n.sym->attr.ext_attr + & (1 << EXT_ATTR_NO_ARG_CHECK)) + && specific->id != GFC_ISYM_C_LOC + && specific->id != GFC_ISYM_PRESENT) + { + gfc_error ("Variable with NO_ARG_CHECK attribute at %L is only " + "permitted as argument to the intrinsic functions " + "C_LOC and PRESENT", &a->expr->where); + return false; + } + else if (a->expr->ts.type == BT_ASSUMED + && specific->id != GFC_ISYM_LBOUND + && specific->id != GFC_ISYM_PRESENT + && specific->id != GFC_ISYM_RANK + && specific->id != GFC_ISYM_SHAPE + && specific->id != GFC_ISYM_SIZE + && specific->id != GFC_ISYM_UBOUND + && specific->id != GFC_ISYM_C_LOC) + { + gfc_error ("Assumed-type argument at %L is not permitted as actual" + " argument to the intrinsic %s", &a->expr->where, + gfc_current_intrinsic); + return false; + } + else if (a->expr->ts.type == BT_ASSUMED && a != arg) + { + gfc_error ("Assumed-type argument at %L is only permitted as " + "first actual argument to the intrinsic %s", + &a->expr->where, gfc_current_intrinsic); + return false; + } + if (a->expr->rank == -1 && !specific->inquiry) + { + gfc_error ("Assumed-rank argument at %L is only permitted as actual " + "argument to intrinsic inquiry functions", + &a->expr->where); + return false; + } + if (a->expr->rank == -1 && arg != a) + { + gfc_error ("Assumed-rank argument at %L is only permitted as first " + "actual argument to the intrinsic inquiry function %s", + &a->expr->where, gfc_current_intrinsic); + return false; + } + } + a1 = arg->expr; arg = arg->next; if (arg == NULL) |