re PR fortran/60928 (gfortran issue with allocatable components and OpenMP)

author Jakub Jelinek <jakub@redhat.com>

Tue, 10 Jun 2014 06:05:22 +0000 (08:05 +0200)

committer Jakub Jelinek <jakub@gcc.gnu.org>

Tue, 10 Jun 2014 06:05:22 +0000 (08:05 +0200)
author Jakub Jelinek <jakub@redhat.com>
Tue, 10 Jun 2014 06:05:22 +0000 (08:05 +0200)
committer Jakub Jelinek <jakub@gcc.gnu.org>
Tue, 10 Jun 2014 06:05:22 +0000 (08:05 +0200)
diff --git a/gcc/ChangeLog b/gcc/ChangeLog

index 3fdd5a5..e277f22 100644 (file)
--- a/gcc/ChangeLog
+++ b/gcc/ChangeLog
@@ -1,3 +1,13 @@
+2014-06-10  Jakub Jelinek  <jakub@redhat.com>
+
+       PR fortran/60928
+       * omp-low.c (lower_rec_input_clauses) <case OMP_CLAUSE_LASTPRIVATE>:
+       Set lastprivate_firstprivate even if omp_private_outer_ref
+       langhook returns true.
+       <case OMP_CLAUSE_REDUCTION>: When calling omp_clause_default_ctor
+       langhook, call unshare_expr on new_var and call
+       build_outer_var_ref to get the last argument.
+
  2014-06-10  Marek Polacek  <polacek@redhat.com>
  
         PR c/60988
  2014-06-10  Marek Polacek  <polacek@redhat.com>
  
         PR c/60988
diff --git a/gcc/c-family/ChangeLog b/gcc/c-family/ChangeLog

index 07bcdab..b976f21 100644 (file)
--- a/gcc/c-family/ChangeLog
+++ b/gcc/c-family/ChangeLog
@@ -1,3 +1,9 @@
+2014-06-10  Jakub Jelinek  <jakub@redhat.com>
+
+       PR fortran/60928
+       * c-pragma.c (omp_pragmas_simd): Move PRAGMA_OMP_TASK...
+       (omp_pragmas): ... back here.
+
  2014-06-05  Marek Polacek  <polacek@redhat.com>
  
         PR c/49706
  2014-06-05  Marek Polacek  <polacek@redhat.com>
  
         PR c/49706
diff --git a/gcc/c-family/c-pragma.c b/gcc/c-family/c-pragma.c

index 7b016ab..5e57de3 100644 (file)
--- a/gcc/c-family/c-pragma.c
+++ b/gcc/c-family/c-pragma.c
@@ -1185,6 +1185,7 @@ static const struct omp_pragma_def omp_pragmas[] = {
    { "section", PRAGMA_OMP_SECTION },
    { "sections", PRAGMA_OMP_SECTIONS },
    { "single", PRAGMA_OMP_SINGLE },
    { "section", PRAGMA_OMP_SECTION },
    { "sections", PRAGMA_OMP_SECTIONS },
    { "single", PRAGMA_OMP_SINGLE },
+  { "task", PRAGMA_OMP_TASK },
    { "taskgroup", PRAGMA_OMP_TASKGROUP },
    { "taskwait", PRAGMA_OMP_TASKWAIT },
    { "taskyield", PRAGMA_OMP_TASKYIELD },
    { "taskgroup", PRAGMA_OMP_TASKGROUP },
    { "taskwait", PRAGMA_OMP_TASKWAIT },
    { "taskyield", PRAGMA_OMP_TASKYIELD },
@@ -1197,7 +1198,6 @@ static const struct omp_pragma_def omp_pragmas_simd[] = {
    { "parallel", PRAGMA_OMP_PARALLEL },
    { "simd", PRAGMA_OMP_SIMD },
    { "target", PRAGMA_OMP_TARGET },
    { "parallel", PRAGMA_OMP_PARALLEL },
    { "simd", PRAGMA_OMP_SIMD },
    { "target", PRAGMA_OMP_TARGET },
-  { "task", PRAGMA_OMP_TASK },
    { "teams", PRAGMA_OMP_TEAMS },
  };
  
    { "teams", PRAGMA_OMP_TEAMS },
  };
  
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog

index c044333..f945dd1 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,67 @@
+2014-06-10  Jakub Jelinek  <jakub@redhat.com>
+
+       PR fortran/60928
+       * f95-lang.c (gfc_init_builtin_functions): Handle -fopenmp-simd
+       like -fopenmp.
+       * openmp.c (resolve_omp_clauses): Remove allocatable components
+       diagnostics.  Add associate-name and intent(in) pointer
+       diagnostics for various clauses, diagnose procedure pointers in
+       reduction clause.
+       * parse.c (match_word_omp_simd): New function.
+       (matchs, matcho): New macros.
+       (decode_omp_directive): Change match macros to either matchs
+       or matcho.  Handle -fopenmp-simd.
+       (next_free, next_fixed): Handle -fopenmp-simd like -fopenmp.
+       * scanner.c (skip_free_comments, skip_fixed_comments, include_line):
+       Likewise.
+       * trans-array.c (get_full_array_size): Rename to...
+       (gfc_full_array_size): ... this.  No longer static.
+       (duplicate_allocatable): Adjust caller.  Add NO_MEMCPY argument
+       and handle it.
+       (gfc_duplicate_allocatable, gfc_copy_allocatable_data): Adjust
+       duplicate_allocatable callers.
+       (gfc_duplicate_allocatable_nocopy): New function.
+       (structure_alloc_comps): Adjust g*_full_array_size and
+       duplicate_allocatable caller.
+       * trans-array.h (gfc_full_array_size,
+       gfc_duplicate_allocatable_nocopy): New prototypes.
+       * trans-common.c (create_common): Call gfc_finish_decl_attrs.
+       * trans-decl.c (gfc_finish_decl_attrs): New function.
+       (gfc_finish_var_decl, create_function_arglist,
+       gfc_get_fake_result_decl): Call it.
+       (gfc_allocate_lang_decl): If DECL_LANG_SPECIFIC is already allocated,
+       don't allocate it again.
+       (gfc_get_symbol_decl): Set GFC_DECL_ASSOCIATE_VAR_P on
+       associate-names.
+       * trans.h (gfc_finish_decl_attrs): New prototype.
+       (struct lang_decl): Add scalar_allocatable and scalar_pointer
+       bitfields.
+       (GFC_DECL_SCALAR_ALLOCATABLE, GFC_DECL_SCALAR_POINTER,
+       GFC_DECL_GET_SCALAR_ALLOCATABLE, GFC_DECL_GET_SCALAR_POINTER,
+       GFC_DECL_ASSOCIATE_VAR_P): Define.
+       (GFC_POINTER_TYPE_P): Remove.
+       * trans-openmp.c (gfc_omp_privatize_by_reference): Don't check
+       GFC_POINTER_TYPE_P, instead test GFC_DECL_GET_SCALAR_ALLOCATABLE,
+       GFC_DECL_GET_SCALAR_POINTER or GFC_DECL_CRAY_POINTEE on decl.
+       (gfc_omp_predetermined_sharing): Associate-names are predetermined.
+       (enum walk_alloc_comps): New.
+       (gfc_has_alloc_comps, gfc_omp_unshare_expr_r, gfc_omp_unshare_expr,
+       gfc_walk_alloc_comps): New functions.
+       (gfc_omp_private_outer_ref): Return true for scalar allocatables or
+       decls with allocatable components.
+       (gfc_omp_clause_default_ctor, gfc_omp_clause_copy_ctor,
+       gfc_omp_clause_assign_op, gfc_omp_clause_dtor): Fix up handling of
+       allocatables, handle also OMP_CLAUSE_REDUCTION, handle scalar
+       allocatables and decls with allocatable components.
+       (gfc_trans_omp_array_reduction_or_udr): Don't handle allocatable
+       arrays here.
+       (gfc_trans_omp_reduction_list): Call
+       gfc_trans_omp_array_reduction_or_udr even for allocatable scalars.
+       (gfc_trans_omp_do_simd): If -fno-openmp, just expand it as OMP_SIMD.
+       (gfc_trans_omp_parallel_do_simd): Likewise.
+       * trans-types.c (gfc_sym_type): Don't set GFC_POINTER_TYPE_P.
+       (gfc_get_derived_type): Call gfc_finish_decl_attrs.
+
  2014-06-09  Paul Thomas  <pault@gcc.gnu.org>
  
         PR fortran/61406
  2014-06-09  Paul Thomas  <pault@gcc.gnu.org>
  
         PR fortran/61406
diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c

index f5d57a8..1962144 100644 (file)
--- a/gcc/fortran/f95-lang.c
+++ b/gcc/fortran/f95-lang.c
@@ -1044,7 +1044,9 @@ gfc_init_builtin_functions (void)
  #include "../sync-builtins.def"
  #undef DEF_SYNC_BUILTIN
  
  #include "../sync-builtins.def"
  #undef DEF_SYNC_BUILTIN
  
-  if (gfc_option.gfc_flag_openmp || flag_tree_parallelize_loops)
+  if (gfc_option.gfc_flag_openmp
+      || gfc_option.gfc_flag_openmp_simd
+      || flag_tree_parallelize_loops)
      {
  #undef DEF_GOMP_BUILTIN
  #define DEF_GOMP_BUILTIN(code, name, type, attr) \
      {
  #undef DEF_GOMP_BUILTIN
  #define DEF_GOMP_BUILTIN(code, name, type, attr) \
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c

index 4d92575..a6e5f6c 100644 (file)
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -1763,9 +1763,6 @@ resolve_omp_clauses (gfc_code *code, locus *where,
                 if (!n->sym->attr.threadprivate)
                   gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
                              " at %L", n->sym->name, where);
                 if (!n->sym->attr.threadprivate)
                   gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
                              " at %L", n->sym->name, where);
-               if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
-                 gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
-                            n->sym->name, where);
               }
             break;
           case OMP_LIST_COPYPRIVATE:
               }
             break;
           case OMP_LIST_COPYPRIVATE:
@@ -1774,9 +1771,9 @@ resolve_omp_clauses (gfc_code *code, locus *where,
                 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
                   gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
                              "at %L", n->sym->name, where);
                 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
                   gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
                              "at %L", n->sym->name, where);
-               if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
-                 gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
-                            n->sym->name, where);
+               if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
+                 gfc_error ("INTENT(IN) POINTER '%s' in COPYPRIVATE clause "
+                            "at %L", n->sym->name, where);
               }
             break;
           case OMP_LIST_SHARED:
               }
             break;
           case OMP_LIST_SHARED:
@@ -1788,6 +1785,9 @@ resolve_omp_clauses (gfc_code *code, locus *where,
                 if (n->sym->attr.cray_pointee)
                   gfc_error ("Cray pointee '%s' in SHARED clause at %L",
                             n->sym->name, where);
                 if (n->sym->attr.cray_pointee)
                   gfc_error ("Cray pointee '%s' in SHARED clause at %L",
                             n->sym->name, where);
+               if (n->sym->attr.associate_var)
+                 gfc_error ("ASSOCIATE name '%s' in SHARED clause at %L",
+                            n->sym->name, where);
               }
             break;
           case OMP_LIST_ALIGNED:
               }
             break;
           case OMP_LIST_ALIGNED:
@@ -1879,17 +1879,17 @@ resolve_omp_clauses (gfc_code *code, locus *where,
                 if (n->sym->attr.cray_pointee)
                   gfc_error ("Cray pointee '%s' in %s clause at %L",
                             n->sym->name, name, where);
                 if (n->sym->attr.cray_pointee)
                   gfc_error ("Cray pointee '%s' in %s clause at %L",
                             n->sym->name, name, where);
+               if (n->sym->attr.associate_var)
+                 gfc_error ("ASSOCIATE name '%s' in %s clause at %L",
+                            n->sym->name, name, where);
                 if (list != OMP_LIST_PRIVATE)
                   {
                 if (list != OMP_LIST_PRIVATE)
                   {
+                   if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION)
+                     gfc_error ("Procedure pointer '%s' in %s clause at %L",
+                                n->sym->name, name, where);
                     if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
                       gfc_error ("POINTER object '%s' in %s clause at %L",
                                  n->sym->name, name, where);
                     if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
                       gfc_error ("POINTER object '%s' in %s clause at %L",
                                  n->sym->name, name, where);
-                   /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below).  */
-                   if (list != OMP_LIST_REDUCTION
-                        && n->sym->ts.type == BT_DERIVED
-                        && n->sym->ts.u.derived->attr.alloc_comp)
-                     gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
-                                name, n->sym->name, where);
                     if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
                       gfc_error ("Cray pointer '%s' in %s clause at %L",
                                  n->sym->name, name, where);
                     if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
                       gfc_error ("Cray pointer '%s' in %s clause at %L",
                                  n->sym->name, name, where);
@@ -1901,6 +1901,19 @@ resolve_omp_clauses (gfc_code *code, locus *where,
                   gfc_error ("Variable '%s' in %s clause is used in "
                              "NAMELIST statement at %L",
                              n->sym->name, name, where);
                   gfc_error ("Variable '%s' in %s clause is used in "
                              "NAMELIST statement at %L",
                              n->sym->name, name, where);
+               if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
+                 switch (list)
+                   {
+                   case OMP_LIST_PRIVATE:
+                   case OMP_LIST_LASTPRIVATE:
+                   case OMP_LIST_LINEAR:
+                   /* case OMP_LIST_REDUCTION: */
+                     gfc_error ("INTENT(IN) POINTER '%s' in %s clause at %L",
+                                n->sym->name, name, where);
+                     break;
+                   default:
+                     break;
+                   }
                 switch (list)
                   {
                   case OMP_LIST_REDUCTION:
                 switch (list)
                   {
                   case OMP_LIST_REDUCTION:
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c

index b7c4273..bdee831 100644 (file)
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -74,6 +74,34 @@ match_word (const char *str, match (*subr) (void), locus *old_locus)
  }
  
  
  }
  
  
+/* Like match_word, but if str is matched, set a flag that it
+   was matched.  */
+static match
+match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus,
+                    bool *simd_matched)
+{
+  match m;
+
+  if (str != NULL)
+    {
+      m = gfc_match (str);
+      if (m != MATCH_YES)
+       return m;
+      *simd_matched = true;
+    }
+
+  m = (*subr) ();
+
+  if (m != MATCH_YES)
+    {
+      gfc_current_locus = *old_locus;
+      reject_statement ();
+    }
+
+  return m;
+}
+
+
  /* Load symbols from all USE statements encountered in this scoping unit.  */
  
  static void
  /* Load symbols from all USE statements encountered in this scoping unit.  */
  
  static void
@@ -103,7 +131,7 @@ use_modules (void)
        if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
         return st;                                              \
        else                                                     \
        if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
         return st;                                              \
        else                                                     \
-       undo_new_statement ();                            \
+       undo_new_statement ();                                  \
      } while (0);
  
  
      } while (0);
  
  
@@ -531,11 +559,34 @@ decode_statement (void)
    return ST_NONE;
  }
  
    return ST_NONE;
  }
  
+/* Like match, but set a flag simd_matched if keyword matched.  */
+#define matchs(keyword, subr, st)                              \
+    do {                                                       \
+      if (match_word_omp_simd (keyword, subr, &old_locus,      \
+                              &simd_matched) == MATCH_YES)     \
+       return st;                                              \
+      else                                                     \
+       undo_new_statement ();                                  \
+    } while (0);
+
+/* Like match, but don't match anything if not -fopenmp.  */
+#define matcho(keyword, subr, st)                              \
+    do {                                                       \
+      if (!gfc_option.gfc_flag_openmp)                         \
+       ;                                                       \
+      else if (match_word (keyword, subr, &old_locus)          \
+              == MATCH_YES)                                    \
+       return st;                                              \
+      else                                                     \
+       undo_new_statement ();                                  \
+    } while (0);
+
  static gfc_statement
  decode_omp_directive (void)
  {
    locus old_locus;
    char c;
  static gfc_statement
  decode_omp_directive (void)
  {
    locus old_locus;
    char c;
+  bool simd_matched = false;
  
    gfc_enforce_clean_symbol_state ();
  
  
    gfc_enforce_clean_symbol_state ();
  
@@ -560,94 +611,102 @@ decode_omp_directive (void)
  
    c = gfc_peek_ascii_char ();
  
  
    c = gfc_peek_ascii_char ();
  
+  /* match is for directives that should be recognized only if
+     -fopenmp, matchs for directives that should be recognized
+     if either -fopenmp or -fopenmp-simd.  */
    switch (c)
      {
      case 'a':
    switch (c)
      {
      case 'a':
-      match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
+      matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
        break;
      case 'b':
        break;
      case 'b':
-      match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
+      matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
        break;
      case 'c':
        break;
      case 'c':
-      match ("cancellation% point", gfc_match_omp_cancellation_point,
-            ST_OMP_CANCELLATION_POINT);
-      match ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
-      match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
+      matcho ("cancellation% point", gfc_match_omp_cancellation_point,
+             ST_OMP_CANCELLATION_POINT);
+      matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
+      matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
        break;
      case 'd':
        break;
      case 'd':
-      match ("declare reduction", gfc_match_omp_declare_reduction,
-            ST_OMP_DECLARE_REDUCTION);
-      match ("declare simd", gfc_match_omp_declare_simd,
-            ST_OMP_DECLARE_SIMD);
-      match ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
-      match ("do", gfc_match_omp_do, ST_OMP_DO);
+      matchs ("declare reduction", gfc_match_omp_declare_reduction,
+             ST_OMP_DECLARE_REDUCTION);
+      matchs ("declare simd", gfc_match_omp_declare_simd,
+             ST_OMP_DECLARE_SIMD);
+      matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
+      matcho ("do", gfc_match_omp_do, ST_OMP_DO);
        break;
      case 'e':
        break;
      case 'e':
-      match ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC);
-      match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
-      match ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
-      match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
-      match ("end simd", gfc_match_omp_eos, ST_OMP_END_SIMD);
-      match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
-      match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
-      match ("end parallel do simd", gfc_match_omp_eos,
-            ST_OMP_END_PARALLEL_DO_SIMD);
-      match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
-      match ("end parallel sections", gfc_match_omp_eos,
-            ST_OMP_END_PARALLEL_SECTIONS);
-      match ("end parallel workshare", gfc_match_omp_eos,
-            ST_OMP_END_PARALLEL_WORKSHARE);
-      match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
-      match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
-      match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
-      match ("end taskgroup", gfc_match_omp_eos, ST_OMP_END_TASKGROUP);
-      match ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
-      match ("end workshare", gfc_match_omp_end_nowait,
-            ST_OMP_END_WORKSHARE);
+      matcho ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC);
+      matcho ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
+      matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
+      matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
+      matchs ("end simd", gfc_match_omp_eos, ST_OMP_END_SIMD);
+      matcho ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
+      matcho ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
+      matchs ("end parallel do simd", gfc_match_omp_eos,
+             ST_OMP_END_PARALLEL_DO_SIMD);
+      matcho ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
+      matcho ("end parallel sections", gfc_match_omp_eos,
+             ST_OMP_END_PARALLEL_SECTIONS);
+      matcho ("end parallel workshare", gfc_match_omp_eos,
+             ST_OMP_END_PARALLEL_WORKSHARE);
+      matcho ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
+      matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
+      matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
+      matcho ("end taskgroup", gfc_match_omp_eos, ST_OMP_END_TASKGROUP);
+      matcho ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
+      matcho ("end workshare", gfc_match_omp_end_nowait,
+             ST_OMP_END_WORKSHARE);
        break;
      case 'f':
        break;
      case 'f':
-      match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
+      matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
        break;
      case 'm':
        break;
      case 'm':
-      match ("master", gfc_match_omp_master, ST_OMP_MASTER);
+      matcho ("master", gfc_match_omp_master, ST_OMP_MASTER);
        break;
      case 'o':
        break;
      case 'o':
-      match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
+      matcho ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
        break;
      case 'p':
        break;
      case 'p':
-      match ("parallel do simd", gfc_match_omp_parallel_do_simd,
-            ST_OMP_PARALLEL_DO_SIMD);
-      match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
-      match ("parallel sections", gfc_match_omp_parallel_sections,
-            ST_OMP_PARALLEL_SECTIONS);
-      match ("parallel workshare", gfc_match_omp_parallel_workshare,
-            ST_OMP_PARALLEL_WORKSHARE);
-      match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
+      matchs ("parallel do simd", gfc_match_omp_parallel_do_simd,
+             ST_OMP_PARALLEL_DO_SIMD);
+      matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
+      matcho ("parallel sections", gfc_match_omp_parallel_sections,
+             ST_OMP_PARALLEL_SECTIONS);
+      matcho ("parallel workshare", gfc_match_omp_parallel_workshare,
+             ST_OMP_PARALLEL_WORKSHARE);
+      matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
        break;
      case 's':
        break;
      case 's':
-      match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
-      match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
-      match ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
-      match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
+      matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
+      matcho ("section", gfc_match_omp_eos, ST_OMP_SECTION);
+      matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
+      matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE);
        break;
      case 't':
        break;
      case 't':
-      match ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
-      match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
-      match ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
-      match ("task", gfc_match_omp_task, ST_OMP_TASK);
-      match ("threadprivate", gfc_match_omp_threadprivate,
-            ST_OMP_THREADPRIVATE);
+      matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
+      matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
+      matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
+      matcho ("task", gfc_match_omp_task, ST_OMP_TASK);
+      matcho ("threadprivate", gfc_match_omp_threadprivate,
+             ST_OMP_THREADPRIVATE);
        break;
      case 'w':
        break;
      case 'w':
-      match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
+      matcho ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
        break;
      }
  
    /* All else has failed, so give up.  See if any of the matchers has
        break;
      }
  
    /* All else has failed, so give up.  See if any of the matchers has
-     stored an error message of some sort.  */
+     stored an error message of some sort.  Don't error out if
+     not -fopenmp and simd_matched is false, i.e. if a directive other
+     than one marked with match has been seen.  */
  
  
-  if (gfc_error_check () == 0)
-    gfc_error_now ("Unclassifiable OpenMP directive at %C");
+  if (gfc_option.gfc_flag_openmp || simd_matched)
+    {
+      if (gfc_error_check () == 0)
+       gfc_error_now ("Unclassifiable OpenMP directive at %C");
+    }
  
    reject_statement ();
  
  
    reject_statement ();
  
@@ -770,7 +829,9 @@ next_free (void)
           return decode_gcc_attribute ();
  
         }
           return decode_gcc_attribute ();
  
         }
-      else if (c == '$' && gfc_option.gfc_flag_openmp)
+      else if (c == '$'
+              && (gfc_option.gfc_flag_openmp
+                  || gfc_option.gfc_flag_openmp_simd))
         {
           int i;
  
         {
           int i;
  
@@ -859,7 +920,9 @@ next_fixed (void)
  
               return decode_gcc_attribute ();
             }
  
               return decode_gcc_attribute ();
             }
-         else if (c == '$' && gfc_option.gfc_flag_openmp)
+         else if (c == '$'
+                  && (gfc_option.gfc_flag_openmp
+                      || gfc_option.gfc_flag_openmp_simd))
             {
               for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
                 gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
             {
               for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
                 gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c

index 8f51734..8934924 100644 (file)
--- a/gcc/fortran/scanner.c
+++ b/gcc/fortran/scanner.c
@@ -752,7 +752,8 @@ skip_free_comments (void)
              2) handle OpenMP conditional compilation, where
                 !$ should be treated as 2 spaces (for initial lines
                 only if followed by space).  */
              2) handle OpenMP conditional compilation, where
                 !$ should be treated as 2 spaces (for initial lines
                 only if followed by space).  */
-         if (gfc_option.gfc_flag_openmp && at_bol)
+         if ((gfc_option.gfc_flag_openmp
+              || gfc_option.gfc_flag_openmp_simd) && at_bol)
             {
               locus old_loc = gfc_current_locus;
               if (next_char () == '$')
             {
               locus old_loc = gfc_current_locus;
               if (next_char () == '$')
@@ -878,7 +879,7 @@ skip_fixed_comments (void)
               && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
             continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
  
               && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
             continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
  
-         if (gfc_option.gfc_flag_openmp)
+         if (gfc_option.gfc_flag_openmp || gfc_option.gfc_flag_openmp_simd)
             {
               if (next_char () == '$')
                 {
             {
               if (next_char () == '$')
                 {
@@ -1821,7 +1822,7 @@ include_line (gfc_char_t *line)
  
    c = line;
  
  
    c = line;
  
-  if (gfc_option.gfc_flag_openmp)
+  if (gfc_option.gfc_flag_openmp || gfc_option.gfc_flag_openmp_simd)
      {
        if (gfc_current_form == FORM_FREE)
         {
      {
        if (gfc_current_form == FORM_FREE)
         {
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c

index 5255969..5558217 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7381,8 +7381,8 @@ gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr)
  
  /* This helper function calculates the size in words of a full array.  */
  
  
  /* This helper function calculates the size in words of a full array.  */
  
-static tree
-get_full_array_size (stmtblock_t *block, tree decl, int rank)
+tree
+gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
  {
    tree idx;
    tree nelems;
  {
    tree idx;
    tree nelems;
@@ -7408,7 +7408,7 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank)
  
  static tree
  duplicate_allocatable (tree dest, tree src, tree type, int rank,
  
  static tree
  duplicate_allocatable (tree dest, tree src, tree type, int rank,
-                      bool no_malloc, tree str_sz)
+                      bool no_malloc, bool no_memcpy, tree str_sz)
  {
    tree tmp;
    tree size;
  {
    tree tmp;
    tree size;
@@ -7442,9 +7442,13 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
           gfc_add_expr_to_block (&block, tmp);
         }
  
           gfc_add_expr_to_block (&block, tmp);
         }
  
-      tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
-      tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
-                                fold_convert (size_type_node, size));
+      if (!no_memcpy)
+       {
+         tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+         tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
+                                    fold_convert (size_type_node, size));
+         gfc_add_expr_to_block (&block, tmp);
+       }
      }
    else
      {
      }
    else
      {
@@ -7453,7 +7457,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
  
        gfc_init_block (&block);
        if (rank)
  
        gfc_init_block (&block);
        if (rank)
-       nelems = get_full_array_size (&block, src, rank);
+       nelems = gfc_full_array_size (&block, src, rank);
        else
         nelems = gfc_index_one_node;
  
        else
         nelems = gfc_index_one_node;
  
@@ -7473,14 +7477,17 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
  
        /* We know the temporary and the value will be the same length,
          so can use memcpy.  */
  
        /* We know the temporary and the value will be the same length,
          so can use memcpy.  */
-      tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
-      tmp = build_call_expr_loc (input_location,
-                       tmp, 3, gfc_conv_descriptor_data_get (dest),
-                       gfc_conv_descriptor_data_get (src),
-                       fold_convert (size_type_node, size));
+      if (!no_memcpy)
+       {
+         tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+         tmp = build_call_expr_loc (input_location, tmp, 3,
+                                    gfc_conv_descriptor_data_get (dest),
+                                    gfc_conv_descriptor_data_get (src),
+                                    fold_convert (size_type_node, size));
+         gfc_add_expr_to_block (&block, tmp);
+       }
      }
  
      }
  
-  gfc_add_expr_to_block (&block, tmp);
    tmp = gfc_finish_block (&block);
  
    /* Null the destination if the source is null; otherwise do
    tmp = gfc_finish_block (&block);
  
    /* Null the destination if the source is null; otherwise do
@@ -7502,7 +7509,8 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
  tree
  gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
  {
  tree
  gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
  {
-  return duplicate_allocatable (dest, src, type, rank, false, NULL_TREE);
+  return duplicate_allocatable (dest, src, type, rank, false, false,
+                               NULL_TREE);
  }
  
  
  }
  
  
@@ -7511,7 +7519,16 @@ gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
  tree
  gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
  {
  tree
  gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
  {
-  return duplicate_allocatable (dest, src, type, rank, true, NULL_TREE);
+  return duplicate_allocatable (dest, src, type, rank, true, false,
+                               NULL_TREE);
+}
+
+/* Allocate dest to the same size as src, but don't copy anything.  */
+
+tree
+gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
+{
+  return duplicate_allocatable (dest, src, type, rank, false, true, NULL_TREE);
  }
  
  
  }
  
  
@@ -7571,7 +7588,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
           /* Use the descriptor for an allocatable array.  Since this
              is a full array reference, we only need the descriptor
              information from dimension = rank.  */
           /* Use the descriptor for an allocatable array.  Since this
              is a full array reference, we only need the descriptor
              information from dimension = rank.  */
-         tmp = get_full_array_size (&fnblock, decl, rank);
+         tmp = gfc_full_array_size (&fnblock, decl, rank);
           tmp = fold_build2_loc (input_location, MINUS_EXPR,
                                  gfc_array_index_type, tmp,
                                  gfc_index_one_node);
           tmp = fold_build2_loc (input_location, MINUS_EXPR,
                                  gfc_array_index_type, tmp,
                                  gfc_index_one_node);
@@ -7930,7 +7947,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
               gfc_add_expr_to_block (&fnblock, tmp);
               size = size_of_string_in_bytes (c->ts.kind, len);
               tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
               gfc_add_expr_to_block (&fnblock, tmp);
               size = size_of_string_in_bytes (c->ts.kind, len);
               tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
-                                          false, size);
+                                          false, false, size);
               gfc_add_expr_to_block (&fnblock, tmp);
             }
           else if (c->attr.allocatable && !c->attr.proc_pointer
               gfc_add_expr_to_block (&fnblock, tmp);
             }
           else if (c->attr.allocatable && !c->attr.proc_pointer
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h

index c4c09c1..e0bb820 100644 (file)
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -44,10 +44,14 @@ 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, bool, gfc_expr *);
  
  /* Generate code to deallocate an array, if it is allocated.  */
  tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *);
  
+tree gfc_full_array_size (stmtblock_t *, tree, int);
+
  tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);
  
  tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank);
  
  tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);
  
  tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank);
  
+tree gfc_duplicate_allocatable_nocopy (tree, tree, tree, int);
+
  tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
  
  tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
  tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
  
  tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c

index 19eadda..36aa8f3 100644 (file)
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -705,6 +705,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
         TREE_ADDRESSABLE (var_decl) = 1;
        /* Fake variables are not visible from other translation units. */
        TREE_PUBLIC (var_decl) = 0;
         TREE_ADDRESSABLE (var_decl) = 1;
        /* Fake variables are not visible from other translation units. */
        TREE_PUBLIC (var_decl) = 0;
+      gfc_finish_decl_attrs (var_decl, &s->sym->attr);
  
        /* To preserve identifier names in COMMON, chain to procedure
           scope unless at top level in a module definition.  */
  
        /* To preserve identifier names in COMMON, chain to procedure
           scope unless at top level in a module definition.  */
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c

index 959bcb1..863e596 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -496,6 +496,29 @@ gfc_finish_decl (tree decl)
  }
  
  
  }
  
  
+/* Handle setting of GFC_DECL_SCALAR* on DECL.  */
+
+void
+gfc_finish_decl_attrs (tree decl, symbol_attribute *attr)
+{
+  if (!attr->dimension && !attr->codimension)
+    {
+      /* Handle scalar allocatable variables.  */
+      if (attr->allocatable)
+       {
+         gfc_allocate_lang_decl (decl);
+         GFC_DECL_SCALAR_ALLOCATABLE (decl) = 1;
+       }
+      /* Handle scalar pointer variables.  */
+      if (attr->pointer)
+       {
+         gfc_allocate_lang_decl (decl);
+         GFC_DECL_SCALAR_POINTER (decl) = 1;
+       }
+    }
+}
+
+
  /* Apply symbol attributes to a variable, and add it to the function scope.  */
  
  static void
  /* Apply symbol attributes to a variable, and add it to the function scope.  */
  
  static void
@@ -607,6 +630,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
    if (sym->attr.threadprivate
        && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
      DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
    if (sym->attr.threadprivate
        && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
      DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+
+  gfc_finish_decl_attrs (decl, &sym->attr);
  }
  
  
  }
  
  
@@ -615,7 +640,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
  void
  gfc_allocate_lang_decl (tree decl)
  {
  void
  gfc_allocate_lang_decl (tree decl)
  {
-  DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> ();
+  if (DECL_LANG_SPECIFIC (decl) == NULL)
+    DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> ();
  }
  
  /* Remember a symbol to generate initialization/cleanup code at function
  }
  
  /* Remember a symbol to generate initialization/cleanup code at function
@@ -1517,6 +1543,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
        && !sym->attr.select_type_temporary)
      DECL_BY_REFERENCE (decl) = 1;
  
        && !sym->attr.select_type_temporary)
      DECL_BY_REFERENCE (decl) = 1;
  
+  if (sym->attr.associate_var)
+    GFC_DECL_ASSOCIATE_VAR_P (decl) = 1;
+
    if (sym->attr.vtab
        || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
      TREE_READONLY (decl) = 1;
    if (sym->attr.vtab
        || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
      TREE_READONLY (decl) = 1;
@@ -2236,6 +2265,7 @@ create_function_arglist (gfc_symbol * sym)
         DECL_BY_REFERENCE (parm) = 1;
  
        gfc_finish_decl (parm);
         DECL_BY_REFERENCE (parm) = 1;
  
        gfc_finish_decl (parm);
+      gfc_finish_decl_attrs (parm, &f->sym->attr);
  
        f->sym->backend_decl = parm;
  
  
        f->sym->backend_decl = parm;
  
@@ -2690,6 +2720,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
        TREE_ADDRESSABLE (decl) = 1;
  
        layout_decl (decl, 0);
        TREE_ADDRESSABLE (decl) = 1;
  
        layout_decl (decl, 0);
+      gfc_finish_decl_attrs (decl, &sym->attr);
  
        if (parent_flag)
         gfc_add_decl_to_parent_function (decl);
  
        if (parent_flag)
         gfc_add_decl_to_parent_function (decl);
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c

index 3851a4e..998d687 100644 (file)
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -55,7 +55,9 @@ gfc_omp_privatize_by_reference (const_tree decl)
        /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
          that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P
          set are supposed to be privatized by reference.  */
        /* Array POINTER/ALLOCATABLE have aggregate types, all user variables
          that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P
          set are supposed to be privatized by reference.  */
-      if (GFC_POINTER_TYPE_P (type))
+      if (GFC_DECL_GET_SCALAR_POINTER (decl)
+         || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
+         || GFC_DECL_CRAY_POINTEE (decl))
         return false;
  
        if (!DECL_ARTIFICIAL (decl)
         return false;
  
        if (!DECL_ARTIFICIAL (decl)
@@ -77,6 +79,19 @@ gfc_omp_privatize_by_reference (const_tree decl)
  enum omp_clause_default_kind
  gfc_omp_predetermined_sharing (tree decl)
  {
  enum omp_clause_default_kind
  gfc_omp_predetermined_sharing (tree decl)
  {
+  /* Associate names preserve the association established during ASSOCIATE.
+     As they are implemented either as pointers to the selector or array
+     descriptor and shouldn't really change in the ASSOCIATE region,
+     this decl can be either shared or firstprivate.  If it is a pointer,
+     use firstprivate, as it is cheaper that way, otherwise make it shared.  */
+  if (GFC_DECL_ASSOCIATE_VAR_P (decl))
+    {
+      if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
+       return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE;
+      else
+       return OMP_CLAUSE_DEFAULT_SHARED;
+    }
+
    if (DECL_ARTIFICIAL (decl)
        && ! GFC_DECL_RESULT (decl)
        && ! (DECL_LANG_SPECIFIC (decl)
    if (DECL_ARTIFICIAL (decl)
        && ! GFC_DECL_RESULT (decl)
        && ! (DECL_LANG_SPECIFIC (decl)
@@ -135,6 +150,41 @@ gfc_omp_report_decl (tree decl)
    return decl;
  }
  
    return decl;
  }
  
+/* Return true if TYPE has any allocatable components.  */
+
+static bool
+gfc_has_alloc_comps (tree type, tree decl)
+{
+  tree field, ftype;
+
+  if (POINTER_TYPE_P (type))
+    {
+      if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
+       type = TREE_TYPE (type);
+      else if (GFC_DECL_GET_SCALAR_POINTER (decl))
+       return false;
+    }
+
+  while (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
+    type = gfc_get_element_type (type);
+
+  if (TREE_CODE (type) != RECORD_TYPE)
+    return false;
+
+  for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
+    {
+      ftype = TREE_TYPE (field);
+      if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
+       return true;
+      if (GFC_DESCRIPTOR_TYPE_P (ftype)
+         && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
+       return true;
+      if (gfc_has_alloc_comps (ftype, field))
+       return true;
+    }
+  return false;
+}
+
  /* Return true if DECL in private clause needs
     OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause.  */
  bool
  /* Return true if DECL in private clause needs
     OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause.  */
  bool
@@ -146,68 +196,335 @@ gfc_omp_private_outer_ref (tree decl)
        && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
      return true;
  
        && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
      return true;
  
+  if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
+    return true;
+
+  if (gfc_omp_privatize_by_reference (decl))
+    type = TREE_TYPE (type);
+
+  if (gfc_has_alloc_comps (type, decl))
+    return true;
+
    return false;
  }
  
    return false;
  }
  
+/* Callback for gfc_omp_unshare_expr.  */
+
+static tree
+gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *)
+{
+  tree t = *tp;
+  enum tree_code code = TREE_CODE (t);
+
+  /* Stop at types, decls, constants like copy_tree_r.  */
+  if (TREE_CODE_CLASS (code) == tcc_type
+      || TREE_CODE_CLASS (code) == tcc_declaration
+      || TREE_CODE_CLASS (code) == tcc_constant
+      || code == BLOCK)
+    *walk_subtrees = 0;
+  else if (handled_component_p (t)
+          || TREE_CODE (t) == MEM_REF)
+    {
+      *tp = unshare_expr (t);
+      *walk_subtrees = 0;
+    }
+
+  return NULL_TREE;
+}
+
+/* Unshare in expr anything that the FE which normally doesn't
+   care much about tree sharing (because during gimplification
+   everything is unshared) could cause problems with tree sharing
+   at omp-low.c time.  */
+
+static tree
+gfc_omp_unshare_expr (tree expr)
+{
+  walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL);
+  return expr;
+}
+
+enum walk_alloc_comps
+{
+  WALK_ALLOC_COMPS_DTOR,
+  WALK_ALLOC_COMPS_DEFAULT_CTOR,
+  WALK_ALLOC_COMPS_COPY_CTOR
+};
+
+/* Handle allocatable components in OpenMP clauses.  */
+
+static tree
+gfc_walk_alloc_comps (tree decl, tree dest, tree var,
+                     enum walk_alloc_comps kind)
+{
+  stmtblock_t block, tmpblock;
+  tree type = TREE_TYPE (decl), then_b, tem, field;
+  gfc_init_block (&block);
+
+  if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      if (GFC_DESCRIPTOR_TYPE_P (type))
+       {
+         gfc_init_block (&tmpblock);
+         tem = gfc_full_array_size (&tmpblock, decl,
+                                    GFC_TYPE_ARRAY_RANK (type));
+         then_b = gfc_finish_block (&tmpblock);
+         gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (then_b));
+         tem = gfc_omp_unshare_expr (tem);
+         tem = fold_build2_loc (input_location, MINUS_EXPR,
+                                gfc_array_index_type, tem,
+                                gfc_index_one_node);
+       }
+      else
+       {
+         if (!TYPE_DOMAIN (type)
+             || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE
+             || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node
+             || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node)
+           {
+             tem = fold_build2 (EXACT_DIV_EXPR, sizetype,
+                                TYPE_SIZE_UNIT (type),
+                                TYPE_SIZE_UNIT (TREE_TYPE (type)));
+             tem = size_binop (MINUS_EXPR, tem, size_one_node);
+           }
+         else
+           tem = array_type_nelts (type);
+         tem = fold_convert (gfc_array_index_type, tem);
+       }
+
+      tree nelems = gfc_evaluate_now (tem, &block);
+      tree index = gfc_create_var (gfc_array_index_type, "S");
+
+      gfc_init_block (&tmpblock);
+      tem = gfc_conv_array_data (decl);
+      tree declvar = build_fold_indirect_ref_loc (input_location, tem);
+      tree declvref = gfc_build_array_ref (declvar, index, NULL);
+      tree destvar, destvref = NULL_TREE;
+      if (dest)
+       {
+         tem = gfc_conv_array_data (dest);
+         destvar = build_fold_indirect_ref_loc (input_location, tem);
+         destvref = gfc_build_array_ref (destvar, index, NULL);
+       }
+      gfc_add_expr_to_block (&tmpblock,
+                            gfc_walk_alloc_comps (declvref, destvref,
+                                                  var, kind));
+
+      gfc_loopinfo loop;
+      gfc_init_loopinfo (&loop);
+      loop.dimen = 1;
+      loop.from[0] = gfc_index_zero_node;
+      loop.loopvar[0] = index;
+      loop.to[0] = nelems;
+      gfc_trans_scalarizing_loops (&loop, &tmpblock);
+      gfc_add_block_to_block (&block, &loop.pre);
+      return gfc_finish_block (&block);
+    }
+  else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var))
+    {
+      decl = build_fold_indirect_ref_loc (input_location, decl);
+      if (dest)
+       dest = build_fold_indirect_ref_loc (input_location, dest);
+      type = TREE_TYPE (decl);
+    }
+
+  gcc_assert (TREE_CODE (type) == RECORD_TYPE);
+  for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
+    {
+      tree ftype = TREE_TYPE (field);
+      tree declf, destf = NULL_TREE;
+      bool has_alloc_comps = gfc_has_alloc_comps (ftype, field);
+      if ((!GFC_DESCRIPTOR_TYPE_P (ftype)
+          || GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE)
+         && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
+         && !has_alloc_comps)
+       continue;
+      declf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
+                              decl, field, NULL_TREE);
+      if (dest)
+       destf = fold_build3_loc (input_location, COMPONENT_REF, ftype,
+                                dest, field, NULL_TREE);
+
+      tem = NULL_TREE;
+      switch (kind)
+       {
+       case WALK_ALLOC_COMPS_DTOR:
+         break;
+       case WALK_ALLOC_COMPS_DEFAULT_CTOR:
+         if (GFC_DESCRIPTOR_TYPE_P (ftype)
+             && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
+           {
+             gfc_add_modify (&block, unshare_expr (destf),
+                             unshare_expr (declf));
+             tem = gfc_duplicate_allocatable_nocopy
+                                       (destf, declf, ftype,
+                                        GFC_TYPE_ARRAY_RANK (ftype));
+           }
+         else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
+           tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0);
+         break;
+       case WALK_ALLOC_COMPS_COPY_CTOR:
+         if (GFC_DESCRIPTOR_TYPE_P (ftype)
+             && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
+           tem = gfc_duplicate_allocatable (destf, declf, ftype,
+                                            GFC_TYPE_ARRAY_RANK (ftype));
+         else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
+           tem = gfc_duplicate_allocatable (destf, declf, ftype, 0);
+         break;
+       }
+      if (tem)
+       gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
+      if (has_alloc_comps)
+       {
+         gfc_init_block (&tmpblock);
+         gfc_add_expr_to_block (&tmpblock,
+                                gfc_walk_alloc_comps (declf, destf,
+                                                      field, kind));
+         then_b = gfc_finish_block (&tmpblock);
+         if (GFC_DESCRIPTOR_TYPE_P (ftype)
+             && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
+           tem = gfc_conv_descriptor_data_get (unshare_expr (declf));
+         else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
+           tem = unshare_expr (declf);
+         else
+           tem = NULL_TREE;
+         if (tem)
+           {
+             tem = fold_convert (pvoid_type_node, tem);
+             tem = fold_build2_loc (input_location, NE_EXPR,
+                                    boolean_type_node, tem,
+                                    null_pointer_node);
+             then_b = build3_loc (input_location, COND_EXPR, void_type_node,
+                                  tem, then_b,
+                                  build_empty_stmt (input_location));
+           }
+         gfc_add_expr_to_block (&block, then_b);
+       }
+      if (kind == WALK_ALLOC_COMPS_DTOR)
+       {
+         if (GFC_DESCRIPTOR_TYPE_P (ftype)
+             && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
+           {
+             tem = gfc_trans_dealloc_allocated (unshare_expr (declf),
+                                                false, NULL);
+             gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
+           }
+         else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
+           {
+             tem = gfc_call_free (unshare_expr (declf));
+             gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
+           }
+       }
+    }
+
+  return gfc_finish_block (&block);
+}
+
  /* Return code to initialize DECL with its default constructor, or
     NULL if there's nothing to do.  */
  
  tree
  gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
  {
  /* Return code to initialize DECL with its default constructor, or
     NULL if there's nothing to do.  */
  
  tree
  gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
  {
-  tree type = TREE_TYPE (decl), rank, size, esize, ptr, cond, then_b, else_b;
+  tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b;
    stmtblock_t block, cond_block;
  
    stmtblock_t block, cond_block;
  
-  if (! GFC_DESCRIPTOR_TYPE_P (type)
-      || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
-    return NULL;
+  gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
+             || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE
+             || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR
+             || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION);
  
  
-  if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION)
-    return NULL;
+  if ((! GFC_DESCRIPTOR_TYPE_P (type)
+       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
+      && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
+    {
+      if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+       {
+         gcc_assert (outer);
+         gfc_start_block (&block);
+         tree tem = gfc_walk_alloc_comps (outer, decl,
+                                          OMP_CLAUSE_DECL (clause),
+                                          WALK_ALLOC_COMPS_DEFAULT_CTOR);
+         gfc_add_expr_to_block (&block, tem);
+         return gfc_finish_block (&block);
+       }
+      return NULL_TREE;
+    }
  
  
-  gcc_assert (outer != NULL);
-  gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE
-             || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE);
+  gcc_assert (outer != NULL_TREE);
  
  
-  /* Allocatable arrays in PRIVATE clauses need to be set to
+  /* Allocatable arrays and scalars in PRIVATE clauses need to be set to
       "not currently allocated" allocation status if outer
       array is "not currently allocated", otherwise should be allocated.  */
    gfc_start_block (&block);
  
    gfc_init_block (&cond_block);
  
       "not currently allocated" allocation status if outer
       array is "not currently allocated", otherwise should be allocated.  */
    gfc_start_block (&block);
  
    gfc_init_block (&cond_block);
  
-  gfc_add_modify (&cond_block, decl, outer);
-  rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
-  size = gfc_conv_descriptor_ubound_get (decl, rank);
-  size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-                         size, gfc_conv_descriptor_lbound_get (decl, rank));
-  size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-                         size, gfc_index_one_node);
-  if (GFC_TYPE_ARRAY_RANK (type) > 1)
-    size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-                           size, gfc_conv_descriptor_stride_get (decl, rank));
-  esize = fold_convert (gfc_array_index_type,
-                       TYPE_SIZE_UNIT (gfc_get_element_type (type)));
-  size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-                         size, esize);
-  size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
-
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      gfc_add_modify (&cond_block, decl, outer);
+      tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
+      size = gfc_conv_descriptor_ubound_get (decl, rank);
+      size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+                             size,
+                             gfc_conv_descriptor_lbound_get (decl, rank));
+      size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+                             size, gfc_index_one_node);
+      if (GFC_TYPE_ARRAY_RANK (type) > 1)
+       size = fold_build2_loc (input_location, MULT_EXPR,
+                               gfc_array_index_type, size,
+                               gfc_conv_descriptor_stride_get (decl, rank));
+      tree esize = fold_convert (gfc_array_index_type,
+                                TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+                             size, esize);
+      size = unshare_expr (size);
+      size = gfc_evaluate_now (fold_convert (size_type_node, size),
+                              &cond_block);
+    }
+  else
+    size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
    ptr = gfc_create_var (pvoid_type_node, NULL);
    gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
    ptr = gfc_create_var (pvoid_type_node, NULL);
    gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
-  gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
-
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr);
+  else
+    gfc_add_modify (&cond_block, unshare_expr (decl),
+                   fold_convert (TREE_TYPE (decl), ptr));
+  if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+    {
+      tree tem = gfc_walk_alloc_comps (outer, decl,
+                                      OMP_CLAUSE_DECL (clause),
+                                      WALK_ALLOC_COMPS_DEFAULT_CTOR);
+      gfc_add_expr_to_block (&cond_block, tem);
+    }
    then_b = gfc_finish_block (&cond_block);
  
    then_b = gfc_finish_block (&cond_block);
  
-  gfc_init_block (&cond_block);
-  gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node);
-  else_b = gfc_finish_block (&cond_block);
-
-  cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
-                         fold_convert (pvoid_type_node,
-                                       gfc_conv_descriptor_data_get (outer)),
-                         null_pointer_node);
-  gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
-                        void_type_node, cond, then_b, else_b));
+  /* Reduction clause requires allocated ALLOCATABLE.  */
+  if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION)
+    {
+      gfc_init_block (&cond_block);
+      if (GFC_DESCRIPTOR_TYPE_P (type))
+       gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl),
+                                     null_pointer_node);
+      else
+       gfc_add_modify (&cond_block, unshare_expr (decl),
+                       build_zero_cst (TREE_TYPE (decl)));
+      else_b = gfc_finish_block (&cond_block);
+
+      tree tem = fold_convert (pvoid_type_node,
+                              GFC_DESCRIPTOR_TYPE_P (type)
+                              ? gfc_conv_descriptor_data_get (outer) : outer);
+      tem = unshare_expr (tem);
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                             tem, null_pointer_node);
+      gfc_add_expr_to_block (&block,
+                            build3_loc (input_location, COND_EXPR,
+                                        void_type_node, cond, then_b,
+                                        else_b));
+    }
+  else
+    gfc_add_expr_to_block (&block, then_b);
  
    return gfc_finish_block (&block);
  }
  
    return gfc_finish_block (&block);
  }
@@ -217,15 +534,29 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
  tree
  gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
  {
  tree
  gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
  {
-  tree type = TREE_TYPE (dest), ptr, size, esize, rank, call;
+  tree type = TREE_TYPE (dest), ptr, size, call;
    tree cond, then_b, else_b;
    stmtblock_t block, cond_block;
  
    tree cond, then_b, else_b;
    stmtblock_t block, cond_block;
  
-  if (! GFC_DESCRIPTOR_TYPE_P (type)
-      || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
-    return build2_v (MODIFY_EXPR, dest, src);
+  gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE
+             || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR);
  
  
-  gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE);
+  if ((! GFC_DESCRIPTOR_TYPE_P (type)
+       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
+      && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
+    {
+      if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+       {
+         gfc_start_block (&block);
+         gfc_add_modify (&block, dest, src);
+         tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause),
+                                          WALK_ALLOC_COMPS_COPY_CTOR);
+         gfc_add_expr_to_block (&block, tem);
+         return gfc_finish_block (&block);
+       }
+      else
+       return build2_v (MODIFY_EXPR, dest, src);
+    }
  
    /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
       and copied from SRC.  */
  
    /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated
       and copied from SRC.  */
@@ -234,85 +565,257 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
    gfc_init_block (&cond_block);
  
    gfc_add_modify (&cond_block, dest, src);
    gfc_init_block (&cond_block);
  
    gfc_add_modify (&cond_block, dest, src);
-  rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
-  size = gfc_conv_descriptor_ubound_get (dest, rank);
-  size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-                         size, gfc_conv_descriptor_lbound_get (dest, rank));
-  size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-                         size, gfc_index_one_node);
-  if (GFC_TYPE_ARRAY_RANK (type) > 1)
-    size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-                           size, gfc_conv_descriptor_stride_get (dest, rank));
-  esize = fold_convert (gfc_array_index_type,
-                       TYPE_SIZE_UNIT (gfc_get_element_type (type)));
-  size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-                         size, esize);
-  size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
-
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
+      size = gfc_conv_descriptor_ubound_get (dest, rank);
+      size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+                             size,
+                             gfc_conv_descriptor_lbound_get (dest, rank));
+      size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+                             size, gfc_index_one_node);
+      if (GFC_TYPE_ARRAY_RANK (type) > 1)
+       size = fold_build2_loc (input_location, MULT_EXPR,
+                               gfc_array_index_type, size,
+                               gfc_conv_descriptor_stride_get (dest, rank));
+      tree esize = fold_convert (gfc_array_index_type,
+                                TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+                             size, esize);
+      size = unshare_expr (size);
+      size = gfc_evaluate_now (fold_convert (size_type_node, size),
+                              &cond_block);
+    }
+  else
+    size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
    ptr = gfc_create_var (pvoid_type_node, NULL);
    gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
    ptr = gfc_create_var (pvoid_type_node, NULL);
    gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE);
-  gfc_conv_descriptor_data_set (&cond_block, dest, ptr);
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr);
+  else
+    gfc_add_modify (&cond_block, unshare_expr (dest),
+                   fold_convert (TREE_TYPE (dest), ptr));
  
  
+  tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
+               ? gfc_conv_descriptor_data_get (src) : src;
+  srcptr = unshare_expr (srcptr);
+  srcptr = fold_convert (pvoid_type_node, srcptr);
    call = build_call_expr_loc (input_location,
    call = build_call_expr_loc (input_location,
-                         builtin_decl_explicit (BUILT_IN_MEMCPY),
-                         3, ptr,
-                         fold_convert (pvoid_type_node,
-                                       gfc_conv_descriptor_data_get (src)),
-                         size);
+                             builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
+                             srcptr, size);
    gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
    gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
+  if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+    {
+      tree tem = gfc_walk_alloc_comps (src, dest,
+                                      OMP_CLAUSE_DECL (clause),
+                                      WALK_ALLOC_COMPS_COPY_CTOR);
+      gfc_add_expr_to_block (&cond_block, tem);
+    }
    then_b = gfc_finish_block (&cond_block);
  
    gfc_init_block (&cond_block);
    then_b = gfc_finish_block (&cond_block);
  
    gfc_init_block (&cond_block);
-  gfc_conv_descriptor_data_set (&cond_block, dest, null_pointer_node);
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest),
+                                 null_pointer_node);
+  else
+    gfc_add_modify (&cond_block, unshare_expr (dest),
+                   build_zero_cst (TREE_TYPE (dest)));
    else_b = gfc_finish_block (&cond_block);
  
    cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
    else_b = gfc_finish_block (&cond_block);
  
    cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
-                         fold_convert (pvoid_type_node,
-                                       gfc_conv_descriptor_data_get (src)),
-                         null_pointer_node);
-  gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
-                        void_type_node, cond, then_b, else_b));
+                         unshare_expr (srcptr), null_pointer_node);
+  gfc_add_expr_to_block (&block,
+                        build3_loc (input_location, COND_EXPR,
+                                    void_type_node, cond, then_b, else_b));
  
    return gfc_finish_block (&block);
  }
  
  
    return gfc_finish_block (&block);
  }
  
-/* Similarly, except use an assignment operator instead.  */
+/* Similarly, except use an intrinsic or pointer assignment operator
+   instead.  */
  
  tree
  
  tree
-gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
+gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
  {
  {
-  tree type = TREE_TYPE (dest), rank, size, esize, call;
-  stmtblock_t block;
+  tree type = TREE_TYPE (dest), ptr, size, call, nonalloc;
+  tree cond, then_b, else_b;
+  stmtblock_t block, cond_block, cond_block2, inner_block;
  
  
-  if (! GFC_DESCRIPTOR_TYPE_P (type)
-      || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
-    return build2_v (MODIFY_EXPR, dest, src);
+  if ((! GFC_DESCRIPTOR_TYPE_P (type)
+       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
+      && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
+    {
+      if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+       {
+         gfc_start_block (&block);
+         /* First dealloc any allocatable components in DEST.  */
+         tree tem = gfc_walk_alloc_comps (dest, NULL_TREE,
+                                          OMP_CLAUSE_DECL (clause),
+                                          WALK_ALLOC_COMPS_DTOR);
+         gfc_add_expr_to_block (&block, tem);
+         /* Then copy over toplevel data.  */
+         gfc_add_modify (&block, dest, src);
+         /* Finally allocate any allocatable components and copy.  */
+         tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause),
+                                          WALK_ALLOC_COMPS_COPY_CTOR);
+         gfc_add_expr_to_block (&block, tem);
+         return gfc_finish_block (&block);
+       }
+      else
+       return build2_v (MODIFY_EXPR, dest, src);
+    }
  
  
-  /* Handle copying allocatable arrays.  */
    gfc_start_block (&block);
  
    gfc_start_block (&block);
  
-  rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
-  size = gfc_conv_descriptor_ubound_get (dest, rank);
-  size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-                         size, gfc_conv_descriptor_lbound_get (dest, rank));
-  size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-                         size, gfc_index_one_node);
-  if (GFC_TYPE_ARRAY_RANK (type) > 1)
-    size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-                           size, gfc_conv_descriptor_stride_get (dest, rank));
-  esize = fold_convert (gfc_array_index_type,
-                       TYPE_SIZE_UNIT (gfc_get_element_type (type)));
-  size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-                         size, esize);
-  size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
+  if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+    {
+      then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause),
+                                    WALK_ALLOC_COMPS_DTOR);
+      tree tem = fold_convert (pvoid_type_node,
+                              GFC_DESCRIPTOR_TYPE_P (type)
+                              ? gfc_conv_descriptor_data_get (dest) : dest);
+      tem = unshare_expr (tem);
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                             tem, null_pointer_node);
+      tem = build3_loc (input_location, COND_EXPR, void_type_node, cond,
+                       then_b, build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, tem);
+    }
+
+  gfc_init_block (&cond_block);
+
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
+      size = gfc_conv_descriptor_ubound_get (src, rank);
+      size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+                             size,
+                             gfc_conv_descriptor_lbound_get (src, rank));
+      size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+                             size, gfc_index_one_node);
+      if (GFC_TYPE_ARRAY_RANK (type) > 1)
+       size = fold_build2_loc (input_location, MULT_EXPR,
+                               gfc_array_index_type, size,
+                               gfc_conv_descriptor_stride_get (src, rank));
+      tree esize = fold_convert (gfc_array_index_type,
+                                TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+                             size, esize);
+      size = unshare_expr (size);
+      size = gfc_evaluate_now (fold_convert (size_type_node, size),
+                              &cond_block);
+    }
+  else
+    size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type)));
+  ptr = gfc_create_var (pvoid_type_node, NULL);
+
+  tree destptr = GFC_DESCRIPTOR_TYPE_P (type)
+                ? gfc_conv_descriptor_data_get (dest) : dest;
+  destptr = unshare_expr (destptr);
+  destptr = fold_convert (pvoid_type_node, destptr);
+  gfc_add_modify (&cond_block, ptr, destptr);
+
+  nonalloc = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+                             destptr, null_pointer_node);
+  cond = nonalloc;
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      int i;
+      for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++)
+       {
+         tree rank = gfc_rank_cst[i];
+         tree tem = gfc_conv_descriptor_ubound_get (src, rank);
+         tem = fold_build2_loc (input_location, MINUS_EXPR,
+                                gfc_array_index_type, tem,
+                                gfc_conv_descriptor_lbound_get (src, rank));
+         tem = fold_build2_loc (input_location, PLUS_EXPR,
+                                gfc_array_index_type, tem,
+                                gfc_conv_descriptor_lbound_get (dest, rank));
+         tem = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                                tem, gfc_conv_descriptor_ubound_get (dest,
+                                                                     rank));
+         cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+                                 boolean_type_node, cond, tem);
+       }
+    }
+
+  gfc_init_block (&cond_block2);
+
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      gfc_init_block (&inner_block);
+      gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE);
+      then_b = gfc_finish_block (&inner_block);
+
+      gfc_init_block (&inner_block);
+      gfc_add_modify (&inner_block, ptr,
+                     gfc_call_realloc (&inner_block, ptr, size));
+      else_b = gfc_finish_block (&inner_block);
+
+      gfc_add_expr_to_block (&cond_block2,
+                            build3_loc (input_location, COND_EXPR,
+                                        void_type_node,
+                                        unshare_expr (nonalloc),
+                                        then_b, else_b));
+      gfc_add_modify (&cond_block2, dest, src);
+      gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr);
+    }
+  else
+    {
+      gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE);
+      gfc_add_modify (&cond_block2, unshare_expr (dest),
+                     fold_convert (type, ptr));
+    }
+  then_b = gfc_finish_block (&cond_block2);
+  else_b = build_empty_stmt (input_location);
+
+  gfc_add_expr_to_block (&cond_block,
+                        build3_loc (input_location, COND_EXPR,
+                                    void_type_node, unshare_expr (cond),
+                                    then_b, else_b));
+
+  tree srcptr = GFC_DESCRIPTOR_TYPE_P (type)
+               ? gfc_conv_descriptor_data_get (src) : src;
+  srcptr = unshare_expr (srcptr);
+  srcptr = fold_convert (pvoid_type_node, srcptr);
    call = build_call_expr_loc (input_location,
    call = build_call_expr_loc (input_location,
-                         builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
-                         fold_convert (pvoid_type_node,
-                                       gfc_conv_descriptor_data_get (dest)),
-                         fold_convert (pvoid_type_node,
-                                       gfc_conv_descriptor_data_get (src)),
-                         size);
-  gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
+                             builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
+                             srcptr, size);
+  gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
+  if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+    {
+      tree tem = gfc_walk_alloc_comps (src, dest,
+                                      OMP_CLAUSE_DECL (clause),
+                                      WALK_ALLOC_COMPS_COPY_CTOR);
+      gfc_add_expr_to_block (&cond_block, tem);
+    }
+  then_b = gfc_finish_block (&cond_block);
+
+  if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN)
+    {
+      gfc_init_block (&cond_block);
+      if (GFC_DESCRIPTOR_TYPE_P (type))
+       gfc_add_expr_to_block (&cond_block,
+                              gfc_trans_dealloc_allocated (unshare_expr (dest),
+                                                           false, NULL));
+      else
+       {
+         destptr = gfc_evaluate_now (destptr, &cond_block);
+         gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr));
+         gfc_add_modify (&cond_block, unshare_expr (dest),
+                         build_zero_cst (TREE_TYPE (dest)));
+       }
+      else_b = gfc_finish_block (&cond_block);
+
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                             unshare_expr (srcptr), null_pointer_node);
+      gfc_add_expr_to_block (&block,
+                            build3_loc (input_location, COND_EXPR,
+                                        void_type_node, cond,
+                                        then_b, else_b));
+    }
+  else
+    gfc_add_expr_to_block (&block, then_b);
  
    return gfc_finish_block (&block);
  }
  
    return gfc_finish_block (&block);
  }
@@ -321,20 +824,52 @@ gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src)
     to be done.  */
  
  tree
     to be done.  */
  
  tree
-gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
+gfc_omp_clause_dtor (tree clause, tree decl)
  {
  {
-  tree type = TREE_TYPE (decl);
+  tree type = TREE_TYPE (decl), tem;
  
  
-  if (! GFC_DESCRIPTOR_TYPE_P (type)
-      || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
-    return NULL;
+  if ((! GFC_DESCRIPTOR_TYPE_P (type)
+       || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
+      && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)))
+    {
+      if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+       return gfc_walk_alloc_comps (decl, NULL_TREE,
+                                    OMP_CLAUSE_DECL (clause),
+                                    WALK_ALLOC_COMPS_DTOR);
+      return NULL_TREE;
+    }
  
  
-  if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION)
-    return NULL;
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
+       to be deallocated if they were allocated.  */
+    tem = gfc_trans_dealloc_allocated (decl, false, NULL);
+  else
+    tem = gfc_call_free (decl);
+  tem = gfc_omp_unshare_expr (tem);
  
  
-  /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
-     to be deallocated if they were allocated.  */
-  return gfc_trans_dealloc_allocated (decl, false, NULL);
+  if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+    {
+      stmtblock_t block;
+      tree then_b;
+
+      gfc_init_block (&block);
+      gfc_add_expr_to_block (&block,
+                            gfc_walk_alloc_comps (decl, NULL_TREE,
+                                                  OMP_CLAUSE_DECL (clause),
+                                                  WALK_ALLOC_COMPS_DTOR));
+      gfc_add_expr_to_block (&block, tem);
+      then_b = gfc_finish_block (&block);
+
+      tem = fold_convert (pvoid_type_node,
+                         GFC_DESCRIPTOR_TYPE_P (type)
+                         ? gfc_conv_descriptor_data_get (decl) : decl);
+      tem = unshare_expr (tem);
+      tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                                  tem, null_pointer_node);
+      tem = build3_loc (input_location, COND_EXPR, void_type_node, cond,
+                       then_b, build_empty_stmt (input_location));
+    }
+  return tem;
  }
  
  
  }
  
  
@@ -881,47 +1416,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
  
    /* Create the init statement list.  */
    pushlevel ();
  
    /* Create the init statement list.  */
    pushlevel ();
-  if (sym->attr.dimension
-      && GFC_DESCRIPTOR_TYPE_P (type)
-      && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
-    {
-      /* If decl is an allocatable array, it needs to be allocated
-        with the same bounds as the outer var.  */
-      tree rank, size, esize, ptr;
-      stmtblock_t block;
-
-      gfc_start_block (&block);
-
-      gfc_add_modify (&block, decl, outer_sym.backend_decl);
-      rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
-      size = gfc_conv_descriptor_ubound_get (decl, rank);
-      size = fold_build2_loc (input_location, MINUS_EXPR,
-                             gfc_array_index_type, size,
-                             gfc_conv_descriptor_lbound_get (decl, rank));
-      size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-                             size, gfc_index_one_node);
-      if (GFC_TYPE_ARRAY_RANK (type) > 1)
-       size = fold_build2_loc (input_location, MULT_EXPR,
-                               gfc_array_index_type, size,
-                               gfc_conv_descriptor_stride_get (decl, rank));
-      esize = fold_convert (gfc_array_index_type,
-                           TYPE_SIZE_UNIT (gfc_get_element_type (type)));
-      size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-                             size, esize);
-      size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
-
-      ptr = gfc_create_var (pvoid_type_node, NULL);
-      gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE);
-      gfc_conv_descriptor_data_set (&block, decl, ptr);
-
-      if (e2)
-       stmt = gfc_trans_assignment (e1, e2, false, false);
-      else
-       stmt = gfc_trans_omp_udr_expr (n, true, e1, e3);
-      gfc_add_expr_to_block (&block, stmt);
-      stmt = gfc_finish_block (&block);
-    }
-  else if (e2)
+  if (e2)
      stmt = gfc_trans_assignment (e1, e2, false, false);
    else if (sym->attr.dimension)
      stmt = gfc_trans_omp_udr_expr (n, true, e1, e3);
      stmt = gfc_trans_assignment (e1, e2, false, false);
    else if (sym->attr.dimension)
      stmt = gfc_trans_omp_udr_expr (n, true, e1, e3);
@@ -936,25 +1431,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
  
    /* Create the merge statement list.  */
    pushlevel ();
  
    /* Create the merge statement list.  */
    pushlevel ();
-  if (sym->attr.dimension
-      && GFC_DESCRIPTOR_TYPE_P (type)
-      && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
-    {
-      /* If decl is an allocatable array, it needs to be deallocated
-        afterwards.  */
-      stmtblock_t block;
-
-      gfc_start_block (&block);
-      if (e4)
-       stmt = gfc_trans_assignment (e3, e4, false, true);
-      else
-       stmt = gfc_trans_omp_udr_expr (n, false, e1, e3);
-      gfc_add_expr_to_block (&block, stmt);
-      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false,
-                                                                 NULL));
-      stmt = gfc_finish_block (&block);
-    }
-  else if (e4)
+  if (e4)
      stmt = gfc_trans_assignment (e3, e4, false, true);
    else if (sym->attr.dimension)
      stmt = gfc_trans_omp_udr_expr (n, false, e1, e3);
      stmt = gfc_trans_assignment (e3, e4, false, true);
    else if (sym->attr.dimension)
      stmt = gfc_trans_omp_udr_expr (n, false, e1, e3);
@@ -1055,7 +1532,8 @@ gfc_trans_omp_reduction_list (gfc_omp_namelist *namelist, tree list,
                 gcc_unreachable ();
               }
             if (namelist->sym->attr.dimension
                 gcc_unreachable ();
               }
             if (namelist->sym->attr.dimension
-               || namelist->rop == OMP_REDUCTION_USER)
+               || namelist->rop == OMP_REDUCTION_USER
+               || namelist->sym->attr.allocatable)
               gfc_trans_omp_array_reduction_or_udr (node, namelist, where);
             list = gfc_trans_add_clause (node, list);
           }
               gfc_trans_omp_array_reduction_or_udr (node, namelist, where);
             list = gfc_trans_add_clause (node, list);
           }
@@ -2274,8 +2752,9 @@ gfc_trans_omp_do_simd (gfc_code *code, gfc_omp_clauses *clausesa,
        clausesa = clausesa_buf;
        gfc_split_omp_clauses (code, clausesa);
      }
        clausesa = clausesa_buf;
        gfc_split_omp_clauses (code, clausesa);
      }
-  omp_do_clauses
-    = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
+  if (gfc_option.gfc_flag_openmp)
+    omp_do_clauses
+      = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
    pblock = &block;
    body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock,
                            &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
    pblock = &block;
    body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock,
                            &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
@@ -2283,10 +2762,15 @@ gfc_trans_omp_do_simd (gfc_code *code, gfc_omp_clauses *clausesa,
      body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
    else
      poplevel (0, 0);
      body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
    else
      poplevel (0, 0);
-  stmt = make_node (OMP_FOR);
-  TREE_TYPE (stmt) = void_type_node;
-  OMP_FOR_BODY (stmt) = body;
-  OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
+  if (gfc_option.gfc_flag_openmp)
+    {
+      stmt = make_node (OMP_FOR);
+      TREE_TYPE (stmt) = void_type_node;
+      OMP_FOR_BODY (stmt) = body;
+      OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
+    }
+  else
+    stmt = body;
    gfc_add_expr_to_block (&block, stmt);
    return gfc_finish_block (&block);
  }
    gfc_add_expr_to_block (&block, stmt);
    return gfc_finish_block (&block);
  }
@@ -2332,18 +2816,22 @@ gfc_trans_omp_parallel_do_simd (gfc_code *code)
    gfc_start_block (&block);
  
    gfc_split_omp_clauses (code, clausesa);
    gfc_start_block (&block);
  
    gfc_split_omp_clauses (code, clausesa);
-  omp_clauses
-    = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
-                            code->loc);
+  if (gfc_option.gfc_flag_openmp)
+    omp_clauses
+      = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
+                              code->loc);
    pushlevel ();
    stmt = gfc_trans_omp_do_simd (code, clausesa, omp_clauses);
    if (TREE_CODE (stmt) != BIND_EXPR)
      stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
    else
      poplevel (0, 0);
    pushlevel ();
    stmt = gfc_trans_omp_do_simd (code, clausesa, omp_clauses);
    if (TREE_CODE (stmt) != BIND_EXPR)
      stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
    else
      poplevel (0, 0);
-  stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
-                    omp_clauses);
-  OMP_PARALLEL_COMBINED (stmt) = 1;
+  if (gfc_option.gfc_flag_openmp)
+    {
+      stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
+                        omp_clauses);
+      OMP_PARALLEL_COMBINED (stmt) = 1;
+    }
    gfc_add_expr_to_block (&block, stmt);
    return gfc_finish_block (&block);
  }
    gfc_add_expr_to_block (&block, stmt);
    return gfc_finish_block (&block);
  }
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c

index d9aab47..71a159b 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2160,9 +2160,6 @@ gfc_sym_type (gfc_symbol * sym)
                                                 restricted);
               byref = 0;
             }
                                                 restricted);
               byref = 0;
             }
-
-         if (sym->attr.cray_pointee)
-           GFC_POINTER_TYPE_P (type) = 1;
          }
        else
         {
          }
        else
         {
@@ -2181,8 +2178,6 @@ gfc_sym_type (gfc_symbol * sym)
        if (sym->attr.allocatable || sym->attr.pointer
           || gfc_is_associate_pointer (sym))
         type = gfc_build_pointer_type (sym, type);
        if (sym->attr.allocatable || sym->attr.pointer
           || gfc_is_associate_pointer (sym))
         type = gfc_build_pointer_type (sym, type);
-      if (sym->attr.pointer || sym->attr.cray_pointee)
-       GFC_POINTER_TYPE_P (type) = 1;
      }
  
    /* We currently pass all parameters by reference.
      }
  
    /* We currently pass all parameters by reference.
@@ -2552,6 +2547,8 @@ gfc_get_derived_type (gfc_symbol * derived)
        else if (derived->declared_at.lb)
         gfc_set_decl_location (field, &derived->declared_at);
  
        else if (derived->declared_at.lb)
         gfc_set_decl_location (field, &derived->declared_at);
  
+      gfc_finish_decl_attrs (field, &c->attr);
+
        DECL_PACKED (field) |= TYPE_PACKED (typenode);
  
        gcc_assert (field);
        DECL_PACKED (field) |= TYPE_PACKED (typenode);
  
        gcc_assert (field);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h

index def6b9d..7e8d08c 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -547,6 +547,9 @@ void gfc_set_decl_assembler_name (tree, tree);
  /* Returns true if a variable of specified size should go on the stack.  */
  int gfc_can_put_var_on_stack (tree);
  
  /* Returns true if a variable of specified size should go on the stack.  */
  int gfc_can_put_var_on_stack (tree);
  
+/* Set GFC_DECL_SCALAR_* on decl from sym if needed.  */
+void gfc_finish_decl_attrs (tree, symbol_attribute *);
+
  /* Allocate the lang-specific part of a decl node.  */
  void gfc_allocate_lang_decl (tree);
  
  /* Allocate the lang-specific part of a decl node.  */
  void gfc_allocate_lang_decl (tree);
  
@@ -822,6 +825,8 @@ struct GTY(()) lang_decl {
    tree span;
    /* For assumed-shape coarrays.  */
    tree token, caf_offset;
    tree span;
    /* For assumed-shape coarrays.  */
    tree token, caf_offset;
+  unsigned int scalar_allocatable : 1;
+  unsigned int scalar_pointer : 1;
  };
  
  
  };
  
  
@@ -832,6 +837,14 @@ struct GTY(()) lang_decl {
  #define GFC_DECL_CAF_OFFSET(node) DECL_LANG_SPECIFIC(node)->caf_offset
  #define GFC_DECL_SAVED_DESCRIPTOR(node) \
    (DECL_LANG_SPECIFIC(node)->saved_descriptor)
  #define GFC_DECL_CAF_OFFSET(node) DECL_LANG_SPECIFIC(node)->caf_offset
  #define GFC_DECL_SAVED_DESCRIPTOR(node) \
    (DECL_LANG_SPECIFIC(node)->saved_descriptor)
+#define GFC_DECL_SCALAR_ALLOCATABLE(node) \
+  (DECL_LANG_SPECIFIC (node)->scalar_allocatable)
+#define GFC_DECL_SCALAR_POINTER(node) \
+  (DECL_LANG_SPECIFIC (node)->scalar_pointer)
+#define GFC_DECL_GET_SCALAR_ALLOCATABLE(node) \
+  (DECL_LANG_SPECIFIC (node) ? GFC_DECL_SCALAR_ALLOCATABLE (node) : 0)
+#define GFC_DECL_GET_SCALAR_POINTER(node) \
+  (DECL_LANG_SPECIFIC (node) ? GFC_DECL_SCALAR_POINTER (node) : 0)
  #define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
  #define GFC_DECL_PARTIAL_PACKED_ARRAY(node) DECL_LANG_FLAG_1(node)
  #define GFC_DECL_ASSIGN(node) DECL_LANG_FLAG_2(node)
  #define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
  #define GFC_DECL_PARTIAL_PACKED_ARRAY(node) DECL_LANG_FLAG_1(node)
  #define GFC_DECL_ASSIGN(node) DECL_LANG_FLAG_2(node)
@@ -839,14 +852,13 @@ struct GTY(()) lang_decl {
  #define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
  #define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
  #define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node)
  #define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
  #define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
  #define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node)
+#define GFC_DECL_ASSOCIATE_VAR_P(node) DECL_LANG_FLAG_7(node)
  #define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node)
  
  /* An array descriptor.  */
  #define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
  /* An array without a descriptor.  */
  #define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node)
  #define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node)
  
  /* An array descriptor.  */
  #define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
  /* An array without a descriptor.  */
  #define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node)
-/* Fortran POINTER type.  */
-#define GFC_POINTER_TYPE_P(node) TYPE_LANG_FLAG_3(node)
  /* Fortran CLASS type.  */
  #define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node)
  /* The GFC_TYPE_ARRAY_* members are present in both descriptor and
  /* Fortran CLASS type.  */
  #define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node)
  /* The GFC_TYPE_ARRAY_* members are present in both descriptor and
diff --git a/gcc/omp-low.c b/gcc/omp-low.c

index 0f400b0..ddb049d 100644 (file)
--- a/gcc/omp-low.c
+++ b/gcc/omp-low.c
@@ -3110,6 +3110,13 @@ lower_rec_input_clauses (tree clauses, gimple_seq *ilist, gimple_seq *dlist,
                   if (pass != 0)
                     continue;
                 }
                   if (pass != 0)
                     continue;
                 }
+             /* Even without corresponding firstprivate, if
+                decl is Fortran allocatable, it needs outer var
+                reference.  */
+             else if (pass == 0
+                      && lang_hooks.decls.omp_private_outer_ref
+                                                       (OMP_CLAUSE_DECL (c)))
+               lastprivate_firstprivate = true;
               break;
             case OMP_CLAUSE_ALIGNED:
               if (pass == 0)
               break;
             case OMP_CLAUSE_ALIGNED:
               if (pass == 0)
@@ -3545,7 +3552,8 @@ lower_rec_input_clauses (tree clauses, gimple_seq *ilist, gimple_seq *dlist,
                   else if (is_reference (var) && is_simd)
                     handle_simd_reference (clause_loc, new_vard, ilist);
                   x = lang_hooks.decls.omp_clause_default_ctor
                   else if (is_reference (var) && is_simd)
                     handle_simd_reference (clause_loc, new_vard, ilist);
                   x = lang_hooks.decls.omp_clause_default_ctor
-                               (c, new_var, unshare_expr (x));
+                               (c, unshare_expr (new_var),
+                                build_outer_var_ref (var, ctx));
                   if (x)
                     gimplify_and_add (x, ilist);
                   if (OMP_CLAUSE_REDUCTION_GIMPLE_INIT (c))
                   if (x)
                     gimplify_and_add (x, ilist);
                   if (OMP_CLAUSE_REDUCTION_GIMPLE_INIT (c))
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog

index b307bd3..b8a1649 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,15 @@
+2014-06-10  Jakub Jelinek  <jakub@redhat.com>
+
+       PR fortran/60928
+       * gfortran.dg/gomp/allocatable_components_1.f90: Remove dg-error
+       directives.
+       * gfortran.dg/gomp/associate1.f90: New test.
+       * gfortran.dg/gomp/intentin1.f90: New test.
+       * gfortran.dg/gomp/openmp-simd-1.f90: New test.
+       * gfortran.dg/gomp/openmp-simd-2.f90: New test.
+       * gfortran.dg/gomp/openmp-simd-3.f90: New test.
+       * gfortran.dg/gomp/proc_ptr_2.f90: New test.
+
  2014-06-09  Marek Polacek  <polacek@redhat.com>
  
         PR c/36446
  2014-06-09  Marek Polacek  <polacek@redhat.com>
  
         PR c/36446
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90 b/gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90

index 8e4e539..bc06cc8 100644 (file)
--- a/gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90
@@ -14,7 +14,7 @@ CONTAINS
      TYPE(t), SAVE :: a
  
      !$omp threadprivate(a)
      TYPE(t), SAVE :: a
  
      !$omp threadprivate(a)
-    !$omp parallel copyin(a)        ! { dg-error "has ALLOCATABLE components" }
+    !$omp parallel copyin(a)
        ! do something
      !$omp end parallel
    END SUBROUTINE
        ! do something
      !$omp end parallel
    END SUBROUTINE
@@ -22,7 +22,7 @@ CONTAINS
    SUBROUTINE test_copyprivate()
      TYPE(t) :: a
  
    SUBROUTINE test_copyprivate()
      TYPE(t) :: a
  
-    !$omp single                    ! { dg-error "has ALLOCATABLE components" }
+    !$omp single
        ! do something
      !$omp end single copyprivate (a)
    END SUBROUTINE
        ! do something
      !$omp end single copyprivate (a)
    END SUBROUTINE
@@ -30,7 +30,7 @@ CONTAINS
    SUBROUTINE test_firstprivate
      TYPE(t) :: a
  
    SUBROUTINE test_firstprivate
      TYPE(t) :: a
  
-    !$omp parallel firstprivate(a)  ! { dg-error "has ALLOCATABLE components" }
+    !$omp parallel firstprivate(a)
        ! do something
      !$omp end parallel
    END SUBROUTINE
        ! do something
      !$omp end parallel
    END SUBROUTINE
@@ -39,7 +39,7 @@ CONTAINS
      TYPE(t) :: a
      INTEGER :: i
  
      TYPE(t) :: a
      INTEGER :: i
  
-    !$omp parallel do lastprivate(a)  ! { dg-error "has ALLOCATABLE components" }
+    !$omp parallel do lastprivate(a)
        DO i = 1, 1
        END DO
      !$omp end parallel do
        DO i = 1, 1
        END DO
      !$omp end parallel do
diff --git a/gcc/testsuite/gfortran.dg/gomp/associate1.f90 b/gcc/testsuite/gfortran.dg/gomp/associate1.f90

new file mode 100644 (file)

index 0000000..abc5ae9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/associate1.f90
@@ -0,0 +1,83 @@
+! { dg-do compile }
+
+program associate1
+  type dl
+    integer :: i
+  end type
+  type dt
+    integer :: i
+    real :: a(3, 3)
+    type(dl) :: c(3, 3)
+  end type
+  integer :: v, i, j
+  real :: a(3, 3)
+  type(dt) :: b(3)
+  i = 1
+  j = 2
+  associate(k => v, l => a(i, j), m => a(i, :))
+  associate(n => b(j)%c(:, :)%i, o => a, p => b)
+!$omp parallel shared (l)      ! { dg-error "ASSOCIATE name" }
+!$omp end parallel
+!$omp parallel firstprivate (m)        ! { dg-error "ASSOCIATE name" }
+!$omp end parallel
+!$omp parallel reduction (+: k)        ! { dg-error "ASSOCIATE name" }
+!$omp end parallel
+!$omp parallel do firstprivate (k)     ! { dg-error "ASSOCIATE name" }
+  do i = 1, 10
+  end do
+!$omp parallel do lastprivate (n)      ! { dg-error "ASSOCIATE name" }
+  do i = 1, 10
+  end do
+!$omp parallel do private (o)  ! { dg-error "ASSOCIATE name" }
+  do i = 1, 10
+  end do
+!$omp parallel do shared (p)   ! { dg-error "ASSOCIATE name" }
+  do i = 1, 10
+  end do
+!$omp task private (k)         ! { dg-error "ASSOCIATE name" }
+!$omp end task
+!$omp task shared (l)          ! { dg-error "ASSOCIATE name" }
+!$omp end task
+!$omp task firstprivate (m)    ! { dg-error "ASSOCIATE name" }
+!$omp end task
+!$omp do private (l)           ! { dg-error "ASSOCIATE name" }
+  do i = 1, 10
+  end do
+!$omp do reduction (*: k)      ! { dg-error "ASSOCIATE name" }
+  do i = 1, 10
+  end do
+!$omp sections private(o)      ! { dg-error "ASSOCIATE name" }
+!$omp section
+!$omp section
+!$omp end sections
+!$omp parallel sections firstprivate(p)        ! { dg-error "ASSOCIATE name" }
+!$omp section
+!$omp section
+!$omp endparallelsections
+!$omp parallelsections lastprivate(m)  ! { dg-error "ASSOCIATE name" }
+!$omp section
+!$omp section
+!$omp endparallelsections
+!$omp sections reduction(+:k)  ! { dg-error "ASSOCIATE name" }
+!$omp section
+!$omp section
+!$omp end sections
+!$omp simd private (l)         ! { dg-error "ASSOCIATE name" }
+  do i = 1, 10
+  end do
+  k = 1
+!$omp simd lastprivate (m)     ! { dg-error "ASSOCIATE name" }
+  do i = 1, 10
+  end do
+  k = 1
+!$omp simd reduction (+: k)    ! { dg-error "ASSOCIATE name" }
+  do i = 1, 10
+  end do
+  k = 1
+!$omp simd linear (k : 2)      ! { dg-error "ASSOCIATE name" }
+  do i = 1, 10
+    k = k + 2
+  end do
+  end associate
+  end associate
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/intentin1.f90 b/gcc/testsuite/gfortran.dg/gomp/intentin1.f90

new file mode 100644 (file)

index 0000000..f2a2e98
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/intentin1.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+
+subroutine foo (x)
+  integer, pointer, intent (in) :: x
+  integer :: i
+!$omp parallel private (x)             ! { dg-error "INTENT.IN. POINTER" }
+!$omp end parallel
+!$omp parallel do lastprivate (x)      ! { dg-error "INTENT.IN. POINTER" }
+  do i = 1, 10
+  end do
+!$omp simd linear (x)                  ! { dg-error "INTENT.IN. POINTER" }
+  do i = 1, 10
+  end do
+!$omp single                           ! { dg-error "INTENT.IN. POINTER" }
+!$omp end single copyprivate (x)
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/openmp-simd-1.f90 b/gcc/testsuite/gfortran.dg/gomp/openmp-simd-1.f90

new file mode 100644 (file)

index 0000000..c9ce70c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/openmp-simd-1.f90
@@ -0,0 +1,137 @@
+! { dg-do compile }
+! { dg-options "-fno-openmp -fopenmp-simd -fdump-tree-original -O2" }
+
+!$omp declare reduction (foo:integer:omp_out = omp_out + omp_in)
+  interface
+    integer function foo (x, y)
+      integer, value :: x, y
+!$omp declare simd (foo) linear (y : 2)
+    end function foo
+  end interface
+  integer :: i, a(64), b, c
+  integer, save :: d
+!$omp threadprivate (d)
+  d = 5
+  a = 6
+!$omp simd
+  do i = 1, 64
+    a(i) = foo (a(i), 2 * i)
+  end do
+  b = 0
+  c = 0
+!$omp simd reduction (+:b) reduction (foo:c)
+  do i = 1, 64
+    b = b + a(i)
+    c = c + a(i) * 2
+  end do
+  print *, b
+  b = 0
+!$omp parallel
+!$omp do simd schedule(static, 4) safelen (8) reduction (+:b)
+  do i = 1, 64
+    a(i) = a(i) + 1
+    b = b + 1
+  end do
+!$omp end parallel
+  print *, b
+  b = 0
+!$omp parallel do simd schedule(static, 4) safelen (8) &
+!$omp num_threads (4) if (.true.) reduction (+:b)
+  do i = 1, 64
+    a(i) = a(i) + 1
+    b = b + 1
+  end do
+  print *, b
+  b = 0
+!$omp parallel
+!$omp do simd schedule(static, 4) safelen (8) reduction (+:b)
+  do i = 1, 64
+    a(i) = a(i) + 1
+    b = b + 1
+  end do
+!$omp enddosimd
+!$omp end parallel
+  print *, b
+  b = 0
+!$omp parallel do simd schedule(static, 4) safelen (8) &
+!$omp num_threads (4) if (.true.) reduction (+:b)
+  do i = 1, 64
+    a(i) = a(i) + 1
+    b = b + 1
+  end do
+!$omp end parallel do simd
+!$omp atomic seq_cst
+  b = b + 1
+!$omp end atomic
+!$omp barrier
+!$omp parallel private (i)
+!$omp cancellation point parallel
+!$omp critical (bar)
+  b = b + 1
+!$omp end critical (bar)
+!$omp flush(b)
+!$omp single
+  b = b + 1
+!$omp end single
+!$omp do ordered
+  do i = 1, 10
+    !$omp atomic
+    b = b + 1
+    !$omp end atomic
+    !$omp ordered
+      print *, b
+    !$omp end ordered
+  end do
+!$omp end do
+!$omp master
+  b = b + 1
+!$omp end master
+!$omp cancel parallel
+!$omp end parallel
+!$omp parallel do schedule(runtime) num_threads(8)
+  do i = 1, 10
+    print *, b
+  end do
+!$omp end parallel do
+!$omp sections
+!$omp section
+  b = b + 1
+!$omp section
+  c = c + 1
+!$omp end sections
+  print *, b
+!$omp parallel sections firstprivate (b) if (.true.)
+!$omp section
+  b = b + 1
+!$omp section
+  c = c + 1
+!$omp endparallelsections
+!$omp workshare
+  b = 24
+!$omp end workshare
+!$omp parallel workshare num_threads (2)
+  b = b + 1
+  c = c + 1
+!$omp end parallel workshare
+  print *, b
+!$omp parallel
+!$omp single
+!$omp taskgroup
+!$omp task firstprivate (b)
+  b = b + 1
+!$omp taskyield
+!$omp end task
+!$omp task firstprivate (b)
+  b = b + 1
+!$omp end task
+!$omp taskwait
+!$omp end taskgroup
+!$omp end single
+!$omp end parallel
+  print *, a, c
+end
+
+! { dg-final { scan-tree-dump-times "pragma omp simd" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp" 6 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/openmp-simd-2.f90 b/gcc/testsuite/gfortran.dg/gomp/openmp-simd-2.f90

new file mode 100644 (file)

index 0000000..4b2046a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/openmp-simd-2.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+! { dg-options "-fopenmp -fopenmp-simd -fdump-tree-original -O2" }
+
+include 'openmp-simd-1.f90'
+
+! { dg-final { scan-tree-dump-times "pragma omp simd" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp" 39 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp for" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp parallel" 9 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp taskgroup" 1 "original" } }
+! Includes the above taskgroup
+! { dg-final { scan-tree-dump-times "pragma omp task" 3 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp critical" 1 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp atomic" 2 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp sections" 2 "original" } }
+! Includes the above sections
+! { dg-final { scan-tree-dump-times "pragma omp section" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp single" 4 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp ordered" 1 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp master" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP" 5 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_barrier" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancellation_point" 1 "original" } }
+! Includes the above cancellation point
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel" 2 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskyield" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskwait" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/openmp-simd-3.f90 b/gcc/testsuite/gfortran.dg/gomp/openmp-simd-3.f90

new file mode 100644 (file)

index 0000000..2dece89
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/openmp-simd-3.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+! { dg-options "-fopenmp -fno-openmp-simd -fdump-tree-original -O2" }
+
+include 'openmp-simd-1.f90'
+
+! { dg-final { scan-tree-dump-times "pragma omp simd" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp" 39 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp for" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp parallel" 9 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp taskgroup" 1 "original" } }
+! Includes the above taskgroup
+! { dg-final { scan-tree-dump-times "pragma omp task" 3 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp critical" 1 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp atomic" 2 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp sections" 2 "original" } }
+! Includes the above sections
+! { dg-final { scan-tree-dump-times "pragma omp section" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp single" 4 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp ordered" 1 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp master" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP" 5 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_barrier" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancellation_point" 1 "original" } }
+! Includes the above cancellation point
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel" 2 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskyield" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskwait" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/proc_ptr_2.f90 b/gcc/testsuite/gfortran.dg/gomp/proc_ptr_2.f90

new file mode 100644 (file)

index 0000000..d993429
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/proc_ptr_2.f90
@@ -0,0 +1,14 @@
+! { dg-do compile }
+  procedure(foo), pointer :: ptr
+  integer :: i
+  ptr => foo
+!$omp do reduction (+ : ptr)   ! { dg-error "Procedure pointer|not found" }
+  do i = 1, 10
+  end do
+!$omp simd linear (ptr)                ! { dg-error "must be INTEGER" }
+  do i = 1, 10
+  end do
+contains
+  subroutine foo
+  end subroutine
+end
diff --git a/libgomp/ChangeLog b/libgomp/ChangeLog

index ff389bc..8e6d37a 100644 (file)
--- a/libgomp/ChangeLog
+++ b/libgomp/ChangeLog
@@ -1,3 +1,17 @@
+2014-06-10  Jakub Jelinek  <jakub@redhat.com>
+
+       PR fortran/60928
+       * testsuite/libgomp.fortran/allocatable9.f90: New test.
+       * testsuite/libgomp.fortran/allocatable10.f90: New test.
+       * testsuite/libgomp.fortran/allocatable11.f90: New test.
+       * testsuite/libgomp.fortran/allocatable12.f90: New test.
+       * testsuite/libgomp.fortran/alloc-comp-1.f90: New test.
+       * testsuite/libgomp.fortran/alloc-comp-2.f90: New test.
+       * testsuite/libgomp.fortran/alloc-comp-3.f90: New test.
+       * testsuite/libgomp.fortran/associate1.f90: New test.
+       * testsuite/libgomp.fortran/associate2.f90: New test.
+       * testsuite/libgomp.fortran/procptr1.f90: New test.
+
  2014-06-06  Jakub Jelinek  <jakub@redhat.com>
  
         * testsuite/libgomp.fortran/simd1.f90: New test.
  2014-06-06  Jakub Jelinek  <jakub@redhat.com>
  
         * testsuite/libgomp.fortran/simd1.f90: New test.
diff --git a/libgomp/testsuite/libgomp.fortran/alloc-comp-1.f90 b/libgomp/testsuite/libgomp.fortran/alloc-comp-1.f90

new file mode 100644 (file)

index 0000000..2a2a12e
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/alloc-comp-1.f90
@@ -0,0 +1,328 @@
+! { dg-do run }
+! Don't cycle by default through all options, just test -O0 and -O2,
+! as this is quite large test.
+! { dg-skip-if "" { ! run_expensive_tests } { "*" } { "-O0" "-O2" } }
+
+module m
+  type dl
+    integer :: a, b
+    integer, allocatable :: c(:,:)
+    integer :: d, e
+    integer, allocatable :: f
+  end type
+  type dt
+    integer :: g
+    type (dl), allocatable :: h(:)
+    integer :: i
+    type (dl) :: j(2, 2)
+    type (dl), allocatable :: k
+  end type
+contains
+  subroutine ver_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
+    type (dl), intent (in) :: obj
+    integer, intent (in) :: val, cl1, cu1, cl2, cu2
+    logical, intent (in) :: c, f
+    if ((c .neqv. allocated (obj%c)) .or. (f .neqv. allocated (obj%f))) call abort
+    if (c) then
+      if (lbound (obj%c, 1) /= cl1 .or. ubound (obj%c, 1) /= cu1) call abort
+      if (lbound (obj%c, 2) /= cl2 .or. ubound (obj%c, 2) /= cu2) call abort
+    end if
+    if (val /= 0) then
+      if (obj%a /= val .or. obj%b /= val) call abort
+      if (obj%d /= val .or. obj%e /= val) call abort
+      if (c) then
+        if (any (obj%c /= val)) call abort
+      end if
+      if (f) then
+        if (obj%f /= val) call abort
+      end if
+    end if
+  end subroutine ver_dl
+  subroutine ver_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
+    type (dt), intent (in) :: obj
+    integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
+    logical, intent (in) :: h, k, c, f
+    integer :: i, j
+    if ((h .neqv. allocated (obj%h)) .or. (k .neqv. allocated (obj%k))) call abort
+    if (h) then
+      if (lbound (obj%h, 1) /= hl .or. ubound (obj%h, 1) /= hu) call abort
+      do i = hl, hu
+        call ver_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
+      end do
+    end if
+    do i = 1, 2
+      do j = 1, 2
+        call ver_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
+      end do
+    end do
+    if (k) call ver_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
+    if (val /= 0) then
+      if (obj%g /= val .or. obj%i /= val) call abort
+    end if
+  end subroutine ver_dt
+  subroutine alloc_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
+    type (dl), intent (inout) :: obj
+    integer, intent (in) :: val, cl1, cu1, cl2, cu2
+    logical, intent (in) :: c, f
+    if (val /= 0) then
+      obj%a = val
+      obj%b = val
+      obj%d = val
+      obj%e = val
+    end if
+    if (allocated (obj%c)) deallocate (obj%c)
+    if (c) then
+      allocate (obj%c(cl1:cu1, cl2:cu2))
+      if (val /= 0) obj%c = val
+    end if
+    if (f) then
+      if (.not.allocated (obj%f)) allocate (obj%f)
+      if (val /= 0) obj%f = val
+    else
+      if (allocated (obj%f)) deallocate (obj%f)
+    end if
+  end subroutine alloc_dl
+  subroutine alloc_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
+    type (dt), intent (inout) :: obj
+    integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
+    logical, intent (in) :: h, k, c, f
+    integer :: i, j
+    if (val /= 0) then
+      obj%g = val
+      obj%i = val
+    end if
+    if (allocated (obj%h)) deallocate (obj%h)
+    if (h) then
+      allocate (obj%h(hl:hu))
+      do i = hl, hu
+        call alloc_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
+      end do
+    end if
+    do i = 1, 2
+      do j = 1, 2
+        call alloc_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
+      end do
+    end do
+    if (k) then
+      if (.not.allocated (obj%k)) allocate (obj%k)
+      call alloc_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
+    else
+      if (allocated (obj%k)) deallocate (obj%k)
+    end if
+  end subroutine alloc_dt
+end module m
+  use m
+  type (dt) :: y
+  call foo (y)
+contains
+  subroutine foo (y)
+    use m
+    type (dt) :: x, y, z(-3:-3,2:3)
+    logical, parameter :: F = .false.
+    logical, parameter :: T = .true.
+    logical :: l
+    call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel private (x, y, z)
+    call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    call ver_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+!$omp end parallel
+    call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+!$omp parallel private (x, y, z)
+    call ver_dt (x, 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y, 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    deallocate (x%h, x%k)
+    deallocate (y%h)
+    allocate (y%k)
+    call ver_dt (z(-3,2), 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    deallocate (z(-3,2)%h, z(-3,2)%k)
+    deallocate (z(-3,3)%h)
+    allocate (z(-3,3)%k)
+!$omp end parallel
+    call alloc_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+!$omp parallel firstprivate (x, y, z)
+    call ver_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (y, 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+    call ver_dt (y, 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+!$omp end parallel
+    call ver_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel firstprivate (x, y, z)
+    call ver_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y, 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+    call ver_dt (y, 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+    call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+    call ver_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+!$omp end parallel
+    call ver_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y, 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
+    call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
+    l = F
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+    if (l) then
+      call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+      call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    else
+      call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+      call ver_dt (y, 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+      call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+      call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+    end if
+    l = T
+    call alloc_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+    call ver_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+    call alloc_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+    call ver_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+    call alloc_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+    call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+    call alloc_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+    call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+!$omp section
+    if (l) then
+      call ver_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+      call ver_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+      call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+      call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+    else
+      call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+      call ver_dt (y, 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+      call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+      call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+    end if
+    l = T
+    call alloc_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call alloc_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    call alloc_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call alloc_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+!$omp section
+!$omp end parallel sections
+    call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+    if (l) then
+      call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+      call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+      call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+      call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    else
+      call ver_dt (x, 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (y, 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+      call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    end if
+    l = T
+    call alloc_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call alloc_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp section
+    if (l) then
+      call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+      call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+      call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+      call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    else
+      call ver_dt (x, 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (y, 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+      call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    end if
+    l = T
+    call alloc_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call alloc_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp section
+!$omp end parallel sections
+    call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp parallel private (x, y, z)
+    call ver_dt (x, 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (y, 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,2), 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp single
+    call alloc_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call alloc_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp end single copyprivate (x, y, z)
+    call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp end parallel
+    call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+  end subroutine foo
+end
diff --git a/libgomp/testsuite/libgomp.fortran/alloc-comp-2.f90 b/libgomp/testsuite/libgomp.fortran/alloc-comp-2.f90

new file mode 100644 (file)

index 0000000..490ed24
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/alloc-comp-2.f90
@@ -0,0 +1,367 @@
+! { dg-do run }
+! Don't cycle by default through all options, just test -O0 and -O2,
+! as this is quite large test.
+! { dg-skip-if "" { ! run_expensive_tests } { "*" } { "-O0" "-O2" } }
+
+module m
+  type dl
+    integer :: a, b
+    integer, allocatable :: c(:,:)
+    integer :: d, e
+    integer, allocatable :: f
+  end type
+  type dt
+    integer :: g
+    type (dl), allocatable :: h(:)
+    integer :: i
+    type (dl) :: j(2, 2)
+    type (dl), allocatable :: k
+  end type
+contains
+  subroutine ver_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
+    type (dl), intent (in) :: obj
+    integer, intent (in) :: val, cl1, cu1, cl2, cu2
+    logical, intent (in) :: c, f
+    if ((c .neqv. allocated (obj%c)) .or. (f .neqv. allocated (obj%f))) call abort
+    if (c) then
+      if (lbound (obj%c, 1) /= cl1 .or. ubound (obj%c, 1) /= cu1) call abort
+      if (lbound (obj%c, 2) /= cl2 .or. ubound (obj%c, 2) /= cu2) call abort
+    end if
+    if (val /= 0) then
+      if (obj%a /= val .or. obj%b /= val) call abort
+      if (obj%d /= val .or. obj%e /= val) call abort
+      if (c) then
+        if (any (obj%c /= val)) call abort
+      end if
+      if (f) then
+        if (obj%f /= val) call abort
+      end if
+    end if
+  end subroutine ver_dl
+  subroutine ver_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
+    type (dt), intent (in) :: obj
+    integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
+    logical, intent (in) :: h, k, c, f
+    integer :: i, j
+    if ((h .neqv. allocated (obj%h)) .or. (k .neqv. allocated (obj%k))) call abort
+    if (h) then
+      if (lbound (obj%h, 1) /= hl .or. ubound (obj%h, 1) /= hu) call abort
+      do i = hl, hu
+        call ver_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
+      end do
+    end if
+    do i = 1, 2
+      do j = 1, 2
+        call ver_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
+      end do
+    end do
+    if (k) call ver_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
+    if (val /= 0) then
+      if (obj%g /= val .or. obj%i /= val) call abort
+    end if
+  end subroutine ver_dt
+  subroutine alloc_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
+    type (dl), intent (inout) :: obj
+    integer, intent (in) :: val, cl1, cu1, cl2, cu2
+    logical, intent (in) :: c, f
+    if (val /= 0) then
+      obj%a = val
+      obj%b = val
+      obj%d = val
+      obj%e = val
+    end if
+    if (allocated (obj%c)) deallocate (obj%c)
+    if (c) then
+      allocate (obj%c(cl1:cu1, cl2:cu2))
+      if (val /= 0) obj%c = val
+    end if
+    if (f) then
+      if (.not.allocated (obj%f)) allocate (obj%f)
+      if (val /= 0) obj%f = val
+    else
+      if (allocated (obj%f)) deallocate (obj%f)
+    end if
+  end subroutine alloc_dl
+  subroutine alloc_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
+    type (dt), intent (inout) :: obj
+    integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
+    logical, intent (in) :: h, k, c, f
+    integer :: i, j
+    if (val /= 0) then
+      obj%g = val
+      obj%i = val
+    end if
+    if (allocated (obj%h)) deallocate (obj%h)
+    if (h) then
+      allocate (obj%h(hl:hu))
+      do i = hl, hu
+        call alloc_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
+      end do
+    end if
+    do i = 1, 2
+      do j = 1, 2
+        call alloc_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
+      end do
+    end do
+    if (k) then
+      if (.not.allocated (obj%k)) allocate (obj%k)
+      call alloc_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
+    else
+      if (allocated (obj%k)) deallocate (obj%k)
+    end if
+  end subroutine alloc_dt
+end module m
+  use m
+  type (dt), allocatable :: y
+  call foo (y)
+contains
+  subroutine foo (y)
+    use m
+    type (dt), allocatable :: x, y, z(:,:)
+    logical, parameter :: F = .false.
+    logical, parameter :: T = .true.
+    logical :: l
+!$omp parallel private (x, y, z)
+    if (allocated (x) .or. allocated (y) .or. allocated (z)) call abort
+!$omp end parallel
+!$omp parallel firstprivate (x, y, z)
+    if (allocated (x) .or. allocated (y) .or. allocated (z)) call abort
+!$omp end parallel
+    l = F
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+    if (.not. l) then
+      if (allocated (x) .or. allocated (y) .or. allocated (z)) call abort
+    end if
+!$omp section
+    if (.not. l) then
+      if (allocated (x) .or. allocated (y) .or. allocated (z)) call abort
+    end if
+    allocate (x, y, z(-3:-3,2:3))
+    call alloc_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call alloc_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp section
+!$omp end parallel sections
+    if (.not.allocated (x) .or. .not.allocated (y)) call abort
+    if (.not.allocated (z)) call abort
+    if (lbound (z, 1) /= -3 .or. ubound (z, 1) /= -3) call abort
+    if (lbound (z, 2) /= 2 .or. ubound (z, 2) /= 3) call abort
+    call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call alloc_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel private (x, y, z)
+    call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    call ver_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+!$omp end parallel
+    call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+!$omp parallel private (x, y, z)
+    call ver_dt (x, 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y, 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    deallocate (x%h, x%k)
+    deallocate (y%h)
+    allocate (y%k)
+    call ver_dt (z(-3,2), 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    deallocate (z(-3,2)%h, z(-3,2)%k)
+    deallocate (z(-3,3)%h)
+    allocate (z(-3,3)%k)
+!$omp end parallel
+    call alloc_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+!$omp parallel firstprivate (x, y, z)
+    call ver_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (y, 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+    call ver_dt (y, 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+!$omp end parallel
+    call ver_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel firstprivate (x, y, z)
+    call ver_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y, 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+    call ver_dt (y, 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+    call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+    call ver_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+!$omp end parallel
+    call ver_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y, 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
+    call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
+    l = F
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+    if (l) then
+      call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+      call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    else
+      call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+      call ver_dt (y, 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+      call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+      call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+    end if
+    l = T
+    call alloc_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+    call ver_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+    call alloc_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+    call ver_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+    call alloc_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+    call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+    call alloc_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+    call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+!$omp section
+    if (l) then
+      call ver_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+      call ver_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+      call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+      call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+    else
+      call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+      call ver_dt (y, 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+      call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+      call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+    end if
+    l = T
+    call alloc_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call alloc_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    call alloc_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call alloc_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+!$omp section
+!$omp end parallel sections
+    call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+    if (l) then
+      call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+      call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+      call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+      call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    else
+      call ver_dt (x, 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (y, 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+      call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    end if
+    l = T
+    call alloc_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call alloc_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp section
+    if (l) then
+      call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+      call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+      call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+      call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    else
+      call ver_dt (x, 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (y, 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+      call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    end if
+    l = T
+    call alloc_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call alloc_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp section
+!$omp end parallel sections
+    call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp parallel private (x, y, z)
+    call ver_dt (x, 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (y, 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,2), 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp single
+    call alloc_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call alloc_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp end single copyprivate (x, y, z)
+    call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp end parallel
+    call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+  end subroutine foo
+end
diff --git a/libgomp/testsuite/libgomp.fortran/alloc-comp-3.f90 b/libgomp/testsuite/libgomp.fortran/alloc-comp-3.f90

new file mode 100644 (file)

index 0000000..20f1314
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/alloc-comp-3.f90
@@ -0,0 +1,372 @@
+! { dg-do run }
+! Don't cycle by default through all options, just test -O0 and -O2,
+! as this is quite large test.
+! { dg-skip-if "" { ! run_expensive_tests } { "*" } { "-O0" "-O2" } }
+
+module m
+  type dl
+    integer :: a, b
+    integer, allocatable :: c(:,:)
+    integer :: d, e
+    integer, allocatable :: f
+  end type
+  type dt
+    integer :: g
+    type (dl), allocatable :: h(:)
+    integer :: i
+    type (dl) :: j(2, 2)
+    type (dl), allocatable :: k
+  end type
+contains
+  subroutine ver_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
+    type (dl), intent (in) :: obj
+    integer, intent (in) :: val, cl1, cu1, cl2, cu2
+    logical, intent (in) :: c, f
+    if ((c .neqv. allocated (obj%c)) .or. (f .neqv. allocated (obj%f))) call abort
+    if (c) then
+      if (lbound (obj%c, 1) /= cl1 .or. ubound (obj%c, 1) /= cu1) call abort
+      if (lbound (obj%c, 2) /= cl2 .or. ubound (obj%c, 2) /= cu2) call abort
+    end if
+    if (val /= 0) then
+      if (obj%a /= val .or. obj%b /= val) call abort
+      if (obj%d /= val .or. obj%e /= val) call abort
+      if (c) then
+        if (any (obj%c /= val)) call abort
+      end if
+      if (f) then
+        if (obj%f /= val) call abort
+      end if
+    end if
+  end subroutine ver_dl
+  subroutine ver_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
+    type (dt), intent (in) :: obj
+    integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
+    logical, intent (in) :: h, k, c, f
+    integer :: i, j
+    if ((h .neqv. allocated (obj%h)) .or. (k .neqv. allocated (obj%k))) call abort
+    if (h) then
+      if (lbound (obj%h, 1) /= hl .or. ubound (obj%h, 1) /= hu) call abort
+      do i = hl, hu
+        call ver_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
+      end do
+    end if
+    do i = 1, 2
+      do j = 1, 2
+        call ver_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
+      end do
+    end do
+    if (k) call ver_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
+    if (val /= 0) then
+      if (obj%g /= val .or. obj%i /= val) call abort
+    end if
+  end subroutine ver_dt
+  subroutine alloc_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
+    type (dl), intent (inout) :: obj
+    integer, intent (in) :: val, cl1, cu1, cl2, cu2
+    logical, intent (in) :: c, f
+    if (val /= 0) then
+      obj%a = val
+      obj%b = val
+      obj%d = val
+      obj%e = val
+    end if
+    if (allocated (obj%c)) deallocate (obj%c)
+    if (c) then
+      allocate (obj%c(cl1:cu1, cl2:cu2))
+      if (val /= 0) obj%c = val
+    end if
+    if (f) then
+      if (.not.allocated (obj%f)) allocate (obj%f)
+      if (val /= 0) obj%f = val
+    else
+      if (allocated (obj%f)) deallocate (obj%f)
+    end if
+  end subroutine alloc_dl
+  subroutine alloc_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
+    type (dt), intent (inout) :: obj
+    integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
+    logical, intent (in) :: h, k, c, f
+    integer :: i, j
+    if (val /= 0) then
+      obj%g = val
+      obj%i = val
+    end if
+    if (allocated (obj%h)) deallocate (obj%h)
+    if (h) then
+      allocate (obj%h(hl:hu))
+      do i = hl, hu
+        call alloc_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
+      end do
+    end if
+    do i = 1, 2
+      do j = 1, 2
+        call alloc_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
+      end do
+    end do
+    if (k) then
+      if (.not.allocated (obj%k)) allocate (obj%k)
+      call alloc_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
+    else
+      if (allocated (obj%k)) deallocate (obj%k)
+    end if
+  end subroutine alloc_dt
+end module m
+  use m
+  type (dt), allocatable :: z(:,:)
+  type (dt) :: y(2:3)
+  call foo (y, z, 4)
+contains
+  subroutine foo (y, z, n)
+    use m
+    integer :: n
+    type (dt) :: x(2:n), y(3:)
+    type (dt), allocatable :: z(:,:)
+    logical, parameter :: F = .false.
+    logical, parameter :: T = .true.
+    logical :: l
+    if (lbound (x, 1) /= 2 .or. ubound (x, 1) /= 4) call abort
+    if (lbound (y, 1) /= 3 .or. ubound (y, 1) /= 4) call abort
+    call ver_dt (x(2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (x(n), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (y(3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (y(4), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel private (z)
+    if (allocated (z)) call abort
+!$omp end parallel
+!$omp parallel firstprivate (z)
+    if (allocated (z)) call abort
+!$omp end parallel
+    l = F
+!$omp parallel sections lastprivate (z) firstprivate (l)
+!$omp section
+    if (.not. l) then
+      if (allocated (z)) call abort
+    end if
+!$omp section
+    if (.not. l) then
+      if (allocated (z)) call abort
+    end if
+    allocate (z(-3:-3,2:3))
+    call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp section
+!$omp end parallel sections
+    if (.not.allocated (z)) call abort
+    if (lbound (z, 1) /= -3 .or. ubound (z, 1) /= -3) call abort
+    if (lbound (z, 2) /= 2 .or. ubound (z, 2) /= 3) call abort
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (y(4), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel private (x, y, z)
+    call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y(4), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y(4), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    call ver_dt (y(4), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+!$omp end parallel
+    call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y(4), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y(4), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+!$omp parallel private (x, y, z)
+    call ver_dt (x(n - 1), 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y(4), 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    deallocate (x(n - 1)%h, x(n - 1)%k)
+    deallocate (y(4)%h)
+    allocate (y(4)%k)
+    call ver_dt (z(-3,2), 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
+    deallocate (z(-3,2)%h, z(-3,2)%k)
+    deallocate (z(-3,3)%h)
+    allocate (z(-3,3)%k)
+!$omp end parallel
+    call alloc_dt (x(n - 1), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (y(4), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+!$omp parallel firstprivate (x, y, z)
+    if (lbound (x, 1) /= 2 .or. ubound (x, 1) /= 4) call abort
+    if (lbound (y, 1) /= 3 .or. ubound (y, 1) /= 4) call abort
+    call ver_dt (x(n - 1), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y(4), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (y(4), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+    call ver_dt (y(4), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+    call ver_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+!$omp end parallel
+    call ver_dt (x(n - 1), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (x(n - 1), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (y(4), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (y(4), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+    call alloc_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+    call alloc_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel firstprivate (x, y, z)
+    call ver_dt (x(n - 1), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (y(4), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y(4), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+    call ver_dt (y(4), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+    call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+    call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+    call ver_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+!$omp end parallel
+    call ver_dt (x(n - 1), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (y(4), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (y(4), 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
+    call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call alloc_dt (z(-3,3), 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
+    l = F
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+    if (l) then
+      call ver_dt (x(n - 1), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (y(4), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+      call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    else
+      call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+      call ver_dt (y(4), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+      call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+      call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+    end if
+    l = T
+    call alloc_dt (x(n - 1), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+    call ver_dt (x(n - 1), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+    call alloc_dt (y(4), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+    call ver_dt (y(4), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+    call alloc_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+    call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+    call alloc_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+    call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+!$omp section
+    if (l) then
+      call ver_dt (x(n - 1), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+      call ver_dt (y(4), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+      call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+      call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+    else
+      call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+      call ver_dt (y(4), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+      call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+      call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+    end if
+    l = T
+    call alloc_dt (x(n - 1), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call ver_dt (x(n - 1), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call alloc_dt (y(4), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    call ver_dt (y(4), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    call alloc_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call alloc_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+!$omp section
+!$omp end parallel sections
+    call ver_dt (x(n - 1), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call ver_dt (y(4), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+    call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+    if (l) then
+      call ver_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+      call ver_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+      call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+      call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    else
+      call ver_dt (x(n - 1), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (y(4), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+      call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    end if
+    l = T
+    call alloc_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call ver_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call alloc_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call ver_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp section
+    if (l) then
+      call ver_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+      call ver_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+      call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+      call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    else
+      call ver_dt (x(n - 1), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (y(4), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+      call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+      call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+    end if
+    l = T
+    call alloc_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call alloc_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp section
+!$omp end parallel sections
+    call ver_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp parallel private (x, y, z)
+    call ver_dt (x(n - 1), 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (y(4), 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,2), 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp single
+    call alloc_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call alloc_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp end single copyprivate (x, y, z)
+    call ver_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call ver_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+    call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+    call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp end parallel
+    call ver_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+    call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+    call ver_dt (x(2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (x(n), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+    call ver_dt (y(3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+  end subroutine foo
+end
diff --git a/libgomp/testsuite/libgomp.fortran/allocatable10.f90 b/libgomp/testsuite/libgomp.fortran/allocatable10.f90

new file mode 100644 (file)

index 0000000..54eed61
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocatable10.f90
@@ -0,0 +1,112 @@
+! { dg-do run }
+
+  integer, allocatable :: a, b(:), c(:,:)
+  integer :: i
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) &
+!$omp & initializer (omp_priv = 0)
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+  allocate (a, b(6:9), c(3, 8:9))
+  a = 0
+  b = 0
+  c = 0
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 4) call abort
+  if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+!$omp parallel do reduction (+:a, b, c)
+  do i = 1, 10
+    if (.not.allocated (a)) call abort
+    if (.not.allocated (b) .or. size (b) /= 4) call abort
+    if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+    if (.not.allocated (c) .or. size (c) /= 6) call abort
+    if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+    if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+    if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+    a = a + i
+    b = b + 2 * i
+    c = c + 3 * i
+  end do
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 4) call abort
+  if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+  if (a /= 55 .or. any (b /= 110) .or. any (c /= 165)) call abort
+  a = 0
+  b = 0
+  c = 0
+!$omp parallel do reduction (foo : a, b, c)
+  do i = 1, 10
+    if (.not.allocated (a)) call abort
+    if (.not.allocated (b) .or. size (b) /= 4) call abort
+    if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+    if (.not.allocated (c) .or. size (c) /= 6) call abort
+    if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+    if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+    if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+    a = a + i
+    b = b + 2 * i
+    c = c + 3 * i
+  end do
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 4) call abort
+  if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+  if (a /= 55 .or. any (b /= 110) .or. any (c /= 165)) call abort
+  a = 0
+  b = 0
+  c = 0
+!$omp simd reduction (+:a, b, c)
+  do i = 1, 10
+    if (.not.allocated (a)) call abort
+    if (.not.allocated (b) .or. size (b) /= 4) call abort
+    if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+    if (.not.allocated (c) .or. size (c) /= 6) call abort
+    if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+    if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+    if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+    a = a + i
+    b = b + 2 * i
+    c = c + 3 * i
+  end do
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 4) call abort
+  if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+  if (a /= 55 .or. any (b /= 110) .or. any (c /= 165)) call abort
+  a = 0
+  b = 0
+  c = 0
+!$omp simd reduction (foo : a, b, c)
+  do i = 1, 10
+    if (.not.allocated (a)) call abort
+    if (.not.allocated (b) .or. size (b) /= 4) call abort
+    if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+    if (.not.allocated (c) .or. size (c) /= 6) call abort
+    if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+    if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+    if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+    a = a + i
+    b = b + 2 * i
+    c = c + 3 * i
+  end do
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 4) call abort
+  if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+  if (a /= 55 .or. any (b /= 110) .or. any (c /= 165)) call abort
+end
diff --git a/libgomp/testsuite/libgomp.fortran/allocatable11.f90 b/libgomp/testsuite/libgomp.fortran/allocatable11.f90

new file mode 100644 (file)

index 0000000..479f604
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocatable11.f90
@@ -0,0 +1,72 @@
+! { dg-do run }
+! { dg-require-effective-target tls_runtime }
+
+  use omp_lib
+  integer, allocatable, save :: a, b(:), c(:,:)
+  integer :: p
+!$omp threadprivate (a, b, c)
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+
+  call omp_set_dynamic (.false.)
+  call omp_set_num_threads (4)
+
+!$omp parallel num_threads (4)
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+!$omp end parallel
+
+  allocate (a, b(6:9), c(3, 8:9))
+  a = 4
+  b = 5
+  c = 6
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 4) call abort
+  if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+
+!$omp parallel num_threads (4) copyin (a, b, c) private (p)
+  p = omp_get_thread_num ()
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 4) call abort
+  if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+  if (a /= 4 .or. any (b /= 5) .or. any (c /= 6)) call abort
+  deallocate (a, b, c)
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+  allocate (a, b(p:9), c(3, p:7))
+  a = p
+  b = p
+  c = p
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= (10 - p)) call abort
+  if (lbound (b, 1) /= p .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= (3 * (8 - p))) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= (8 - p)) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= p .or. ubound (c, 2) /= 7) call abort
+  if (a /= p .or. any (b /= p) .or. any (c /= p)) call abort
+!$omp end parallel
+
+!$omp parallel num_threads (4) copyin (a, b, c)
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 10) call abort
+  if (lbound (b, 1) /= 0 .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= 24) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 8) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 0 .or. ubound (c, 2) /= 7) call abort
+  if (a /= 0 .or. any (b /= 0) .or. any (c /= 0)) call abort
+!$omp end parallel
+
+  deallocate (a, b, c)
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+
+!$omp parallel num_threads (4) copyin (a, b, c)
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+!$omp end parallel
+end
diff --git a/libgomp/testsuite/libgomp.fortran/allocatable12.f90 b/libgomp/testsuite/libgomp.fortran/allocatable12.f90

new file mode 100644 (file)

index 0000000..533ab7c
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocatable12.f90
@@ -0,0 +1,74 @@
+! { dg-do run }
+
+  integer, allocatable :: a, b(:), c(:,:)
+  logical :: l
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+
+!$omp parallel private (a, b, c, l)
+  l = .false.
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+
+!$omp single
+  allocate (a, b(6:9), c(3, 8:9))
+  a = 4
+  b = 5
+  c = 6
+!$omp end single copyprivate (a, b, c)
+
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 4) call abort
+  if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+  if (a /= 4 .or. any (b /= 5) .or. any (c /= 6)) call abort
+
+!$omp single
+  deallocate (a, b, c)
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+  allocate (a, b(0:4), c(3, 2:7))
+  a = 1
+  b = 2
+  c = 3
+!$omp end single copyprivate (a, b, c)
+
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 5) call abort
+  if (lbound (b, 1) /= 0 .or. ubound (b, 1) /= 4) call abort
+  if (.not.allocated (c) .or. size (c) /= 18) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 6) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 2 .or. ubound (c, 2) /= 7) call abort
+  if (a /= 1 .or. any (b /= 2) .or. any (c /= 3)) call abort
+
+!$omp single
+  l = .true.
+  deallocate (a, b, c)
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+  allocate (a, b(2:6), c(3:5, 3:8))
+  a = 7
+  b = 8
+  c = 9
+!$omp end single copyprivate (a, b, c)
+
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 5) call abort
+  if (l) then
+    if (lbound (b, 1) /= 2 .or. ubound (b, 1) /= 6) call abort
+  else
+    if (lbound (b, 1) /= 0 .or. ubound (b, 1) /= 4) call abort
+  end if
+  if (.not.allocated (c) .or. size (c) /= 18) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 6) call abort
+  if (l) then
+    if (lbound (c, 1) /= 3 .or. ubound (c, 1) /= 5) call abort
+    if (lbound (c, 2) /= 3 .or. ubound (c, 2) /= 8) call abort
+  else
+    if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+    if (lbound (c, 2) /= 2 .or. ubound (c, 2) /= 7) call abort
+  end if
+  if (a /= 7 .or. any (b /= 8) .or. any (c /= 9)) call abort
+
+!$omp end parallel
+end
diff --git a/libgomp/testsuite/libgomp.fortran/allocatable9.f90 b/libgomp/testsuite/libgomp.fortran/allocatable9.f90

new file mode 100644 (file)

index 0000000..80bf5d3
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocatable9.f90
@@ -0,0 +1,156 @@
+! { dg-do run }
+
+  integer, allocatable :: a, b(:), c(:,:)
+  logical :: l
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+!$omp parallel private (a, b, c)
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+  allocate (a, b(-7:-1), c(2:3, 3:5))
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 7) call abort
+  if (lbound (b, 1) /= -7 .or. ubound (b, 1) /= -1) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 2 .or. size (c, 2) /= 3) call abort
+  if (lbound (c, 1) /= 2 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 3 .or. ubound (c, 2) /= 5) call abort
+  a = 4
+  b = 3
+  c = 2
+!$omp end parallel
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+!$omp parallel firstprivate (a, b, c)
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+  allocate (a, b(-7:-1), c(2:3, 3:5))
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 7) call abort
+  if (lbound (b, 1) /= -7 .or. ubound (b, 1) /= -1) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 2 .or. size (c, 2) /= 3) call abort
+  if (lbound (c, 1) /= 2 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 3 .or. ubound (c, 2) /= 5) call abort
+  a = 4
+  b = 3
+  c = 2
+!$omp end parallel
+  if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+  allocate (a, b(6:9), c(3, 8:9))
+  a = 2
+  b = 4
+  c = 5
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 4) call abort
+  if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+!$omp parallel firstprivate (a, b, c)
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 4) call abort
+  if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+  if (a /= 2 .or. any (b .ne. 4) .or. any (c .ne. 5)) call abort
+  deallocate (a)
+  if (allocated (a)) call abort
+  allocate (a)
+  a = 8
+  b = (/ 1, 2, 3 /)
+  c = reshape ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), (/ 2, 4 /))
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 3) call abort
+  if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 3) call abort
+  if (.not.allocated (c) .or. size (c) /= 8) call abort
+  if (size (c, 1) /= 2 .or. size (c, 2) /= 4) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 2) call abort
+  if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 4) call abort
+  if (a /= 8 .or. b(2) /= 2 .or. c(1, 2) /= 3) call abort
+!$omp end parallel
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 4) call abort
+  if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+  if (.not.allocated (c) .or. size (c) /= 6) call abort
+  if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+  if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+  if (a /= 2 .or. any (b .ne. 4) .or. any (c .ne. 5)) call abort
+  l = .false.
+!$omp parallel sections lastprivate (a, b, c) firstprivate (l)
+!$omp section
+  if (.not.allocated (a)) call abort
+  if (l) then
+    if (.not.allocated (b) .or. size (b) /= 6) call abort
+    if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 6) call abort
+    if (.not.allocated (c) .or. size (c) /= 8) call abort
+    if (size (c, 1) /= 4 .or. size (c, 2) /= 2) call abort
+    if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 4) call abort
+    if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 2) call abort
+    if (a /= 12 .or. b(2) /= 8 .or. c(1, 2) /= 5) call abort
+  else
+    if (.not.allocated (b) .or. size (b) /= 4) call abort
+    if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+    if (.not.allocated (c) .or. size (c) /= 6) call abort
+    if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+    if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+    if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+  end if
+  l = .true.
+  deallocate (a)
+  if (allocated (a)) call abort
+  allocate (a)
+  a = 8
+  b = (/ 1, 2, 3 /)
+  c = reshape ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), (/ 2, 4 /))
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 3) call abort
+  if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 3) call abort
+  if (.not.allocated (c) .or. size (c) /= 8) call abort
+  if (size (c, 1) /= 2 .or. size (c, 2) /= 4) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 2) call abort
+  if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 4) call abort
+  if (a /= 8 .or. b(2) /= 2 .or. c(1, 2) /= 3) call abort
+!$omp section
+  if (.not.allocated (a)) call abort
+  if (l) then
+    if (.not.allocated (b) .or. size (b) /= 3) call abort
+    if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 3) call abort
+    if (.not.allocated (c) .or. size (c) /= 8) call abort
+    if (size (c, 1) /= 2 .or. size (c, 2) /= 4) call abort
+    if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 2) call abort
+    if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 4) call abort
+    if (a /= 8 .or. b(2) /= 2 .or. c(1, 2) /= 3) call abort
+  else
+    if (.not.allocated (b) .or. size (b) /= 4) call abort
+    if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+    if (.not.allocated (c) .or. size (c) /= 6) call abort
+    if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+    if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+    if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+  end if
+  l = .true.
+  deallocate (a)
+  if (allocated (a)) call abort
+  allocate (a)
+  a = 12
+  b = (/ 9, 8, 7, 6, 5, 4 /)
+  c = reshape ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), (/ 4, 2 /))
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 6) call abort
+  if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 6) call abort
+  if (.not.allocated (c) .or. size (c) /= 8) call abort
+  if (size (c, 1) /= 4 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 4) call abort
+  if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 2) call abort
+  if (a /= 12 .or. b(2) /= 8 .or. c(1, 2) /= 5) call abort
+!$omp end parallel sections
+  if (.not.allocated (a)) call abort
+  if (.not.allocated (b) .or. size (b) /= 6) call abort
+  if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 6) call abort
+  if (.not.allocated (c) .or. size (c) /= 8) call abort
+  if (size (c, 1) /= 4 .or. size (c, 2) /= 2) call abort
+  if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 4) call abort
+  if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 2) call abort
+  if (a /= 12 .or. b(2) /= 8 .or. c(1, 2) /= 5) call abort
+end
diff --git a/libgomp/testsuite/libgomp.fortran/associate1.f90 b/libgomp/testsuite/libgomp.fortran/associate1.f90

new file mode 100644 (file)

index 0000000..e409955
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/associate1.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+
+program associate1
+  integer :: v, i, j
+  real :: a(3, 3)
+  v = 15
+  a = 4.5
+  a(2,1) = 3.5
+  i = 2
+  j = 1
+  associate(u => v, b => a(i, j))
+!$omp parallel private(v, a) default(none)
+  v = -1
+  a = 2.5
+  if (v /= -1 .or. u /= 15) call abort
+  if (a(2,1) /= 2.5 .or. b /= 3.5) call abort
+  associate(u => v, b => a(2, 1))
+  if (u /= -1 .or. b /= 2.5) call abort
+  end associate
+  if (u /= 15 .or. b /= 3.5) call abort
+!$omp end parallel
+  end associate
+end program
diff --git a/libgomp/testsuite/libgomp.fortran/associate2.f90 b/libgomp/testsuite/libgomp.fortran/associate2.f90

new file mode 100644 (file)

index 0000000..dee8496
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/associate2.f90
@@ -0,0 +1,46 @@
+! { dg-do run }
+
+program associate2
+  type dl
+    integer :: i
+  end type
+  type dt
+    integer :: i
+    real :: a(3, 3)
+    type(dl) :: c(3, 3)
+  end type
+  integer :: v(4), i, j, k, l
+  type (dt) :: a(3, 3)
+  v = 15
+  forall (k = 1:3, l = 1:3) a(k, l)%a(:,:) = 4.5
+  a(2,1)%a(1,2) = 3.5
+  i = 2
+  j = 1
+  associate(u => v, b => a(i, j)%a)
+!$omp parallel private(v, a) default(none)
+  v = -1
+  forall (k = 1:3, l = 1:3) a(k, l)%a(:,:) = 2.5
+  if (v(3) /= -1 .or. u(3) /= 15) call abort
+  if (a(2,1)%a(1,2) /= 2.5 .or. b(1,2) /= 3.5) call abort
+  associate(u => v, b => a(2, 1)%a)
+  if (u(3) /= -1 .or. b(1,2) /= 2.5) call abort
+  end associate
+  if (u(3) /= 15 .or. b(1,2) /= 3.5) call abort
+!$omp end parallel
+  end associate
+  forall (k = 1:3, l = 1:3) a(k, l)%c(:,:)%i = 7
+  a(1,2)%c(2,1)%i = 9
+  i = 1
+  j = 2
+  associate(d => a(i, j)%c(2,:)%i)
+!$omp parallel private(a) default(none)
+  forall (k = 1:3, l = 1:3) a(k, l)%c(:,:)%i = 15
+  if (a(1,2)%c(2,1)%i /= 15 .or. d(1) /= 9) call abort
+  if (a(1,2)%c(2,2)%i /= 15 .or. d(2) /= 7) call abort
+  associate(d => a(2,1)%c(2,:)%i)
+  if (d(1) /= 15 .or. d(2) /= 15) call abort
+  end associate
+  if (d(1) /= 9 .or. d(2) /= 7) call abort
+!$omp end parallel
+  end associate
+end program
diff --git a/libgomp/testsuite/libgomp.fortran/procptr1.f90 b/libgomp/testsuite/libgomp.fortran/procptr1.f90

new file mode 100644 (file)

index 0000000..4187739
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/procptr1.f90
@@ -0,0 +1,42 @@
+! { dg-do run }
+  interface
+    integer function foo ()
+    end function
+    integer function bar ()
+    end function
+    integer function baz ()
+    end function
+  end interface
+  procedure(foo), pointer :: ptr
+  integer :: i
+  ptr => foo
+!$omp parallel shared (ptr)
+  if (ptr () /= 1) call abort
+!$omp end parallel
+  ptr => bar
+!$omp parallel firstprivate (ptr)
+  if (ptr () /= 2) call abort
+!$omp end parallel
+!$omp parallel sections lastprivate (ptr)
+!$omp section
+  ptr => foo
+  if (ptr () /= 1) call abort
+!$omp section
+  ptr => bar
+  if (ptr () /= 2) call abort
+!$omp section
+  ptr => baz
+  if (ptr () /= 3) call abort
+!$omp end parallel sections
+  if (ptr () /= 3) call abort
+  if (.not.associated (ptr, baz)) call abort
+end
+integer function foo ()
+  foo = 1
+end function
+integer function bar ()
+  bar = 2
+end function
+integer function baz ()
+  baz = 3
+end function
author	Jakub Jelinek <jakub@redhat.com>
	Tue, 10 Jun 2014 06:05:22 +0000 (08:05 +0200)
committer	Jakub Jelinek <jakub@gcc.gnu.org>
	Tue, 10 Jun 2014 06:05:22 +0000 (08:05 +0200)
gcc/ChangeLog		patch \| blob \| history
gcc/c-family/ChangeLog		patch \| blob \| history
gcc/c-family/c-pragma.c		patch \| blob \| history
gcc/fortran/ChangeLog		patch \| blob \| history
gcc/fortran/f95-lang.c		patch \| blob \| history
gcc/fortran/openmp.c		patch \| blob \| history
gcc/fortran/parse.c		patch \| blob \| history
gcc/fortran/scanner.c		patch \| blob \| history
gcc/fortran/trans-array.c		patch \| blob \| history
gcc/fortran/trans-array.h		patch \| blob \| history
gcc/fortran/trans-common.c		patch \| blob \| history
gcc/fortran/trans-decl.c		patch \| blob \| history
gcc/fortran/trans-openmp.c		patch \| blob \| history
gcc/fortran/trans-types.c		patch \| blob \| history
gcc/fortran/trans.h		patch \| blob \| history
gcc/omp-low.c		patch \| blob \| history
gcc/testsuite/ChangeLog		patch \| blob \| history
gcc/testsuite/gfortran.dg/gomp/allocatable_components_1.f90		patch \| blob \| history
gcc/testsuite/gfortran.dg/gomp/associate1.f90	[new file with mode: 0644]	patch \| blob
gcc/testsuite/gfortran.dg/gomp/intentin1.f90	[new file with mode: 0644]	patch \| blob
gcc/testsuite/gfortran.dg/gomp/openmp-simd-1.f90	[new file with mode: 0644]	patch \| blob
gcc/testsuite/gfortran.dg/gomp/openmp-simd-2.f90	[new file with mode: 0644]	patch \| blob
gcc/testsuite/gfortran.dg/gomp/openmp-simd-3.f90	[new file with mode: 0644]	patch \| blob
gcc/testsuite/gfortran.dg/gomp/proc_ptr_2.f90	[new file with mode: 0644]	patch \| blob
libgomp/ChangeLog		patch \| blob \| history
libgomp/testsuite/libgomp.fortran/alloc-comp-1.f90	[new file with mode: 0644]	patch \| blob
libgomp/testsuite/libgomp.fortran/alloc-comp-2.f90	[new file with mode: 0644]	patch \| blob
libgomp/testsuite/libgomp.fortran/alloc-comp-3.f90	[new file with mode: 0644]	patch \| blob
libgomp/testsuite/libgomp.fortran/allocatable10.f90	[new file with mode: 0644]	patch \| blob
libgomp/testsuite/libgomp.fortran/allocatable11.f90	[new file with mode: 0644]	patch \| blob
libgomp/testsuite/libgomp.fortran/allocatable12.f90	[new file with mode: 0644]	patch \| blob
libgomp/testsuite/libgomp.fortran/allocatable9.f90	[new file with mode: 0644]	patch \| blob
libgomp/testsuite/libgomp.fortran/associate1.f90	[new file with mode: 0644]	patch \| blob
libgomp/testsuite/libgomp.fortran/associate2.f90	[new file with mode: 0644]	patch \| blob
libgomp/testsuite/libgomp.fortran/procptr1.f90	[new file with mode: 0644]	patch \| blob