Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 168596)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3078,3083 ****
--- 3078,3084 ----
  		 argument and another one.  */
  	      if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
  		{
+ 		  gfc_expr *iarg;
  		  sym_intent intent;
  
  		  if (fsym != NULL)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3088,3093 ****
--- 3089,3113 ----
  		  if (gfc_check_fncall_dependency (e, intent, sym, args,
  						   NOT_ELEMENTAL))
  		    parmse.force_tmp = 1;
+ 
+ 		  iarg = e->value.function.actual->expr;
+ 
+ 		  /* Temporary needed if aliasing due to host association.  */
+ 		  if (sym->attr.contained
+ 			&& !sym->attr.pure
+ 			&& !sym->attr.implicit_pure
+ 			&& !sym->attr.use_assoc
+ 			&& iarg->expr_type == EXPR_VARIABLE
+ 			&& sym->ns == iarg->symtree->n.sym->ns)
+ 		    parmse.force_tmp = 1;
+ 
+ 		  /* Ditto within module.  */
+ 		  if (sym->attr.use_assoc
+ 			&& !sym->attr.pure
+ 			&& !sym->attr.implicit_pure
+ 			&& iarg->expr_type == EXPR_VARIABLE
+ 			&& sym->module == iarg->symtree->n.sym->module)
+ 		    parmse.force_tmp = 1;
  		}
  
  	      if (e->expr_type == EXPR_VARIABLE
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3382,3388 ****
  
  	  /* If the lhs of an assignment x = f(..) is allocatable and
  	     f2003 is allowed, we must do the automatic reallocation.
! 	     TODO - deal with instrinsics, without using a temporary.  */
  	  if (gfc_option.flag_realloc_lhs
  		&& se->ss && se->ss->loop_chain
  		&& se->ss->loop_chain->is_alloc_lhs
--- 3402,3408 ----
  
  	  /* If the lhs of an assignment x = f(..) is allocatable and
  	     f2003 is allowed, we must do the automatic reallocation.
! 	     TODO - deal with intrinsics, without using a temporary.  */
  	  if (gfc_option.flag_realloc_lhs
  		&& se->ss && se->ss->loop_chain
  		&& se->ss->loop_chain->is_alloc_lhs
*************** arrayfunc_assign_needs_temporary (gfc_ex
*** 5376,5393 ****
    if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
      return true;
  
    /* A PURE function can unconditionally be called without a temporary.  */
    if (expr2->value.function.esym != NULL
        && expr2->value.function.esym->attr.pure)
      return false;
  
!   /* TODO a function that could correctly be declared PURE but is not
!      could do with returning false as well.  */
  
    if (!sym->attr.use_assoc
  	&& !sym->attr.in_common
  	&& !sym->attr.pointer
  	&& !sym->attr.target
  	&& expr2->value.function.esym)
      {
        /* A temporary is not needed if the function is not contained and
--- 5396,5428 ----
    if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
      return true;
  
+   /* If the lhs has been host_associated, is in common, a pointer or is
+      a target and the function is not using a RESULT variable, aliasing
+      can occur and a temporary is needed.  */
+   if ((sym->attr.host_assoc
+ 	   || sym->attr.in_common
+ 	   || sym->attr.pointer
+ 	   || sym->attr.target)
+ 	&& expr2->symtree != NULL
+ 	&& expr2->symtree->n.sym == expr2->symtree->n.sym->result)
+     return true;
+ 
    /* A PURE function can unconditionally be called without a temporary.  */
    if (expr2->value.function.esym != NULL
        && expr2->value.function.esym->attr.pure)
      return false;
  
!   /* Implicit_pure functions are those which could legally be declared
!      to be PURE.  */
!   if (expr2->value.function.esym != NULL
!       && expr2->value.function.esym->attr.implicit_pure)
!     return false;
  
    if (!sym->attr.use_assoc
  	&& !sym->attr.in_common
  	&& !sym->attr.pointer
  	&& !sym->attr.target
+ 	&& !sym->attr.cray_pointee
  	&& expr2->value.function.esym)
      {
        /* A temporary is not needed if the function is not contained and
*************** gfc_trans_assignment (gfc_expr * expr1, 
*** 6003,6009 ****
  		      bool dealloc)
  {
    tree tmp;
!   
    if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
      {
        gfc_error ("Assignment to deferred-length character variable at %L "
--- 6038,6044 ----
  		      bool dealloc)
  {
    tree tmp;
! 
    if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
      {
        gfc_error ("Assignment to deferred-length character variable at %L "
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 168596)
--- gcc/fortran/symbol.c	(working copy)
*************** gfc_add_save (symbol_attribute *attr, sa
*** 1110,1115 ****
--- 1110,1118 ----
        return FAILURE;
      }
  
+   if (s == SAVE_EXPLICIT && gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
      {
  	if (gfc_notify_std (GFC_STD_LEGACY, 
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c	(revision 168596)
--- gcc/fortran/decl.c	(working copy)
*************** match_old_style_init (const char *name)
*** 502,507 ****
--- 502,510 ----
        return MATCH_ERROR;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    /* Mark the variable as having appeared in a data statement.  */
    if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
      {
*************** gfc_match_data (void)
*** 560,565 ****
--- 563,571 ----
        return MATCH_ERROR;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    return MATCH_YES;
  
  cleanup:
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 168596)
--- gcc/fortran/gfortran.h	(working copy)
*************** typedef struct
*** 723,728 ****
--- 723,733 ----
    unsigned sequence:1, elemental:1, pure:1, recursive:1;
    unsigned unmaskable:1, masked:1, contained:1, mod_proc:1, abstract:1;
  
+   /* This is set if a contained procedure could be declared pure.  This is
+      used for certain optimizations that require the result or arguments
+      cannot alias.  */
+   unsigned implicit_pure:1;
+ 
    /* This is set if the subroutine doesn't return.  Currently, this
       is only possible for intrinsic subroutines.  */
    unsigned noreturn:1;
*************** void gfc_resolve (gfc_namespace *);
*** 2736,2741 ****
--- 2741,2747 ----
  void gfc_resolve_blocks (gfc_code *, gfc_namespace *);
  int gfc_impure_variable (gfc_symbol *);
  int gfc_pure (gfc_symbol *);
+ int gfc_implicit_pure (gfc_symbol *);
  int gfc_elemental (gfc_symbol *);
  gfc_try gfc_resolve_iterator (gfc_iterator *, bool);
  gfc_try find_forall_index (gfc_expr *, gfc_symbol *, int);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(revision 168596)
--- gcc/fortran/expr.c	(working copy)
*************** gfc_check_pointer_assign (gfc_expr *lval
*** 3227,3233 ****
  {
    symbol_attribute attr;
    gfc_ref *ref;
!   bool is_pure, rank_remap;
    int proc_pointer;
  
    if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
--- 3227,3233 ----
  {
    symbol_attribute attr;
    gfc_ref *ref;
!   bool is_pure, is_implicit_pure, rank_remap;
    int proc_pointer;
  
    if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
*************** gfc_check_pointer_assign (gfc_expr *lval
*** 3311,3316 ****
--- 3311,3317 ----
      }
  
    is_pure = gfc_pure (NULL);
+   is_implicit_pure = gfc_implicit_pure (NULL);
  
    /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
       kind, etc for lvalue and rvalue must match, and rvalue must be a
*************** gfc_check_pointer_assign (gfc_expr *lval
*** 3519,3524 ****
--- 3520,3529 ----
  		 "procedure at %L", &rvalue->where);
      }
  
+   if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+     
+ 
    if (gfc_has_vector_index (rvalue))
      {
        gfc_error ("Pointer assignment with vector subscript "
*************** gfc_check_vardef_context (gfc_expr* e, b
*** 4461,4466 ****
--- 4466,4474 ----
        return FAILURE;
      }
  
+   if (!pointer && gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    /* Check variable definition context for associate-names.  */
    if (!pointer && sym->assoc)
      {
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c	(revision 168596)
--- gcc/fortran/module.c	(working copy)
*************** typedef enum
*** 1675,1681 ****
    AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
    AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
    AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
!   AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER
  }
  ab_attribute;
  
--- 1675,1682 ----
    AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
    AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
    AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
!   AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
!   AB_IMPLICIT_PURE
  }
  ab_attribute;
  
*************** static const mstring attr_bits[] =
*** 1725,1730 ****
--- 1726,1732 ----
      minit ("VTYPE", AB_VTYPE),
      minit ("VTAB", AB_VTAB),
      minit ("CLASS_POINTER", AB_CLASS_POINTER),
+     minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
      minit (NULL, -1)
  };
  
*************** mio_symbol_attribute (symbol_attribute *
*** 1859,1864 ****
--- 1861,1868 ----
  	MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
        if (attr->pure)
  	MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
+       if (attr->implicit_pure)
+ 	MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
        if (attr->recursive)
  	MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
        if (attr->always_explicit)
*************** mio_symbol_attribute (symbol_attribute *
*** 1990,1995 ****
--- 1994,2002 ----
  	    case AB_PURE:
  	      attr->pure = 1;
  	      break;
+ 	    case AB_IMPLICIT_PURE:
+ 	      attr->implicit_pure = 1;
+ 	      break;
  	    case AB_RECURSIVE:
  	      attr->recursive = 1;
  	      break;
Index: gcc/fortran/io.c
===================================================================
*** gcc/fortran/io.c	(revision 168596)
--- gcc/fortran/io.c	(working copy)
*************** match_vtag (const io_tag *tag, gfc_expr 
*** 1315,1320 ****
--- 1315,1323 ----
        return MATCH_ERROR;
      }
  
+   if (gfc_implicit_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    *v = result;
    return MATCH_YES;
  }
*************** gfc_match_open (void)
*** 1824,1829 ****
--- 1827,1835 ----
        goto cleanup;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    warn = (open->err || open->iostat) ? true : false;
  
    /* Checks on NEWUNIT specifier.  */
*************** gfc_match_close (void)
*** 2238,2243 ****
--- 2244,2252 ----
        goto cleanup;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    warn = (close->iostat || close->err) ? true : false;
  
    /* Checks on the STATUS specifier.  */
*************** done:
*** 2385,2390 ****
--- 2394,2402 ----
        goto cleanup;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    new_st.op = op;
    new_st.ext.filepos = fp;
    return MATCH_YES;
*************** if (condition) \
*** 3223,3228 ****
--- 3235,3244 ----
  		     "IO UNIT in %s statement at %C must be "
  		     "an internal file in a PURE procedure",
  		     io_kind_name (k));
+ 
+       if (gfc_implicit_pure (NULL) && (k == M_READ || k == M_WRITE))
+ 	gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
      }
  
    if (k != M_READ)
*************** gfc_match_print (void)
*** 3753,3758 ****
--- 3769,3777 ----
        return MATCH_ERROR;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    return MATCH_YES;
  }
  
*************** gfc_match_inquire (void)
*** 3909,3914 ****
--- 3928,3936 ----
  	  return MATCH_ERROR;
  	}
  
+       if (gfc_implicit_pure (NULL))
+ 	gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
        new_st.block = gfc_get_code ();
        new_st.block->op = EXEC_IOLENGTH;
        terminate_io (code);
*************** gfc_match_inquire (void)
*** 3959,3964 ****
--- 3981,3989 ----
        gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
        goto cleanup;
      }
+ 
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
    
    if (inquire->id != NULL && inquire->pending == NULL)
      {
*************** gfc_match_wait (void)
*** 4142,4147 ****
--- 4167,4175 ----
        goto cleanup;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    new_st.op = EXEC_WAIT;
    new_st.ext.wait = wait;
  
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 168596)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_formal_arglist (gfc_symbol *proc
*** 273,278 ****
--- 273,281 ----
  	      continue;
  	    }
  
+ 	  if (proc->attr.implicit_pure && !gfc_pure(sym))
+ 	    proc->attr.implicit_pure = 0;
+ 
  	  if (gfc_elemental (proc))
  	    {
  	      gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
*************** resolve_formal_arglist (gfc_symbol *proc
*** 345,350 ****
--- 348,363 ----
  		       &sym->declared_at);
  	}
  
+       if (proc->attr.implicit_pure && !sym->attr.pointer
+ 	  && sym->attr.flavor != FL_PROCEDURE)
+ 	{
+ 	  if (proc->attr.function && sym->attr.intent != INTENT_IN)
+ 	    proc->attr.implicit_pure = 0;
+ 
+ 	  if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+ 	    proc->attr.implicit_pure = 0;
+ 	}
+ 
        if (gfc_elemental (proc))
  	{
  	  /* F2008, C1289.  */
*************** resolve_structure_cons (gfc_expr *expr, 
*** 1124,1129 ****
--- 1137,1148 ----
  		     comp->name, &cons->expr->where);
  	}
  
+       if (gfc_implicit_pure (NULL)
+ 	    && cons->expr->expr_type == EXPR_VARIABLE
+ 	    && (gfc_impure_variable (cons->expr->symtree->n.sym)
+ 		|| gfc_is_coindexed (cons->expr)))
+ 	gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
      }
  
    return t;
*************** resolve_function (gfc_expr *expr)
*** 3067,3072 ****
--- 3086,3094 ----
  	}
      }
  
+   if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    /* Functions without the RECURSIVE attribution are not allowed to
     * call themselves.  */
    if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
*************** resolve_ordinary_assign (gfc_code *code,
*** 8803,8809 ****
  	  return rval;
  	}
  
!       /* Fortran 2008, C1283.  */
        if (gfc_is_coindexed (lhs))
  	{
  	  gfc_error ("Assignment to coindexed variable at %L in a PURE "
--- 8825,8831 ----
  	  return rval;
  	}
  
!     /* Fortran 2008, C1283.  */
        if (gfc_is_coindexed (lhs))
  	{
  	  gfc_error ("Assignment to coindexed variable at %L in a PURE "
*************** resolve_ordinary_assign (gfc_code *code,
*** 8812,8817 ****
--- 8834,8859 ----
  	}
      }
  
+   if (gfc_implicit_pure (NULL))
+     {
+       if (lhs->expr_type == EXPR_VARIABLE
+ 	    && lhs->symtree->n.sym != gfc_current_ns->proc_name
+ 	    && lhs->symtree->n.sym->ns != gfc_current_ns)
+ 	gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
+       if (lhs->ts.type == BT_DERIVED
+ 	    && lhs->expr_type == EXPR_VARIABLE
+ 	    && lhs->ts.u.derived->attr.pointer_comp
+ 	    && rhs->expr_type == EXPR_VARIABLE
+ 	    && (gfc_impure_variable (rhs->symtree->n.sym)
+ 		|| gfc_is_coindexed (rhs)))
+ 	gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
+       /* Fortran 2008, C1283.  */
+       if (gfc_is_coindexed (lhs))
+ 	gfc_current_ns->proc_name->attr.implicit_pure = 0;
+     }
+ 
    /* F03:7.4.1.2.  */
    /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
       and coindexed; cf. F2008, 7.2.1.2 and PR 43366.  */
*************** gfc_pure (gfc_symbol *sym)
*** 12763,12768 ****
--- 12805,12836 ----
    return attr.flavor == FL_PROCEDURE && attr.pure;
  }
  
+ /* Test whether a symbol is implicitly pure or not.  For a NULL pointer,
+    checks if the current namespace is implicitly pure.  */
+ 
+ int
+ gfc_implicit_pure (gfc_symbol *sym)
+ {
+   symbol_attribute attr;
+ 
+   if (sym == NULL)
+     {
+       /* Check if the current namespace is implicit_pure.  */
+       sym = gfc_current_ns->proc_name;
+       if (sym == NULL)
+ 	return 0;
+       attr = sym->attr;
+       if (attr.flavor == FL_PROCEDURE
+ 	    && attr.implicit_pure && !attr.pure)
+ 	return 1;
+       return 0;
+     }
+ 
+   attr = sym->attr;
+ 
+   return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
+ }
+ 
  
  /* Test whether the current procedure is elemental or not.  */
  
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c	(revision 168596)
--- gcc/fortran/match.c	(working copy)
*************** gfc_match_critical (void)
*** 1746,1751 ****
--- 1746,1754 ----
        return MATCH_ERROR;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
        == FAILURE)
      return MATCH_ERROR;
*************** gfc_match_stopcode (gfc_statement st)
*** 2189,2194 ****
--- 2192,2200 ----
        goto cleanup;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
      {
        gfc_error ("Image control statement STOP at %C in CRITICAL block");
*************** sync_statement (gfc_statement st)
*** 2321,2326 ****
--- 2327,2335 ----
        return MATCH_ERROR;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
        == FAILURE)
      return MATCH_ERROR;
*************** gfc_match_allocate (void)
*** 2920,2925 ****
--- 2929,2938 ----
  	  goto cleanup;
  	}
  
+       if (gfc_implicit_pure (NULL)
+ 	    && gfc_impure_variable (tail->expr->symtree->n.sym))
+ 	gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
        if (tail->expr->ts.deferred)
  	{
  	  saw_deferred = true;
*************** gfc_match_deallocate (void)
*** 3263,3268 ****
--- 3276,3284 ----
  	  goto cleanup;
  	}
  
+       if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
+ 	gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
        /* FIXME: disable the checking on derived types.  */
        b1 = !(tail->expr->ref
  	   && (tail->expr->ref->type == REF_COMPONENT
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c	(revision 168596)
--- gcc/fortran/parse.c	(working copy)
*************** decode_omp_directive (void)
*** 495,500 ****
--- 495,503 ----
        return ST_NONE;
      }
  
+   if (gfc_implicit_pure (NULL))
+     gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ 
    old_locus = gfc_current_locus;
  
    /* General OpenMP directive matching: Instead of testing every possible
*************** parse_contained (int module)
*** 3850,3855 ****
--- 3853,3864 ----
  	  sym->attr.contained = 1;
  	  sym->attr.referenced = 1;
  
+ 	  /* Set implicit_pure so that it can be reset if any of the
+ 	     tests for purity fail.  This is used for some optimisation
+ 	     during translation.  */
+ 	  if (!sym->attr.pure)
+ 	    sym->attr.implicit_pure = 1;
+ 
  	  parse_progunit (ST_NONE);
  
  	  /* Fix up any sibling functions that refer to this one.  */
Index: gcc/testsuite/gfortran.dg/transpose_optimization_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/transpose_optimization_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/transpose_optimization_2.f90	(revision 0)
***************
*** 0 ****
--- 1,65 ----
+ ! { dg-do run }
+ ! { dg-options "-fdump-tree-original " }
+ ! Checks the fix for PR46896, in which the optimization that passes
+ ! the argument of TRANSPOSE directly missed the possible aliasing
+ ! through host association.
+ !
+ ! Contributed by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+ !
+ module mod
+   integer :: b(2,3) = reshape([1,2,3,4,5,6], [2,3])
+ contains
+   subroutine msub(x)
+     integer :: x(:,:)
+     b(1,:) = 99
+     b(2,:) = x(:,1)
+     if (any (b(:,1) /= [99, 1]).or.any (b(:,2) /= [99, 3])) call abort()
+   end subroutine msub
+   subroutine pure_msub(x, y)
+     integer, intent(in) :: x(:,:)
+     integer, intent(OUT) :: y(size (x, 2), size (x, 1))
+     y = transpose (x)
+   end subroutine pure_msub
+ end
+ 
+   use mod
+   integer :: a(2,3) = reshape([1,2,3,4,5,6], [2,3])
+   call impure
+   call purity
+ contains
+ !
+ ! pure_sub and pure_msub could be PURE, if so declared.  They do not
+ ! need a temporary.
+ !
+   subroutine purity
+     integer :: c(2,3)
+     call pure_sub(transpose(a), c)
+     if (any (c .ne. a)) call abort
+     call pure_msub(transpose(b), c)
+     if (any (c .ne. b)) call abort
+   end subroutine purity
+ !
+ ! sub and msub both need temporaries to avoid aliasing.
+ !
+   subroutine impure
+     call sub(transpose(a))
+   end subroutine impure
+ 
+   subroutine sub(x)
+     integer :: x(:,:)
+     a(1,:) = 88
+     a(2,:) = x(:,1)
+     if (any (a(:,1) /= [88, 1]).or.any (a(:,2) /= [88, 3])) call abort()
+   end subroutine sub
+   subroutine pure_sub(x, y)
+     integer, intent(in) :: x(:,:)
+     integer, intent(OUT) :: y(size (x, 2), size (x, 1))
+     y = transpose (x)
+   end subroutine pure_sub
+ end
+ !
+ ! The check below for temporaries gave 14 and 33 for "parm" and "atmp".
+ !
+ ! { dg-final { scan-tree-dump-times "parm" 66 "original" } }
+ ! { dg-final { scan-tree-dump-times "atmp" 12 "original" } }
+ ! { dg-final { cleanup-modules "mod" } }
