OSDN Git Service

2010-04-14 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Wed, 14 Apr 2010 05:43:30 +0000 (05:43 +0000)
committerMasaki Muranaka <monaka@monami-software.com>
Sun, 23 May 2010 01:00:37 +0000 (10:00 +0900)
        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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158292 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/array.c
gcc/fortran/gfortran.h
gcc/fortran/intrinsic.c
gcc/fortran/intrinsic.texi
gcc/fortran/match.c
gcc/fortran/simplify.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/coarray_11.f90
gcc/testsuite/gfortran.dg/coarray_9.f90

index 7e0d91a..72ede7a 100644 (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
index c3e366d..5487be7 100644 (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)
index a95134c..48e80f6 100644 (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,
index a92b5b5..470839a 100644 (file)
@@ -30,7 +30,7 @@ along with GCC; see the file COPYING3.  If not see
 /* Namespace to hold the resolved symbols for intrinsic subroutines.  */
 static gfc_namespace *gfc_intrinsic_namespace;
 
-bool gfc_init_expr_flag = false;
+int gfc_init_expr = 0;
 
 /* Pointers to an intrinsic function and its argument names that are being
    checked.  */
@@ -956,14 +956,17 @@ gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc)
   /* See if this intrinsic is allowed in the current standard.  */
   if (gfc_check_intrinsic_standard (isym, &symstd, false, loc) == FAILURE)
     {
-      if (sym->attr.proc == PROC_UNKNOWN
-         && gfc_option.warn_intrinsics_std)
-       gfc_warning_now ("The intrinsic '%s' at %L is not included in the"
-                        " selected standard but %s and '%s' will be"
-                        " treated as if declared EXTERNAL.  Use an"
-                        " appropriate -std=* option or define"
-                        " -fall-intrinsics to allow this intrinsic.",
-                        sym->name, &loc, symstd, sym->name);
+      if (sym->attr.proc == PROC_UNKNOWN)
+       {
+         if (gfc_option.warn_intrinsics_std)
+           gfc_warning_now ("The intrinsic '%s' at %L is not included in the"
+                            " selected standard but %s and '%s' will be"
+                            " treated as if declared EXTERNAL.  Use an"
+                            " appropriate -std=* option or define"
+                            " -fall-intrinsics to allow this intrinsic.",
+                            sym->name, &loc, symstd, sym->name);
+         gfc_add_external (&sym->attr, &loc);
+       }
 
       return false;
     }
@@ -1476,6 +1479,8 @@ add_functions (void)
             gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble,
             a, BT_REAL, dr, REQUIRED);
 
+  make_alias ("dfloat", GFC_STD_GNU);
+
   make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77);
 
   add_sym_1 ("digits", GFC_ISYM_DIGITS, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
@@ -1781,7 +1786,7 @@ 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, gfc_resolve_image_index,
+            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
@@ -1920,12 +1925,12 @@ 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_F2008,
-            gfc_check_lcobound, gfc_simplify_lcobound, gfc_resolve_lcobound,
+            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_F2008);
+  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,
@@ -2291,15 +2296,11 @@ add_functions (void)
             a, BT_UNKNOWN, dr, REQUIRED);
 
   add_sym_1 ("float", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
-            gfc_check_float, gfc_simplify_float, NULL,
+            gfc_check_i, gfc_simplify_float, NULL,
             a, BT_INTEGER, di, REQUIRED);
 
-  add_sym_1 ("dfloat", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
-            gfc_check_float, gfc_simplify_dble, gfc_resolve_dble,
-            a, BT_REAL, dr, REQUIRED);
-
   add_sym_1 ("sngl", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
-            gfc_check_sngl, gfc_simplify_sngl, NULL,
+            NULL, gfc_simplify_sngl, NULL,
             a, BT_REAL, dd, REQUIRED);
 
   make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
@@ -2539,7 +2540,7 @@ 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, gfc_resolve_this_image,
+            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, 
@@ -2599,12 +2600,12 @@ 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_F2008,
-            gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound,
+            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_F2008);
+  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,
@@ -3291,7 +3292,7 @@ keywords:
 
       if (f->actual != NULL)
        {
-         gfc_error ("Argument '%s' appears twice in call to '%s' at %L",
+         gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
                     f->name, name, where);
          return FAILURE;
        }
@@ -3805,7 +3806,7 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
 
   if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE
        || isym->id == GFC_ISYM_CMPLX)
-      && gfc_init_expr_flag
+      && gfc_init_expr
       && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Function '%s' "
                         "as initialization expression at %L", name,
                         &expr->where) == FAILURE)
@@ -3881,7 +3882,7 @@ got_specific:
      (4)   A reference to an elemental standard intrinsic function,
            where each argument is an initialization expression  */
 
-  if (gfc_init_expr_flag && isym->elemental && flag
+  if (gfc_init_expr && isym->elemental && flag
       && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Elemental function "
                        "as initialization expression with non-integer/non-"
                        "character arguments at %L", &expr->where) == FAILURE)
@@ -4015,66 +4016,11 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
 
   /* At this point, a conversion is necessary. A warning may be needed.  */
   if ((gfc_option.warn_std & sym->standard) != 0)
-    {
-      gfc_warning_now ("Extension: Conversion from %s to %s at %L",
-                      gfc_typename (&from_ts), gfc_typename (ts),
-                      &expr->where);
-    }
-  else if (wflag)
-    {
-      /* Two modes of warning:
-         - gfc_option.warn_conversion tries to be more intelligent
-           about the warnings raised and omits those where smaller
-           kinds are promoted to larger ones without change in the
-           value
-         - gfc_option.warn_conversion_extra does not take the kinds
-           into account and also warns for coversions like
-           REAL(4) -> REAL(8)
-
-        NOTE: Possible enhancement for warn_conversion
-        If converting from a smaller to a larger kind, check if the
-        value is constant and if yes, whether the value still fits
-        in the smaller kind. If yes, omit the warning.
-      */
-
-      /* If the types are the same (but not LOGICAL), and if from-kind
-        is larger than to-kind, this may indicate a loss of precision.
-        The same holds for conversions from REAL to COMPLEX.  */
-      if (((from_ts.type == ts->type && from_ts.type != BT_LOGICAL)
-           && ((gfc_option.warn_conversion && from_ts.kind > ts->kind)
-              || gfc_option.warn_conversion_extra))
-         || ((from_ts.type == BT_REAL && ts->type == BT_COMPLEX)
-             && ((gfc_option.warn_conversion && from_ts.kind > ts->kind)
-                 || gfc_option.warn_conversion_extra)))
-       gfc_warning_now ("Possible change of value in conversion "
-                        "from %s to %s at %L", gfc_typename (&from_ts),
-                        gfc_typename (ts), &expr->where);
-
-      /* If INTEGER is converted to REAL/COMPLEX, this is generally ok if
-        the kind of the INTEGER value is less or equal to the kind of the
-        REAL/COMPLEX one. Otherwise the value may not fit.
-        Assignment of an overly large integer constant also generates
-        an overflow error with range checking. */
-      else if (from_ts.type == BT_INTEGER
-              && (ts->type == BT_REAL || ts->type == BT_COMPLEX)
-              && ((gfc_option.warn_conversion && from_ts.kind > ts->kind)
-                  || gfc_option.warn_conversion_extra))
-       gfc_warning_now ("Possible change of value in conversion "
-                        "from %s to %s at %L", gfc_typename (&from_ts),
-                        gfc_typename (ts), &expr->where);
-
-      /* If REAL/COMPLEX is converted to INTEGER, or COMPLEX is converted
-        to REAL we almost certainly have a loss of digits, regardless of
-        the respective kinds.  */
-      else if ((((from_ts.type == BT_REAL || from_ts.type == BT_COMPLEX)
-                 && ts->type == BT_INTEGER)
-               || (from_ts.type == BT_COMPLEX && ts->type == BT_REAL))
-              && (gfc_option.warn_conversion
-                  || gfc_option.warn_conversion_extra))
-       gfc_warning_now ("Possible change of value in conversion from "
-                       "%s to %s at %L", gfc_typename (&from_ts),
-                       gfc_typename (ts), &expr->where);
-    }
+    gfc_warning_now ("Extension: Conversion from %s to %s at %L",
+                    gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
+  else if (wflag && gfc_option.warn_conversion)
+    gfc_warning_now ("Conversion from %s to %s at %L",
+                    gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
 
   /* Insert a pre-resolved function call to the right function.  */
   old_where = expr->where;
index 4439464..63b8b2b 100644 (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
 
 
index ea1134a..44e9f9d 100644 (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;
     }
 
index b909b1c..1838c00 100644 (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);
     }
 }
 
@@ -2921,6 +3048,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)
 {
   unsigned long lz, bs;
@@ -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);
@@ -5174,11 +5323,248 @@ 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)
index 2981f07..913b01a 100644 (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
index 7ec7353..969d491 100644 (file)
@@ -2,7 +2,6 @@
 ! { dg-options "-fcoarray=single -fdump-tree-original" }
 !
 ! PR fortran/18918
-! PR fortran/43919 for boundsTest()
 !
 ! Coarray intrinsics
 !
@@ -53,12 +52,5 @@ 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
 
-subroutine boundsTest()
-  implicit none
-  integer :: a[*] = 7
-  if (any (lcobound(a) /= [1])) call not_existing()
-  if (any (ucobound(a) /= [1])) call not_existing()
-end subroutine boundsTest
-
 ! { dg-final { scan-tree-dump-times "not_existing" 0 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
index d44cdda..cdfb4dc 100644 (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