OSDN Git Service

2012-01-06 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 6 Jan 2012 13:38:49 +0000 (13:38 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 6 Jan 2012 13:38:49 +0000 (13:38 +0000)
        * trans-openmp.c (gfc_omp_clause_dtor,
        * gfc_trans_omp_array_reduction):
        Update call to gfc_trans_dealloc_allocated.
        * trans.c (gfc_allocate_using_malloc): Fix spacing.
        (gfc_allocate_allocatable): For gfc_allocate_using_lib, jump to
        label_finish when an error occurs.
        (gfc_deallocate_with_status): Call caf_deregister for -fcoarray=lib.
        * trans.h (gfc_allocate_allocatable,
        * gfc_deallocate_with_status):
        Update prototype.
        (gfor_fndecl_caf_deregister): New tree symbol.
        * trans-expr.c (gfc_conv_procedure_call): Update
        gfc_deallocate_with_status and gfc_trans_dealloc_allocated calls.
        * trans-array.c (gfc_array_allocate,
        * gfc_trans_dealloc_allocated,
        structure_alloc_comps, gfc_trans_deferred_array): Ditto.
        (gfc_array_deallocate): Handle coarrays with -fcoarray=lib.
        * trans-array.h (gfc_array_deallocate, gfc_array_allocate,
        gfc_trans_dealloc_allocated): Update prototypes.
        * trans-stmt.c (gfc_trans_sync): Fix indentation.
        (gfc_trans_allocate): Fix errmsg padding and label handling.
        (gfc_trans_deallocate): Ditto and handle -fcoarray=lib.
        * expr.c (gfc_is_coarray): Fix algorithm for BT_CLASS.
        * libgfortran.h (GFC_STAT_STOPPED_IMAGE): Use large value
        to avoid other stats accidentally matching this one.
        * trans-decl.c (gfor_fndecl_caf_deregister): New global var.
        (gfc_build_builtin_function_decls): Fix prototype decl of caf_register
        and add decl for caf_deregister.
        (gfc_trans_deferred_vars): Handle CAF vars with -fcoarrays=lib.
        * trans-intrinsic.c (conv_intrinsic_move_alloc): Update call to
        gfc_deallocate_with_status.

2012-01-06  Tobias Burnus <burnus@net-b.de>

        * caf/single.c (_gfortran_caf_register,
        * _gfortran_caf_deregister):
        Fix token handling.
        * caf/mpi.c  (_gfortran_caf_register, _gfortran_caf_deregister):
        * Ditto.
        * caf/libcaf.h (STAT_STOPPED_IMAGE): Sync with libgfortran.h.
        (_gfortran_caf_register, _gfortran_caf_deregister): Update prototype.

2012-01-06  Tobias Burnus <burnus@net-b.de>

        * gfortran.dg/deallocate_stat_2.f90: New.
        * coarray/allocate_errgmsg.f90: New.
        * gfortran.dg/coarray_lib_alloc_1.f90: New.
        * gfortran.dg/coarray_lib_alloc_2.f90: New.
        * coarray/subobject_1.f90: Fix for num_images > 1.
        * gfortran.dg/deallocate_stat.f90: Update due to changed
        stat= handling.

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

23 files changed:
gcc/fortran/ChangeLog
gcc/fortran/expr.c
gcc/fortran/libgfortran.h
gcc/fortran/trans-array.c
gcc/fortran/trans-array.h
gcc/fortran/trans-decl.c
gcc/fortran/trans-expr.c
gcc/fortran/trans-intrinsic.c
gcc/fortran/trans-openmp.c
gcc/fortran/trans-stmt.c
gcc/fortran/trans.c
gcc/fortran/trans.h
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/coarray/subobject_1.f90
gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/deallocate_stat.f90
gcc/testsuite/gfortran.dg/deallocate_stat_2.f90 [new file with mode: 0644]
libgfortran/ChangeLog
libgfortran/caf/libcaf.h
libgfortran/caf/mpi.c
libgfortran/caf/single.c

index 879c564..19f7d7b 100644 (file)
@@ -1,3 +1,34 @@
+2012-01-06  Tobias Burnus <burnus@net-b.de>
+
+       * trans-openmp.c (gfc_omp_clause_dtor, gfc_trans_omp_array_reduction):
+       Update call to gfc_trans_dealloc_allocated.
+       * trans.c (gfc_allocate_using_malloc): Fix spacing.
+       (gfc_allocate_allocatable): For gfc_allocate_using_lib, jump to
+       label_finish when an error occurs.
+       (gfc_deallocate_with_status): Call caf_deregister for -fcoarray=lib.
+       * trans.h (gfc_allocate_allocatable, gfc_deallocate_with_status):
+       Update prototype.
+       (gfor_fndecl_caf_deregister): New tree symbol.
+       * trans-expr.c (gfc_conv_procedure_call): Update
+       gfc_deallocate_with_status and gfc_trans_dealloc_allocated calls.
+       * trans-array.c (gfc_array_allocate, gfc_trans_dealloc_allocated,
+       structure_alloc_comps, gfc_trans_deferred_array): Ditto.
+       (gfc_array_deallocate): Handle coarrays with -fcoarray=lib.
+       * trans-array.h (gfc_array_deallocate, gfc_array_allocate,
+       gfc_trans_dealloc_allocated): Update prototypes.
+       * trans-stmt.c (gfc_trans_sync): Fix indentation.
+       (gfc_trans_allocate): Fix errmsg padding and label handling.
+       (gfc_trans_deallocate): Ditto and handle -fcoarray=lib.
+       * expr.c (gfc_is_coarray): Fix algorithm for BT_CLASS.
+       * libgfortran.h (GFC_STAT_STOPPED_IMAGE): Use large value
+       to avoid other stats accidentally matching this one.
+       * trans-decl.c (gfor_fndecl_caf_deregister): New global var.
+       (gfc_build_builtin_function_decls): Fix prototype decl of caf_register
+       and add decl for caf_deregister.
+       (gfc_trans_deferred_vars): Handle CAF vars with -fcoarrays=lib.
+       * trans-intrinsic.c (conv_intrinsic_move_alloc): Update call to
+       gfc_deallocate_with_status.
+
 2012-01-05  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/PR48946
index 182738c..a6baa68 100644 (file)
@@ -1,6 +1,6 @@
 /* Routines for manipulation of expression nodes.
    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-   2009, 2010, 2011
+   2009, 2010, 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -4264,13 +4264,17 @@ gfc_is_coarray (gfc_expr *e)
     {
       case REF_COMPONENT:
        comp = ref->u.c.component;
-        if (comp->attr.pointer || comp->attr.allocatable)
+       if (comp->ts.type == BT_CLASS && comp->attr.class_ok
+           && (CLASS_DATA (comp)->attr.class_pointer
+               || CLASS_DATA (comp)->attr.allocatable))
          {
            coindexed = false;
-           if (comp->ts.type == BT_CLASS && comp->attr.class_ok)
-             coarray = CLASS_DATA (comp)->attr.codimension;
-           else
-             coarray = comp->attr.codimension;
+           coarray = CLASS_DATA (comp)->attr.codimension;
+         }
+        else if (comp->attr.pointer || comp->attr.allocatable)
+         {
+           coindexed = false;
+           coarray = comp->attr.codimension;
          }
         break;
 
index 874cd95..3f36fe8 100644 (file)
@@ -1,5 +1,5 @@
 /* Header file to the Fortran front-end and runtime library
-   Copyright (C) 2007, 2008, 2009, 2010, 2011
+   Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012
    Free Software Foundation, Inc.
 
 This file is part of GCC.
@@ -105,7 +105,7 @@ typedef enum
   GFC_STAT_UNLOCKED = 0,
   GFC_STAT_LOCKED,
   GFC_STAT_LOCKED_OTHER_IMAGE,
-  GFC_STAT_STOPPED_IMAGE /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */
+  GFC_STAT_STOPPED_IMAGE = 6000 /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */
 }
 libgfortran_stat_codes;
 
index 494721e..b9902b9 100644 (file)
@@ -4938,7 +4938,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
 bool
 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
-                   tree errlen, gfc_expr *expr3)
+                   tree errlen, tree label_finish, gfc_expr *expr3)
 {
   tree tmp;
   tree pointer;
@@ -5064,7 +5064,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   /* The allocatable variant takes the old pointer as first argument.  */
   if (allocatable)
     gfc_allocate_allocatable (&elseblock, pointer, size, token,
-                             status, errmsg, errlen, expr);
+                             status, errmsg, errlen, label_finish, expr);
   else
     gfc_allocate_using_malloc (&elseblock, pointer, size, status);
 
@@ -5127,24 +5127,40 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 /*GCC ARRAYS*/
 
 tree
-gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
+gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
+                     tree label_finish, gfc_expr* expr)
 {
   tree var;
   tree tmp;
   stmtblock_t block;
+  bool coarray = gfc_is_coarray (expr);
 
   gfc_start_block (&block);
+
   /* Get a pointer to the data.  */
   var = gfc_conv_descriptor_data_get (descriptor);
   STRIP_NOPS (var);
 
   /* Parameter is the address of the data component.  */
-  tmp = gfc_deallocate_with_status (var, pstat, false, expr);
+  tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg,
+                                   errlen, label_finish, false, expr, coarray);
   gfc_add_expr_to_block (&block, tmp);
 
-  /* Zero the data pointer.  */
+  /* Zero the data pointer; only for coarrays an error can occur and then
+     the allocation status may not be changed.  */
   tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
                         var, build_int_cst (TREE_TYPE (var), 0));
+  if (pstat != NULL_TREE && coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      tree cond;
+      tree stat = build_fold_indirect_ref_loc (input_location, pstat);
+
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+                             stat, build_int_cst (TREE_TYPE (stat), 0));
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+                            cond, tmp, build_empty_stmt (input_location));
+    }
+
   gfc_add_expr_to_block (&block, tmp);
 
   return gfc_finish_block (&block);
@@ -7055,7 +7071,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
 /* Generate code to deallocate an array, if it is allocated.  */
 
 tree
-gfc_trans_dealloc_allocated (tree descriptor)
+gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
 { 
   tree tmp;
   tree var;
@@ -7069,7 +7085,9 @@ gfc_trans_dealloc_allocated (tree descriptor)
   /* Call array_deallocate with an int * present in the second argument.
      Although it is ignored here, it's presence ensures that arrays that
      are already deallocated are ignored.  */
-  tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
+  tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
+                                   NULL_TREE, NULL_TREE, NULL_TREE, true,
+                                   NULL, coarray);
   gfc_add_expr_to_block (&block, tmp);
 
   /* Zero the data pointer.  */
@@ -7358,7 +7376,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
            {
              comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
                                      decl, cdecl, NULL_TREE);
-             tmp = gfc_trans_dealloc_allocated (comp);
+             tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension);
              gfc_add_expr_to_block (&fnblock, tmp);
            }
          else if (c->attr.allocatable)
@@ -7388,7 +7406,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
                                      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
 
              if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
-               tmp = gfc_trans_dealloc_allocated (comp);
+               tmp = gfc_trans_dealloc_allocated (comp,
+                                       CLASS_DATA (c)->attr.codimension);
              else
                {
                  tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
@@ -8094,7 +8113,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
   if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
       && !sym->attr.save && !sym->attr.result)
     {
-      tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
+      tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
+                                        sym->attr.codimension);
       gfc_add_expr_to_block (&cleanup, tmp);
     }
 
index 19cfac5..ed922d0 100644 (file)
@@ -1,5 +1,5 @@
 /* Header for array handling functions
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook
 
@@ -20,11 +20,12 @@ along with GCC; see the file COPYING3.  If not see
 <http://www.gnu.org/licenses/>.  */
 
 /* Generate code to free an array.  */
-tree gfc_array_deallocate (tree, tree, gfc_expr*);
+tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*);
 
 /* Generate code to initialize and allocate an array.  Statements are added to
    se, which should contain an expression for the array descriptor.  */
-bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, gfc_expr *);
+bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
+                        gfc_expr *);
 
 /* Allow the bounds of a loop to be set from a callee's array spec.  */
 void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
@@ -42,7 +43,7 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *);
 /* Generate entry and exit code for g77 calling convention arrays.  */
 void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
 /* Generate code to deallocate an array, if it is allocated.  */
-tree gfc_trans_dealloc_allocated (tree);
+tree gfc_trans_dealloc_allocated (tree, bool);
 
 tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);
 
index 14332f6..0761ebb 100644 (file)
@@ -1,6 +1,6 @@
 /* Backend function setup
    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-   2011
+   2011, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook
 
@@ -121,6 +121,7 @@ tree gfor_fndecl_associated;
 tree gfor_fndecl_caf_init;
 tree gfor_fndecl_caf_finalize;
 tree gfor_fndecl_caf_register;
+tree gfor_fndecl_caf_deregister;
 tree gfor_fndecl_caf_critical;
 tree gfor_fndecl_caf_end_critical;
 tree gfor_fndecl_caf_sync_all;
@@ -3163,7 +3164,11 @@ gfc_build_builtin_function_decls (void)
       gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
        get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6,
         size_type_node, integer_type_node, ppvoid_type_node, pint_type,
-        build_pointer_type (pchar_type_node), integer_type_node);
+        pchar_type_node, integer_type_node);
+
+      gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
+       get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4,
+        ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
 
       gfor_fndecl_caf_critical = gfc_build_library_function_decl (
        get_identifier (PREFIX("caf_critical")), void_type_node, 0);
@@ -3688,6 +3693,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
        {
          if (!sym->attr.save)
            {
+             tree descriptor = NULL_TREE;
+
              /* Nullify and automatic deallocation of allocatable
                 scalars.  */
              e = gfc_lval_expr_from_sym (sym);
@@ -3712,6 +3719,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
              else
                {
                  gfc_conv_expr (&se, e);
+                 descriptor = se.expr;
                  se.expr = gfc_conv_descriptor_data_addr (se.expr);
                  se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
                }
@@ -3761,9 +3769,18 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
              /* Deallocate when leaving the scope. Nullifying is not
                 needed.  */
              if (!sym->attr.result && !sym->attr.dummy)
-               tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
-                                                        NULL, sym->ts);
-
+               {
+                 if (sym->ts.type == BT_CLASS
+                     && CLASS_DATA (sym)->attr.codimension)
+                   tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
+                                                     NULL_TREE, NULL_TREE,
+                                                     NULL_TREE, true, NULL,
+                                                     true);
+                 else
+                   tmp = gfc_deallocate_scalar_with_status (se.expr, NULL,
+                                                            true, NULL,
+                                                            sym->ts);
+               }
              if (sym->ts.type == BT_CLASS)
                {
                  /* Initialize _vptr to declared type.  */
index 54572fb..14411e0 100644 (file)
@@ -3525,7 +3525,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
                      gfc_init_block  (&block);
                      tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
-                                                       true, NULL);
+                                                       NULL_TREE, NULL_TREE,
+                                                       NULL_TREE, true, NULL,
+                                                       false);
                      gfc_add_expr_to_block (&block, tmp);
                      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
                                             void_type_node, parmse.expr,
@@ -3665,7 +3667,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                {
                  tmp = build_fold_indirect_ref_loc (input_location,
                                                     parmse.expr);
-                 tmp = gfc_trans_dealloc_allocated (tmp);
+                 tmp = gfc_trans_dealloc_allocated (tmp, false);
                  if (fsym->attr.optional
                      && e->expr_type == EXPR_VARIABLE
                      && e->symtree->n.sym->attr.optional)
@@ -4335,7 +4337,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
          /* Finally free the temporary's data field.  */
          tmp = gfc_conv_descriptor_data_get (tmp2);
-         tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
+         tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
+                                           NULL_TREE, NULL_TREE, true,
+                                           NULL, false);
          gfc_add_expr_to_block (&se->pre, tmp);
        }
     }
index 0caa59d..cb74273 100644 (file)
@@ -1,5 +1,6 @@
 /* Intrinsic translation
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+   2011, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -7355,7 +7356,8 @@ conv_intrinsic_move_alloc (gfc_code *code)
   gfc_conv_expr_descriptor (&from_se, from_expr, from_ss);
 
   tmp = gfc_conv_descriptor_data_get (to_se.expr);
-  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, to_expr);
+  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
+                                   NULL_TREE, true, to_expr, false);
   gfc_add_expr_to_block (&block, tmp);
 
   /* Move the pointer and update the array descriptor data.  */
index a41e97b..f8b3e22 100644 (file)
@@ -1,5 +1,5 @@
 /* OpenMP directive translation -- generate GCC trees from gfc_code.
-   Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011
+   Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Jakub Jelinek <jakub@redhat.com>
 
@@ -326,7 +326,7 @@ gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
 
   /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
      to be deallocated if they were allocated.  */
-  return gfc_trans_dealloc_allocated (decl);
+  return gfc_trans_dealloc_allocated (decl, false);
 }
 
 
@@ -708,7 +708,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
       gfc_start_block (&block);
       gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false,
                             true));
-      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
+      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false));
       stmt = gfc_finish_block (&block);
     }
   else
index 92f7f43..9456e2d 100644 (file)
@@ -1,6 +1,6 @@
 /* Statement translation -- generate GCC trees from gfc_code.
    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-   2011
+   2011, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -755,8 +755,8 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
    if (gfc_option.coarray == GFC_FCOARRAY_LIB)
      {
        tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
-       tmp = build_call_expr_loc (input_location, tmp, 0);
-       gfc_add_expr_to_block (&se.pre, tmp);
+       tmp = build_call_expr_loc (input_location, tmp, 0);
+       gfc_add_expr_to_block (&se.pre, tmp);
      }
 
   if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY)
@@ -4738,10 +4738,10 @@ gfc_trans_allocate (gfc_code * code)
       if (code->expr2)
        {
          gfc_init_se (&se, NULL);
+         se.want_pointer = 1;
          gfc_conv_expr_lhs (&se, code->expr2);
-
-         errlen = gfc_get_expr_charlen (code->expr2);
-         errmsg = gfc_build_addr_expr (pchar_type_node, se.expr);
+         errmsg = se.expr;
+         errlen = se.string_length;
        }
       else
        {
@@ -4752,8 +4752,7 @@ gfc_trans_allocate (gfc_code * code)
       /* GOTO destinations.  */
       label_errmsg = gfc_build_label_decl (NULL_TREE);
       label_finish = gfc_build_label_decl (NULL_TREE);
-      TREE_USED (label_errmsg) = 1;
-      TREE_USED (label_finish) = 1;
+      TREE_USED (label_finish) = 0;
     }
 
   expr3 = NULL_TREE;
@@ -4772,7 +4771,8 @@ gfc_trans_allocate (gfc_code * code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
-      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, code->expr3))
+      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
+                              code->expr3))
        {
          /* A scalar or derived type.  */
 
@@ -4892,7 +4892,7 @@ gfc_trans_allocate (gfc_code * code)
          /* Allocate - for non-pointers with re-alloc checking.  */
          if (gfc_expr_attr (expr).allocatable)
            gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
-                                     stat, errmsg, errlen, expr);
+                                     stat, errmsg, errlen, label_finish, expr);
          else
            gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
 
@@ -4919,18 +4919,12 @@ gfc_trans_allocate (gfc_code * code)
       /* Error checking -- Note: ERRMSG only makes sense with STAT.  */
       if (code->expr1)
        {
-         /* The coarray library already sets the errmsg.  */
-         if (gfc_option.coarray == GFC_FCOARRAY_LIB
-             && gfc_expr_attr (expr).codimension)
-           tmp = build1_v (GOTO_EXPR, label_finish);
-         else
-           tmp = build1_v (GOTO_EXPR, label_errmsg);
-
+         tmp = build1_v (GOTO_EXPR, label_errmsg);
          parm = fold_build2_loc (input_location, NE_EXPR,
                                  boolean_type_node, stat,
                                  build_int_cst (TREE_TYPE (stat), 0));
          tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
-                                gfc_unlikely(parm), tmp,
+                                gfc_unlikely (parm), tmp,
                                     build_empty_stmt (input_location));
          gfc_add_expr_to_block (&block, tmp);
        }
@@ -5102,26 +5096,24 @@ gfc_trans_allocate (gfc_code * code)
       gfc_free_expr (expr);
     }
 
-  /* STAT  (ERRMSG only makes sense with STAT).  */
+  /* STAT.  */
   if (code->expr1)
     {
       tmp = build1_v (LABEL_EXPR, label_errmsg);
       gfc_add_expr_to_block (&block, tmp);
     }
 
-  /* ERRMSG block.  */
-  if (code->expr2)
+  /* ERRMSG - only useful if STAT is present.  */
+  if (code->expr1 && code->expr2)
     {
-      /* A better error message may be possible, but not required.  */
       const char *msg = "Attempt to allocate an allocated object";
-      tree slen, dlen;
+      tree slen, dlen, errmsg_str;
+      stmtblock_t errmsg_block;
 
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr_lhs (&se, code->expr2);
+      gfc_init_block (&errmsg_block);
 
-      errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
-
-      gfc_add_modify (&block, errmsg,
+      errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
+      gfc_add_modify (&errmsg_block, errmsg_str,
                gfc_build_addr_expr (pchar_type_node,
                        gfc_build_localized_cstring_const (msg)));
 
@@ -5130,9 +5122,9 @@ gfc_trans_allocate (gfc_code * code)
       slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
                              slen);
 
-      dlen = build_call_expr_loc (input_location,
-                                 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
-               gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+      gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
+                            slen, errmsg_str, gfc_default_character_kind);
+      dlen = gfc_finish_block (&errmsg_block);
 
       tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
                             build_int_cst (TREE_TYPE (stat), 0));
@@ -5142,16 +5134,15 @@ gfc_trans_allocate (gfc_code * code)
       gfc_add_expr_to_block (&block, tmp);
     }
 
-  /* STAT  (ERRMSG only makes sense with STAT).  */
-  if (code->expr1)
-    {
-      tmp = build1_v (LABEL_EXPR, label_finish);
-      gfc_add_expr_to_block (&block, tmp);
-    }
-
   /* STAT block.  */
   if (code->expr1)
     {
+      if (TREE_USED (label_finish))
+       {
+         tmp = build1_v (LABEL_EXPR, label_finish);
+         gfc_add_expr_to_block (&block, tmp);
+       }
+
       gfc_init_se (&se, NULL);
       gfc_conv_expr_lhs (&se, code->expr1);
       tmp = convert (TREE_TYPE (se.expr), stat);
@@ -5172,29 +5163,39 @@ gfc_trans_deallocate (gfc_code *code)
 {
   gfc_se se;
   gfc_alloc *al;
-  tree apstat, astat, pstat, stat, tmp;
+  tree apstat, pstat, stat, errmsg, errlen, tmp;
+  tree label_finish, label_errmsg;
   stmtblock_t block;
 
-  pstat = apstat = stat = astat = tmp = NULL_TREE;
+  pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
+  label_finish = label_errmsg = NULL_TREE;
 
   gfc_start_block (&block);
 
   /* Count the number of failed deallocations.  If deallocate() was
      called with STAT= , then set STAT to the count.  If deallocate
      was called with ERRMSG, then set ERRMG to a string.  */
-  if (code->expr1 || code->expr2)
+  if (code->expr1)
     {
       tree gfc_int4_type_node = gfc_get_int_type (4);
 
       stat = gfc_create_var (gfc_int4_type_node, "stat");
       pstat = gfc_build_addr_expr (NULL_TREE, stat);
 
-      /* Running total of possible deallocation failures.  */
-      astat = gfc_create_var (gfc_int4_type_node, "astat");
-      apstat = gfc_build_addr_expr (NULL_TREE, astat);
+      /* GOTO destinations.  */
+      label_errmsg = gfc_build_label_decl (NULL_TREE);
+      label_finish = gfc_build_label_decl (NULL_TREE);
+      TREE_USED (label_finish) = 0;
+    }
 
-      /* Initialize astat to 0.  */
-      gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
+  /* Set ERRMSG - only needed if STAT is available.  */
+  if (code->expr1 && code->expr2)
+    {
+      gfc_init_se (&se, NULL);
+      se.want_pointer = 1;
+      gfc_conv_expr_lhs (&se, code->expr2);
+      errmsg = se.expr;
+      errlen = se.string_length;
     }
 
   for (al = code->ext.alloc.list; al != NULL; al = al->next)
@@ -5212,7 +5213,7 @@ gfc_trans_deallocate (gfc_code *code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
-      if (expr->rank || gfc_expr_attr (expr).codimension)
+      if (expr->rank || gfc_is_coarray (expr))
        {
          if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
            {
@@ -5232,7 +5233,8 @@ gfc_trans_deallocate (gfc_code *code)
                  gfc_add_expr_to_block (&se.pre, tmp);
                }
            }
-         tmp = gfc_array_deallocate (se.expr, pstat, expr);
+         tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
+                                     label_finish, expr);
          gfc_add_expr_to_block (&se.pre, tmp);
        }
       else
@@ -5261,13 +5263,17 @@ gfc_trans_deallocate (gfc_code *code)
            }
        }
 
-      /* Keep track of the number of failed deallocations by adding stat
-        of the last deallocation to the running total.  */
-      if (code->expr1 || code->expr2)
+      if (code->expr1)
        {
-         apstat = fold_build2_loc (input_location, PLUS_EXPR,
-                                   TREE_TYPE (stat), astat, stat);
-         gfc_add_modify (&se.pre, astat, apstat);
+          tree cond;
+
+         cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
+                                 build_int_cst (TREE_TYPE (stat), 0));
+         tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+                                gfc_unlikely (cond),
+                                build1_v (GOTO_EXPR, label_errmsg),
+                                build_empty_stmt (input_location));
+         gfc_add_expr_to_block (&se.pre, tmp);
        }
 
       tmp = gfc_finish_block (&se.pre);
@@ -5275,48 +5281,56 @@ gfc_trans_deallocate (gfc_code *code)
       gfc_free_expr (expr);
     }
 
-  /* Set STAT.  */
   if (code->expr1)
     {
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr_lhs (&se, code->expr1);
-      tmp = convert (TREE_TYPE (se.expr), astat);
-      gfc_add_modify (&block, se.expr, tmp);
+      tmp = build1_v (LABEL_EXPR, label_errmsg);
+      gfc_add_expr_to_block (&block, tmp);
     }
 
-  /* Set ERRMSG.  */
-  if (code->expr2)
+  /* Set ERRMSG - only needed if STAT is available.  */
+  if (code->expr1 && code->expr2)
     {
-      /* A better error message may be possible, but not required.  */
       const char *msg = "Attempt to deallocate an unallocated object";
-      tree errmsg, slen, dlen;
+      stmtblock_t errmsg_block;
+      tree errmsg_str, slen, dlen, cond;
 
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr_lhs (&se, code->expr2);
+      gfc_init_block (&errmsg_block);
 
-      errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
-
-      gfc_add_modify (&block, errmsg,
+      errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
+      gfc_add_modify (&errmsg_block, errmsg_str,
                gfc_build_addr_expr (pchar_type_node,
                         gfc_build_localized_cstring_const (msg)));
-
       slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
       dlen = gfc_get_expr_charlen (code->expr2);
-      slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
-                             slen);
 
-      dlen = build_call_expr_loc (input_location,
-                                 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
-               gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+      gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
+                            slen, errmsg_str, gfc_default_character_kind);
+      tmp = gfc_finish_block (&errmsg_block);
 
-      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, astat,
-                            build_int_cst (TREE_TYPE (astat), 0));
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
+                            build_int_cst (TREE_TYPE (stat), 0));
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+                            gfc_unlikely (cond), tmp,
+                            build_empty_stmt (input_location));
 
-      tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tmp);
+    }
 
+  if (code->expr1 && TREE_USED (label_finish))
+    {
+      tmp = build1_v (LABEL_EXPR, label_finish);
       gfc_add_expr_to_block (&block, tmp);
     }
 
+  /* Set STAT.  */
+  if (code->expr1)
+    {
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_lhs (&se, code->expr1);
+      tmp = convert (TREE_TYPE (se.expr), stat);
+      gfc_add_modify (&block, se.expr, tmp);
+    }
+
   return gfc_finish_block (&block);
 }
 
index 085f58f..8075dbc 100644 (file)
@@ -1,5 +1,5 @@
 /* Code translation -- generate GCC trees from gfc_code.
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook
 
@@ -653,7 +653,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
                                boolean_type_node, pointer,
                                build_int_cst (prvoid_type_node, 0));
   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
-                        gfc_unlikely(error_cond), on_error,
+                        gfc_unlikely (error_cond), on_error,
                         build_empty_stmt (input_location));
 
   gfc_add_expr_to_block (block, tmp);
@@ -738,7 +738,8 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
     and variable name in case a runtime error has to be printed.  */
 void
 gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
-                         tree status, tree errmsg, tree errlen, gfc_expr* expr)
+                         tree status, tree errmsg, tree errlen, tree label_finish,
+                         gfc_expr* expr)
 {
   stmtblock_t alloc_block;
   tree tmp, null_mem, alloc, error;
@@ -757,8 +758,23 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
 
   if (gfc_option.coarray == GFC_FCOARRAY_LIB
       && gfc_expr_attr (expr).codimension)
-    gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
-                           errmsg, errlen);
+    {
+      tree cond;
+
+      gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
+                             errmsg, errlen);
+      if (status != NULL_TREE)
+       {
+         TREE_USED (label_finish) = 1;
+         tmp = build1_v (GOTO_EXPR, label_finish);
+         cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                                 status, build_zero_cst (TREE_TYPE (status)));
+         tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+                                gfc_unlikely (cond), tmp,
+                                build_empty_stmt (input_location));
+         gfc_add_expr_to_block (&alloc_block, tmp);
+       }
+    }
   else
     gfc_allocate_using_malloc (&alloc_block, mem, size, status);
 
@@ -852,13 +868,27 @@ gfc_call_free (tree var)
    each procedure).
    
    If a runtime-message is possible, `expr' must point to the original
-   expression being deallocated for its locus and variable name.  */
+   expression being deallocated for its locus and variable name.
+
+   For coarrays, "pointer" must be the array descriptor and not its
+   "data" component.  */
 tree
-gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
-                           gfc_expr* expr)
+gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
+                           tree errlen, tree label_finish,
+                           bool can_fail, gfc_expr* expr, bool coarray)
 {
   stmtblock_t null, non_null;
   tree cond, tmp, error;
+  tree status_type = NULL_TREE;
+  tree caf_decl = NULL_TREE;
+
+  if (coarray)
+    {
+      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
+      caf_decl = pointer;
+      pointer = gfc_conv_descriptor_data_get (caf_decl);
+      STRIP_NOPS (pointer);
+    }
 
   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
                          build_int_cst (TREE_TYPE (pointer), 0));
@@ -884,9 +914,9 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
 
   if (status != NULL_TREE && !integer_zerop (status))
     {
-      tree status_type = TREE_TYPE (TREE_TYPE (status));
       tree cond2;
 
+      status_type = TREE_TYPE (TREE_TYPE (status));
       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
                               status, build_int_cst (TREE_TYPE (status), 0));
       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
@@ -901,26 +931,90 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
 
   /* When POINTER is not NULL, we free it.  */
   gfc_start_block (&non_null);
-  tmp = build_call_expr_loc (input_location,
-                            builtin_decl_explicit (BUILT_IN_FREE), 1,
-                            fold_convert (pvoid_type_node, pointer));
-  gfc_add_expr_to_block (&non_null, tmp);
+  if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
+    {
+      tmp = build_call_expr_loc (input_location,
+                                builtin_decl_explicit (BUILT_IN_FREE), 1,
+                                fold_convert (pvoid_type_node, pointer));
+      gfc_add_expr_to_block (&non_null, tmp);
 
-  if (status != NULL_TREE && !integer_zerop (status))
+      if (status != NULL_TREE && !integer_zerop (status))
+       {
+         /* We set STATUS to zero if it is present.  */
+         tree status_type = TREE_TYPE (TREE_TYPE (status));
+         tree cond2;
+
+         cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                                  status,
+                                  build_int_cst (TREE_TYPE (status), 0));
+         tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+                                fold_build1_loc (input_location, INDIRECT_REF,
+                                                 status_type, status),
+                                build_int_cst (status_type, 0));
+         tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+                                gfc_unlikely (cond2), tmp,
+                                build_empty_stmt (input_location));
+         gfc_add_expr_to_block (&non_null, tmp);
+       }
+    }
+  else
     {
-      /* We set STATUS to zero if it is present.  */
-      tree status_type = TREE_TYPE (TREE_TYPE (status));
-      tree cond2;
+      tree caf_type, token, cond2;
+      tree pstat = null_pointer_node;
 
-      cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
-                              status, build_int_cst (TREE_TYPE (status), 0));
-      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
-                            fold_build1_loc (input_location, INDIRECT_REF,
-                                             status_type, status),
-                            build_int_cst (status_type, 0));
-      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
-                            tmp, build_empty_stmt (input_location));
+      if (errmsg == NULL_TREE)
+       {
+         gcc_assert (errlen == NULL_TREE);
+         errmsg = null_pointer_node;
+         errlen = build_zero_cst (integer_type_node);
+       }
+      else
+       {
+         gcc_assert (errlen != NULL_TREE);
+         if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
+           errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
+       }
+
+      caf_type = TREE_TYPE (caf_decl);
+
+      if (status != NULL_TREE && !integer_zerop (status))
+       {
+         gcc_assert (status_type == integer_type_node);
+         pstat = status;
+       }
+
+      if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+         && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+       token = gfc_conv_descriptor_token (caf_decl);
+      else if (DECL_LANG_SPECIFIC (caf_decl)
+              && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+       token = GFC_DECL_TOKEN (caf_decl);
+      else
+       {
+         gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+                     && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
+         token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+       }
+
+      token = gfc_build_addr_expr  (NULL_TREE, token);
+      tmp = build_call_expr_loc (input_location,
+            gfor_fndecl_caf_deregister, 4,
+            token, pstat, errmsg, errlen);
       gfc_add_expr_to_block (&non_null, tmp);
+
+      if (status != NULL_TREE)
+       {
+         tree stat = build_fold_indirect_ref_loc (input_location, status);
+
+         TREE_USED (label_finish) = 1;
+         tmp = build1_v (GOTO_EXPR, label_finish);
+         cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                                  stat, build_zero_cst (TREE_TYPE (stat)));
+         tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+                                gfc_unlikely (cond2), tmp,
+                                build_empty_stmt (input_location));
+         gfc_add_expr_to_block (&non_null, tmp);
+       }
     }
 
   return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
index 61a4817..b7c25b3 100644 (file)
@@ -1,5 +1,6 @@
 /* Header for code translation functions
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+   2011, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook
 
@@ -587,14 +588,15 @@ tree gfc_call_malloc (stmtblock_t *, tree, tree);
 tree gfc_build_memcpy_call (tree, tree, tree);
 
 /* Allocate memory for allocatable variables, with optional status variable.  */
-void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree,
+void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, tree,
                               tree, tree, tree, gfc_expr*);
 
 /* Allocate memory, with optional status variable.  */
 void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree);
 
 /* Generate code to deallocate an array.  */
-tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);
+tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool,
+                                gfc_expr *, bool);
 tree gfc_deallocate_scalar_with_status (tree, tree, bool, gfc_expr*, gfc_typespec);
 
 /* Generate code to call realloc().  */
@@ -676,6 +678,7 @@ extern GTY(()) tree gfor_fndecl_associated;
 extern GTY(()) tree gfor_fndecl_caf_init;
 extern GTY(()) tree gfor_fndecl_caf_finalize;
 extern GTY(()) tree gfor_fndecl_caf_register;
+extern GTY(()) tree gfor_fndecl_caf_deregister;
 extern GTY(()) tree gfor_fndecl_caf_critical;
 extern GTY(()) tree gfor_fndecl_caf_end_critical;
 extern GTY(()) tree gfor_fndecl_caf_sync_all;
index d503014..aeef955 100644 (file)
@@ -1,3 +1,13 @@
+2012-01-06  Tobias Burnus <burnus@net-b.de>
+
+       * gfortran.dg/deallocate_stat_2.f90: New.
+       * coarray/allocate_errgmsg.f90: New.
+       * gfortran.dg/coarray_lib_alloc_1.f90: New.
+       * gfortran.dg/coarray_lib_alloc_2.f90: New.
+       * coarray/subobject_1.f90: Fix for num_images > 1.
+       * gfortran.dg/deallocate_stat.f90: Update due to changed
+       stat= handling.
+
 2012-01-06  Andrew Stubbs  <ams@codesourcery.com>
 
        * gcc.target/arm/headmerge-2.c: Adjust scan pattern.
diff --git a/gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90 b/gcc/testsuite/gfortran.dg/coarray/allocate_errgmsg.f90
new file mode 100644 (file)
index 0000000..e5a1954
--- /dev/null
@@ -0,0 +1,36 @@
+! { dg-do run }
+!
+! Check handling of errmsg.
+!
+implicit none
+integer, allocatable :: a[:], b(:)[:], c, d(:)
+integer :: stat
+character(len=300) :: str
+
+allocate(a[*], b(1)[*], c, d(2), stat=stat)
+
+str = repeat('X', len(str))
+allocate(a[*], stat=stat, errmsg=str)
+!print *, stat, trim(str)
+if (stat == 0 .or. str /= "Attempt to allocate an allocated object") &
+  call abort ()
+
+str = repeat('Y', len(str))
+allocate(b(2)[*], stat=stat, errmsg=str)
+!print *, stat, trim(str)
+if (stat == 0 .or. str /= "Attempt to allocate an allocated object") &
+  call abort ()
+
+str = repeat('Q', len(str))
+allocate(c, stat=stat, errmsg=str)
+!print *, stat, trim(str)
+if (stat == 0 .or. str /= "Attempt to allocate an allocated object") &
+  call abort ()
+
+str = repeat('P', len(str))
+allocate(d(3), stat=stat, errmsg=str)
+!print *, stat, trim(str)
+if (stat == 0 .or. str /= "Attempt to allocate an allocated object") &
+  call abort ()
+
+end
index 0253686..028c24a 100644 (file)
   b%a%i = 7
   if (b%a%i /= 7) call abort
   if (any (lcobound(b%a) /= (/ lb /))) call abort
-  if (ucobound(b%a, dim=1) /= this_image() + lb - 1) call abort
+  if (ucobound(b%a, dim=1) /= num_images() + lb - 1) call abort
   if (any (lcobound(b%a%i) /= (/ lb /))) call abort
-  if (ucobound(b%a%i, dim=1) /= this_image() + lb - 1) call abort
+  if (ucobound(b%a%i, dim=1) /= num_images() + lb - 1) call abort
   allocate(c%a(la)[lc:*])
   c%a%i = init
   if (any(c%a%i /= init)) call abort
   if (any (lcobound(c%a) /= (/ lc /))) call abort
-  if (ucobound(c%a, dim=1) /= this_image() + lc - 1) call abort
+  if (ucobound(c%a, dim=1) /= num_images() + lc - 1) call abort
   if (any (lcobound(c%a%i) /= (/ lc /))) call abort
-  if (ucobound(c%a%i, dim=1) /= this_image() + lc - 1) call abort
+  if (ucobound(c%a%i, dim=1) /= num_images() + lc - 1) call abort
   if (c%a(2)%i /= init(2)) call abort
   if (any (lcobound(c%a(2)) /= (/ lc /))) call abort
-  if (ucobound(c%a(2), dim=1) /= this_image() + lc - 1) call abort
+  if (ucobound(c%a(2), dim=1) /= num_images() + lc - 1) call abort
   if (any (lcobound(c%a(2)%i) /= (/ lc /))) call abort
-  if (ucobound(c%a(2)%i, dim=1) /= this_image() + lc - 1) call abort
+  if (ucobound(c%a(2)%i, dim=1) /= num_images() + lc - 1) call abort
   deallocate(b%a, c%a)
 end
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_1.f90
new file mode 100644 (file)
index 0000000..c0d06a4
--- /dev/null
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Allocate/deallocate with libcaf.
+!
+
+ integer(4), allocatable :: xx[:], yy(:)[:]
+ integer :: stat
+ character(len=200) :: errmsg
+ allocate(xx[*], stat=stat, errmsg=errmsg)
+ allocate(yy(2)[*], stat=stat, errmsg=errmsg)
+ deallocate(xx,yy,stat=stat, errmsg=errmsg)
+ end
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register .4, 1, &xx.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register .8, 1, &yy.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_2.f90
new file mode 100644 (file)
index 0000000..3aaff1e
--- /dev/null
@@ -0,0 +1,23 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Allocate/deallocate with libcaf.
+!
+
+ type t
+ end type t
+ class(t), allocatable :: xx[:], yy(:)[:]
+ integer :: stat
+ character(len=200) :: errmsg
+ allocate(xx[*], stat=stat, errmsg=errmsg)
+ allocate(yy(2)[*], stat=stat, errmsg=errmsg)
+ deallocate(xx,yy,stat=stat, errmsg=errmsg)
+ end
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register .1, 1, &yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, &stat.., &errmsg, 200.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0B, 0B, 0.;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
index b691f21..b2ba95c 100644 (file)
@@ -69,9 +69,9 @@ program deallocate_stat
    i = 13
    deallocate(a1, stat=i) ;         if (i /= 0) call abort
    deallocate(a2, a1, stat=i) ;     if (i /= 1) call abort
-   deallocate(a1, a3, a2, stat=i) ; if (i /= 2) call abort
+   deallocate(a1, a3, a2, stat=i) ; if (i /= 1) call abort
    deallocate(b4, stat=i) ;         if (i /= 0) call abort
    deallocate(b4, b5, stat=i) ;     if (i /= 1) call abort
-   deallocate(b4, b5, b6, stat=i) ; if (i /= 2) call abort
+   deallocate(b4, b5, b6, stat=i) ; if (i /= 1) call abort
 
 end program deallocate_stat
diff --git a/gcc/testsuite/gfortran.dg/deallocate_stat_2.f90 b/gcc/testsuite/gfortran.dg/deallocate_stat_2.f90
new file mode 100644 (file)
index 0000000..e93f446
--- /dev/null
@@ -0,0 +1,30 @@
+! { dg-do run }
+!
+! Check that the error is properly diagnosed and the strings are correctly padded.
+!
+integer, allocatable :: A, B(:)
+integer :: stat
+character(len=5) :: sstr
+character(len=200) :: str
+
+str = repeat('X', len(str))
+deallocate(a, stat=stat, errmsg=str)
+!print *, stat, trim(str)
+if (stat == 0 .or. str /= "Attempt to deallocate an unallocated object") call abort()
+
+str = repeat('Y', len(str))
+deallocate(b, stat=stat, errmsg=str)
+!print *, stat, trim(str)
+if (stat == 0 .or. str /= "Attempt to deallocate an unallocated object") call abort()
+
+sstr = repeat('Q', len(sstr))
+deallocate(a, stat=stat, errmsg=sstr)
+!print *, stat, trim(sstr)
+if (stat == 0 .or. sstr /= "Attem") call abort()
+
+sstr = repeat('P', len(sstr))
+deallocate(b, stat=stat, errmsg=sstr)
+!print *, stat, trim(sstr)
+if (stat == 0 .or. sstr /= "Attem") call abort()
+
+end
index f516bad..f6b2a16 100644 (file)
@@ -1,3 +1,11 @@
+2012-01-06  Tobias Burnus <burnus@net-b.de>
+
+       * caf/single.c (_gfortran_caf_register, _gfortran_caf_deregister):
+       Fix token handling.
+       * caf/mpi.c  (_gfortran_caf_register, _gfortran_caf_deregister): Ditto.
+       * caf/libcaf.h (STAT_STOPPED_IMAGE): Sync with libgfortran.h.
+       (_gfortran_caf_register, _gfortran_caf_deregister): Update prototype.
+
 2011-12-22  Janne Blomqvist  <jb@gcc.gnu.org>
        Tobias Burnus  <burnus@net-b.de>
 
index e6be7ce..caffe17 100644 (file)
@@ -1,5 +1,5 @@
 /* Common declarations for all of GNU Fortran libcaf implementations.
-   Copyright (C) 2011
+   Copyright (C) 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Tobias Burnus <burnus@net-b.de>
 
@@ -44,7 +44,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 #define STAT_UNLOCKED          0
 #define STAT_LOCKED            1
 #define STAT_LOCKED_OTHER_IMAGE        2
-#define STAT_STOPPED_IMAGE     3
+#define STAT_STOPPED_IMAGE     6000
 
 /* Describes what type of array we are registerring. Keep in sync with
    gcc/fortran/trans.h.  */
@@ -67,9 +67,9 @@ caf_static_t;
 void _gfortran_caf_init (int *, char ***, int *, int *);
 void _gfortran_caf_finalize (void);
 
-void * _gfortran_caf_register (ptrdiff_t, caf_register_t, void **, int *,
+void * _gfortran_caf_register (ptrdiff_t, caf_register_t, void ***, int *,
                               char *, int);
-void _gfortran_caf_deregister (void **, int *, char *, int);
+void _gfortran_caf_deregister (void ***, int *, char *, int);
 
 
 void _gfortran_caf_sync_all (int *, char *, int);
index c69c5b9..8c9f07b 100644 (file)
@@ -1,5 +1,5 @@
 /* MPI implementation of GNU Fortran Coarray Library
-   Copyright (C) 2011
+   Copyright (C) 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Tobias Burnus <burnus@net-b.de>
 
@@ -119,7 +119,7 @@ _gfortran_caf_finalize (void)
 
 
 void *
-_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
+_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void ***token,
                        int *stat, char *errmsg, int errmsg_len)
 {
   void *local;
@@ -134,18 +134,19 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
 
   /* Token contains only a list of pointers.  */
   local = malloc (size);
-  token = malloc (sizeof (void*) * caf_num_images);
+  *token = malloc (sizeof (void*) * caf_num_images);
 
-  if (unlikely (local == NULL || token == NULL))
+  if (unlikely (local == NULL || *token == NULL))
     goto error;
 
   /* token[img-1] is the address of the token in image "img".  */
-  err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, token,
+  err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, *token,
                       sizeof (void*), MPI_BYTE, MPI_COMM_WORLD);
+
   if (unlikely (err))
     {
       free (local);
-      free (token);
+      free (*token);
       goto error;
     }
 
@@ -153,7 +154,7 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
     {
       caf_static_t *tmp = malloc (sizeof (caf_static_t));
       tmp->prev  = caf_static_list;
-      tmp->token = token;
+      tmp->token = *token;
       caf_static_list = tmp;
     }
 
@@ -192,7 +193,7 @@ error:
 
 
 void
-_gfortran_caf_deregister (void **token, int *stat, char *errmsg, int errmsg_len)
+_gfortran_caf_deregister (void ***token, int *stat, char *errmsg, int errmsg_len)
 {
   if (unlikely (caf_is_finalized))
     {
@@ -220,8 +221,8 @@ _gfortran_caf_deregister (void **token, int *stat, char *errmsg, int errmsg_len)
   if (stat)
     *stat = 0;
 
-  free (token[caf_this_image-1]);
-  free (token);
+  free ((*token)[caf_this_image-1]);
+  free (*token);
 }
 
 
index 5353c7b..4242fad 100644 (file)
@@ -1,5 +1,5 @@
 /* Single-image implementation of GNU Fortran Coarray Library
-   Copyright (C) 2011
+   Copyright (C) 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Tobias Burnus <burnus@net-b.de>
 
@@ -81,14 +81,14 @@ _gfortran_caf_finalize (void)
 
 
 void *
-_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
+_gfortran_caf_register (ptrdiff_t size, caf_register_t type, void ***token,
                        int *stat, char *errmsg, int errmsg_len)
 {
   void *local;
 
   local = malloc (size);
-  token = malloc (sizeof (void*) * 1);
-  token[0] = local;
+  *token = malloc (sizeof (void*) * 1);
+  (*token)[0] = local;
 
   if (unlikely (local == NULL || token == NULL))
     {
@@ -117,7 +117,7 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
     {
       caf_static_t *tmp = malloc (sizeof (caf_static_t));
       tmp->prev  = caf_static_list;
-      tmp->token = token;
+      tmp->token = *token;
       caf_static_list = tmp;
     }
   return local;
@@ -125,12 +125,12 @@ _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token,
 
 
 void
-_gfortran_caf_deregister (void **token, int *stat,
+_gfortran_caf_deregister (void ***token, int *stat,
                          char *errmsg __attribute__ ((unused)),
                          int errmsg_len __attribute__ ((unused)))
 {
+  free ((*token)[0]);
   free (*token);
-  free (token);
 
   if (stat)
     *stat = 0;