1 files changed, 138 insertions, 0 deletions
diff --git a/testsuite/tests/concurrent/prog003/IOList.lhs b/testsuite/tests/concurrent/prog003/IOList.lhs
new file mode 100644
index 0000000000..72aa1dee46
--- /dev/null
+++ b/testsuite/tests/concurrent/prog003/IOList.lhs
@@ -0,0 +1,138 @@
+> {-# LANGUAGE BangPatterns,CPP #-}
+> module IOList where
+
+-- #define USE_UNPACK
+-- #define USE_STRICT
+
+#if defined(USE_UNPACK)
+#define UNPACK(p) {-# UNPACK #-} !(p)
+#elif defined(USE_STRICT)
+#define UNPACK(p) !(p)
+#else
+#define UNPACK(p) p
+#endif
+
+> import Data.IORef
+
+
+> data List a = Node { val :: a, next :: UNPACK(IORef (List a))}   
+>           | Null
+>           | Head {next :: UNPACK(IORef (List a)) }
+
+> data ListHandle a = ListHandle { headList :: UNPACK(IORef (IORef (List a))),
+>                            tailList :: UNPACK(IORef (IORef (List a))) }
+
+> atomically = \x -> x
+
+
+> -- we create a new list
+> newList :: IO (ListHandle a)
+> newList = 
+>   do null <- newIORef Null
+>      hd <- newIORef (Head {next = null })
+>      hdPtr <- newIORef hd
+>      tailPtr <- newIORef null
+>      return (ListHandle {headList = hdPtr, tailList = tailPtr})
+  
+> find ::  Eq a => ListHandle a -> a -> IO Bool
+> find (ListHandle {headList = ptrPtr})  i =  do 
+>  ptr <- readIORef ptrPtr
+>  Head {next = startptr} <- readIORef ptr
+>  find2 startptr i 
+>   where 
+>    find2 :: Eq a => IORef (List a) -> a -> IO Bool
+>    find2 curNodePtr i = do
+>    { curNode <- readIORef curNodePtr
+>    ; case curNode of
+>        Null -> return False  -- we've reached the end of the list
+>                              -- element not found
+>        Node {val = curval, next = curnext} ->
+>          if (curval == i) then return True -- element found
+>          else find2 curnext i              -- keep searching
+>    }
+ 
+
+> -- we add a new node, by overwriting the null tail node
+> -- we only need to adjust tailList but not headList because
+> -- of the static Head
+> -- we return the location of the newly added node
+> addToTail :: ListHandle a -> a -> IO (IORef (List a))
+> addToTail (ListHandle {tailList = tailPtrPtr}) x =
+>   do tPtr <- atomically (
+>                do null <- newIORef Null
+>                   tailPtr <- readIORef tailPtrPtr
+>                   writeIORef tailPtr (Node {val = x, next = null})
+>                   writeIORef tailPtrPtr null
+>                   return tailPtr
+>              )
+>      return tPtr
+
+
+> delete :: Eq a => ListHandle a -> a -> IO Bool
+> delete (ListHandle {headList = ptrPtr})  i = 
+>  atomically (
+>          do startptr <- readIORef ptrPtr
+>             delete2 startptr i)
+>   where
+>    delete2 :: Eq a => IORef (List a) -> a -> IO Bool
+>    delete2 prevPtr i =
+>     do
+>    { prevNode <- readIORef prevPtr
+>    ; let curNodePtr = next prevNode --  head/node have both next 
+>    ; curNode <- readIORef curNodePtr
+>    ; case curNode of
+>        Null -> return False  -- we've reached the end of the list
+>                              -- element not found
+>        Node {val = curval, next = nextNode} ->
+>          if (curval /= i) 
+>           then delete2 curNodePtr i         -- keep searching
+>           else 
+>               -- delete element (ie delink node)
+>               do { case prevNode of
+>                      Head {} -> do writeIORef prevPtr (Head {next = nextNode})
+>                                    return True
+>                      Node {} -> do writeIORef prevPtr
+>                                       (Node {val = val prevNode, next = nextNode})
+>                                    return True
+>                  }
+>     }
+
+
+printing and counting
+
+> printList :: Show a => ListHandle a -> IO ()
+> printList (ListHandle {headList = ptrPtr}) =
+>   do startptr <- (
+>          do ptr <- readIORef ptrPtr
+>             Head {next = startptr} <- readIORef ptr
+>             return startptr)
+>      printListHelp startptr
+
+
+> printListHelp :: Show a => IORef (List a) -> IO ()
+> printListHelp curNodePtr =
+>   do { curNode <- readIORef curNodePtr
+>      ; case curNode of
+>          Null -> putStr "Nil"
+>          Node {val = curval, next = curnext} ->
+>             do { putStr (show curval  ++ " -> ")
+>                ;  printListHelp curnext }
+>      } 
+
+> cntList :: Show a => ListHandle a -> IO Int
+> cntList (ListHandle {headList = ptrPtr}) =
+>  do startptr <- (
+>          do ptr <- readIORef ptrPtr
+>             Head {next = startptr} <- readIORef ptr
+>             return startptr)
+>     cntListHelp startptr 0
+
+
+> cntListHelp :: Show a => IORef (List a) -> Int -> IO Int
+> cntListHelp curNodePtr i =
+>   do { curNode <- readIORef curNodePtr
+>      ; case curNode of
+>          Null -> return i
+>          Node {val = curval, next = curnext} -> 
+>                cntListHelp curnext (i+1)
+>      }