looping with class(*)? Easy as a tail recursion

module cons_pairs
  use iso_fortran_env, only : error_unit

  implicit none

  type cons_nil
  end type cons_nil

  type cons_pair
     class(*), allocatable :: car
     class(*), allocatable :: cdr
  end type cons_pair

  contains

    function nil () result (lst)
      class(cons_nil), allocatable :: lst
      allocate (lst)
    end function nil

    function is_nil (object) result (truth)
      class(*) :: object
      logical :: truth
      select type (object)
      class is (cons_nil)
         truth = .true.
      class default
         truth = .false.
      end select
    end function is_nil

    function is_pair (object) result (truth)
      class(*) :: object
      logical :: truth
      select type (object)
      class is (cons_pair)
         truth = .true.
      class default
         truth = .false.
      end select
    end function is_pair

    function cons (car, cdr) result (pair)
      class(*), intent(in) :: car
      class(*), intent(in) :: cdr
      class(cons_pair), allocatable :: pair
      allocate (pair)
      pair%car = car
      pair%cdr = cdr
    end function cons

    function car (pair) result (element)
      class(*), intent(in) :: pair
      class(*), allocatable :: element
      select type (pair)
      class is (cons_pair)
         element = pair%car
      class default
         write (error_unit, '("Error: ", a)') &
              "car(p) where p is not a cons_pair"
         call abort
      end select
    end function car

    function cdr (pair) result (element)
      class(*), intent(in) :: pair
      class(*), allocatable :: element
      select type (pair)
      class is (cons_pair)
         element = pair%cdr
      class default
         write (error_unit, '("Error: ", a)') &
              "cdr(p) where p is not a cons_pair"
         call abort
      end select
    end function cdr

    function list_length (lst) result (length)
      ! FIXME: Does not check for circular list.
      class(*), value :: lst
      integer :: length
      length = loop (lst, 0)
    contains
      recursive function loop (lst, len) result (length)
        class(*), value :: lst
        integer, value :: len
        integer :: length
        select type (lst)
        class is (cons_nil)
           length = len
        class is (cons_pair)
           length = loop (lst%cdr, len + 1)
        class default
           write (error_unit, '("Error: ", a)') &
                "list_length (lst) where lst is not a proper list"
           call abort
        end select
      end function loop
    end function list_length

end module cons_pairs