fortran/array.c | 5 fortran/check.c | 188 +++++++++++++++ fortran/gfortran.h | 4 fortran/intrinsic.c | 27 ++ fortran/intrinsic.h | 8 fortran/intrinsic.texi | 190 +++++++++++++++ fortran/match.c | 4 fortran/simplify.c | 434 +++++++++++++++++++++++++++++++++++- testsuite/gfortran.dg/coarray_9.f90 | 7 9 files changed, 849 insertions(+), 18 deletions(-) diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index d9ca043..f0df9ad 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -529,7 +529,7 @@ coarray: if (gfc_option.coarray == GFC_FCOARRAY_NONE) { - gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); goto cleanup; } @@ -2448,7 +2448,8 @@ gfc_find_array_ref (gfc_expr *e) for (ref = e->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY - && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION)) + && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION + || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0))) break; if (ref == NULL) diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 9b6f8ea..66cdf7e 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1,5 +1,5 @@ /* Check functions - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught & Katherine Holcomb @@ -182,6 +182,32 @@ double_check (gfc_expr *d, int n) } +/* Check whether an expression is a coarray (without array designator). */ + +static bool +is_coarray (gfc_expr *e) +{ + bool coarray = false; + gfc_ref *ref; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + coarray = e->symtree->n.sym->attr.codimension; + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT) + coarray = ref->u.c.component->attr.codimension; + else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0 + || ref->u.ar.codimen != 0) + coarray = false; + } + + return coarray; +} + + /* Make sure the expression is a logical array. */ static gfc_try @@ -328,6 +354,36 @@ dim_check (gfc_expr *dim, int n, bool optional) } +/* If a coarray DIM parameter is a constant, make sure that it is greater than + zero and less than or equal to the corank of the given array. */ + +static gfc_try +dim_corank_check (gfc_expr *dim, gfc_expr *array) +{ + gfc_array_ref *ar; + int corank; + + gcc_assert (array->expr_type == EXPR_VARIABLE); + + if (dim->expr_type != EXPR_CONSTANT) + return SUCCESS; + + ar = gfc_find_array_ref (array); + corank = ar->as->corank; + + if (mpz_cmp_ui (dim->value.integer, 1) < 0 + || mpz_cmp_ui (dim->value.integer, corank) > 0) + { + gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid " + "codimension index", gfc_current_intrinsic, &dim->where); + + return FAILURE; + } + + return SUCCESS; +} + + /* If a DIM parameter is a constant, make sure that it is greater than zero and less than or equal to the rank of the given array. If allow_assumed is zero then dim must be less than the rank of the array @@ -1640,6 +1696,38 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_try +gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) +{ + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return FAILURE; + } + + if (!is_coarray (coarray)) + { + gfc_error ("Expected coarray variable as '%s' argument to the LCOBOUND " + "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where); + return FAILURE; + } + + if (dim != NULL) + { + if (dim_check (dim, 1, false) == FAILURE) + return FAILURE; + + if (dim_corank_check (dim, coarray) == FAILURE) + return FAILURE; + } + + if (kind_check (kind, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) { if (type_check (s, 0, BT_CHARACTER) == FAILURE) @@ -3144,6 +3232,72 @@ gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) gfc_try +gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) +{ + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return FAILURE; + } + + if (!is_coarray (coarray)) + { + gfc_error ("Expected coarray variable as '%s' argument to IMAGE_INDEX " + "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where); + return FAILURE; + } + + if (sub->rank != 1) + { + gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L", + gfc_current_intrinsic_arg[1], &sub->where); + return FAILURE; + } + + return SUCCESS; +} + + +gfc_try +gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim) +{ + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return FAILURE; + } + + if (dim != NULL && coarray == NULL) + { + gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE " + "intrinsic at %L", &coarray->where); + return FAILURE; + } + + if (coarray == NULL) + return SUCCESS; + + if (!is_coarray (coarray)) + { + gfc_error ("Expected coarray variable as '%s' argument to THIS_IMAGE " + "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where); + return FAILURE; + } + + if (dim != NULL) + { + if (dim_check (dim, 1, false) == FAILURE) + return FAILURE; + + if (dim_corank_check (dim, coarray) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + +gfc_try gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED, gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size) { @@ -3204,6 +3358,38 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_try +gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) +{ + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return FAILURE; + } + + if (!is_coarray (coarray)) + { + gfc_error ("Expected coarray variable as '%s' argument to the UCOBOUND " + "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where); + return FAILURE; + } + + if (dim != NULL) + { + if (dim_check (dim, 1, false) == FAILURE) + return FAILURE; + + if (dim_corank_check (dim, coarray) == FAILURE) + return FAILURE; + } + + if (kind_check (kind, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +gfc_try gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { mpz_t vector_size; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 3668df4..9d916cd 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -404,6 +404,7 @@ enum gfc_isym_id GFC_ISYM_IDATE, GFC_ISYM_IEOR, GFC_ISYM_IERRNO, + GFC_ISYM_IMAGE_INDEX, GFC_ISYM_INDEX, GFC_ISYM_INT, GFC_ISYM_INT2, @@ -423,6 +424,7 @@ enum gfc_isym_id GFC_ISYM_KILL, GFC_ISYM_KIND, GFC_ISYM_LBOUND, + GFC_ISYM_LCOBOUND, GFC_ISYM_LEADZ, GFC_ISYM_LEN, GFC_ISYM_LEN_TRIM, @@ -509,6 +511,7 @@ enum gfc_isym_id GFC_ISYM_SYSTEM_CLOCK, GFC_ISYM_TAN, GFC_ISYM_TANH, + GFC_ISYM_THIS_IMAGE, GFC_ISYM_TIME, GFC_ISYM_TIME8, GFC_ISYM_TINY, @@ -518,6 +521,7 @@ enum gfc_isym_id GFC_ISYM_TRIM, GFC_ISYM_TTYNAM, GFC_ISYM_UBOUND, + GFC_ISYM_UCOBOUND, GFC_ISYM_UMASK, GFC_ISYM_UNLINK, GFC_ISYM_UNPACK, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index fbfc47a..470839a 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1081,7 +1081,8 @@ add_functions (void) *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b", *z = "z", *ln = "len", *ut = "unit", *han = "handler", *num = "number", *tm = "time", *nm = "name", *md = "mode", - *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command"; + *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command", + *ca = "coarray", *sub = "sub"; int di, dr, dd, dl, dc, dz, ii; @@ -1784,6 +1785,10 @@ add_functions (void) 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, + ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED); + /* The resolution function for INDEX is called gfc_resolve_index_func because the name gfc_resolve_index is already used in resolve.c. */ add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, @@ -1919,6 +1924,14 @@ add_functions (void) 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, + ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F95); + add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_i, gfc_simplify_leadz, NULL, @@ -2526,6 +2539,10 @@ add_functions (void) 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, + 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, NULL, NULL, gfc_resolve_time); @@ -2582,6 +2599,14 @@ add_functions (void) 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, + ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F95); + /* g77 compatibility for UMASK. */ add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index b675de2..de33a4f 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -91,6 +91,7 @@ gfc_try gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_kill (gfc_expr *, gfc_expr *); gfc_try gfc_check_kind (gfc_expr *); gfc_try gfc_check_lbound (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_try gfc_check_lcobound (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_len_lentrim (gfc_expr *, gfc_expr *); gfc_try gfc_check_link (gfc_expr *, gfc_expr *); gfc_try gfc_check_lge_lgt_lle_llt (gfc_expr *, gfc_expr *); @@ -143,6 +144,7 @@ gfc_try gfc_check_transpose (gfc_expr *); gfc_try gfc_check_trim (gfc_expr *); gfc_try gfc_check_ttynam (gfc_expr *); gfc_try gfc_check_ubound (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_try gfc_check_ucobound (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_umask (gfc_expr *); gfc_try gfc_check_unlink (gfc_expr *); gfc_try gfc_check_unpack (gfc_expr *, gfc_expr *, gfc_expr *); @@ -178,6 +180,7 @@ gfc_try gfc_check_fseek_sub (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_ftell_sub (gfc_expr *, gfc_expr *); gfc_try gfc_check_getcwd_sub (gfc_expr *, gfc_expr *); gfc_try gfc_check_hostnm_sub (gfc_expr *, gfc_expr *); +gfc_try gfc_check_image_index (gfc_expr *, gfc_expr *); gfc_try gfc_check_itime_idate (gfc_expr *); gfc_try gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_ltime_gmtime (gfc_expr *, gfc_expr *); @@ -189,6 +192,7 @@ gfc_try gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_sleep_sub (gfc_expr *); gfc_try gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_system_sub (gfc_expr *, gfc_expr *); +gfc_try gfc_check_this_image (gfc_expr *, gfc_expr *); gfc_try gfc_check_ttynam_sub (gfc_expr *, gfc_expr *); gfc_try gfc_check_umask_sub (gfc_expr *, gfc_expr *); gfc_try gfc_check_unlink_sub (gfc_expr *, gfc_expr *); @@ -255,6 +259,7 @@ gfc_expr *gfc_simplify_ibits (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ichar (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_int2 (gfc_expr *); @@ -270,6 +275,7 @@ gfc_expr *gfc_simplify_ishft (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ishftc (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_kind (gfc_expr *); gfc_expr *gfc_simplify_lbound (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_lcobound (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_leadz (gfc_expr *); gfc_expr *gfc_simplify_len (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_len_trim (gfc_expr *, gfc_expr *); @@ -330,12 +336,14 @@ gfc_expr *gfc_simplify_sqrt (gfc_expr *); gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_tan (gfc_expr *); gfc_expr *gfc_simplify_tanh (gfc_expr *); +gfc_expr *gfc_simplify_this_image (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_tiny (gfc_expr *); gfc_expr *gfc_simplify_trailz (gfc_expr *); gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_transpose (gfc_expr *); gfc_expr *gfc_simplify_trim (gfc_expr *); gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_ucobound (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_unpack (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_xor (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 4439464..63b8b2b 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -154,6 +154,7 @@ Some basic guidelines for editing this document: * @code{INT8}: INT8, Convert to 64-bit integer type * @code{IOR}: IOR, Bitwise logical or * @code{IRAND}: IRAND, Integer pseudo-random number +* @code{IMAGE_INDEX}: IMAGE_INDEX, Cosubscript to image index convertion * @code{IS_IOSTAT_END}: IS_IOSTAT_END, Test for end-of-file value * @code{IS_IOSTAT_EOR}: IS_IOSTAT_EOR, Test for end-of-record value * @code{ISATTY}: ISATTY, Whether a unit is a terminal device @@ -164,6 +165,7 @@ Some basic guidelines for editing this document: * @code{KILL}: KILL, Send a signal to a process * @code{KIND}: KIND, Kind of an entity * @code{LBOUND}: LBOUND, Lower dimension bounds of an array +* @code{LCOBOUND}: LCOBOUND, Lower codimension bounds of an array * @code{LEADZ}: LEADZ, Number of leading zero bits of an integer * @code{LEN}: LEN, Length of a character entity * @code{LEN_TRIM}: LEN_TRIM, Length of a character entity without trailing blank characters @@ -251,6 +253,7 @@ Some basic guidelines for editing this document: * @code{SYSTEM_CLOCK}: SYSTEM_CLOCK, Time function * @code{TAN}: TAN, Tangent function * @code{TANH}: TANH, Hyperbolic tangent function +* @code{THIS_IMAGE}: THIS_IMAGE, Cosubscript index of this image * @code{TIME}: TIME, Time function * @code{TIME8}: TIME8, Time function (64-bit) * @code{TINY}: TINY, Smallest positive number of a real kind @@ -260,6 +263,7 @@ Some basic guidelines for editing this document: * @code{TRIM}: TRIM, Remove trailing blank characters of a string * @code{TTYNAM}: TTYNAM, Get the name of a terminal device. * @code{UBOUND}: UBOUND, Upper dimension bounds of an array +* @code{UCOBOUND}: UCOBOUND, Upper codimension bounds of an array * @code{UMASK}: UMASK, Set the file creation mask * @code{UNLINK}: UNLINK, Remove a file from the file system * @code{UNPACK}: UNPACK, Unpack an array of rank one into an array @@ -6115,6 +6119,50 @@ end program test_irand +@node IMAGE_INDEX +@section @code{IMAGE_INDEX} --- Function that converts a cosubscript to an image index +@fnindex IMAGE_INDEX +@cindex coarray, IMAGE_INDEX +@cindex images, cosubscript to image index conversion + +@table @asis +@item @emph{Description}: +Returns the image index belonging to a cosubscript. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Inquiry function. + +@item @emph{Syntax}: +@code{RESULT = IMAGE_INDEX(COARRAY, SUB)} + +@item @emph{Arguments}: None. +@multitable @columnfractions .15 .70 +@item @var{COARRAY} @tab Coarray of any type. +@item @var{SUB} @tab default integer rank-1 array of a size equal to +the corank of @var{COARRAY}. +@end multitable + + +@item @emph{Return value}: +Scalar default integer with the value of the image index which corresponds +to the cosubscripts. For invalid cosubscripts the result is zero. + +@item @emph{Example}: +@smallexample +INTEGER :: array[2,-1:4,8,*] +! Writes 28 (or 0 if there are fewer than 28 images) +WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1]) +@end smallexample + +@item @emph{See also}: +@ref{THIS_IMAGE}, @ref{NUM_IMAGES} +@end table + + + @node IS_IOSTAT_END @section @code{IS_IOSTAT_END} --- Test for end-of-file value @fnindex IS_IOSTAT_END @@ -6535,7 +6583,46 @@ structure component, or if it has a zero extent along the relevant dimension, the lower bound is taken to be 1. @item @emph{See also}: -@ref{UBOUND} +@ref{UBOUND}, @ref{LCOBOUND} +@end table + + + +@node LCOBOUND +@section @code{LCOBOUND} --- Lower codimension bounds of an array +@fnindex LCOBOUND +@cindex coarray, lower bound + +@table @asis +@item @emph{Description}: +Returns the lower bounds of a coarray, or a single lower cobound +along the @var{DIM} codimension. +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Inquiry function + +@item @emph{Syntax}: +@code{RESULT = LCOBOUND(COARRAY [, DIM [, KIND]])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an coarray, of any type. +@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization +expression indicating the kind parameter of the result. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{INTEGER} and of kind @var{KIND}. If +@var{KIND} is absent, the return value is of default integer kind. +If @var{DIM} is absent, the result is an array of the lower cobounds of +@var{COARRAY}. If @var{DIM} is present, the result is a scalar +corresponding to the lower cobound of the array along that codimension. + +@item @emph{See also}: +@ref{UCOBOUND}, @ref{LBOUND} @end table @@ -8414,7 +8501,7 @@ END IF @end smallexample @item @emph{See also}: -@c FIXME: ref{THIS_IMAGE} +@ref{THIS_IMAGE}, @ref{IMAGE_INDEX} @end table @@ -10654,6 +10741,64 @@ end program test_tanh +@node THIS_IMAGE +@section @code{THIS_IMAGE} --- Function that returns the cosubscript index of this image +@fnindex THIS_IMAGE +@cindex coarray, THIS_IMAGE +@cindex images, index of this image + +@table @asis +@item @emph{Description}: +Returns the cosubscript for this image. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = THIS_IMAGE()} +@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM])} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{COARRAY} @tab Coarray of any type (optional; if @var{DIM} +present, required). +@item @var{DIM} @tab default integer scalar (optional). If present, +@var{DIM} shall be between one and the corank of @var{COARRAY}. +@end multitable + + +@item @emph{Return value}: +Default integer. If @var{COARRAY} is not present, it is scalar and its value +is the index of the invoking image. Otherwise, if @var{DIM} is not present, +a rank-1 array with corank elements is returned, containing the cosubscripts +for @var{COARRAY} specifying the invoking image. If @var{DIM} is present, +a scalar is returned, with the value of the @var{DIM} element of +@code{THIS_IMAGE(COARRAY)}. + +@item @emph{Example}: +@smallexample +INTEGER :: value[*] +INTEGER :: i +value = THIS_IMAGE() +SYNC ALL +IF (THIS_IMAGE() == 1) THEN + DO i = 1, NUM_IMAGES() + WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i] + END DO +END IF +@end smallexample + +@item @emph{See also}: +@ref{NUM_IMAGES}, @ref{IMAGE_INDEX} +@end table + + + @node TIME @section @code{TIME} --- Time function @fnindex TIME @@ -11030,7 +11175,46 @@ dimension, the upper bound is taken to be the number of elements along the relevant dimension. @item @emph{See also}: -@ref{LBOUND} +@ref{LBOUND}, @ref{LCOBOUND} +@end table + + + +@node UCOBOUND +@section @code{UCOBOUND} --- Upper codimension bounds of an array +@fnindex UCOBOUND +@cindex coarray, upper bound + +@table @asis +@item @emph{Description}: +Returns the upper cobounds of a coarray, or a single upper cobound +along the @var{DIM} codimension. +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Inquiry function + +@item @emph{Syntax}: +@code{RESULT = UCOBOUND(COARRAY [, DIM [, KIND]])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an coarray, of any type. +@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}. +@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization +expression indicating the kind parameter of the result. +@end multitable + +@item @emph{Return value}: +The return value is of type @code{INTEGER} and of kind @var{KIND}. If +@var{KIND} is absent, the return value is of default integer kind. +If @var{DIM} is absent, the result is an array of the lower cobounds of +@var{COARRAY}. If @var{DIM} is present, the result is a scalar +corresponding to the lower cobound of the array along that codimension. + +@item @emph{See also}: +@ref{LCOBOUND}, @ref{LBOUND} @end table diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 2709de7..12aceb0 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1752,7 +1752,7 @@ gfc_match_critical (void) if (gfc_option.coarray == GFC_FCOARRAY_NONE) { - gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); return MATCH_ERROR; } @@ -2153,7 +2153,7 @@ sync_statement (gfc_statement st) if (gfc_option.coarray == GFC_FCOARRAY_NONE) { - gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); return MATCH_ERROR; } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 50cd6da..c394345 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2890,13 +2890,14 @@ gfc_simplify_kind (gfc_expr *e) static gfc_expr * simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, - gfc_array_spec *as, gfc_ref *ref) + gfc_array_spec *as, gfc_ref *ref, bool coarray) { gfc_expr *l, *u, *result; int k; /* The last dimension of an assumed-size array is special. */ - if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) + if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) + || (coarray && d == as->rank + as->corank)) { if (as->lower[d-1]->expr_type == EXPR_CONSTANT) return gfc_copy_expr (as->lower[d-1]); @@ -2913,12 +2914,13 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, /* Then, we need to know the extent of the given dimension. */ - if (ref->u.ar.type == AR_FULL) + if (coarray || ref->u.ar.type == AR_FULL) { l = as->lower[d-1]; u = as->upper[d-1]; - if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT) + if (l->expr_type != EXPR_CONSTANT || u == NULL + || u->expr_type != EXPR_CONSTANT) return NULL; if (mpz_cmp (l->value.integer, u->value.integer) > 0) @@ -3030,7 +3032,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) /* Simplify the bounds for each dimension. */ for (d = 0; d < array->rank; d++) { - bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref); + bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref, + false); if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) { int j; @@ -3096,7 +3099,154 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) return &gfc_bad_expr; } - return simplify_bound_dim (array, kind, d, upper, as, ref); + return simplify_bound_dim (array, kind, d, upper, as, ref, false); + } +} + + +static gfc_expr * +simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) +{ + gfc_ref *ref; + gfc_array_spec *as; + int d; + + if (array->expr_type != EXPR_VARIABLE) + return NULL; + + /* Follow any component references. */ + as = array->symtree->n.sym->as; + for (ref = array->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + switch (ref->u.ar.type) + { + case AR_ELEMENT: + as = NULL; + continue; + + case AR_FULL: + /* We're done because 'as' has already been set in the + previous iteration. */ + if (!ref->next) + goto done; + + /* Fall through. */ + + case AR_UNKNOWN: + return NULL; + + case AR_SECTION: + as = ref->u.ar.as; + goto done; + } + + gcc_unreachable (); + + case REF_COMPONENT: + as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + continue; + } + } + + gcc_unreachable (); + + done: + + if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE) + return NULL; + + if (dim == NULL) + { + /* Multi-dimensional bounds. */ + gfc_expr *bounds[GFC_MAX_DIMENSIONS]; + gfc_expr *e; + gfc_constructor *head, *tail; + int k; + + /* UBOUND(ARRAY) is not valid for an assumed-size array. */ + if (upper && as->type == AS_ASSUMED_SIZE) + { + /* An error message will be emitted in + check_assumed_size_reference (resolve.c). */ + return &gfc_bad_expr; + } + + /* Simplify the bounds for each dimension. */ + for (d = 0; d < as->corank; d++) + { + bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank, + upper, as, ref, true); + if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) + { + int j; + + for (j = 0; j < d; j++) + gfc_free_expr (bounds[j]); + return bounds[d]; + } + } + + /* Allocate the result expression. */ + e = gfc_get_expr (); + e->where = array->where; + e->expr_type = EXPR_ARRAY; + e->ts.type = BT_INTEGER; + k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND", + gfc_default_integer_kind); + if (k == -1) + { + gfc_free_expr (e); + return &gfc_bad_expr; + } + e->ts.kind = k; + + /* The result is a rank 1 array; its size is the rank of the first + argument to {L,U}COBOUND. */ + e->rank = 1; + e->shape = gfc_get_shape (1); + mpz_init_set_ui (e->shape[0], as->corank); + + /* Create the constructor for this array. */ + head = tail = NULL; + for (d = 0; d < as->corank; d++) + { + /* Get a new constructor element. */ + if (head == NULL) + head = tail = gfc_get_constructor (); + else + { + tail->next = gfc_get_constructor (); + tail = tail->next; + } + + tail->where = e->where; + tail->expr = bounds[d]; + } + e->value.constructor = head; + + return e; + } + else + { + /* A DIM argument is specified. */ + if (dim->expr_type != EXPR_CONSTANT) + return NULL; + + d = mpz_get_si (dim->value.integer); + + if (d < 1 || d > as->corank) + { + gfc_error ("DIM argument at %L is out of bounds", &dim->where); + return &gfc_bad_expr; + } + + return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true); } } @@ -3109,6 +3259,21 @@ gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_expr * +gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + gfc_expr *e; + /* return simplify_cobound (array, dim, kind, 0);*/ + + e = simplify_cobound (array, dim, kind, 0); + if (e != NULL) + return e; + + gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant " + "cobounds at %L", &e->where); + return &gfc_bad_expr; +} + +gfc_expr * gfc_simplify_leadz (gfc_expr *e) { gfc_expr *result; @@ -3939,6 +4104,13 @@ gfc_expr * gfc_simplify_num_images (void) { gfc_expr *result; + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return &gfc_bad_expr; + } + /* FIXME: gfc_current_locus is wrong. */ result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); mpz_set_si (result->value.integer, 1); @@ -5489,11 +5661,261 @@ gfc_simplify_trim (gfc_expr *e) gfc_expr * +gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) +{ + gfc_expr *result; + gfc_ref *ref; + gfc_array_spec *as; + gfc_constructor *sub_cons; + bool first_image; + int d; + + if (!is_constant_array_expr (sub)) + goto not_implemented; /* return NULL;*/ + + /* Follow any component references. */ + as = coarray->symtree->n.sym->as; + for (ref = coarray->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + as = ref->u.ar.as; + + if (as->type == AS_DEFERRED) + goto not_implemented; /* return NULL;*/ + + /* "valid sequence of cosubscripts" are required; thus, return 0 unless + the cosubscript addresses the first image. */ + + sub_cons = sub->value.constructor; + first_image = true; + + for (d = 1; d <= as->corank; d++) + { + gfc_expr *ca_bound; + int cmp; + + if (sub_cons == NULL) + { + gfc_error ("Too few elements in expression for SUB= argument at %L", + &sub->where); + return &gfc_bad_expr; + } + + ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, + NULL, true); + if (ca_bound == NULL) + goto not_implemented; /* return NULL */ + + if (ca_bound == &gfc_bad_expr) + return ca_bound; + + cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer); + + if (cmp == 0) + { + gfc_free_expr (ca_bound); + sub_cons = sub_cons->next; + continue; + } + + first_image = false; + + if (cmp > 0) + { + gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " + "SUB has %ld and COARRAY lower bound is %ld)", + &coarray->where, d, + mpz_get_si (sub_cons->expr->value.integer), + mpz_get_si (ca_bound->value.integer)); + gfc_free_expr (ca_bound); + return &gfc_bad_expr; + } + + gfc_free_expr (ca_bound); + + /* Check whether upperbound is valid for the multi-images case. */ + if (d < as->corank) + { + ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as, + NULL, true); + if (ca_bound == &gfc_bad_expr) + return ca_bound; + + if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT + && mpz_cmp (ca_bound->value.integer, + sub_cons->expr->value.integer) < 0) + { + gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " + "SUB has %ld and COARRAY upper bound is %ld)", + &coarray->where, d, + mpz_get_si (sub_cons->expr->value.integer), + mpz_get_si (ca_bound->value.integer)); + gfc_free_expr (ca_bound); + return &gfc_bad_expr; + } + + if (ca_bound) + gfc_free_expr (ca_bound); + } + + sub_cons = sub_cons->next; + } + + if (sub_cons != NULL) + { + gfc_error ("Too many elements in expression for SUB= argument at %L", + &sub->where); + return &gfc_bad_expr; + } + + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + if (first_image) + mpz_set_si (result->value.integer, 1); + else + mpz_set_si (result->value.integer, 0); + + return result; + +not_implemented: + gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant " + "cobounds at %L", &coarray->where); + return &gfc_bad_expr; +} + + +gfc_expr * +gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) +{ + gfc_ref *ref; + gfc_array_spec *as; + int d; + + if (coarray == NULL) + { + gfc_expr *result; + /* FIXME: gfc_current_locus is wrong. */ + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); + mpz_set_si (result->value.integer, 1); + return result; + } + + gcc_assert (coarray->expr_type == EXPR_VARIABLE); + + /* Follow any component references. */ + as = coarray->symtree->n.sym->as; + for (ref = coarray->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + as = ref->u.ar.as; + + if (as->type == AS_DEFERRED) + goto not_implemented; /* return NULL;*/ + + if (dim == NULL) + { + /* Multi-dimensional bounds. */ + gfc_expr *bounds[GFC_MAX_DIMENSIONS]; + gfc_expr *e; + gfc_constructor *head, *tail; + + /* Simplify the bounds for each dimension. */ + for (d = 0; d < as->corank; d++) + { + bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0, + as, NULL, true); + if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) + { + int j; + + for (j = 0; j < d; j++) + gfc_free_expr (bounds[j]); + if (bounds[d] == NULL) + goto not_implemented; + return bounds[d]; + } + } + + /* Allocate the result expression. */ + e = gfc_get_expr (); + e->where = coarray->where; + e->expr_type = EXPR_ARRAY; + e->ts.type = BT_INTEGER; + e->ts.kind = gfc_default_integer_kind; + + e->rank = 1; + e->shape = gfc_get_shape (1); + mpz_init_set_ui (e->shape[0], as->corank); + + /* Create the constructor for this array. */ + head = tail = NULL; + for (d = 0; d < as->corank; d++) + { + /* Get a new constructor element. */ + if (head == NULL) + head = tail = gfc_get_constructor (); + else + { + tail->next = gfc_get_constructor (); + tail = tail->next; + } + + tail->where = e->where; + tail->expr = bounds[d]; + } + e->value.constructor = head; + + return e; + } + else + { + gfc_expr *e; + /* A DIM argument is specified. */ + if (dim->expr_type != EXPR_CONSTANT) + goto not_implemented; /*return NULL;*/ + + d = mpz_get_si (dim->value.integer); + + if (d < 1 || d > as->corank) + { + gfc_error ("DIM argument at %L is out of bounds", &dim->where); + return &gfc_bad_expr; + } + + /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/ + e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true); + if (e != NULL) + return e; + else + goto not_implemented; + } + +not_implemented: + gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant " + "cobounds at %L", &coarray->where); + return &gfc_bad_expr; +} + + +gfc_expr * gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { return simplify_bound (array, dim, kind, 1); } +gfc_expr * +gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + gfc_expr *e; + /* return simplify_cobound (array, dim, kind, 1);*/ + + e = simplify_cobound (array, dim, kind, 1); + if (e != NULL) + return e; + + gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant " + "cobounds at %L", &e->where); + return &gfc_bad_expr; +} + gfc_expr * gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) diff --git a/gcc/testsuite/gfortran.dg/coarray_9.f90 b/gcc/testsuite/gfortran.dg/coarray_9.f90 index d44cdda..cdfb4dc 100644 --- a/gcc/testsuite/gfortran.dg/coarray_9.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_9.f90 @@ -9,9 +9,10 @@ integer :: a integer :: b[*] ! { dg-error "Coarrays disabled" } error stop "Error" -sync all ! { dg-error "Coarrays disabled" } +sync all ! "Coarrays disabled" (but error above is fatal) -critical ! { dg-error "Coarrays disabled" } -end critical ! { dg-error "Expecting END PROGRAM statement" } +critical ! "Coarrays disabled" (but error above is fatal) + +end critical ! "Expecting END PROGRAM statement" (but error above is fatal) end