Feature: offer macros for invoking the assert subroutine only when -DDEBUG is passed

README.md

@@ -52,14 +52,6 @@ The [examples/README.md] file shows examples of writing constraints in notes on
 Downloading, Building, and Running Examples
 -------------------------------------------
 
-### Prerequisites
-1. A Fortran 2018 compiler.
-2. The [Fortran Package Manager].
-3. _Optional_: [OpenCoarrays] for parallel execution with the GNU Fortran compiler.
-
-Assert was developed primarily with `gfortran` 11.2.0 and `nagfor` 7.1.
-Recent versions of the Cray and Intel compilers should also suffice.  
-
 ### Downloading Assert
 ```
 git clone [email protected]:sourceryinstitute/assert
@@ -70,29 +62,34 @@ cd assert
 #### Single-image (serial) execution
 The following command builds Assert and runs the full test suite in a single image:
 ```
-fpm test
+fpm test --profile release
 ```
-where `fpm test` builds the Assert library and runs the test suite, including the tests.
+which builds the Assert library and runs the test suite.
 
 #### Multi-image (parallel) execution
 With `gfortran` and OpenCoarrays installed,
 ```
-fpm test --compiler caf --runner "cafrun -n 2"
+fpm test --compiler caf --profile release --runner "cafrun -n 2"
 ```
 To build and test with the Numerical Algorithms Group (NAG) Fortran compiler version
 7.1 or later, use
 ```
-fpm test --compiler=nagfor --flag="-coarray=cosmp -fpp -f2018"
+fpm test --compiler=nagfor --profile release --flag="-coarray=cosmp -fpp -f2018"
 ```
 
 ### Building and testing with the Intel `ifx` compiler
 ```
-fpm test --compiler ifx --flag -coarray
+fpm test --compiler ifx --profile release --flag -coarray
+```
+### Building and testing with the LLVM `flang-new` compiler
+```
+fpm test --compiler flang-new --flag "-mmlir -allow-assumed-rank -O3"
+
 ```
 
 ### Building and testing with the Numerical Algorithms Group (NAG) compiler
 ```
-fpm test --compiler nagfor --flag "-fpp -coarray=cosmp"
+fpm test --compiler nagfor --profile release --flag "-fpp -coarray=cosmp"
 ```
 
 ### Building and testing with the Cray Compiler Environment (CCE)
@@ -108,7 +105,7 @@ ftn $@
 ```
 Then build and test Assert with the command
 ```
-fpm test --compiler crayftn.sh
+fpm test --compiler crayftn.sh --profile release
 ```
 
 

example/false-assertion.F90

@@ -0,0 +1,7 @@
+program false_assertion
+  use assert_m, only : assert
+  implicit none
+
+  call assert(.false., "false-assertion: unconditionally failing test")
+
+end program

example/invoke-via-macro.F90

@@ -0,0 +1,25 @@
+#include "../src/assert/assert_macros.h"
+
+program invoke_via_macro
+  !! Demonstrate how to invoke the 'assert' subroutine using a preprocessor macro that facilitates
+  !! the complete removal of the call in the absence of the compiler flag -DDEBUG.
+  use assert_m, only : assert, intrinsic_array_t, string
+    !! If an "only" clause is employed as above, it must include the "string" function that the
+    !! call_assert* macros reference when transforming the code below into "assert" subroutine calls.
+  implicit none
+
+#ifndef DEBUG
+  print *
+  print *,'To enable the "assert" call, define -DDEBUG, e.g., fpm run --example invoke-via-macro --flag "-DDEBUG -fcoarray=single"'
+  print *
+#endif
+
+  ! The C preprocessor will convert each call_assert* macro below into calls to the "assert" subroutine 
+  ! (if -DDEBUG is in the compiler command) or into nothing (if -DDEBUG is not in the compiler command).
+
+  call_assert(1==1) ! true assertion
+  call_assert_describe(2>0,    "example assertion invocation via macro") ! true assertion
+  call_assert_diagnose(1+1==2, "example with scalar diagnostic data", 1+1) ! true assertion
+  call_assert_diagnose(1+1>2,  "example with array diagnostic data" , intrinsic_array_t([1,1,2])) ! false assertion
+
+end program invoke_via_macro

example/support-assert-test-suite/check-exit-status.f90

@@ -0,0 +1,14 @@
+program check_exit_status
+  ! Despite its location in the example subdirectory, this program is _not_ intended to
+  ! be a user-facing example. This program exists to work around an LLVM Flang (flang-new)
+  ! compiler issue. This program is invoked by test/test-assert-subroutine-error-termination.F90,
+  ! which reads the file this program writes to determine the exist status of the program
+  ! example/false-assertion.f90. The latter  program intentionally error terminates in order
+  ! to test the case wehn assertion = .false.
+  implicit none
+  integer exit_status, unit
+  read(*,*) exit_status
+  open(newunit=unit, file="build/exit_status", status="unknown")
+  write(unit,*) exit_status
+  close(unit)
+end program 

src/assert/assert_macros.h

@@ -0,0 +1,9 @@
+#ifdef DEBUG
+# define call_assert(assertion) call assert(assertion, "No description provided (see file " // __FILE__ // ", line " // string(__LINE__) // ")")
+# define call_assert_describe(assertion, description) call assert(assertion, description // " in file " // __FILE__ // ", line " // string(__LINE__) // ": " )
+# define call_assert_diagnose(assertion, description, diagnostic_data) call assert(assertion, "file " // __FILE__ // ", line " // string(__LINE__) // ": " // description, diagnostic_data)
+#else
+# define call_assert(assertion)
+# define call_assert_describe(assertion, description)
+# define call_assert_diagnose(assertion, description, diagnostic_data)
+#endif

src/assert/intrinsic_array_s.F90

@@ -1,4 +1,5 @@
 submodule(intrinsic_array_m) intrinsic_array_s
+  use assert_m, only : assert
   implicit none
 
 contains
@@ -11,21 +12,25 @@
       select type(array)
       type is(complex)
         allocate(intrinsic_array%complex_1D, source = array)
+      type is(complex(kind(1.D0)))
+        allocate(intrinsic_array%complex_double_1D, source = array)
       type is(integer)
         allocate(intrinsic_array%integer_1D, source = array)
       type is(logical)
         allocate(intrinsic_array%logical_1D, source = array)
       type is(real)
         allocate(intrinsic_array%real_1D, source = array)
       type is(double precision)
-        allocate(intrinsic_array%double_precision_1D, source = array)
+        intrinsic_array%double_precision_1D = array
       class default
-        error  stop "intrinsic_array_t construct: unsupported rank-1 type"
+        error  stop "intrinsic_array_s(construct): unsupported rank-1 type"
       end select
     rank(2)
       select type(array)
       type is(complex)
         allocate(intrinsic_array%complex_2D, source = array)
+      type is(complex(kind(1.D0)))
+        allocate(intrinsic_array%complex_double_2D, source = array)
       type is(integer)
         allocate(intrinsic_array%integer_2D, source = array)
       type is(logical)
@@ -35,13 +40,15 @@
       type is(double precision)
         allocate(intrinsic_array%double_precision_2D, source = array)
       class default
-        error  stop "intrinsic_array_t construct: unsupported rank-2 type"
+        error  stop "intrinsic_array_s(construct): unsupported rank-2 type"
       end select
 
     rank(3)
       select type(array)
       type is(complex)
         allocate(intrinsic_array%complex_3D, source = array)
+      type is(complex(kind(1.D0)))
+        allocate(intrinsic_array%complex_double_3D, source = array)
       type is(integer)
         allocate(intrinsic_array%integer_3D, source = array)
       type is(logical)
@@ -51,11 +58,11 @@
       type is(double precision)
         allocate(intrinsic_array%double_precision_3D, source = array)
       class default
-        error  stop "intrinsic_array_t construct: unsupported rank-3 type"
+        error  stop "intrinsic_array_s(construct): unsupported rank-3 type"
       end select
 
     rank default
-      error  stop "intrinsic_array_t construct: unsupported rank"
+      error  stop "intrinsic_array_s(construct): unsupported rank"
     end select
 
   end procedure
@@ -71,7 +78,7 @@
         rank(3)
             allocate(intrinsic_array%complex_3D, source = array)
         rank default
-          error  stop "intrinsic_array_t complex_array: unsupported rank"
+          error  stop "intrinsic_array_s(complex_array): unsupported rank"
       end select
 
     end procedure
@@ -86,7 +93,7 @@
         rank(3)
             allocate(intrinsic_array%integer_3D, source = array)
         rank default
-          error  stop "intrinsic_array_t integer_array: unsupported rank"
+          error  stop "intrinsic_array_s(integer_array): unsupported rank"
       end select
 
     end procedure
@@ -101,7 +108,7 @@
         rank(3)
             allocate(intrinsic_array%logical_3D, source = array)
         rank default
-          error  stop "intrinsic_array_t logical_array: unsupported rank"
+          error  stop "intrinsic_array_s(logical_array): unsupported rank"
       end select
 
     end procedure
@@ -116,7 +123,7 @@
         rank(3)
             allocate(intrinsic_array%real_3D, source = array)
         rank default
-          error  stop "intrinsic_array_t real_array: unsupported rank"
+          error  stop "intrinsic_array_s(real_array): unsupported rank"
       end select
 
     end procedure
@@ -131,28 +138,32 @@
         rank(3)
             allocate(intrinsic_array%double_precision_3D, source = array)
         rank default
-          error  stop "intrinsic_array_t double_precision_array: unsupported rank"
+          error  stop "intrinsic_array_s(double_precision_array): unsupported rank"
       end select
 
     end procedure
 
 #endif
 
-  pure function one_allocated_component(self) result(one_allocated)
+  pure function allocated_components(self) 
     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) &
-      ])
+    logical, allocatable :: allocated_components(:)
+    allocated_components = [ &
+       allocated(self%complex_1D), allocated(self%real_1D), allocated(self%integer_1D), allocated(self%complex_double_1D) &
+      ,allocated(self%complex_2D), allocated(self%real_2D), allocated(self%integer_2D), allocated(self%complex_double_2D) &
+      ,allocated(self%complex_3D), allocated(self%real_3D), allocated(self%integer_3D), allocated(self%complex_double_3D) &
+      ,allocated(self%logical_1D), allocated(self%double_precision_1D) &
+      ,allocated(self%logical_2D), allocated(self%double_precision_2D) &
+      ,allocated(self%logical_3D), allocated(self%double_precision_3D) &
+    ]
   end function
 
   module procedure as_character
-    integer, parameter :: single_number_width=32
+    integer, parameter :: single_number_width=64
 
-    if (.not. one_allocated_component(self)) error stop "intrinsic_array_s(as_character): invalid number of allocated components"
+    associate(a => allocated_components(self))
+      call assert(count(a) == 1, "intrinsic_array_s(as_character): invalid number of allocated components", intrinsic_array_t(a))
+    end associate
 
     if (allocated(self%complex_1D)) then
       character_self = repeat(" ", ncopies = single_number_width*size(self%complex_1D))
@@ -182,7 +193,7 @@ pure function one_allocated_component(self) result(one_allocated)
       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))
+      character_self = repeat(" ", ncopies = single_number_width*size(self%logical_2D))
       write(character_self, *) self%logical_2D
     else if (allocated(self%real_2D)) then
       character_self = repeat(" ", ncopies = single_number_width*size(self%real_2D))
@@ -200,7 +211,7 @@ pure function one_allocated_component(self) result(one_allocated)
       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))
+      character_self = repeat(" ", ncopies = single_number_width*size(self%logical_3D))
       write(character_self, *) self%logical_3D
     else if (allocated(self%real_3D)) then
       character_self = repeat(" ", ncopies = single_number_width*size(self%real_3D))

src/assert/string_m.f90

@@ -0,0 +1,16 @@
+module string_m
+  implicit none
+
+contains  
+
+   pure function string(number) result(number_as_string)
+    integer, intent(in) :: number
+    integer, parameter :: max_len=128
+    character(len=max_len) :: untrimmed_string
+    character(len=:), allocatable :: number_as_string
+
+    write(untrimmed_string, *) number
+    number_as_string = trim(adjustl(untrimmed_string))
+  end function
+
+end module string_m

src/assert_m.f90

@@ -2,5 +2,6 @@ module assert_m
   use intrinsic_array_m
   use assert_subroutine_m
   use characterizable_m
+  use string_m, only : string
   implicit none
 end module assert_m

test/run-false-assertion.sh

@@ -0,0 +1,3 @@
+#!/bin/bash
+output=$(fpm run --example false_assertion --compiler flang-new --flag '-mmlir -allow-assumed-rank -O3' > /dev/null 2>&1)
+echo $?

test/test-assert-macro.F90

@@ -0,0 +1,46 @@
+program test_assert_macros
+  use assert_m
+  implicit none
+
+  print *
+  print *,"The call_assert macro"
+
+#define DEBUG
+#include "../../src/assert/assert_macros.h"
+  call_assert(1==1)
+  print *,"  passes on not error-terminating when an assertion expression evaluating to .true. is the only argument"
+
+#undef DEBUG
+#include "../../src/assert/assert_macros.h"
+  call_assert(.false.)
+  print *,"  passes on being removed by the preprocessor when DEBUG is undefined" // new_line('')
+
+  !------------------------------------------
+
+  print *,"The call_assert_describe macro"
+
+#define DEBUG
+#include "../../src/assert/assert_macros.h"
+  call_assert_describe(.true., ".true.")
+  print *,"  passes on not error-terminating when assertion = .true. and a description is present"
+
+#undef DEBUG
+#include "../../src/assert/assert_macros.h"
+  call_assert_describe(.false., "")
+  print *,"  passes on being removed by the preprocessor when DEBUG is undefined" // new_line('')
+
+  !------------------------------------------
+
+  print *,"The call_assert_diagnose macro"
+
+#define DEBUG
+#include "../../src/assert/assert_macros.h"
+  call_assert_diagnose(.true., ".true.", diagnostic_data=1)
+  print *,"  passes on not error-terminating when assertion = .true. and description and diagnostic_data are present"
+
+#undef DEBUG
+#include "../../src/assert/assert_macros.h"
+  call_assert_describe(.false., "")
+  print *,"  passes on being removed by the preprocessor when DEBUG is undefined"
+
+end program