From f3207b37d34107210fda3f7b3bc999ac7537d7c0 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Tobias=20Schl=C3=BCter?= Date: Mon, 14 Jun 2004 17:56:50 +0200 Subject: [PATCH] re PR fortran/14928 (minloc intrinsic does not understand mask) fortran/ 2004-06-05 Tobias Schlueter Andrew Vaught PR fortran/14928 * gfortran.h (gfc_check_f): Add new field f3ml. * check.c (gfc_check_minloc_maxloc): Take argument list instead of individual arguments, reorder if necessary. * intrinsic.h (gfc_check_minloc_maxloc): ... adapt prototype. * intrinsic.c (add_sym_3ml): New function. (add_functions): Change to add_sym_3ml for MINLOC, MAXLOC. (check_specific): Catch special case MINLOC, MAXLOC. testsuite/ PR fortran/14928 * gfortran.fortran-torture/compile/mloc.f90: New test. Co-Authored-By: Andrew Vaught From-SVN: r83111 --- gcc/fortran/ChangeLog | 12 ++++ gcc/fortran/check.c | 57 +++++++---------- gcc/fortran/gfortran.h | 1 + gcc/fortran/intrinsic.c | 64 ++++++++++++++----- gcc/fortran/intrinsic.h | 2 +- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.fortran-torture/compile/mloc.f90 | 8 +++ 7 files changed, 98 insertions(+), 51 deletions(-) create mode 100644 gcc/testsuite/gfortran.fortran-torture/compile/mloc.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0cacdfc11d3..72a0678b5e7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2004-06-05 Tobias Schlueter + Andrew Vaught + + PR fortran/14928 + * gfortran.h (gfc_check_f): Add new field f3ml. + * check.c (gfc_check_minloc_maxloc): Take argument list instead + of individual arguments, reorder if necessary. + * intrinsic.h (gfc_check_minloc_maxloc): ... adapt prototype. + * intrinsic.c (add_sym_3ml): New function. + (add_functions): Change to add_sym_3ml for MINLOC, MAXLOC. + (check_specific): Catch special case MINLOC, MAXLOC. + 2004-06-14 Paul Brook * intrinsic.c (add_sym_2s): Use correct function types. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index cbf3d9dba7a..9a82d889371 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1096,53 +1096,40 @@ gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b) MASK NULL NULL MASK minloc(array, mask=m) DIM MASK -*/ + + I.e. in the case of minloc(array,mask), mask will be in the second + position of the argument list and we'll have to fix that up. */ try -gfc_check_minloc_maxloc (gfc_expr * array, gfc_expr * a2, gfc_expr * a3) +gfc_check_minloc_maxloc (gfc_actual_arglist * ap) { + gfc_expr *a, *m, *d; - if (int_or_real_check (array, 0) == FAILURE) + a = ap->expr; + if (int_or_real_check (a, 0) == FAILURE + || array_check (a, 0) == FAILURE) return FAILURE; - if (array_check (array, 0) == FAILURE) - return FAILURE; + d = ap->next->expr; + m = ap->next->next->expr; - if (a3 != NULL) + if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL + && ap->next->name[0] == '\0') { - if (logical_array_check (a3, 2) == FAILURE) - return FAILURE; + m = d; + d = NULL; - if (a2 != NULL) - { - if (scalar_check (a2, 1) == FAILURE) - return FAILURE; - if (type_check (a2, 1, BT_INTEGER) == FAILURE) - return FAILURE; - } + ap->next->expr = NULL; + ap->next->next->expr = m; } - else - { - if (a2 != NULL) - { - switch (a2->ts.type) - { - case BT_INTEGER: - if (scalar_check (a2, 1) == FAILURE) - return FAILURE; - break; - case BT_LOGICAL: /* The '2' makes the error message correct */ - if (logical_array_check (a2, 2) == FAILURE) - return FAILURE; - break; + if (d != NULL + && (scalar_check (d, 1) == FAILURE + || type_check (d, 1, BT_INTEGER) == FAILURE)) + return FAILURE; - default: - type_check (a2, 1, BT_INTEGER); /* Guaranteed to fail */ - return FAILURE; - } - } - } + if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE) + return FAILURE; return SUCCESS; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a533b1c348e..d9107dd32cd 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -821,6 +821,7 @@ typedef union try (*f1m)(gfc_actual_arglist *); try (*f2)(struct gfc_expr *, struct gfc_expr *); try (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); + try (*f3ml)(gfc_actual_arglist *); try (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); try (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index bf72947e03c..04443d92ae1 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -479,6 +479,33 @@ static void add_sym_3 (const char *name, int elemental, int actual_ok, bt type, (void*)0); } +/* MINLOC and MAXLOC get special treatment because their argument + might have to be reordered. */ + +static void add_sym_3ml (const char *name, int elemental, + int actual_ok, bt type, int kind, + try (*check)(gfc_actual_arglist *), + gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *), + void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *), + const char* a1, bt type1, int kind1, int optional1, + const char* a2, bt type2, int kind2, int optional2, + const char* a3, bt type3, int kind3, int optional3 + ) { + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f3ml = check; + sf.f3 = simplify; + rf.f3 = resolve; + + add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf, + a1, type1, kind1, optional1, + a2, type2, kind2, optional2, + a3, type3, kind3, optional3, + (void*)0); +} + /* Add the name of an intrinsic subroutine with three arguments to the list of intrinsic names. */ @@ -1281,10 +1308,10 @@ add_functions (void) make_generic ("maxexponent", GFC_ISYM_NONE); - add_sym_3 ("maxloc", 0, 1, BT_INTEGER, di, - gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc, - ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1, - msk, BT_LOGICAL, dl, 1); + add_sym_3ml ("maxloc", 0, 1, BT_INTEGER, di, + gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc, + ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1, + msk, BT_LOGICAL, dl, 1); make_generic ("maxloc", GFC_ISYM_MAXLOC); @@ -1336,10 +1363,10 @@ add_functions (void) make_generic ("minexponent", GFC_ISYM_NONE); - add_sym_3 ("minloc", 0, 1, BT_INTEGER, di, - gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc, - ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1, - msk, BT_LOGICAL, dl, 1); + add_sym_3ml ("minloc", 0, 1, BT_INTEGER, di, + gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc, + ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1, + msk, BT_LOGICAL, dl, 1); make_generic ("minloc", GFC_ISYM_MINLOC); @@ -2331,14 +2358,21 @@ check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag) &expr->where) == FAILURE) return FAILURE; - if (specific->check.f1 == NULL) - { - t = check_arglist (ap, specific, error_flag); - if (t == SUCCESS) - expr->ts = specific->ts; - } + if (specific->check.f3ml != gfc_check_minloc_maxloc) + { + if (specific->check.f1 == NULL) + { + t = check_arglist (ap, specific, error_flag); + if (t == SUCCESS) + expr->ts = specific->ts; + } + else + t = do_check (specific, *ap); + } else - t = do_check (specific, *ap); + /* This is special because we might have to reorder the argument + list. */ + t = gfc_check_minloc_maxloc (*ap); /* Check ranks for elemental intrinsics. */ if (t == SUCCESS && specific->elemental) diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index ab261431f06..c345abc8eaa 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -69,7 +69,7 @@ try gfc_check_min_max_real (gfc_actual_arglist *); try gfc_check_min_max_double (gfc_actual_arglist *); try gfc_check_matmul (gfc_expr *, gfc_expr *); try gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *); -try gfc_check_minloc_maxloc (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_minloc_maxloc (gfc_actual_arglist *); try gfc_check_minval_maxval (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_nearest (gfc_expr *, gfc_expr *); try gfc_check_null (gfc_expr *); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 86926967b0f..02da20e3509 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2004-06-14 Tobias Schlueter + + PR fortran/14928 + * gfortran.fortran-torture/compile/mloc.f90: New test. + 2004-06-13 Paul Brook * gfortran.fortran-torture/execute/random_2.f90: New test. diff --git a/gcc/testsuite/gfortran.fortran-torture/compile/mloc.f90 b/gcc/testsuite/gfortran.fortran-torture/compile/mloc.f90 new file mode 100644 index 00000000000..8d1d754f585 --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/compile/mloc.f90 @@ -0,0 +1,8 @@ +! from PR 14928 +! we used to not accept the two argument variant of MINLOC and MAXLOC when +! the MASK keyword was omitted. + real b(10) + integer c(1) + c = minloc(b,b<0) + c = maxloc(b,b>0) +end -- 2.30.2