diff options
Diffstat (limited to 'gcc/fortran/check.c')
| -rw-r--r-- | gcc/fortran/check.c | 49 |
1 files changed, 47 insertions, 2 deletions
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 0460bf2..99174bc 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -3617,11 +3617,31 @@ gfc_check_sizeof (gfc_expr *arg) { if (arg->ts.type == BT_PROCEDURE) { - gfc_error ("'%s' argument of '%s' intrinsic at %L may not be a procedure", + gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a procedure", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &arg->where); return FAILURE; } + + if (arg->ts.type == BT_ASSUMED) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &arg->where); + return FAILURE; + } + + if (arg->rank && arg->expr_type == EXPR_VARIABLE + && arg->symtree->n.sym->as != NULL + && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref + && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be an " + "assumed-size array", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &arg->where); + return FAILURE; + } + return SUCCESS; } @@ -3739,6 +3759,15 @@ gfc_check_c_sizeof (gfc_expr *arg) return FAILURE; } + if (arg->ts.type == BT_ASSUMED) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be " + "TYPE(*)", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &arg->where); + return FAILURE; + } + if (arg->rank && arg->expr_type == EXPR_VARIABLE && arg->symtree->n.sym->as != NULL && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref @@ -5593,8 +5622,24 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) gfc_try -gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind) +gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) { + if (a->ts.type == BT_ASSUMED) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); + return FAILURE; + } + + if (a->ts.type == BT_PROCEDURE) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be a " + "procedure", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &a->where); + return FAILURE; + } + if (kind == NULL) return SUCCESS; |