[MLton] Bug report

[Stephen Weeks]

> The following program raises exception "UnequalLengths".  I am
> guessing it shouldn't.

Thanks for the bug report.  The problem was in our basis library
implementation of the ListPair structure.  I've checked a fix into our
CVS.  If you want to apply the fix immediately, you can replace the
contents of

	/usr/lib/mlton/sml/basis-library/list/list-pair.sml

on your machine with the code below.

--------------------------------------------------------------------------------

(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-1999 NEC Research Institute.
 *
 * MLton is released under the GNU General Public License (GPL).
 * Please see the file MLton-LICENSE for license information.
 *)
structure ListPair: LIST_PAIR =
   struct
      exception UnequalLengths

      fun id x = x

      fun ul _ = raise UnequalLengths

      fun unzip l =
	 List.foldr (fn ((x, y), (xs, ys)) => (x :: xs, y :: ys)) ([], []) l

      fun foldl' w f b (l1, l2) =
	 let
	    fun loop (l1, l2, b) =
	       case (l1, l2) of
		  ([], []) => b
		| (x1 :: l1, x2 :: l2) => loop (l1, l2, f (x1, x2, b))
		| _ => w b
	 in
	    loop (l1, l2, b)
	 end

      fun foldl f = foldl' id f

      fun foldlEq f = foldl' ul f

      fun foldr' w f b (l1, l2) =
	 let
	    fun loop (l1, l2) =
	       case (l1, l2) of
		  ([], []) => b
		| (x1 :: l1, x2 :: l2) => f (x1, x2, loop (l1, l2))
		| _ => w b
	 in
	    loop (l1, l2)
	 end

      fun foldr f = foldr' id f
	 
      fun foldrEq f = foldr' ul f

      fun zip' w (l1, l2) =
	 rev (foldl' w (fn (x, x', l) => (x, x') :: l) [] (l1, l2))

      fun zip (l1, l2) = zip' id (l1, l2)

      fun zipEq (l1, l2) = zip' ul (l1, l2)
	 
      fun map' w f = rev o (foldl' w (fn (x1, x2, l) => f (x1, x2) :: l) [])

      fun map f = map' id f

      fun mapEq f = map' ul f
	 
      fun app' w f = foldl' w (fn (x1, x2, ()) => f (x1, x2)) ()

      fun app f = app' id f

      fun appEq f = app' ul f

      fun exists p (l1, l2) =
	 let
	    fun loop (l1, l2) =
	       case (l1, l2) of
		  (x1 :: l1, x2 :: l2) => p (x1, x2) orelse loop (l1, l2)
		| _ => false
	 in
	    loop (l1, l2)
	 end
       
      fun all p ls = not (exists (not o p) ls)

      fun allEq p =
	 let
	    fun loop (l1, l2) =
	       case (l1, l2) of
		  ([], []) => true
		| (x1 :: l1, x2 :: l2) => p (x1, x2) andalso loop (l1, l2)
		| _ => false
	 in
	    loop
	 end
   end