Merge pull request #11 from sourceryinstitute/add-uddtio-in-assert

feat(assert): add "object" class type guard

Author: Damian Rouson

src/assertions_implementation.F90

@@ -12,6 +12,7 @@
   module procedure assert
     use iso_fortran_env, only : error_unit
     use string_functions_interface, only : string
+    use object_interface, only : object
 
     character(len=:), allocatable :: header, trailer
     integer, parameter :: max_this_image_digits=9
@@ -32,21 +33,25 @@
         else
 
           block
-            character(len=*), parameter :: lede = "with diagnostic data"
+            character(len=*), parameter :: prefix = "with diagnostic data"
+            integer, parameter :: max_data_length = 1024
 
             select type(diagnostic_data)
               type is(character(len=*))
-                trailer =  lede // diagnostic_data
+                trailer =  prefix // diagnostic_data
               type is(integer)
-                trailer = lede // string(diagnostic_data)
+                trailer = prefix // string(diagnostic_data)
+              class is(object)
+                trailer = repeat(" ", ncopies =  max_data_length)
+                write(trailer,*) diagnostic_data
               class default
-                trailer = lede // 'of unsupported type'
+                trailer = prefix // 'of unsupported type'
             end select
           end block
 
         end if
 
-        error stop header // trailer
+        error stop header // trim(trailer)
 
       end if
 

src/object_interface.f90

@@ -1,16 +1,11 @@
-!! author: Damian Rouson, GSE LLC
-!! category: Morfeus-FD
-!! summary: Abstract base type, `object`
-!!
-!! ### Copyright notice
-!!
-!!     ```
-!!     (c) 2019-2020 Guide Star Engineering, LLC
-!!     This Software was developed for the US Nuclear Regulatory Commission (US NRC) under contract
-!!     "Multi-Dimensional Physics Implementation into Fuel Analysis under Steady-state and Transients (FAST)",
-!!     contract # NRC-HQ-60-17-C-0007
-!!     ```
-
+! ### Copyright notice
+!
+!     ```
+!     (c) 2019-2020 Guide Star Engineering, LLC
+!     This Software was developed for the US Nuclear Regulatory Commission (US NRC) under contract
+!     "Multi-Dimensional Physics Implementation into Fuel Analysis under Steady-state and Transients (FAST)",
+!     contract # NRC-HQ-60-17-C-0007
+!     ```
 module object_interface
   implicit none
 
@@ -31,6 +26,8 @@ module object_interface
   contains
     procedure :: mark_as_defined
     procedure :: user_defined
+    procedure(write_interface), deferred :: write_formatted
+    generic :: write(formatted) => write_formatted
   end type
 
   interface
@@ -50,4 +47,16 @@ pure module function user_defined(this) result(is_defined)
 
   end interface
 
+  abstract interface
+    subroutine write_interface(self, unit, iotype, v_list, iostat, iomsg)
+      import object
+      class(object), intent(in) :: self
+      integer, intent(in) :: unit
+      character(*), intent(in) :: iotype
+      integer, intent(in) :: v_list(:)
+      integer, intent(out) :: iostat
+      character(*), intent(inout) :: iomsg
+    end subroutine
+  end interface
+
 end module object_interface

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