fortran-julienne-3.6.2/0000775000175000017500000000000015151767003015175 5ustar alastairalastairfortran-julienne-3.6.2/app/0000775000175000017500000000000015151766762015770 5ustar alastairalastairfortran-julienne-3.6.2/app/scaffold.F900000664000175000017500000000630715151766762020037 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt program scaffold use julienne_m, only : command_line_t, file_t, test_suite_t implicit none type(command_line_t) command_line integer i if (help_requested()) call print_usage_info_and_stop #if (! __GNUC__) && (! NAGFOR) associate(subjects_file_name => command_line%flag_value("--json-file")) if (len(subjects_file_name) == 0) call print_usage_info_and_stop print '(*(a))', "Reading test subject information from " // subjects_file_name associate(test_suite => test_suite_t(file_t(subjects_file_name))) associate(path => command_line%flag_value("--suite-path")) print '(*(a))', "Writing test-suite scaffolding in " // path if (len(path) == 0) call print_usage_info_and_stop associate(driver => test_suite%driver_file()) call driver%write_lines(path // "/driver.f90") end associate associate(subjects => test_suite%test_subjects(), modules => test_suite%test_modules()) do i = 1, size(subjects) associate(stub => test_suite%stub_file(subjects(i))) call stub%write_lines(path // "/" // modules(i) // ".f90") end associate end do end associate end associate end associate end associate #else block character(len=:), allocatable :: path, subjects_file_name subjects_file_name = command_line%flag_value("--json-file") if (len(subjects_file_name) == 0) call print_usage_info_and_stop print '(*(a))', "Reading test subject information from " // subjects_file_name associate(test_suite => test_suite_t(file_t(subjects_file_name))) path = command_line%flag_value("--suite-path") if (len(path) == 0) call print_usage_info_and_stop print '(*(a))', "Writing test-suite scaffolding in " // path call test_suite%write_driver(path // "/driver.f90") associate(subjects => test_suite%test_subjects(), modules => test_suite%test_modules()) do i = 1, size(subjects) associate(stub => test_suite%stub_file(subjects(i))) call stub%write_lines(path // "/" // modules(i) // ".f90") end associate end do end associate end associate end block #endif contains logical function help_requested() type(command_line_t) command_line help_requested = command_line%argument_present([character(len=len("--help"))::"--help","-h"]) end function subroutine print_usage_info_and_stop character(len=*), parameter :: usage = & new_line('') // new_line('') // & 'Usage: fpm run scaffold -- [--json-file --suite-path ] | [--help] | -h]' // & new_line('') // new_line('') // & 'where square brackets ([]) denote optional arguments, a pipe (|) separates alternative arguments,' // new_line('') // & 'angular brackets (<>) denote a user-provided value, the --subjects string names a JSON file,' // new_line('') // & 'and the --path string names a directory for the new test-suite scaffold.' // new_line('') stop usage end subroutine end program scaffold fortran-julienne-3.6.2/ford.md0000664000175000017500000000177415151766762016475 0ustar alastairalastairproject: Julienne summary: A Fortran 2023 correctness-checking framework supporting expressive idioms for writing assertions and tests src_dir: src src_dir: example src_dir: app exclude_dir: doc output_dir: doc/html preprocess: true macro: FORD preprocessor: gfortran -E display: public protected private source: true graph: true md_extensions: markdown.extensions.toc coloured_edges: true sort: permission-alpha extra_mods: iso_fortran_env:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html iso_c_binding:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fC_005fBINDING.html#ISO_005fC_005fBINDING project_github: https://github.com/berkeleylab/inference-engine author: Berkeley Lab print_creation_date: true creation_date: %Y-%m-%d %H:%M %z project_github: https://github.com/berkeleylab/julienne project_download: https://github.com/berkeleylab/julienne/releases github: https://github.com/berkeleylab predocmark_alt: > predocmark: < docmark_alt: docmark: ! {!README.md!} fortran-julienne-3.6.2/src/0000775000175000017500000000000015151766762015777 5ustar alastairalastairfortran-julienne-3.6.2/src/julienne_m.F900000664000175000017500000000412115151766762020402 0ustar alastairalastair! 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_m !! Global aggregation of all public entities use julienne_assert_m, only : call_julienne_assert_, julienne_assert use julienne_bin_m, only : bin_t use julienne_command_line_m, only : command_line_t 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 & ,operator(.cat.) & ,operator(.csv.) & ,operator(.separatedBy.) & ! same as operator(.sv.) ,operator(.sv.) use julienne_test_description_m, only : test_description_t, filter, usher use julienne_test_diagnosis_m, only : & diagnosis_function_i & ,operator(//) & ,operator(.all.) & ,operator(.also.) & ,operator(.and.) & ,operator(.approximates.) & ,operator(.equalsExpected.) & ,operator(.expect.) & ,operator(.isAfter.) & ,operator(.isAtLeast.) & ,operator(.isAtMost.) & ,operator(.isBefore.) & ,operator(.lessThan.) & ,operator(.lessThanOrEqualTo.) & ! same as operator(.isAtMost.) ,operator(.greaterThan.) & ,operator(.greaterThanOrEqualTo.) & ! same as operator(.isAtLeast.) ,operator(.within.) & ,operator(.withinFraction.) & ,operator(.withinPercentage.) & ,passing_test & ,test_diagnosis_t use julienne_test_fixture_m, only : test_fixture_t use julienne_test_harness_m, only : test_harness_t use julienne_test_result_m, only : test_result_t use julienne_test_suite_m, only : test_suite_t use julienne_test_m, only : test_t #if JULIENNE_PARALLEL_CALLBACKS use julienne_multi_image_m, only: & julienne_this_image_interface, julienne_this_image & ,julienne_num_images_interface, julienne_num_images & ,julienne_sync_all_interface, julienne_sync_all & ,julienne_co_sum_integer_interface, julienne_co_sum_integer & ,julienne_error_stop_interface, julienne_error_stop #endif implicit none end module julienne_m fortran-julienne-3.6.2/src/julienne/0000775000175000017500000000000015151766762017610 5ustar alastairalastairfortran-julienne-3.6.2/src/julienne/julienne_test_suite_m.f900000664000175000017500000000450015151766762024524 0ustar alastairalastair! 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_suite_m use julienne_file_m, only : file_t use julienne_string_m, only : string_t implicit none private public :: test_suite_t type test_suite_t private type(string_t), allocatable :: test_subjects_(:) contains procedure driver_file procedure stub_file procedure test_subjects procedure test_modules procedure test_types procedure to_file procedure write_driver end type interface test_suite_t pure module function from_components(test_subjects) result(test_suite) implicit none type(string_t), intent(in) :: test_subjects(:) type(test_suite_t) test_suite end function pure module function from_file(file) result(test_suite) implicit none type(file_t), intent(in) :: file type(test_suite_t) test_suite end function end interface interface pure module function test_subjects(self) result(subjects) implicit none class(test_suite_t), intent(in) :: self type(string_t), allocatable :: subjects(:) end function pure module function test_modules(self) result(modules) implicit none class(test_suite_t), intent(in) :: self type(string_t), allocatable :: modules(:) end function pure module function test_types(self) result(types) implicit none class(test_suite_t), intent(in) :: self type(string_t), allocatable :: types(:) end function pure module function to_file(self) result(file) implicit none class(test_suite_t), intent(in) :: self type(file_t) file end function pure module function driver_file(self) result(file) implicit none class(test_suite_t), intent(in) :: self type(file_t) file end function pure module function stub_file(self, subject) result(file) implicit none class(test_suite_t), intent(in) :: self type(string_t), intent(in) :: subject type(file_t) file end function module subroutine write_driver(self, file_name) implicit none class(test_suite_t), intent(in) :: self character(len=*), intent(in) :: file_name end subroutine end interface end module julienne_test_suite_m fortran-julienne-3.6.2/src/julienne/julienne_command_line_m.f900000664000175000017500000000246015151766762024764 0ustar alastairalastair! 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_command_line_m !! return command line argument information implicit none private public :: command_line_t type command_line_t contains procedure, nopass :: argument_present procedure, nopass :: flag_value end type interface module function argument_present(acceptable_argument) result(found) implicit none !! result is .true. only if a command-line argument matches an element of this function's argument character(len=*), intent(in) :: acceptable_argument(:) !! sample list: [character(len=len()):: "--benchmark", "-b", "/benchmark", "/b"] !! where dashes support Linux/macOS, slashes support Windows, and must be replaced !! by the longest list element ("--benchmark" above) logical found end function module function flag_value(flag) !! result = { the value passed immediately after a command-line flag if the flag is present or !! { an empty string otherwise. implicit none character(len=*), intent(in) :: flag character(len=:), allocatable :: flag_value end function end interface end module fortran-julienne-3.6.2/src/julienne/julienne_file_s.F900000664000175000017500000000645315151766762023232 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" submodule(julienne_file_m) julienne_file_s use iso_fortran_env, only : iostat_end, iostat_eor, output_unit use assert_m implicit none contains module procedure lines my_lines = self%lines_ end procedure module procedure write_to_output_unit integer l call_assert(allocated(self%lines_)) do l = 1, size(self%lines_) write(output_unit, '(a)') self%lines_(l)%string() end do end procedure module procedure write_to_character_file_name integer file_unit, l logical file_open call_assert(allocated(self%lines_)) inquire(file=file_name, opened=file_open, number=file_unit) if (.not. file_open) open(newunit=file_unit, file=file_name, form='formatted', status='unknown', action='write') do l = 1, size(self%lines_) write(file_unit, '(a)') self%lines_(l)%string() end do end procedure module procedure write_to_string_file_name call self%write_to_character_file_name(file_name%string()) end procedure module procedure from_lines allocate(file_object%lines_, source=lines) end procedure module procedure from_file_with_character_name file_object = from_file_with_string_name(string_t(file_name)) end procedure module procedure from_file_with_string_name integer io_status, file_unit, line_num character(len=:), allocatable :: line integer, parameter :: max_message_length=128 character(len=max_message_length) error_message integer, allocatable :: lengths(:) open(newunit=file_unit, file=file_name%string(), form='formatted', status='old') lengths = line_lengths(file_unit) associate(num_lines => size(lengths)) allocate(file_object%lines_(num_lines)) do line_num = 1, num_lines allocate(character(len=lengths(line_num)) :: line) read(file_unit, '(a)') line file_object%lines_(line_num) = string_t(line) deallocate(line) end do end associate close(file_unit) contains function line_count(file_unit) result(num_lines) integer, intent(in) :: file_unit integer num_lines rewind(file_unit) num_lines = 0 do read(file_unit, *, iostat=io_status) if (io_status==iostat_end) exit num_lines = num_lines + 1 end do rewind(file_unit) end function function line_lengths(file_unit) result(lengths) integer, intent(in) :: file_unit integer, allocatable :: lengths(:) integer io_status, l character(len=1) c associate(num_lines => line_count(file_unit)) allocate(lengths(num_lines), source = 0) rewind(file_unit) do l = 1, num_lines do read(file_unit, '(a)', advance='no', iostat=io_status, iomsg=error_message) c associate(eliminate_unused_variable_warning => c) ! eliminate NAG compiler "variable c set but never referenced" warning end associate if (io_status==iostat_eor .or. io_status==iostat_end) exit lengths(l) = lengths(l) + 1 end do end do rewind(file_unit) end associate end function end procedure end submodule julienne_file_s fortran-julienne-3.6.2/src/julienne/julienne_assert_m.f900000664000175000017500000000546515151766762023650 0ustar alastairalastair! 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_assert_m !! Define interfaces for writing assertions use julienne_test_diagnosis_m, only : test_diagnosis_t implicit none private public :: call_julienne_assert_ public :: julienne_assert interface julienne_assert module procedure idiomatic_assert module procedure logical_assert end interface interface call_julienne_assert_ pure module subroutine idiomatic_assert(test_diagnosis, file, line, description) !! Error terminate if `test_diagnosis%test_passed() == .false.`, in which !! case the stop code contains !! !! 1. The description argument if present and if called via !! `julienne_assert; otherwise, a copy of the invoking statement, !! 2. The value of `test_diagnosis%diagnostics_string(),`, !! 3. The file name if present, and !! 4. The line number if present. !! !! Most compilers write the stop code to `error_unit`. !! !! Usage !! ----- !! !! `call julienne_assert(.all. (["a","b","c"] .isBefore. "efg"))` !! `call_julienne_assert(.all. (["a","b","c"] .isBefore. "efg"))` !! !! The first line above guarantees execution, whereas the second ensures !! removal when compiled without `-DASSERTIONS`. When invoked via macro, !! the second line also causes the automatic insertion of items 1-4 above. implicit none type(test_diagnosis_t), intent(in) :: test_diagnosis character(len=*), intent(in), optional :: file, description integer, intent(in), optional :: line end subroutine pure module subroutine logical_assert(assertion, file, line, description) !! Error terminate if `assertion == .false.`, in which case the stop code !! contains !! !! - The description argument if present and if called via !! `julienne_assert; otherwise, a copy of the invoking statement, !! - The file name if present, and !! - The line number if present. !! !! Most compilers write the stop code to `error_unit`. !! !! !! Usage !! ----- !! !! `call julienne_assert(associated(A))` !! `call_julienne_assert(associated(A))` !! !! The first line above guarantees execution, whereas the second ensures !! removal when compiled without `-DASSERTIONS`. When invoked via macro, !! the second line also causes the automatic insertion of items 1-4 above. implicit none logical, intent(in) :: assertion character(len=*), intent(in), optional :: file, description integer, intent(in), optional :: line end subroutine end interface end module julienne_assert_m fortran-julienne-3.6.2/src/julienne/julienne_test_description_s.F900000664000175000017500000001012215151766762025661 0ustar alastairalastair! Copyright (c) 20242-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt #include "julienne-assert-macros.h" #include "assert_macros.h" #include "language-support.F90" submodule(julienne_test_description_m) julienne_test_description_s use assert_m use julienne_assert_m, only : call_julienne_assert_ use julienne_command_line_m, only : command_line_t use iso_c_binding, only: c_f_procpointer implicit none contains module procedure construct_from_characters test_description%description_ = description if (present(diagnosis_function)) test_description%diagnosis_function_ => diagnosis_function call_assert(allocated(test_description%description_)) end procedure module procedure construct_from_characters_funloc test_description%description_ = description call c_f_procpointer(diagnosis_function, test_description%diagnosis_function_) call_assert(allocated(test_description%description_)) end procedure module procedure construct_from_characters_usher test_description%description_ = description test_description%diagnosis_function_ => diagnosis_function%ptr call_assert(allocated(test_description%description_)) end procedure module procedure construct_from_string test_description%description_ = description if (present(diagnosis_function)) test_description%diagnosis_function_ => diagnosis_function call_assert(allocated(test_description%description_)) end procedure module procedure construct_from_string_funloc test_description%description_ = description call c_f_procpointer(diagnosis_function, test_description%diagnosis_function_) call_assert(allocated(test_description%description_)) end procedure module procedure construct_from_string_usher test_description%description_ = description test_description%diagnosis_function_ => diagnosis_function%ptr call_assert(allocated(test_description%description_)) end procedure module procedure run call_assert(allocated(self%description_)) if (associated(self%diagnosis_function_)) then test_result = test_result_t(self%description_, self%diagnosis_function_()) else test_result = test_result_t(self%description_) end if end procedure module procedure contains_string_t call_assert(allocated(self%description_)) match = index(self%description_, substring%string()) /= 0 end procedure module procedure contains_characters call_assert(allocated(self%description_)) match = index(self%description_, substring) /= 0 end procedure module procedure equals call_assert(allocated(lhs%description_) .and. allocated(rhs%description_)) lhs_eq_rhs = (lhs%description_ == rhs%description_) .and. & ( associated(lhs%diagnosis_function_, rhs%diagnosis_function_) .or. & ( .not. associated(lhs%diagnosis_function_) .and. .not. associated(rhs%diagnosis_function_) ) ) end procedure module procedure filter type(command_line_t) command_line #if defined(__flang__) associate(search_string => command_line%flag_value("--contains")) filtered_test_descriptions = & pack( array = test_descriptions & ,mask = index(subject, search_string) /= 0 & ! subject contains search_string .or. test_descriptions%contains_text(search_string) & ! test_description%description_ contains search_string ) end associate #else block character(len=:), allocatable :: search_string search_string = command_line%flag_value("--contains") filtered_test_descriptions = & pack( array = test_descriptions & ,mask = index(subject, search_string) /= 0 & ! subject contains search_string .or. test_descriptions%contains_text(search_string) & ! test_description%description_ contains search_string ) end block #endif end procedure end submodule julienne_test_description_s fortran-julienne-3.6.2/src/julienne/julienne_test_result_s.F900000664000175000017500000000777715151766762024702 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt #include "julienne-assert-macros.h" #include "language-support.F90" submodule(julienne_test_result_m) julienne_test_result_s #if ASSERTIONS use julienne_assert_m, only : call_julienne_assert_ #endif use julienne_multi_image_m, only : internal_this_image, internal_num_images, internal_sync_all, internal_co_sum_integer implicit none contains module procedure construct_from_string test_result%description_ = description if (present(diagnosis)) test_result%diagnosis_ = diagnosis end procedure module procedure construct_from_character test_result%description_ = description if (present(diagnosis)) test_result%diagnosis_ = diagnosis end procedure #if HAVE_MULTI_IMAGE_SUPPORT module procedure co_characterize logical i_passed integer, parameter :: skips=1, passes=2 integer tally(skips:passes) character(len=*), parameter :: indent = " " associate(i_skipped => .not. allocated(self%diagnosis_)) if (i_skipped) then i_passed = .false. else i_passed = self%diagnosis_%test_passed() end if tally = [merge(1,0,i_skipped), merge(1,0,i_passed)] call internal_co_sum_integer(tally) associate(me => internal_this_image(), images => internal_num_images(), & images_skipped => tally(skips), images_passed => tally(passes)) call_julienne_assert(any(images_skipped == [0,images])) if (i_skipped) then if (me==1) print '(a)', indent // "SKIPS on " // trim(self%description_%string()) // "." else if (images_passed < images .and. i_passed) then ! a failure on any image becomes a failure on all images self%diagnosis_ = test_diagnosis_t(test_passed=.false., diagnostics_string="peer image failure") end if if (me==1) print '(a)', indent // merge("passes on ", "FAILS on ", self%diagnosis_%test_passed()) // trim(self%description_%string()) // "." #if ! ASYNCHRONOUS_DIAGNOSTICS call internal_sync_all ! ensure image 1 prints test outcome before any failure diagnostics print #endif if (.not. i_passed) then associate(image => string_t(me)) print '(a)', indent // indent // "diagnostics on image " // image%string() // ": " // self%diagnosis_%diagnostics_string() end associate end if #if ! ASYNCHRONOUS_DIAGNOSTICS call internal_sync_all ! ensure all images print failure diagnostics, if any, for a given test before any image moves on to the next test #endif end if end associate end associate end procedure #else module procedure co_characterize character(len=*), parameter :: indent = " " if (.not. allocated(self%diagnosis_)) then print '(a)', indent // "SKIPS on " // trim(self%description_%string()) // "." else associate(test_passed => self%diagnosis_%test_passed()) print '(a)', indent // merge("passes on ", "FAILS on ", test_passed) // trim(self%description_%string()) // "." if (.not. test_passed) print '(a)', indent //indent // "diagnostics: " // self%diagnosis_%diagnostics_string() end associate end if end procedure #endif module procedure passed if (.not. allocated(self%diagnosis_)) then test_passed = .false. else test_passed = self%diagnosis_%test_passed() end if end procedure module procedure skipped test_skipped = .not. allocated(self%diagnosis_) end procedure module procedure description_contains_string substring_found = self%description_contains_characters(substring%string()) end procedure module procedure description_contains_characters substring_found = index(self%description_%string(), substring) /= 0 end procedure end submodule julienne_test_result_s fortran-julienne-3.6.2/src/julienne/julienne_assert_s.f900000664000175000017500000000214515151766762023646 0ustar alastairalastair! 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_assert_m) julienne_assert_s use assert_m, only : assert_always implicit none contains module procedure idiomatic_assert character(len=:), allocatable :: description_ if (.not. test_diagnosis%test_passed()) then if (present(description)) then description_ = new_line('') // description // new_line('') // test_diagnosis%diagnostics_string() else description_ = new_line('') // test_diagnosis%diagnostics_string() end if call assert_always(.false., description_, file, line) end if end procedure module procedure logical_assert character(len=:), allocatable :: description_ if (.not. assertion) then if (present(description)) then description_ = new_line('') // description // new_line('') else description_ = new_line('') end if call assert_always(.false., description_ , file, line) end if end procedure end submodule julienne_assert_s fortran-julienne-3.6.2/src/julienne/julienne_test_result_m.f900000664000175000017500000000675315151766762024725 0ustar alastairalastair! 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_result_m !! Define an abstraction for describing test results the test description and, !! if the test was not skipped, then also a test diagnosis. use julienne_string_m, only : string_t use julienne_test_diagnosis_m, only : test_diagnosis_t implicit none private public :: test_result_t type test_result_t !! Encapsulate a test-description string and optionally a test diagnosis. !! This type is similar to test_description_t and test_diagnosis_t type but !! 1. Doesn't need the former's procedure(diagnosis_function_i) component and !! 2. Allocates an instance of the latter if and only if the test wasn't skipped. private type(string_t) :: description_ type(test_diagnosis_t), allocatable :: diagnosis_ contains procedure :: co_characterize procedure :: passed procedure :: skipped generic :: description_contains => description_contains_string, description_contains_characters procedure, private :: description_contains_string, description_contains_characters end type interface test_result_t elemental module function construct_from_string(description, diagnosis) result(test_result) !! The result is a test_result_t object with the components defined by the dummy arguments implicit none type(string_t), intent(in) :: description type(test_diagnosis_t), intent(in), optional :: diagnosis type(test_result_t) test_result end function elemental module function construct_from_character(description, diagnosis) result(test_result) !! The result is a test_result_t object with the components defined by the dummy arguments implicit none character(len=*), intent(in) :: description type(test_diagnosis_t), intent(in), optional :: diagnosis type(test_result_t) test_result end function end interface interface module subroutine co_characterize(self) !! Print a description of the test, its outcome, and diagnostic information if the test fails implicit none class(test_result_t), intent(inout) :: self end subroutine impure elemental module function passed(self) result(test_passed) !! The result is true if and only if the test passed on all images implicit none class(test_result_t), intent(in) :: self logical test_passed end function impure elemental module function skipped(self) result(test_skipped) !! The result is true if and only if the test result contains no diagnosis on any image implicit none class(test_result_t), intent(in) :: self logical test_skipped end function elemental module function description_contains_string(self, substring) result(substring_found) !! The result is true if and only if the test description contains the substring implicit none class(test_result_t), intent(in) :: self type(string_t), intent(in) :: substring logical substring_found end function elemental module function description_contains_characters(self, substring) result(substring_found) !! The result is true if and only if the test description contains the substring implicit none class(test_result_t), intent(in) :: self character(len=*), intent(in) :: substring logical substring_found end function end interface end module julienne_test_result_m fortran-julienne-3.6.2/src/julienne/julienne_formats_s.F900000664000175000017500000000245715151766762023766 0ustar alastairalastair! 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_formats_m) julienne_formats_s !! Construct separated-value formats implicit none contains module procedure separated_values character(len=*), parameter :: prefix = "(*(G0,:,'" character(len=*), parameter :: double_prefix = "(*(G25.20,:,'" character(len=*), parameter :: complex_prefix = "(*('(',G0,',',G0,')',:,'" character(len=*), parameter :: suffix = "'))" select rank(mold) rank(1) select type(mold) type is(complex) format_string = complex_prefix // separator // suffix type is(double precision) format_string = double_prefix // separator // "'))" type is(real) format_string = prefix // separator // suffix type is(integer) format_string = prefix // separator // suffix type is(character(len=*)) format_string = prefix // separator // suffix class default error stop "format_s separated_values: unsupported type" end select rank default error stop "formats_s separated_values: unsupported rank" end select end procedure end submodule julienne_formats_s fortran-julienne-3.6.2/src/julienne/julienne_file_m.f900000664000175000017500000000373215151766762023261 0ustar alastairalastair! 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_file_m !! A representation of a file as an object use julienne_string_m, only : string_t private public :: file_t type file_t private type(string_t), allocatable :: lines_(:) contains procedure :: lines generic :: write_lines => write_to_output_unit, write_to_character_file_name, write_to_string_file_name procedure, private :: write_to_output_unit, write_to_character_file_name, write_to_string_file_name end type interface file_t module function from_file_with_string_name(file_name) result(file_object) implicit none type(string_t), intent(in) :: file_name type(file_t) file_object end function module function from_file_with_character_name(file_name) result(file_object) implicit none character(len=*), intent(in) :: file_name type(file_t) file_object end function pure module function from_lines(lines) result(file_object) implicit none type(string_t), intent(in) :: lines(:) type(file_t) file_object end function end interface interface pure module function lines(self) result(my_lines) implicit none class(file_t), intent(in) :: self type(string_t), allocatable :: my_lines(:) end function module subroutine write_to_output_unit(self) implicit none class(file_t), intent(in) :: self end subroutine impure elemental module subroutine write_to_string_file_name(self, file_name) implicit none class(file_t), intent(in) :: self type(string_t), intent(in) :: file_name end subroutine impure elemental module subroutine write_to_character_file_name(self, file_name) implicit none class(file_t), intent(in) :: self character(len=*), intent(in) :: file_name end subroutine end interface end module julienne_file_m fortran-julienne-3.6.2/src/julienne/julienne_github_ci_s.f900000664000175000017500000000117615151766762024305 0ustar alastairalastair! 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_github_ci_m) julienne_github_ci_s implicit none contains module procedure GitHub_CI integer name_length character(len=:), allocatable :: CI call get_environment_variable("CI", length=name_length) if (name_length==0) then GitHub_CI = .false. else allocate(character(len=name_length):: CI) call get_environment_variable("CI", value=CI) GitHub_CI = merge(.true., .false., CI=="true") end if end procedure end submodule fortran-julienne-3.6.2/src/julienne/julienne_test_harness_m.f900000664000175000017500000000254715151766762025047 0ustar alastairalastair! 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_mfortran-julienne-3.6.2/src/julienne/julienne_command_line_s.f900000664000175000017500000000345115151766762024773 0ustar alastairalastair! 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_command_line_m) julienne_command_line_s implicit none contains module procedure argument_present !! list of acceptable arguments !! sample list: [character(len=len(longest_argument)):: "--benchmark", "-b", "/benchmark", "/b"] !! where dashes support Linux/macOS and slashes support Windows integer :: i, argnum, arglen !! loop counter, argument position, argument length character(len=32) arg !! argument position !! acceptable argument lengths (used to preclude extraneous trailing characters) associate(acceptable_length => [(len(trim(acceptable_argument(i))), i = 1, size(acceptable_argument))]) do argnum = 1,command_argument_count() call get_command_argument(argnum, arg, arglen) if (any( & [(arg==acceptable_argument(i) .and. arglen==acceptable_length(i), i = 1, size(acceptable_argument))] & )) then found = .true. return end if end do found = .false. end associate end procedure module procedure flag_value integer argnum, arglen, flag_value_length character(len=:), allocatable :: arg do argnum = 1,command_argument_count()-1 call get_command_argument(argnum, length=arglen) allocate(character(len=arglen) :: arg) call get_command_argument(argnum, arg) if (arg==flag) then call get_command_argument(argnum+1, length=flag_value_length) allocate(character(len=flag_value_length) :: flag_value) call get_command_argument(argnum+1, flag_value) return end if deallocate(arg) end do flag_value="" end procedure end submodule fortran-julienne-3.6.2/src/julienne/julienne_test_diagnosis_s.F900000664000175000017500000006100315151766762025322 0ustar alastairalastair! 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" #include "assert_macros.h" submodule(julienne_test_diagnosis_m) julienne_test_diagnosis_s use assert_m use julienne_string_m, only : operator(.cat.) use iso_c_binding, only : c_associated, c_intptr_t implicit none contains module procedure passing_test test_diagnosis%test_passed_ = .true. test_diagnosis%diagnostics_string_ = "" end procedure module procedure assign_logical lhs%test_passed_ = rhs lhs%diagnostics_string_ = "" end procedure module procedure append_string_if_test_failed if (lhs%test_passed_) then lhs_cat_rhs = lhs else lhs_cat_rhs = test_diagnosis_t(lhs%test_passed_, lhs%diagnostics_string_ // rhs) end if end procedure module procedure append_character_if_test_failed if (lhs%test_passed_) then lhs_cat_rhs = lhs else lhs_cat_rhs = test_diagnosis_t(lhs%test_passed_, lhs%diagnostics_string_ // rhs) end if end procedure module procedure also_DD diagnosis = .all. ([lhs,rhs]) end procedure module procedure also_LD diagnosis = .all. ([.expect.(lhs),rhs]) end procedure module procedure also_DL diagnosis = .all. ([lhs,.expect.(rhs)]) end procedure #ifndef __GFORTRAN__ module procedure aggregate_diagnosis character(len=*), parameter :: new_line_indent = new_line('') // " " select rank(diagnoses) rank(0) diagnosis = diagnoses rank(1) diagnosis = aggregate_vector_diagnosis(diagnoses) rank(2) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(3) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(4) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(5) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(6) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(7) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(8) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(9) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(10) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(11) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(12) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(13) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(14) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank(15) diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) rank default associate(diagnoses_rank => string_t(rank(diagnoses))) error stop "aggregate_diagnosis (julienne_test_diagnosis_s): rank " // diagnoses_rank%string() // " unspported" end associate end select contains pure function aggregate_vector_diagnosis(diagnoses) result(diagnosis) type(test_diagnosis_t), intent(in) :: diagnoses(:) type(test_diagnosis_t) diagnosis character(len=*), parameter :: new_line_indent = new_line('') // " " type(string_t), allocatable :: array(:) integer i allocate(array(size(diagnoses))) do i = 1, size(diagnoses) associate( str => diagnoses(i)%diagnostics_string_ ) if (len(str) == 0) then array(i) = str else if (str(1:1) == new_line('')) then ! don't prepend a another newline if the string already begins with one array(i) = str else array(i) = string_t(new_line_indent // str) end if end associate end do diagnosis = test_diagnosis_t( & test_passed = all(diagnoses%test_passed_) & ,diagnostics_string = .cat. pack( & array = array & ,mask = .not. diagnoses%test_passed_ & ) ) end function end procedure #else module procedure aggregate_scalar_diagnosis diagnosis = diagnoses end procedure module procedure aggregate_vector_diagnosis character(len=*), parameter :: new_line_indent = new_line('') // " " type(string_t), allocatable :: array(:) integer i allocate(array(size(diagnoses))) do i = 1, size(diagnoses) associate( str => diagnoses(i)%diagnostics_string_ ) if (len(str) == 0) then array(i) = str else if (str(1:1) == new_line('')) then ! don't prepend a another newline if the string already begins with one array(i) = str else array(i) = string_t(new_line_indent // str) end if end associate end do diagnosis = test_diagnosis_t( & test_passed = all(diagnoses%test_passed_) & ,diagnostics_string = .cat. pack( & array = array & ,mask = .not. diagnoses%test_passed_ & ) ) end procedure module procedure aggregate_rank2_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank3_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank4_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank5_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank6_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank7_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank8_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank9_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank10_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank11_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank12_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank13_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank14_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure module procedure aggregate_rank15_diagnosis diagnosis = aggregate_vector_diagnosis(reshape(diagnoses, shape=[size(diagnoses)])) end procedure #endif module procedure approximates_real operands = operands_t(actual, expected) end procedure module procedure approximates_double_precision #if HAVE_DERIVED_TYPE_KIND_PARAMETERS operands = operands_t(double_precision)(actual, expected) #else operands = double_precision_operands_t(actual, expected) #endif end procedure module procedure alphabetical_character_vs_character if (lhs < rhs) then test_diagnosis = test_diagnosis_t(.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(.false., diagnostics_string = rhs //" is before " // lhs // " alphabetically.") end if end procedure module procedure alphabetical_string_vs_string if (lhs%string() < rhs%string()) then test_diagnosis = test_diagnosis_t(.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(.false., diagnostics_string = lhs //" is before " // rhs // " alphabetically.") end if end procedure module procedure alphabetical_character_vs_string if (lhs < rhs%string()) then test_diagnosis = test_diagnosis_t(.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(.false., diagnostics_string = lhs //" is before " // rhs // " alphabetically.") end if end procedure module procedure alphabetical_string_vs_character if (lhs%string() < rhs) then test_diagnosis = test_diagnosis_t(.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(.false., diagnostics_string = lhs //" is before " // rhs // " alphabetically.") end if end procedure module procedure reverse_alphabetical_character_vs_character test_diagnosis = rhs .isBefore. lhs end procedure module procedure reverse_alphabetical_string_vs_string test_diagnosis = rhs .isBefore. lhs end procedure module procedure reverse_alphabetical_character_vs_string test_diagnosis = rhs .isBefore. lhs end procedure module procedure reverse_alphabetical_string_vs_character 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_c_ptr if (c_associated(actual, expected) .or. (.not. c_associated(actual) .and. .not. c_associated(expected))) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else block integer(c_intptr_t), parameter :: mold = 0_c_intptr_t character(len=18) :: str_actual, str_expect associate(actual_c_loc => transfer(actual, mold), expect_c_loc => transfer(expected, mold)) write(str_actual, '(A2,Z16.16)') '0x',actual_c_loc write(str_expect, '(A2,Z16.16)') '0x',expect_c_loc test_diagnosis = test_diagnosis_t( & test_passed = .false. & ,diagnostics_string = "expected " // str_expect // "; actual value is " // str_actual & ) end associate end block end if end procedure module procedure equals_expected_logical if (actual .EQV. expected) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "expected " // string_t(expected) // "; actual value is " // string_t(actual) & ) end if end procedure module procedure equals_expected_integer if (actual == expected) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "expected " // string_t(expected) // "; actual value is " // string_t(actual) & ) end if end procedure module procedure equals_expected_int64 if (actual == expected) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "expected " // string_t(expected) // "; actual value is " // string_t(actual) & ) end if end procedure module procedure equals_expected_character if (actual == expected) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "expected '" // expected // "'; actual value is '" // actual //"'" & ) end if end procedure module procedure equals_expected_character_vs_string if (actual == expected) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "expected '" // expected // "'; actual value is '" // actual //"'" & ) end if end procedure module procedure equals_expected_string if (actual == expected) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "expected '" // expected // "'; actual value is '" // actual //"'" & ) end if end procedure module procedure equals_expected_string_vs_character if (actual == expected) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "expected '" // expected // "'; actual value is '" // actual //"'" & ) end if end procedure module procedure less_than_real if (actual < expected_ceiling) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be less than " // string_t(expected_ceiling) & ) end if end procedure module procedure less_than_double if (actual < expected_ceiling) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be less than " // string_t(expected_ceiling) & ) end if end procedure module procedure less_than_integer if (actual < expected_ceiling) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be less than " // string_t(expected_ceiling) & ) end if end procedure module procedure less_than_int64 if (actual < expected_ceiling) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be less than " // string_t(expected_ceiling) & ) end if end procedure module procedure less_than_or_equal_to_integer if (actual <= expected_max) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be less than or equal to " // string_t(expected_max) & ) end if end procedure module procedure less_than_or_equal_to_int64 if (actual <= expected_max) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be less than or equal to " // string_t(expected_max) & ) end if end procedure module procedure less_than_or_equal_to_real if (actual <= expected_max) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be less than or equal to " // string_t(expected_max) & ) end if end procedure module procedure less_than_or_equal_to_double_precision if (actual <= expected_max) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be less than or equal to " // string_t(expected_max) & ) end if end procedure module procedure greater_than_or_equal_to_integer if (actual >= expected_min) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be greater than or equal to " // string_t(expected_min) & ) end if end procedure module procedure greater_than_or_equal_to_int64 if (actual >= expected_min) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be greater than or equal to " // string_t(expected_min) & ) end if end procedure module procedure greater_than_or_equal_to_real if (actual >= expected_min) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be greater than or equal to " // string_t(expected_min) & ) end if end procedure module procedure greater_than_or_equal_to_double_precision if (actual >= expected_min) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be greater than or equal to " // string_t(expected_min) & ) end if end procedure module procedure greater_than_real if (actual > expected_floor) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be greater than " // string_t(expected_floor) & ) end if end procedure module procedure greater_than_double if (actual > expected_floor) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be greater than " // string_t(expected_floor) & ) end if end procedure module procedure greater_than_integer if (actual > expected_floor) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be greater than " // string_t(expected_floor) & ) end if end procedure module procedure greater_than_int64 if (actual > expected_floor) then test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed = .false. & ,diagnostics_string = "The value " // string_t(actual) // " was expected to be greater than " // string_t(expected_floor) & ) end if end procedure module procedure within_real if (abs(operands%actual - operands%expected) <= tolerance) then ! We use <= to allow for tolerance=0, which could never be satisfied if we used < instead: test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed=.false. & ,diagnostics_string = "expected " // string_t(operands%expected) & // " within a tolerance of " // string_t(tolerance) & // "; actual value is " // string_t(operands%actual) & ) end if end procedure module procedure within_real_fraction if (abs(operands%actual - operands%expected) <= abs(fractional_tolerance*operands%expected)) then ! We use <= to allow for fractional_tolerance=0, which could never be satisfied if we used < instead: test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed=.false. & ,diagnostics_string = "expected " // string_t(operands%expected) & // " within a fractional tolerance of " // string_t(fractional_tolerance) & // "; actual value is " // string_t(operands%actual) & ) end if end procedure module procedure within_real_percentage if (abs(operands%actual - operands%expected) <= abs(operands%expected*percentage_tolerance/1D02)) then ! We use <= to allow for fractional_tolerance=0, which could never be satisfied if we used < instead: test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed=.false. & ,diagnostics_string = "expected " // string_t(operands%expected) & // " within a tolerance of " // string_t(percentage_tolerance) // " percent;" & // " actual value is " // string_t(operands%actual) & ) end if end procedure module procedure within_double_precision if (abs(operands%actual - operands%expected) <= tolerance) then ! We use <= to allow for tolerance=0, which could never be satisfied if we used < instead: test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed=.false. & ,diagnostics_string = "expected " // string_t(operands%expected) & // " within a tolerance of " // string_t(tolerance) & // "; actual value is " // string_t(operands%actual) & ) end if end procedure module procedure within_double_precision_fraction if (abs(operands%actual - operands%expected) <= abs(fractional_tolerance*operands%expected)) then ! We use <= to allow for tolerance=0, which could never be satisfied if we used < instead: test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed=.false. & ,diagnostics_string = "expected " // string_t(operands%expected) & // " within a fractional tolerance of " // string_t(fractional_tolerance) & // "; actual value is " // string_t(operands%actual) & ) end if end procedure module procedure within_double_precision_percentage if (abs((operands%actual - operands%expected)) <= abs(operands%expected*percentage_tolerance/1D02)) then ! Using <= above supports the tolerance=0 use case test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") else test_diagnosis = test_diagnosis_t(test_passed=.false. & ,diagnostics_string = "expected " // string_t(operands%expected) & // " within a tolerance of " // string_t(percentage_tolerance) // " percent;" & // " actual value is " // string_t(operands%actual) & ) end if end procedure module procedure construct_from_string_t test_diagnosis%test_passed_ = test_passed test_diagnosis%diagnostics_string_ = diagnostics_string end procedure module procedure construct_from_character test_diagnosis%test_passed_ = test_passed test_diagnosis%diagnostics_string_ = diagnostics_string end procedure module procedure copy_construct_from_string_t test_diagnosis = diagnosis // diagnostics_string end procedure module procedure copy_construct_from_character if (present(diagnostics_string)) then test_diagnosis = diagnosis // diagnostics_string else test_diagnosis = diagnosis end if end procedure module procedure test_passed passed = self%test_passed_ end procedure module procedure diagnostics_string call_assert(allocated(self%diagnostics_string_)) string = self%diagnostics_string_ end procedure end submodule julienne_test_diagnosis_s fortran-julienne-3.6.2/src/julienne/julienne_multi_image_m.F900000664000175000017500000000545615151766762024603 0ustar alastairalastair! 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_multi_image_m !! Define interfaces for supporting multi-image execution implicit none public :: internal_this_image, internal_num_images public :: internal_co_sum_integer public :: internal_error_stop interface module function internal_this_image() result(this_image_id) implicit none integer :: this_image_id end function module function internal_num_images() result(image_count) implicit none integer :: image_count end function module subroutine internal_sync_all() implicit none end subroutine module subroutine internal_co_sum_integer(a, result_image) implicit none integer, intent(inout), target :: a(:) integer, intent(in), optional :: result_image end subroutine module subroutine internal_error_stop(stop_code_char) implicit none character(len=*), intent(in) :: stop_code_char end subroutine end interface #if JULIENNE_PARALLEL_CALLBACKS public :: julienne_this_image_interface, julienne_this_image public :: julienne_num_images_interface, julienne_num_images public :: julienne_sync_all_interface, julienne_sync_all public :: julienne_co_sum_integer_interface, julienne_co_sum_integer public :: julienne_error_stop_interface, julienne_error_stop abstract interface function julienne_this_image_interface() result(this_image_id) implicit none integer :: this_image_id end function end interface procedure(julienne_this_image_interface), pointer :: julienne_this_image abstract interface function julienne_num_images_interface() result(image_count) implicit none integer :: image_count end function end interface procedure(julienne_num_images_interface), pointer :: julienne_num_images abstract interface subroutine julienne_sync_all_interface() implicit none end subroutine end interface procedure(julienne_sync_all_interface), pointer :: julienne_sync_all abstract interface subroutine julienne_co_sum_integer_interface(a, result_image) implicit none integer, intent(inout), target :: a(:) integer, intent(in), optional :: result_image end subroutine end interface procedure(julienne_co_sum_integer_interface), pointer :: julienne_co_sum_integer abstract interface subroutine julienne_error_stop_interface(stop_code_char) implicit none character(len=*), intent(in) :: stop_code_char end subroutine end interface procedure(julienne_error_stop_interface), pointer :: julienne_error_stop #endif end module julienne_multi_image_m fortran-julienne-3.6.2/src/julienne/julienne_test_fixture_s.F900000664000175000017500000000067515151766762025040 0ustar alastairalastair! 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_sfortran-julienne-3.6.2/src/julienne/julienne_test_s.F900000664000175000017500000000347715151766762023275 0ustar alastairalastair! 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" submodule(julienne_test_m) julienne_test_s use julienne_test_description_m, only : filter use julienne_multi_image_m, only : internal_this_image implicit none contains #if __GNUC__ && ( __GNUC__ > 13) module procedure run associate(matching_descriptions => filter(test_descriptions, test%subject())) test_results = matching_descriptions%run() end associate end procedure #else module procedure run type(test_description_t), allocatable :: matching_descriptions(:) matching_descriptions = filter(test_descriptions, test%subject()) test_results = matching_descriptions%run() end procedure #endif module procedure report integer t logical, allocatable :: passing_tests(:), skipped_tests(:) type(test_result_t), allocatable :: test_results(:) associate(me => internal_this_image()) if (me==1) print '(a)', new_line('') // test%subject() test_results = test%results() skipped_tests = test_results%skipped() associate(num_tests => size(test_results)) do t = 1, num_tests call test_results(t)%co_characterize() end do passing_tests = test_results%passed() ! may be altered by co_characterize tests = tests + num_tests associate(num_passes => count(passing_tests), num_skipped => count(skipped_tests)) if (me==1) print '(*(a,:,i0))', " ", num_passes, " of ", num_tests, " tests passed. ", num_skipped, " tests were skipped." passes = passes + num_passes skips = skips + num_skipped end associate end associate end associate end procedure end submodule julienne_test_s fortran-julienne-3.6.2/src/julienne/julienne_test_m.F900000664000175000017500000000437315151766762023263 0ustar alastairalastair! 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 julienne_test_m !! Define an abstract test_t type with deferred bindings ("subject" and "results") !! used by a type-bound procedure ("report") for reporting test results. The "report" !! procedure thus represents an implementation of the Template Method pattern. use julienne_test_result_m, only : test_result_t use julienne_test_description_m, only : test_description_t use julienne_command_line_m, only : command_line_t implicit none private public :: test_t type, abstract :: test_t !! Facilitate testing and test reporting contains procedure(subject_interface), nopass, deferred :: subject procedure(results_interface), nopass, deferred :: results procedure :: run procedure :: report end type abstract interface pure function subject_interface() result(specimen_description) !! The result is the name of the test specimen (the subject of testing) character(len=:), allocatable :: specimen_description end function function results_interface() result(test_results) !! The result is an array of test results for subsequent reporting in the "report" type-bound procedure import test_result_t type(test_result_t), allocatable :: test_results(:) end function end interface interface module function run(test, test_descriptions) result(test_results) !! Construct an array of test results from a set of tests filtered for descriptions and subjects with !! the '--contains' flag's value if the flag was included on the command line at program launch. implicit none class(test_t), intent(in) :: test type(test_description_t), intent(in) :: test_descriptions(:) type(test_result_t), allocatable :: test_results(:) end function module subroutine report(test, passes, tests, skips) !! Print the test results and increment the tallies of passing tests, total tests, and skipped tests. implicit none class(test_t), intent(in) :: test integer, intent(inout) :: passes, tests, skips end subroutine end interface end module julienne_test_mfortran-julienne-3.6.2/src/julienne/julienne_test_diagnosis_m.F900000664000175000017500000005263615151766762025330 0ustar alastairalastair! 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 julienne_test_diagnosis_m !! Define abstractions, defined operations, and procedures for writing correctness checks use julienne_string_m, only : string_t use iso_fortran_env, only : int64 use iso_c_binding, only : c_ptr implicit none private public :: test_diagnosis_t public :: diagnosis_function_i public :: passing_test public :: operator(//) public :: operator(.all.) public :: operator(.also.) public :: operator(.and.) public :: operator(.approximates.) public :: operator(.isAfter.) public :: operator(.isAtLeast.) public :: operator(.isAtMost.) public :: operator(.isBefore.) public :: operator(.equalsExpected.) public :: operator(.expect.) public :: operator(.greaterThan.) public :: operator(.greaterThanOrEqualTo.) public :: operator(.lessThan.) public :: operator(.lessThanOrEqualTo.) public :: operator(.within.) public :: operator(.withinFraction.) public :: operator(.withinPercentage.) type test_diagnosis_t !! Encapsulate test outcome and diagnostic information private logical :: test_passed_ = .false. character(len=:), allocatable :: diagnostics_string_ contains procedure, non_overridable :: test_passed procedure, non_overridable :: diagnostics_string generic :: assignment(=) => assign_logical procedure, non_overridable, private :: assign_logical end type abstract interface function diagnosis_function_i() result(test_diagnosis) import test_diagnosis_t implicit none type(test_diagnosis_t) test_diagnosis end function end interface integer, parameter :: default_real = kind(1.), double_precision = kind(1D0) #if HAVE_DERIVED_TYPE_KIND_PARAMETERS type operands_t(k) integer, kind :: k = default_real real(k) actual, expected end type #else type operands_t real actual, expected end type type double_precision_operands_t double precision actual, expected end type #endif interface operator(//) elemental module function append_string_if_test_failed(lhs, rhs) result(lhs_cat_rhs) implicit none class(test_diagnosis_t), intent(in) :: lhs type(string_t), intent(in) :: rhs type(test_diagnosis_t) lhs_cat_rhs end function elemental module function append_character_if_test_failed(lhs, rhs) result(lhs_cat_rhs) implicit none class(test_diagnosis_t), intent(in) :: lhs character(len=*), intent(in) :: rhs type(test_diagnosis_t) lhs_cat_rhs end function end interface interface operator(.all.) #ifndef __GFORTRAN__ pure module function aggregate_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(..) type(test_diagnosis_t) diagnosis end function #else pure module function aggregate_scalar_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses type(test_diagnosis_t) diagnosis end function pure module function aggregate_vector_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank2_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank3_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank4_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank5_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:,:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank6_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:,:,:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank7_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:,:,:,:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank8_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:,:,:,:,:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank9_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:,:,:,:,:,:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank10_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:,:,:,:,:,:,:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank11_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:,:,:,:,:,:,:,:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank12_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:,:,:,:,:,:,:,:,:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank13_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:,:,:,:,:,:,:,:,:,:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank14_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:,:,:,:,:,:,:,:,:,:,:,:) type(test_diagnosis_t) diagnosis end function pure module function aggregate_rank15_diagnosis(diagnoses) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: diagnoses(:,:,:,:,:,:,:,:,:,:,:,:,:,:,:) type(test_diagnosis_t) diagnosis end function #endif end interface interface operator(.also.) elemental module function also_DD(lhs, rhs) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: lhs, rhs type(test_diagnosis_t) diagnosis end function elemental module function also_DL(lhs, rhs) result(diagnosis) implicit none type(test_diagnosis_t), intent(in) :: lhs logical, intent(in) :: rhs type(test_diagnosis_t) diagnosis end function elemental module function also_LD(lhs, rhs) result(diagnosis) implicit none logical, intent(in) :: lhs type(test_diagnosis_t), intent(in) :: rhs type(test_diagnosis_t) diagnosis end function end interface interface operator(.and.) module procedure also_DD module procedure also_LD module procedure also_DL end interface interface operator(.approximates.) elemental module function approximates_real(actual, expected) result(operands) implicit none real, intent(in) :: actual, expected type(operands_t) operands end function elemental module function approximates_double_precision(actual, expected) result(operands) implicit none double precision, intent(in) :: actual, expected #if HAVE_DERIVED_TYPE_KIND_PARAMETERS type(operands_t(double_precision)) operands #else type(double_precision_operands_t) operands #endif end function 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_logical(actual, expected) result(test_diagnosis) implicit none logical, intent(in) :: actual, expected type(test_diagnosis_t) test_diagnosis end function elemental module function equals_expected_c_ptr(actual, expected) result(test_diagnosis) implicit none type(c_ptr), intent(in) :: actual, expected type(test_diagnosis_t) test_diagnosis end function elemental module function equals_expected_integer(actual, expected) result(test_diagnosis) implicit none integer, intent(in) :: actual, expected type(test_diagnosis_t) test_diagnosis end function elemental module function equals_expected_int64(actual, expected) result(test_diagnosis) implicit none integer(int64), intent(in) :: actual, expected type(test_diagnosis_t) test_diagnosis end function elemental module function equals_expected_character(actual, expected) result(test_diagnosis) implicit none character(len=*), intent(in) :: actual, expected type(test_diagnosis_t) test_diagnosis end function elemental module function equals_expected_string(actual, expected) result(test_diagnosis) implicit none type(string_t), intent(in) :: actual, expected type(test_diagnosis_t) test_diagnosis end function elemental module function equals_expected_character_vs_string(actual, expected) result(test_diagnosis) implicit none character(len=*), intent(in) :: actual type(string_t), intent(in) :: expected type(test_diagnosis_t) test_diagnosis end function elemental module function equals_expected_string_vs_character(actual, expected) result(test_diagnosis) implicit none type(string_t), intent(in) :: actual character(len=*), intent(in) :: expected type(test_diagnosis_t) test_diagnosis end function end interface interface operator(.lessThan.) elemental module function less_than_real(actual, expected_ceiling) result(test_diagnosis) implicit none real, intent(in) :: actual, expected_ceiling type(test_diagnosis_t) test_diagnosis end function elemental module function less_than_double(actual, expected_ceiling) result(test_diagnosis) implicit none double precision, intent(in) :: actual, expected_ceiling type(test_diagnosis_t) test_diagnosis end function elemental module function less_than_integer(actual, expected_ceiling) result(test_diagnosis) implicit none integer, intent(in) :: actual, expected_ceiling type(test_diagnosis_t) test_diagnosis end function elemental module function less_than_int64(actual, expected_ceiling) result(test_diagnosis) implicit none integer(int64), intent(in) :: actual, expected_ceiling type(test_diagnosis_t) test_diagnosis end function end interface interface operator(.lessThanOrEqualTo.) elemental module function less_than_or_equal_to_integer(actual, expected_max) result(test_diagnosis) implicit none integer, intent(in) :: actual, expected_max type(test_diagnosis_t) test_diagnosis end function elemental module function less_than_or_equal_to_int64(actual, expected_max) result(test_diagnosis) implicit none integer(int64), intent(in) :: actual, expected_max type(test_diagnosis_t) test_diagnosis end function elemental module function less_than_or_equal_to_real(actual, expected_max) result(test_diagnosis) implicit none real, intent(in) :: actual, expected_max type(test_diagnosis_t) test_diagnosis end function elemental module function less_than_or_equal_to_double_precision(actual, expected_max) result(test_diagnosis) implicit none double precision, intent(in) :: actual, expected_max type(test_diagnosis_t) test_diagnosis end function end interface interface operator(.isAtMost.) module procedure less_than_or_equal_to_integer module procedure less_than_or_equal_to_int64 module procedure less_than_or_equal_to_real module procedure less_than_or_equal_to_double_precision end interface interface operator(.isAtLeast.) module procedure greater_than_or_equal_to_integer module procedure greater_than_or_equal_to_int64 module procedure greater_than_or_equal_to_real module procedure greater_than_or_equal_to_double_precision end interface interface operator(.isBefore.) elemental module function alphabetical_character_vs_character(lhs, rhs) result(test_diagnosis) implicit none character(len=*), intent(in) :: lhs, rhs type(test_diagnosis_t) test_diagnosis end function elemental module function alphabetical_string_vs_string(lhs, rhs) result(test_diagnosis) implicit none type(string_t), intent(in) :: lhs, rhs type(test_diagnosis_t) test_diagnosis end function elemental module function alphabetical_character_vs_string(lhs, rhs) result(test_diagnosis) implicit none character(len=*), intent(in) :: lhs type(string_t), intent(in) :: rhs type(test_diagnosis_t) test_diagnosis end function elemental module function alphabetical_string_vs_character(lhs, rhs) result(test_diagnosis) implicit none type(string_t), intent(in) :: lhs character(len=*), intent(in) :: rhs type(test_diagnosis_t) test_diagnosis end function end interface interface operator(.isAfter.) elemental module function reverse_alphabetical_character_vs_character(lhs, rhs) result(test_diagnosis) implicit none character(len=*), intent(in) :: lhs, rhs type(test_diagnosis_t) test_diagnosis end function elemental module function reverse_alphabetical_string_vs_string(lhs, rhs) result(test_diagnosis) implicit none type(string_t), intent(in) :: lhs, rhs type(test_diagnosis_t) test_diagnosis end function elemental module function reverse_alphabetical_character_vs_string(lhs, rhs) result(test_diagnosis) implicit none character(len=*), intent(in) :: lhs type(string_t), intent(in) :: rhs type(test_diagnosis_t) test_diagnosis end function elemental module function reverse_alphabetical_string_vs_character(lhs, rhs) result(test_diagnosis) implicit none type(string_t), intent(in) :: lhs character(len=*), intent(in) :: rhs type(test_diagnosis_t) test_diagnosis end function end interface interface operator(.greaterThanOrEqualTo.) elemental module function greater_than_or_equal_to_integer(actual, expected_min) result(test_diagnosis) implicit none integer, intent(in) :: actual, expected_min type(test_diagnosis_t) test_diagnosis end function elemental module function greater_than_or_equal_to_int64(actual, expected_min) result(test_diagnosis) implicit none integer(int64), intent(in) :: actual, expected_min type(test_diagnosis_t) test_diagnosis end function elemental module function greater_than_or_equal_to_real(actual, expected_min) result(test_diagnosis) implicit none real, intent(in) :: actual, expected_min type(test_diagnosis_t) test_diagnosis end function elemental module function greater_than_or_equal_to_double_precision(actual, expected_min) result(test_diagnosis) implicit none double precision, intent(in) :: actual, expected_min type(test_diagnosis_t) test_diagnosis end function end interface interface operator(.greaterThan.) elemental module function greater_than_real(actual, expected_floor) result(test_diagnosis) implicit none real, intent(in) :: actual, expected_floor type(test_diagnosis_t) test_diagnosis end function elemental module function greater_than_double(actual, expected_floor) result(test_diagnosis) implicit none double precision, intent(in) :: actual, expected_floor type(test_diagnosis_t) test_diagnosis end function elemental module function greater_than_integer(actual, expected_floor) result(test_diagnosis) implicit none integer, intent(in) :: actual, expected_floor type(test_diagnosis_t) test_diagnosis end function elemental module function greater_than_int64(actual, expected_floor) result(test_diagnosis) implicit none integer(int64), intent(in) :: actual, expected_floor type(test_diagnosis_t) test_diagnosis end function end interface interface operator(.within.) elemental module function within_real(operands, tolerance) result(test_diagnosis) implicit none type(operands_t), intent(in) :: operands real, intent(in) :: tolerance type(test_diagnosis_t) test_diagnosis end function elemental module function within_double_precision(operands, tolerance) result(test_diagnosis) implicit none #if HAVE_DERIVED_TYPE_KIND_PARAMETERS type(operands_t(double_precision)), intent(in) :: operands #else type(double_precision_operands_t), intent(in) :: operands #endif double precision, intent(in) :: tolerance type(test_diagnosis_t) test_diagnosis end function end interface interface operator(.withinFraction.) elemental module function within_real_fraction(operands, fractional_tolerance) result(test_diagnosis) implicit none type(operands_t), intent(in) :: operands real, intent(in) :: fractional_tolerance type(test_diagnosis_t) test_diagnosis end function elemental module function within_double_precision_fraction(operands, fractional_tolerance) result(test_diagnosis) implicit none #if HAVE_DERIVED_TYPE_KIND_PARAMETERS type(operands_t(double_precision)), intent(in) :: operands #else type(double_precision_operands_t), intent(in) :: operands #endif double precision, intent(in) :: fractional_tolerance type(test_diagnosis_t) test_diagnosis end function end interface interface operator(.withinPercentage.) elemental module function within_real_percentage(operands, percentage_tolerance) result(test_diagnosis) implicit none type(operands_t), intent(in) :: operands real, intent(in) :: percentage_tolerance type(test_diagnosis_t) test_diagnosis end function elemental module function within_double_precision_percentage(operands, percentage_tolerance) result(test_diagnosis) implicit none #if HAVE_DERIVED_TYPE_KIND_PARAMETERS type(operands_t(double_precision)), intent(in) :: operands #else type(double_precision_operands_t), intent(in) :: operands #endif double precision, intent(in) :: percentage_tolerance type(test_diagnosis_t) test_diagnosis end function end interface interface test_diagnosis_t elemental module function construct_from_string_t(test_passed, diagnostics_string) result(test_diagnosis) !! The result is a test_diagnosis_t object with the components defined by the dummy arguments implicit none logical, intent(in) :: test_passed type(string_t), intent(in) :: diagnostics_string type(test_diagnosis_t) test_diagnosis end function elemental module function construct_from_character(test_passed, diagnostics_string) result(test_diagnosis) !! The result is a test_diagnosis_t object with the components defined by the dummy arguments implicit none logical, intent(in) :: test_passed character(len=*), intent(in) :: diagnostics_string type(test_diagnosis_t) test_diagnosis end function elemental module function copy_construct_from_string_t(diagnosis, diagnostics_string) result(test_diagnosis) !! The result is a copy of the provided test_diagnosis_t object, with the appended string implicit none type(test_diagnosis_t), intent(in) :: diagnosis type(string_t), intent(in) :: diagnostics_string type(test_diagnosis_t) test_diagnosis end function elemental module function copy_construct_from_character(diagnosis, diagnostics_string) result(test_diagnosis) !! The result is a copy of the provided test_diagnosis_t object, with the optional appended string implicit none type(test_diagnosis_t), intent(in) :: diagnosis character(len=*), intent(in), optional :: diagnostics_string type(test_diagnosis_t) test_diagnosis end function end interface interface module subroutine assign_logical(lhs, rhs) implicit none class(test_diagnosis_t), intent(out) :: lhs logical, intent(in) :: rhs end subroutine pure module function passing_test() result(test_diagnosis) !! Construct a passing test diagnosis with a zero-length diagnostics string implicit none type(test_diagnosis_t) test_diagnosis end function elemental module function test_passed(self) result(passed) !! The result is .true. if the test passed on the executing image and false otherwise implicit none class(test_diagnosis_t), intent(in) :: self logical passed end function pure module function diagnostics_string(self) result(string) !! The result is a string describing the condition(s) that caused a test failure or is a zero-length string if no failure implicit none class(test_diagnosis_t), intent(in) :: self character(len=:), allocatable :: string end function end interface end module julienne_test_diagnosis_m fortran-julienne-3.6.2/src/julienne/julienne_github_ci_m.f900000664000175000017500000000071715151766762024277 0ustar alastairalastair! 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_github_ci_m !! Detect whether a program is running in GitHub Continuous Integration (CI) implicit none interface logical module function GitHub_CI() !! The result is true if the environment variable named "CI" is set to the string "true" end function end interface end module fortran-julienne-3.6.2/src/julienne/julienne_test_description_m.f900000664000175000017500000001251415151766762025722 0ustar alastairalastair! 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_description_m !! Define an abstraction for describing test intentions and test functions use julienne_string_m, only : string_t use julienne_test_result_m, only : test_result_t use julienne_test_diagnosis_m, only : test_diagnosis_t, diagnosis_function_i use iso_c_binding, only: c_funptr implicit none private public :: test_description_t public :: filter public :: usher type test_description_t !! Encapsulate test descriptions and test-functions private character(len=:), allocatable :: description_ procedure(diagnosis_function_i), pointer, nopass :: diagnosis_function_ => null() contains procedure run generic :: contains_text => contains_string_t, contains_characters procedure, private :: contains_string_t, contains_characters generic :: operator(==) => equals procedure, private :: equals end type type usher procedure(diagnosis_function_i), pointer, nopass :: ptr => null() end type interface test_description_t module function construct_from_string_funloc(description, diagnosis_function) result(test_description) !! The result is a test_description_t object with the components defined by the dummy arguments implicit none type(string_t), intent(in) :: description type(c_funptr), intent(in) :: diagnosis_function type(test_description_t) test_description end function module function construct_from_string_usher(description, diagnosis_function) result(test_description) !! The result is a test_description_t object with the components defined by the dummy arguments implicit none type(string_t), intent(in) :: description type(usher), intent(in) :: diagnosis_function type(test_description_t) test_description end function module function construct_from_string(description, diagnosis_function) result(test_description) !! The result is a test_description_t object with the components defined by the dummy arguments implicit none type(string_t), intent(in) :: description procedure(diagnosis_function_i), intent(in), pointer, optional :: diagnosis_function type(test_description_t) test_description end function module function construct_from_characters_funloc(description, diagnosis_function) result(test_description) !! The result is a test_description_t object with the components defined by the dummy arguments implicit none character(len=*), intent(in) :: description type(c_funptr), intent(in) :: diagnosis_function type(test_description_t) test_description end function module function construct_from_characters_usher(description, diagnosis_function) result(test_description) !! The result is a test_description_t object with the components defined by the dummy arguments implicit none character(len=*), intent(in) :: description type(usher), intent(in) :: diagnosis_function type(test_description_t) test_description end function module function construct_from_characters(description, diagnosis_function) result(test_description) !! The result is a test_description_t object with the components defined by the dummy arguments implicit none character(len=*), intent(in) :: description procedure(diagnosis_function_i), intent(in), pointer, optional :: diagnosis_function type(test_description_t) test_description end function end interface interface impure elemental module function run(self) result(test_result) !! The result encapsulates the test description and test outcome implicit none class(test_description_t), intent(in) :: self type(test_result_t) test_result end function elemental module function contains_string_t(self, substring) result(match) !! The result is .true. if the test description includes the value of substring implicit none class(test_description_t), intent(in) :: self type(string_t), intent(in) :: substring logical match end function elemental module function contains_characters(self, substring) result(match) !! The result is .true. if the test description includes the value of substring implicit none class(test_description_t), intent(in) :: self character(len=*), intent(in) :: substring logical match end function elemental module function equals(lhs, rhs) result(lhs_eq_rhs) !! The result is .true. if the components of the lhs & rhs are equal implicit none class(test_description_t), intent(in) :: lhs, rhs logical lhs_eq_rhs end function module function filter(test_descriptions, subject) result(filtered_test_descriptions) !! The result is .true. an array of test_description_t objects whose description_ or contains the substring specified !! by command-line --contains flag if present, or all test_descriptions if the subject contains the same substring implicit none type(test_description_t), intent(in) :: test_descriptions(:) character(len=*), intent(in) :: subject type(test_description_t), allocatable :: filtered_test_descriptions(:) end function end interface end module julienne_test_description_m fortran-julienne-3.6.2/src/julienne/julienne_test_harness_s.F900000664000175000017500000001004615151766762025006 0ustar alastairalastair! 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" submodule(julienne_test_harness_m) julienne_test_harness_s use iso_fortran_env, only : int64, real64 use julienne_command_line_m, only : command_line_t use julienne_string_m, only : string_t use julienne_multi_image_m, only : internal_this_image, internal_num_images, internal_error_stop implicit none contains module procedure component_constructor #ifdef NAGFOR test_harness%test_fixture_ = test_fixtures ! avoid a nagfor internal compiler error #else allocate(test_harness%test_fixture_, source = test_fixtures) ! eliminates a harmless gfortran warning #endif end procedure module procedure report_results integer i, passes, tests, skips integer(int64) start_time, end_time, clock_rate integer, parameter :: ms_per_sec = 1000 passes=0; tests=0; skips=0 call print_usage_info_and_stop_if_requested call system_clock(start_time, clock_rate) do i = 1, size(self%test_fixture_) call self%test_fixture_(i)%report(passes, tests, skips) end do call system_clock(end_time) associate(me => internal_this_image(), image_count => internal_num_images()) if (me==1) then print * #if defined(__flang__) && !defined(__linux__) ! workaround issue 155 observed on flang + macOS print '(a,f0.3,a)', "Test-suite run time: ", (end_time - start_time)/(real(clock_rate, real64)*ms_per_sec), " seconds" #else print '(a,f0.3,a)', "Test-suite run time: ", (end_time - start_time)/ real(clock_rate, real64 ), " seconds" #endif print '(a,i0)', "Number of images: ", image_count print * print '(*(a,:,i0))', "_____ ", passes, " of ", tests, " tests passed. ", skips, " tests were skipped _____" print * end if if (passes + skips /= tests .and. me==1) call internal_error_stop("Some tests failed.") end associate end procedure subroutine print_usage_info_and_stop_if_requested 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('') associate(me => internal_this_image()) associate(command_line => command_line_t()) if (command_line%argument_present([character(len=len("--help"))::"--help","-h"])) then if (me==1) print '(a)', usage stop end if if (me==1) then print '(a)', new_line("") // "Append '-- --help' or '-- -h' to your `fpm test` command to display usage information." #if (! defined(__GFORTRAN__)) && (! defined(NAGFOR)) associate(search_string => command_line%flag_value("--contains")) #else block; character(len=:), allocatable :: search_string; search_string = command_line%flag_value("--contains") #endif if (len(search_string)==0) then print '(a)', new_line('') // & "Running all tests." // new_line('') // & "(Add '-- --contains ' to run only tests with subjects or descriptions containing the specified string.)" else print '(a)', new_line('') // "Running only tests with subjects or descriptions containing '" // search_string // "'." end if #if (! defined(__GFORTRAN__)) && (! defined(NAGFOR)) end associate #else end block #endif end if end associate end associate end subroutine end submodule julienne_test_harness_s fortran-julienne-3.6.2/src/julienne/julienne_string_m.F900000664000175000017500000003734615151766762023620 0ustar alastairalastair! 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_string_m use iso_c_binding, only : c_bool, c_size_t implicit none private public :: string_t public :: array_of_strings ! construct 1D string_t array from a string containing delimited substrings public :: operator(.cat.) ! element-wise concatenation unary operator public :: operator(.csv.) ! comma-separated values unary operator public :: operator(.separatedBy.), operator(.sv.) ! separated-values binary operator type string_t private character(len=:), allocatable :: string_ contains procedure :: as_character generic :: string => as_character procedure :: is_allocated procedure :: get_json_key procedure :: file_extension procedure :: base_name procedure :: bracket generic :: operator(//) => string_t_cat_string_t, string_t_cat_character, character_cat_string_t generic :: operator(/=) => string_t_ne_string_t, string_t_ne_character, character_ne_string_t generic :: operator(==) => string_t_eq_string_t, string_t_eq_character, character_eq_string_t generic :: assignment(= ) => assign_string_t_to_character, assign_character_to_string_t generic :: get_json_value => get_string_with_string_key, get_string_with_character_key & ,get_character_with_string_key, get_character_with_character_key & ,get_string_t_array_with_character_key, get_string_t_array_with_string_t_key & ,get_real, get_real_with_character_key & ,get_logical, get_logical_with_character_key & ,get_real_array ,get_real_array_with_character_key & ,get_integer_array, get_integer_array_with_character_key & ,get_integer, get_integer_with_character_key & ,get_double_precision, get_double_precision_with_character_key & ,get_double_precision_array, get_double_precision_array_with_character_key procedure, private :: get_string_with_string_key, get_string_with_character_key procedure, private :: get_character_with_string_key, get_character_with_character_key procedure, private :: get_string_t_array_with_character_key, get_string_t_array_with_string_t_key procedure, private :: get_real, get_real_with_character_key procedure, private :: get_logical, get_logical_with_character_key procedure, private :: get_integer, get_integer_with_character_key procedure, private :: get_real_array, get_real_array_with_character_key procedure, private :: get_integer_array, get_integer_array_with_character_key procedure, private :: get_double_precision, get_double_precision_with_character_key procedure, private :: get_double_precision_array, get_double_precision_array_with_character_key procedure, private :: string_t_ne_string_t, string_t_ne_character procedure, private :: string_t_eq_string_t, string_t_eq_character procedure, private :: assign_character_to_string_t procedure, private :: string_t_cat_string_t, string_t_cat_character procedure, private, pass(rhs) :: character_cat_string_t procedure, private, pass(rhs) :: character_ne_string_t procedure, private, pass(rhs) :: character_eq_string_t procedure, private, pass(rhs) :: assign_string_t_to_character end type interface string_t elemental module function from_characters(string) result(new_string) implicit none character(len=*), intent(in) :: string type(string_t) new_string end function elemental module function from_default_integer(i) result(string) implicit none integer, intent(in) :: i type(string_t) string end function elemental module function from_integer_c_size_t(i) result(string) implicit none integer(c_size_t), intent(in) :: i type(string_t) string end function elemental module function from_default_real(x) result(string) implicit none real, intent(in) :: x type(string_t) string end function elemental module function from_double_precision(x) result(string) implicit none double precision, intent(in) :: x type(string_t) string end function elemental module function from_default_logical(b) result(string) implicit none logical, intent(in) :: b type(string_t) string end function elemental module function from_logical_c_bool(b) result(string) implicit none logical(c_bool), intent(in) :: b type(string_t) string end function elemental module function from_default_complex(z) result(string) implicit none complex, intent(in) :: z type(string_t) string end function elemental module function from_double_precision_complex(z) result(string) implicit none complex(kind=kind(1D0)), intent(in) :: z type(string_t) string end function end interface interface operator(.cat.) pure module function concatenate_elements(strings) result(concatenated_strings) implicit none type(string_t), intent(in) :: strings(:) type(string_t) concatenated_strings end function end interface interface operator(.csv.) pure module function strings_with_comma_separator(strings) result(csv) implicit none type(string_t), intent(in) :: strings(:) type(string_t) csv end function pure module function characters_with_comma_separator(strings) result(csv) implicit none character(len=*), intent(in) :: strings(:) type(string_t) csv end function end interface interface operator(.sv.) pure module function strings_with_character_separator(strings, separator) result(sv) implicit none type(string_t) , intent(in) :: strings(:) character(len=*), intent(in) :: separator type(string_t) sv end function pure module function characters_with_character_separator(strings, separator) result(sv) implicit none character(len=*), intent(in) :: strings(:), separator type(string_t) sv end function pure module function characters_with_string_separator(strings, separator) result(sv) implicit none character(len=*), intent(in) :: strings(:) type(string_t) , intent(in) :: separator type(string_t) sv end function pure module function strings_with_string_t_separator(strings, separator) result(sv) implicit none type(string_t), intent(in) :: strings(:), separator type(string_t) sv end function end interface interface operator(.separatedBy.) module procedure strings_with_character_separator, strings_with_string_t_separator module procedure characters_with_character_separator, characters_with_string_separator end interface interface pure module function as_character(self) result(raw_string) implicit none class(string_t), intent(in) :: self character(len=:), allocatable :: raw_string end function pure module function array_of_strings(delimited_strings, delimiter) result(strings_array) implicit none character(len=*), intent(in) :: delimited_strings, delimiter type(string_t), allocatable :: strings_array(:) end function elemental module function is_allocated(self) result(string_allocated) implicit none class(string_t), intent(in) :: self logical string_allocated end function elemental module function get_json_key(self) result(unquoted_key) implicit none class(string_t), intent(in) :: self type(string_t) unquoted_key end function elemental module function file_extension(self) result(extension) !! result contains all characters in file_name after the last dot (.) class(string_t), intent(in) :: self type(string_t) extension end function elemental module function base_name(self) result(base) !! result contains all characters in file_name before the last dot (.) class(string_t), intent(in) :: self type(string_t) base end function pure module function get_real(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self, key real, intent(in) :: mold real value_ end function pure module function get_real_with_character_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self character(len=*), intent(in) :: key real, intent(in) :: mold real value_ end function pure module function get_double_precision(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self, key double precision, intent(in) :: mold double precision value_ end function pure module function get_double_precision_with_character_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self character(len=*), intent(in) :: key double precision, intent(in) :: mold double precision value_ end function pure module function get_double_precision_array(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self, key double precision, intent(in) :: mold(:) double precision, allocatable :: value_(:) end function pure module function get_double_precision_array_with_character_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self character(len=*), intent(in) :: key double precision, intent(in) :: mold(:) double precision, allocatable :: value_(:) end function pure module function get_character_with_string_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self, key character(len=*), intent(in) :: mold character(len=:), allocatable :: value_ end function pure module function get_character_with_character_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self character(len=*), intent(in) :: key, mold character(len=:), allocatable :: value_ end function pure module function get_string_with_string_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self, key, mold type(string_t) :: value_ end function pure module function get_string_with_character_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self, mold character(len=*), intent(in) :: key type(string_t) :: value_ end function pure module function get_string_t_array_with_string_t_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self type(string_t), intent(in) :: key, mold(:) type(string_t), allocatable :: value_(:) end function pure module function get_string_t_array_with_character_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self character(len=*), intent(in) :: key type(string_t), intent(in) :: mold(:) type(string_t), allocatable :: value_(:) end function pure module function get_integer_with_character_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self character(len=*), intent(in) :: key integer, intent(in) :: mold integer value_ end function pure module function get_integer(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self, key integer, intent(in) :: mold integer value_ end function pure module function get_logical_with_character_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self character(len=*), intent(in) :: key logical, intent(in) :: mold logical value_ end function pure module function get_logical(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self, key logical, intent(in) :: mold logical value_ end function pure module function get_integer_array_with_character_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self character(len=*), intent(in) :: key integer, intent(in) :: mold(:) integer, allocatable :: value_(:) end function pure module function get_integer_array(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self, key integer, intent(in) :: mold(:) integer, allocatable :: value_(:) end function pure module function get_real_array_with_character_key(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self character(len=*), intent(in) :: key real, intent(in) :: mold(:) real, allocatable :: value_(:) end function pure module function get_real_array(self, key, mold) result(value_) implicit none class(string_t), intent(in) :: self, key real, intent(in) :: mold(:) real, allocatable :: value_(:) end function elemental module function string_t_eq_string_t(lhs, rhs) result(lhs_eq_rhs) implicit none class(string_t), intent(in) :: lhs, rhs logical lhs_eq_rhs end function elemental module function string_t_eq_character(lhs, rhs) result(lhs_eq_rhs) implicit none class(string_t), intent(in) :: lhs character(len=*), intent(in) :: rhs logical lhs_eq_rhs end function elemental module function character_eq_string_t(lhs, rhs) result(lhs_eq_rhs) implicit none class(string_t), intent(in) :: rhs character(len=*), intent(in) :: lhs logical lhs_eq_rhs end function elemental module function string_t_ne_string_t(lhs, rhs) result(lhs_ne_rhs) implicit none class(string_t), intent(in) :: lhs, rhs logical lhs_ne_rhs end function elemental module function string_t_ne_character(lhs, rhs) result(lhs_ne_rhs) implicit none class(string_t), intent(in) :: lhs character(len=*), intent(in) :: rhs logical lhs_ne_rhs end function elemental module function character_ne_string_t(lhs, rhs) result(lhs_ne_rhs) implicit none class(string_t), intent(in) :: rhs character(len=*), intent(in) :: lhs logical lhs_ne_rhs end function elemental module function string_t_cat_string_t(lhs, rhs) result(lhs_cat_rhs) implicit none class(string_t), intent(in) :: lhs, rhs type(string_t) lhs_cat_rhs end function elemental module function string_t_cat_character(lhs, rhs) result(lhs_cat_rhs) implicit none class(string_t), intent(in) :: lhs character(len=*), intent(in) :: rhs type(string_t) lhs_cat_rhs end function elemental module function character_cat_string_t(lhs, rhs) result(lhs_cat_rhs) implicit none character(len=*), intent(in) :: lhs class(string_t), intent(in) :: rhs type(string_t) lhs_cat_rhs end function elemental module subroutine assign_character_to_string_t(lhs, rhs) implicit none class(string_t), intent(inout) :: lhs character(len=*), intent(in) :: rhs end subroutine pure module subroutine assign_string_t_to_character(lhs, rhs) implicit none class(string_t), intent(in) :: rhs character(len=:), intent(out), allocatable :: lhs end subroutine elemental module function bracket(self, opening, closing) result(bracketed_self) implicit none class(string_t), intent(in) :: self character(len=*), intent(in), optional :: opening, closing type(string_t) bracketed_self end function end interface end module julienne_string_m fortran-julienne-3.6.2/src/julienne/julienne_string_s.F900000664000175000017500000005022415151766762023614 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt #include "julienne-assert-macros.h" #include "assert_macros.h" submodule(julienne_string_m) julienne_string_s use assert_m use julienne_assert_m, only : call_julienne_assert_ use julienne_test_diagnosis_m, only : operator(.equalsExpected.) implicit none integer, parameter :: default_integer_width_supremum = 11, default_real_width_supremum = 20, double_precision_width_supremum = 25 integer, parameter :: integer_c_size_t_width_supremum = 19, logical_width=2, comma_width = 1, parenthesis_width = 1, space=1 contains module procedure as_character raw_string = self%string_ end procedure module procedure is_allocated string_allocated = allocated(self%string_) end procedure module procedure from_characters new_string%string_ = string end procedure module procedure from_default_integer allocate(character(len=default_integer_width_supremum) :: string%string_) write(string%string_, '(g0)') i string%string_ = trim(adjustl(string%string_)) end procedure module procedure from_integer_c_size_t allocate(character(len=integer_c_size_t_width_supremum) :: string%string_) write(string%string_, '(g0)') i string%string_ = trim(adjustl(string%string_)) end procedure module procedure from_default_real allocate(character(len=double_precision_width_supremum) :: string%string_) write(string%string_, '(g20.13)') x string%string_ = trim(adjustl(string%string_)) end procedure module procedure from_double_precision allocate(character(len=double_precision_width_supremum) :: string%string_) write(string%string_, '(g20.13)') x string%string_ = trim(adjustl(string%string_)) end procedure module procedure from_default_logical allocate(character(len=logical_width) :: string%string_) write(string%string_, '(g0)') b string%string_ = trim(adjustl(string%string_)) end procedure module procedure from_logical_c_bool allocate(character(len=logical_width) :: string%string_) write(string%string_, '(g0)') b string%string_ = trim(adjustl(string%string_)) end procedure module procedure from_default_complex allocate(character(len=2*default_real_width_supremum + 2*parenthesis_width + comma_width) :: string%string_) write(string%string_, '("(",g20.13,",",g20.13,")")') z string%string_ = trim(adjustl(string%string_)) end procedure module procedure from_double_precision_complex allocate(character(len=space + 2*double_precision_width_supremum + 2*parenthesis_width + comma_width) :: string%string_) write(string%string_, '("(",g20.13,",",g20.13,")")') z string%string_ = trim(adjustl(string%string_)) end procedure module procedure concatenate_elements integer s concatenated_strings = "" do s = 1, size(strings) concatenated_strings = concatenated_strings // strings(s)%string() end do end procedure module procedure strings_with_comma_separator csv = strings_with_string_t_separator(strings, string_t(",")) end procedure module procedure characters_with_comma_separator csv = strings_with_string_t_separator(string_t(strings), string_t(",")) end procedure module procedure characters_with_character_separator sv = strings_with_string_t_separator(string_t(strings), string_t(separator)) end procedure module procedure characters_with_string_separator sv = strings_with_string_t_separator(string_t(strings), separator) end procedure module procedure strings_with_character_separator sv = strings_with_string_t_separator(strings, string_t(separator)) end procedure module procedure strings_with_string_t_separator integer s associate(num_elements => size(strings)) sv = "" do s = 1, num_elements - 1 sv = sv // strings(s) // separator end do sv = sv // strings(num_elements) end associate end procedure module procedure array_of_strings character(len=:), allocatable :: remainder, next_string integer next_delimiter, string_end remainder = trim(adjustl(delimited_strings)) allocate(strings_array(0)) do next_delimiter = index(remainder, delimiter) string_end = merge(len(remainder), next_delimiter-1, next_delimiter==0) next_string = trim(adjustl(remainder(:string_end))) if (len(next_string)==0) exit strings_array = [strings_array, string_t(next_string)] if (next_delimiter==0) then remainder = "" else remainder = trim(adjustl(remainder(next_delimiter+1:))) end if end do end procedure module procedure get_json_key character(len=:), allocatable :: raw_line raw_line = self%string() associate(opening_key_quotes => index(raw_line, '"')) associate(closing_key_quotes => opening_key_quotes + index(raw_line(opening_key_quotes+1:), '"')) unquoted_key = string_t(trim(raw_line(opening_key_quotes+1:closing_key_quotes-1))) end associate end associate end procedure module procedure file_extension character(len=:), allocatable :: name_ name_ = trim(adjustl(self%string())) associate( dot_location => index(name_, '.', back=.true.) ) if (dot_location < len(name_)) then extension = trim(adjustl(name_(dot_location+1:))) else extension = "" end if end associate end procedure module procedure base_name character(len=:), allocatable :: name_ name_ = self%string() associate(dot_location => index(name_, '.', back=.true.) ) if (dot_location < len(name_)) then base = trim(adjustl(name_(1:dot_location-1))) else base = "" end if end associate end procedure module procedure get_real_with_character_key value_ = self%get_real(string_t(key), mold) end procedure module procedure get_double_precision_with_character_key value_ = self%get_double_precision(string_t(key), mold) end procedure #ifndef NAGFOR module procedure get_real character(len=:), allocatable :: raw_line, string_value call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() associate(text_after_colon => raw_line(index(raw_line, ':')+1:)) associate(trailing_comma => index(text_after_colon, ',')) if (trailing_comma == 0) then string_value = trim(adjustl((text_after_colon))) else string_value = trim(adjustl((text_after_colon(:trailing_comma-1)))) end if read(string_value, fmt=*) value_ end associate end associate end procedure #else module procedure get_real character(len=:), allocatable :: raw_line, string_value, text_after_colon call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() text_after_colon = raw_line(index(raw_line, ':')+1:) associate(trailing_comma => index(text_after_colon, ',')) if (trailing_comma == 0) then string_value = trim(adjustl((text_after_colon))) else string_value = trim(adjustl((text_after_colon(:trailing_comma-1)))) end if read(string_value, fmt=*) value_ end associate end procedure #endif #ifndef NAGFOR module procedure get_double_precision character(len=:), allocatable :: raw_line, string_value call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() associate(text_after_colon => raw_line(index(raw_line, ':')+1:)) associate(trailing_comma => index(text_after_colon, ',')) if (trailing_comma == 0) then string_value = trim(adjustl((text_after_colon))) else string_value = trim(adjustl((text_after_colon(:trailing_comma-1)))) end if read(string_value, fmt=*) value_ end associate end associate end procedure #else module procedure get_double_precision character(len=:), allocatable :: raw_line, string_value, text_after_colon integer trailing_comma call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() text_after_colon = raw_line(index(raw_line, ':')+1:) associate(trailing_comma => index(text_after_colon, ',')) if (trailing_comma == 0) then string_value = trim(adjustl((text_after_colon))) else string_value = trim(adjustl((text_after_colon(:trailing_comma-1)))) end if read(string_value, fmt=*) value_ end associate end procedure #endif module procedure get_character_with_string_key associate(string_value => self%get_string_with_string_key(key, string_t(mold))) value_ = string_value%string() end associate end procedure module procedure get_character_with_character_key associate(string_value => self%get_string_with_string_key(string_t(key), string_t(mold))) value_ = string_value%string() end associate end procedure module procedure get_string_with_character_key associate(string_value => self%get_string_with_string_key(string_t(key), mold)) value_ = string_value%string() end associate end procedure module procedure get_string_t_array_with_string_t_key value_ = self%get_string_t_array_with_character_key(key%string(), mold) end procedure #ifndef NAGFOR module procedure get_string_t_array_with_character_key character(len=:), allocatable :: raw_line integer i, comma, opening_quotes, closing_quotes call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() associate(colon => index(raw_line, ':')) associate(opening_bracket => colon + index(raw_line(colon+1:), '[')) associate(closing_bracket => opening_bracket + index(raw_line(opening_bracket+1:), ']')) associate(commas => count([(raw_line(i:i)==",", i = opening_bracket+1, closing_bracket-1)])) allocate(value_(commas+1)) opening_quotes = opening_bracket + index(raw_line(opening_bracket+1:), '"') closing_quotes = opening_quotes + index(raw_line(opening_quotes+1:), '"') value_(1) = raw_line(opening_quotes+1:closing_quotes-1) do i = 1, commas comma = closing_quotes + index(raw_line(closing_quotes+1:), ',') opening_quotes = comma + index(raw_line(comma+1:), '"') closing_quotes = opening_quotes + index(raw_line(opening_quotes+1:), '"') value_(i+1) = raw_line(opening_quotes+1:closing_quotes-1) end do end associate end associate end associate end associate end procedure #else module procedure get_string_t_array_with_character_key character(len=:), allocatable :: raw_line integer i, comma, opening_quotes, closing_quotes, opening_bracket call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() associate(colon => index(raw_line, ':')) opening_bracket = colon + index(raw_line(colon+1:), '[') associate(closing_bracket => opening_bracket + index(raw_line(opening_bracket+1:), ']')) associate(commas => count([(raw_line(i:i)==",", i = opening_bracket+1, closing_bracket-1)])) allocate(value_(commas+1)) opening_quotes = opening_bracket + index(raw_line(opening_bracket+1:), '"') closing_quotes = opening_quotes + index(raw_line(opening_quotes+1:), '"') value_(1) = raw_line(opening_quotes+1:closing_quotes-1) do i = 1, commas comma = closing_quotes + index(raw_line(closing_quotes+1:), ',') opening_quotes = comma + index(raw_line(comma+1:), '"') closing_quotes = opening_quotes + index(raw_line(opening_quotes+1:), '"') value_(i+1) = raw_line(opening_quotes+1:closing_quotes-1) end do end associate end associate end associate end procedure #endif #ifndef NAGFOR module procedure get_string_with_string_key character(len=:), allocatable :: raw_line call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() associate(text_after_colon => raw_line(index(raw_line, ':')+1:)) associate(opening_value_quotes => index(text_after_colon, '"')) associate(closing_value_quotes => opening_value_quotes + index(text_after_colon(opening_value_quotes+1:), '"')) if (any([opening_value_quotes, closing_value_quotes] == 0)) then value_ = string_t(trim(adjustl((text_after_colon)))) else value_ = string_t(text_after_colon(opening_value_quotes+1:closing_value_quotes-1)) end if end associate end associate end associate end procedure #else module procedure get_string_with_string_key character(len=:), allocatable :: raw_line, text_after_colon integer opening_value_quotes call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() text_after_colon = raw_line(index(raw_line, ':')+1:) opening_value_quotes = index(text_after_colon, '"') associate(closing_value_quotes => opening_value_quotes + index(text_after_colon(opening_value_quotes+1:), '"')) if (any([opening_value_quotes, closing_value_quotes] == 0)) then value_ = string_t(trim(adjustl((text_after_colon)))) else value_ = string_t(text_after_colon(opening_value_quotes+1:closing_value_quotes-1)) end if end associate end procedure #endif module procedure get_logical_with_character_key value_ = self%get_logical(string_t(key), mold) end procedure #ifndef NAGFOR module procedure get_logical character(len=:), allocatable :: raw_line, string_value call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() associate(text_after_colon => raw_line(index(raw_line, ':')+1:)) associate(trailing_comma => index(text_after_colon, ',')) if (trailing_comma == 0) then string_value = trim(adjustl((text_after_colon))) else string_value = trim(adjustl((text_after_colon(:trailing_comma-1)))) end if call_assert(any(string_value==['true ', 'false'])) value_ = string_value == "true" end associate end associate end procedure #else module procedure get_logical character(len=:), allocatable :: raw_line, string_value, text_after_colon integer trailing_comma call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() text_after_colon = raw_line(index(raw_line, ':')+1:) trailing_comma = index(text_after_colon, ',') if (trailing_comma == 0) then string_value = trim(adjustl((text_after_colon))) else string_value = trim(adjustl((text_after_colon(:trailing_comma-1)))) end if call_assert(any(string_value==['true ', 'false'])) value_ = string_value == "true" end procedure #endif #ifndef NAGFOR module procedure get_integer character(len=:), allocatable :: raw_line, string_value call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() associate(text_after_colon => raw_line(index(raw_line, ':')+1:)) associate(trailing_comma => index(text_after_colon, ',')) if (trailing_comma == 0) then string_value = trim(adjustl((text_after_colon))) else string_value = trim(adjustl((text_after_colon(:trailing_comma-1)))) end if read(string_value, fmt=*) value_ end associate end associate end procedure #else module procedure get_integer character(len=:), allocatable :: raw_line, string_value, text_after_colon integer trailing_comma call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() text_after_colon = raw_line(index(raw_line, ':')+1:) trailing_comma = index(text_after_colon, ',') if (trailing_comma == 0) then string_value = trim(adjustl((text_after_colon))) else string_value = trim(adjustl((text_after_colon(:trailing_comma-1)))) end if read(string_value, fmt=*) value_ end procedure #endif module procedure get_integer_with_character_key value_ = self%get_integer(string_t(key), mold) end procedure module procedure get_integer_array_with_character_key value_ = int(self%get_integer_array(string_t(key), mold)) end procedure module procedure get_integer_array value_ = int(self%get_real_array(key,mold=[0.])) end procedure module procedure get_real_array_with_character_key value_ = self%get_real_array(string_t(key), mold) end procedure module procedure get_double_precision_array_with_character_key value_ = self%get_double_precision_array(string_t(key), mold) end procedure module procedure get_real_array character(len=:), allocatable :: raw_line real, allocatable :: real_array(:) integer i call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() associate(colon => index(raw_line, ":")) associate(opening_bracket => colon + index(raw_line(colon+1:), "[")) associate(closing_bracket => opening_bracket + index(raw_line(opening_bracket+1:), "]")) i = 0 ! silence a harmless/bogus warning from gfortran associate(commas => count("," == [(raw_line(i:i), i=opening_bracket+1,closing_bracket-1)])) associate(num_inputs => commas + 1) allocate(real_array(num_inputs)) read(raw_line(opening_bracket+1:closing_bracket-1), fmt=*) real_array value_ = real_array end associate end associate end associate end associate end associate end procedure module procedure get_double_precision_array character(len=:), allocatable :: raw_line double precision, allocatable :: double_precision_array(:) integer i call_julienne_assert(self%get_json_key() .equalsExpected. key) raw_line = self%string() associate(colon => index(raw_line, ":")) associate(opening_bracket => colon + index(raw_line(colon+1:), "[")) associate(closing_bracket => opening_bracket + index(raw_line(opening_bracket+1:), "]")) i = 0 ! silence a harmless/bogus warning from gfortran associate(commas => count("," == [(raw_line(i:i), i=opening_bracket+1,closing_bracket-1)])) associate(num_inputs => commas + 1) allocate(double_precision_array(num_inputs)) read(raw_line(opening_bracket+1:closing_bracket-1), fmt=*) double_precision_array value_ = double_precision_array end associate end associate end associate end associate end associate end procedure module procedure string_t_eq_string_t lhs_eq_rhs = lhs%string() == rhs%string() end procedure module procedure string_t_eq_character lhs_eq_rhs = lhs%string() == rhs end procedure module procedure character_eq_string_t lhs_eq_rhs = lhs == rhs%string() end procedure module procedure string_t_ne_string_t lhs_ne_rhs = lhs%string() /= rhs%string() end procedure module procedure string_t_ne_character lhs_ne_rhs = lhs%string() /= rhs end procedure module procedure character_ne_string_t lhs_ne_rhs = lhs /= rhs%string() end procedure module procedure assign_string_t_to_character lhs = rhs%string() end procedure module procedure assign_character_to_string_t lhs%string_ = rhs end procedure module procedure string_t_cat_string_t lhs_cat_rhs = string_t(lhs%string_ // rhs%string_) end procedure module procedure string_t_cat_character lhs_cat_rhs = string_t(lhs%string_ // rhs) end procedure module procedure character_cat_string_t lhs_cat_rhs = string_t(lhs // rhs%string_) end procedure module procedure bracket character(len=:), allocatable :: actual_opening, actual_closing associate(opening_present => present(opening)) if (opening_present) then actual_opening = opening else actual_opening = "[" end if if (present(closing)) then actual_closing = closing else if(opening_present) then actual_closing = actual_opening else actual_closing = "]" end if end associate bracketed_self = string_t(actual_opening // self%string_ // actual_closing) end procedure end submodule julienne_string_s fortran-julienne-3.6.2/src/julienne/julienne_test_fixture_m.f900000664000175000017500000000225315151766762025064 0ustar alastairalastair! 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_mfortran-julienne-3.6.2/src/julienne/julienne_formats_m.F900000664000175000017500000000135715151766762023756 0ustar alastairalastair! 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_formats_m !! Useful strings for formatting `print` and `write` statements implicit none character(len=*), parameter :: csv = "(*(G25.20,:,','))" !! comma-separated values character(len=*), parameter :: cscv = "(*('(',G25.20,',',G25.20,')',:,',')))" !! comma-separated complex values interface pure module function separated_values(separator, mold) result(format_string) character(len=*), intent(in) :: separator class(*), intent(in) :: mold(..) character(len=:), allocatable :: format_string end function end interface end module julienne_formats_m fortran-julienne-3.6.2/src/julienne/julienne_test_suite_s.F900000664000175000017500000001745715151766762024511 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" submodule(julienne_test_suite_m) julienne_test_suite_s use assert_m use julienne_m, only : operator(.csv.) implicit none character(len=*), parameter :: test_suite_key = "test suite" character(len=*), parameter :: test_subjects_key = "test subjects" character(len=*), parameter :: copyright_and_license = & "! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute" // new_line('') & // "! Terms of use are as specified in LICENSE.txt" contains module procedure test_subjects subjects = self%test_subjects_ end procedure module procedure test_modules modules = self%test_subjects_ // "_test_m" end procedure module procedure test_types types = self%test_subjects_ // "_test_t" end procedure module procedure from_components allocate(test_suite%test_subjects_, source = test_subjects) end procedure module procedure from_file integer l logical test_suite_key_found test_suite_key_found = .false. associate(lines => file%lines()) do l=1,size(lines) if (lines(l)%get_json_key() == test_suite_key) then test_suite_key_found = .true. test_suite%test_subjects_ = lines(l+1)%get_json_value(string_t(test_subjects_key), mold=[string_t("")]) return end if end do end associate call_assert(test_suite_key_found) end procedure module procedure to_file character(len=*), parameter :: indent = repeat(" ",ncopies=4) file = file_t([ & string_t("{") & ,string_t(indent // '"' // test_suite_key// '": {') & , indent // indent // '"' // test_subjects_key // '" : [' // .csv. self%test_subjects_%bracket('"') // '],' & ,string_t(indent // '}') & ,string_t("}") & ]) end procedure module procedure driver_file integer i type(string_t), allocatable :: test_types(:), test_modules(:) test_types = self%test_types() ! GCC 14.2 blocks the use of an association test_modules = self%test_modules() ! GCC 14.2 blocks the use of an association file = file_t([ & string_t(copyright_and_license) // new_line('') & ,string_t( "program test_suite_driver") & ,string_t( " use julienne_m, only : test_fixture_t, test_harness_t") & ,[(string_t(" use ") // test_modules(i) // string_t(", only : ") // test_types(i), i=1, size(test_modules))] & ,string_t( " implicit none") // new_line('') & ,string_t( " associate(test_harness => test_harness_t([ &" ) & ,[(string_t(" test_fixture_t(") // test_types(1) // string_t("()) &"))] & ,[(string_t(" ,test_fixture_t(") // test_types(i) // string_t("()) &"), i=2, size(test_types ))] & ,string_t( " ]))" ) & ,string_t( " call test_harness%report_results" ) & ,string_t( " end associate" ) & ,string_t( "end program test_suite_driver") & ]) end procedure module procedure stub_file character(len=:), allocatable :: subject_module, subject_type, test_module, test_type subject_module = subject // "_m" subject_type = subject // "_t" test_module = subject // "_test_m" test_type = subject // "_test_t" file = file_t([ & string_t(copyright_and_license) // new_line('') & ,string_t("module ") // test_module & ,string_t(" use julienne_m, only : &") & ,string_t(" test_t, test_description_t, test_diagnosis_t, test_result_t &") & ,string_t(" ,operator(.approximates.), operator(.within.), operator(.all.), operator(//)") & ,string_t(" use " // subject_module // ", only : " // subject_type) & ,string_t(" implicit none") // new_line('') & ,string_t(" type, extends(test_t) :: ") // test_type & ,string_t(" contains") & ,string_t(" procedure, nopass :: subject") & ,string_t(" procedure, nopass :: results") & ,string_t(" end type") // new_line('') & ,string_t("contains") // new_line('') & ,string_t(" pure function subject() result(test_subject)") & ,string_t(" character(len=:), allocatable :: test_subject") & ,string_t(" test_subject = 'A ") // subject // "'" & ,string_t(" end function") // new_line('') & ,string_t(" function results() result(test_results)") & ,string_t(" type(") // test_type // ") " // subject // "_test" & ,string_t(" type(test_result_t), allocatable :: test_results(:)") & ,string_t(" test_results = ") // subject // "_test%run( & " & ,string_t(" [test_description_t('doing something', do_something) &") & ,string_t(" ,test_description_t('checking something', check_something) &") & ,string_t(" ,test_description_t('skipping something') &") & ,string_t(" ])") & ,string_t(" end function") // new_line('') & ,string_t(" function check_something() result(test_diagnosis)") & ,string_t(" type(test_diagnosis_t) test_diagnosis") & ,string_t(" type(") // subject_type // ") " // subject & ,string_t(" test_diagnosis = .all.( &") & ,string_t(" [22./7., 3.14159] .approximates. ") // subject // "%pi() .within. 0.001 &" & ,string_t(" ) // ' (pi approximation)'") & ,string_t(" end function") // new_line('') & ,string_t(" function do_something() result(test_diagnosis)") & ,string_t(" type(test_diagnosis_t) test_diagnosis") & ,string_t(" test_diagnosis = &") & ,string_t(" test_diagnosis_t(test_passed = 1 == 1, diagnostics_string = 'craziness ensued')") & ,string_t(" end function") // new_line('') & ,string_t("end module") & ]) end procedure module procedure write_driver integer file_unit, l type(string_t), allocatable :: test_modules(:), test_types(:) open(newunit=file_unit, file=file_name, form='formatted', status='unknown', action='write') write(file_unit, '(a)') copyright_and_license // new_line('') write(file_unit, '(a)') "program test_suite_driver" write(file_unit, '(a)') " use julienne_m, only : test_fixture_t, test_harness_t" block type(string_t) use_statement test_modules = self%test_modules() ! GCC 14.2 blocks the use of an association test_types = self%test_types() ! GCC 14.2 blocks the use of an association do l = 1, size(test_modules) use_statement = " use " // test_modules(l) // ", only : " // test_types(l) write(file_unit, '(a)') use_statement%string() end do end block write(file_unit, '(a)') " implicit none" // new_line('') write(file_unit, '(a)') " associate(test_harness => test_harness_t([ &" block type(string_t) fixture_constructor test_types = self%test_types() ! GCC 14.2 blocks the use of an association fixture_constructor = " test_fixture_t(" // test_types(1) // "()) &" write(file_unit, '(a)') fixture_constructor %string() do l = 2, size(test_modules) fixture_constructor= " ,test_fixture_t(" // test_types(l) // "()) &" write(file_unit, '(a)') fixture_constructor%string() end do end block write(file_unit, '(a)') " ]))" write(file_unit, '(a)') " call test_harness%report_results" write(file_unit, '(a)') " end associate" write(file_unit, '(a)') "end program test_suite_driver" close(file_unit) end procedure end submodule julienne_test_suite_s fortran-julienne-3.6.2/src/julienne/julienne_bin_m.f900000664000175000017500000000250515151766762023107 0ustar alastairalastair! 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_bin_m !! distribute item numbers across bins such that the number of items differs by at most 1 between any two bins implicit none private public :: bin_t type bin_t !! encapsulate a range of item numbers associated with a bin private integer first_, last_ contains procedure first procedure last end type interface bin_t elemental module function construct(num_items, num_bins, bin_number) result(bin) !! the result is a bin associated with a range of item numbers integer, intent(in) :: num_items, num_bins, bin_number type(bin_t) bin end function end interface interface elemental module function first(self) result(first_item_number) !! the result is the first item number associated with the given bin implicit none class(bin_t), intent(in) :: self integer first_item_number end function elemental module function last(self) result(last_item_number) !! the result is the last item number associated with the given bin implicit none class(bin_t), intent(in) :: self integer last_item_number end function end interface end module julienne_bin_m fortran-julienne-3.6.2/src/julienne/julienne_bin_s.F900000664000175000017500000000216615151766762023060 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt #include "julienne-assert-macros.h" submodule(julienne_bin_m) julienne_bin_s use julienne_assert_m, only : call_julienne_assert_ use julienne_test_diagnosis_m, only : operator(.isAtLeast.) implicit none contains module procedure construct call_julienne_assert(num_items .isAtLeast. num_bins) associate( remainder => mod(num_items, num_bins), items_per_bin => num_items/num_bins) if (bin_number <= remainder) then bin%first_ = 1 + (bin_number-1)*(items_per_bin+1) bin%last_ = bin_number*(items_per_bin+1) else bin%first_ = 1 + (remainder-1)*(items_per_bin+1) + 1 + (bin_number-remainder)*items_per_bin bin%last_ = remainder*(items_per_bin+1) + (bin_number-remainder)*items_per_bin end if end associate end procedure module procedure first first_item_number = self%first_ end procedure module procedure last last_item_number = self%last_ end procedure end submodule julienne_bin_s fortran-julienne-3.6.2/src/julienne/julienne_multi_image_s.F900000664000175000017500000000451315151766762024602 0ustar alastairalastair! 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" #include "assert_macros.h" submodule(julienne_multi_image_m) julienne_multi_image_s use assert_m implicit none contains module procedure internal_this_image # if !HAVE_MULTI_IMAGE_SUPPORT this_image_id = 1 # elif JULIENNE_PARALLEL_CALLBACKS if (associated(julienne_this_image)) then this_image_id = julienne_this_image() else this_image_id = 1 ! callback unset, assume single-image call_assert(internal_num_images() == 1) end if # else this_image_id = this_image() # endif end procedure module procedure internal_num_images # if !HAVE_MULTI_IMAGE_SUPPORT image_count = 1 # elif JULIENNE_PARALLEL_CALLBACKS if (associated(julienne_num_images)) then image_count = julienne_num_images() else image_count = 1 ! callback unset, assume single-image end if # else image_count = num_images() # endif end procedure module procedure internal_sync_all # if !HAVE_MULTI_IMAGE_SUPPORT ; ! nothing to do # elif JULIENNE_PARALLEL_CALLBACKS if (associated(julienne_sync_all)) then call julienne_sync_all() else ; ! assume single-image, no-op call_assert(internal_num_images() == 1) end if # else sync all # endif end procedure module procedure internal_co_sum_integer # if !HAVE_MULTI_IMAGE_SUPPORT ; ! nothing to do # elif JULIENNE_PARALLEL_CALLBACKS if (associated(julienne_co_sum_integer)) then call julienne_co_sum_integer(a, result_image) else ; ! assume single-image, no-op call_assert(internal_num_images() == 1) end if # else ! this branch is a bug workaround for ifx 2025.2 if (present(result_image)) then call co_sum(a, result_image) else call co_sum(a) end if # endif end procedure module procedure internal_error_stop # if JULIENNE_PARALLEL_CALLBACKS if (associated(julienne_error_stop)) then call julienne_error_stop(stop_code_char) else ; ! deliberate fall-thru end if # endif error stop stop_code_char end procedure end submodule julienne_multi_image_s fortran-julienne-3.6.2/LICENSE.txt0000664000175000017500000000656015151766762017042 0ustar alastairalastairBSD 3-Clause License **************************** *** Copyright Notice *** Julienne Copyright (c) 2024-2026, The Regents of the University of California, through Lawrence Berkeley National Laboratory (subject to receipt of any required approvals from the U.S. Dept. of Energy) and Sourcery Institute. All rights reserved. If you have questions about your rights to use or distribute this software, please contact Berkeley Lab's Intellectual Property Office at IPO@lbl.gov. NOTICE. This Software was developed under funding from the U.S. Department of Energy and the U.S. Government consequently retains certain rights. As such, the U.S. Government has been granted for itself and others acting on its behalf a paid-up, nonexclusive, irrevocable, worldwide license in the Software to reproduce, distribute copies to the public, prepare derivative works, and perform publicly and display publicly, and to permit others to do so. **************************** *** License Agreement *** Julienne Copyright (c) 2024-2026, The Regents of the University of California, through Lawrence Berkeley National Laboratory (subject to receipt of any required approvals from the U.S. Dept. of Energy) and Sourcery Institute. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: (1) Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. (2) Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. (3) Neither the name of the University of California, Lawrence Berkeley National Laboratory, U.S. Dept. of Energy, Sourcery Institute nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. You are under no obligation whatsoever to provide any bug fixes, patches, or upgrades to the features, functionality or performance of the source code ("Enhancements") to anyone; however, if you choose to make your Enhancements available either publicly, or directly to Lawrence Berkeley National Laboratory, without imposing a separate written license agreement for such Enhancements, then you hereby grant the following license: a non-exclusive, royalty-free perpetual license to install, use, modify, prepare derivative works, incorporate into other computer software, distribute, and sublicense such enhancements or derivative works thereof, in binary and source code form. fortran-julienne-3.6.2/doc/0000775000175000017500000000000015151766762015755 5ustar alastairalastairfortran-julienne-3.6.2/doc/parallel-testing-with-flang.md0000664000175000017500000000510615151766762023606 0ustar alastairalastairParallel Testing with Flang =========================== LLVM Flang 22 supports the native Fortran parallel programming model used by Julienne: features that enable launching multiple images, which are instances of a program. As of this writing, "Flang 22" refers to the main branch of [llvm-project](https://github.com/llvm/llvm-project), which when built from source, responds to `flang-new --version` with text that includes `22.0.0git`. To launch multi-image runs, Flang generates calls to the Parallel Runtime Interface for Fortran [(PRIF)](https://go.lbl.gov/prif). Using these features requires linking programs to a PRIF implementation such as [Caffeine](https://go.lbl.gov/caffeine). This document offers a rough sketch of a workflow for building LLVM Flang 22 on one platform. Rough Workflow -------------- Steps like those below have worked on a macOS 15.5 system with Apple Silicon and with the Homebrew package manager installed. If similar steps fail for you, please contact fortran@lbl.gov. ### Build a LLVM Flang ```bash brew install gcc@14 # (gcc@15 failed to build LLVM on the tested computer) git clone -b gcc14.3.0-julienne3.2.0-caffeine0.6.0 \ https://github.com/BerkeleyLab/flang-testing-project.git git clone https://github.com/rouson/handy-dandy chmod u+x handy-dandy/src/fresh-llvm-build.sh cd flang-testing-project ../handy-dandy/src/fresh-llvm-build.sh --prefix= cd .. ``` where angular brackets denote variables to replace with your chosen value. ### Build Caffeine and GASNet An `.install.sh` invocation of the form below _should_ install Caffeine and GASNet in `/lib`. ```bash git clone -b 0.6.0 https://github.com/BerkeleyLab/caffeine.git cd caffeine FC=/bin/flang-new \ CC=/bin/clang \ CXX=/bin/clang++ \ ./install.sh --prefix= cd .. ``` As of this writing, however, the above `install.sh` does not install the Caffeine library file due to an apparent `fpm` bug. Therefore, the next step is to find the resulting library. For example, use ``` find build -name libcaffeine.a ``` Then move `libcaffeine.a` to the `/lib` directory. ### Build and Test Julienne ``` git clone -b 3.2.0 https://github.com/BerkeleyLab/julienne.git cd julienne fpm test \ --compiler flang-new \ --flag "-O3 -DHAVE_MULTI_IMAGE_SUPPORT -fcoarray" \ --link-flag "-lcaffeine -lgasnet-smp-seq -L/lib" ``` If successful, the resulting output will not indicate any test failures, but will describe any tests that are skipped by default. fortran-julienne-3.6.2/doc/uml/0000775000175000017500000000000015151766762016552 5ustar alastairalastairfortran-julienne-3.6.2/doc/uml/sequence-diagram.md0000664000175000017500000000074315151766762022312 0ustar alastairalastairExample Sequence Diagram ------------------------ ```mermaid sequenceDiagram main->>specimen_test_t: report(passes, tests) test_t ->>command_line_t: flag_value("--contains") command_line_t ->> specimen_test_t : test_description_substring test_t ->> test_t : subject test_t ->> test_t : results test_t ->> test_description_t : construct test_t ->> test_result_t : construct test_t ->> test_result_t : characterize test_t ->> test_result_t : passed fortran-julienne-3.6.2/doc/uml/class-diagram.md0000664000175000017500000000450015151766762021602 0ustar alastairalastairJulienne Classes ---------------- Testing centers around the `test_t` abstract derived type. Users define a collection of tests by defining `test_t` child types. This obligates the child type to define `test_t`'s deferred bindings: `subject` and `results`. The `subject` function producdes a `character` string result describing what is being tested -- often a derived type or module. The `results` function passes a `test_descripton_t` array to a child instance's inherited type-bound `run` function. The `run` funtion produces a `test_result_t` array result. ```mermaid classDiagram test_t --> test_description_t : "'run' accepts array of" test_t --> test_result_t : "'run' produces array of" class test_t{ <> + subject() character * + results() test_result_t * + report(passes : integer, tests : integer, skips : integer) } class string_t{ + string_t(character) : string_t + string_t(complex) : string_t + string_t(double precision) : string_t + string_t(integer) : string_t + string_t(logical) : string_t + string_t(real) : string_t + operator(.cat.) : string_t + operator(.csv.) : string_t + operator(.sv.) : string_t + string() : character + array_of_strings(string_t) : string_t + bracket(opening : character, closing : closing) : string_t } class test_diagnosis_t{ + test_diagnosis_t(test_passed : logical, diagnostics_string : character) test_diagnosis_t + test_diagnosis_t(test_passed : logical, diagnostics_string : string_t) test_diagnosis_t + test_passed() logical + diagnsotics_string() string_t } class test_result_t{ + test_result_t(description : character, diagnosis : test_diagnosis_t) test_result_t + test_result_t(description : string_t, diagnosis : test_diagnosis_t) test_result_t + characterize() : character + description_contains(string_t) logical + description_contains(character) logical + passed() logical + skipped() logical } class test_description_t{ + test_description_t(description : character, diagnosis_function : procedure(diagnosis_function_i)) test_description_t + test_description_t(description : string_t, diagnosis_function : procedure(diagnosis_function_i)) test_description_t + run() test_result_t + contains_text(character) logical + contains_text(string_t) logical + operator(==) logical } fortran-julienne-3.6.2/test/0000775000175000017500000000000015151766762016167 5ustar alastairalastairfortran-julienne-3.6.2/test/driver.F900000664000175000017500000000356315151766762017751 0ustar alastairalastair! 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 !! Julienne test-suite driver ! Test infrastructure: use julienne_m, only : test_fixture_t, test_harness_t ! 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 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() ! 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( multi_image_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( command_line_test_t()) & ])) call test_harness%report_results end associate end program fortran-julienne-3.6.2/test/idiomatic_assertion_failure_test.F900000664000175000017500000000233415151766762025250 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt #include "julienne-assert-macros.h" #include "language-support.F90" program idiomatic_assertion_failure_test !! Conditionally test an assertion that is hardwired to fail. use julienne_m, only : call_julienne_assert_, command_line_t, operator(.equalsExpected.) implicit none #if HAVE_MULTI_IMAGE_SUPPORT associate(command_line => command_line_t(), me => this_image()) #else associate(command_line => command_line_t(), me => 1) #endif if (.not. command_line%argument_present([character(len=len("--help"))::"--help","-h"])) then #if TEST_INTENTIONAL_FAILURE && ASSERTIONS if (me==1) print '(a)', new_line('') // 'Test the intentional failure of an idiomatic assertion: ' // new_line('') call_julienne_assert(1 .equalsExpected. 2) #else if (me==1) print '(a)', & new_line('') // & 'Skipping the test in ' // __FILE__ // '.' // new_line('') // & 'Add the following to your fpm command to test assertion failures: --flag "-DASSERTIONS -DTEST_INTENTIONAL_FAILURE"' // & new_line('') #endif end if end associate end program fortran-julienne-3.6.2/test/modules/0000775000175000017500000000000015151766762017637 5ustar alastairalastairfortran-julienne-3.6.2/test/modules/test_test_m.F900000664000175000017500000000262215151766762022453 0ustar alastairalastair! 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 test_test_m !! Conditionally test that failure of a test on only one image is reported as a test failure use julienne_m, only : & operator(.expect.) & ,usher & ,test_description_t & ,test_diagnosis_t & ,test_result_t & ,test_t implicit none private public :: test_test_t type, extends(test_t) :: test_test_t contains procedure, nopass :: subject procedure, nopass :: results end type contains pure function subject() result(specimen) character(len=:), allocatable :: specimen specimen = "The test_t type" end function function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_test_t) test_test test_results = test_test%run([ & test_description_t("(this is an intentional failure intended for visual interpretation)", usher(check_one_image_fails)) & ]) end function function check_one_image_fails() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis #if HAVE_MULTI_IMAGE_SUPPORT associate(me => this_image(), images => num_images()) #else associate(me => 1, images => 1) #endif test_diagnosis = .expect. (me /= images) end associate end function end module test_test_m fortran-julienne-3.6.2/test/modules/formats_test_m.F900000664000175000017500000001361015151766762023146 0ustar alastairalastair! 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 formats_test_m !! Verify that format strings provide the desired formatting use julienne_m, only : & operator(.csv.) & ,separated_values & ,string_t & ,test_description_t & ,test_diagnosis_t & ,test_result_t & ,usher & ,test_t implicit none private public :: formats_test_t type, extends(test_t) :: formats_test_t contains procedure, nopass :: subject procedure, nopass :: results end type contains pure function subject() result(specimen) character(len=:), allocatable :: specimen specimen = "A format string" end function function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_description_t), allocatable :: test_descriptions(:) type(formats_test_t) formats_test test_descriptions = [ & test_description_t(string_t("yielding a comma-separated list of real numbers"), usher(check_csv_reals)), & test_description_t(string_t("yielding a comma-separated list of double-precision numbers"), usher(check_csv_double_precision)), & test_description_t(string_t("yielding a space-separated list of complex numbers"), usher(check_space_separated_complex)), & test_description_t(string_t("yielding a comma- and space-separated list of character values"), usher(check_csv_character)), & test_description_t(string_t("yielding a new-line-separated list of integer numbers"), usher(check_new_line_separated_integers)) & ] test_results = formats_test%run(test_descriptions) end function function check_csv_reals() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis character(len=100) captured_output real, parameter :: expected_values(*) = [0.,1.,2.], tolerance = 1.E-08 real zero, one, two write(captured_output, fmt = separated_values(separator=",", mold=[real::])) expected_values associate(first_comma => index(captured_output, ',')) associate(second_comma => first_comma + index(captured_output(first_comma+1:), ',')) read(captured_output(:first_comma-1), *) zero read(captured_output(first_comma+1:second_comma-1), *) one read(captured_output(second_comma+1:), *) two test_diagnosis = test_diagnosis_t( & test_passed = all(abs([zero, one, two] - expected_values) < tolerance) & ,diagnostics_string = "expected " // .csv. string_t(expected_values) // "; actual " // .csv. string_t([zero, one, two]) & ) end associate end associate end function function check_csv_double_precision() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis character(len=200) captured_output integer, parameter :: dp = kind(0D0) double precision, parameter :: pi = 3.14159265358979323846_dp double precision, parameter :: e = 2.71828182845904523536_dp double precision, parameter :: phi = 1.61803398874989484820_dp double precision, parameter :: values_to_write(*) = [double precision:: e, pi, phi], tolerance = 1.E-16 double precision values_read(size(values_to_write)) write(captured_output, fmt = separated_values(separator=",", mold=[double precision::])) values_to_write associate(first_comma => index(captured_output, ',')) associate(second_comma => first_comma + index(captured_output(first_comma+1:), ',')) read(captured_output(:first_comma-1), *) values_read(1) read(captured_output(first_comma+1:second_comma-1), *) values_read(2) read(captured_output(second_comma+1:), *) values_read(3) test_diagnosis = test_diagnosis_t( & test_passed = all(abs(values_to_write - values_read) < tolerance) & ,diagnostics_string = "expected " // .csv. string_t(values_to_write) // "; actual " // .csv. string_t(values_read) & ) end associate end associate end function function check_space_separated_complex() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis character(len=100) captured_output character(len=:), allocatable :: i_string, one_string complex, parameter :: i = (0.,1.), one = (1.,0.) complex i_read, one_read real, parameter :: tolerance = 1.E-08 write(captured_output, fmt = separated_values(separator=" ", mold=[complex::])) i,one i_string = captured_output(:index(captured_output,")")) one_string = captured_output(len(i_string)+1:) read(i_string,*) i_read read(one_string,*) one_read test_diagnosis = test_diagnosis_t( & test_passed = i_read == i .and. one_read == one & ,diagnostics_string = "expected " // .csv. string_t([i,one]) // "; actual " // .csv. string_t([i_read, one_read]) & ) end function function check_csv_character() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis character(len=200) captured_output character(len=*), parameter :: expected_output = "Yodel, Ay, Hee, Hoo!" write(captured_output, fmt = separated_values(separator=", ", mold=[character::])) "Yodel", "Ay", "Hee", "Hoo!" test_diagnosis = test_diagnosis_t( & test_passed = expected_output == captured_output & ,diagnostics_string = "expected '" // expected_output // "; actual " // captured_output & ) end function function check_new_line_separated_integers() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis character(len=100) captured_output character(len=*), parameter :: expected_output = "0" // new_line("") // "1" // new_line("") // "2" write(captured_output, fmt = separated_values(separator=new_line(""), mold=[integer::])) [0,1,2] test_diagnosis = test_diagnosis_t( & test_passed = captured_output == expected_output & ,diagnostics_string = "expected " // expected_output // "; actual " // captured_output & ) end function end module formats_test_m fortran-julienne-3.6.2/test/modules/assert_test_m.F900000664000175000017500000000462415151766762023001 0ustar alastairalastair! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt #include "language-support.F90" #include "julienne-assert-macros.h" #include "assert_macros.h" module assert_test_m !! Test Julienne's call_julienne_assert generic interface use assert_m ! Import call_assert macro use julienne_m, only : & call_julienne_assert_ & ,julienne_assert & ,operator(.equalsExpected.) & ,test_diagnosis_t & ,test_t & ,usher & ,test_description_t & ,test_result_t & ,operator(.approximates.) & ,operator(.within.) implicit none private public :: assert_test_t type, extends(test_t) :: assert_test_t contains procedure, nopass :: subject procedure, nopass :: results end type contains pure function subject() result(specimen) character(len=:), allocatable :: specimen specimen = "The julienne_assert subroutine" end function function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_description_t), allocatable :: test_descriptions(:) type(assert_test_t) assert_test test_descriptions = [ & test_description_t("invocation via the call_julienne_assert macro", usher(check_call_julienne_assert_macro)) & ,test_description_t("invocation via direct call", usher(check_julienne_assert_call)) & ,test_description_t("invocation removal after undefining the ASSERTIONS macro", usher(check_macro_removal)) & ] test_results = assert_test%run(test_descriptions) end function function check_call_julienne_assert_macro() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis call_julienne_assert(1. .approximates. 2. .within. 3.) test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") end function function check_julienne_assert_call() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis call julienne_assert(1. .approximates. 2. .within. 3.) test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") end function function check_macro_removal() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis #undef ASSERTIONS #include "julienne-assert-macros.h" call_julienne_assert(5 .equalsExpected. 9) test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="") end function end module assert_test_m fortran-julienne-3.6.2/test/modules/test_description_test_m.F900000664000175000017500000001004115151766762025050 0ustar alastairalastair! 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 test_description_test_m !! Verify test_description_t object behavior use iso_c_binding, only : c_funloc use julienne_m, only : & string_t & ,diagnosis_function_i & ,test_result_t & ,test_description_t & ,test_diagnosis_t & ,usher & ,operator(.also.) & ,test_t implicit none private public :: test_description_test_t type, extends(test_t) :: test_description_test_t contains procedure, nopass :: subject procedure, nopass :: results end type contains pure function subject() result(specimen) character(len=:), allocatable :: specimen specimen = "The test_description_t type" end function function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_description_t), allocatable :: test_descriptions(:) type(test_description_test_t) test_description_test test_descriptions = [ & test_description_t("identical construction from equivalent arguments", usher(check_constructors_match)) & ] test_results = test_description_test%run(test_descriptions) end function function check_constructors_match() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis procedure(diagnosis_function_i), pointer :: tautology_ptr tautology_ptr => tautology test_diagnosis = test_diagnosis_t( & test_passed = test_description_t("foo", tautology_ptr) == test_description_t(string_t("foo"), tautology_ptr) & ,diagnostics_string= 'test_description_t("foo", tautology_ptr) /= test_description_t(string_t("foo"), tautology_ptr)'& ) test_diagnosis = test_diagnosis_t( & test_passed = .not. (test_description_t("foo", tautology_ptr) == test_description_t("foo")) & ,diagnostics_string= 'test_description_t("foo", tautology_ptr) == test_description_t("foo")'& ) #if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY test_diagnosis = test_diagnosis .also. test_diagnosis_t( & test_passed = test_description_t("foo", tautology) == test_description_t(string_t("foo"), tautology) & ,diagnostics_string = 'test_description_t("foo", tautology) /= test_description_t(string_t("foo"), tautology)' & ) test_diagnosis = test_diagnosis .also. test_diagnosis_t( & test_passed = test_description_t("foo", tautology) == test_description_t("foo", tautology_ptr) & ,diagnostics_string = 'test_description_t("foo", tautology) /= test_description_t("foo", tautology_ptr)' & ) #endif test_diagnosis = test_diagnosis .also. test_diagnosis_t( & test_passed = test_description_t("foo", tautology_ptr) == test_description_t("foo", usher(tautology)) & ,diagnostics_string= 'test_description_t("foo", tautology_ptr) /= test_description_t("foo", usher(tautology))'& ) test_diagnosis = test_diagnosis .also. test_diagnosis_t( & test_passed = test_description_t("foo", tautology_ptr) == test_description_t("foo", c_funloc(tautology_ptr)) & ,diagnostics_string= 'test_description_t("foo", tautology_ptr) /= test_description_t("foo", c_funloc(tautology))'& ) test_diagnosis = test_diagnosis .also. test_diagnosis_t( & test_passed = test_description_t(string_t("foo"), tautology_ptr) == test_description_t(string_t("foo"), usher(tautology)) & ,diagnostics_string= 'test_description_t(string_t("foo"), tautology_ptr) /= test_description_t(string_t("foo"), usher(tautology))'& ) test_diagnosis = test_diagnosis .also. test_diagnosis_t( & test_passed = test_description_t(string_t("foo"), tautology_ptr) == test_description_t(string_t("foo"), c_funloc(tautology_ptr)) & ,diagnostics_string= 'test_description_t(string_t("foo"), tautology_ptr) /= test_description_t(string_t("foo"), c_funloc(tautology))'& ) contains type(test_diagnosis_t) function tautology() tautology = test_diagnosis_t(.true.,"") end function end function end module test_description_test_m fortran-julienne-3.6.2/test/modules/multi_image_test_m.F900000664000175000017500000001313415151766762023770 0ustar alastairalastair! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt #include "language-support.F90" ! We normally only test the JULIENNE_PARALLEL_CALLBACKS feature ! when HAVE_MULTI_IMAGE_SUPPORT is also enabled, but this test ! can also be force-enabled via -DTEST_PARALLEL_CALLBACKS #if JULIENNE_PARALLEL_CALLBACKS && HAVE_MULTI_IMAGE_SUPPORT #define TEST_PARALLEL_CALLBACKS 1 #endif module multi_image_test_m !! Test JULIENNE_PARALLEL_CALLBACKS support use julienne_m, only : & operator(.also.) & ,operator(.equalsExpected.) & ,operator(.isAtLeast.) & #if TEST_PARALLEL_CALLBACKS ,julienne_this_image & ,julienne_num_images & ,julienne_sync_all & ,julienne_co_sum_integer & ,julienne_error_stop & #endif ,test_diagnosis_t & ,test_t & ,usher & ,test_description_t & ,test_result_t implicit none private public :: multi_image_test_t, multi_image_setup type, extends(test_t) :: multi_image_test_t contains procedure, nopass :: subject procedure, nopass :: results end type logical, save :: setup_called = .false. integer, save :: this_image_cnt = 0 & ,num_images_cnt = 0 & ,sync_all_cnt = 0 & ,co_sum_integer_cnt = 0 contains subroutine multi_image_setup() # if TEST_PARALLEL_CALLBACKS julienne_this_image => julienne_callback_this_image julienne_num_images => julienne_callback_num_images julienne_sync_all => julienne_callback_sync_all julienne_co_sum_integer => julienne_callback_co_sum_integer julienne_error_stop => julienne_callback_error_stop # endif setup_called = .true. end subroutine pure function subject() result(specimen) character(len=:), allocatable :: specimen specimen = "JULIENNE_PARALLEL_CALLBACKS support" end function function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_description_t), allocatable :: test_descriptions(:) type(multi_image_test_t) multi_image_test ! some tests are conditional on JULIENNE_PARALLEL_CALLBACKS and otherwise skipped # if TEST_PARALLEL_CALLBACKS # define MAYBE(fn) , usher(fn) # else # define MAYBE(fn) # endif test_descriptions = [ & test_description_t("callback setup was performed", usher(check_julienne_callback_setup)) & ,test_description_t("callback pointers are still set" MAYBE(check_julienne_callback_ptrs)) & ,test_description_t("callback pointers are invoked as expected" MAYBE(check_julienne_callback_invocation)) & ] test_results = multi_image_test%run(test_descriptions) end function function check_julienne_callback_setup() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = setup_called end function #if TEST_PARALLEL_CALLBACKS function check_julienne_callback_ptrs() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = .true. test_diagnosis = test_diagnosis .also. & associated(julienne_this_image, julienne_callback_this_image) .also. & associated(julienne_num_images, julienne_callback_num_images) .also. & associated(julienne_sync_all, julienne_callback_sync_all) .also. & associated(julienne_co_sum_integer, julienne_callback_co_sum_integer) .also. & associated(julienne_error_stop, julienne_callback_error_stop) end function function check_julienne_callback_invocation() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis ! These callback properties check undocumented internal details # if HAVE_MULTI_IMAGE_SUPPORT test_diagnosis = & (this_image_cnt .isAtLeast. 1) & .also. (num_images_cnt .isAtLeast. 1) & .also. (co_sum_integer_cnt .isAtLeast. 1) & # if ASYNCHRONOUS_DIAGNOSTICS .also. (sync_all_cnt .equalsExpected. 0) # else .also. (sync_all_cnt .isAtLeast. 1) # endif # else test_diagnosis = & (this_image_cnt .equalsExpected. 0) & .also. (num_images_cnt .equalsExpected. 0) & .also. (co_sum_integer_cnt .equalsExpected. 0) & .also. (sync_all_cnt .equalsExpected. 0) # endif end function ! --- callback functions -- ! Currently just force trivial singleton runs function julienne_callback_this_image() result(this_image_id) implicit none integer :: this_image_id this_image_cnt = this_image_cnt + 1 # if HAVE_MULTI_IMAGE_SUPPORT this_image_id = this_image() # else this_image_id = 1 # endif end function function julienne_callback_num_images() result(image_count) implicit none integer :: image_count num_images_cnt = num_images_cnt + 1 # if HAVE_MULTI_IMAGE_SUPPORT image_count = num_images() # else image_count = 1 # endif end function subroutine julienne_callback_sync_all() implicit none sync_all_cnt = sync_all_cnt + 1 # if HAVE_MULTI_IMAGE_SUPPORT sync all # endif end subroutine subroutine julienne_callback_co_sum_integer(a, result_image) implicit none integer, intent(inout), target :: a(:) integer, intent(in), optional :: result_image co_sum_integer_cnt = co_sum_integer_cnt + 1 # if HAVE_MULTI_IMAGE_SUPPORT if (present(result_image)) then call co_sum(a, result_image) else call co_sum(a) end if # endif end subroutine subroutine julienne_callback_error_stop(stop_code_char) implicit none character(len=*), intent(in) :: stop_code_char error stop stop_code_char end subroutine #endif end module multi_image_test_m fortran-julienne-3.6.2/test/modules/string_test_m.F900000664000175000017500000005367415151766762023017 0ustar alastairalastair! 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 string_test_m use assert_m, only : assert use iso_c_binding, only : c_bool, c_size_t use julienne_m, only : & test_t & ,test_result_t & ,test_description_t & ,test_diagnosis_t & ,usher & ,string_t & ,operator(.all.) & ,operator(.also.) & ,operator(.approximates.) & ,operator(.cat.) & ,operator(.csv.) & ,operator(.equalsExpected.) & ,operator(.sv.) & ,operator(.within.) implicit none private public :: string_test_t type, extends(test_t) :: string_test_t contains procedure, nopass :: subject procedure, nopass :: results end type contains pure function subject() result(specimen) character(len=:), allocatable :: specimen specimen = "The string_t type" end function function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_description_t), allocatable :: test_descriptions(:) type(string_test_t) string_test test_descriptions = [ & test_description_t("is_allocated() result .true. if & only if the string_t component(s) is/are allocated", usher(check_allocation))& ,test_description_t("extracting a key string from a colon-separated key/value pair", usher( extracts_key))& ,test_description_t("extracting double-precision value from colon-separated key/value pair", usher(extracts_double_precision_value))& ,test_description_t("extracting a real value from a colon-separated key/value pair", usher( extracts_real_value))& ,test_description_t("extracting a character value from a colon-separated key/value pair", usher( extracts_character_value))& ,test_description_t("extracting a string value from a colon-separated key/value pair", usher( extracts_string_value))& ,test_description_t("extracting an integer value from a colon-separated key/value pair", usher( extracts_integer_value))& ,test_description_t("extracting a logical value from a colon-separated key/value pair", usher( extracts_logical_value))& ,test_description_t("extracting an integer array value from a colon-separated key/value pair", usher( extracts_integer_array_value))& ,test_description_t("extracting an real array value from a colon-separated key/value pair", usher( extracts_real_array_value))& ,test_description_t("extracting a double-precision array from a colon-separated key/value pair", usher( extracts_dp_array_value))& ,test_description_t('supporting operator(==) for string_t and character operands', usher( supports_equivalence_operator))& ,test_description_t('supporting operator(/=) for string_t and character operands', usher( supports_non_equivalence_operator))& ,test_description_t('assigning a string_t object to a character variable', usher( assigns_string_t_to_character))& ,test_description_t('assigning a character variable to a string_t object', usher( assigns_character_to_string_t))& ,test_description_t('supporting operator(//) for string_t and character operands', usher( supports_concatenation_operator))& ,test_description_t('constructing from a default integer and an integer(c_size_t)', usher( constructs_from_integers))& ,test_description_t('constructing from a default real value', usher( constructs_from_default_real))& ,test_description_t('constructing from a double-precision value', usher( constructs_from_double_precision))& ,test_description_t('constructing from a default-precision complex value', usher( constructs_from_default_complex))& ,test_description_t('constructing from a default-kind logical value', usher( constructs_from_default_logical))& ,test_description_t('constructing from a logical(c_bool) value', usher( constructs_from_logical_c_bool))& ,test_description_t('extracting a file base name', usher( extracts_file_base_name))& ,test_description_t('extracting a file name extension', usher( extracts_file_name_extension))& ,test_description_t('supporting unary operator(.cat.) for array arguments', usher( concatenates_elements))& ,test_description_t('constructing bracketed strings', usher( brackets_strings))& ,test_description_t("extracting a string_t array value from a colon-separated key/value pair", usher( extracts_string_array_value))& ,test_description_t('constructing (comma-)separated values from character or string_t arrays', usher( constructs_separated_values))& ,test_description_t('constructing from a double-precision complex value', usher( constructs_from_double_precision_complex))& ] test_results = string_test%run(test_descriptions) end function pure function check_allocation() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis type(string_t) :: scalar_not_allocated, scalar_allocated, array_allocated(2), array_not_allocated(2) scalar_allocated = string_t("") array_allocated = [string_t("yada yada"), string_t("blah blah blah")] associate(not_any_allocated => .not. any([scalar_not_allocated%is_allocated(), array_not_allocated%is_allocated()])) associate(all_allocated => all([scalar_allocated%is_allocated(), array_allocated%is_allocated()])) test_diagnosis = test_diagnosis_t( & test_passed = not_any_allocated .and. all_allocated & ,diagnostics_string = "expected .true., true.; actual " // string_t(not_any_allocated) // string_t(all_allocated) & ) end associate end associate end function function extracts_key() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(line => string_t('"foo" : "bar"')) test_diagnosis = line%get_json_key() .equalsExpected. "foo" end associate end function function extracts_double_precision_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis double precision, parameter :: tolerance = 1D-16 associate(line => string_t('"pi" : 3.141592653589793D0')) test_diagnosis = line%get_json_value(key="pi", mold=0.D0) .approximates. 3.141592653589793D0 .within. tolerance end associate end function function extracts_real_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis real, parameter :: tolerance = 1E-08 associate(line => string_t('"pi" : 3.14159')) associate(json_value => line%get_json_value(key=string_t("pi"), mold=1.)) test_diagnosis = json_value .approximates. 3.14159 .within. tolerance end associate end associate end function function extracts_character_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(line => string_t('"foo" : "bar"'), line_with_comma => string_t('"foo" : "bar",')) test_diagnosis = (line%get_json_value( key= "foo" , mold="") .equalsExpected. "bar") & .also. (line_with_comma%get_json_value(key= "foo" , mold="") .equalsExpected. "bar") & .also. (line%get_json_value( key=string_t("foo"), mold="") .equalsExpected. "bar") & .also. (line_with_comma%get_json_value(key=string_t("foo"), mold="") .equalsExpected. "bar") end associate end function function extracts_string_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(line => string_t('"foo" : "bar"'), line_with_comma => string_t('"foo" : "bar",')) test_diagnosis = (line%get_json_value( key= "foo" , mold=string_t("")) .equalsExpected. "bar") & .also. (line_with_comma%get_json_value(key= "foo" , mold=string_t("")) .equalsExpected. "bar") & .also. (line%get_json_value( key=string_t("foo"), mold=string_t("")) .equalsExpected. "bar") & .also. (line_with_comma%get_json_value(key=string_t("foo"), mold=string_t("")) .equalsExpected. "bar") end associate end function function extracts_integer_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(line => string_t('"an integer" : 99')) associate(json_value => line%get_json_value(key=string_t("an integer"), mold=0)) test_diagnosis = test_diagnosis_t( & test_passed = json_value == 99 & ,diagnostics_string = "expected 99, actual " // string_t(json_value) & ) end associate end associate end function function extracts_logical_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate( & key_true_pair => string_t('"yada yada" : true'), & key_false_pair => string_t('"blah blah" : false'), & trailing_comma => string_t('"trailing comma" : true,') & ) associate( & true => key_true_pair%get_json_value(key=string_t("yada yada"), mold=.true.) & ,true_too => trailing_comma%get_json_value(key=string_t("trailing comma"), mold=.true.) & ,false => key_false_pair%get_json_value(key=string_t("blah blah"), mold=.true.) & ) test_diagnosis = test_diagnosis_t( & test_passed = all([true, true_too, .not. false]) & ,diagnostics_string = "expected T,T,T; actual " // .csv. string_t([true, true_too, .not. false]) & ) end associate end associate end function function extracts_string_array_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(key_string_array_pair => string_t('"lead singer" : ["stevie", "ray", "vaughn"],')) associate(string_array => key_string_array_pair%get_json_value(key="lead singer", mold=[string_t::])) test_diagnosis = .all. (string_array .equalsExpected. [string_t("stevie"), string_t("ray"), string_t("vaughn")]) end associate end associate end function function extracts_integer_array_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(key_integer_array_pair => string_t('"some key" : [1, 2, 3],')) associate(integer_array => key_integer_array_pair%get_json_value(key=string_t("some key"), mold=[integer::])) test_diagnosis = .all. (integer_array .equalsExpected. [1,2,3]) end associate end associate end function function extracts_real_array_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis real, parameter :: tolerance = 1E-08 associate(key_real_array_pair => string_t('"a key" : [1., 2., 4.],')) associate(real_array => key_real_array_pair%get_json_value(key=string_t("a key"), mold=[real::])) test_diagnosis = test_diagnosis_t( & test_passed = all(abs(real_array - [1., 2., 4.]) < tolerance) & ,diagnostics_string = "expected 1,2,3; actual " // .csv. string_t(real_array) & ) end associate end associate end function function extracts_dp_array_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis double precision, parameter :: tolerance = 1E-16 associate(key_dp_array_pair => string_t('"a key" : [1.D0, 2.D0, 4.D0],')) associate(dp_array => key_dp_array_pair%get_json_value(key=string_t("a key"), mold=[double precision::])) test_diagnosis = test_diagnosis_t( & test_passed = all(abs(dp_array - [1D0, 2D0, 4D0]) < tolerance) & ,diagnostics_string = "expected 1.,2.,3.; actual " // .csv. string_t(dp_array) & ) end associate end associate end function function supports_equivalence_operator() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(comparisons => [ string_t("abcdefg") == string_t("abcdefg") & ,string_t("xyz pdq") == "xyz pdq" & , "123.456" == string_t("123.456") & , "123.456" == string_t("123" )]) test_diagnosis = test_diagnosis_t( & test_passed = all(comparisons .eqv. [.true.,.true.,.true.,.false.]) & ,diagnostics_string = "expected T,T,T,F; actual " // .csv. string_t([comparisons(1:3), .not. comparisons(4)]) & ) end associate end function function supports_non_equivalence_operator() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(non_equivalent_strings => [string_t("abcdefg") /= string_t("xyz pdq") & ,string_t("xyz pdq") /= "abcdefg" & , "123.456" /= string_t("456.123") & , "123.456" /= string_t("123.456")]) test_diagnosis = test_diagnosis_t( & test_passed = all(non_equivalent_strings .eqv. [.true.,.true.,.true.,.false.]) & ,diagnostics_string = "expected T,T,T,F; actual " // .csv. string_t(non_equivalent_strings) & ) end associate end function function assigns_string_t_to_character() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis character(len=:), allocatable :: lhs associate(rhs => string_t("ya don't say")) lhs = rhs test_diagnosis = test_diagnosis_t( & test_passed = lhs == rhs & ,diagnostics_string = "expected lhs == rhs; actual lhs = " // lhs // ", rhs = " // rhs & ) end associate end function function assigns_character_to_string_t() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis character(len=*), parameter :: rhs = "well, alrighty then" type(string_t) lhs lhs = rhs test_diagnosis = test_diagnosis_t( & test_passed = lhs == rhs & ,diagnostics_string = "expected lhs == rhs; actual lhs = " // lhs // ", rhs = " // rhs & ) end function function supports_concatenation_operator() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis character(len=*), parameter :: prefix = "foo", postfix="bar", expected = "foo yada yada bar" associate(infix => string_t(" yada yada ")) associate(string_string_string => prefix // infix // postfix, string_character_string => prefix // infix%string() // postfix) test_diagnosis = test_diagnosis_t( & test_passed = all([string_string_string == expected, string_character_string == expected]) & ,diagnostics_string = "expected '"// expected // "', actual " // string_string_string // "," // string_character_string & ) end associate end associate end function function constructs_from_integers() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = (string_t(1234567890) .equalsExpected. "1234567890") & .also. (string_t(1234567890123456789_c_size_t) .equalsExpected. "1234567890123456789") end function function constructs_from_default_real() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis real, parameter :: real_value = -1./1024. ! use a negative power of 2 for an exactly representable rational number real, parameter :: tolerance = 0. real read_value character(len=:), allocatable :: character_representation associate(string => string_t(real_value)) character_representation = string%string() read(character_representation, *) read_value test_diagnosis = read_value .approximates. real_value .within. tolerance end associate end function function constructs_from_double_precision() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis double precision, parameter :: expected_value = -1D0/1024D0 ! use a negative power of 2 for an exactly representable rational number double precision, parameter :: tolerance = 0D0 double precision read_value character(len=:), allocatable :: character_representation associate(string => string_t(expected_value)) character_representation = string%string() read(character_representation, *) read_value test_diagnosis = read_value .approximates. expected_value .within. tolerance end associate end function function constructs_from_default_complex() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis real, parameter :: real_value = -1./1024. ! use a negative power of 2 for an exactly representable rational number real, parameter :: tolerance = 1E-08 complex, parameter :: z = (real_value, real_value) complex read_value character(len=:), allocatable :: character_representation associate(string => string_t(z)) character_representation = string%string() read(character_representation, *) read_value test_diagnosis = test_diagnosis_t( & test_passed = abs(read_value - z) < tolerance & ,diagnostics_string = "expected '"// string_t(z) // "', actual " // string_t(read_value) & ) end associate end function function constructs_from_double_precision_complex() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis double precision, parameter :: double_precision_value = -1D0/1024D0 ! use a negative power of 2 for an exactly representable rational number double precision, parameter :: tolerance = 1E-16 complex(kind(1D0)), parameter :: z = (double_precision_value, double_precision_value) complex(kind(1D0)) read_value character(len=:), allocatable :: character_representation associate(string => string_t(z)) character_representation = string%string() read(character_representation, *) read_value test_diagnosis = test_diagnosis_t( & test_passed = abs(read_value - z) < tolerance & ,diagnostics_string = "expected '"// string_t(z) // "', actual " // string_t(read_value) & ) end associate end function function constructs_from_default_logical() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(true => string_t(.true.), false => string_t(.false.)) test_diagnosis = test_diagnosis_t( & test_passed = all([true%string() == "T", false%string() == "F"]) & ,diagnostics_string = "expected T, F; actual '"// true%string() // ", " // false%string() & ) end associate end function function constructs_from_logical_c_bool() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(true => string_t(.true._c_bool), false => string_t(.false._c_bool)) test_diagnosis = test_diagnosis_t( & test_passed = true%string() == "T" .and. false%string() == "F" & ,diagnostics_string = "expected T, F; actual '"// true%string() // ", " // false%string() & ) end associate end function function extracts_file_base_name() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis character(len=*), parameter :: expected = "foo .bar" associate(string => string_t(" foo .bar.too ")) associate(base_name => string%base_name()) test_diagnosis = test_diagnosis_t( & test_passed = base_name == expected & ,diagnostics_string = "expected "// expected // ", actual " // base_name & ) end associate end associate end function function extracts_file_name_extension() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(string => string_t(" foo .bar.too ")) test_diagnosis = string%file_extension() .equalsExpected. "too" end associate end function function concatenates_elements() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = (.cat. [string_t("foo"), string_t("bar")]) .equalsExpected. "foobar" end function function brackets_strings() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis associate(scalar => string_t("do re mi")) #if (! defined(__GFORTRAN__)) || GCC_VERSION > 150000 associate(array => string_t(["do", "re", "mi"])) test_diagnosis = test_diagnosis_t( & test_passed = scalar%bracket() == string_t("[do re mi]") & .and. all(array%bracket() == [string_t("[do]"), string_t("[re]"), string_t("[mi]")]) & .and. all(array%bracket('"') == [string_t('"do"'), string_t('"re"'), string_t('"mi"')]) & .and. all(array%bracket("{","}") == [string_t('{do}'), string_t('{re}'), string_t('{mi}')]) & ,diagnostics_string = "" & ) end associate #else block type(string_t), allocatable :: array(:) array = string_t(["do", "re", "mi"]) test_diagnosis = test_diagnosis_t( & test_passed = scalar%bracket() == string_t("[do re mi]") & .and. all(array%bracket() == [string_t("[do]"), string_t("[re]"), string_t("[mi]")]) & .and. all(array%bracket('"') == [string_t('"do"'), string_t('"re"'), string_t('"mi"')]) & .and. all(array%bracket("{","}") == [string_t('{do}'), string_t('{re}'), string_t('{mi}')]) & ,diagnostics_string = "" & ) end block #endif end associate end function function constructs_separated_values() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = test_diagnosis_t( & test_passed = & "a,bc,def" == .csv. [string_t("a"), string_t("bc"), string_t("def")] & .and. "abc,def" == .csv. ["abc", "def"] & .and. "do|re|mi" == (string_t(["do", "re", "mi"]) .sv. "|" ) & .and. "dore|mi" == (([string_t("dore"), string_t("mi")]) .sv. string_t("|")) & .and. "do|re|mi" == ( ["do", "re", "mi"] .sv. "|" ) & .and. "do|re|mi" == ( ["do", "re", "mi"] .sv. string_t("|")) & ,diagnostics_string = "" & ) end function end module string_test_m fortran-julienne-3.6.2/test/modules/bin_test_m.F900000664000175000017500000000602015151766762022240 0ustar alastairalastair! 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 bin_test_m !! Check data partitioning across bins use julienne_m, only : & bin_t & ,operator(.csv.) & ,string_t & ,test_description_t & ,test_diagnosis_t & ,test_result_t & ,test_t & ,usher use assert_m, only : assert implicit none private public :: bin_test_t type, extends(test_t) :: bin_test_t contains procedure, nopass :: subject procedure, nopass :: results end type contains pure function subject() result(specimen) character(len=:), allocatable :: specimen specimen = "An array of bin_t objects (bins)" end function function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_description_t), allocatable :: test_descriptions(:) type(bin_test_t) bin_test test_descriptions = [ & test_description_t(string_t("partitioning items nearly evenly across bins"), usher(check_block_partitioning)), & test_description_t(string_t("partitioning all item across all bins without item loss"), usher(check_all_items_partitioned)) & ] test_results = bin_test%run(test_descriptions) end function function check_block_partitioning() result(test_diagnosis) !! Check that the items are partitioned across bins evenly to within a difference of one item per bin type(test_diagnosis_t) test_diagnosis type(bin_t), allocatable :: bins(:) integer, parameter :: n_items=11, n_bins=7 integer b bins = [( bin_t(num_items=n_items, num_bins=n_bins, bin_number=b), b = 1,n_bins )] associate(in_bin => [(bins(b)%last() - bins(b)%first() + 1, b = 1, n_bins)]) associate(remainder => mod(n_items, n_bins), items_per_bin => n_items/n_bins) associate(expected_distribution => [ [(items_per_bin+1, b=1,remainder)], [(items_per_bin, b=remainder+1,n_bins)] ]) test_diagnosis = test_diagnosis_t( & test_passed = all(in_bin == expected_distribution) & ,diagnostics_string = "expected " // .csv. string_t(expected_distribution) // "; actual " // .csv. string_t(in_bin) & ) end associate end associate end associate end function function check_all_items_partitioned() result(test_diagnosis) !! Check that the number of items in each bin sums to the total number of items type(test_diagnosis_t) test_diagnosis type(bin_t), allocatable :: bins(:) integer, parameter :: n_items=11, n_bins=6 integer b bins = [( bin_t(num_items=n_items, num_bins=n_bins, bin_number=b), b = 1,n_bins )] associate(items_in_bins => sum([(bins(b)%last() - bins(b)%first() + 1, b = 1, n_bins)])) test_diagnosis = test_diagnosis_t( & test_passed = items_in_bins == n_items & ,diagnostics_string = "expected " // string_t(n_items) // ", actual " // string_t(items_in_bins) & ) end associate end function end module bin_test_m fortran-julienne-3.6.2/test/modules/command_line_test_m.F900000664000175000017500000001235115151766762024121 0ustar alastairalastair! 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 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_t & ,test_diagnosis_t & ,test_result_t & ,usher & ,test_t implicit none private public :: command_line_test_t type, extends(test_t) :: command_line_test_t contains procedure, nopass :: subject procedure, nopass :: results end type contains pure function subject() result(specimen) character(len=:), allocatable :: specimen specimen = "The command_line_t type" end function function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_description_t), allocatable :: test_descriptions(:) type(command_line_test_t) command_line_test type(command_line_t) command_line #if HAVE_MULTI_IMAGE_SUPPORT image_number: & associate(me => this_image()) #else image_number: & associate(me => 1) #endif 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")) & ] if (me==1) then 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('') end if 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")) & ] if (me==1) then print '(a)', & new_line('') & // "-----> To test command_line_t, append the following to the 'fpm test' command: -- --test command_line_t --type" & // new_line('') end if else ! run the tests test_descriptions = [ & test_description_t(string_t("flag_value() result is the value passed after a command-line flag"), usher(check_flag_value)) & ,test_description_t(string_t("flag_value() result is an empty string if command-line flag value is missing"), usher(check_flag_value_missing)) & ,test_description_t(string_t("flag_value() result is an empty string if command-line flag is missing"), usher(check_flag_missing)) & ,test_description_t(string_t("argument_present() result is .false. if a command-line argument is missing"), usher(check_argument_missing)) & ,test_description_t(string_t("argument_present() result is .true. if a command-line argument is present"), usher(check_argument_present)) & ] end if skip_all_tests_if_running_github_ci end associate image_number test_results = command_line_test%run(test_descriptions) end function function check_flag_value() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis type(command_line_t) command_line 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 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 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 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 test_diagnosis = .expect. command_line%argument_present(["--type"]) end function end module command_line_test_m fortran-julienne-3.6.2/test/modules/test_result_test_m.F900000664000175000017500000000431115151766762024046 0ustar alastairalastair! 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 test_result_test_m !! Verify test_result_t object behavior use julienne_m, only : & operator(.expect.) & ,string_t & ,usher & ,test_description_t & ,test_diagnosis_t & ,test_result_t & ,test_t implicit none private public :: test_result_test_t type, extends(test_t) :: test_result_test_t contains procedure, nopass :: subject procedure, nopass :: results end type contains pure function subject() result(specimen) character(len=:), allocatable :: specimen specimen = "The test_result_t type" end function function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_description_t), allocatable :: test_descriptions(:) type(test_result_test_t) test_result_test test_descriptions = [ & test_description_t(string_t("constructing an array of test_result_t objects elementally"), usher(check_array_result_construction)) & ] test_results = test_result_test%run(test_descriptions) end function function check_array_result_construction() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis #ifndef __GFORTRAN__ associate(two_test_results => test_result_t(["foo","bar"], [test_diagnosis_t(.true.,""), test_diagnosis_t(.true.,"")])) associate(num_results => size(two_test_results)) test_diagnosis = test_diagnosis_t( & test_passed = num_results == 2 & ,diagnostics_string = "expected 2, actual " // string_t(num_results) & ) end associate end associate #else block integer num_results type(test_result_t), allocatable :: two_test_results(:) two_test_results = test_result_t(["foo","bar"], [test_diagnosis_t(.true.,""), test_diagnosis_t(.true.,"")]) num_results = size(two_test_results) test_diagnosis = test_diagnosis_t( & test_passed = num_results == 2 & ,diagnostics_string = "expected 2, actual " // string_t(num_results) & ) end block #endif end function end module test_result_test_m fortran-julienne-3.6.2/test/modules/test_diagnosis_test_m.F900000664000175000017500000004270115151766762024515 0ustar alastairalastair! Copyright (c) 2024, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt #include "language-support.F90" module test_diagnosis_test_m !! Verify test_diagnosis_t object behavior use julienne_m, only : & string_t & ,test_t & ,test_description_t & ,test_diagnosis_t & ,passing_test & ,test_result_t & ,usher & ,operator(//) & ,operator(.all.) & ,operator(.also.) & ,operator(.and.) & ,operator(.equalsExpected.) & ,operator(.expect.) & ,operator(.approximates.) & ,operator(.within.) & ,operator(.withinFraction.) & ,operator(.withinPercentage.) & ,operator(.lessThan.) & ,operator(.isBefore.) & ,operator(.isAfter.) & ,operator(.isAtMost.) & ,operator(.greaterThan.) & ,operator(.isAtLeast.) use iso_c_binding, only : c_ptr, c_loc, c_bool, c_null_ptr use iso_fortran_env, only : int64 implicit none private public :: test_diagnosis_test_t type, extends(test_t) :: test_diagnosis_test_t contains procedure, nopass :: subject procedure, nopass :: results end type contains pure function subject() result(specimen) character(len=:), allocatable :: specimen specimen = "The test_diagnosis_t type" end function function results() result(test_results) type(test_result_t), allocatable :: test_results(:) type(test_description_t), allocatable :: test_descriptions(:) type(test_diagnosis_test_t) test_diagnosis_test test_descriptions = [ & test_description_t("construction from the real expression 'x .approximates. y .within. tolerance'" , usher(check_approximates_real)) & ,test_description_t("construction from the real expression 'x .approximates. y .withinFraction. tolerance'" , usher(check_approximates_real_fraction)) & ,test_description_t("construction from the real expression 'x .approximates. y .withinPercentage. tolerance'" , usher(check_approximates_real_percentage)) & ,test_description_t("construction from the real expression 'x .lessThan. y" , usher(check_less_than_real)) & ,test_description_t("construction from the real expression 'x .greaterThan. y" , usher(check_greater_than_real)) & ,test_description_t("construction from the double precision expression 'x .approximates. y .within. tolerance'" , usher(check_approximates_double)) & ,test_description_t("construction from the double precision expression 'x .approximates. y .withinFraction. tolerance'" , usher(check_approximates_double_fraction)) & ,test_description_t("construction from the double precision expression 'x .approximates. y .withinPercentage. tolerance'", usher(check_approximates_double_percentage)) & ,test_description_t("construction from the double precision expression 'x .lessThan. y" , usher(check_less_than_double)) & ,test_description_t("construction from the double precision expression 'x .greaterThan. y" , usher(check_greater_than_double)) & ,test_description_t("construction from string_t/character expressions 'a .isBefore. b'" , usher(check_alphabetical)) & ,test_description_t("construction from string_t/character expressions 'a .isAfter. b'" , usher(check_reverse_alphabetical)) & ,test_description_t("construction from string_t/character expressions 'a .equalsExpected. b'" , usher(check_equals_character_vs_string)) & ,test_description_t("construction from the character expression 'a .equalsExpected. b'" , usher(check_equals_character)) & ,test_description_t("construction from the type(c_ptr) expression 'p .equalsExpected. q'" , usher(check_equals_c_ptr)) & ,test_description_t("construction from the logical expression 't .equalsExpected. t'" , usher(check_equals_logical)) & ,test_description_t("construction from the string_t expression 'a .equalsExpected. b'" , usher(check_equals_string)) & ,test_description_t("construction from the integer expression 'i .equalsExpected. j'" , usher(check_equals_integer)) & ,test_description_t("construction from integer(int64) relational operators" , usher(check_int64_comparisons)) & ,test_description_t("construction from the integer expression 'i .lessThan. j" , usher(check_less_than_integer)) & ,test_description_t("construction from the integer expression '[i,j] .lessThanOrEqualTo. k" , usher(check_less_than_or_equal_to_integer)) & ,test_description_t("construction from the integer expression 'i .greaterThan. j" , usher(check_greater_than_integer)) & ,test_description_t("construction from the integer expression '[i,j] .greaterThanOrEqualTo. k" , usher(check_greater_than_or_equal_to_integer)) & ,test_description_t("construction from the scalar test_diagnostics_t expression 't .and. u'" , usher(check_and_with_scalar_operands)) & ,test_description_t("construction from the vector test_diagnostics_t expressions 'i .equalsExpected. [j,k]'" , usher(check_and_with_vector_operands)) & ,test_description_t("construction from string concatenation" , usher(check_string_concatentation)) & ,test_description_t("construction from character concatenation" , usher(check_character_concatentation)) & ,test_description_t("construction from (.expects. logical-expression) // 'user-defined message'" , usher(check_expects_logical)) & ,test_description_t("construction from (.expects. logical-expression) // 'user-defined message'" , usher(check_expects_logical)) & ,test_description_t("defining a test_diagnosis_t object by assigning a logical value" , usher(check_assigns_logical)) & ,test_description_t("aggregating a test_diagnosis_t object using .also. with a logical value" , usher(check_also_logical)) & ,test_description_t("hardwiring a test to pass via the passing_test() function" , usher(check_passing_test_function)) & ,test_description_t("construction from another test_diagnosis_t" , usher(check_copy_construction)) & ] test_results = test_diagnosis_test%run(test_descriptions) end function function check_approximates_real() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis real, parameter :: expected_value = 1., tolerance = 1.E-08 test_diagnosis = 1. .approximates. expected_value .within. tolerance end function function check_approximates_double() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis double precision, parameter :: expected_value = 1D0, tolerance = 1D-16 test_diagnosis = 1D0 .approximates. expected_value .within. tolerance end function function check_approximates_real_fraction() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis real, parameter :: actual_value = 1.1, expected_value = 1., fraction_ = 2.E-01 test_diagnosis = actual_value .approximates. expected_value .withinFraction. fraction_ end function function check_approximates_double_fraction() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis double precision, parameter :: actual_value = 1.1D0, expected_value = 1D0, fraction_ = 2D-01 test_diagnosis = actual_value .approximates. expected_value .withinFraction. fraction_ end function function check_approximates_real_percentage() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis real, parameter :: actual_value = 1.01, expected_value = 1., percentage = 2. test_diagnosis = actual_value .approximates. expected_value .withinPercentage. percentage end function function check_approximates_double_percentage() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis double precision, parameter :: actual_value = 1.01D0, expected_value = 1D0, percentage = 2D0 test_diagnosis = actual_value .approximates. expected_value .withinPercentage. percentage end function function check_reverse_alphabetical() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = (string_t("foo") .isAfter. string_t("bar")) & .and. (string_t("foo") .isAfter. "bar") & .and. ("foo" .isAfter. "bar") & .and. ("foo" .isAfter. string_t("bar")) end function function check_alphabetical() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = (string_t("bar") .isBefore. string_t("foo")) & .and. (string_t("bar") .isBefore. "foo") & .and. ("bar" .isBefore. "foo") & .and. ("bar" .isBefore. string_t("foo")) end function function check_equals_character() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis character(len=*), parameter :: expected_value = "foo" test_diagnosis = "foo" .equalsExpected. expected_value end function function check_equals_c_ptr() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis logical(c_bool), target :: t type(c_ptr) t_ptr type(c_ptr) null_ptr t = .true._c_bool t_ptr = c_loc(t) null_ptr = c_null_ptr test_diagnosis = (t_ptr .equalsExpected. c_loc(t)) .also. (null_ptr .equalsExpected. c_null_ptr) end function function check_equals_logical() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis logical, parameter :: t = .true., f = .false. test_diagnosis = (t .equalsExpected. t) .also. (f .equalsExpected. f) end function function check_equals_string() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis type(string_t) expected_value expected_value = string_t("foo") test_diagnosis = string_t("foo") .equalsExpected. expected_value end function function check_equals_character_vs_string() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis character(len=*), parameter :: expected_character = "foo" type(string_t) expected_string expected_string = string_t(expected_character) test_diagnosis = ("foo" .equalsExpected. expected_string) .and. (string_t("foo") .equalsExpected. expected_character) end function function check_equals_integer() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis integer, parameter :: expected_value = 1 test_diagnosis = 1 .equalsExpected. expected_value end function function check_less_than_real() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis real, parameter :: expected_ceiling = 1. test_diagnosis = 0. .lessThan. expected_ceiling end function function check_int64_comparisons() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis integer(int64), parameter :: zero = 0_int64, one = 1_int64, two = 2_int64 test_diagnosis = & ( zero .lessThan. one) & .also. ( one .isAtLeast. one) & .also. (-one .isAtMost. zero) & .also. ( two .greaterThan. one) end function function check_less_than_double() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis double precision, parameter :: expected_ceiling = 1D0 test_diagnosis = 0D0 .lessThan. expected_ceiling end function function check_less_than_integer() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis integer, parameter :: expected_ceiling = 1 test_diagnosis = 0 .lessThan. expected_ceiling end function function check_greater_than_real() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis real, parameter :: expected_floor = 1. test_diagnosis = 2. .greaterThan. expected_floor end function function check_greater_than_double() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis double precision, parameter :: expected_floor = 1D0 test_diagnosis = 2D0 .greaterThan. expected_floor end function function check_greater_than_integer() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis integer, parameter :: expected_floor = 1 test_diagnosis = (2 .greaterThan. expected_floor) end function function check_less_than_or_equal_to_integer() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis integer, parameter :: expected_max = 1 test_diagnosis = .all. ([0,1] .isAtMost. expected_max) end function function check_greater_than_or_equal_to_integer() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis integer, parameter :: expected_min = 1 test_diagnosis = .all. ([1,2] .isAtLeast. expected_min) end function function check_and_with_scalar_operands() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis integer, parameter :: expected_min = 1 test_diagnosis = (2 .isAtLeast. expected_min) .and. (1 .equalsExpected. 1) end function function check_and_with_vector_operands() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = .all. ((2 .equalsExpected. [2,2,2]) .and. ([0,1,2] .equalsExpected. [0,1,2])) end function function check_string_concatentation() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis #ifndef __GFORTRAN__ associate(diagnosis_cat_string => test_diagnosis_t(test_passed=.false., diagnostics_string="blah blah") // string_t(" yada yada")) test_diagnosis = diagnosis_cat_string%diagnostics_string() .equalsExpected. "blah blah yada yada" end associate associate(diagnosis_do_not_cat_string => test_diagnosis_t(test_passed=.true., diagnostics_string="blah blah") // string_t(" yada yada")) test_diagnosis = test_diagnosis .also. (diagnosis_do_not_cat_string%diagnostics_string() .equalsExpected. "blah blah") end associate #else block type(test_diagnosis_t) diagnosis_cat_string, diagnosis_do_not_cat_string diagnosis_cat_string = test_diagnosis_t(test_passed=.false., diagnostics_string="blah blah") // string_t(" yada yada") test_diagnosis = diagnosis_cat_string%diagnostics_string() .equalsExpected. "blah blah yada yada" diagnosis_do_not_cat_string = test_diagnosis_t(test_passed=.true., diagnostics_string="blah blah") // string_t(" yada yada") test_diagnosis = test_diagnosis .also. (diagnosis_do_not_cat_string%diagnostics_string() .equalsExpected. "blah blah") end block #endif end function function check_character_concatentation() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis #ifndef __GFORTRAN__ associate(diagnosis_cat_string => test_diagnosis_t(test_passed=.false., diagnostics_string="blah blah") // " yada yada") test_diagnosis = diagnosis_cat_string%diagnostics_string() .equalsExpected. "blah blah yada yada" end associate associate(diagnosis_do_not_cat_string => test_diagnosis_t(test_passed=.true., diagnostics_string="blah blah") // " yada yada") test_diagnosis = test_diagnosis .also. (diagnosis_do_not_cat_string%diagnostics_string() .equalsExpected. "blah blah") end associate #else block type(test_diagnosis_t) diagnosis_cat_string, diagnosis_do_not_cat_string diagnosis_cat_string = test_diagnosis_t(test_passed=.false., diagnostics_string="blah blah") // " yada yada" test_diagnosis = diagnosis_cat_string%diagnostics_string() .equalsExpected. "blah blah yada yada" diagnosis_do_not_cat_string = test_diagnosis_t(test_passed=.true., diagnostics_string="blah blah") // " yada yada" test_diagnosis = test_diagnosis .also. (diagnosis_do_not_cat_string%diagnostics_string() .equalsExpected. "blah blah") end block #endif end function function check_expects_logical() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis integer, allocatable :: A(:) test_diagnosis = .expect. (.not. allocated(A)) // "(expected unallocated array A)" end function function check_assigns_logical() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = .true. end function function check_also_logical() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = .true. test_diagnosis = test_diagnosis .also. .true. test_diagnosis = .true. .also. test_diagnosis end function function check_passing_test_function() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = passing_test() end function function check_copy_construction() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis type(test_diagnosis_t) f,u test_diagnosis = .true. f = .false. u = test_diagnosis_t(f) test_diagnosis = test_diagnosis .also. & (u%diagnostics_string() .equalsExpected. "") u = test_diagnosis_t(f, "foo") test_diagnosis = test_diagnosis .also. & (u%diagnostics_string() .equalsExpected. "foo") u = test_diagnosis_t(f, string_t("bar")) test_diagnosis = test_diagnosis .also. & (u%diagnostics_string() .equalsExpected. "bar") end function end module test_diagnosis_test_m fortran-julienne-3.6.2/test/unit_test_failure_test.F900000664000175000017500000000241215151766762023232 0ustar alastairalastairprogram unit_test_failure_test !! Conditionally execute test_test_t%report use julienne_m, only : command_line_t, test_fixture_t, test_harness_t use test_test_m, only : test_test_t implicit none # if TEST_INTENTIONAL_FAILURE associate(command_line => command_line_t()) if (.not. command_line%argument_present([character(len=len("--help"))::"--help","-h"])) then associate(test_harness => test_harness_t([test_fixture_t(test_test_t())])) call test_harness%report_results print *, "If this message appears, the test did not fail as intended." end associate end if end associate # else # if HAVE_MULTI_IMAGE_SUPPORT associate(command_line => command_line_t(), me => this_image()) # else associate(command_line => command_line_t(), me => 1) # endif if (.not. command_line%argument_present([character(len=len("--help"))::"--help","-h"])) then if (me==1) print '(a)', & new_line('') // & 'Skipping the test in ' // __FILE__ // '.' // new_line('') // & 'Add the following to your fpm command to test unit-test failures: --flag "-DTEST_INTENTIONAL_FAILURE"' // & new_line('') end if end associate # endif end program fortran-julienne-3.6.2/test/logical_assertion_failure_test.F900000664000175000017500000000240415151766762024716 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt #include "julienne-assert-macros.h" #include "language-support.F90" program logical_assertion_failure_test !! Conditionally test an assertion that is hardwired to fail. use julienne_m, only : call_julienne_assert_, command_line_t implicit none integer, allocatable :: array(:) #if HAVE_MULTI_IMAGE_SUPPORT associate(command_line => command_line_t(), me => this_image()) #else associate(command_line => command_line_t(), me => 1) #endif if (.not. command_line%argument_present([character(len=len("--help"))::"--help","-h"])) then #if TEST_INTENTIONAL_FAILURE && ASSERTIONS if (me==1) print '(a)', new_line('') // 'Test the intentional failure of a logical assertion: ' // new_line('') if (allocated(array)) deallocate(array) call_julienne_assert(allocated(array)) #else if (me==1) print '(a)', & new_line('') // & 'Skipping the test in ' // __FILE__ // '.' // new_line('') // & 'Add the following to your fpm command to test assertion failures: --flag "-DASSERTIONS -DTEST_INTENTIONAL_FAILURE"' // & new_line('') #endif end if end associate end program fortran-julienne-3.6.2/README.md0000664000175000017500000003732515151766762016501 0ustar alastairalastair

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 defined operations: a uniquely flexible Fortran capability allowing developers to define _new_ operators or to overloading Fortran's intrinsic operators. Example expressions | Supported operand types -----------------------------------------------------|-------------------------------------- `x .approximates. y .within. tolerance` | `real`, `double precision` for `x`, `y`, `tolerance` `x .approximates. y .withinFraction. tolerance` | `real`, `double precision` for `x`, `y`, `tolerance` `x .approximates. y .withinPercentage. tolerance` | `real`, `double precision` for `x`, `y`, `tolerance` `.all. ([i,j] .lessThan. k)` | `test_diagnosis_t` for `.all.` operator's operand `.all. ([i,j] .lessThan. [k,m])` | `test_diagnosis_t` for `.all`. operator's operand `.all. (i .lessThan. [k,m])` | `test_diagnosis_t` for `.all.` operator's operand `(i .lessThan. j) .also. (k .equalsExpected. m))` | `test_diagnosis_t` for `.also.` operator's operands `x .lessThan. y` | `integer`, `real`, `double precision` for `x`, `y` `x .greaterThan. y` | `integer`, `real`, `double precision` for `x`, `y` `i .equalsExpected. j` | `integer`, `character`, `type(c_ptr)` for `i`, `j` `i .isAtLeast. j` | `integer`, `real`, `double precision` for `i`, `j` `i .isAtMost. j` | `integer`, `real`, `double precision` for `i`, `j` `s .isBefore. t` | `character` for `s`, `t` `s .isAfter. t` | `character` for `s`, `t` `.expect. allocated(A)` // " (expected allocated A)" | `logical` for `.expect.` operator's operand where * `.isAtLeast.` and `.isAtMost.` can alternatively be spelled `.greaterThanOrEqualTo.` and `.lessThanOrEqualTo.`, respectively; * `.equalsExpected.` uses `==`, which implies that trailing blank spaces are ignored in character operands; * `.equalsExpected.` with integer operands supports default integers and `integer(c_size_t)`; * `.isBefore.` and `.isAfter.` verify alphabetical and reverse-alphabetical order, respectively; * `.all.` aggregates arrays of expression results, reports a consensus result, and shows diagnostics only for failing tests, if any; * `.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: ```fortran call_julienne_assert(x .lessThan. y) ``` which a preprocessor will replace with a call to Julienne's assertion subroutine when compiling with `-DASSERTIONS`. Otherwise, the preprocessor will remove the above line entirely. ### Unit tests The above tabulated expressions can also serve as results in unit-test functions. ### Constraints All operands in an expression must be compatible in type and kind as well as conformable in rank. Conformability implies that the operands must be all scalars or all arrays with the same shape or a combination of scalars and arrays with the same shape. This constraint follows from each of the binary operators being `elemental`. The unary `.all.` operator applies to operands of any rank. Each expression tabulated above produces a `test_diagnosis_t` object with two components: - a `logical` indicator of test success if `.true`. or failure if `.false.` and - an automated diagnostic messages generated only if the test or assertion fails. Custom Test Diagnostics ----------------------- For cases in which the defined operations do not support a desired correctness condition, Julienne provides string-handling utilities for use in crafting custom diagnostic messages. The string utilities center around a `string_t` derived type, which offers `elemental` constructor functions, i.e., functions that one invokes via the same name as the derived type: `string_t()`. The `string_t()` constructor functions convert data of numeric type to `character` type, storing the resulting `character` representation in a private component of the constructor function result. The actual argument provided to the constructor function can be of any one of several types, kinds, and ranks. Julienne provides defined operations for concatenating `string_t` objects (`//`), forming a concatenated `string_t` object from an array of `string_t` objects (`.cat.`), forming a separated-value list (`.separatedBy.` or equivalently `.sv.`), including a comma-separated value list `(.csv.)`. Example expression | Result -------------------------------------------------|------------------------------------------------ `s%bracket()`, where `s=string_t("abc")`, | `string_t("[abc]")` `s%bracket("_")`, where `s=string_t("abc")` | `string_t("_abc_")` `s%bracket("{","}")`, where `s=string_t("abc")` | `string_t("{abc}")` `string_t(["a", "b", "c"])` | `[string_t("a"), string_t("b"), string_t("c")]` `.cat. string_t([9,8,7])` | `string_t("987")` `.csv. string_t([1.5,2.0,3.25])` | `string_t("1.50000000,2.00000000,3.25000000")` `string_t([1,2,4]) .separatedBy. "-"` | `string_t("1-2-4")` `string_t("ab") // string_t("cd")` | `string_t("abcd")` `"ab" // string_t("cd")` | `string_t("abcd")` `string_t("ab") // "cd"` | `string_t("abcd")` One can use such expressions to craft a diagnostic message: ```fortran type(test_diagnosis_t) test_diagnosis test_diagnosis = test_diagnosis_t( & test_passed = i==j, & diagnostics_string = "expected " // string_t(i) // "; actual " //string_t(j) & ) ``` A file abstraction ------------------ Arrays of `string_t` objects provide a convenient way to store a ragged-length array of `character` data. Julienne's `file_t` derived type has a private component that is a `string_t` array, wherein each element is one line of a text file. By storing a file in a `file_t` object using the `file_t` derived type's constructor function one can confine a program's file input/output (I/O) to one or two procedures. The resulting `file_t` object can be manipulated elsewhere without incurring the costs associated with file I/O. For example, the following lines read a file named `data.txt` into a `file_t` object and associates the name `file` with the resulting object. ```fortran associate(file => file_t("data.txt")) end associate ``` This style supports functional programming patterns in two ways. First, the rest of the program can be comprised of `pure` procedures, which are precluded from performing I/O. Second, an associate name is immutable when associated with an expression, including an expression that is simply a function reference. Functional programming revolves around creating and using immutable state. (By contrast, when associating a name with a variable or array instead of with an expression, only certain attributes, such as the entity's allocation status, are immutable. The value of such a variable or array can be redefined.) Functional Programming ---------------------- Functional programming patterns centered around `pure` procedures enhance code clarity, ease refactoring, and encourage optimization. For example, the constraints on `pure` procedures make it easier for a developer or a compiler to safely reorder program statements. Moreover, Fortran allows invoking only `pure` procedures inside `do concurrent`, a construct that compilers can automatically offload to a graphics processing unit (GPU). Julienne lowers a widely stated barrier to writing `pure` procedures (including `simple` procedures): the difficulty in printing values while debugging code. The Julienne philosophy is that printing a value for debugging purposes implies an expectation about the value. Assert such expectations by writing Julienne expressions inspired by natural language. A program will proceed quietly past a correct assertion. An incorrect assertion produces either automated or custom diagnostic messages during error termination. Getting Started --------------- ### Writing Unit Tests Please see [demo/README.md](./demo/README.md) for a detailed demonstration of test setup. ### Writing Assertions To write a Julienne assertion, insert a function-like preprocessor macro `call_julienne_assert` on a single line as in each of the two macro invocations below: ```fortran #include "julienne-assertion-macros.h" program main use, julienne_m, only : call_julienne_assert_ implicit none real, parameter :: x=1., y=2., tolerance=3. call_julienne_assert(x .approximates. y .within. tolerance) call_julienne_assert(abs(x-y) < tolerance) end program ``` where inserting `-DASSERTIONS` in a compile command will expand the macros to ```fortran call call_julienne_assert_(x .approximates. y .within. tolerance, __FILE__, __LINE__) call call_julienne_assert_(allocated(a), __FILE__, __LINE__) ``` and where dots (`.`) delimit Julienne operators. The above expression containing Julienne operators evaluates to a Julienne `test_diagnosis_t` object, whereas expression `allocated(a)` on the subsequent line evaluates to a `logical` value. If an assertion containing a Julienne expression fails, Julienne inserts diagnostic information into the stop code in an ultimate `error stop`. If an expression evaluates to a `logical` value of `false.`, the error stop code will contain a literal copy of the expression (e.g., `allocated(a)`). In either case, Julienne also inserts the file and line number into the stop code using via the `__FILE__` and `__LINE__` macros, respectively. Most compilers write the resulting stop code to `error_unit`. Building and Testing -------------------- With the Fortran Package Manager ([`fpm`]) installed and in your `PATH`, the commands in the table below will build and run the Julienne test suite. With `fpm` versions higher than 0.12.0, `flang-new` can be replaced with `flang`. For additional information on setting up parallel builds with LLVM, please see [parallel-testing-with-flang.md](./doc/parallel-testing-with-flang.md). Compiler/Runtime |Tested Versions|Run Type|Example build/test commands (parallel examples use 2 images) ------------------|---------------|--------|------------------------------------------------------------ LLVM/[Caffeine] |22.0.0git |parallel|`fpm test --compiler flang-new --flag "-O3 -DHAVE_MULTI_IMAGE_SUPPORT -fcoarray" --link-flag "-lcaffeine -lgasnet-smp-seq -L -L"` LLVM |20-22 |serial |`fpm test --compiler flang-new --flag -O3` LLVM |19 |serial |`fpm test --compiler flang-new --flag "-O3 -mmlir -allow-assumed-rank"` NAG |7.2, Build 7235|parallel|`NAGFORTRAN_NUM_IMAGES=2 fpm test --compiler nagfor --flag "-fpp -O3 -coarray"` Intel |2025.2.{0-1} |parallel|`FOR_COARRAY_NUM_IMAGES=2 fpm test --compiler ifx --flag "-fpp -O3 -coarray" --profile release` GCC/[OpenCoarrays]|14-15 |serial |`fpm test --compiler gfortran --profile release` GCC |14-15 |parallel|`fpm test --compiler caf --runner "cafrun -n 2" --profile release` GCC/[OpenCoarrays]|13 |serial |`fpm test --compiler gfortran --profile release --flag -ffree-line-length-none` GCC |13 |parallel|`fpm test --compiler caf --runner "cafrun -n 2" --profile release --flag -ffree-line-length-none` The test output reports a test as skipped if there is a known issue that blocks the tested feature with the chosen compiler version or platform. Due to a GitHub continuous-integration (CI) issue, the default behavior is to skip the tests for Julienne's command-line parsing utility: `command_line_t`. To test `command_line_t`, add `-- --flag --test command_line_t --type` at the end of an `fpm` command. ### Useful preprocessor macros: To define the following macros or to override the values defined in Julienne's `include` directory, add `--flag -D=` to an `fpm` command: - `ASSERTIONS`: enables runtime enforcement of Julienne's assertions - `HAVE_MULTI_IMAGE_SUPPORT`: enables Julienne's use of Fortran's built-in multi-image support, for testing of parallel multi-process programs. The default is compiler-dependent, set to 0 to disable multi-image support. - `ASYNCHRONOUS_DIAGNOSTICS`: removes synchronizations that partially order test-failure diagnostics output for clarity. Only relevant for multi-image execution. - `JULIENNE_PARALLEL_CALLBACKS`: activates Julienne callbacks that support `HAVE_MULTI_IMAGE_SUPPORT` with external SPMD multi-process models. Contact us for more details. - `TEST_INTENTIONAL_FAILURE`: enables tests of unit-test failure; also enables tests of assertion failure if `ASSERTIONS` is non-zero. An Origin Story --------------- Julienne's name derives from the term for vegetables sliced into thin strings: julienned vegetables. The [Veggies] and [Garden] unit-testing frameworks inspired the structure of Julienne's tests and output. Initially developed in the [Sourcery] repository as lightweight alternative with greater portability across compilers, Julienne's chief innovation now lies in the expressive idioms the framework supports. Documentation ------------- See our online [documentation] or build the documentation locally by installing [FORD] and executing `ford ford.md`. Publications ------------ Citing Julienne? Please use the following publication: Damian Rouson, Dan Bonachea, and Katherine Rasmussen, "[**Idiomatic Correctness-Checking via Julienne in Fortran 2023**](https://doi.org/10.25344/S4BG65)", _Proceedings of the [US Research Software Engineering Conference](https://us-rse.org/usrse25/)_, October 2025. DOI: [10.25344/S4BG65](https://doi.org/10.25344/S4BG65) Known Software Using Julienne ----------------------------- * [band_distribution](https://github.com/pibion/band_distribution?tab=readme-ov-file): a utility supporting the search for dark matter * [Caffeine](https://go.lbl.gov/caffeine): Coarray Fortran Framework of Efficient Interfaces to Network Environments * [Fiats](https://go.lbl.gov/fiats): Functional inference and training for surrogates * [Matcha](https://go.lbl.gov/matcha): Motility analysis of T-cell histories in activation * nQMCC: Quantum Monte Carlo simulation software for nuclear physics * [TRACE](https://www.nrc.gov/docs/ML1200/ML120060218.pdf):a two-phase flow solver for nuclear reactors [`diagnosis_function_i`]: https://github.com/BerkeleyLab/julienne/blob/37bcc959efa8f9e27ae50fecfd37a6bf52ef0a43/src/julienne/julienne_test_description_m.f90#L16 [documentation]: https:///berkeleylab.github.io/julienne/ [FORD]: https://github.com/Fortran-FOSS-Programmers/ford [Garden]: https://gitlab.com/everythingfunctional/garden [Sourcery]: https://github.com/sourceryinstitute/sourcery [Veggies]: https://gitlab.com/everythingfunctional/veggies [Caffeine]: https://go.lbl.gov/caffeine [OpenCoarrays]: https://github.com/sourceryinstitute/opencoarrays [`fpm`]: https://github.com/fortran-lang/fpm fortran-julienne-3.6.2/example/0000775000175000017500000000000015151766762016643 5ustar alastairalastairfortran-julienne-3.6.2/example/assertions/0000775000175000017500000000000015151766762021035 5ustar alastairalastairfortran-julienne-3.6.2/example/assertions/assertions.F900000664000175000017500000000354715151766762023520 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt #include "julienne-assert-macros.h" program assertions !! Example: two true assertions followed by one intentionally false assertion use julienne_m, only : & call_julienne_assert_ & ,operator(.approximates.) & ,operator(.equalsExpected.) & ,operator(.within.) & ,operator(.withinPercentage.) implicit none #if ! ASSERTIONS print * print '(a)', "Skipping asertions." print '(a)', "Use a command such as the following to rerun with assertions:" print '(a)', "fpm run --example assertions --flag -DASSERTIONS" #else print '(a)', new_line('') print '(a)', "This program evaluates the following true assertions that should run silently:" // new_line('') print '(a)', " call_julienne_assert(pi_ .approximates. pi .within. absolute_tolerance)" print '(a)', " call_julienne_assert(pi_ .approximates. pi .withinPercentage. relative_tolerance)" // new_line('') print '(a)', "where pi_ = 22./7., pi 3.14152654, absolute_tolerance = 0.1, and relative_tolerance = 1.0." // new_line('') print '(a)', "The program will then evaluate one false assertion:" // new_line('') print '(a)', " call_julienne_assert(1 .equalsExpected. 2)" // new_line('') print '(a)', "which should initiate error termination and provide a diagnostic message:" // new_line('') #endif block real, parameter :: pi_ = 22./7. real, parameter :: pi = 3.141592654 real, parameter :: absolute_tolerance = 0.2 real, parameter :: relative_tolerance = 1.0 ! percentage call_julienne_assert(pi_ .approximates. pi .within. absolute_tolerance) call_julienne_assert(pi_ .approximates. pi .withinPercentage. relative_tolerance) call_julienne_assert(1 .equalsExpected. 2) ! intentional failure end block end program fortran-julienne-3.6.2/example/strings/0000775000175000017500000000000015151766762020334 5ustar alastairalastairfortran-julienne-3.6.2/example/strings/create-markdown-table.F900000664000175000017500000000650315151766762024770 0ustar alastairalastairprogram create_markdown_table !! This program demonstrates the creation of a Markdown table summarzing kind values used by a compiler: !! !! 1. Using the string_t user-defined structure constructor to encapsulate a ragged-edged string_t array. !! 2. Using operator(.separatedBy.) to concatenate string_t array elements with interspersed separators. !! 3. Using the elemental type-bound procedure "bracket" to prefix and suffix string_t array elements. !! !! Running the program with a command of the form "fpm run --example create-markdown-table" without quotes !! should produce a table similar to the following with "flang" replaced by the employed compiler's name. !! !! |compiler \ kind|default|c_size_t|c_int64_t|c_intptr_t| !! |-|-|-|-|-| !! |flang|4|8|8|8| use iso_fortran_env, only : compiler_version use iso_c_binding, only : c_size_t, c_int64_t, c_intptr_t use julienne_string_m, only : string_t, operator(.separatedBy.) implicit none block integer row integer, parameter :: default_integer_kind = kind(0) integer, parameter :: body(*,*) = reshape([default_integer_kind, c_size_t , c_int64_t , c_intptr_t], [1,4]) type(string_t), allocatable :: table_lines(:), header(:) header = & [string_t("compiler \ kind"), string_t("default"), string_t("c_size_t"), string_t("c_int64_t"), string_t("c_intptr_t")] table_lines = markdown_table(row_header=[compiler()], column_header=header, body_cells=string_t(body), side_borders=.true.) do row = 1, size(table_lines) print '(a)', table_lines(row)%string() end do end block contains pure function markdown_table(row_header, column_header, body_cells, side_borders) result(lines) integer, parameter :: first_body_row = 3 type(string_t), intent(in) :: row_header(first_body_row:), column_header(:), body_cells(first_body_row:,:) logical, intent(in) :: side_borders character(len=1), parameter :: column_separator = "|" integer, parameter :: num_rule_lines = 1 type(string_t) lines(size(body_cells,1) + rank(column_header) + num_rule_lines) integer row, col if (size(column_header) /= rank(row_header) + size(body_cells,2)) error stop "column size mismatch" if (size(row_header) /= size(body_cells,1)) error stop "row size mismatch" lines(1) = column_header .separatedBy. column_separator lines(2) = [("-", col=1,size(column_header))] .separatedBy. column_separator do row = 3, size(lines) lines(row) = [row_header(row), body_cells(row,:)] .separatedBy. column_separator end do if (side_borders) lines = lines%bracket(column_separator) end function pure function compiler() type(string_t) compiler associate(compiler_identity => compiler_version()) if (index(compiler_identity, "GCC") /= 0) then compiler = string_t("gfortran") else if (index(compiler_identity, "NAG") /= 0) then compiler = string_t("nagfor") else if (index(compiler_identity, "flang") /= 0) then compiler = string_t("flang") else if (index(compiler_identity, "Intel") /= 0) then compiler = string_t("ifx") else #if (! defined(__GFORTRAN__)) || (GCC_VERSION > 140000) error stop "unrecognized compiler: " // compiler_identity #else error stop "unrecognized compiler" #endif end if end associate end function end program fortran-julienne-3.6.2/example/README.md0000664000175000017500000000106315151766762020122 0ustar alastairalastairExamples ======== Please see the following directories for examples of the listed Julienne uses: * [Assertions](./assertions): runtime assertion checking using idioms that evaluate to `test_diagnosis_t` result objects, * [Command-line parsing](./command-line-parsing): checking a command-line flag's presence and getting an associated value using the `command_line_t` type, * [String operations](./strings): operating on strings using the `string_t` type and defined operations, and * [Testing](../demo): a demonstration unit test suite using the `test_t` type. fortran-julienne-3.6.2/example/command-line-parsing/0000775000175000017500000000000015151766762022647 5ustar alastairalastairfortran-julienne-3.6.2/example/command-line-parsing/check-for-command-line-argument.f900000664000175000017500000000210415151766762031206 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt program check_for_command_line_argument !! This program shows how to use the command_line_t derived type to check whether a !! command-line argument is present. Running this program as follows with the command !! should print an indication that the command-line argument is present: !! !! fpm run --example check-for-command-line-argument -- --some-argument !! !! Running the program without the argument or with the argument spelled differently !! should print an indication that the argument is not present: !! !! fpm run --example check-for-command-line-argument use julienne_m, only : command_line_t implicit none type(command_line_t) command_line if (command_line%argument_present(["--some-argument"])) then print '(a)', new_line('') // "argument 'some-argument' present" // new_line('') else print '(a)', new_line('') // "argument 'some-argument' not present" // new_line('') end if end program fortran-julienne-3.6.2/example/command-line-parsing/get-command-line-flag-value.f900000664000175000017500000000175715151766762030342 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt program get_command_line_flag_value !! This program demonstrates how to find the value of a command-line flag. Running this program !! as follows should print 'foo=bar' without quotes: !! !! fpm run --example get-command-line-flag-value -- --foo bar !! !! Running the above command either without `bar` or without "--foo bar" should print an indication the message "flag '--foo' not present or present with no value". !! was provided. use julienne_m, only : command_line_t implicit none type(command_line_t) command_line character(len=:), allocatable :: foo_value foo_value = command_line%flag_value("--foo") if (len(foo_value)/=0) then print '(a)', new_line('') // "foo=" // foo_value // new_line('') else print '(a)', new_line('') // "flag '--foo' not present or present with no value" // new_line('') end if end program fortran-julienne-3.6.2/demo/0000775000175000017500000000000015151766762016134 5ustar alastairalastairfortran-julienne-3.6.2/demo/test-suite.json0000664000175000017500000000011615151766762021133 0ustar alastairalastair{ "test suite": { "test subjects" : ["specimen","widget"] } } fortran-julienne-3.6.2/demo/src/0000775000175000017500000000000015151766762016723 5ustar alastairalastairfortran-julienne-3.6.2/demo/src/widget_m.f900000664000175000017500000000100015151766762021031 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt module widget_m !! Example test widget corresponding to the test defined in widget_test_m.F90 implicit none type widget_t contains procedure pi end type contains function pi(self) class(widget_t), intent(in) :: self real pi associate(avoid_unused_variable_warning => self) end associate pi = 3.1415926536 end function end modulefortran-julienne-3.6.2/demo/src/specimen_m.f900000664000175000017500000000101215151766762021354 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt module specimen_m !! Example test specimen corresponding to the test defined in specimen_test_m.F90 implicit none type specimen_t contains procedure pi end type contains function pi(self) class(specimen_t), intent(in) :: self real pi associate(avoid_unused_variable_warning => self) end associate pi = 3.1415926536 end function end modulefortran-julienne-3.6.2/demo/test/0000775000175000017500000000000015151766762017113 5ustar alastairalastairfortran-julienne-3.6.2/demo/test/widget_test_m.f900000664000175000017500000000300115151766762022263 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt module widget_test_m use julienne_m, only : & test_t, test_description_t, test_diagnosis_t, test_result_t & ,operator(.approximates.), operator(.within.), operator(.all.), operator(//) use widget_m, only : widget_t implicit none type, extends(test_t) :: widget_test_t contains procedure, nopass :: subject procedure, nopass :: results end type contains pure function subject() result(test_subject) character(len=:), allocatable :: test_subject test_subject = 'A widget' end function function results() result(test_results) type(widget_test_t) widget_test type(test_result_t), allocatable :: test_results(:) test_results = widget_test%run( & [test_description_t('doing something', do_something) & ,test_description_t('checking something', check_something) & ,test_description_t('skipping something') & ]) end function function check_something() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis type(widget_t) widget test_diagnosis = .all.( & [22./7., 3.14159] .approximates. widget%pi() .within. 0.001 & ) // ' (pi approximation)' end function function do_something() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = & test_diagnosis_t(test_passed = 1 == 1, diagnostics_string = 'craziness ensued') end function end module fortran-julienne-3.6.2/demo/test/specimen_test_m.f900000664000175000017500000000302715151766762022613 0ustar alastairalastair! Copyright (c) 2024-2025, The Regents of the University of California and Sourcery Institute ! Terms of use are as specified in LICENSE.txt module specimen_test_m use julienne_m, only : & test_t, test_description_t, test_diagnosis_t, test_result_t & ,operator(.approximates.), operator(.within.), operator(.all.), operator(//) use specimen_m, only : specimen_t implicit none type, extends(test_t) :: specimen_test_t contains procedure, nopass :: subject procedure, nopass :: results end type contains pure function subject() result(test_subject) character(len=:), allocatable :: test_subject test_subject = 'A specimen' end function function results() result(test_results) type(specimen_test_t) specimen_test type(test_result_t), allocatable :: test_results(:) test_results = specimen_test%run( & [test_description_t('doing something', do_something) & ,test_description_t('checking something', check_something) & ,test_description_t('skipping something') & ]) end function function check_something() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis type(specimen_t) specimen test_diagnosis = .all.( & [22./7., 3.14159] .approximates. specimen%pi() .within. 0.001 & ) // ' (pi approximation)' end function function do_something() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis test_diagnosis = & test_diagnosis_t(test_passed = 1 == 1, diagnostics_string = 'craziness ensued') end function end module fortran-julienne-3.6.2/demo/test/driver.f900000664000175000017500000000104115151766762020722 0ustar alastairalastair! 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 use julienne_m, only : test_fixture_t, test_harness_t use specimen_test_m, only : specimen_test_t use widget_test_m, only : widget_test_t implicit none associate(test_harness => test_harness_t([ & test_fixture_t(specimen_test_t()) & ,test_fixture_t(widget_test_t()) & ])) call test_harness%report_results end associate end program test_suite_driver fortran-julienne-3.6.2/demo/README.md0000664000175000017500000002653415151766762017425 0ustar alastairalastairGetting Started =============== This `demo` directory contains a demonstration project with * Stub types and functions in the `src` subdirectory, * Tests for the stubs in the `test` subdirectory, * A Fortran Package Manager (`fpm`) build/test system in `fpm.toml`. Please try [running the demonstration tests] and [generating test scaffolding]. Writing tests ------------- Testing with Julienne centers around the `test_t` abstract derived type. Users extend `test_t`, defining non-abstract child types capturing groups of tests. Doing so requires defining the inherited deferred bindings: the `subject` and `results` functions. * `subject` has no arguments and defines a `character` string result describing what is being tested, * `results` has no arguments defines a `test_result_t` array result by invoking the inherited `run` function on a child instance, and * `run` uses its `test_description_t` array argument to construct a `test_result_t` array result. Users construct each `test_description_t` array element by invoking a `test_description_t` constructor function, which has two arguments: * A `character` string describing what the test does, typically beginning with a gerund: a word ending in `-ing`, and * The name of a function conforming to Julienne's `diagnosis_function_i` abstract interface. The `diagnosis_function_i` function implementations have no arguments and construct a `test_diagnosis_t` result by * Writing an expression in a Julienne idiom with defined operations (.e.g, `.all.(['a','b','c'] .isBefore. 'efg')`) or * Invoking the `test_diagnosis_t` constructor if no convenient idiom exists. The `test_diagnosis_t` constructor has two arguments: * `test_passed`: `logical` expression defining the test condition (.e.g, ` * `diagnostics_string`: a `string_t` or `character`. Please see [Forming Diagnostics Strings] and [String-Handling Functions]. Please see the `test` subdirectory for code examples. Also, please see the following Unified Modeling Language ([UML]) class diagram for a summary of user-facing derived types, including type relationships and object constructors. Users invoke constructor functions via generic names matching the type of the constructed object result. ```mermaid classDiagram test_t --> test_description_t : "'run' accepts array of" test_t --> test_result_t : "'run' defines array of" class test_t{ <> subject() character * results() test_result_t * run(test_descriptions : test_description_t) test_result_t } class test_description_t{ test_decription_t(description : character, diagnosis_function : procedure(diagnosis_function_i)) test_description_t } ``` ```mermaid classDiagram class test_diagnosis_t{ test_diagnosis_t(test_passed : logical, diagnostics_string : string_t) test_diagnosis_t } ``` ```mermaid classDiagram class string_t{ string_t(character) string_t } ``` Running the demonstration tests ------------------------------- With the Fortran Package Manager (`fpm`) installed, please set the `demo` subdirectory as your present working directory in a shell. Then run the demonstration test suite using the command below for your compiler. |Vendor | Version(s) Tested | Example shell command | |-------|-------------------------|--------------------------------------------------| |LLVM | 20-21 | `fpm test --compiler flang-new --flag "-O3"` | |GCC | 13-151 | `fpm test --compiler gfortran --profile release` | |NAG | 7.2 Build 7235 | `fpm test --compiler nagfor --flag "-O3 -fpp"` | |Intel | 2025.2.1 Build 20250806 | `fpm test --compiler ifx --flag "-fpp -O3"` | 1With GCC 13, please append `--flag "-ffree-line-length-none"` to the listed `fpm test` command. Generating test scaffolding --------------------------- To recreate the `test` directory contents, pass the following `test-suite.json` file to Julienne's `scaffold` program: ``` { "test suite": { "test subjects" : ["specimen","widget"] } } ``` Please maintain the above format by not inserting, deleting, or combining any lines. Please run following command in a `bash` or `zsh` shell with Julienne's root directory as your present working directory: ``` fpm run scaffold \ --compiler flang-new \ -- --json-file demo/test-suite.json \ --suite-path demo/test ``` where a similar command works with the other supported compilers after editing the `fpm` arguments to mirror those used in [Running the demonstration tests]. The above `fpm` command generates the files in the `demo/test` subdirectory of the following `demo` source tree: ``` demo ├── src │   ├── specimen_m.f90 │   └── widget_m.f90 ├── test    ├── driver.f90    ├── specimen_test_m.f90    └── widget_test_m.f90 ``` The modules inside the `specimen_test_m.f90` and `widget_test_m.f90` files each contain three tests: 1. One test intentionally fails and demonstrates the construction of a test diagnosis via an idiom using Julienne's defined operations: ``` test_diagnosis = .all.([22./7., 3.14159] .approximates. pi .within. 0.001) ``` The resulting failure of the first approximation (`22./7.`) generates a diagnostic message for that approximation only. 2. Another test demonstrates the use of the `test_diagnosis_t()` user-defined structure constructor, which supports tasks that cannot be conveniently expressed with the operators defined in the README.md file in the root of Julienne's source tree. ``` test_diagnosis = test_diagnosis_t(test_passed = 1 == 1, diagnostics_string = 'craziness ensued') ``` 3. A third test demonstrates how to skip a test by not including a diagnosis function in the corresponding test description, which is useful when a test is known to crash with a specific build configuration for example. The driver program imports the `test_t` child types. The driver then constructs a `test_harness_t` object from an array of `test_fixture_t` objects. The driver constructs `test_fixture_t` objects from structure constructors provided by the language standard for each test type. Forming diagnostic strings -------------------------- Julienne provides string-manipulation utilities to support the construction of the `test_diagnosis_t` constructor's `diagnostics_string` argument. The `string_t` generic interface can be used to invoke various specific functions, each of which takes an argument of a different data type, kind, or rank (TKR) and defines a `string_t` result encapsulating a `character` representation of the function argument. For the currently supported TKR, please see Julienne's online [documentation](https://berkeleylab.github.io/julienne). An especially useful pattern for forming diagnostic strings involves invoking Julienne's `operator(.csv.)` to form a string of comma-separated values (CSV) from a one-dimensional (1D) array. For example, consider the following test description: ```fortran test_description_t("returning the counting numbers up to 3", check_counting_numbers) ``` and the following corresponding test: ```fortran function check_counting_numbers() integer, parameter :: expected_array(*) = [1, 2, 3] associate(actual_array => counting_numbers(max=3)) test_diagnosis = test_diagnosis_t( & test_passed = all(expected_array == actual_array) & ,diagnostics_string = "expected " // .csv. string_t(expected_array) // "; actual // .csv. string_t(actual_array) & ) end associate end function ``` If the `counting_numbers` result contains all zeros, the test report would include the following text: ``` FAILS on returning the counting numbers up to 3 diagnostics: expected 1,2,3; actual 0,0,0 ``` To support a common array notation, Julienne also supports bracketing strings. Diagnosis Functions ------------------- The Unified Modeling Language ([UML]) class diagram below depicts some of the class relationships involved in making the above example work: ```mermaid %%{init: { 'theme':'default', "class" : {"hideEmptyMembersBox": true} } }%% classDiagram class test_t{ <> subject() character(len=:) * results() test_result_t[0..*] * report(passes : integer, tests : integer, skips : integer) } test_t --> specimen_test_t : report() invokes subject() and results() on class specimen_test_t{ subject() character(len=:) results() test_result_t[0..*] } specimen_test_t --|> test_t : extends and implements specimen_test_t --> test_description_t : results() passes run() an array of specimen_test_t --> test_t : results() invokes run() on class test_description_t{ test_description_t(description : string_t, diagnosis_function : diagnosis_function_i) run() test_result_t } ``` Skipping Tests -------------- When a test is known to cause a compile-time or runtime crash in a specific scenario, e.g., with a specific compiler or compiler version, including that test will prevent the test suite from building or running to completion. It can be useful to skip a test with the problematic compiler but to report the test as skipped and account for the skipped tests in the tally of test results. For this purpose, the `test_description_t` constructor function has an optional `diagnosis_function` argument. When these arguments are not `present`, the `test_t`'s `report` procedure will report the test as skipped but will terminate normally as long as the sum of the passing tests and skipped tests equals the total number of tests. One might accomplish this with the compiler's predefined preprocessor macro: ``` #ifndef __GFORTRAN__ ,test_description_t('constructing bracketed strings', brackets_strings_ptr) & #else ,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` 13 bug. String-Handling Functions ------------------------- Because of the central role that `string_t` type-bound procedures play in defining diagnostics strings, we list most of these procedures in the class diagram below. ```mermaid classDiagram class string_t{ string_t(integer) string_t string_t(logical) string_t string_t(logical(c_bool)) string_t string_t(real) string_t string_t(double precision) string_t string_t(character(len=*)) string_t string_t(complex) string_t string_t(complex(kind(1D0))) string_t operator(//)(string_t, string_t) operator(//)(string_t, character(len=*)) operator(//)(character(len=*), string_t) operator(.csv.)(string_t) string_t operator(.csv.)(character(len=*)) string_t operator(.sv.)(strings : string_t[1..*], separator : character(len=*)) string_t operator(.sv.)(strings : character(len=*)[1..*], separator : character(len=*)) string_t operator(.sv.)(strings : string_t[1..*], separator : string_t) string_t array_of_strings(delimited_strings : character(len=*), delimiter : character(len=*)) file_extension(string_t) string_t base_name(string_t) string_t } ``` [UML]: https://wikipedia.org/Unified_modeling_language [running the demonstration tests]: #running-the-demonstration-tests [generating test scaffolding]: #generating-test-scaffolding [Forming Diagnostics Strings]: #forming-diagnostics-strings [String-Handling Functions]: #string-handling-functions [Running the demonstration tests]: #running-the-demonstration-tests fortran-julienne-3.6.2/demo/fpm.toml0000664000175000017500000000010615151766762017610 0ustar alastairalastairname = "Example-Test-Suite" [dependencies] julienne = {path = "../"} fortran-julienne-3.6.2/fpm.toml0000664000175000017500000000020415151766762016663 0ustar alastairalastairname = "julienne" [dependencies] assert = {git = "https://github.com/berkeleylab/assert", tag = "3.0.2"} [install] library = true fortran-julienne-3.6.2/.gitignore0000664000175000017500000000004315151766762017175 0ustar alastairalastair*.smod *.mod *.o a.out build *.swp fortran-julienne-3.6.2/include/0000775000175000017500000000000015151766762016633 5ustar alastairalastairfortran-julienne-3.6.2/include/julienne-assert-macros.h0000664000175000017500000000111215151766762023371 0ustar alastairalastair! julienne-assert-macros.h: provides preprocessor-based assertion macros ! that are guaranteed to compile away statically when disabled. #include "assert_macros.h" #ifndef ASSERTIONS ! Assertions are off by default #define ASSERTIONS 0 #endif ! Enable repeated includes to toggle assertions based on current settings: #undef call_julienne_assert #if ASSERTIONS # define call_julienne_assert(assertion) call call_julienne_assert_(assertion, __FILE__, __LINE__, "call_julienne_assert(" // CPP_STRINGIFY_SOURCE(assertion) // ") ") #else # define call_julienne_assert(assertion) #endif fortran-julienne-3.6.2/include/language-support.F900000664000175000017500000000436215151766762022415 0ustar alastairalastair! 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 #ifdef __GNUC__ # define GCC_VERSION (__GNUC__ * 10000 + __GNUC_MINOR__ * 100 + __GNUC_PATCHLEVEL__) #else # define GCC_VERSION 0 #endif #if __GNUC__ && ( __GNUC__ < 14 || (__GNUC__ == 14 && __GNUC_MINOR__ < 3) ) #define GCC_GE_MINIMUM #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__) || defined(__LFORTRAN__) || (defined(__INTEL_COMPILER) && (__INTEL_COMPILER < 20250201)) # 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 invoke ! co_max with a character array first argument, a feature used in Julienne's co_gather function #ifndef HAVE_CO_MAX_CHARACTER_ARRAY_SUPPORT # if ! HAVE_MULTI_IMAGE_SUPPORT # define HAVE_CO_MAX_CHARACTER_ARRAY_SUPPORT 0 # elif defined(_CRAYFTN) || defined(NAGFOR) || defined(__flang__) # define HAVE_CO_MAX_CHARACTER_ARRAY_SUPPORT 1 # else # define HAVE_CO_MAX_CHARACTER_ARRAY_SUPPORT 0 # endif #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(_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 ! 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__) || defined(__LFORTRAN__) # define HAVE_DERIVED_TYPE_KIND_PARAMETERS 0 # else # define HAVE_DERIVED_TYPE_KIND_PARAMETERS 1 # endif #endif #endif fortran-julienne-3.6.2/.github/0000775000175000017500000000000015151766762016550 5ustar alastairalastairfortran-julienne-3.6.2/.github/workflows/0000775000175000017500000000000015151766762020605 5ustar alastairalastairfortran-julienne-3.6.2/.github/workflows/build.yml0000664000175000017500000002006415151766762022431 0ustar alastairalastairname: Build on: [push, pull_request] defaults: run: shell: bash jobs: build: name: ${{ matrix.compiler }}-${{ matrix.version }} (${{ matrix.os }}) runs-on: ${{ matrix.os }} strategy: fail-fast: false matrix: os: [ macos-14, macos-15, macos-15-intel, macos-26, ubuntu-24.04 ] compiler: [ gfortran ] version: [ 13, 14, 15 ] extra_flags: [ -g -O3 ] include: # --- LLVM flang coverage --- - os: macos-14 compiler: flang version: 21 - os: macos-15 compiler: flang version: 21 - os: macos-15-intel compiler: flang version: 21 - os: macos-26 compiler: flang version: 21 # https://hub.docker.com/r/snowstep/llvm/tags - os: ubuntu-24.04 compiler: flang version: latest container: snowstep/llvm:noble - os: ubuntu-22.04 compiler: flang version: latest container: snowstep/llvm:jammy # https://hub.docker.com/r/phhargrove/llvm-flang/tags - os: ubuntu-24.04 compiler: flang version: 22 container: phhargrove/llvm-flang:22.1.0-latest - os: ubuntu-24.04 compiler: flang version: 21 container: phhargrove/llvm-flang:21.1.0-latest - os: ubuntu-24.04 compiler: flang version: 20 container: phhargrove/llvm-flang:20.1.0-latest - os: ubuntu-24.04 compiler: flang version: 19 extra_flags: -g -mmlir -allow-assumed-rank -O3 container: phhargrove/llvm-flang:19.1.1-latest # --- Intel coverage --- # https://hub.docker.com/r/intel/fortran-essentials/tags - os: ubuntu-24.04 compiler: ifx version: 2025.2.0 error_stop_code: 128 container: intel/fortran-essentials:2025.2.0-0-devel-ubuntu24.04 - os: ubuntu-24.04 compiler: ifx version: 2025.2.2 error_stop_code: 128 container: intel/fortran-essentials:2025.2.2-0-devel-ubuntu24.04 - os: ubuntu-24.04 compiler: ifx version: latest error_stop_code: 128 container: intel/fortran-essentials:latest # --- LFortran coverage --- # https://hub.docker.com/r/phhargrove/lfortran/tags #- os: ubuntu-24.04 # compiler: lfortran # version: 0.54.0 # container: phhargrove/lfortran:0.54.0-1 container: image: ${{ matrix.container }} env: COMPILER_VERSION: ${{ matrix.version }} FC: ${{ matrix.compiler }} FFLAGS: ${{ matrix.extra_flags }} FPM_FLAGS: --profile release --verbose steps: - name: Checkout code uses: actions/checkout@v4 - name: Install Dependencies Ubuntu if: ${{ contains(matrix.os, 'ubuntu') && matrix.compiler == 'gfortran' && matrix.version == '15' }} run: | sudo apt-get update sudo apt list -a 'gfortran-*' sudo apt install -y build-essential if [[ ${COMPILER_VERSION} < 15 ]] ; then \ sudo apt install -y gfortran-${COMPILER_VERSION} ; \ else \ curl -L https://raw.githubusercontent.com/Homebrew/install/HEAD/install.sh -o install-homebrew.sh ; \ chmod +x install-homebrew.sh ; \ env CI=1 ./install-homebrew.sh ; \ HOMEBREW_PREFIX="/home/linuxbrew/.linuxbrew" ; \ ${HOMEBREW_PREFIX}/bin/brew install -v gcc@${COMPILER_VERSION} binutils ; \ ls -al ${HOMEBREW_PREFIX}/bin ; \ echo "PATH=${HOMEBREW_PREFIX}/bin:${PATH}" >> "$GITHUB_ENV" ; \ : Homebrew GCC@15 needs binutils 2.44+ ; \ HOMEBREW_BINUTILS=$(ls -d ${HOMEBREW_PREFIX}/Cellar/binutils/2.*/bin ) ; \ ls -al ${HOMEBREW_BINUTILS} ; \ echo "FFLAGS=$FFLAGS -B ${HOMEBREW_BINUTILS}" >> "$GITHUB_ENV" ; \ echo "CFLAGS=$CFLAGS -B ${HOMEBREW_BINUTILS}" >> "$GITHUB_ENV" ; \ echo "CXXFLAGS=$CXXFLAGS -B ${HOMEBREW_BINUTILS}" >> "$GITHUB_ENV" ; \ fi - name: Install Ubuntu Container Dependencies if: ${{ contains(matrix.os, 'ubuntu') && matrix.container != '' && !contains(matrix.container, 'phhargrove') }} run: | set -x apt update apt install -y build-essential pkg-config make git curl - name: Install macOS Dependencies if: contains(matrix.os, 'macos') run: | set -x brew update # fpm binary distribution for macOS requires gfortran shared libraries from gcc@12 brew install gcc@12 - name: Install LLVM flang on macOS if: contains(matrix.os, 'macos') && matrix.compiler == 'flang' run: | set -x brew install llvm@${COMPILER_VERSION} flang # workaround issue #228: clang cannot find homebrew flang's C header for p in /opt/homebrew /usr/local $(brew --prefix) ; do find $p/Cellar/flang -name ISO_Fortran_binding.h 2>/dev/null || true ; done echo "CFLAGS=-I$(dirname $(find $(brew --prefix)/Cellar/flang -name ISO_Fortran_binding.h | head -1)) ${CFLAGS}" >> "$GITHUB_ENV" # Prepend homebrew clang to PATH: echo "PATH=$(brew --prefix)/opt/llvm/bin:${PATH}" >> "$GITHUB_ENV" - name: Setup Compilers run: | set -x if test "$FC" = "flang" ; then \ echo "FPM_FC=flang-new" >> "$GITHUB_ENV" ; \ elif test "$FC" = "ifx" ; then \ echo "FPM_FC=ifx" >> "$GITHUB_ENV" ; \ echo "FFLAGS=-coarray -fpp -g -traceback $FFLAGS" >> "$GITHUB_ENV" ; \ echo "FOR_COARRAY_NUM_IMAGES=4" >> "$GITHUB_ENV" ; \ : echo "FOR_COARRAY_DEBUG_STARTUP=1" >> "$GITHUB_ENV" ; \ : echo "FOR_COARRAY_MPI_VERBOSE=1" >> "$GITHUB_ENV" ; \ elif test "$FC" = "lfortran" ; then \ echo "FPM_FC=lfortran" >> "$GITHUB_ENV" ; \ echo "FFLAGS=--cpp $FFLAGS" >> "$GITHUB_ENV" ; \ else \ echo "FPM_FC=gfortran-${COMPILER_VERSION}" >> "$GITHUB_ENV" ; \ echo "FFLAGS=-ffree-line-length-0 $FFLAGS" >> "$GITHUB_ENV" ; \ fi if [[ "${{ matrix.container }}" =~ "snowstep/llvm" ]] ; then \ echo "LD_LIBRARY_PATH=/usr/lib/llvm-22/lib:$LD_LIBRARY_PATH" >> "$GITHUB_ENV" ; \ fi if test -n "${{ matrix.error_stop_code }}" ; then \ echo "ERROR_STOP_CODE=${{ matrix.error_stop_code }}" >> "$GITHUB_ENV" ; \ else \ echo "ERROR_STOP_CODE=1" >> "$GITHUB_ENV" ; \ fi - name: Setup FPM uses: fortran-lang/setup-fpm@main with: github-token: ${{ secrets.GITHUB_TOKEN }} fpm-version: latest - name: Build FPM if: false run: | set -x export FPM_VERSION=0.12.0 curl --retry 5 -LOsS https://github.com/fortran-lang/fpm/releases/download/v$FPM_VERSION/fpm-$FPM_VERSION.F90 mkdir fpm-temp gfortran-14 -o fpm-temp/fpm fpm-$FPM_VERSION.F90 echo "PATH=`pwd`/fpm-temp:${PATH}" >> "$GITHUB_ENV" - name: Version info run: | echo == TOOL VERSIONS == echo Platform version info: uname -a if test -r /etc/os-release ; then grep -e NAME -e VERSION /etc/os-release ; fi if test -x /usr/bin/sw_vers ; then /usr/bin/sw_vers ; fi echo echo PATH="$PATH" for tool in ${FPM_FC} fpm ; do ( echo ; set -x ; w=$(which $tool) ; ls -al $w ; ls -alhL $w ; $tool --version ) done - name: Build and Test (Assertions OFF) run: | set -x fpm test ${FPM_FLAGS} --flag "$FFLAGS" - name: Build and Test (Assertions ON) env: FPM_FLAGS: ${{ env.FPM_FLAGS }} --flag -DASSERTIONS run: | set -x fpm test ${FPM_FLAGS} --flag "$FFLAGS" - name: Test w/ Parallel Callbacks env: FPM_FLAGS: ${{ env.FPM_FLAGS }} --flag -DJULIENNE_PARALLEL_CALLBACKS --flag -DTEST_PARALLEL_CALLBACKS run: | set -x fpm test ${FPM_FLAGS} --flag "$FFLAGS" fortran-julienne-3.6.2/.github/workflows/deploy-docs.yml0000664000175000017500000000215315151766762023553 0ustar alastairalastairname: Build and Deploy Documentation on: [push, pull_request] jobs: Build: runs-on: ubuntu-22.04 steps: - name: Checkout code uses: actions/checkout@v4 - name: Install Dependencies Ubuntu run: | sudo apt-get update sudo apt install -y python3-dev python3 build-essential graphviz sudo python3 -m pip install ford - name: Build Developer Documenation run: | ford ford.md - name: Upload Documentation uses: actions/upload-artifact@v4 with: name: documentation path: doc/html if-no-files-found: error - name: Broken Link Check if: ${{ github.ref == 'refs/heads/main'}} uses: technote-space/broken-link-checker-action@v1 with: TARGET: file://${{ github.workspace }}/doc/html/index.html RECURSIVE: true ASSIGNEES: ${{ github.actor }} - name: Deploy API Documentation uses: JamesIves/github-pages-deploy-action@4.1.0 if: ${{ github.event_name == 'push' && github.ref == 'refs/heads/main' }} with: branch: gh-pages folder: doc/html