Skip to content

Commit

Permalink
fix(intrinsic_array): mv macro to expose tbp
Browse files Browse the repository at this point in the history
  • Loading branch information
@rouson
rouson committed Feb 10, 2024
1 parent 0fc4380 commit ccd567f
Show file tree
Hide file tree
Showing 2 changed files with 83 additions and 76 deletions.
8 changes: 8 additions & 0 deletions example/derived_type_diagnostic.f90 → example/derived_type_diagnostic.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -137,9 +137,17 @@ program diagnostic_data_pattern

type(stuff_t) stuff

#ifndef _CRAYFTN
associate (i => stuff_t(z=(0.,1.)))
call assert(i%defined(), "main: i%defined()", characterizable_stuff_t(i))!Passes: constructor postcondition ensures defined data
end associate
#else
block
type(stuff_t) stuff
stuff = stuff_t(z=(0.,1.))
call assert(stuff%defined(), "main: i%defined()", characterizable_stuff_t(stuff))
end block
#endif

print *, stuff%z() ! Fails: accessor precondition catches use of undefined data

Expand Down
151 changes: 75 additions & 76 deletions src/assert/intrinsic_array_s.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -60,83 +60,7 @@

end procedure

pure function one_allocated_component(self) result(one_allocated)
type(intrinsic_array_t), intent(in) :: self
logical one_allocated
one_allocated = count( &
[ allocated(self%complex_1D), allocated(self%complex_double_1D), allocated(self%integer_1D), allocated(self%logical_1D), &
allocated(self%real_1D), allocated(self%complex_2D), allocated(self%complex_double_2D), allocated(self%integer_2D), &
allocated(self%logical_2D), allocated(self%real_2D), allocated(self%complex_3D), allocated(self%complex_double_3D), &
allocated(self%integer_3D), allocated(self%logical_3D), allocated(self%real_3D) &
])
end function

module procedure as_character
integer, parameter :: single_number_width=32

if (.not. one_allocated_component(self)) error stop "intrinsic_array_s(as_character): invalid number of allocated components"

if (allocated(self%complex_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_1D))
write(character_self, *) self%complex_1D
else if (allocated(self%complex_double_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_1D))
write(character_self, *) self%complex_double_1D
else if (allocated(self%integer_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%integer_1D))
write(character_self, *) self%integer_1D
else if (allocated(self%logical_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D))
write(character_self, *) self%logical_1D
else if (allocated(self%real_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%real_1D))
write(character_self, *) self%real_1D
else if (allocated(self%double_precision_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_1D))
write(character_self, *) self%double_precision_1D
else if (allocated(self%complex_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_2D))
write(character_self, *) self%complex_2D
else if (allocated(self%complex_double_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_2D))
write(character_self, *) self%complex_double_2D
else if (allocated(self%integer_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%integer_2D))
write(character_self, *) self%integer_2D
else if (allocated(self%logical_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D))
write(character_self, *) self%logical_2D
else if (allocated(self%real_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%real_2D))
write(character_self, *) self%real_2D
else if (allocated(self%double_precision_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_2D))
write(character_self, *) self%double_precision_2D
else if (allocated(self%complex_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_3D))
write(character_self, *) self%complex_3D
else if (allocated(self%complex_double_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_3D))
write(character_self, *) self%complex_double_3D
else if (allocated(self%integer_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%integer_3D))
write(character_self, *) self%integer_3D
else if (allocated(self%logical_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D))
write(character_self, *) self%logical_3D
else if (allocated(self%real_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%real_3D))
write(character_self, *) self%real_3D
else if (allocated(self%double_precision_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_3D))
write(character_self, *) self%double_precision_3D
end if

character_self = trim(adjustl(character_self))
end procedure

#else

module procedure complex_array

select rank(array)
Expand Down Expand Up @@ -214,4 +138,79 @@ pure function one_allocated_component(self) result(one_allocated)

#endif

pure function one_allocated_component(self) result(one_allocated)
type(intrinsic_array_t), intent(in) :: self
logical one_allocated
one_allocated = 1 == count( &
[ allocated(self%complex_1D), allocated(self%complex_double_1D), allocated(self%integer_1D), allocated(self%logical_1D), &
allocated(self%real_1D), allocated(self%complex_2D), allocated(self%complex_double_2D), allocated(self%integer_2D), &
allocated(self%logical_2D), allocated(self%real_2D), allocated(self%complex_3D), allocated(self%complex_double_3D), &
allocated(self%integer_3D), allocated(self%logical_3D), allocated(self%real_3D) &
])
end function

module procedure as_character
integer, parameter :: single_number_width=32

if (.not. one_allocated_component(self)) error stop "intrinsic_array_s(as_character): invalid number of allocated components"

if (allocated(self%complex_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_1D))
write(character_self, *) self%complex_1D
else if (allocated(self%complex_double_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_1D))
write(character_self, *) self%complex_double_1D
else if (allocated(self%integer_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%integer_1D))
write(character_self, *) self%integer_1D
else if (allocated(self%logical_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D))
write(character_self, *) self%logical_1D
else if (allocated(self%real_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%real_1D))
write(character_self, *) self%real_1D
else if (allocated(self%double_precision_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_1D))
write(character_self, *) self%double_precision_1D
else if (allocated(self%complex_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_2D))
write(character_self, *) self%complex_2D
else if (allocated(self%complex_double_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_2D))
write(character_self, *) self%complex_double_2D
else if (allocated(self%integer_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%integer_2D))
write(character_self, *) self%integer_2D
else if (allocated(self%logical_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D))
write(character_self, *) self%logical_2D
else if (allocated(self%real_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%real_2D))
write(character_self, *) self%real_2D
else if (allocated(self%double_precision_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_2D))
write(character_self, *) self%double_precision_2D
else if (allocated(self%complex_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_3D))
write(character_self, *) self%complex_3D
else if (allocated(self%complex_double_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_3D))
write(character_self, *) self%complex_double_3D
else if (allocated(self%integer_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%integer_3D))
write(character_self, *) self%integer_3D
else if (allocated(self%logical_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D))
write(character_self, *) self%logical_3D
else if (allocated(self%real_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%real_3D))
write(character_self, *) self%real_3D
else if (allocated(self%double_precision_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_3D))
write(character_self, *) self%double_precision_3D
end if

character_self = trim(adjustl(character_self))
end procedure

end submodule intrinsic_array_s

0 comments on commit ccd567f

Please sign in to comment.