This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, Fortran] PR18918 Coarray patch 11/n: Some minor fixes and additions for CAF intrinsics
- From: Tobias Burnus <burnus at net-b dot de>
- To: Mikael Morin <mikael dot morin at sfr dot fr>, gfortran <fortran at gcc dot gnu dot org>
- Cc: gcc-patches at gcc dot gnu dot org
- Date: Sun, 02 May 2010 17:13:18 +0200
- Subject: Re: [Patch, Fortran] PR18918 Coarray patch 11/n: Some minor fixes and additions for CAF intrinsics
- References: <4BDD5613.4050604@net-b.de> <4BDD7BDC.7030905@sfr.fr>
Hi Mikael,
can you keep the CC to fortran@? I and many others are only subscribed
to fortran@ and not to gcc-patches@.
Mikael Morin wrote:
> On 02.05.2010 12:38, Tobias Burnus wrote:
>> Build and regtested on x86-64-linux.
>> OK for committal?
> two minor nits below, OK otherwise.
>> static char lbound[] = "__lbound";
>> + resolve_bound (f, array, dim, kind);
>> + f->value.function.name = lbound;
>> +}
> Did you consider setting f->value.function.name in resolve_bound ?
I didn't, but now I use:
+resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
+ const char *name)
+{
...
+ f->value.function.name = strdup (name);
+}
>> + static char lcobound[] = "__lbound";
> I think you were meaning "__lcobound" here.
Well spotted. Thanks!
> May be worth adding a testcase as it should have been caught by the
> testsuite.
No, the name won't survive that long. In trans-intrinsic.c it is
directly converted in TREE code and thus there no function which is
actually called.
Tobias
PS: I have committed the following patch as Rev. 158974.
Index: intrinsic.c
===================================================================
--- intrinsic.c (Revision 158973)
+++ intrinsic.c (Arbeitskopie)
@@ -1786,7 +1786,7 @@
make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
- gfc_check_image_index, gfc_simplify_image_index, NULL,
+ gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index,
ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED);
/* The resolution function for INDEX is called gfc_resolve_index_func
@@ -1925,12 +1925,12 @@
make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
- BT_INTEGER, di, GFC_STD_F95,
- gfc_check_lcobound, gfc_simplify_lcobound, NULL,
+ BT_INTEGER, di, GFC_STD_F2008,
+ gfc_check_lcobound, gfc_simplify_lcobound, gfc_resolve_lcobound,
ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
kind, BT_INTEGER, di, OPTIONAL);
- make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F95);
+ make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F2008);
add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
@@ -2540,7 +2540,7 @@
make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
add_sym_2 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
- gfc_check_this_image, gfc_simplify_this_image, NULL,
+ gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image,
ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL);
add_sym_0 ("time", GFC_ISYM_TIME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
@@ -2600,12 +2600,12 @@
make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
- BT_INTEGER, di, GFC_STD_F95,
- gfc_check_ucobound, gfc_simplify_ucobound, NULL,
+ BT_INTEGER, di, GFC_STD_F2008,
+ gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound,
ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
kind, BT_INTEGER, di, OPTIONAL);
- make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F95);
+ make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F2008);
/* g77 compatibility for UMASK. */
add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
Index: intrinsic.h
===================================================================
--- intrinsic.h (Revision 158973)
+++ intrinsic.h (Arbeitskopie)
@@ -422,6 +422,7 @@
void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
void gfc_resolve_ierrno (gfc_expr *);
@@ -441,6 +442,7 @@
void gfc_resolve_ishftc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_kill (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_lbound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_lcobound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_len (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_len_trim (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_lgamma (gfc_expr *, gfc_expr *);
@@ -498,6 +500,7 @@
void gfc_resolve_system (gfc_expr *, gfc_expr *);
void gfc_resolve_tan (gfc_expr *, gfc_expr *);
void gfc_resolve_tanh (gfc_expr *, gfc_expr *);
+void gfc_resolve_this_image (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_time (gfc_expr *);
void gfc_resolve_time8 (gfc_expr *);
void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
@@ -505,6 +508,7 @@
void gfc_resolve_trim (gfc_expr *, gfc_expr *);
void gfc_resolve_ttynam (gfc_expr *, gfc_expr *);
void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_ucobound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_umask (gfc_expr *, gfc_expr *);
void gfc_resolve_unlink (gfc_expr *, gfc_expr *);
void gfc_resolve_unpack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
Index: ChangeLog
===================================================================
--- ChangeLog (Revision 158973)
+++ ChangeLog (Arbeitskopie)
@@ -1,6 +1,18 @@
-2010-04-30 Tobias Burnus Mburnus@net-b.de>
+2010-05-02 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
+ * intrinsic.c (add_functions): Fix GFC_STD and add gfc_resolve_ calls
+ for lcobound, ucobound, image_index and this_image.
+ * intrinsic.h (gfc_resolve_lcobound, gfc_resolve_this_image,
+ gfc_resolve_image_index, gfc_resolve_ucobound): New prototypes.
+ * iresolve.c (gfc_resolve_lcobound, gfc_resolve_this_image,
+ gfc_resolve_image_index, gfc_resolve_ucobound, resolve_bound): New
+ functions.
+ (gfc_resolve_lbound, gfc_resolve_ubound): Use resolve_bound.
+
+2010-04-30 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/18918
PR fortran/43931
* trans-types.c (gfc_get_array_descriptor_base): Fix index
calculation for array descriptor types.
Index: iresolve.c
===================================================================
--- iresolve.c (Revision 158973)
+++ iresolve.c (Arbeitskopie)
@@ -119,6 +119,27 @@
}
}
+
+static void
+resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
+ const char *name)
+{
+ f->ts.type = BT_INTEGER;
+ if (kind)
+ f->ts.kind = mpz_get_si (kind->value.integer);
+ else
+ f->ts.kind = gfc_default_integer_kind;
+
+ if (dim == NULL)
+ {
+ f->rank = 1;
+ f->shape = gfc_get_shape (1);
+ mpz_init_set_ui (f->shape[0], array->rank);
+ }
+
+ f->value.function.name = xstrdup (name);
+}
+
/********************** Resolution functions **********************/
@@ -1247,22 +1268,14 @@
void
gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
- static char lbound[] = "__lbound";
+ resolve_bound (f, array, dim, kind, "__lbound");
+}
- f->ts.type = BT_INTEGER;
- if (kind)
- f->ts.kind = mpz_get_si (kind->value.integer);
- else
- f->ts.kind = gfc_default_integer_kind;
- if (dim == NULL)
- {
- f->rank = 1;
- f->shape = gfc_get_shape (1);
- mpz_init_set_ui (f->shape[0], array->rank);
- }
-
- f->value.function.name = lbound;
+void
+gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ resolve_bound (f, array, dim, kind, "__lcobound");
}
@@ -2376,6 +2389,23 @@
void
+gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
+ gfc_expr *sub ATTRIBUTE_UNUSED)
+{
+ static char this_image[] = "__image_index";
+ f->ts.kind = gfc_default_integer_kind;
+ f->value.function.name = this_image;
+}
+
+
+void
+gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+ resolve_bound (f, array, dim, NULL, "__this_image");
+}
+
+
+void
gfc_resolve_time (gfc_expr *f)
{
f->ts.type = BT_INTEGER;
@@ -2510,22 +2540,14 @@
void
gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
- static char ubound[] = "__ubound";
+ resolve_bound (f, array, dim, kind, "__ubound");
+}
- f->ts.type = BT_INTEGER;
- if (kind)
- f->ts.kind = mpz_get_si (kind->value.integer);
- else
- f->ts.kind = gfc_default_integer_kind;
- if (dim == NULL)
- {
- f->rank = 1;
- f->shape = gfc_get_shape (1);
- mpz_init_set_ui (f->shape[0], array->rank);
- }
-
- f->value.function.name = ubound;
+void
+gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+ resolve_bound (f, array, dim, kind, "__ucobound");
}