OSDN Git Service

2009-11-26 Jerry DeLisle <jvdelisle@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / expr.c
index ea76653..cbd3172 100644 (file)
@@ -1,5 +1,5 @@
 /* Routines for manipulation of expression nodes.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -156,8 +156,12 @@ free_expr0 (gfc_expr *e)
          break;
 
        case BT_COMPLEX:
+#ifdef HAVE_mpc
+         mpc_clear (e->value.complex);
+#else
          mpfr_clear (e->value.complex.r);
          mpfr_clear (e->value.complex.i);
+#endif
          break;
 
        default:
@@ -182,6 +186,7 @@ free_expr0 (gfc_expr *e)
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gfc_free_actual_arglist (e->value.compcall.actual);
       break;
 
@@ -325,6 +330,36 @@ gfc_has_vector_index (gfc_expr *e)
 }
 
 
+/* Insert a reference to the component of the given name.
+   Only to be used with CLASS containers.  */
+
+void
+gfc_add_component_ref (gfc_expr *e, const char *name)
+{
+  gfc_ref **tail = &(e->ref);
+  gfc_ref *next = NULL;
+  gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
+  while (*tail != NULL)
+    {
+      if ((*tail)->type == REF_COMPONENT)
+       derived = (*tail)->u.c.component->ts.u.derived;
+      if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
+       break;
+      tail = &((*tail)->next);
+    }
+  if (*tail != NULL && strcmp (name, "$data") == 0)
+    next = *tail;
+  (*tail) = gfc_get_ref();
+  (*tail)->next = next;
+  (*tail)->type = REF_COMPONENT;
+  (*tail)->u.c.sym = derived;
+  (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
+  gcc_assert((*tail)->u.c.component);
+  if (!next)
+    e->ts = (*tail)->u.c.component->ts;
+}
+
+
 /* Copy a shape array.  */
 
 mpz_t *
@@ -438,10 +473,15 @@ gfc_copy_expr (gfc_expr *p)
 
        case BT_COMPLEX:
          gfc_set_model_kind (q->ts.kind);
+#ifdef HAVE_mpc
+         mpc_init2 (q->value.complex, mpfr_get_default_prec());
+         mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
+#else
          mpfr_init (q->value.complex.r);
          mpfr_init (q->value.complex.i);
          mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
          mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
+#endif
          break;
 
        case BT_CHARACTER:
@@ -471,6 +511,7 @@ gfc_copy_expr (gfc_expr *p)
        case BT_HOLLERITH:
        case BT_LOGICAL:
        case BT_DERIVED:
+       case BT_CLASS:
          break;                /* Already done.  */
 
        case BT_PROCEDURE:
@@ -507,6 +548,7 @@ gfc_copy_expr (gfc_expr *p)
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       q->value.compcall.actual =
        gfc_copy_actual_arglist (p->value.compcall.actual);
       q->value.compcall.tbp = p->value.compcall.tbp;
@@ -1028,6 +1070,14 @@ find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
   mpz_init_set_ui (span, 1);
   for (i = 0; i < ar->dimen; i++)
     {
+      if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
+         || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
+       {
+         t = FAILURE;
+         cons = NULL;
+         goto depart;
+       }
+
       e = gfc_copy_expr (ar->start[i]);
       if (e->expr_type != EXPR_CONSTANT)
        {
@@ -1035,14 +1085,15 @@ find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
          goto depart;
        }
 
+      gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
+                 && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
+
       /* Check the bounds.  */
       if ((ar->as->upper[i]
-          && ar->as->upper[i]->expr_type == EXPR_CONSTANT
           && mpz_cmp (e->value.integer,
                       ar->as->upper[i]->value.integer) > 0)
-         || (ar->as->lower[i]->expr_type == EXPR_CONSTANT
-             && mpz_cmp (e->value.integer,
-                         ar->as->lower[i]->value.integer) < 0))
+         || (mpz_cmp (e->value.integer,
+                      ar->as->lower[i]->value.integer) < 0))
        {
          gfc_error ("Index in dimension %d is out of bounds "
                     "at %L", i + 1, &ar->c_where[i]);
@@ -1201,7 +1252,12 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
            }
 
          gcc_assert (begin->rank == 1);
-         gcc_assert (begin->shape);
+         /* Zero-sized arrays have no shape and no elements, stop early.  */
+         if (!begin->shape) 
+           {
+             mpz_init_set_ui (nelts, 0);
+             break;
+           }
 
          vecsub[d] = begin->value.constructor;
          mpz_set (ctr[d], vecsub[d]->expr->value.integer);
@@ -1479,14 +1535,13 @@ simplify_const_ref (gfc_expr *p)
                      else
                        string_len = 0;
 
-                     if (!p->ts.cl)
-                       {
-                         p->ts.cl = gfc_get_charlen ();
-                         p->ts.cl->next = NULL;
-                         p->ts.cl->length = NULL;
-                       }
-                     gfc_free_expr (p->ts.cl->length);
-                     p->ts.cl->length = gfc_int_expr (string_len);
+                     if (!p->ts.u.cl)
+                       p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
+                                                     NULL);
+                     else
+                       gfc_free_expr (p->ts.u.cl->length);
+
+                     p->ts.u.cl->length = gfc_int_expr (string_len);
                    }
                }
              gfc_free_ref_list (p->ref);
@@ -1638,18 +1693,16 @@ gfc_simplify_expr (gfc_expr *p, int type)
          gfc_char_t *s;
          int start, end;
 
+         start = 0;
          if (p->ref && p->ref->u.ss.start)
            {
              gfc_extract_int (p->ref->u.ss.start, &start);
              start--;  /* Convert from one-based to zero-based.  */
            }
-         else
-           start = 0;
 
+         end = p->value.character.length;
          if (p->ref && p->ref->u.ss.end)
            gfc_extract_int (p->ref->u.ss.end, &end);
-         else
-           end = p->value.character.length;
 
          s = gfc_get_wide_string (end - start + 2);
          memcpy (s, p->value.character.string + start,
@@ -1658,10 +1711,8 @@ gfc_simplify_expr (gfc_expr *p, int type)
          gfc_free (p->value.character.string);
          p->value.character.string = s;
          p->value.character.length = end - start;
-         p->ts.cl = gfc_get_charlen ();
-         p->ts.cl->next = gfc_current_ns->cl_list;
-         gfc_current_ns->cl_list = p->ts.cl;
-         p->ts.cl->length = gfc_int_expr (p->value.character.length);
+         p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+         p->ts.u.cl->length = gfc_int_expr (p->value.character.length);
          gfc_free_ref_list (p->ref);
          p->ref = NULL;
          p->expr_type = EXPR_CONSTANT;
@@ -1714,6 +1765,7 @@ gfc_simplify_expr (gfc_expr *p, int type)
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gcc_unreachable ();
       break;
     }
@@ -1929,16 +1981,6 @@ check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
       if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
        goto not_numeric;
 
-      if (e->value.op.op == INTRINSIC_POWER
-         && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
-       {
-         if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
-                             "exponent in an initialization "
-                             "expression at %L", &op2->where)
-             == FAILURE)
-           return FAILURE;
-       }
-
       break;
 
     case INTRINSIC_CONCAT:
@@ -2090,7 +2132,7 @@ check_inquiry (gfc_expr *e, int not_restricted)
           with LEN, as required by the standard.  */
        if (i == 5 && not_restricted
            && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
-           && ap->expr->symtree->n.sym->ts.cl->length == NULL)
+           && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
          {
            gfc_error ("Assumed character length variable '%s' in constant "
                       "expression at %L", e->symtree->n.sym->name, &e->where);
@@ -2120,8 +2162,16 @@ check_transformational (gfc_expr *e)
     "selected_real_kind", "transfer", "trim", NULL
   };
 
+  static const char * const trans_func_f2003[] =  {
+    "all", "any", "count", "dot_product", "matmul", "null", "pack",
+    "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
+    "selected_real_kind", "spread", "sum", "transfer", "transpose",
+    "trim", "unpack", NULL
+  };
+
   int i;
   const char *name;
+  const char *const *functions;
 
   if (!e->value.function.isym
       || !e->value.function.isym->transformational)
@@ -2129,31 +2179,23 @@ check_transformational (gfc_expr *e)
 
   name = e->symtree->n.sym->name;
 
+  functions = (gfc_option.allow_std & GFC_STD_F2003) 
+               ? trans_func_f2003 : trans_func_f95;
+
   /* NULL() is dealt with below.  */
   if (strcmp ("null", name) == 0)
     return MATCH_NO;
 
-  for (i = 0; trans_func_f95[i]; i++)
-    if (strcmp (trans_func_f95[i], name) == 0)
-      break;
+  for (i = 0; functions[i]; i++)
+    if (strcmp (functions[i], name) == 0)
+       break;
 
-  /* FIXME, F2003: implement translation of initialization
-     expressions before enabling this check. For F95, error
-     out if the transformational function is not in the list.  */
-#if 0
-  if (trans_func_f95[i] == NULL
-      && gfc_notify_std (GFC_STD_F2003, 
-                        "transformational intrinsic '%s' at %L is not permitted "
-                        "in an initialization expression", name, &e->where) == FAILURE)
-    return MATCH_ERROR;
-#else
-  if (trans_func_f95[i] == NULL)
+  if (functions[i] == NULL)
     {
       gfc_error("transformational intrinsic '%s' at %L is not permitted "
                "in an initialization expression", name, &e->where);
       return MATCH_ERROR;
     }
-#endif
 
   return check_init_expr_arguments (e);
 }
@@ -2415,7 +2457,11 @@ gfc_reduce_init_expr (gfc_expr *expr)
 
 
 /* Match an initialization expression.  We work by first matching an
-   expression, then reducing it to a constant.  */
+   expression, then reducing it to a constant.  The reducing it to 
+   constant part requires a global variable to flag the prohibition
+   of a non-integer exponent in -std=f95 mode.  */
+
+bool init_flag = false;
 
 match
 gfc_match_init_expr (gfc_expr **result)
@@ -2426,18 +2472,25 @@ gfc_match_init_expr (gfc_expr **result)
 
   expr = NULL;
 
+  init_flag = true;
+
   m = gfc_match_expr (&expr);
   if (m != MATCH_YES)
-    return m;
+    {
+      init_flag = false;
+      return m;
+    }
 
   t = gfc_reduce_init_expr (expr);
   if (t != SUCCESS)
     {
       gfc_free_expr (expr);
+      init_flag = false;
       return MATCH_ERROR;
     }
 
   *result = expr;
+  init_flag = false;
 
   return MATCH_YES;
 }
@@ -2759,18 +2812,25 @@ gfc_specification_expr (gfc_expr *e)
 /* Given two expressions, make sure that the arrays are conformable.  */
 
 gfc_try
-gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
+gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
 {
   int op1_flag, op2_flag, d;
   mpz_t op1_size, op2_size;
   gfc_try t;
 
+  va_list argp;
+  char buffer[240];
+
   if (op1->rank == 0 || op2->rank == 0)
     return SUCCESS;
 
+  va_start (argp, optype_msgid);
+  vsnprintf (buffer, 240, optype_msgid, argp);
+  va_end (argp);
+
   if (op1->rank != op2->rank)
     {
-      gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid),
+      gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
                 op1->rank, op2->rank, &op1->where);
       return FAILURE;
     }
@@ -2785,7 +2845,7 @@ gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
        {
          gfc_error ("Different shape for %s at %L on dimension %d "
-                    "(%d and %d)", _(optype_msgid), &op1->where, d + 1,
+                    "(%d and %d)", _(buffer), &op1->where, d + 1,
                     (int) mpz_get_si (op1_size),
                     (int) mpz_get_si (op2_size));
 
@@ -2903,7 +2963,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
 
   if (rvalue->expr_type == EXPR_NULL)
     {  
-      if (lvalue->symtree->n.sym->attr.pointer
+      if (has_pointer && (ref == NULL || ref->next == NULL)
          && lvalue->symtree->n.sym->attr.data)
         return SUCCESS;
       else
@@ -2933,7 +2993,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
 
   /* Check size of array assignments.  */
   if (lvalue->rank != 0 && rvalue->rank != 0
-      && gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
+      && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
     return FAILURE;
 
   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
@@ -3023,7 +3083,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   symbol_attribute attr;
   gfc_ref *ref;
   int is_pure;
-  int pointer, check_intent_in;
+  int pointer, check_intent_in, proc_pointer;
 
   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
       && !lvalue->symtree->n.sym->attr.proc_pointer)
@@ -3034,7 +3094,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
     }
 
   if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
-      && lvalue->symtree->n.sym->attr.use_assoc)
+      && lvalue->symtree->n.sym->attr.use_assoc
+      && !lvalue->symtree->n.sym->attr.proc_pointer)
     {
       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
                 "l-value since it is a procedure",
@@ -3046,16 +3107,19 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   /* Check INTENT(IN), unless the object itself is the component or
      sub-component of a pointer.  */
   check_intent_in = 1;
-  pointer = lvalue->symtree->n.sym->attr.pointer
-             | lvalue->symtree->n.sym->attr.proc_pointer;
+  pointer = lvalue->symtree->n.sym->attr.pointer;
+  proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
 
   for (ref = lvalue->ref; ref; ref = ref->next)
     {
       if (pointer)
        check_intent_in = 0;
 
-      if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
-       pointer = 1;
+      if (ref->type == REF_COMPONENT)
+       {
+         pointer = ref->u.c.component->attr.pointer;
+         proc_pointer = ref->u.c.component->attr.proc_pointer;
+       }
 
       if (ref->type == REF_ARRAY && ref->next == NULL)
        {
@@ -3091,7 +3155,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       return FAILURE;
     }
 
-  if (!pointer)
+  if (!pointer && !proc_pointer
+       && !(lvalue->ts.type == BT_CLASS
+               && lvalue->ts.u.derived->components->attr.pointer))
     {
       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
       return FAILURE;
@@ -3112,9 +3178,104 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
     return SUCCESS;
 
-  /* TODO checks on rvalue for a procedure pointer assignment.  */
-  if (lvalue->symtree->n.sym->attr.proc_pointer)
-    return SUCCESS;
+  /* Checks on rvalue for procedure pointer assignments.  */
+  if (proc_pointer)
+    {
+      char err[200];
+      gfc_symbol *s1,*s2;
+      gfc_component *comp;
+      const char *name;
+
+      attr = gfc_expr_attr (rvalue);
+      if (!((rvalue->expr_type == EXPR_NULL)
+           || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
+           || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
+           || (rvalue->expr_type == EXPR_VARIABLE
+               && attr.flavor == FL_PROCEDURE)))
+       {
+         gfc_error ("Invalid procedure pointer assignment at %L",
+                    &rvalue->where);
+         return FAILURE;
+       }
+      if (attr.abstract)
+       {
+         gfc_error ("Abstract interface '%s' is invalid "
+                    "in procedure pointer assignment at %L",
+                    rvalue->symtree->name, &rvalue->where);
+         return FAILURE;
+       }
+      /* Check for C727.  */
+      if (attr.flavor == FL_PROCEDURE)
+       {
+         if (attr.proc == PROC_ST_FUNCTION)
+           {
+             gfc_error ("Statement function '%s' is invalid "
+                        "in procedure pointer assignment at %L",
+                        rvalue->symtree->name, &rvalue->where);
+             return FAILURE;
+           }
+         if (attr.proc == PROC_INTERNAL &&
+             gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
+                             "invalid in procedure pointer assignment at %L",
+                             rvalue->symtree->name, &rvalue->where) == FAILURE)
+           return FAILURE;
+       }
+
+      /* Ensure that the calling convention is the same. As other attributes
+        such as DLLEXPORT may differ, one explicitly only tests for the
+        calling conventions.  */
+      if (rvalue->expr_type == EXPR_VARIABLE
+         && lvalue->symtree->n.sym->attr.ext_attr
+              != rvalue->symtree->n.sym->attr.ext_attr)
+       {
+         symbol_attribute calls;
+
+         calls.ext_attr = 0;
+         gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
+         gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
+         gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
+
+         if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
+             != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
+           {
+             gfc_error ("Mismatch in the procedure pointer assignment "
+                        "at %L: mismatch in the calling convention",
+                        &rvalue->where);
+         return FAILURE;
+           }
+       }
+
+      if (gfc_is_proc_ptr_comp (lvalue, &comp))
+       s1 = comp->ts.interface;
+      else
+       s1 = lvalue->symtree->n.sym;
+
+      if (gfc_is_proc_ptr_comp (rvalue, &comp))
+       {
+         s2 = comp->ts.interface;
+         name = comp->name;
+       }
+      else if (rvalue->expr_type == EXPR_FUNCTION)
+       {
+         s2 = rvalue->symtree->n.sym->result;
+         name = rvalue->symtree->n.sym->result->name;
+       }
+      else
+       {
+         s2 = rvalue->symtree->n.sym;
+         name = rvalue->symtree->n.sym->name;
+       }
+
+      if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
+                                              err, sizeof(err)))
+       {
+         gfc_error ("Interface mismatch in procedure pointer assignment "
+                    "at %L: %s", &rvalue->where, err);
+         return FAILURE;
+       }
+
+      return SUCCESS;
+    }
 
   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
     {
@@ -3124,7 +3285,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       return FAILURE;
     }
 
-  if (lvalue->ts.kind != rvalue->ts.kind)
+  if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
     {
       gfc_error ("Different kind type parameters in pointer "
                 "assignment at %L", &lvalue->where);
@@ -3142,15 +3303,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   if (rvalue->expr_type == EXPR_NULL)
     return SUCCESS;
 
-  if (lvalue->ts.type == BT_CHARACTER
-      && lvalue->ts.cl && rvalue->ts.cl
-      && lvalue->ts.cl->length && rvalue->ts.cl->length
-      && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
-                                   rvalue->ts.cl->length)) == 1)
+  if (lvalue->ts.type == BT_CHARACTER)
     {
-      gfc_error ("Different character lengths in pointer "
-                "assignment at %L", &lvalue->where);
-      return FAILURE;
+      gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
+      if (t == FAILURE)
+       return FAILURE;
     }
 
   if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
@@ -3208,7 +3365,10 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
   lvalue.symtree->n.sym = sym;
   lvalue.where = sym->declared_at;
 
-  if (sym->attr.pointer || sym->attr.proc_pointer)
+  if (sym->attr.pointer || sym->attr.proc_pointer
+      || (sym->ts.type == BT_CLASS 
+         && sym->ts.u.derived->components->attr.pointer
+         && rvalue->expr_type == EXPR_NULL))
     r = gfc_check_pointer_assign (&lvalue, rvalue);
   else
     r = gfc_check_assign (&lvalue, rvalue, 1);
@@ -3229,7 +3389,7 @@ gfc_default_initializer (gfc_typespec *ts)
   gfc_component *c;
 
   /* See if we have a default initializer.  */
-  for (c = ts->derived->components; c; c = c->next)
+  for (c = ts->u.derived->components; c; c = c->next)
     if (c->initializer || c->attr.allocatable)
       break;
 
@@ -3240,10 +3400,10 @@ gfc_default_initializer (gfc_typespec *ts)
   init = gfc_get_expr ();
   init->expr_type = EXPR_STRUCTURE;
   init->ts = *ts;
-  init->where = ts->derived->declared_at;
+  init->where = ts->u.derived->declared_at;
 
   tail = NULL;
-  for (c = ts->derived->components; c; c = c->next)
+  for (c = ts->u.derived->components; c; c = c->next)
     {
       if (tail == NULL)
        init->value.constructor = tail = gfc_get_constructor ();
@@ -3313,10 +3473,10 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
     return true;
 
   if (expr->ts.type == BT_CHARACTER
-       && expr->ts.cl
-       && expr->ts.cl->length
-       && expr->ts.cl->length->expr_type != EXPR_CONSTANT
-       && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
+       && expr->ts.u.cl
+       && expr->ts.u.cl->length
+       && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
+       && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
     return true;
 
   switch (expr->expr_type)
@@ -3394,11 +3554,11 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
 
        case REF_COMPONENT:
          if (ref->u.c.component->ts.type == BT_CHARACTER
-               && ref->u.c.component->ts.cl
-               && ref->u.c.component->ts.cl->length
-               && ref->u.c.component->ts.cl->length->expr_type
+               && ref->u.c.component->ts.u.cl
+               && ref->u.c.component->ts.u.cl->length
+               && ref->u.c.component->ts.u.cl->length->expr_type
                     != EXPR_CONSTANT
-               && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
+               && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
                                      sym, func, f))
            return true;
 
@@ -3442,6 +3602,34 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr)
 }
 
 
+/* Determine if an expression is a procedure pointer component. If yes, the
+   argument 'comp' will point to the component (provided that 'comp' was
+   provided).  */
+
+bool
+gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
+{
+  gfc_ref *ref;
+  bool ppc = false;
+
+  if (!expr || !expr->ref)
+    return false;
+
+  ref = expr->ref;
+  while (ref->next)
+    ref = ref->next;
+
+  if (ref->type == REF_COMPONENT)
+    {
+      ppc = ref->u.c.component->attr.proc_pointer;
+      if (ppc && comp)
+       *comp = ref->u.c.component;
+    }
+
+  return ppc;
+}
+
+
 /* Walk an expression tree and check each variable encountered for being typed.
    If strict is not set, a top-level variable is tolerated untyped in -std=gnu
    mode as is a basic arithmetic expression using those; this is for things in
@@ -3510,11 +3698,18 @@ gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
 static bool
 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
 {
-  if ((expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_FUNCTION)
+  if ((expr->expr_type == EXPR_VARIABLE 
+       || (expr->expr_type == EXPR_FUNCTION
+          && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
       && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
     {
       gfc_symtree *stree;
-      gfc_get_sym_tree (expr->symtree->name, sym->formal_ns, &stree);
+      gfc_namespace *ns = sym->formal_ns;
+      /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
+        the symtree rather than create a new one (and probably fail later).  */
+      stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
+                               expr->symtree->n.sym->name);
+      gcc_assert (stree);
       stree->n.sym->attr = expr->symtree->n.sym->attr;
       expr->symtree = stree;
     }
@@ -3526,3 +3721,39 @@ gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
 {
   gfc_traverse_expr (expr, dest, &replace_symbol, 0);
 }
+
+/* The following is analogous to 'replace_symbol', and needed for copying
+   interfaces for procedure pointer components. The argument 'sym' must formally
+   be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
+   However, it gets actually passed a gfc_component (i.e. the procedure pointer
+   component in whose formal_ns the arguments have to be).  */
+
+static bool
+replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+  gfc_component *comp;
+  comp = (gfc_component *)sym;
+  if ((expr->expr_type == EXPR_VARIABLE 
+       || (expr->expr_type == EXPR_FUNCTION
+          && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
+      && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
+    {
+      gfc_symtree *stree;
+      gfc_namespace *ns = comp->formal_ns;
+      /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
+        the symtree rather than create a new one (and probably fail later).  */
+      stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
+                               expr->symtree->n.sym->name);
+      gcc_assert (stree);
+      stree->n.sym->attr = expr->symtree->n.sym->attr;
+      expr->symtree = stree;
+    }
+  return false;
+}
+
+void
+gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
+{
+  gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
+}
+