+2010-04-14 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/18918
+ * array.c (gfc_find_array_ref): Handle codimensions.
+ (gfc_match_array_spec,gfc_match_array_ref): Use gfc_fatal_error.
+ * check.c (is_coarray, dim_corank_check, gfc_check_lcobound,
+ gfc_check_image_index, gfc_check_this_image, gfc_check_ucobound):
+ New functions.
+ * gfortran.h (gfc_isym_id): Add GFC_ISYM_IMAGE_INDEX,
+ GFC_ISYM_LCOBOUND, GFC_ISYM_THIS_IMAGE,
+ GFC_ISYM_UCOBOUND.
+ * intrinsic.h (add_functions): Add this_image, image_index,
+ lcobound and ucobound intrinsics.
+ * intrinsic.c (gfc_check_lcobound,gfc_check_ucobound,
+ gfc_check_image_index, gfc_check_this_image,
+ gfc_simplify_image_index, gfc_simplify_lcobound,
+ gfc_simplify_this_image, gfc_simplify_ucobound):
+ New function prototypes.
+ * intrinsic.texi (IMAGE_INDEX, LCOBOUND, THIS_IMAGE
+ IMAGE_INDEX): Document new intrinsic functions.
+ * match.c (gfc_match_critical, sync_statement): Make -fcoarray=none
+ error fatal.
+ * simplify.c (simplify_bound_dim): Handle coarrays.
+ (simplify_bound): Update simplify_bound_dim call.
+ (gfc_simplify_num_images): Add -fcoarray=none check.
+ (simplify_cobound, gfc_simplify_lcobound, gfc_simplify_ucobound,
+ gfc_simplify_ucobound, gfc_simplify_ucobound): New functions.
+
2010-04-14 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/43747
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;
}
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;
}
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)
/* 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
}
+/* 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
}
+/* 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
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)
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", &dim->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)
{
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;
GFC_ISYM_IDATE,
GFC_ISYM_IEOR,
GFC_ISYM_IERRNO,
+ GFC_ISYM_IMAGE_INDEX,
GFC_ISYM_INDEX,
GFC_ISYM_INT,
GFC_ISYM_INT2,
GFC_ISYM_KILL,
GFC_ISYM_KIND,
GFC_ISYM_LBOUND,
+ GFC_ISYM_LCOBOUND,
GFC_ISYM_LEADZ,
GFC_ISYM_LEN,
GFC_ISYM_LEN_TRIM,
GFC_ISYM_SYSTEM_CLOCK,
GFC_ISYM_TAN,
GFC_ISYM_TANH,
+ GFC_ISYM_THIS_IMAGE,
GFC_ISYM_TIME,
GFC_ISYM_TIME8,
GFC_ISYM_TINY,
GFC_ISYM_TRIM,
GFC_ISYM_TTYNAM,
GFC_ISYM_UBOUND,
+ GFC_ISYM_UCOBOUND,
GFC_ISYM_UMASK,
GFC_ISYM_UNLINK,
GFC_ISYM_UNPACK,
*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;
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,
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,
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);
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,
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
* @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
* @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
* @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
* @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
+@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
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
@end smallexample
@item @emph{See also}:
-@c FIXME: ref{THIS_IMAGE}
+@ref{THIS_IMAGE}, @ref{IMAGE_INDEX}
@end table
+@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
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
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;
}
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;
}
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]);
/* 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)
/* 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;
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 cobounds. */
+ gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+ gfc_expr *e;
+ int k;
+
+ /* Simplify the cobounds 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. */
+ for (d = 0; d < as->corank; d++)
+ gfc_constructor_append_expr (&e->value.constructor,
+ bounds[d], &e->where);
+ 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);
}
}
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", &array->where);
+ return &gfc_bad_expr;
+}
+
+gfc_expr *
gfc_simplify_leadz (gfc_expr *e)
{
unsigned long lz, bs;
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_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
&gfc_current_locus);
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 = gfc_constructor_first (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 = gfc_constructor_next (sub_cons);
+ 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 = gfc_constructor_next (sub_cons);
+ }
+
+ if (sub_cons != NULL)
+ {
+ gfc_error ("Too many elements in expression for SUB= argument at %L",
+ &sub->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_get_constant_expr (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_get_constant_expr (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;
+
+ /* 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. */
+ for (d = 0; d < as->corank; d++)
+ gfc_constructor_append_expr (&e->value.constructor,
+ bounds[d], &e->where);
+
+ 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", &array->where);
+ return &gfc_bad_expr;
+}
+
gfc_expr *
gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
+2010-04-14 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/18918
+ * gfortran.dg/coarray_9.f90: Update dg-errors.
+ * gfortran.dg/coarray_10.f90: New test.
+ * gfortran.dg/coarray_11.f90: New test.
+
2010-04-14 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/43747
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/18918
+!
+! Coarray intrinsics
+!
+
+subroutine image_idx_test1()
+ INTEGER,save :: array[2,-1:4,8,*]
+ WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1])
+ WRITE (*,*) IMAGE_INDEX (array, [0,0,3,1]) ! { dg-error "for dimension 1, SUB has 0 and COARRAY lower bound is 1" }
+ WRITE (*,*) IMAGE_INDEX (array, [1,2,9,0]) ! { dg-error "for dimension 3, SUB has 9 and COARRAY upper bound is 8" }
+ WRITE (*,*) IMAGE_INDEX (array, [2,0,3]) ! { dg-error "Too few elements" }
+ WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1,1])! { dg-error "Too many elements" }
+end subroutine
+
+subroutine this_image_check()
+ integer,save :: a(1,2,3,5)[0:3,*]
+ integer :: j
+ integer,save :: z(4)[*], i
+
+ j = this_image(a,dim=3) ! { dg-error "not a valid codimension index" }
+ j = this_image(dim=3) ! { dg-error "DIM argument without ARRAY argument" }
+ i = image_index(i, [ 1 ]) ! { dg-error "Expected coarray variable" }
+ i = image_index(z, 2) ! { dg-error "must be a rank one array" }
+
+end subroutine this_image_check
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fcoarray=single -fdump-tree-original" }
+!
+! PR fortran/18918
+!
+! Coarray intrinsics
+!
+
+subroutine image_idx_test1()
+ INTEGER,save :: array[2,-1:4,8,*]
+ WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1])
+ if (IMAGE_INDEX (array, [1,-1,1,1]) /= 1) call not_existing()
+ if (IMAGE_INDEX (array, [2,-1,1,1]) /= 0) call not_existing()
+ if (IMAGE_INDEX (array, [1,-1,1,2]) /= 0) call not_existing()
+end subroutine
+
+subroutine this_image_check()
+ integer,save :: a(1,2,3,5)[0:3,*]
+ integer :: j
+ if (this_image() /= 1) call not_existing()
+ if (this_image(a,dim=1) /= 0) call not_existing()
+ if (this_image(a,dim=2) /= 1) call not_existing()
+end subroutine this_image_check
+
+subroutine othercheck()
+real,save :: a(5)[2,*]
+complex,save :: c[4:5,6,9:*]
+integer,save :: i, j[*]
+dimension :: b(3)
+codimension :: b[5:*]
+dimension :: h(9:10)
+codimension :: h[8:*]
+save :: b,h
+if (this_image() /= 1) call not_existing()
+if (num_images() /= 1) call not_existing()
+if(any(this_image(coarray=a) /= [ 1, 1 ])) call not_existing()
+if(any(this_image(c) /= [4,1,9])) call not_existing()
+if(this_image(c, dim=3) /= 9) call not_existing()
+if(ubound(b,dim=1) /= 3 .or. this_image(coarray=b,dim=1) /= 5) call not_existing()
+if(ubound(h,dim=1) /= 10 .or. this_image(h,dim=1) /= 8) call not_existing()
+end subroutine othercheck
+
+subroutine andanother()
+integer,save :: a(1)[2:9,4,-3:5,0:*]
+print *, lcobound(a)
+print *, lcobound(a,dim=3,kind=8)
+print *, ucobound(a)
+print *, ucobound(a,dim=1,kind=2)
+if (any(lcobound(a) /= [2, 1, -3, 0])) call not_existing()
+if (any(ucobound(a) /= [9, 4, 5, 0])) call not_existing()
+if (lcobound(a,dim=3,kind=8) /= -3_8) call not_existing()
+if (ucobound(a,dim=1,kind=2) /= 9_2) call not_existing()
+end subroutine andanother
+
+! { dg-final { scan-tree-dump-times "not_existing" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
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
OSDN Git Service
