procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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  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.

From-SVN: r158292
This commit is contained in:
Tobias Burnus 2010-04-14 07:43:30 +02:00 • committed by Tobias Burnus
parent e1859f3336
commit 64f002ed70
13 changed files with 933 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
gcc/fortran/ChangeLog
View file

@ -1,3 +1,31 @@
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

7
gcc/fortran/array.c
View file

@ -210,7 +210,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");
return MATCH_ERROR;
}
@ -531,7 +531,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;
}
@ -2223,7 +2223,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)

188
gcc/fortran/check.c
View file

@ -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
@ -183,6 +183,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
@ -329,6 +355,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)
{
@ -3137,6 +3225,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", &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)
@ -3197,6 +3351,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)
{

4
gcc/fortran/gfortran.h
View file

@ -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,

27
gcc/fortran/intrinsic.c
View file

@ -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,

8
gcc/fortran/intrinsic.h
View file

@ -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 *);

190
gcc/fortran/intrinsic.texi
View file

@ -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

4
gcc/fortran/match.c
View file

@ -1753,7 +1753,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;
}
@ -2154,7 +2154,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;
}

398
gcc/fortran/simplify.c
View file

@ -2722,13 +2722,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]);
@ -2745,12 +2746,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)
@ -2861,7 +2863,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;
@ -2908,7 +2911,131 @@ 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 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);
}
}
@ -2920,6 +3047,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", &array->where);
return &gfc_bad_expr;
}
gfc_expr *
gfc_simplify_leadz (gfc_expr *e)
{
@ -3703,6 +3845,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_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
&gfc_current_locus);
@ -5173,12 +5322,249 @@ 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 = 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)

7
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,10 @@
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

28
gcc/testsuite/gfortran.dg/coarray_10.f90 Normal file
View file

@ -0,0 +1,28 @@
! { 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

56
gcc/testsuite/gfortran.dg/coarray_11.f90 Normal file
View file

@ -0,0 +1,56 @@
! { 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" } }

7
gcc/testsuite/gfortran.dg/coarray_9.f90
View file

@ -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