diff options
| author | Janus Weil <janus@gcc.gnu.org> | 2011-10-04 20:37:13 +0200 |
|---|---|---|
| committer | Janus Weil <janus@gcc.gnu.org> | 2011-10-04 20:37:13 +0200 |
| commit | 97f26732675a4a388b79d927876443c92a55c8c7 (patch) | |
| tree | aa83e4a9f7e19504f2d24c28ebc17d090fb3ca19 /gcc/fortran/interface.c | |
| parent | 0de99d2625d60d155d319cc5c3325a9efdda1eb7 (diff) | |
| download | gcc-97f26732675a4a388b79d927876443c92a55c8c7.zip gcc-97f26732675a4a388b79d927876443c92a55c8c7.tar.gz gcc-97f26732675a4a388b79d927876443c92a55c8c7.tar.bz2 | |
re PR fortran/35831 ([F95] Shape mismatch check missing for dummy procedure argument)
2011-10-04 Janus Weil <janus@gcc.gnu.org>
PR fortran/35831
* interface.c (check_dummy_characteristics): Check the array shape.
2011-10-04 Janus Weil <janus@gcc.gnu.org>
PR fortran/35831
* gfortran.dg/dummy_procedure_6.f90: New.
From-SVN: r179520
Diffstat (limited to 'gcc/fortran/interface.c')
| -rw-r--r-- | gcc/fortran/interface.c | 43 |
1 files changed, 42 insertions, 1 deletions
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index aa075a9..43b9113 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -69,6 +69,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "gfortran.h" #include "match.h" +#include "arith.h" /* The current_interface structure holds information about the interface currently being parsed. This structure is saved and @@ -1071,13 +1072,51 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, /* Check array shape. */ if (s1->as && s2->as) { + int i, compval; + gfc_expr *shape1, *shape2; + if (s1->as->type != s2->as->type) { snprintf (errmsg, err_len, "Shape mismatch in argument '%s'", s1->name); return FAILURE; } - /* FIXME: Check exact shape. */ + + if (s1->as->type == AS_EXPLICIT) + for (i = 0; i < s1->as->rank + s1->as->corank; i++) + { + shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]), + gfc_copy_expr (s1->as->lower[i])); + shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]), + gfc_copy_expr (s2->as->lower[i])); + compval = gfc_dep_compare_expr (shape1, shape2); + gfc_free_expr (shape1); + gfc_free_expr (shape2); + switch (compval) + { + case -1: + case 1: + case -3: + snprintf (errmsg, err_len, "Shape mismatch in dimension %i of " + "argument '%s'", i, s1->name); + return FAILURE; + + case -2: + /* FIXME: Implement a warning for this case. + gfc_warning ("Possible shape mismatch in argument '%s'", + s1->name);*/ + break; + + case 0: + break; + + default: + gfc_internal_error ("check_dummy_characteristics: Unexpected " + "result %i of gfc_dep_compare_expr", + compval); + break; + } + } } return SUCCESS; @@ -1131,6 +1170,8 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, "of '%s'", name2); return 0; } + + /* FIXME: Check array bounds and string length of result. */ } if (s1->attr.pure && !s2->attr.pure) |