Пример #1
0
gfc_symbol *
gfc_find_derived_vtab (gfc_symbol *derived)
{
    gfc_namespace *ns;
    gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
    gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;

    /* Find the top-level namespace (MODULE or PROGRAM).  */
    for (ns = gfc_current_ns; ns; ns = ns->parent)
        if (!ns->parent)
            break;

    /* If the type is a class container, use the underlying derived type.  */
    if (derived->attr.is_class)
        derived = gfc_get_derived_super_type (derived);

    if (ns)
    {
        char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];

        get_unique_hashed_string (tname, derived);
        sprintf (name, "__vtab_%s", tname);

        /* Look for the vtab symbol in various namespaces.  */
        gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
        if (vtab == NULL)
            gfc_find_symbol (name, ns, 0, &vtab);
        if (vtab == NULL)
            gfc_find_symbol (name, derived->ns, 0, &vtab);

        if (vtab == NULL)
        {
            gfc_get_symbol (name, ns, &vtab);
            vtab->ts.type = BT_DERIVED;
            if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
                                &gfc_current_locus) == FAILURE)
                goto cleanup;
            vtab->attr.target = 1;
            vtab->attr.save = SAVE_IMPLICIT;
            vtab->attr.vtab = 1;
            vtab->attr.access = ACCESS_PUBLIC;
            gfc_set_sym_referenced (vtab);
            sprintf (name, "__vtype_%s", tname);

            gfc_find_symbol (name, ns, 0, &vtype);
            if (vtype == NULL)
            {
                gfc_component *c;
                gfc_symbol *parent = NULL, *parent_vtab = NULL;

                gfc_get_symbol (name, ns, &vtype);
                if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
                                    NULL, &gfc_current_locus) == FAILURE)
                    goto cleanup;
                vtype->attr.access = ACCESS_PUBLIC;
                vtype->attr.vtype = 1;
                gfc_set_sym_referenced (vtype);

                /* Add component '_hash'.  */
                if (gfc_add_component (vtype, "_hash", &c) == FAILURE)
                    goto cleanup;
                c->ts.type = BT_INTEGER;
                c->ts.kind = 4;
                c->attr.access = ACCESS_PRIVATE;
                c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
                                                   NULL, derived->hash_value);

                /* Add component '_size'.  */
                if (gfc_add_component (vtype, "_size", &c) == FAILURE)
                    goto cleanup;
                c->ts.type = BT_INTEGER;
                c->ts.kind = 4;
                c->attr.access = ACCESS_PRIVATE;
                /* Remember the derived type in ts.u.derived,
                so that the correct initializer can be set later on
                 (in gfc_conv_structure).  */
                c->ts.u.derived = derived;
                c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
                                                   NULL, 0);

                /* Add component _extends.  */
                if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
                    goto cleanup;
                c->attr.pointer = 1;
                c->attr.access = ACCESS_PRIVATE;
                parent = gfc_get_derived_super_type (derived);
                if (parent)
                {
                    parent_vtab = gfc_find_derived_vtab (parent);
                    c->ts.type = BT_DERIVED;
                    c->ts.u.derived = parent_vtab->ts.u.derived;
                    c->initializer = gfc_get_expr ();
                    c->initializer->expr_type = EXPR_VARIABLE;
                    gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
                                       0, &c->initializer->symtree);
                }
                else
                {
                    c->ts.type = BT_DERIVED;
                    c->ts.u.derived = vtype;
                    c->initializer = gfc_get_null_expr (NULL);
                }

                if (derived->components == NULL && !derived->attr.zero_comp)
                {
                    /* At this point an error must have occurred.
                       Prevent further errors on the vtype components.  */
                    found_sym = vtab;
                    goto have_vtype;
                }

                /* Add component _def_init.  */
                if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
                    goto cleanup;
                c->attr.pointer = 1;
                c->attr.access = ACCESS_PRIVATE;
                c->ts.type = BT_DERIVED;
                c->ts.u.derived = derived;
                if (derived->attr.abstract)
                    c->initializer = gfc_get_null_expr (NULL);
                else
                {
                    /* Construct default initialization variable.  */
                    sprintf (name, "__def_init_%s", tname);
                    gfc_get_symbol (name, ns, &def_init);
                    def_init->attr.target = 1;
                    def_init->attr.save = SAVE_IMPLICIT;
                    def_init->attr.access = ACCESS_PUBLIC;
                    def_init->attr.flavor = FL_VARIABLE;
                    gfc_set_sym_referenced (def_init);
                    def_init->ts.type = BT_DERIVED;
                    def_init->ts.u.derived = derived;
                    def_init->value = gfc_default_initializer (&def_init->ts);

                    c->initializer = gfc_lval_expr_from_sym (def_init);
                }

                /* Add component _copy.  */
                if (gfc_add_component (vtype, "_copy", &c) == FAILURE)
                    goto cleanup;
                c->attr.proc_pointer = 1;
                c->attr.access = ACCESS_PRIVATE;
                c->tb = XCNEW (gfc_typebound_proc);
                c->tb->ppc = 1;
                if (derived->attr.abstract)
                    c->initializer = gfc_get_null_expr (NULL);
                else
                {
                    /* Set up namespace.  */
                    gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
                    sub_ns->sibling = ns->contained;
                    ns->contained = sub_ns;
                    sub_ns->resolved = 1;
                    /* Set up procedure symbol.  */
                    sprintf (name, "__copy_%s", tname);
                    gfc_get_symbol (name, sub_ns, &copy);
                    sub_ns->proc_name = copy;
                    copy->attr.flavor = FL_PROCEDURE;
                    copy->attr.if_source = IFSRC_DECL;
                    if (ns->proc_name->attr.flavor == FL_MODULE)
                        copy->module = ns->proc_name->name;
                    gfc_set_sym_referenced (copy);
                    /* Set up formal arguments.  */
                    gfc_get_symbol ("src", sub_ns, &src);
                    src->ts.type = BT_DERIVED;
                    src->ts.u.derived = derived;
                    src->attr.flavor = FL_VARIABLE;
                    src->attr.dummy = 1;
                    gfc_set_sym_referenced (src);
                    copy->formal = gfc_get_formal_arglist ();
                    copy->formal->sym = src;
                    gfc_get_symbol ("dst", sub_ns, &dst);
                    dst->ts.type = BT_DERIVED;
                    dst->ts.u.derived = derived;
                    dst->attr.flavor = FL_VARIABLE;
                    dst->attr.dummy = 1;
                    gfc_set_sym_referenced (dst);
                    copy->formal->next = gfc_get_formal_arglist ();
                    copy->formal->next->sym = dst;
                    /* Set up code.  */
                    sub_ns->code = gfc_get_code ();
                    sub_ns->code->op = EXEC_INIT_ASSIGN;
                    sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
                    sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
                    /* Set initializer.  */
                    c->initializer = gfc_lval_expr_from_sym (copy);
                    c->ts.interface = copy;
                }

                /* Add procedure pointers for type-bound procedures.  */
                add_procs_to_declared_vtab (derived, vtype);
            }

have_vtype:
            vtab->ts.u.derived = vtype;
            vtab->value = gfc_default_initializer (&vtab->ts);
        }
    }

    found_sym = vtab;

cleanup:
    /* It is unexpected to have some symbols added at resolution or code
       generation time. We commit the changes in order to keep a clean state.  */
    if (found_sym)
    {
        gfc_commit_symbol (vtab);
        if (vtype)
            gfc_commit_symbol (vtype);
        if (def_init)
            gfc_commit_symbol (def_init);
        if (copy)
            gfc_commit_symbol (copy);
        if (src)
            gfc_commit_symbol (src);
        if (dst)
            gfc_commit_symbol (dst);
    }
    else
        gfc_undo_symbols ();

    return found_sym;
}
Пример #2
0
gfc_symbol *
gfc_find_derived_vtab (gfc_symbol *derived)
{
  gfc_namespace *ns;
  gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
  char name[2 * GFC_MAX_SYMBOL_LEN + 8];

  ns = gfc_current_ns;

  for (; ns; ns = ns->parent)
    if (!ns->parent)
      break;

  if (ns)
    {
      sprintf (name, "vtab$%s", derived->name);
      gfc_find_symbol (name, ns, 0, &vtab);

      if (vtab == NULL)
	{
	  gfc_get_symbol (name, ns, &vtab);
	  vtab->ts.type = BT_DERIVED;
	  vtab->attr.flavor = FL_VARIABLE;
	  vtab->attr.target = 1;
	  vtab->attr.save = SAVE_EXPLICIT;
	  vtab->attr.vtab = 1;
	  vtab->refs++;
	  gfc_set_sym_referenced (vtab);
	  sprintf (name, "vtype$%s", derived->name);
	  
	  gfc_find_symbol (name, ns, 0, &vtype);
	  if (vtype == NULL)
	    {
	      gfc_component *c;
	      gfc_symbol *parent = NULL, *parent_vtab = NULL;

	      gfc_get_symbol (name, ns, &vtype);
	      if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
				  NULL, &gfc_current_locus) == FAILURE)
		goto cleanup;
	      vtype->refs++;
	      gfc_set_sym_referenced (vtype);

	      /* Add component '$hash'.  */
	      if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
		goto cleanup;
	      c->ts.type = BT_INTEGER;
	      c->ts.kind = 4;
	      c->attr.access = ACCESS_PRIVATE;
	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
						 NULL, derived->hash_value);

	      /* Add component '$size'.  */
	      if (gfc_add_component (vtype, "$size", &c) == FAILURE)
		goto cleanup;
	      c->ts.type = BT_INTEGER;
	      c->ts.kind = 4;
	      c->attr.access = ACCESS_PRIVATE;
	      /* Remember the derived type in ts.u.derived,
		 so that the correct initializer can be set later on
		 (in gfc_conv_structure).  */
	      c->ts.u.derived = derived;
	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
						 NULL, 0);

	      /* Add component $extends.  */
	      if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
		goto cleanup;
	      c->attr.pointer = 1;
	      c->attr.access = ACCESS_PRIVATE;
	      parent = gfc_get_derived_super_type (derived);
	      if (parent)
		{
		  parent_vtab = gfc_find_derived_vtab (parent);
		  c->ts.type = BT_DERIVED;
		  c->ts.u.derived = parent_vtab->ts.u.derived;
		  c->initializer = gfc_get_expr ();
		  c->initializer->expr_type = EXPR_VARIABLE;
		  gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
				     0, &c->initializer->symtree);
		}
	      else
		{
		  c->ts.type = BT_DERIVED;
		  c->ts.u.derived = vtype;
		  c->initializer = gfc_get_null_expr (NULL);
		}

	      add_procs_to_declared_vtab (derived, vtype);
	      vtype->attr.vtype = 1;
	    }

	  vtab->ts.u.derived = vtype;
	  vtab->value = gfc_default_initializer (&vtab->ts);
	}
    }

  found_sym = vtab;

cleanup:
  /* It is unexpected to have some symbols added at resolution or code
     generation time. We commit the changes in order to keep a clean state.  */
  if (found_sym)
    gfc_commit_symbols ();
  else
    gfc_undo_symbols ();

  return found_sym;
}
Пример #3
0
gfc_try
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
                        gfc_array_spec **as, bool delayed_vtab)
{
    char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
    gfc_symbol *fclass;
    gfc_symbol *vtab;
    gfc_component *c;

    if (attr->class_ok)
        /* Class container has already been built.  */
        return SUCCESS;

    attr->class_ok = attr->dummy || attr->pointer || attr->allocatable;

    if (!attr->class_ok)
        /* We can not build the class container yet.  */
        return SUCCESS;

    if (*as)
    {
        gfc_fatal_error ("Polymorphic array at %C not yet supported");
        return FAILURE;
    }

    /* Determine the name of the encapsulating type.  */
    get_unique_hashed_string (tname, ts->u.derived);
    if ((*as) && (*as)->rank && attr->allocatable)
        sprintf (name, "__class_%s_%d_a", tname, (*as)->rank);
    else if ((*as) && (*as)->rank)
        sprintf (name, "__class_%s_%d", tname, (*as)->rank);
    else if (attr->pointer)
        sprintf (name, "__class_%s_p", tname);
    else if (attr->allocatable)
        sprintf (name, "__class_%s_a", tname);
    else
        sprintf (name, "__class_%s", tname);

    gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
    if (fclass == NULL)
    {
        gfc_symtree *st;
        /* If not there, create a new symbol.  */
        fclass = gfc_new_symbol (name, ts->u.derived->ns);
        st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
        st->n.sym = fclass;
        gfc_set_sym_referenced (fclass);
        fclass->refs++;
        fclass->ts.type = BT_UNKNOWN;
        fclass->attr.abstract = ts->u.derived->attr.abstract;
        if (ts->u.derived->f2k_derived)
            fclass->f2k_derived = gfc_get_namespace (NULL, 0);
        if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
                            NULL, &gfc_current_locus) == FAILURE)
            return FAILURE;

        /* Add component '_data'.  */
        if (gfc_add_component (fclass, "_data", &c) == FAILURE)
            return FAILURE;
        c->ts = *ts;
        c->ts.type = BT_DERIVED;
        c->attr.access = ACCESS_PRIVATE;
        c->ts.u.derived = ts->u.derived;
        c->attr.class_pointer = attr->pointer;
        c->attr.pointer = attr->pointer || attr->dummy;
        c->attr.allocatable = attr->allocatable;
        c->attr.dimension = attr->dimension;
        c->attr.codimension = attr->codimension;
        c->attr.abstract = ts->u.derived->attr.abstract;
        c->as = (*as);
        c->initializer = NULL;

        /* Add component '_vptr'.  */
        if (gfc_add_component (fclass, "_vptr", &c) == FAILURE)
            return FAILURE;
        c->ts.type = BT_DERIVED;
        if (delayed_vtab)
            c->ts.u.derived = NULL;
        else
        {
            vtab = gfc_find_derived_vtab (ts->u.derived);
            gcc_assert (vtab);
            c->ts.u.derived = vtab->ts.u.derived;
        }
        c->attr.access = ACCESS_PRIVATE;
        c->attr.pointer = 1;
    }

    /* Since the extension field is 8 bit wide, we can only have
       up to 255 extension levels.  */
    if (ts->u.derived->attr.extension == 255)
    {
        gfc_error ("Maximum extension level reached with type '%s' at %L",
                   ts->u.derived->name, &ts->u.derived->declared_at);
        return FAILURE;
    }

    fclass->attr.extension = ts->u.derived->attr.extension + 1;
    fclass->attr.is_class = 1;
    ts->u.derived = fclass;
    attr->allocatable = attr->pointer = attr->dimension = 0;
    (*as) = NULL;  /* XXX */
    return SUCCESS;
}
Пример #4
0
static match
gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
{
  gfc_omp_clauses *c = gfc_get_omp_clauses ();
  locus old_loc;
  bool needs_space = true, first = true;

  *cp = NULL;
  while (1)
    {
      if ((first || gfc_match_char (',') != MATCH_YES)
	  && (needs_space && gfc_match_space () != MATCH_YES))
	break;
      needs_space = false;
      first = false;
      gfc_gobble_whitespace ();
      if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
	  && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
	  && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_PRIVATE)
	  && gfc_match_omp_variable_list ("private (",
					  &c->lists[OMP_LIST_PRIVATE], true)
	     == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
	  && gfc_match_omp_variable_list ("firstprivate (",
					  &c->lists[OMP_LIST_FIRSTPRIVATE],
					  true)
	     == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_LASTPRIVATE)
	  && gfc_match_omp_variable_list ("lastprivate (",
					  &c->lists[OMP_LIST_LASTPRIVATE],
					  true)
	     == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_COPYPRIVATE)
	  && gfc_match_omp_variable_list ("copyprivate (",
					  &c->lists[OMP_LIST_COPYPRIVATE],
					  true)
	     == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_SHARED)
	  && gfc_match_omp_variable_list ("shared (",
					  &c->lists[OMP_LIST_SHARED], true)
	     == MATCH_YES)
	continue;
      if ((mask & OMP_CLAUSE_COPYIN)
	  && gfc_match_omp_variable_list ("copyin (",
					  &c->lists[OMP_LIST_COPYIN], true)
	     == MATCH_YES)
	continue;
      old_loc = gfc_current_locus;
      if ((mask & OMP_CLAUSE_REDUCTION)
	  && gfc_match ("reduction ( ") == MATCH_YES)
	{
	  int reduction = OMP_LIST_NUM;
	  char buffer[GFC_MAX_SYMBOL_LEN + 1];
	  if (gfc_match_char ('+') == MATCH_YES)
	    reduction = OMP_LIST_PLUS;
	  else if (gfc_match_char ('*') == MATCH_YES)
	    reduction = OMP_LIST_MULT;
	  else if (gfc_match_char ('-') == MATCH_YES)
	    reduction = OMP_LIST_SUB;
	  else if (gfc_match (".and.") == MATCH_YES)
	    reduction = OMP_LIST_AND;
	  else if (gfc_match (".or.") == MATCH_YES)
	    reduction = OMP_LIST_OR;
	  else if (gfc_match (".eqv.") == MATCH_YES)
	    reduction = OMP_LIST_EQV;
	  else if (gfc_match (".neqv.") == MATCH_YES)
	    reduction = OMP_LIST_NEQV;
	  else if (gfc_match_name (buffer) == MATCH_YES)
	    {
	      gfc_symbol *sym;
	      const char *n = buffer;

	      gfc_find_symbol (buffer, NULL, 1, &sym);
	      if (sym != NULL)
		{
		  if (sym->attr.intrinsic)
		    n = sym->name;
		  else if ((sym->attr.flavor != FL_UNKNOWN
			    && sym->attr.flavor != FL_PROCEDURE)
			   || sym->attr.external
			   || sym->attr.generic
			   || sym->attr.entry
			   || sym->attr.result
			   || sym->attr.dummy
			   || sym->attr.subroutine
			   || sym->attr.pointer
			   || sym->attr.target
			   || sym->attr.cray_pointer
			   || sym->attr.cray_pointee
			   || (sym->attr.proc != PROC_UNKNOWN
			       && sym->attr.proc != PROC_INTRINSIC)
			   || sym->attr.if_source != IFSRC_UNKNOWN
			   || sym == sym->ns->proc_name)
		    {
		      gfc_error_now ("%s is not INTRINSIC procedure name "
				     "at %C", buffer);
		      sym = NULL;
		    }
		  else
		    n = sym->name;
		}
	      if (strcmp (n, "max") == 0)
		reduction = OMP_LIST_MAX;
	      else if (strcmp (n, "min") == 0)
		reduction = OMP_LIST_MIN;
	      else if (strcmp (n, "iand") == 0)
		reduction = OMP_LIST_IAND;
	      else if (strcmp (n, "ior") == 0)
		reduction = OMP_LIST_IOR;
	      else if (strcmp (n, "ieor") == 0)
		reduction = OMP_LIST_IEOR;
	      if (reduction != OMP_LIST_NUM
		  && sym != NULL
		  && ! sym->attr.intrinsic
		  && ! sym->attr.use_assoc
		  && ((sym->attr.flavor == FL_UNKNOWN
		       && gfc_add_flavor (&sym->attr, FL_PROCEDURE,
					  sym->name, NULL) == FAILURE)
		      || gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
		{
		  gfc_free_omp_clauses (c);
		  return MATCH_ERROR;
		}
	    }
	  if (reduction != OMP_LIST_NUM
	      && gfc_match_omp_variable_list (" :", &c->lists[reduction],
					      false)
		 == MATCH_YES)
	    continue;
	  else
	    gfc_current_locus = old_loc;
	}
      if ((mask & OMP_CLAUSE_DEFAULT)
	  && c->default_sharing == OMP_DEFAULT_UNKNOWN)
	{
	  if (gfc_match ("default ( shared )") == MATCH_YES)
	    c->default_sharing = OMP_DEFAULT_SHARED;
	  else if (gfc_match ("default ( private )") == MATCH_YES)
	    c->default_sharing = OMP_DEFAULT_PRIVATE;
	  else if (gfc_match ("default ( none )") == MATCH_YES)
	    c->default_sharing = OMP_DEFAULT_NONE;
	  else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
	    c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
	  if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
	    continue;
	}
      old_loc = gfc_current_locus;
      if ((mask & OMP_CLAUSE_SCHEDULE)
	  && c->sched_kind == OMP_SCHED_NONE
	  && gfc_match ("schedule ( ") == MATCH_YES)
	{
	  if (gfc_match ("static") == MATCH_YES)
	    c->sched_kind = OMP_SCHED_STATIC;
	  else if (gfc_match ("dynamic") == MATCH_YES)
	    c->sched_kind = OMP_SCHED_DYNAMIC;
	  else if (gfc_match ("guided") == MATCH_YES)
	    c->sched_kind = OMP_SCHED_GUIDED;
	  else if (gfc_match ("runtime") == MATCH_YES)
	    c->sched_kind = OMP_SCHED_RUNTIME;
	  else if (gfc_match ("auto") == MATCH_YES)
	    c->sched_kind = OMP_SCHED_AUTO;
	  if (c->sched_kind != OMP_SCHED_NONE)
	    {
	      match m = MATCH_NO;
	      if (c->sched_kind != OMP_SCHED_RUNTIME
		  && c->sched_kind != OMP_SCHED_AUTO)
		m = gfc_match (" , %e )", &c->chunk_size);
	      if (m != MATCH_YES)
		m = gfc_match_char (')');
	      if (m != MATCH_YES)
		c->sched_kind = OMP_SCHED_NONE;
	    }
	  if (c->sched_kind != OMP_SCHED_NONE)
	    continue;
	  else
	    gfc_current_locus = old_loc;
	}
      if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
	  && gfc_match ("ordered") == MATCH_YES)
	{
	  c->ordered = needs_space = true;
	  continue;
	}
      if ((mask & OMP_CLAUSE_UNTIED) && !c->untied
	  && gfc_match ("untied") == MATCH_YES)
	{
	  c->untied = needs_space = true;
	  continue;
	}
      if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
	{
	  gfc_expr *cexpr = NULL;
	  match m = gfc_match ("collapse ( %e )", &cexpr);

	  if (m == MATCH_YES)
	    {
	      int collapse;
	      const char *p = gfc_extract_int (cexpr, &collapse);
	      if (p)
		{
		  gfc_error_now (p);
		  collapse = 1;
		}
	      else if (collapse <= 0)
		{
		  gfc_error_now ("COLLAPSE clause argument not"
				 " constant positive integer at %C");
		  collapse = 1;
		}
	      c->collapse = collapse;
	      gfc_free_expr (cexpr);
	      continue;
	    }
	}

      break;
    }

  if (gfc_match_omp_eos () != MATCH_YES)
    {
      gfc_free_omp_clauses (c);
      return MATCH_ERROR;
    }

  *cp = c;
  return MATCH_YES;
}