Re: FINAL subroutines

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 13270 bytes --]

Hi Salvatore,


My reading of F2018: 7.5.6.3 "When finalization occurs" is that three calls
is correct. (i) Paragraph 1 stipulates that the 'var' expression be
evaluated before the reallocation and intrinsic assignment; (ii)stipulates
that the function result be finalised "the result is finalized after
execution of the innermost
executable construct containing the reference." ; and (iii) Finalisation
occurs on going out of scope.

That is what is implemented in the attached. I am working my way through
the testcase dependencies of PR37336 making sure that finalizat
ion occurs as required by 7.5.6.3 and in the order defined in the previous
section. It will all be done in the next few days.

What will remain is finalization of function results within array
constructors and one or two other corner cases. Following that, the
existing finalization calls will be brought into the framework as the new
calls.

Best regards

Paul


On Thu, 27 Jan 2022 at 07:17, Salvatore Filippone <
filippone.salvatore@gmail.com> wrote:

> One more data point: Cray FTN issues TWO calls to the FINAL.
> Which begs the question: what is the correct number of calls one, two or
> three?
> Salvatore
>
> fsalvato@daint102:/project/prce01/fsalvato/NUMERICAL/PSBLAS/V4/psblas4/test/newstuff>
> ftn --version
> Cray Fortran : Version 11.0.0
> fsalvato@daint102:/project/prce01/fsalvato/NUMERICAL/PSBLAS/V4/psblas4/test/newstuff>
> ftn -o testfinal testfinal.f90
> fsalvato@daint102:/project/prce01/fsalvato/NUMERICAL/PSBLAS/V4/psblas4/test/newstuff>
> ./testfinal
>  Allocating wrapper
>  Calling new_outer_type
>  Assigning outer%test_item
>  Called delete_test_type
>  End of new_outer_type
>  DeAllocating wrapper
>  Called delete_test_type
>
> On Wed, Jan 26, 2022 at 11:59 PM Paul Richard Thomas <
> paul.richard.thomas@gmail.com> wrote:
>
>> Hi Jerry,
>>
>> I am trying to fix the failure of my latest patch with this very test
>> case. Otherwise it fixes most of the remaining dependencies in PR37336.
>>
>> At a pinch, I could submit the earlier patch that Andrew mentions and
>> work from there. However, you will note that it does miss one of the
>> finalizations. This is critical because function results, which should be
>> finalized, are not.
>>
>> I'll keep an eye on the state of the branch. By and large, release occurs
>> 3-4 months after the start of stage 4. I will leave 2 months maximum.
>>
>> Best regards
>>
>> Paul
>>
>>
>> On Wed, 26 Jan 2022 at 21:29, Jerry D via Fortran <fortran@gcc.gnu.org>
>> wrote:
>>
>>> Is there any reason these patches can not be applied and use this test
>>> as a test case?
>>>
>>> Regards,
>>>
>>> Jerry
>>>
>>> On 1/24/22 8:11 AM, Salvatore Filippone via Fortran wrote:
>>> > Thanks a lot
>>> > (yes, I suspected both gfortran and intel were wrong, precisely
>>> because I
>>> > could see why you'd need two FINAL calls, but not three).
>>> >
>>> > Salvatore
>>> >
>>> > On Mon, Jan 24, 2022 at 4:45 PM Andrew Benson <
>>> abenson@carnegiescience.edu>
>>> > wrote:
>>> >
>>> >> Hi Salvatore,
>>> >>
>>> >> This looks like it's related to some of the missing finalization
>>> >> functionality
>>> >> (https://gcc.gnu.org/bugzilla/show_bug.cgi?id=37336). Paul has some
>>> >> patches
>>> >> (e.g. https://gcc.gnu.org/pipermail/fortran/2022-January/057415.html)
>>> >> which
>>> >> implement most of the missing functionality. With those patches
>>> >> incorporated
>>> >> your code gives the following output with gfortran:
>>> >>
>>> >> $ ./testfinal
>>> >>   Allocating wrapper
>>> >>   Calling new_outer_type
>>> >>   Assigning outer%test_item
>>> >>   Called delete_test_type
>>> >>   End of new_outer_type
>>> >>   DeAllocating wrapper
>>> >>   Called delete_test_type
>>> >>
>>> >> So there is one more call to the finalizer than you found - I haven't
>>> >> checked
>>> >> carefully but I would guess this is a deallocation of LHS on
>>> assignment.
>>> >>
>>> >> In testing these patches using the Intel compiler we found that it
>>> seems
>>> >> to
>>> >> call the finalization wrapper more than it should, sometimes on
>>> objects
>>> >> that
>>> >> have already been deallocated. Your code, compiled with the Intel
>>> compiler
>>> >> and
>>> >> then run under valgrind shows the following:
>>> >>
>>> >> $ valgrind ./testfinal
>>> >> ==7340== Memcheck, a memory error detector
>>> >> ==7340== Copyright (C) 2002-2017, and GNU GPL'd, by Julian Seward et
>>> al.
>>> >> ==7340== Using Valgrind-3.13.0 and LibVEX; rerun with -h for
>>> copyright info
>>> >> ==7340== Command: ./testfinal
>>> >> ==7340==
>>> >> ==7340== Conditional jump or move depends on uninitialised value(s)
>>> >> ==7340==    at 0x493A51: __intel_sse2_strcpy (in
>>> /home/abensonca/Scratch/
>>> >> ifortTests/testfinal)
>>> >> ==7340==    by 0x45D70E: for__add_to_lf_table (in
>>> /home/abensonca/Scratch/
>>> >> ifortTests/testfinal)
>>> >> ==7340==    by 0x4410CB: for__open_proc (in /home/abensonca/Scratch/
>>> >> ifortTests/testfinal)
>>> >> ==7340==    by 0x423A64: for__open_default (in
>>> /home/abensonca/Scratch/
>>> >> ifortTests/testfinal)
>>> >> ==7340==    by 0x4305A9: for_write_seq_lis (in
>>> /home/abensonca/Scratch/
>>> >> ifortTests/testfinal)
>>> >> ==7340==    by 0x4047E1: MAIN__ (testfinal.f90:62)
>>> >> ==7340==    by 0x403CE1: main (in /home/abensonca/Scratch/ifortTests/
>>> >> testfinal)
>>> >> ==7340==
>>> >>   Allocating wrapper
>>> >>   Calling new_outer_type
>>> >>   Assigning outer%test_item
>>> >>   Called delete_test_type
>>> >> ==7340== Conditional jump or move depends on uninitialised value(s)
>>> >> ==7340==    at 0x40572A: do_alloc_copy (in
>>> >> /home/abensonca/Scratch/ifortTests/
>>> >> testfinal)
>>> >> ==7340==    by 0x406B9A: do_alloc_copy (in
>>> >> /home/abensonca/Scratch/ifortTests/
>>> >> testfinal)
>>> >> ==7340==    by 0x4084ED: for_alloc_assign_v2 (in
>>> /home/abensonca/Scratch/
>>> >> ifortTests/testfinal)
>>> >> ==7340==    by 0x404474: target_mod_mp_new_outer_type_
>>> (testfinal.f90:48)
>>> >> ==7340==    by 0x40485E: MAIN__ (testfinal.f90:65)
>>> >> ==7340==    by 0x403CE1: main (in /home/abensonca/Scratch/ifortTests/
>>> >> testfinal)
>>> >> ==7340==
>>> >>   Called delete_test_type
>>> >>   End of new_outer_type
>>> >>   DeAllocating wrapper
>>> >>   Called delete_test_type
>>> >> ==7340==
>>> >> ==7340== HEAP SUMMARY:
>>> >> ==7340==     in use at exit: 48 bytes in 1 blocks
>>> >> ==7340==   total heap usage: 14 allocs, 13 frees, 12,879 bytes
>>> allocated
>>> >> ==7340==
>>> >> ==7340== LEAK SUMMARY:
>>> >> ==7340==    definitely lost: 48 bytes in 1 blocks
>>> >> ==7340==    indirectly lost: 0 bytes in 0 blocks
>>> >> ==7340==      possibly lost: 0 bytes in 0 blocks
>>> >> ==7340==    still reachable: 0 bytes in 0 blocks
>>> >> ==7340==         suppressed: 0 bytes in 0 blocks
>>> >> ==7340== Rerun with --leak-check=full to see details of leaked memory
>>> >> ==7340==
>>> >> ==7340== For counts of detected and suppressed errors, rerun with: -v
>>> >> ==7340== Use --track-origins=yes to see where uninitialised values
>>> come
>>> >> from
>>> >> ==7340== ERROR SUMMARY: 2 errors from 2 contexts (suppressed: 0 from
>>> 0)
>>> >>
>>> >> so there are some cases of what look like incorrect accesses (and some
>>> >> leaked
>>> >> memory).
>>> >>
>>> >> Your code compiled  with gfortran (with Paul's patches in place)
>>> shows no
>>> >> errors or leaks from valgrind.
>>> >>
>>> >> So, in summary, in this case I think the current gfortran is missing
>>> some
>>> >> finalizations (which are fixed by Paul's patches), and ifort is likely
>>> >> doing
>>> >> something wrong and probably calling the finalizer more times than it
>>> >> should.
>>> >>
>>> >> -Andrew
>>> >>
>>> >> On Monday, January 24, 2022 6:49:23 AM PST Salvatore Filippone via
>>> Fortran
>>> >> wrote:
>>> >>> And here is the code embedded as text............ sorry  about
>>> sending an
>>> >>> attachment that was purged
>>> >>> ------------------------- testfinal.f90 ---------------------
>>> >>> module test_type_mod
>>> >>>
>>> >>>    type :: my_test_type
>>> >>>      integer, allocatable :: i
>>> >>>    contains
>>> >>>      final :: delete_test_type
>>> >>>    end type my_test_type
>>> >>>
>>> >>>    interface my_test_type
>>> >>>      module procedure  new_test_type_object
>>> >>>    end interface my_test_type
>>> >>>
>>> >>> contains
>>> >>>
>>> >>>    subroutine delete_test_type(this)
>>> >>>      type(my_test_type) :: this
>>> >>>
>>> >>>      write(*,*) 'Called delete_test_type'
>>> >>>      if (allocated(this%i)) deallocate(this%i)
>>> >>>
>>> >>>    end subroutine delete_test_type
>>> >>>
>>> >>>
>>> >>>    function new_test_type_object(item) result(res)
>>> >>>      type(my_test_type)  :: res
>>> >>>      integer, intent(in) :: item
>>> >>>      !Allocation on assignment
>>> >>>      res%i=item
>>> >>>    end function new_test_type_object
>>> >>>
>>> >>>
>>> >>> end module test_type_mod
>>> >>>
>>> >>> module target_mod
>>> >>>    use test_type_mod
>>> >>>    type :: outer_type
>>> >>>      type(my_test_type), allocatable  :: test_item
>>> >>>    end type outer_type
>>> >>>
>>> >>> contains
>>> >>>
>>> >>>    subroutine new_outer_type(outer,item)
>>> >>>      type(outer_type), intent(out) :: outer
>>> >>>      integer :: item
>>> >>>
>>> >>>      allocate(outer%test_item)
>>> >>>      write(*,*) 'Assigning outer%test_item'
>>> >>>      outer%test_item = my_test_type(itemi)
>>> >>>      write(*,*) 'End of new_outer_type'
>>> >>>    end subroutine new_outer_type
>>> >>>
>>> >>> end module target_mod
>>> >>>
>>> >>> program testfinal
>>> >>>    use target_mod
>>> >>>
>>> >>>    implicit none
>>> >>>
>>> >>>    integer :: i=10
>>> >>>    type(outer_type), allocatable  :: wrapper
>>> >>>
>>> >>>    write(*,*) 'Allocating wrapper '
>>> >>>    allocate(wrapper)
>>> >>>    write(*,*) 'Calling new_outer_type '
>>> >>>    call new_outer_type(wrapper,i)
>>> >>>    write(*,*) 'DeAllocating wrapper '
>>> >>>    deallocate(wrapper)
>>> >>>
>>> >>> end program testfinal
>>> >>>
>>> >>> On Mon, Jan 24, 2022 at 2:50 PM Salvatore Filippone <
>>> >>>
>>> >>> filippone.salvatore@gmail.com> wrote:
>>> >>>> Hi all
>>> >>>> The attached code compiles and runs fine under both GNU and Intel,
>>> but
>>> >> it
>>> >>>> produces different results, in particular the FINAL subroutine is
>>> >> invoked
>>> >>>> just once with GNU, three times with Intel.
>>> >>>>
>>> >>>> It seems to me that they cannot both be right; I am not sure what
>>> the
>>> >>>> standard is mandating in this case.
>>> >>>> Any ideas?
>>> >>>> Salvatore
>>> >>>> ---------------  Intel
>>> >>>> [pr1eio03@login1: newstuff]$ ifort -v
>>> >>>> ifort version 19.1.1.217
>>> >>>> [pr1eio03@login1: newstuff]$ ifort -o testfinal testfinal.f90
>>> >>>> [pr1eio03@login1: newstuff]$ ./testfinal
>>> >>>>
>>> >>>>   Allocating wrapper
>>> >>>>   Calling new_outer_type
>>> >>>>   Assigning outer%test_item
>>> >>>>   Called delete_test_type
>>> >>>>   Called delete_test_type
>>> >>>>   End of new_outer_type
>>> >>>>   DeAllocating wrapper
>>> >>>>   Called delete_test_type
>>> >>>>
>>> >>>> ----------------------------- GNU
>>> >>>> sfilippo@lagrange newstuff]$ gfortran -v
>>> >>>> Using built-in specs.
>>> >>>> COLLECT_GCC=gfortran
>>> >>>>
>>> COLLECT_LTO_WRAPPER=/usr/libexec/gcc/x86_64-redhat-linux/11/lto-wrapper
>>> >>>> OFFLOAD_TARGET_NAMES=nvptx-none
>>> >>>> OFFLOAD_TARGET_DEFAULT=1
>>> >>>> Target: x86_64-redhat-linux
>>> >>>> Configured with: ../configure --enable-bootstrap
>>> >>>> --enable-languages=c,c++,fortran,objc,obj-c++,ada,go,d,lto
>>> >> --prefix=/usr
>>> >>>> --mandir=/usr/share/man --infodir=/usr/share/info --with-bugurl=
>>> >>>> http://bugzilla.redhat.com/bugzilla --enable-shared
>>> >>>> --enable-threads=posix --enable-checking=release --enable-multilib
>>> >>>> --with-system-zlib --enable-__cxa_atexit
>>> --disable-libunwind-exceptions
>>> >>>> --enable-gnu-unique-object --enable-linker-build-id
>>> >>>> --with-gcc-major-version-only --with-linker-hash-style=gnu
>>> >> --enable-plugin
>>> >>>> --enable-initfini-array
>>> >>>>
>>> >>
>>> --with-isl=/builddir/build/BUILD/gcc-11.2.1-20210728/obj-x86_64-redhat-lin
>>> >>>> ux/isl-install --enable-offload-targets=nvptx-none
>>> >> --without-cuda-driver
>>> >>>> --enable-gnu-indirect-function --enable-cet --with-tune=generic
>>> >>>> --with-arch_32=i686 --build=x86_64-redhat-linux
>>> >>>> Thread model: posix
>>> >>>> Supported LTO compression algorithms: zlib zstd
>>> >>>> gcc version 11.2.1 20210728 (Red Hat 11.2.1-1) (GCC)
>>> >>>> [sfilippo@lagrange newstuff]$ gfortran -o testfinal testfinal.f90
>>> >>>> [sfilippo@lagrange newstuff]$ ./testfinal
>>> >>>>
>>> >>>>   Allocating wrapper
>>> >>>>   Calling new_outer_type
>>> >>>>   Assigning outer%test_item
>>> >>>>   End of new_outer_type
>>> >>>>   DeAllocating wrapper
>>> >>>>   Called delete_test_type
>>> >>>>
>>> >>>> ---------------------
>>> >>
>>> >> --
>>> >>
>>> >> * Andrew Benson: https://abensonca.github.io
>>> >>
>>> >> * Galacticus: https://github.com/galacticusorg/galacticus
>>> >>
>>> >>
>>> >>
>>> >>
>>>
>>>
>>
>> --
>> "If you can't explain it simply, you don't understand it well enough" -
>> Albert Einstein
>>
>

-- 
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein

[-- Attachment #2: Check270222.diff --]
[-- Type: text/x-patch, Size: 34670 bytes --]

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 731e9b0fe6a..a249eea4a30 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -896,7 +896,8 @@ has_finalizer_component (gfc_symbol *derived)
    gfc_component *c;
 
   for (c = derived->components; c; c = c->next)
-    if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable)
+    if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable
+	&& c->attr.flavor != FL_PROCEDURE)
       {
 	if (c->ts.u.derived->f2k_derived
 	    && c->ts.u.derived->f2k_derived->finalizers)
@@ -1059,7 +1060,8 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
     {
       /* Call FINAL_WRAPPER (comp);  */
       gfc_code *final_wrap;
-      gfc_symbol *vtab;
+      gfc_symbol *vtab, *byte_stride;
+      gfc_expr *scalar, *size_expr, *fini_coarray_expr;
       gfc_component *c;
 
       vtab = gfc_find_derived_vtab (comp->ts.u.derived);
@@ -1068,12 +1070,54 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
 	  break;
 
       gcc_assert (c);
+
+      /* Set scalar argument for storage_size.  */
+      gfc_get_symbol ("comp_byte_stride", sub_ns, &byte_stride);
+      byte_stride->ts = e->ts;
+      byte_stride->attr.flavor = FL_VARIABLE;
+      byte_stride->attr.value = 1;
+      byte_stride->attr.artificial = 1;
+      gfc_set_sym_referenced (byte_stride);
+      gfc_commit_symbol (byte_stride);
+      scalar = gfc_lval_expr_from_sym (byte_stride);
+
       final_wrap = gfc_get_code (EXEC_CALL);
       final_wrap->symtree = c->initializer->symtree;
       final_wrap->resolved_sym = c->initializer->symtree->n.sym;
       final_wrap->ext.actual = gfc_get_actual_arglist ();
       final_wrap->ext.actual->expr = e;
 
+      /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE.  */
+      size_expr = gfc_get_expr ();
+      size_expr->where = gfc_current_locus;
+      size_expr->expr_type = EXPR_OP;
+      size_expr->value.op.op = INTRINSIC_DIVIDE;
+
+      /* STORAGE_SIZE (array,kind=c_intptr_t).  */
+      size_expr->value.op.op1
+	= gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
+				    "storage_size", gfc_current_locus, 2,
+				    scalar,
+				    gfc_get_int_expr (gfc_index_integer_kind,
+						      NULL, 0));
+
+      /* NUMERIC_STORAGE_SIZE.  */
+      size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+						  gfc_character_storage_size);
+      size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+      size_expr->ts = size_expr->value.op.op1->ts;
+
+      /* Which provides the argument 'byte_stride'.....  */
+      final_wrap->ext.actual->next = gfc_get_actual_arglist ();
+      final_wrap->ext.actual->next->expr = size_expr;
+
+      /* ...and last of all the 'fini_coarray' argument.  */
+      fini_coarray_expr = gfc_lval_expr_from_sym (fini_coarray);
+      final_wrap->ext.actual->next->next = gfc_get_actual_arglist ();
+      final_wrap->ext.actual->next->next->expr = fini_coarray_expr;
+
+
+
       if (*code)
 	{
 	  (*code)->next = final_wrap;
@@ -1430,8 +1474,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   block->next->resolved_sym = fini->proc_tree->n.sym;
   block->next->ext.actual = gfc_get_actual_arglist ();
   block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
-  block->next->ext.actual->next = gfc_get_actual_arglist ();
-  block->next->ext.actual->next->expr = gfc_copy_expr (size_expr);
 
   /* ELSE.  */
 
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 835a4783718..5558af4e2ba 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10512,6 +10512,10 @@ resolve_where (gfc_code *code, gfc_expr *mask)
 	      if (e && !resolve_where_shape (cnext->expr1, e))
 	       gfc_error ("WHERE assignment target at %L has "
 			  "inconsistent shape", &cnext->expr1->where);
+
+	      if (cnext->op == EXEC_ASSIGN)
+		cnext->expr1->must_finalize = 1;
+
 	      break;
 
 
@@ -10599,6 +10603,10 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
 	    /* WHERE assignment statement */
 	    case EXEC_ASSIGN:
 	      gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
+
+	      if (cnext->op == EXEC_ASSIGN)
+		cnext->expr1->must_finalize = 1;
+
 	      break;
 
 	    /* WHERE operator assignment statement */
@@ -10645,6 +10653,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
 	case EXEC_ASSIGN:
 	case EXEC_POINTER_ASSIGN:
 	  gfc_resolve_assign_in_forall (c, nvar, var_expr);
+
+	  if (c->op == EXEC_ASSIGN)
+	    c->expr1->must_finalize = 1;
+
 	  break;
 
 	case EXEC_ASSIGN_CALL:
@@ -12069,6 +12081,9 @@ start:
 	      && code->expr1->ts.u.derived->attr.defined_assign_comp)
 	    generate_component_assignments (&code, ns);
 
+	  if (code->op == EXEC_ASSIGN)
+	    code->expr1->must_finalize = 1;
+
 	  break;
 
 	case EXEC_LABEL_ASSIGN:
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 2f0c8a4d412..b03e74960ce 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -994,9 +994,9 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
       if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
 	{
 	  gcc_assert (expr->ts.type == BT_CHARACTER);
-	  
+
 	  tmp = gfc_get_character_len_in_bytes (tmp);
-	  
+
 	  if (tmp == NULL_TREE || integer_zerop (tmp))
 	    {
 	      tree bs;
@@ -1007,7 +1007,7 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
 	      tmp = fold_build2_loc (input_location, MULT_EXPR,
 				     gfc_array_index_type, tmp, bs);
 	    }
-	  
+
 	  tmp = (tmp && !integer_zerop (tmp))
 	    ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
 	}
@@ -5657,7 +5657,12 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
   gfc_se se;
   int n;
 
-  type = TREE_TYPE (descriptor);
+  if (expr->ts.type == BT_CLASS
+      && expr3_desc != NULL_TREE
+      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
+    type = TREE_TYPE (expr3_desc);
+  else
+    type = TREE_TYPE (descriptor);
 
   stride = gfc_index_one_node;
   offset = gfc_index_zero_node;
@@ -7478,7 +7483,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 
   if (!se->direct_byref)
     se->unlimited_polymorphic = UNLIMITED_POLY (expr);
-  
+
   /* Special case things we know we can pass easily.  */
   switch (expr->expr_type)
     {
@@ -8922,7 +8927,7 @@ static gfc_actual_arglist *pdt_param_list;
 static tree
 structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		       tree dest, int rank, int purpose, int caf_mode,
-		       gfc_co_subroutines_args *args)
+		       gfc_co_subroutines_args *args, bool no_finalization)
 {
   gfc_component *c;
   gfc_loopinfo loop;
@@ -9010,11 +9015,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 					     gfc_conv_array_data (dest));
 	  dref = gfc_build_array_ref (tmp, index, NULL);
 	  tmp = structure_alloc_comps (der_type, vref, dref, rank,
-				       COPY_ALLOC_COMP, caf_mode, args);
+				       COPY_ALLOC_COMP, caf_mode, args,
+				       no_finalization);
 	}
       else
 	tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
-				     caf_mode, args);
+				     caf_mode, args, no_finalization);
 
       gfc_add_expr_to_block (&loopbody, tmp);
 
@@ -9048,13 +9054,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
   if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
     {
       tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-				   DEALLOCATE_PDT_COMP, 0, args);
+				   DEALLOCATE_PDT_COMP, 0, args,
+				   no_finalization);
       gfc_add_expr_to_block (&fnblock, tmp);
     }
   else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
     {
       tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-				   NULLIFY_ALLOC_COMP, 0, args);
+				   NULLIFY_ALLOC_COMP, 0, args,
+				   no_finalization);
       gfc_add_expr_to_block (&fnblock, tmp);
     }
 
@@ -9112,7 +9120,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  add_when_allocated
 		      = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
 					       comp, NULL_TREE, rank, purpose,
-					       caf_mode, args);
+					       caf_mode, args, no_finalization);
 		}
 	      else
 		{
@@ -9120,7 +9128,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  add_when_allocated = structure_alloc_comps (c->ts.u.derived,
 							      comp, NULL_TREE,
 							      rank, purpose,
-							      caf_mode, args);
+							      caf_mode, args,
+							      no_finalization);
 		}
 	    }
 
@@ -9216,8 +9225,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		continue;
 	    }
 
-	  if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
-	     || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
+	  if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+	     || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
 	    /* Call the finalizer, which will free the memory and nullify the
 	       pointer of an array.  */
 	    deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
@@ -9245,7 +9254,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  add_when_allocated
 		      = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
 					       comp, NULL_TREE, rank, purpose,
-					       caf_mode, args);
+					       caf_mode, args, no_finalization);
 		}
 	      else
 		{
@@ -9253,7 +9262,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  add_when_allocated = structure_alloc_comps (c->ts.u.derived,
 							      comp, NULL_TREE,
 							      rank, purpose,
-							      caf_mode, args);
+							      caf_mode, args,
+							      no_finalization);
 		}
 	    }
 
@@ -9551,7 +9561,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 				      decl, cdecl, NULL_TREE);
 	      rank = c->as ? c->as->rank : 0;
 	      tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
-					   rank, purpose, caf_mode, args);
+					   rank, purpose, caf_mode, args,
+					   no_finalization);
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
 	  break;
@@ -9587,7 +9598,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
 					       rank, purpose, caf_mode
 					       | GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
-					       args);
+					       args, no_finalization);
 		  gfc_add_expr_to_block (&fnblock, tmp);
 		}
 	    }
@@ -9695,7 +9706,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      add_when_allocated = structure_alloc_comps (c->ts.u.derived,
 							  comp, dcmp,
 							  rank, purpose,
-							  caf_mode, args);
+							  caf_mode, args,
+							  no_finalization);
 	    }
 	  else
 	    add_when_allocated = NULL_TREE;
@@ -10068,7 +10080,8 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
 {
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
 				NULLIFY_ALLOC_COMP,
-				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
+				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
+				NULL, false);
 }
 
 
@@ -10081,7 +10094,8 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
 {
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
 				DEALLOCATE_ALLOC_COMP,
-				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
+				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
+				NULL, false);
 }
 
 tree
@@ -10119,7 +10133,8 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
 
   tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
 			       BCAST_ALLOC_COMP,
-  			       GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args);
+			       GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
+			       &args, false);
   return tmp;
 }
 
@@ -10129,10 +10144,12 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
    status of coarrays.  */
 
 tree
-gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
+gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
+				  bool no_finalization)
 {
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-				DEALLOCATE_ALLOC_COMP, 0, NULL);
+				DEALLOCATE_ALLOC_COMP, 0, NULL,
+				no_finalization);
 }
 
 
@@ -10140,7 +10157,8 @@ tree
 gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
 {
   return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
-				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL);
+				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
+				NULL, false);
 }
 
 
@@ -10152,7 +10170,7 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
 		     int caf_mode)
 {
   return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
-				caf_mode, NULL);
+				caf_mode, NULL, false);
 }
 
 
@@ -10163,7 +10181,7 @@ tree
 gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
 {
   return structure_alloc_comps (der_type, decl, dest, rank,
-				COPY_ONLY_ALLOC_COMP, 0, NULL);
+				COPY_ONLY_ALLOC_COMP, 0, NULL, false);
 }
 
 
@@ -10178,7 +10196,7 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
   gfc_actual_arglist *old_param_list = pdt_param_list;
   pdt_param_list = param_list;
   res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-			       ALLOCATE_PDT_COMP, 0, NULL);
+			       ALLOCATE_PDT_COMP, 0, NULL, false);
   pdt_param_list = old_param_list;
   return res;
 }
@@ -10190,7 +10208,7 @@ tree
 gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
 {
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-				DEALLOCATE_PDT_COMP, 0, NULL);
+				DEALLOCATE_PDT_COMP, 0, NULL, false);
 }
 
 
@@ -10205,7 +10223,7 @@ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
   gfc_actual_arglist *old_param_list = pdt_param_list;
   pdt_param_list = param_list;
   res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
-			       CHECK_PDT_DUMMY, 0, NULL);
+			       CHECK_PDT_DUMMY, 0, NULL, false);
   pdt_param_list = old_param_list;
   return res;
 }
@@ -10926,7 +10944,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 	&& expr1->ts.u.derived->attr.alloc_comp)
     {
       tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
-					      expr1->rank);
+					      expr1->rank, true);
       gfc_add_expr_to_block (&realloc_block, tmp);
     }
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 04fee617590..3aae4d2c4eb 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -56,7 +56,8 @@ tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
 tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
 tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree,
 			   tree, tree, tree);
-tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
+tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int,
+				       bool no_finalization = false);
 tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
 
 tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int, int);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index eb6a78c3a62..6ffe317afbf 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1904,6 +1904,7 @@ gfc_init_se (gfc_se * se, gfc_se * parent)
 {
   memset (se, 0, sizeof (gfc_se));
   gfc_init_block (&se->pre);
+  gfc_init_block (&se->finalblock);
   gfc_init_block (&se->post);
 
   se->parent = parent;
@@ -5975,6 +5976,116 @@ post_call:
 }
 
 
+/* Finalize a function result using the finalizer wrapper. The result is fixed
+   in order to prevent repeated calls.  */
+
+static void
+finalize_function_result (gfc_se *se, gfc_symbol *derived,
+			  symbol_attribute attr)
+{
+  tree vptr, final_fndecl, desc, tmp, size, is_final, data_ptr;
+  gfc_symbol *vtab;
+  gfc_se post_se;
+  bool is_class = GFC_CLASS_TYPE_P (TREE_TYPE (se->expr));
+
+  if (attr.pointer)
+    return;
+
+  if (is_class)
+    {
+      if (!VAR_P (se->expr))
+	{
+	  desc = gfc_evaluate_now (se->expr, &se->pre);
+	  se->expr = desc;
+	}
+      desc = gfc_class_data_get (se->expr);
+      vptr = gfc_class_vptr_get (se->expr);
+    }
+  else
+    {
+      desc = gfc_evaluate_now (se->expr, &se->pre);
+      se->expr = gfc_evaluate_now (desc, &se->pre);
+      gfc_add_expr_to_block (&se->pre,
+			     gfc_copy_alloc_comp (derived, se->expr,
+			     desc, 0, 0));
+      vtab = gfc_find_derived_vtab (derived);
+      if (vtab->backend_decl == NULL_TREE)
+	vptr = gfc_get_symbol_decl (vtab);
+      else
+	vptr = vtab->backend_decl;
+      vptr = gfc_build_addr_expr (NULL, vptr);
+    }
+
+  size = gfc_vptr_size_get (vptr);
+  final_fndecl = gfc_vptr_final_get (vptr);
+  is_final = fold_build2_loc (input_location, NE_EXPR,
+			      logical_type_node,
+			      final_fndecl,
+			      fold_convert (TREE_TYPE (final_fndecl),
+					    null_pointer_node));
+
+  final_fndecl = build_fold_indirect_ref_loc (input_location,
+					      final_fndecl);
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+    {
+      if (is_class)
+	desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
+      else
+	{
+	  gfc_init_se (&post_se, NULL);
+	  desc = gfc_conv_scalar_to_descriptor (&post_se, desc, attr);
+	  gfc_add_expr_to_block (&se->pre, gfc_finish_block (&post_se.pre));
+	}
+    }
+
+  tmp = gfc_create_var (TREE_TYPE (desc), "res");
+  gfc_add_modify (&se->pre, tmp, desc);
+  desc = tmp;
+
+  tmp = build_call_expr_loc (input_location, final_fndecl, 3,
+			     gfc_build_addr_expr (NULL, desc),
+			     size, boolean_false_node);
+
+  tmp = fold_build3_loc (input_location, COND_EXPR,
+			 void_type_node, is_final, tmp,
+			 build_empty_stmt (input_location));
+
+  if (is_class && se->ss && se->ss->loop)
+    {
+      data_ptr = gfc_conv_descriptor_data_get (desc);
+
+      gfc_add_expr_to_block (&se->loop->post, tmp);
+      tmp = fold_build2_loc (input_location, NE_EXPR,
+			     logical_type_node,
+			     data_ptr,
+			     fold_convert (TREE_TYPE (data_ptr),
+					   null_pointer_node));
+      tmp = fold_build3_loc (input_location, COND_EXPR,
+			     void_type_node, tmp,
+			     gfc_call_free (data_ptr),
+			     build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&se->loop->post, tmp);
+    }
+  else
+    {
+      gfc_add_expr_to_block (&se->finalblock, tmp);
+      if (is_class)
+	{
+	  data_ptr = gfc_conv_descriptor_data_get (desc);
+	  tmp = fold_build2_loc (input_location, NE_EXPR,
+				 logical_type_node,
+				 data_ptr,
+				 fold_convert (TREE_TYPE (data_ptr),
+					       null_pointer_node));
+	  tmp = fold_build3_loc (input_location, COND_EXPR,
+				 void_type_node, tmp,
+				 gfc_call_free (data_ptr),
+				 build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&se->finalblock, tmp);
+	}
+    }
+}
+
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
    Return nonzero, if the call has alternate specifiers.
@@ -7011,6 +7122,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
       gfc_add_block_to_block (&se->pre, &parmse.pre);
       gfc_add_block_to_block (&post, &parmse.post);
+      gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
 
       /* Allocated allocatable components of derived types must be
 	 deallocated for non-variable scalars, array arguments to elemental
@@ -7675,9 +7787,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   /* Allocatable scalar function results must be freed and nullified
      after use. This necessitates the creation of a temporary to
      hold the result to prevent duplicate calls.  */
+  symbol_attribute attr =  comp ? comp->attr : sym->attr;
+  bool allocatable = attr.allocatable && !attr.dimension;
+  gfc_symbol *der = comp && comp->ts.type == BT_DERIVED ? comp->ts.u.derived
+		    : (sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL);
+  bool finalizable = der != NULL && gfc_is_finalizable (der, NULL);
+
+  if (!byref && finalizable)
+    finalize_function_result (se, der, attr);
+
   if (!byref && sym->ts.type != BT_CHARACTER
-      && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
-	  || (comp && comp->attr.allocatable && !comp->attr.dimension)))
+      && allocatable && !finalizable)
     {
       tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
       gfc_add_modify (&se->pre, tmp, se->expr);
@@ -7737,6 +7857,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      se->expr = info->descriptor;
 	      /* Bundle in the string length.  */
 	      se->string_length = len;
+
+	      if (finalizable)
+		finalize_function_result (se, der, attr);
 	    }
 	  else if (ts.type == BT_CHARACTER)
 	    {
@@ -7829,8 +7952,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
 	  && expr->must_finalize)
 	{
-	  tree final_fndecl;
-	  tree is_final;
 	  int n;
 	  if (se->ss && se->ss->loop)
 	    {
@@ -7852,66 +7973,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      /* TODO Eliminate the doubling of temporaries. This
 		 one is necessary to ensure no memory leakage.  */
 	      se->expr = gfc_evaluate_now (se->expr, &se->pre);
-	      tmp = gfc_class_data_get (se->expr);
-	      tmp = gfc_conv_scalar_to_descriptor (se, tmp,
-			CLASS_DATA (expr->value.function.esym->result)->attr);
 	    }
 
-	  if ((gfc_is_class_array_function (expr)
-	       || gfc_is_alloc_class_scalar_function (expr))
-	      && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
-	    goto no_finalization;
-
-	  final_fndecl = gfc_class_vtab_final_get (se->expr);
-	  is_final = fold_build2_loc (input_location, NE_EXPR,
-				      logical_type_node,
-				      final_fndecl,
-				      fold_convert (TREE_TYPE (final_fndecl),
-					   	    null_pointer_node));
-	  final_fndecl = build_fold_indirect_ref_loc (input_location,
-						      final_fndecl);
- 	  tmp = build_call_expr_loc (input_location,
-				     final_fndecl, 3,
-				     gfc_build_addr_expr (NULL, tmp),
-				     gfc_class_vtab_size_get (se->expr),
-				     boolean_false_node);
-	  tmp = fold_build3_loc (input_location, COND_EXPR,
-				 void_type_node, is_final, tmp,
-				 build_empty_stmt (input_location));
-
-	  if (se->ss && se->ss->loop)
-	    {
-	      gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
-	      tmp = fold_build2_loc (input_location, NE_EXPR,
-				     logical_type_node,
-				     info->data,
-				     fold_convert (TREE_TYPE (info->data),
-					   	    null_pointer_node));
-	      tmp = fold_build3_loc (input_location, COND_EXPR,
-				     void_type_node, tmp,
-				     gfc_call_free (info->data),
-				     build_empty_stmt (input_location));
-	      gfc_add_expr_to_block (&se->ss->loop->post, tmp);
-	    }
-	  else
-	    {
-	      tree classdata;
-	      gfc_prepend_expr_to_block (&se->post, tmp);
-	      classdata = gfc_class_data_get (se->expr);
-	      tmp = fold_build2_loc (input_location, NE_EXPR,
-				     logical_type_node,
-				     classdata,
-				     fold_convert (TREE_TYPE (classdata),
-					   	    null_pointer_node));
-	      tmp = fold_build3_loc (input_location, COND_EXPR,
-				     void_type_node, tmp,
-				     gfc_call_free (classdata),
-				     build_empty_stmt (input_location));
-	      gfc_add_expr_to_block (&se->post, tmp);
-	    }
+	  /* Finalize the result, if necessary.  */
+	  attr = CLASS_DATA (expr->value.function.esym->result)->attr;
+	  if (!((gfc_is_class_array_function (expr)
+		 || gfc_is_alloc_class_scalar_function (expr))
+		&& attr.pointer))
+	    finalize_function_result (se, NULL, attr);
 	}
-
-no_finalization:
       gfc_add_block_to_block (&se->post, &post);
     }
 
@@ -10430,7 +10500,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       if (dealloc)
 	{
 	  tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
-	  tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
+	  tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
+						  0, true);
 	  if (deep_copy)
 	    tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
 			    tmp);
@@ -10872,6 +10943,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
 
   gfc_conv_function_expr (&se, expr2);
   gfc_add_block_to_block (&se.pre, &se.post);
+  gfc_add_block_to_block (&se.pre, &se.finalblock);
 
   if (ss)
     gfc_cleanup_loop (&loop);
@@ -11387,6 +11459,89 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
 }
 
 
+  /* F2018 (7.5.6.3): "When an intrinsic assignment statement is executed
+     (10.2.1.3), if the variable is not an unallocated allocatable variable,
+     it is finalized after evaluation of expr and before the definition of
+     the variable. If the variable is an allocated allocatable variable, or
+     has an allocated allocatable subobject, that would be deallocated by
+     intrinsic assignment, the finalization occurs before the deallocation */
+
+static tree
+gfc_assignment_finalizer_call (gfc_expr *expr1, bool init_flag)
+{
+  stmtblock_t final_block;
+  gfc_init_block (&final_block);
+  symbol_attribute lhs_attr;
+  tree final_expr;
+  tree ptr;
+  tree cond;
+  gfc_se se;
+
+  /* We have to exclude vtable procedures (_copy and _final especially), uses
+     of gfc_trans_assignment_1 in initialization and allocation before trying
+     to build a final call.  */
+  if (!expr1->must_finalize
+      || expr1->symtree->n.sym->attr.artificial
+      || expr1->symtree->n.sym->ns->proc_name->attr.artificial
+      || init_flag)
+    return NULL_TREE;
+
+  if (!(expr1->ts.type == BT_CLASS
+	|| (expr1->ts.type == BT_DERIVED
+	    && gfc_is_finalizable (expr1->ts.u.derived, NULL)))
+      || !gfc_add_finalizer_call (&final_block, expr1))
+    return NULL_TREE;
+
+  lhs_attr = gfc_expr_attr (expr1);
+
+  /* Check allocatable/pointer is allocated/associated.  */
+  if (lhs_attr.allocatable || lhs_attr.pointer)
+    {
+      if (expr1->ts.type == BT_CLASS)
+	{
+	  ptr = gfc_get_class_from_gfc_expr (expr1);
+	  gcc_assert (ptr != NULL_TREE);
+	  ptr = gfc_class_data_get (ptr);
+	  if (lhs_attr.dimension)
+	    ptr = gfc_conv_descriptor_data_get (ptr);
+	}
+      else
+	{
+	  gfc_init_se (&se, NULL);
+	  if (expr1->rank)
+	    {
+	      gfc_conv_expr_descriptor (&se, expr1);
+	      ptr = gfc_conv_descriptor_data_get (se.expr);
+	    }
+	  else
+	    {
+	      gfc_conv_expr (&se, expr1);
+	      ptr = gfc_build_addr_expr (NULL_TREE, se.expr);
+	    }
+	}
+
+      cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			      ptr, build_zero_cst (TREE_TYPE (ptr)));
+      final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+			       cond, gfc_finish_block (&final_block),
+			       build_empty_stmt (input_location));
+    }
+  else
+    final_expr = gfc_finish_block (&final_block);
+
+  /* Check optional present.  */
+  if (expr1->symtree->n.sym->attr.optional)
+    {
+      cond = gfc_conv_expr_present (expr1->symtree->n.sym);
+      final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+			       cond, final_expr,
+			       build_empty_stmt (input_location));
+    }
+
+  return final_expr;
+}
+
+
 static tree
 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 			gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
@@ -11394,6 +11549,16 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 {
   tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
   vec<tree, va_gc> *args = NULL;
+  tree final_expr;
+
+  final_expr = gfc_assignment_finalizer_call (lhs, false);
+  if (final_expr != NULL_TREE)
+    {
+      if (rse->loop)
+	gfc_prepend_expr_to_block (&rse->loop->pre, final_expr);
+      else
+	gfc_add_expr_to_block (block, final_expr);
+    }
 
   /* Store the old vptr so that dynamic types can be compared for
      reallocation to occur or not.  */
@@ -11419,8 +11584,12 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 	old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
 
       size = gfc_vptr_size_get (vptr);
-      class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
-	  ? gfc_class_data_get (lse->expr) : lse->expr;
+      if (TREE_CODE (lse->expr) == INDIRECT_REF)
+	tmp = TREE_OPERAND (lse->expr, 0);
+      else
+	tmp = lse->expr;
+      class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+	  ? gfc_class_data_get (tmp) : tmp;
 
       /* Allocate block.  */
       gfc_init_block (&alloc);
@@ -11519,6 +11688,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
     }
 }
 
+
 /* Subroutine of gfc_trans_assignment that actually scalarizes the
    assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
    init_flag indicates initialization expressions and dealloc that no
@@ -11542,6 +11712,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   tree tmp;
   stmtblock_t block;
   stmtblock_t body;
+  tree final_expr;
   bool l_is_temp;
   bool scalar_to_array;
   tree string_length;
@@ -11582,6 +11753,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
      needed at two locations, so do it once only before the information is
      needed.  */
   lhs_attr = gfc_expr_attr (expr1);
+
   is_poly_assign = (use_vptr_copy || lhs_attr.pointer
 		    || (lhs_attr.allocatable && !lhs_attr.dimension))
 		   && (expr1->ts.type == BT_CLASS
@@ -11855,6 +12027,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	  else
 	    gfc_add_expr_to_block (&loop.post, tmp2);
 	}
+
+      expr1->must_finalize = 0;
     }
   else if (flag_coarray == GFC_FCOARRAY_LIB
 	   && lhs_caf_attr.codimension && rhs_caf_attr.codimension
@@ -11909,12 +12083,36 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 				   !(l_is_temp || init_flag) && dealloc,
 				   expr1->symtree->n.sym->attr.codimension);
 
-  /* Add the pre blocks to the body.  */
-  gfc_add_block_to_block (&body, &rse.pre);
+  /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
+     after evaluation of the rhs and before reallocation.  */
+  final_expr = gfc_assignment_finalizer_call (expr1, init_flag);
+  if (final_expr)
+    {
+      if (lss == gfc_ss_terminator)
+	{
+	  gfc_add_block_to_block (&block, &rse.pre);
+	  gfc_add_expr_to_block (&block, final_expr);
+	}
+      else
+	{
+	  gfc_add_block_to_block (&body, &rse.pre);
+	  gfc_add_expr_to_block (&loop.code[expr1->rank - 1], final_expr);
+	}
+    }
+  else
+    gfc_add_block_to_block (&body, &rse.pre);
+
+  /* Add the lse pre block to the body  */
   gfc_add_block_to_block (&body, &lse.pre);
   gfc_add_expr_to_block (&body, tmp);
   /* Add the post blocks to the body.  */
-  gfc_add_block_to_block (&body, &rse.post);
+  if (lss == gfc_ss_terminator)
+    {
+      gfc_add_block_to_block (&rse.finalblock, &rse.post);
+      gfc_add_block_to_block (&body, &rse.finalblock);
+    }
+  else
+    gfc_add_block_to_block (&body, &rse.post);
   gfc_add_block_to_block (&body, &lse.post);
 
   if (lss == gfc_ss_terminator)
@@ -11979,6 +12177,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
       /* Wrap the whole thing up.  */
       gfc_add_block_to_block (&block, &loop.pre);
       gfc_add_block_to_block (&block, &loop.post);
+      gfc_add_block_to_block (&block, &rse.finalblock);
 
       gfc_cleanup_loop (&loop);
     }
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index 732221f848b..bf4f0671585 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2664,6 +2664,7 @@ scalarize:
 
   gfc_add_block_to_block (&body, &se.pre);
   gfc_add_block_to_block (&body, &se.post);
+  gfc_add_block_to_block (&body, &se.finalblock);
 
   if (se.ss == NULL)
     tmp = gfc_finish_block (&body);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 04f8147d23b..e0f513f8941 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -443,7 +443,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
       else
 	gfc_add_expr_to_block (&se.pre, se.expr);
 
-      gfc_add_block_to_block (&se.pre, &se.post);
+      gfc_add_block_to_block (&se.finalblock, &se.post);
+      gfc_add_block_to_block (&se.pre, &se.finalblock);
     }
 
   else
@@ -542,6 +543,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
       gfc_trans_scalarizing_loops (&loop, &body);
       gfc_add_block_to_block (&se.pre, &loop.pre);
       gfc_add_block_to_block (&se.pre, &loop.post);
+      gfc_add_block_to_block (&se.pre, &loopse.finalblock);
       gfc_add_block_to_block (&se.pre, &se.post);
       gfc_cleanup_loop (&loop);
     }
@@ -6337,7 +6339,10 @@ gfc_trans_allocate (gfc_code * code)
 	}
       gfc_add_block_to_block (&block, &se.pre);
       if (code->expr3->must_finalize)
-	gfc_add_block_to_block (&final_block, &se.post);
+	{
+	  gfc_add_block_to_block (&final_block, &se.finalblock);
+	  gfc_add_block_to_block (&final_block, &se.post);
+	}
       else
 	gfc_add_block_to_block (&post, &se.post);
 
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 738c7487a56..72af54c4d29 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -43,6 +43,10 @@ typedef struct gfc_se
   stmtblock_t pre;
   stmtblock_t post;
 
+  /* Carries finalization code that is required to be executed execution of the
+     innermost executable construct.  */
+  stmtblock_t finalblock;
+
   /* the result of the expression */
   tree expr;
 
@@ -55,7 +59,7 @@ typedef struct gfc_se
 
   /* Whether expr is a reference to an unlimited polymorphic object.  */
   unsigned unlimited_polymorphic:1;
-  
+
   /* If set gfc_conv_variable will return an expression for the array
      descriptor. When set, want_pointer should also be set.
      If not set scalarizing variables will be substituted.  */
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
index 92dc50756d4..de20a147842 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
@@ -68,4 +68,4 @@ contains
   end function func_foo_a
 
 end program simple_leak
-! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } }
+! { dg-final { scan-tree-dump-times "\>_final" 4 "original" } }