Stop and print

README.md

@@ -4,13 +4,34 @@
 
 Julienne: Idiomatic Correctness Checking for Fortran 2023
 =========================================================
-The Julienne framework offers a unified approach to writing unit tests and
-assertions.  Julienne defines idioms for specifying correctness conditions in a
-common in tests that wrap the tested procedures or assertions that conditionally
-execute inside procedures.  Julienne idioms center around expressions built from
+The Julienne framework offers unified approaches to unit testing, assertion
+enforcement, and formatted error-output inside `pure` procedures.  Julienne
+defines idioms for specifying correctness conditions in a common way in tests
+that wrap the tested procedures or assertions that conditionally execute inside
+procedures.  Julienne idioms center around expressions built from
 defined operations: a uniquely flexible Fortran capability allowing developers
 to define _new_ operators or to overloading Fortran's intrinsic operators.
 
+Output in pure procedures
+-------------------------
+Julienne's `stop_and_print` generic interface facilitates automatic or user-defined
+formatting of various data types and ranks inside `pure` procedures via either of two
+specific subroutines:
+
+1. One with a Julienne `string_t` dummy argument and
+2. Another with `character` and unlimited-polymorphic/assumed-rank dummy arugments.
+
+The first subroutine accepts Julienne `string_t` expressions that, for example, convert
+numeric arrays to comma-separated text with `.csv. string_t([1,2,3])`.  The second
+subroutine prints its `character` argument as a header followed by user-formatted or
+automatically-formatted representrations of its polymorphic argument.  Julienne
+automatically formats and prints numeric scalars or arrays up to rank 3.  Users can
+format information for printing by encapsulating the text in a Julienne `file_t` object
+or passing an object, or object wrapper, that extends Julienne's `writable_t` abstract
+type and defines the so-inherited `write(formatted)` generic binding.
+
+Expressive idioms
+-----------------
 Example expressions                                  | Supported operand types
 -----------------------------------------------------|--------------------------------------
 `x .approximates. y .within. tolerance`              | `real`, `double precision` for `x`, `y`, `tolerance`
@@ -38,8 +59,6 @@ where
 * `.equalsExpected.` generates asymmetric diagnostic output for failures, denoting the left- and right-hand sides as the actual value and expected values, respectively; and
 * `//` appends the subsequent string to diagnostics strings, if any.
 
-Expressive idioms
------------------
 ### Assertions
 Any of the above expressions can be the actual argument in an invocation of
 Julienne's `call_julienne_assert` function-line preprocessor macro:

src/julienne/julienne_file_m.f90

@@ -31,12 +31,18 @@ module function from_file_with_character_name(file_name) result(file_object)
       type(file_t) file_object
     end function
 
-    pure module function from_lines(lines) result(file_object)
+    pure module function from_string_t_lines(lines) result(file_object)
       implicit none
       type(string_t), intent(in) :: lines(:)
       type(file_t) file_object
     end function
 
+    pure module function from_character_lines(lines) result(file_object)
+      implicit none
+      character(len=*), intent(in) :: lines(:)
+      type(file_t) file_object
+    end function
+
   end interface
 
   interface

src/julienne/julienne_file_s.F90

@@ -42,10 +42,14 @@
     call self%write_to_character_file_name(file_name%string())
   end procedure
 
-  module procedure from_lines
+  module procedure from_string_t_lines
     allocate(file_object%lines_, source=lines)
   end procedure
 
+  module procedure from_character_lines
+    allocate(file_object%lines_, source=string_t(lines))
+  end procedure
+
   module procedure from_file_with_character_name
     file_object = from_file_with_string_name(string_t(file_name))
   end procedure

src/julienne/julienne_stop_and_print_m.F90

@@ -0,0 +1,75 @@
+! Copyright (c), The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
+
+module julienne_stop_and_print_m
+  !! Define a pure subroutine that formats and prints various data types during error termination
+  use julienne_string_m, only : string_t
+  implicit none
+
+  private
+  public :: stop_and_print
+  public :: writable_t
+  public :: character_stop_code
+
+  type, abstract :: writable_t
+    private
+    integer :: maxlen_ = 16384
+  contains
+    generic :: write(formatted) => write_formatted
+    procedure(write_formatted_i), deferred :: write_formatted
+    procedure :: set_maxlen
+    procedure :: maxlen
+  end type
+
+  abstract interface
+
+    subroutine write_formatted_i(self, unit, edit_descriptor, v_list, iostat, iomsg)
+      import writable_t
+      class(writable_t), intent(in) :: self
+      integer, intent(in) :: unit
+      character(len=*), intent(in) :: edit_descriptor
+      integer, intent(in) :: v_list(:)
+      integer, intent(out) :: iostat
+      character(len=*), intent(inout) :: iomsg
+    end subroutine
+
+  end interface
+
+  interface stop_and_print
+
+    pure module subroutine stop_and_print_string(message)
+      implicit none
+      type(string_t), intent(in) :: message
+    end subroutine
+
+    pure module subroutine stop_and_print_header_and_data(header, data)
+      implicit none
+      character(len=*), intent(in) :: header
+      class(*), intent(in) :: data
+    end subroutine
+
+  end interface
+
+  interface
+
+    pure module subroutine set_maxlen(self, length)
+      implicit none
+      class(writable_t), intent(inout) :: self
+      integer, intent(in) :: length
+    end subroutine
+
+    pure module function maxlen(self) result(length)
+      implicit none
+      class(writable_t), intent(in) :: self
+      integer length
+    end function
+
+    pure module function character_stop_code(stuff) result(stop_code)
+      implicit none
+      class(*), intent(in) :: stuff(..)
+      character(len=:), allocatable :: stop_code
+    end function
+
+  end interface
+
+end module julienne_stop_and_print_m

src/julienne/julienne_stop_and_print_s.F90

@@ -0,0 +1,142 @@
+! Copyright (c), The Regents of the University of California and Sourcery Institute
+! Terms of use are as specified in LICENSE.txt
+
+submodule(julienne_stop_and_print_m) julienne_stop_and_print_s
+  use julienne_string_m, only : operator(.csv.), operator(.separatedBy.)
+  use julienne_file_m, only : file_t
+  implicit none
+
+contains 
+
+  module procedure stop_and_print_string
+    error stop message%string()
+  end procedure
+
+  module procedure set_maxlen
+    self%maxlen_ = length
+  end procedure
+
+  module procedure maxlen
+    length = self%maxlen_
+  end procedure
+
+  module procedure stop_and_print_header_and_data
+#ifndef __GFORTRAN__
+    error stop new_line('') // header // new_line('') // character_stop_code(data)
+#else
+    block
+      character(len=:), allocatable :: code
+      code = new_line('') // header // new_line('') // character_stop_code(data)
+      error stop code
+    end block
+#endif
+  end procedure
+
+  module procedure character_stop_code
+
+    type(string_t) stringy_stuff
+    integer row, page
+
+    select rank(stuff)
+      rank(0)
+        select type(stuff)
+          type is(character(len=*))
+            stringy_stuff = stuff
+          type is(complex)
+            stringy_stuff = string_t(stuff)
+            stop_code = stringy_stuff%string()
+          type is(double precision)
+            stringy_stuff = string_t(stuff)
+            stop_code = stringy_stuff%string()
+          type is(file_t)
+            stringy_stuff = stuff%lines() .separatedBy. new_line('')
+            stop_code = stringy_stuff%string()
+          type is(integer)
+            stringy_stuff = string_t(stuff)
+            stop_code = stringy_stuff%string()
+          type is(real)
+            stringy_stuff = string_t(stuff)
+            stop_code = stringy_stuff%string()
+          class is(string_t)
+            stop_code = stuff%string()
+          class is(writable_t)
+            allocate(character(len=stuff%maxlen()) :: stop_code)
+            block
+              integer io_status
+              write(stop_code,*,iostat=io_status) stuff
+              associate(code_maxlen => string_t(stuff%maxlen()))
+                if (io_status /= 0) error stop "Call writable_t's set_maxlen procedure to increase stop_code maximum size above " // code_maxlen%string()
+              end associate
+            end block
+            stop_code = trim(stop_code)
+          class default
+             error stop "character_stop_code (in print_and_stop_s): unsupported stop-code type for scalar"
+        end select
+      rank(1)
+        select type(stuff)
+          type is(character(len=*))
+            stringy_stuff = .csv. string_t(stuff)
+            stop_code = stringy_stuff%string()
+          type is(complex)
+            stringy_stuff = .csv. string_t(stuff)
+            stop_code = stringy_stuff%string()
+          type is(double precision)
+            stringy_stuff = .csv. string_t(stuff)
+            stop_code = stringy_stuff%string()
+          type is(integer)
+            stringy_stuff = .csv. string_t(stuff)
+            stop_code = stringy_stuff%string()
+          type is(real)
+            stringy_stuff = .csv. string_t(stuff)
+            stop_code = stringy_stuff%string()
+          class is(string_t)
+            stringy_stuff = .csv. stuff
+            stop_code = stringy_stuff%string()
+          class default
+             error stop "character_stop_code (in print_and_stop_s): unsupported stop-code type for rank-1 array"
+        end select
+      rank(2)
+        select type(stuff)
+          type is(character(len=*))
+            stringy_stuff =  [(.csv. string_t(stuff(row,:)) , row=1,size(stuff,1))] .separatedBy. new_line('')
+            stop_code = stringy_stuff%string()
+          type is(complex)
+            stringy_stuff =  [(.csv. string_t(stuff(row,:)) , row=1,size(stuff,1))] .separatedBy. new_line('')
+            stop_code = stringy_stuff%string()
+          type is(double precision)
+            stringy_stuff =  [(.csv. string_t(stuff(row,:)) , row=1,size(stuff,1))] .separatedBy. new_line('')
+            stop_code = stringy_stuff%string()
+          type is(integer)
+            stringy_stuff =  [(.csv. string_t(stuff(row,:)) , row=1,size(stuff,1))] .separatedBy. new_line('')
+            stop_code = stringy_stuff%string()
+          type is(real)
+            stringy_stuff =  [(.csv. string_t(stuff(row,:)) , row=1,size(stuff,1))] .separatedBy. new_line('')
+            stop_code = stringy_stuff%string()
+          class default
+             error stop "character_stop_code (in print_and_stop_s): unsupported stop-code type for rank-2 array"
+        end select
+      rank(3)
+        select type(stuff)
+          type is(complex)
+            stringy_stuff =  [( [(.csv. string_t(stuff(row,:,page)) , row=1,size(stuff,1))] .separatedBy. new_line(''), page = 1,size(stuff,3) )] .separatedBy. (new_line('') // new_line(''))
+            stop_code = stringy_stuff%string()
+          type is(double precision)
+            stringy_stuff =  [( [(.csv. string_t(stuff(row,:,page)) , row=1,size(stuff,1))] .separatedBy. new_line(''), page = 1,size(stuff,3) )] .separatedBy. (new_line('') // new_line(''))
+            stop_code = stringy_stuff%string()
+          type is(integer)
+            stringy_stuff =  [( [(.csv. string_t(stuff(row,:,page)) , row=1,size(stuff,1))] .separatedBy. new_line(''), page = 1,size(stuff,3) )] .separatedBy. (new_line('') // new_line(''))
+            stop_code = stringy_stuff%string()
+          type is(real)
+            stringy_stuff =  [( [(.csv. string_t(stuff(row,:,page)) , row=1,size(stuff,1))] .separatedBy. new_line(''), page = 1,size(stuff,3) )] .separatedBy. (new_line('') // new_line(''))
+            stop_code = stringy_stuff%string()
+          class default
+             error stop "character_stop_code (in print_and_stop_s): unsupported stop-code type for rank-3 array"
+        end select
+      rank default
+        associate(stop_code_rank => string_t(stop_code))
+          error stop "character_stop_code (in print_and_stop_s): unsupported stop-code rank: " //  stop_code_rank%string()
+        end associate
+    end select
+  end procedure
+
+end submodule julienne_stop_and_print_s

src/julienne_m.F90

@@ -9,6 +9,7 @@ module julienne_m
   use julienne_file_m, only : file_t
   use julienne_formats_m, only : separated_values, csv
   use julienne_github_ci_m, only : github_ci
+  use julienne_stop_and_print_m, only : stop_and_print, writable_t
   use julienne_string_m, only : string_t, array_of_strings &
     ,operator(.cat.) &
     ,operator(.csv.) &

test/driver.F90

@@ -10,14 +10,14 @@ program test_suite_driver
   ! Modules containing test_t child types:
   use assert_test_m                    ,only :                   assert_test_t
   use bin_test_m                       ,only :                      bin_test_t
+  use character_stop_code_test_m       ,only :      character_stop_code_test_t
   use command_line_test_m              ,only :             command_line_test_t
   use formats_test_m                   ,only :                  formats_test_t
   use multi_image_test_m               ,only :              multi_image_test_t, multi_image_setup
   use string_test_m                    ,only :                   string_test_t
   use test_description_test_m          ,only :         test_description_test_t
   use test_diagnosis_test_m            ,only :           test_diagnosis_test_t
   use test_result_test_m               ,only :              test_result_test_t
-
   implicit none
 
   call multi_image_setup()
@@ -27,6 +27,7 @@ program test_suite_driver
   associate(test_harness => test_harness_t([           &
      test_fixture_t(                  assert_test_t()) &
     ,test_fixture_t(                     bin_test_t()) &
+    ,test_fixture_t(     character_stop_code_test_t()) &
     ,test_fixture_t(                 formats_test_t()) &
     ,test_fixture_t(             multi_image_test_t()) &
     ,test_fixture_t(                  string_test_t()) &