diff --git a/src/assertions_implementation.F90 b/src/assertions_implementation.F90 index 70f737e6..3c865b6a 100644 --- a/src/assertions_implementation.F90 +++ b/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 diff --git a/src/object_interface.f90 b/src/object_interface.f90 index d871ce5f..81a2b044 100644 --- a/src/object_interface.f90 +++ b/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 diff --git a/tests/main.f90 b/tests/main.f90 index 543d06d8..88c3bdd3 100644 --- a/tests/main.f90 +++ b/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) diff --git a/tests/object_interface_test.f90 b/tests/object_interface_test.f90 new file mode 100644 index 00000000..fbb00cd9 --- /dev/null +++ b/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