test(object): add object-pattern parent unit test

and add user-defined derived type output deferred binding to
object class.

Author: Damian Rouson

tests/main.f90

@@ -10,17 +10,20 @@ subroutine run()
                 collective_subroutines_co_sum => test_co_sum
         use data_partition_test, only: &
                 data_partition_data_partition => test_data_partition
+        use object_interface_test, only: &
+                object_interface_object => test_object
         use single_image_intrinsics_test, only: &
                 single_image_intrinsics_findloc => test_findloc
         use vegetables, only: test_item_t, test_that, run_tests
 
         type(test_item_t) :: tests
-        type(test_item_t) :: individual_tests(4)
+        type(test_item_t) :: individual_tests(5)
 
         individual_tests(1) = collective_subroutines_co_all()
         individual_tests(2) = collective_subroutines_co_sum()
         individual_tests(3) = data_partition_data_partition()
-        individual_tests(4) = single_image_intrinsics_findloc()
+        individual_tests(4) = object_interface_object()
+        individual_tests(5) = single_image_intrinsics_findloc()
         tests = test_that(individual_tests)
 
         call run_tests(tests)

tests/object_interface_test.f90

@@ -0,0 +1,77 @@
+module object_interface_test
+   !! author: Damian Rouson
+   !!
+   !! summary: verify object pattern asbtract parent
+   use vegetables, only: &
+     result_t, input_t, integer_input_t, test_item_t, &   ! types
+     describe, it, assert_equals, assert_that, assert_not ! functions
+   use object_interface, only : object
+   implicit none
+
+   private
+   public :: test_object
+
+   type, extends(object) :: subject
+   contains
+     procedure write_formatted
+   end type
+
+contains
+
+  function test_object() result(tests)
+    type(test_item_t) tests
+
+    tests = describe( &
+     "object class", &
+     [it( &
+       ".not. user_defined() if only default-initialized", &
+       check_default_initialization), &
+      it( &
+       "user_defined() after call mark_as_defined", &
+       check_mark_as_defined)])
+  end function
+
+  function check_default_initialization() result(result_)
+    !! Verify that user_defined() is .false. for a default-initialied object
+    class(object), allocatable :: object_
+    type(result_t) result_
+
+    allocate(subject :: object_)
+
+    result_ = assert_not(object_%user_defined())
+  end function
+
+  function check_mark_as_defined() result(result_)
+    !! Verify that mark_as_defined results in user_defined() being .true.
+    class(object), allocatable :: object_
+    type(result_t) result_
+
+    allocate(subject :: object_)
+
+    call object_%mark_as_defined
+    result_ = assert_that(object_%user_defined())
+  end function
+
+  subroutine write_formatted(self, unit, iotype, v_list, iostat, iomsg)
+    class(subject), intent(in) :: self
+    integer, intent(in) :: unit
+    character(*), intent(in) :: iotype
+    integer, intent(in) :: v_list(:)
+    integer, intent(out) :: iostat
+    character(*), intent(inout) :: iomsg
+
+    select case(iotype)
+      case('LISTDIRECTED')
+        write(unit,*) self%user_defined()
+        iostat = 0
+        iomsg = ""
+      case default
+        iostat = -1
+        iomsg = "object_interface_test: subject%write_formatted iotype received unsupported iotype " // iotype
+    end select
+
+    associate( unused => v_list)
+    end associate
+  end subroutine
+
+end module object_interface_test