This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Patch for MAX_MINLOC
- From: Feng Wang <wf_cs at yahoo dot com>
- To: fortran at gcc dot gnu dot org
- Cc: gcc <gcc-g95-devel at lists dot sourceforge dot net>
- Date: Fri, 17 Oct 2003 17:28:17 +0800 (CST)
- Subject: Patch for MAX_MINLOC
Thanks for Joost VandeVondele and Vijayendra
Munikoti. These are their test programs:
REAL A(-1:1) ,B(2:3),C(1:2)
A=0
B=0
C=0
A(-1)=1
B(2)=1
C(1)=1
! maxloc should be an integer i.e. write(6,*)
MAXLOC(C,1)
IF (MAXLOC(A,1).NE.1) CALL ABORT()
IF (MAXLOC(B,1).NE.1) CALL ABORT()
IF (MAXLOC(C,1).NE.1) CALL ABORT()
END
And:
PROGRAM TEST
INTEGER (KIND = 4), DIMENSION(1):: I
REAL (KIND = 8), DIMENSION(3) :: VC
VC = (/4.0D0, 2.50D1, 1.0D1/)
I = MINLOC(VC)
PRINT*, I
END PROGRAM TEST
The Changlog entry of gcc/gcc/fortran:
2003-10-17 Feng Wang <wf_cs@yahoo.com>
* iresolve.c (gfc_resolve_maxloc): Change the
result's kind and type.
(gfc_resolve_minloc): Ditto.
* trans-intrinsic.c
(gfc_conv_intrinsic_minmaxloc): Fix bugs about type.
Paul, can you check the diff file attached ? The
main changes are about the type and kind of the array
returned.
Feng Wang
__________________________________________________
Do You Yahoo!?
Tired of spam? Yahoo! Mail has the best spam protection around
http://mail.yahoo.com diff -rc3p 1015/gcc/gcc/fortran/iresolve.c gcc/gcc/fortran/iresolve.c
*** 1015/gcc/gcc/fortran/iresolve.c 2003-10-17 16:00:52.000000000 -0800
--- gcc/gcc/fortran/iresolve.c 2003-10-17 20:41:07.000000000 -0800
*************** gfc_resolve_maxloc (gfc_expr * f, gfc_ex
*** 784,790 ****
{
const char *name;
! f->ts = array->ts;
if (dim == NULL)
f->rank = 1;
--- 784,791 ----
{
const char *name;
! f->ts.type = BT_INTEGER;
! f->ts.kind = gfc_default_integer_kind ();
if (dim == NULL)
f->rank = 1;
*************** gfc_resolve_maxloc (gfc_expr * f, gfc_ex
*** 797,803 ****
name = mask ? "mmaxloc" : "maxloc";
f->value.function.name =
gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
! gfc_type_letter (array->ts.type), array->ts.kind);
}
--- 798,804 ----
name = mask ? "mmaxloc" : "maxloc";
f->value.function.name =
gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
! gfc_type_letter (array->ts.type), array->ts.kind);
}
*************** gfc_resolve_minloc (gfc_expr * f, gfc_ex
*** 846,852 ****
{
const char *name;
! f->ts = array->ts;
if (dim == NULL)
f->rank = 1;
--- 847,854 ----
{
const char *name;
! f->ts.type = BT_INTEGER;
! f->ts.kind = gfc_default_integer_kind ();
if (dim == NULL)
f->rank = 1;
*************** gfc_resolve_minloc (gfc_expr * f, gfc_ex
*** 859,865 ****
name = mask ? "mminloc" : "minloc";
f->value.function.name =
gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
! gfc_type_letter (array->ts.type), array->ts.kind);
}
void
--- 861,867 ----
name = mask ? "mminloc" : "minloc";
f->value.function.name =
gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind,
! gfc_type_letter (array->ts.type), array->ts.kind);
}
void
diff -rc3p 1015/gcc/gcc/fortran/trans-intrinsic.c gcc/gcc/fortran/trans-intrinsic.c
*** 1015/gcc/gcc/fortran/trans-intrinsic.c 2003-10-17 16:00:52.000000000 -0800
--- gcc/gcc/fortran/trans-intrinsic.c 2003-10-17 19:31:43.000000000 -0800
*************** gfc_conv_intrinsic_minmaxloc (gfc_se * s
*** 1315,1343 ****
return;
}
- type = gfc_typenode_for_spec (&expr->ts);
/* Initialize the result. */
- limit = gfc_create_var (type, "limit");
pos = gfc_create_var (gfc_array_index_type, "pos");
! n = gfc_validate_kind (expr->ts.type, expr->ts.kind);
! switch (expr->ts.type)
! {
! case BT_REAL:
! tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
! break;
!
! case BT_INTEGER:
! tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
! break;
!
! default:
! abort ();
! }
!
! /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
! if (op == GT_EXPR)
! tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
! gfc_add_modify_expr (&se->pre, limit, tmp);
/* Walk the arguments. */
actual = expr->value.function.actual;
--- 1315,1323 ----
return;
}
/* Initialize the result. */
pos = gfc_create_var (gfc_array_index_type, "pos");
! type = gfc_typenode_for_spec (&expr->ts);
/* Walk the arguments. */
actual = expr->value.function.actual;
*************** gfc_conv_intrinsic_minmaxloc (gfc_se * s
*** 1356,1361 ****
--- 1336,1362 ----
else
maskss = NULL;
+ limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
+ n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind);
+ switch (arrayexpr->ts.type)
+ {
+ case BT_REAL:
+ tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
+ break;
+
+ case BT_INTEGER:
+ tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, arrayexpr->ts.kind);
+ break;
+
+ default:
+ abort ();
+ }
+
+ /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
+ if (op == GT_EXPR)
+ tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
+ gfc_add_modify_expr (&se->pre, limit, tmp);
+
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, arrayss);
*************** gfc_conv_intrinsic_minmaxloc (gfc_se * s
*** 1433,1439 ****
integer_one_node));
tmp = fold (build (MINUS_EXPR, gfc_array_index_type, pos, tmp));
/* And convert to the required type. */
! se->expr = convert (type, pos);
}
static void
--- 1434,1440 ----
integer_one_node));
tmp = fold (build (MINUS_EXPR, gfc_array_index_type, pos, tmp));
/* And convert to the required type. */
! se->expr = convert (type, tmp);
}
static void