Merge branch 'releases/gcc-12' into devel/omp/gcc-12

[gcc.git] / gcc / fortran / resolve.cc

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 532ca05b69c565d174dbeb407eb5151a8c66b41b..aaeaf396b91a0ba61863ba6172de78ac95eeaaf2 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -488,7 +488,8 @@ gfc_resolve_formal_arglist (gfc_symbol *proc)
              continue;
            }
 
-         if (sym->attr.flavor == FL_PROCEDURE)
+         if (sym->attr.flavor == FL_PROCEDURE
+             && !proc->attr.artificial && !sym->attr.artificial)
            {
              gfc_error ("Dummy procedure %qs not allowed in elemental "
                         "procedure %qs at %L", sym->name, proc->name,
@@ -1898,7 +1899,8 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
   sym->attr.elemental = isym->elemental;
 
   /* Check it is actually available in the standard settings.  */
-  if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
+  if ((!sym->ns->proc_name || !sym->ns->proc_name->attr.artificial)
+      && !gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
     {
       gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
                 "available in the current standard settings but %s. Use "
@@ -10903,6 +10905,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
        case EXEC_OACC_ENTER_DATA:
        case EXEC_OACC_EXIT_DATA:
        case EXEC_OACC_ROUTINE:
+       case EXEC_OMP_ASSUME:
        case EXEC_OMP_CRITICAL:
        case EXEC_OMP_DISTRIBUTE:
        case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
@@ -11868,6 +11871,17 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
          gfc_resolve_forall (code, ns, forall_save);
          forall_flag = 2;
        }
+      else if (code->op == EXEC_OMP_METADIRECTIVE)
+       {
+         gfc_omp_metadirective_clause *clause
+           = code->ext.omp_metadirective_clauses;
+
+         while (clause)
+           {
+             gfc_resolve_code (clause->code, ns);
+             clause = clause->next;
+           }
+       }
       else if (code->block)
        {
          omp_workshare_save = -1;
@@ -11891,9 +11905,14 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
              break;
            case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
            case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+           case EXEC_OMP_MASKED_TASKLOOP:
+           case EXEC_OMP_MASKED_TASKLOOP_SIMD:
+           case EXEC_OMP_MASTER_TASKLOOP:
+           case EXEC_OMP_MASTER_TASKLOOP_SIMD:
            case EXEC_OMP_PARALLEL:
            case EXEC_OMP_PARALLEL_DO:
            case EXEC_OMP_PARALLEL_DO_SIMD:
+           case EXEC_OMP_PARALLEL_LOOP:
            case EXEC_OMP_PARALLEL_MASKED:
            case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
            case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
@@ -11904,11 +11923,13 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
            case EXEC_OMP_TARGET_PARALLEL:
            case EXEC_OMP_TARGET_PARALLEL_DO:
            case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
+           case EXEC_OMP_TARGET_PARALLEL_LOOP:
            case EXEC_OMP_TARGET_TEAMS:
            case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
            case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
            case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
            case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+           case EXEC_OMP_TARGET_TEAMS_LOOP:
            case EXEC_OMP_TASK:
            case EXEC_OMP_TASKLOOP:
            case EXEC_OMP_TASKLOOP_SIMD:
@@ -11917,6 +11938,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
            case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
            case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
            case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
+           case EXEC_OMP_TEAMS_LOOP:
              omp_workshare_save = omp_workshare_flag;
              omp_workshare_flag = 0;
              gfc_resolve_omp_parallel_blocks (code, ns);
@@ -11925,6 +11947,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
            case EXEC_OMP_DISTRIBUTE_SIMD:
            case EXEC_OMP_DO:
            case EXEC_OMP_DO_SIMD:
+           case EXEC_OMP_LOOP:
            case EXEC_OMP_SIMD:
            case EXEC_OMP_TARGET_SIMD:
              gfc_resolve_omp_do_blocks (code, ns);
@@ -12344,6 +12367,8 @@ start:
          gfc_resolve_oacc_directive (code, ns);
          break;
 
+       case EXEC_OMP_ALLOCATE:
+       case EXEC_OMP_ASSUME:
        case EXEC_OMP_ATOMIC:
        case EXEC_OMP_BARRIER:
        case EXEC_OMP_CANCEL:
@@ -12365,6 +12390,7 @@ start:
        case EXEC_OMP_MASKED:
        case EXEC_OMP_MASKED_TASKLOOP:
        case EXEC_OMP_MASKED_TASKLOOP_SIMD:
+       case EXEC_OMP_METADIRECTIVE:
        case EXEC_OMP_ORDERED:
        case EXEC_OMP_SCAN:
        case EXEC_OMP_SCOPE:
@@ -13409,7 +13435,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
                     name, &sym->declared_at);
          return false;
        }
-      if (sym->attr.dummy)
+      if (sym->attr.dummy && !sym->attr.artificial)
        {
          gfc_error ("Dummy procedure %qs at %L shall not be elemental",
                     sym->name, &sym->declared_at);
@@ -13623,17 +13649,14 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable)
   if (parent)
     gfc_resolve_finalizers (parent, finalizable);
 
-  /* Ensure that derived-type components have a their finalizers resolved.  */
+  /* Ensure that derived-type components have a their finalizers resolved;
+     handle allocatables but avoid issues with (in)direct allocatable types. */
   bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers;
   for (c = derived->components; c; c = c->next)
     if (c->ts.type == BT_DERIVED
        && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable)
-      {
-       bool has_final2 = false;
-       if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2))
-         return false;  /* Error.  */
-       has_final = has_final || has_final2;
-      }
+      has_final |= gfc_is_finalizable (c->ts.u.derived, NULL);
+
   /* Return early if not finalizable.  */
   if (!has_final)
     {
@@ -15147,6 +15170,19 @@ resolve_fl_derived (gfc_symbol *sym)
       return false;
     }
 
+  gfc_component *c = (sym->attr.is_class
+                     ? CLASS_DATA (sym->components) : sym->components);
+  for ( ; c; c = c->next)
+    if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+       && !c->ts.u.derived->resolve_symbol_called)
+      {
+       if (c->ts.u.derived->components == NULL
+           && !c->ts.u.derived->attr.zero_comp
+           && !c->ts.u.derived->attr.use_assoc)
+         continue;
+       resolve_symbol (c->ts.u.derived);
+      }
+
   /* Resolve the finalizer procedures.  */
   if (!gfc_resolve_finalizers (sym, NULL))
     return false;
@@ -15481,6 +15517,14 @@ resolve_symbol (gfc_symbol *sym)
   if (sym->attr.unlimited_polymorphic)
     return;
 
+  if (__builtin_expect (flag_openmp && strcmp (sym->name, "omp_all_memory")
+                       == 0, 0))
+    {
+      gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in "
+                "the OpenMP DEPEND clause", &sym->declared_at);
+      return;
+    }
+
   if (sym->attr.flavor == FL_UNKNOWN
       || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
          && !sym->attr.generic && !sym->attr.external
@@ -17499,7 +17543,8 @@ resolve_types (gfc_namespace *ns)
 
   for (n = ns->contained; n; n = n->sibling)
     {
-      if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
+      if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name)
+         && (!n->proc_name || !n->proc_name->attr.artificial))
        gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
                   "also be PURE", n->proc_name->name,
                   &n->proc_name->declared_at);
@@ -17612,6 +17657,9 @@ gfc_resolve (gfc_namespace *ns)
   component_assignment_level = 0;
   resolve_codes (ns);
 
+  if (ns->omp_assumes)
+    gfc_resolve_omp_assumptions (ns->omp_assumes);
+
   gfc_current_ns = old_ns;
   cs_base = old_cs_base;
   ns->resolved = 1;