Skip to content

Eliminate the need for .all. #184

Description

@rouson

The code below demonstrates a way to eliminate the need for Julienne's .all. operator. After developing this code last month, I made an attempt to adopt this strategy in Julienne and ran into problems but unfortunately I don't recall what the issue was. I think it was an inexplicable runtime crash with more than one compiler. I think the code below is standard-conforming, but it's possible that introducing this approach in the context of Julienne leads a language constraint violation somewhere along the way -- causing runs to crash with multiple compilers.

I'm putting the code here for preservation and to remind myself or someone else so motivated to investigate this.

module test_diagnosis_m
  implicit none

  type test_diagnosis_t
    logical :: test_passed = .true.
  contains
    generic :: assignment(=) => aggregate
    procedure aggregate
  end  type

  interface operator(.equalsExpected.)
    module procedure integer_equalsExpected
  end interface

  interface operator(.also.)
    module procedure also_all
  end interface

  interface string
    module procedure integer_to_string, logical_to_string
  end interface

contains

  subroutine aggregate(lhs, rhs)
    class(test_diagnosis_t), intent(inout) :: lhs
    type(test_diagnosis_t), intent(in) :: rhs(..)
    select rank(rhs)
    rank(0)
      lhs%test_passed = rhs%test_passed
    rank(1)
      lhs%test_passed = all(rhs%test_passed)
    rank default
      error stop "aggregate: unsupported rank " // string(rank(rhs))
    end select
  end subroutine

  elemental function integer_equalsExpected(lhs, rhs) result(test_diagnosis)
    integer, intent(in) :: lhs, rhs
    type(test_diagnosis_t) test_diagnosis
    test_diagnosis%test_passed = lhs == rhs 
  end function

  pure function also_all(lhs, rhs) result(test_diagnosis)
    type(test_diagnosis_t), intent(in) :: lhs, rhs(..)
    type(test_diagnosis_t) test_diagnosis
    select rank(rhs)
    rank(0)
      test_diagnosis%test_passed = lhs%test_passed .and. rhs%test_passed
    rank(1)
      test_diagnosis%test_passed = all(lhs%test_passed .and. rhs%test_passed)
    rank(2)
      test_diagnosis%test_passed = all(lhs%test_passed .and. rhs%test_passed)
    rank default
      error stop "also_all: unsupported rank " // string(rank(rhs))
    end select
  end function

  pure function integer_to_string(i) result(i_as_string)
    integer, intent(in) :: i
    character(len=12) i_as_string
    write(i_as_string,'(i12)') i 
  end function

  pure function logical_to_string(bool) result(bool_as_string)
    logical, intent(in) :: bool
    character(len=:), allocatable :: bool_as_string
    bool_as_string = trim(merge("true ", "false", bool))
  end function

end module test_diagnosis_m

program main
  use test_diagnosis_m
  implicit none

  type(test_diagnosis_t) diagnosis

  diagnosis = 2 .equalsExpected. [2,2]
  print *,"Expected true, Actually ", string(diagnosis%test_passed)

  diagnosis = [1,2] .equalsExpected. [1,2]
  print *,"Expected true, Actually ", string(diagnosis%test_passed)

  diagnosis = [1,2] .equalsExpected. 1
  print *,"Expected false, Actually ", string(diagnosis%test_passed)

  diagnosis = diagnosis .also. (1 .equalsExpected. 1)
  print *,"Expected false, Actually ", string(diagnosis%test_passed)

  diagnosis = diagnosis .also. ([1,2] .equalsExpected. 1)
  print *,"Expected false, Actually ", string(diagnosis%test_passed)

end program

Metadata

Metadata

Assignees

No one assigned

    Labels

    No labels
    No labels

    Type

    No type

    Projects

    No projects

    Milestone

    No milestone

    Relationships

    None yet

    Development

    No branches or pull requests

    Issue actions