diff --git a/.github/workflows/build-with-flang.yml b/.github/workflows/build-with-flang.yml index 2dab8dd78..07ee2f212 100644 --- a/.github/workflows/build-with-flang.yml +++ b/.github/workflows/build-with-flang.yml @@ -1,4 +1,4 @@ -name: Build with LLVM Flang +name: Build with LLVM Flang 20 on: [push, pull_request] @@ -28,5 +28,5 @@ jobs: fpm --version $FC --version export FPM_FC=$FC - export FPM_FFLAGS="-mmlir -allow-assumed-rank -O3" + export FPM_FFLAGS="-O3" fpm test diff --git a/.github/workflows/CI.yml b/.github/workflows/build-with-gfortran.yml similarity index 62% rename from .github/workflows/CI.yml rename to .github/workflows/build-with-gfortran.yml index fea4ae1a9..777cf9350 100644 --- a/.github/workflows/CI.yml +++ b/.github/workflows/build-with-gfortran.yml @@ -1,4 +1,4 @@ -name: CI +name: Build with gfortran-14 on: [push, pull_request] @@ -8,6 +8,10 @@ jobs: strategy: matrix: os: [macos-13, ubuntu-24.04] + fail-fast: true + env: + FC: gfortran-14 + CXX: g++-14 steps: - name: Checkout code @@ -21,8 +25,10 @@ jobs: if: contains(matrix.os, 'ubuntu') run: | sudo apt update - sudo apt install -y build-essential gfortran-14 g++-14 + sudo apt install -y build-essential $FC $CC - - name: Build and Run unit tests + - name: Build and Test with GCC run: | - fpm test --compiler gfortran-14 + fpm --version + $FC --version + fpm test --compiler $FC diff --git a/README.md b/README.md index 9fb3ad678..c50491a41 100644 --- a/README.md +++ b/README.md @@ -24,12 +24,13 @@ Example expressions | Operand types `(i .lessThan. j) .also. (k .equalsExpected. m))` | `integer`, `real`, `double precision` `x .lessThan. y` | `integer`, `real`, `double precision` `x .greaterThan. y` | `integer`, `real`, `double precision` -`i .greaterThan. j` | `integer`, `real`, `double precision` `i .equalsExpected. j` | `integer`, `character` `i .isAtLeast. j` | `integer`, `real`, `double precision` `i .isAtMost. j` | `integer`, `real`, `double precision` `s .isBefore. t` | `character` `s .isAfter. t` | `character` +`.expect. command_line%argument_present("--help")`| `logical` + where `.isAtLeast.` and `.isAtMost.` can alternatively be spelled `.greaterThanOrEqualTo.` and `.lessThanOrEqualTo.`, respectively; diff --git a/demo/README.md b/demo/README.md index 4d82c8baa..82dcccf18 100644 --- a/demo/README.md +++ b/demo/README.md @@ -1,38 +1,36 @@ Getting Started =============== To get started with Julienne, review and test the demonstration project in this directory. -Then copy the `main.F90` and `specimen_test_m.F90` files to your project's test directory. +Then copy the `main.f90` and `specimen_test_m.f90` files to your project's test directory. Finally, modify the files as described below to adapt them to your project. Testing the Demonstration Project -------------------------------- This demonstration project defines a trivial library named "specimen" in the `src` -subdirectory and a test suite the `test` subdirectory. The test suite includes five tests: +subdirectory and a test suite in the `test` subdirectory. The test suite includes five tests: -1. Two tests pass. +1. Three tests pass. 2. One test intentionally fails to demonstrate diagnostic output. 3. One test is skipped to demonstrate the reporting and tallying of skipped tests. -4. One test passes with three compilers but is skipped with GCC due to a compiler bug. Test Julienne by setting your present working directory to the `demo/` subdirectory in a terminal window and then building and running the demonstration project's test suite using the command corresponding to your compiler in the table below. -|Vendor | Version/Build | Example shell command | -|---------|-------------------------|------------------------------------------------------------------------------------| -|LLVM | 20.1.4 (Homebrew) | `fpm test --compiler flang-new` | -|GCC | 14.2.0_1 (Homebrew) | `fpm test --compiler gfortran --profile release` | -|GCC | 13.3.0_1 (Homebrew) | `fpm test --compiler gfortran --profile release --flag "-ffree-line-length-0"` | -|NAG | 7.2 Build 7227 | `fpm test --compiler nagfor --flag -fpp` | -|Intel | 2025.1.0 Build 20250317 | `fpm test --compiler ifx --flag "-fpp -O3 -coarray"` | +|Vendor | Version/Build Tested | Example shell command | +|---------|-------------------------|------------------------------------------------------| +|LLVM | 20.1.4 | `fpm test --compiler flang-new` | +|GCC | 14.3.0 | `fpm test --compiler gfortran --profile release` | +|NAG | 7.2 Build 7235 | `fpm test --compiler nagfor --flag -fpp` | +|Intel | 2025.1.0 Build 20250317 | `fpm test --compiler ifx --flag "-fpp -O3 -coarray"` | Setting Up Your Project's Test Suite ------------------------------------ -1. If you build your project with the Fortran Package Manager ([`fpm`](https://github.com/fotran-lang/fpm)), then you might copy the `main.F90` and `specimen_test_m.F90` files from this subdirectory to a `test/` subdirectory in the root of your project's source tree. -2. Rename the `specimen_test_m.F90` file, the `specimen_test_m` module, and the `specimen_test_t` derived type and any references thereto, replacing `specimen` with the name of an entity that you intend to test -- most likely a module containing procedures or derived type with type-bound procedures. -3. Similarly replace occurrences of `specimen` in the resulting`test/main.F90` file. -4. In the `results()` function body of your new `*_test_m.F90` file, replace the `test_descriptions_t` array constructor elements with your own test descriptions. The test output will read most naturally if your description string (the first argument) contains a gerund: a verb ending in "ing" and used as a noun, such as `producing` above +1. If you build your project with the Fortran Package Manager ([`fpm`](https://github.com/fotran-lang/fpm)), then you might copy the `main.f90` and `specimen_test_m.f90` files from this subdirectory to a `test/` subdirectory in the root of your project's source tree. +2. Rename the `specimen_test_m.f90` file, the `specimen_test_m` module, and the `specimen_test_t` derived type and any references thereto, replacing `specimen` with the name of an entity that you intend to test -- most likely a module containing procedures or derived type with type-bound procedures. +3. Similarly replace occurrences of `specimen` in the resulting`test/main.f90` file. +4. In the `results()` function body of your new `*_test_m.f90` file, replace the `test_descriptions_t` array constructor elements with your own test descriptions. The test output will read most naturally if your description string (the first argument) contains a gerund: a verb ending in "ing" and used as a noun, such as `producing` above. 5. Replace the function name (the second argument) with the name of a function that will perform your test. 7. Edit the correspondingly-renamed function to perform the test. The function must take no arguments and define a `test_diagnosis_t` result. @@ -43,7 +41,7 @@ The options include 2. Invoking the `test_diagnosis_t` constructor and using Julienne's `string_t` constructors to form a diagnostic string. `String_t` is a generic interface to various specific functions, each of which takes an argument of a different data type, kind, and rank (TKR) and defines a `string_t` result containing a charater representation of the function argument. -Please see Julienne's online [documentation] for the currently supported TKR. +Please see Julienne's online [documentation](https://berkeleylab.github.io/julienne) for the currently supported TKR. Please submit an issue to request support for additional TKR or submit a pull request to contribute such support. #### Forming diagnostic strings from array data @@ -127,7 +125,7 @@ One might accomplish this with the compiler's predefined preprocessor macro: ,test_description_t('constructing bracketed strings' ) & #endif ``` -which presently appears in Julienne `test/string_test_m.F90` test in order to work around a runtime crash known to be caused by a `gfortran` bug. +which presently appears in Julienne `test/string_test_m.f90` test in order to work around a runtime crash known to be caused by a `gfortran` bug. String_t Functions ------------------ @@ -167,7 +165,7 @@ Deprecated: Vector Diagnosis Function Julienne's `vector_diagnosis_function_i` abstract interface and the corresponding `vector_test_description_t` type were developed before Julienne's `operator(.all.)` and `operator(.and.)`. Because the operators replace the interface and type with simpler functionality, it is likely that a future release will remove the `vector_*` entities. -The Unified Modeling Language ([UML]) class diagram below depicts the class relationships involved when test function performs multiple checks and defines a result containing an array of corresponding `test_diagnosis_t` objects: +The Unified Modeling Language ([UML](https://wikipedia.org/Unified_modeling_language)) class diagram below depicts the class relationships involved when test function performs multiple checks and defines a result containing an array of corresponding `test_diagnosis_t` objects: ```mermaid %%{init: { 'theme':'default', "class" : {"hideEmptyMembersBox": true} } }%% classDiagram @@ -187,6 +185,3 @@ class test_diagnosis_t{ test_diagnosis_t(test_passed : logical, diagnostics_string : string_t) } ``` - -[documentation]: https://berkeleylab.github.io/julienne -[UML]: https://wikipedia.org/Unified_modeling_language diff --git a/demo/fpm.toml b/demo/fpm.toml index 9bebbc833..97d45a379 100644 --- a/demo/fpm.toml +++ b/demo/fpm.toml @@ -1,4 +1,4 @@ name = "Example-Test-Suite" [dependencies] -julienne = {git = "https://github.com/berkeleylab/julienne", tag = "2.1.0-rc5"} +julienne = {path = "../"} diff --git a/demo/include/language-support.F90 b/demo/include/language-support.F90 deleted file mode 100644 index d27c70243..000000000 --- a/demo/include/language-support.F90 +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (c) 2024-2025, The Regents of the University of California -! Terms of use are as specified in LICENSE.txt - -#ifndef _JULIENNE_LANGUAGE_SUPPORT_H -#define _JULIENNE_LANGUAGE_SUPPORT_H - -! If not already determined, make a compiler-dependent determination of whether Julienne may pass -! procedure actual arguments to procedure pointer dummy arguments, a feature introduced in -! Fortran 2008 and described in Fortran 2023 clause 15.5.2.10 paragraph 5. -#ifndef HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY -# if defined(__GFORTRAN__) -# define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 0 -# else -# define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 1 -# endif -#endif - -! If not already determined, make a compiler-dependent determination of whether Julienne may use -! multi-image features such as `this_image()` and `sync all`. -#ifndef HAVE_MULTI_IMAGE_SUPPORT -# if defined(__flang__) -# define HAVE_MULTI_IMAGE_SUPPORT 0 -# else -# define HAVE_MULTI_IMAGE_SUPPORT 1 -# endif -#endif - -! If not already determined, make a compiler-dependent determination of whether Julienne may use -! kind type parameters for derived types. -#ifndef HAVE_DERIVED_TYPE_KIND_PARAMETERS -# if defined(__GFORTRAN__) -# define HAVE_DERIVED_TYPE_KIND_PARAMETERS 0 -# else -# define HAVE_DERIVED_TYPE_KIND_PARAMETERS 1 -# endif -#endif - -#endif diff --git a/demo/src/specimen_m.F90 b/demo/src/specimen_m.f90 similarity index 100% rename from demo/src/specimen_m.F90 rename to demo/src/specimen_m.f90 diff --git a/demo/test/main.F90 b/demo/test/main.F90 deleted file mode 100644 index b5ef45de9..000000000 --- a/demo/test/main.F90 +++ /dev/null @@ -1,51 +0,0 @@ -! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute -! Terms of use are as specified in LICENSE.txt - -#include "language-support.F90" - -program main - !! Example test main program to demonstrate the printing of diagnostic output when a test fails - use julienne_m, only : command_line_t - use specimen_test_m, only : specimen_test_t - implicit none - - type(specimen_test_t) specimen_test - integer :: passes=0, tests=0, skips=0 - - call print_usage_and_stop_if_help_requested - call specimen_test%report(passes, tests, skips) - call report_tally_and_error_stop_if_test_fails - -contains - - subroutine print_usage_and_stop_if_help_requested - type(command_line_t) command_line - if (command_line%argument_present([character(len=len("--help"))::"--help","-h"])) then - print * - print '(a)', 'Usage: fpm run --example main -- [--help] | [--contains ]' - print * - print '(a)', 'where square brackets ([]) denote optional arguments, a pipe (|) separates alternative arguments,' - print '(a)', 'angular brackets (<>) denote a user-provided value, and passing a substring limits execution to' - print '(a)', 'the tests with test subjects or test descriptions containing the user-specified substring.' - stop - else - print * - print "(a)", "Append '-- --help' or '-- -h' to your `fpm test` command to display usage information." - end if - end subroutine - - subroutine report_tally_and_error_stop_if_test_fails - -#if HAVE_MULTI_IMAGE_SUPPORT - if (this_image()==1) then -#endif - print * - print '(*(a,:,g0))', "_________ In total, ",passes," of ",tests, " tests pass. ", skips , " tests were skipped _________" - if (passes /= tests) error stop "Some tests failed." -#if HAVE_MULTI_IMAGE_SUPPORT - end if -#endif - - end subroutine - -end program diff --git a/demo/test/main.f90 b/demo/test/main.f90 new file mode 100644 index 000000000..8278b46b9 --- /dev/null +++ b/demo/test/main.f90 @@ -0,0 +1,41 @@ +! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +program test_suite_driver + !! Example test-suite driver + use julienne_m ,only : test_fixture_t, test_harness_t ! Import test infrastructure + use specimen_test_m ,only : specimen_test_t ! Must be a non-abstract child type extending Julienne's test_t type + use iso_fortran_env ,only : compiler_version + implicit none + + call stop_if_compiler_too_old + + ! Construct a test harness from an array of test fixtures, each of which is + ! constructed from a structure constructor for a type that extends test_t. + associate(test_harness => test_harness_t( [ test_fixture_t(specimen_test_t()) ] )) + call test_harness%report_results + end associate + +contains + subroutine stop_if_compiler_too_old + character(len=:), allocatable :: compiler_identity + integer major, minor + compiler_identity = compiler_version() + if (index(compiler_identity, "GCC")==1) then + associate( final_dot => index(compiler_identity ,"." ,back=.true.)) + associate( penultimate_dot => index(compiler_identity(:final_dot-1) ,"." ,back=.true.)) + associate(space_before_version => index(compiler_identity(:penultimate_dot-1) ," " ,back=.true.)) + associate( & + major_string => compiler_identity(space_before_version+1 : penultimate_dot-1) & + ,minor_string => compiler_identity( penultimate_dot+1 : final_dot-1) & + ) + read(major_string, '(i2)') major + read(minor_string, '(i1)') minor + if ((major < 14) .or. (major==14 .and. minor<3)) stop "'"// compiler_identity //"' too old: GCC >= 14.3.0 required" + end associate + end associate + end associate + end associate + end if + end subroutine +end program diff --git a/demo/test/specimen_test_m.F90 b/demo/test/specimen_test_m.f90 similarity index 64% rename from demo/test/specimen_test_m.F90 rename to demo/test/specimen_test_m.f90 index 9cfb923b7..3624da1ed 100644 --- a/demo/test/specimen_test_m.F90 +++ b/demo/test/specimen_test_m.f90 @@ -1,8 +1,6 @@ ! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt -#include "language-support.F90" - module specimen_test_m !! Example unit test for the specimen_t test subject use specimen_m, only : specimen_t @@ -17,11 +15,8 @@ module specimen_test_m ,operator(.within.) & ,operator(.all.) & ,operator(.equalsExpected.) & - ,operator(.greaterThan.) & - ,operator(.lessThan.) -#if defined(__GFORTRAN__) - use julienne_m, only : diagnosis_function_i ! work around gfortran's missing Fortran 2008 feature -#endif + ,operator(.lessThan.) & + ,operator(.isAtMost.) implicit none @@ -41,8 +36,6 @@ pure function subject() result(specimen_description) specimen_description = "A specimen_t object" end function -#if ! defined(__GFORTRAN__) - function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_description_t), allocatable :: test_descriptions(:) @@ -61,35 +54,6 @@ function results() result(test_results) test_results = test_descriptions%run() end function -#else - - function results() result(test_results) - !! work around missing Fortran 2008 feature in gfortran versions earlier than 15 - type(test_result_t), allocatable :: test_results(:) - type(test_description_t), allocatable :: test_descriptions(:) - procedure(diagnosis_function_i), pointer :: check_operators_ptr => check_zero_using_operators - procedure(diagnosis_function_i), pointer :: check_constructor_ptr => check_zero_using_constructor - procedure(diagnosis_function_i), pointer :: check_aggregate_ptr => check_aggregate_diagnosis - procedure(diagnosis_function_i), pointer :: check_print_diagnosis_ptr => check_print_diagnosis - - ! Omitting the optional 2nd argument in the 3rd test_description_t constructor below skips the described - ! test. When the test suite runs, it reports the test as skipped and reports a tally of skippped tests. - - test_descriptions = [ & - test_description_t("diagnosing the zero function using Julienne operators", check_operators_ptr) & - ,test_description_t("diagnosing the zero function using a diagnosis constructor", check_constructor_ptr) & - ,test_description_t("aggregating diagnoses of the zero and one functions using operator(.all.)") & - ,test_description_t("(intentional failure to demonstrate diagnostic output)", check_print_diagnosis_ptr) & - ,test_description_t("skipping a test when no diagnosis function is specified") & - ] - test_descriptions = pack( & - array = test_descriptions & - ,mask = test_descriptions%contains_text(test_description_substring) .or. index(subject(), test_description_substring)/=0 & - ) - test_results = test_descriptions%run() - end function -#endif - function check_zero_using_operators() result(test_diagnosis) !! Construct a test diagnosis using Julienne's operator(.approximates.) and operator(.within.) type(test_diagnosis_t) test_diagnosis @@ -123,8 +87,9 @@ function check_aggregate_diagnosis() result(test_diagnosis) end function function check_print_diagnosis() result(test_diagnosis) + !! Intentional test failure to demonstrate diagnostic output type(test_diagnosis_t) test_diagnosis - test_diagnosis = 2 .lessThan. 1 ! intentional test failure + test_diagnosis = 2 .isAtMost. 1 end function end module \ No newline at end of file diff --git a/include/language-support.F90 b/include/language-support.F90 index f71dd6c2e..37e5df9b9 100644 --- a/include/language-support.F90 +++ b/include/language-support.F90 @@ -4,16 +4,21 @@ #ifndef _JULIENNE_LANGUAGE_SUPPORT_H #define _JULIENNE_LANGUAGE_SUPPORT_H +#ifdef __GNUC__ #define GCC_VERSION (__GNUC__ * 10000 + __GNUC_MINOR__ * 100 + __GNUC_PATCHLEVEL__) +#else +#define GCC_VERSION 0 +#endif ! If not already determined, make a compiler-dependent determination of whether Julienne may pass ! procedure actual arguments to procedure pointer dummy arguments, a feature introduced in ! Fortran 2008 and described in Fortran 2023 clause 15.5.2.10 paragraph 5. + #ifndef HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY -# if defined(__GFORTRAN__) -# define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 0 -# else +#if defined(_CRAYFTN) || defined(__INTEL_COMPILER) || defined(NAGFOR) || defined(__flang__) || (GCC_VERSION > 140200) # define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 1 +# else +# define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 0 # endif #endif diff --git a/src/julienne/julienne_test_diagnosis_m.F90 b/src/julienne/julienne_test_diagnosis_m.F90 index 901866a84..31ea81b88 100644 --- a/src/julienne/julienne_test_diagnosis_m.F90 +++ b/src/julienne/julienne_test_diagnosis_m.F90 @@ -22,6 +22,7 @@ module julienne_test_diagnosis_m public :: operator(.withinFraction.) public :: operator(.withinPercentage.) public :: operator(.equalsExpected.) + public :: operator(.expect.) public :: operator(.lessThan.) public :: operator(.lessThanOrEqualTo.) public :: operator(.greaterThan.) @@ -199,6 +200,16 @@ elemental module function approximates_double_precision(actual, expected) result end interface + interface operator(.expect.) + + elemental module function expect(expected_true) result(test_diagnosis) + implicit none + logical, intent(in) :: expected_true + type(test_diagnosis_t) test_diagnosis + end function + + end interface + interface operator(.equalsExpected.) elemental module function equals_expected_integer(actual, expected) result(test_diagnosis) diff --git a/src/julienne/julienne_test_diagnosis_s.F90 b/src/julienne/julienne_test_diagnosis_s.F90 index 241a032b9..57398e293 100644 --- a/src/julienne/julienne_test_diagnosis_s.F90 +++ b/src/julienne/julienne_test_diagnosis_s.F90 @@ -228,6 +228,14 @@ pure function aggregate_vector_diagnosis(diagnoses) result(diagnosis) test_diagnosis = rhs .isBefore. lhs end procedure + module procedure expect + if (expected_true) then + test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") + else + test_diagnosis = test_diagnosis_t(test_passed=.false., diagnostics_string="expected to be true") + end if + end procedure + module procedure equals_expected_integer if (actual == expected) then diff --git a/src/julienne/julienne_test_fixture_m.f90 b/src/julienne/julienne_test_fixture_m.f90 new file mode 100644 index 000000000..5809af8f7 --- /dev/null +++ b/src/julienne/julienne_test_fixture_m.f90 @@ -0,0 +1,43 @@ +! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +module julienne_test_fixture_m + !! Define a wrapper type for the test_t type to facilitate creating a polymorphic + !! array of test_t objects. + use julienne_test_m, only : test_t + + implicit none + + private + public :: test_fixture_t + + type test_fixture_t + private + class(test_t), allocatable :: test_ + contains + procedure report + end type + + interface test_fixture_t + + module function component_constructor(test) result(test_fixture) ! can be pure in Fortran 2023 + !! Construct a test_fixture_t object from its components + implicit none + class(test_t), intent(in) :: test + type(test_fixture_t) test_fixture + end function + + end interface + + interface + + module subroutine report(self, passes, tests, skips) + !! Print the test results and increment the tallies of passing tests, total tests, and skipped tests. + implicit none + class(test_fixture_t), intent(in) :: self + integer, intent(inout) :: passes, tests, skips + end subroutine + + end interface + +end module julienne_test_fixture_m \ No newline at end of file diff --git a/src/julienne/julienne_test_fixture_s.F90 b/src/julienne/julienne_test_fixture_s.F90 new file mode 100644 index 000000000..a65cc6d3b --- /dev/null +++ b/src/julienne/julienne_test_fixture_s.F90 @@ -0,0 +1,17 @@ +! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +submodule(julienne_test_fixture_m) julienne_test_fixture_s + implicit none + +contains + + module procedure component_constructor + test_fixture%test_ = test + end procedure + + module procedure report + call self%test_%report(passes, tests, skips) + end procedure + +end submodule julienne_test_fixture_s \ No newline at end of file diff --git a/src/julienne/julienne_test_harness_m.f90 b/src/julienne/julienne_test_harness_m.f90 new file mode 100644 index 000000000..402556ab8 --- /dev/null +++ b/src/julienne/julienne_test_harness_m.f90 @@ -0,0 +1,43 @@ +! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +module julienne_test_harness_m + !! Define a test harness encapsulating an array of text fixtures, each of which can run a set of tests. + use julienne_test_fixture_m, only : test_fixture_t + + implicit none + + private + public :: test_harness_t + + type test_harness_t + !! Encapsulate a set of test fixtures, each of which can run a set of tests. + private + type(test_fixture_t), allocatable :: test_fixture_(:) + contains + procedure report_results + end type + + interface test_harness_t + + module function component_constructor(test_fixtures) result(test_harness) ! can be pure in Fortran 2028 + !! Component-wise user-defined structure constructor + class(test_fixture_t) test_fixtures(:) + type(test_harness_t) test_harness + end function + + end interface + + interface + + module subroutine report_results(self) + !! If command line includes -h or --help, print usage information and stop. + !! Otherwise, run tests and print results, including diagnostics for any failures. + !! Also, tally and print the numbers of passing tests, total tests, skipped tests. + implicit none + class(test_harness_t), intent(in) :: self + end subroutine + + end interface + +end module julienne_test_harness_m \ No newline at end of file diff --git a/src/julienne/julienne_test_harness_s.F90 b/src/julienne/julienne_test_harness_s.F90 new file mode 100644 index 000000000..de1ddacfc --- /dev/null +++ b/src/julienne/julienne_test_harness_s.F90 @@ -0,0 +1,54 @@ +! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +submodule(julienne_test_harness_m) julienne_test_harness_s + use julienne_command_line_m, only : command_line_t + implicit none + +contains + + module procedure component_constructor + test_harness%test_fixture_ = test_fixtures + end procedure + + module procedure report_results + + call print_usage_info_and_stop_if_requested + + block + integer i, passes, tests, skips + + passes=0; tests=0; skips=0 + + do i = 1, size(self%test_fixture_) + call self%test_fixture_(i)%report(passes, tests, skips) + end do + + print '(a,*(a,:,g0))', new_line(''), "_______ ", passes, " of ", tests, " tests pass. ", skips, " tests were skipped _______" + + if (passes + skips /= tests) error stop "Some tests failed." + end block + + end procedure + + subroutine print_usage_info_and_stop_if_requested + + associate(command_line => command_line_t()) + block + character(len=*), parameter :: usage = & + new_line('') // new_line('') // & + 'Usage: fpm test -- [--help] | [--contains ]' // & + new_line('') // new_line('') // & + 'where square brackets ([]) denote optional arguments, a pipe (|) separates alternative arguments,' // new_line('') // & + 'angular brackets (<>) denote a user-provided value, and passing a substring limits execution to' // new_line('') // & + 'the tests with test subjects or test descriptions containing the user-specified substring.' // new_line('') + + if (command_line%argument_present([character(len=len("--help"))::"--help","-h"])) stop usage + end block + end associate + + print "(a)", new_line("") // "Append '-- --help' or '-- -h' to your `fpm test` command to display usage information." + + end subroutine + +end submodule julienne_test_harness_s \ No newline at end of file diff --git a/src/julienne_m.f90 b/src/julienne_m.f90 index 1540f6556..ec5bcfadf 100644 --- a/src/julienne_m.f90 +++ b/src/julienne_m.f90 @@ -9,21 +9,19 @@ 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_string_m, only : & - string_t & - ,array_of_strings & + use julienne_string_m, only : string_t, array_of_strings & ,operator(.cat.) & ,operator(.csv.) & ,operator(.separatedBy.) & ! same as operator(.sv.) ,operator(.sv.) - use julienne_test_description_m, only : test_description_t, diagnosis_function_i - use julienne_test_diagnosis_m, only : & - test_diagnosis_t & + use julienne_test_description_m, only : test_description_t + use julienne_test_diagnosis_m, only : test_diagnosis_t & ,operator(.all.) & ,operator(.and.) & ,operator(.also.) & ,operator(.approximates.) & ,operator(.equalsExpected.) & + ,operator(.expect.) & ,operator(.isAtLeast.) & ,operator(.isAtMost.) & ,operator(.isBefore.) & @@ -35,10 +33,13 @@ module julienne_m ,operator(.within.) & ,operator(.withinFraction.) & ,operator(.withinPercentage.) - use julienne_test_m, only : test_t, test_description_substring - use julienne_test_result_m, only : test_result_t + use julienne_test_fixture_m, only : test_fixture_t + use julienne_test_harness_m, only : test_harness_t + use julienne_test_m, only : test_t, test_description_substring + use julienne_test_result_m, only : test_result_t !! Deprecated features: + use julienne_test_description_m, only : diagnosis_function_i use julienne_vector_test_description_m, only : vector_test_description_t, vector_diagnosis_function_i implicit none end module julienne_m diff --git a/test/legacy-main.F90 b/test/legacy-main.F90 new file mode 100644 index 000000000..bdc91cd57 --- /dev/null +++ b/test/legacy-main.F90 @@ -0,0 +1,86 @@ +! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt + +#include "language-support.F90" + +program main + !! Julienne unit tests driver + +#if defined(__GCC__) && (GCC_VERSION < 140300) + ! Internal utilities + use julienne_m ,only : command_line_t, GitHub_CI + + ! Test modules + use assert_test_m ,only : assert_test_t + use bin_test_m ,only : bin_test_t + use command_line_test_m ,only : command_line_test_t + use formats_test_m ,only : formats_test_t + use string_test_m ,only : string_test_t + use test_result_test_m ,only : test_result_test_t + use test_description_test_m ,only : test_description_test_t + use test_diagnosis_test_m ,only : test_diagnosis_test_t + use vector_test_description_test_m ,only : vector_test_description_test_t + implicit none + + type(assert_test_t) assert_test + type(bin_test_t) bin_test + type(command_line_test_t) command_line_test + type(formats_test_t) formats_test + type(string_test_t) string_test + type(test_result_test_t) test_result_test + type(test_description_test_t) test_description_test + type(test_diagnosis_test_t) test_diagnosis_test + type(vector_test_description_test_t) vector_test_description_test + + type(command_line_t) command_line + + integer :: passes=0, tests=0, skips=0 + + character(len=*), parameter :: usage = & + new_line('') // new_line('') // & + 'Usage: fpm test -- [--help] | [--contains ]' // & + new_line('') // new_line('') // & + 'where square brackets ([]) denote optional arguments, a pipe (|) separates alternative arguments,' // new_line('') // & + 'angular brackets (<>) denote a user-provided value, and passing a substring limits execution to' // new_line('') // & + 'the tests with test subjects or test descriptions containing the user-specified substring.' // new_line('') + + if (command_line%argument_present([character(len=len("--help"))::"--help","-h"])) stop usage + + print "(a)", new_line("") // "Append '-- --help' or '-- -h' to your `fpm test` command to display usage information." + + call assert_test%report(passes, tests, skips) + call bin_test%report(passes, tests, skips) + call formats_test%report(passes, tests, skips) + call string_test%report(passes, tests, skips) + call test_result_test%report(passes, tests, skips) + call test_description_test%report(passes, tests, skips) + call test_diagnosis_test%report(passes, tests, skips) + call vector_test_description_test%report(passes,tests, skips) + + if (.not. GitHub_CI()) then + if (command_line%argument_present(["--test"])) then + call command_line_test%report(passes, tests, skips) + else + write(*,"(a)") & + new_line("") // & + "To also test Julienne's command_line_t type, append the following to your fpm test command:" // & + new_line("") // & + "-- --test command_line_t --type" + end if + end if + +#if HAVE_MULTI_IMAGE_SUPPORT + if (this_image()==1) then +#endif + + print * + print '(*(a,:,g0))', "_________ In total, ",passes," of ",tests, " tests pass. ", skips, " tests were skipped. _________" + + if (passes + skips /= tests) error stop "Some executed tests failed." + +#if HAVE_MULTI_IMAGE_SUPPORT + end if +#endif + +#endif +end program diff --git a/test/main.F90 b/test/main.F90 index f18803eac..bd4daa043 100644 --- a/test/main.F90 +++ b/test/main.F90 @@ -1,84 +1,40 @@ ! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt -#include "language-support.F90" +program test_suite_driver + !! Julienne test-suite driver -program main - !! Julienne unit tests driver +#if ! defined(__GCC__) || (GCC_VERSION >= 140300) + ! Test infrastructure: + use julienne_m, only : test_fixture_t, test_harness_t - ! Internal utilities - use julienne_m ,only : command_line_t, GitHub_CI - - ! Test modules + ! Modules containing test_t child types: use assert_test_m ,only : assert_test_t use bin_test_m ,only : bin_test_t use command_line_test_m ,only : command_line_test_t use formats_test_m ,only : formats_test_t use string_test_m ,only : string_test_t - use test_result_test_m ,only : test_result_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 use vector_test_description_test_m ,only : vector_test_description_test_t - implicit none - - type(assert_test_t) assert_test - type(bin_test_t) bin_test - type(command_line_test_t) command_line_test - type(formats_test_t) formats_test - type(string_test_t) string_test - type(test_result_test_t) test_result_test - type(test_description_test_t) test_description_test - type(test_diagnosis_test_t) test_diagnosis_test - type(vector_test_description_test_t) vector_test_description_test - - type(command_line_t) command_line - - integer :: passes=0, tests=0, skips=0 - - character(len=*), parameter :: usage = & - new_line('') // new_line('') // & - 'Usage: fpm test -- [--help] | [--contains ]' // & - new_line('') // new_line('') // & - 'where square brackets ([]) denote optional arguments, a pipe (|) separates alternative arguments,' // new_line('') // & - 'angular brackets (<>) denote a user-provided value, and passing a substring limits execution to' // new_line('') // & - 'the tests with test subjects or test descriptions containing the user-specified substring.' // new_line('') - - if (command_line%argument_present([character(len=len("--help"))::"--help","-h"])) stop usage - print "(a)", new_line("") // "Append '-- --help' or '-- -h' to your `fpm test` command to display usage information." - - call assert_test%report(passes, tests, skips) - call bin_test%report(passes, tests, skips) - call formats_test%report(passes, tests, skips) - call string_test%report(passes, tests, skips) - call test_result_test%report(passes, tests, skips) - call test_description_test%report(passes, tests, skips) - call test_diagnosis_test%report(passes, tests, skips) - call vector_test_description_test%report(passes,tests, skips) - - if (.not. GitHub_CI()) then - if (command_line%argument_present(["--test"])) then - call command_line_test%report(passes, tests, skips) - else - write(*,"(a)") & - new_line("") // & - "To also test Julienne's command_line_t type, append the following to your fpm test command:" // & - new_line("") // & - "-- --test command_line_t --type" - end if - end if - -#if HAVE_MULTI_IMAGE_SUPPORT - if (this_image()==1) then -#endif - - print * - print '(*(a,:,g0))', "_________ In total, ",passes," of ",tests, " tests pass. ", skips, " tests were skipped. _________" - - if (passes + skips /= tests) error stop "Some executed tests failed." + implicit none -#if HAVE_MULTI_IMAGE_SUPPORT - end if + ! Construct a test harness from an array of test fixtures, each of which is + ! constructed from an invocation of a test_t child type's structure constructor: + associate(test_harness => test_harness_t([ & + test_fixture_t( assert_test_t()) & + ,test_fixture_t( bin_test_t()) & + ,test_fixture_t( formats_test_t()) & + ,test_fixture_t( string_test_t()) & + ,test_fixture_t( test_description_test_t()) & + ,test_fixture_t( test_diagnosis_test_t()) & + ,test_fixture_t( test_result_test_t()) & + ,test_fixture_t(vector_test_description_test_t()) & + ,test_fixture_t( command_line_test_t()) & + ])) + call test_harness%report_results + end associate #endif - end program diff --git a/test/modules/assert_test_m.F90 b/test/modules/assert_test_m.F90 index 5933b469a..328264cf0 100644 --- a/test/modules/assert_test_m.F90 +++ b/test/modules/assert_test_m.F90 @@ -41,20 +41,15 @@ pure function subject() result(specimen) function results() result(test_results) type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) - associate(descriptions => [ & + test_descriptions = [ & test_description_t("invocation via the call_julienne_assert macro", check_call_julienne_assert_macro) & ,test_description_t("invocation via direct call", check_julienne_assert_call) & ,test_description_t("invocation removal after undefining the ASSERTIONS macro", check_macro_removal) & - ]) - associate(substring_in_subject => index(subject(), test_description_substring) /= 0) - associate(substring_in_test_diagnosis => descriptions%contains_text(test_description_substring)) - associate(matching_descriptions => pack(descriptions, substring_in_subject .or. substring_in_test_diagnosis)) - test_results = matching_descriptions%run() - end associate - end associate - end associate - end associate + ] + test_descriptions = pack(test_descriptions, (index(subject(), test_description_substring) /= 0).or. test_descriptions%contains_text(test_description_substring)) + test_results = test_descriptions%run() end function diff --git a/test/modules/command_line_test_m.F90 b/test/modules/command_line_test_m.F90 index b8118aa1d..172cfedbd 100644 --- a/test/modules/command_line_test_m.F90 +++ b/test/modules/command_line_test_m.F90 @@ -7,6 +7,9 @@ module command_line_test_m !! Verify object pattern asbtract parent use julienne_m, only : & command_line_t & + ,GitHub_CI & + ,operator(.equalsExpected.) & + ,operator(.expect.) & ,string_t & ,test_description_substring & ,test_description_t & @@ -38,21 +41,13 @@ pure function subject() result(specimen) function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_description_t), allocatable :: test_descriptions(:) -#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - test_descriptions = [ & - test_description_t(string_t("flag_value() result is the value passed after a command-line flag"), check_flag_value) & - ,test_description_t(string_t("flag_value() result is an empty string if command-line flag value is missing"), check_flag_value_missing) & - ,test_description_t(string_t("flag_value() result is an empty string if command-line flag is missing"), check_flag_missing) & - ,test_description_t(string_t("argument_present() result is .false. if a command-line argument is missing"), check_argument_missing) & - ,test_description_t(string_t("argument_present() result is .true. if a command-line argument is present"), check_argument_present) & - ] -#else - ! Work around missing Fortran 2008 feature: associating a procedure actual argument with a procedure pointer dummy argument: + type(command_line_t) command_line +#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY procedure(diagnosis_function_i), pointer :: & - check_flag_value_ptr & + check_flag_value_ptr & ,check_flag_value_missing_ptr & - ,check_flag_missing_ptr & - ,check_argument_missing_ptr & + ,check_flag_missing_ptr & + ,check_argument_missing_ptr & ,check_argument_present_ptr check_flag_value_ptr => check_flag_value @@ -60,83 +55,85 @@ function results() result(test_results) check_flag_missing_ptr => check_flag_missing check_argument_missing_ptr => check_argument_missing check_argument_present_ptr => check_argument_present +#endif - test_descriptions = [ & - test_description_t(string_t("flag_value() result is the value passed after a command-line flag"), check_flag_value_ptr) & - ,test_description_t(string_t("flag_value() result is an empty string if command-line flag value is missing"), check_flag_value_missing_ptr) & - ,test_description_t(string_t("flag_value() result is an empty string if command-line flag is missing"), check_flag_missing_ptr) & - ,test_description_t(string_t("argument_present() result is .false. if a command-line argument is missing"), check_argument_missing_ptr) & - ,test_description_t(string_t("argument_present() result is .true. if a command-line argument is present"), check_argument_present_ptr) & - ] + skip_all_tests_if_running_github_ci: & + if (GitHub_CI()) then + test_descriptions = [ & + test_description_t(string_t("flag_value() result is the value passed after a command-line flag")) & + ,test_description_t(string_t("flag_value() result is an empty string if command-line flag value is missing")) & + ,test_description_t(string_t("flag_value() result is an empty string if command-line flag is missing")) & + ,test_description_t(string_t("argument_present() result is .false. if a command-line argument is missing")) & + ,test_description_t(string_t("argument_present() result is .true. if a command-line argument is present")) & + ] + print "(*(a))" & + ,new_line('') & + ,"----> Skipping the command_line_t tests in GitHub CI.", new_line('') & + ,"----> To test locally, append the following flags to the 'fpm test' command: -- --test command_line_t --type" & + ,new_line('') + else if (.not. command_line%argument_present(["--test"])) then ! skip the tests if not explicitly requested + test_descriptions = [ & + test_description_t(string_t("flag_value() result is the value passed after a command-line flag")) & + ,test_description_t(string_t("flag_value() result is an empty string if command-line flag value is missing")) & + ,test_description_t(string_t("flag_value() result is an empty string if command-line flag is missing")) & + ,test_description_t(string_t("argument_present() result is .false. if a command-line argument is missing")) & + ,test_description_t(string_t("argument_present() result is .true. if a command-line argument is present")) & + ] + print "(*(a))" & + ,new_line('') & + ,"-----> To test command_line_t, append the following to the 'fpm test' command: -- --test command_line_t --type" & + ,new_line('') + else ! run the tests +#if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + test_descriptions = [ & + test_description_t(string_t("flag_value() result is the value passed after a command-line flag"), check_flag_value) & + ,test_description_t(string_t("flag_value() result is an empty string if command-line flag value is missing"), check_flag_value_missing) & + ,test_description_t(string_t("flag_value() result is an empty string if command-line flag is missing"), check_flag_missing) & + ,test_description_t(string_t("argument_present() result is .false. if a command-line argument is missing"), check_argument_missing) & + ,test_description_t(string_t("argument_present() result is .true. if a command-line argument is present"), check_argument_present) & + ] +#else + test_descriptions = [ & + test_description_t(string_t("flag_value() result is the value passed after a command-line flag"), check_flag_value_ptr) & + ,test_description_t(string_t("flag_value() result is an empty string if command-line flag value is missing"), check_flag_value_missing_ptr) & + ,test_description_t(string_t("flag_value() result is an empty string if command-line flag is missing"), check_flag_missing_ptr) & + ,test_description_t(string_t("argument_present() result is .false. if a command-line argument is missing"), check_argument_missing_ptr) & + ,test_description_t(string_t("argument_present() result is .true. if a command-line argument is present"), check_argument_present_ptr) & + ] #endif - test_descriptions = pack(test_descriptions, & - index(subject(), test_description_substring) /= 0 .or. & - test_descriptions%contains_text(string_t(test_description_substring))) + end if skip_all_tests_if_running_github_ci + test_results = test_descriptions%run() end function function check_flag_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis type(command_line_t) command_line - character(len=*), parameter :: expected_flag_value = "command_line_t" - - associate(actual_flag_value => command_line%flag_value("--test")) - test_diagnosis = test_diagnosis_t( & - test_passed = expected_flag_value == actual_flag_value & - ,diagnostics_string = "expected " // expected_flag_value // ", actual " // actual_flag_value & - ) - end associate + test_diagnosis = command_line%flag_value("--test") .equalsExpected. "command_line_t" end function function check_flag_value_missing() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis type(command_line_t) command_line - character(len=*), parameter :: expected_flag_value = "" - - associate(actual_flag_value => command_line%flag_value("--type")) - test_diagnosis = test_diagnosis_t( & - test_passed = expected_flag_value == actual_flag_value & - ,diagnostics_string = "expected '" // expected_flag_value // "', actual '" // actual_flag_value // "'" & - ) - end associate + test_diagnosis = command_line%flag_value("--type") .equalsExpected. "" end function function check_flag_missing() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis type(command_line_t) command_line - character(len=*), parameter :: expected_flag_value = "" - - associate(actual_flag_value => command_line%flag_value("r@nd0m.Junk-H3R3")) - test_diagnosis = test_diagnosis_t( & - test_passed = expected_flag_value == actual_flag_value & - ,diagnostics_string = "expected '" // expected_flag_value // "', actual '" // actual_flag_value // "'" & - ) - end associate + test_diagnosis = command_line%flag_value("r@nd0m.Junk-H3R3") .equalsExpected. "" end function function check_argument_missing() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis type(command_line_t) command_line - character(len=*), parameter :: expected_flag_value = "" - - associate(argument_found => command_line%argument_present(["M1ss1ng-argUment"])) - test_diagnosis = test_diagnosis_t( & - test_passed = .not. argument_found & - ,diagnostics_string = "expected .false., actual .true." & - ) - end associate + test_diagnosis = .expect. (.not. command_line%argument_present(["M1ss1ng-argUment"])) end function function check_argument_present() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis type(command_line_t) command_line - - associate(argument_found => command_line%argument_present(["--type"])) - test_diagnosis = test_diagnosis_t( & - test_passed = argument_found & - ,diagnostics_string = "expected .true., actual .false." & - ) - end associate + test_diagnosis = .expect. command_line%argument_present(["--type"]) end function end module command_line_test_m diff --git a/test/modules/test_description_test_m.F90 b/test/modules/test_description_test_m.F90 index 5c4bf17c8..0f52b108c 100644 --- a/test/modules/test_description_test_m.F90 +++ b/test/modules/test_description_test_m.F90 @@ -33,44 +33,32 @@ pure function subject() result(specimen) function results() result(test_results) type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) #if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - associate(descriptions => & - [test_description_t("identical construction from string_t or character argument", check_constructors_match)] & - ) + test_descriptions = [ & + test_description_t("identical construction from string_t or character argument", check_constructors_match) & + ] #else ! Work around missing Fortran 2008 feature: associating a procedure actual argument with a procedure pointer dummy argument: procedure(diagnosis_function_i), pointer :: check_constructors_match_ptr - type(test_description_t), allocatable :: descriptions(:) check_constructors_match_ptr => check_constructors_match - descriptions = [ & + test_descriptions = [ & test_description_t("identical construction from string_t or character argument", check_constructors_match_ptr) & ] #endif -#ifndef __GFORTRAN__ - associate(substring_in_subject => index(subject(), test_description_substring) /= 0) - associate(substring_in_test_description => descriptions%contains_text(test_description_substring)) - associate(matching_descriptions => pack(descriptions, substring_in_subject .or. substring_in_test_description)) - test_results = matching_descriptions%run() - end associate - end associate - end associate - end associate - -#else block logical substring_in_subject logical, allocatable :: substring_in_test_description(:) type(test_description_t), allocatable :: matching_descriptions(:) substring_in_subject = index(subject(), test_description_substring) /= 0 - substring_in_test_description = descriptions%contains_text(test_description_substring) - matching_descriptions = pack(descriptions, substring_in_subject .or. substring_in_test_description) + substring_in_test_description = test_descriptions%contains_text(test_description_substring) + matching_descriptions = pack(test_descriptions, substring_in_subject .or. substring_in_test_description) test_results = matching_descriptions%run() end block -#endif end function diff --git a/test/modules/test_diagnosis_test_m.F90 b/test/modules/test_diagnosis_test_m.F90 index eec183c55..05c32e016 100644 --- a/test/modules/test_diagnosis_test_m.F90 +++ b/test/modules/test_diagnosis_test_m.F90 @@ -49,9 +49,10 @@ pure function subject() result(specimen) function results() result(test_results) type(test_result_t), allocatable :: test_results(:) + type(test_description_t), allocatable :: test_descriptions(:) #if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY - associate(descriptions => [ & + test_descriptions = [ & test_description_t("construction from the real expression 'x .approximates. y .within. tolerance'" , check_approximates_real) & ,test_description_t("construction from the real expression 'x .approximates. y .withinFraction. tolerance'" , check_approximates_real_fraction) & ,test_description_t("construction from the real expression 'x .approximates. y .withinPercentage. tolerance'" , check_approximates_real_percentage) & @@ -74,10 +75,9 @@ function results() result(test_results) ,test_description_t("construction from the integer expression '[i,j] .greaterThanOrEqualTo. k" , check_greater_than_or_equal_to_integer) & ,test_description_t("construction from the scalar test_diagnostics_t expression 't .and. u'" , check_and_with_scalar_operands) & ,test_description_t("construction from the vector test_diagnostics_t expressions 'i .equalsExpected. [j,k]'" , check_and_with_vector_operands) & - ] ) + ] #else ! Work around missing Fortran 2008 feature: associating a procedure actual argument with a procedure pointer dummy argument: - type(test_description_t), allocatable :: descriptions(:) procedure(diagnosis_function_i), pointer :: & check_approximates_real_ptr => check_approximates_real & ,check_approximates_real_fraction_ptr => check_approximates_real_fraction & @@ -102,7 +102,7 @@ function results() result(test_results) ,check_and_with_scalar_operands_ptr => check_and_with_scalar_operands & ,check_and_with_vector_operands_ptr => check_and_with_vector_operands - descriptions = [ & + test_descriptions = [ & test_description_t("construction from the real expression 'x .approximates. y .within. tolerance'" , check_approximates_real_ptr) & ,test_description_t("construction from the real expression 'x .approximates. y .withinFraction. tolerance'" , check_approximates_real_fraction_ptr) & ,test_description_t("construction from the real expression 'x .approximates. y .withinPercentage. tolerance'" , check_approximates_real_percentage_ptr) & @@ -128,27 +128,16 @@ function results() result(test_results) ] #endif -#ifndef __GFORTRAN__ - associate(substring_in_subject => index(subject(), test_description_substring) /= 0) - associate(substring_in_test_diagnosis => descriptions%contains_text(test_description_substring)) - associate(matching_descriptions => pack(descriptions, substring_in_subject .or. substring_in_test_diagnosis)) - test_results = matching_descriptions%run() - end associate - end associate - end associate - end associate -#else block logical substring_in_subject logical, allocatable :: substring_in_test_diagnosis(:) type(test_description_t), allocatable :: matching_descriptions(:) substring_in_subject = index(subject(), test_description_substring) /= 0 - substring_in_test_diagnosis = descriptions%contains_text(test_description_substring) - matching_descriptions = pack(descriptions, substring_in_subject .or. substring_in_test_diagnosis) + substring_in_test_diagnosis = test_descriptions%contains_text(test_description_substring) + matching_descriptions = pack(test_descriptions, substring_in_subject .or. substring_in_test_diagnosis) test_results = matching_descriptions%run() end block -#endif end function diff --git a/test/test-julienne_assert-intentional-failure.F90 b/test/test-julienne_assert-intentional-failure.F90 index 1b30dda14..e59ebd88f 100644 --- a/test/test-julienne_assert-intentional-failure.F90 +++ b/test/test-julienne_assert-intentional-failure.F90 @@ -5,22 +5,22 @@ program test_julienne_assert_intentional_failure !! Conditionally test an assertion that is hardwired to fail. - -#ifdef RUN_FALSE_ASSERTIONS - - use julienne_m, only : operator(.equalsExpected.), call_julienne_assert_ + use julienne_m, only : call_julienne_assert_, command_line_t, operator(.equalsExpected.) implicit none - print '(a)', new_line('') // 'Test julienne_assert intentional failure: ' // new_line('') - call_julienne_assert(1 .equalsExpected. 2) + associate(command_line => command_line_t()) + if (.not. command_line%argument_present([character(len=len("--help"))::"--help","-h"])) then +#ifdef RUN_FALSE_ASSERTIONS + print '(a)', new_line('') // 'Test julienne_assert intentional failure: ' // new_line('') + call_julienne_assert(1 .equalsExpected. 2) #else - - print * - print '(a)', 'Skipping the test in ' // __FILE__ // '.' - print '(a)', 'Add the following to your fpm command to test assertion failure: --flag "-DASSERTIONS -DRUN_FALSE_ASSERTIONS"' - print * - + print * + print '(a)', 'Skipping the test in ' // __FILE__ // '.' + print '(a)', 'Add the following to your fpm command to test assertion failure: --flag "-DASSERTIONS -DRUN_FALSE_ASSERTIONS"' + print * #endif + end if + end associate end program