Commit 0d6d8e00 by Tobias Burnus Committed by Tobias Burnus

re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])

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.

From-SVN: r158974
parent 34a47f6f
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/18918
PR fortran/43931 PR fortran/43931
......
...@@ -1786,7 +1786,7 @@ add_functions (void) ...@@ -1786,7 +1786,7 @@ add_functions (void)
make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU); 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, 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); ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED);
/* The resolution function for INDEX is called gfc_resolve_index_func /* The resolution function for INDEX is called gfc_resolve_index_func
...@@ -1925,12 +1925,12 @@ add_functions (void) ...@@ -1925,12 +1925,12 @@ add_functions (void)
make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95); make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO, add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95, BT_INTEGER, di, GFC_STD_F2008,
gfc_check_lcobound, gfc_simplify_lcobound, NULL, gfc_check_lcobound, gfc_simplify_lcobound, gfc_resolve_lcobound,
ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
kind, BT_INTEGER, di, 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, add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008, BT_INTEGER, di, GFC_STD_F2008,
...@@ -2540,7 +2540,7 @@ add_functions (void) ...@@ -2540,7 +2540,7 @@ add_functions (void)
make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77); 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, 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); 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, add_sym_0 ("time", GFC_ISYM_TIME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
...@@ -2600,12 +2600,12 @@ add_functions (void) ...@@ -2600,12 +2600,12 @@ add_functions (void)
make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95); make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO, add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F95, BT_INTEGER, di, GFC_STD_F2008,
gfc_check_ucobound, gfc_simplify_ucobound, NULL, gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound,
ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
kind, BT_INTEGER, di, 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. */ /* g77 compatibility for UMASK. */
add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
......
...@@ -422,6 +422,7 @@ void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *); ...@@ -422,6 +422,7 @@ void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *); 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_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibset (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 *, void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *); gfc_expr *);
void gfc_resolve_ierrno (gfc_expr *); void gfc_resolve_ierrno (gfc_expr *);
...@@ -441,6 +442,7 @@ void gfc_resolve_ishft (gfc_expr *, gfc_expr *, gfc_expr *); ...@@ -441,6 +442,7 @@ void gfc_resolve_ishft (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ishftc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); 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_kill (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_lbound (gfc_expr *, 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 (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_len_trim (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 *); void gfc_resolve_lgamma (gfc_expr *, gfc_expr *);
...@@ -498,6 +500,7 @@ void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *); ...@@ -498,6 +500,7 @@ void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_system (gfc_expr *, gfc_expr *); void gfc_resolve_system (gfc_expr *, gfc_expr *);
void gfc_resolve_tan (gfc_expr *, gfc_expr *); void gfc_resolve_tan (gfc_expr *, gfc_expr *);
void gfc_resolve_tanh (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_time (gfc_expr *);
void gfc_resolve_time8 (gfc_expr *); void gfc_resolve_time8 (gfc_expr *);
void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
...@@ -505,6 +508,7 @@ void gfc_resolve_transpose (gfc_expr *, gfc_expr *); ...@@ -505,6 +508,7 @@ void gfc_resolve_transpose (gfc_expr *, gfc_expr *);
void gfc_resolve_trim (gfc_expr *, gfc_expr *); void gfc_resolve_trim (gfc_expr *, gfc_expr *);
void gfc_resolve_ttynam (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_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_umask (gfc_expr *, gfc_expr *);
void gfc_resolve_unlink (gfc_expr *, gfc_expr *); void gfc_resolve_unlink (gfc_expr *, gfc_expr *);
void gfc_resolve_unpack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_unpack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
......
...@@ -119,6 +119,27 @@ resolve_mask_arg (gfc_expr *mask) ...@@ -119,6 +119,27 @@ resolve_mask_arg (gfc_expr *mask)
} }
} }
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 **********************/ /********************** Resolution functions **********************/
...@@ -1247,22 +1268,14 @@ gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED, ...@@ -1247,22 +1268,14 @@ gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
void void
gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 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) void
{ gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
f->rank = 1; {
f->shape = gfc_get_shape (1); resolve_bound (f, array, dim, kind, "__lcobound");
mpz_init_set_ui (f->shape[0], array->rank);
}
f->value.function.name = lbound;
} }
...@@ -2376,6 +2389,23 @@ gfc_resolve_tanh (gfc_expr *f, gfc_expr *x) ...@@ -2376,6 +2389,23 @@ gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
void 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) gfc_resolve_time (gfc_expr *f)
{ {
f->ts.type = BT_INTEGER; f->ts.type = BT_INTEGER;
...@@ -2510,22 +2540,14 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string) ...@@ -2510,22 +2540,14 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
void void
gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) 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");
} }
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment