Commit e6b8a949 authored by bbr's avatar bbr
Browse files

error located and bug fixed

- several functions in external prelude made more maintainable
parent 0f1ee4aa
......@@ -69,11 +69,11 @@ ctcStore mode cont x state =
in case changeStore ref state of
Inconsistent -> failed (curryError "ctcStore")
Found i -> contCTC (bs!!i) state
NoBinding contSt -> if mode || not (isGenerator ref)
NoBinding i contSt -> if mode || not (isGenerator ref)
then lift contCTC ref bs contSt
else cont x state
NewInfo ref st -> branching ref [cont (head bs) state]
FoundAndNewInfo i ref st -> branching ref [cont (bs!!i) state]
else cont (branching (updRef (\_->i) ref) bs) state
NewInfo ref st -> branching ref [contCTC (head bs) st]
FoundAndNewInfo i ref st -> branching ref [contCTC (bs!!i) st]
where
contCTC = ctcStore mode cont
err = curryError ("Prelude."++if mode then "$#" else "$!")
......@@ -82,7 +82,7 @@ mapOr :: BaseCurry b => (a -> Result b) -> OrRef -> Branches a -> Result b
mapOr cont ref bs st = case changeStore ref st of
Inconsistent -> failed (curryError "lift")
Found i -> cont (bs!!i) st
NoBinding contSt -> lift cont ref bs contSt
NoBinding _ contSt -> lift cont ref bs contSt
NewInfo ref st -> branching ref [cont (head bs) st]
FoundAndNewInfo i ref st -> branching ref [cont (bs!!i) st]
......
......@@ -9,7 +9,7 @@ module Store
mkRefWithGenInfo,equalFromTo,
isGenerator, isConstr,
isGenerator, isConstr,updRef,
narrowOrRef
......@@ -56,6 +56,7 @@ mkRefWithGenInfo = OrRef
deref :: OrRef -> Int
deref r = case uncover r of
OrRef _ i -> i
_ -> (-42)
genInfo :: OrRef -> (Int,Int,Int)
genInfo r = case uncover r of
......@@ -81,6 +82,12 @@ updKind f (Layer r) = Layer (updKind f r)
updKind f (OrRef k i) = OrRef (f k) i
updKind f c@(Equality _ _ _ _ _ _) = c
updRef :: (Int -> Int) -> OrRef -> OrRef
updRef f (Layer r) = Layer (updRef f r)
updRef f (OrRef k i) = OrRef k (f i)
updRef f c@(Equality _ _ _ _ _ _) = c
narrowOrRef :: OrRef -> OrRef
narrowOrRef = updKind narrow
where
......@@ -116,14 +123,22 @@ emptyStore :: Store
emptyStore = Store empty
data StoreResult = Inconsistent
| NoBinding (Int -> Store)
| NoBinding Int (Int -> Store)
| Found Int
| NewInfo OrRef Store
| FoundAndNewInfo Int OrRef Store
instance Show StoreResult where
show Inconsistent = "I"
show (NoBinding i _) = "no"++show i
show (Found i) = "f "++show i
show (NewInfo r st) = "n"++show (r,st)
show (FoundAndNewInfo i r st) = "fn"++show (i,r,st)
changeStore :: OrRef -> Store -> StoreResult
changeStore r st =
trace (show (r,st)) $ trace' $
case uncover r of
OrRef k r -> let (toEntry,mima) = minMax k in
access toEntry (mima >>= \ (i,j) -> Just (i,j,r)) r st
......@@ -175,17 +190,17 @@ insertEntry key e st@(Store store) = case lookup key store of
access :: (Int->Entry) -> Maybe (Int,Int,Int) -> Int -> Store -> StoreResult
access toEntry mima key st@(Store store) = case lookup key store of
Nothing -> NoBinding (\ i -> Store (insert key (toEntry i) store))
Nothing -> NoBinding key (\ i -> Store (insert key (toEntry i) store))
Just (Equal key') -> access toEntry mima key' st
Just (Choice i) -> Found i
Just (Binding bmin bmax i) -> case mima of
Nothing -> Found i
Just (amin,amax,key0) -> case compare key0 key of
EQ -> Found i
LT -> let info = Equality amin amax key0 bmin bmax key in
Just (amin,amax,key0) -> case compare amin bmin of
EQ -> trace "EQ" Found i
_ -> trace "LT" $ let info = Equality amin amax key0 bmin bmax key in
maybe Inconsistent (FoundAndNewInfo i info) $
foldChain (key0:[amin .. amax]) (key:[bmin .. bmax]) st
GT -> error "order violated"
foldChain [amin .. amax] [bmin .. bmax] st
--GT -> error "order violated"
......
......@@ -4,28 +4,41 @@ import Data.Tree
import CurryPrelude
import Curry
optChStore err det br ref bs st = case changeStore ref st of
Inconsistent -> err
Found i -> det i (bs!!i) st
NoBinding _ contSt -> br contSt
NewInfo ref st -> det 0 (head bs) st
FoundAndNewInfo i ref st -> det i (bs!!i) st
showSearchTree :: Curry a => State -> a -> C_String
showSearchTree _ x = toCurry (drawTree (mkSearchTree emptyStore x))
mkSearchTree :: Curry a => Store -> a -> Tree String
mkSearchTree st x = case consKind x of
Val -> Node "V" (foldCurry (\ xi ts -> mkSearchTree st xi : ts) [] x)
showSearchTree :: Curry a => a -> Result C_String
showSearchTree x st = toCurry (drawTree (mkSearchTree x emptyStore))
mkSearchTree :: Curry a => a -> Result (Tree String)
mkSearchTree x st = case consKind x of
Val -> Node "V" (foldCurry (\ xi ts st -> mkSearchTree xi st : ts) [] x st)
Failed -> Node "F" []
Branching -> let ref = orRef x
bs = branches x in Node ("Or "++show ref) $
case fromStore st ref of
Nothing -> zipWith (descend mkSearchTree st ref) [0..] bs
Just i -> replicate i (Node "X" []) ++
mkSearchTree st (bs !! i) :
replicate (length bs - i - 1) (Node "X" [])
optChStore
[Node "F" []]
(\ i x st -> replicate i (Node "X" []) ++
mkSearchTree x st :
replicate (length bs - i - 1) (Node "X" []))
(\ st -> map ($st) $ zipWith (descend mkSearchTree ref) [0..] bs)
ref bs st
descend :: Curry a => (Store -> a -> b) -> Store -> OrRef -> Int -> a -> b
descend f st r i = f (addToStore st r i)
descend :: Curry a => (a -> Result b) -> OrRef -> Int -> a
-> (Int -> Store) -> b
descend f r i x st = f x (st i)
countGarbage :: Curry a => State -> a -> T2 C_Int C_Int
countGarbage _ x = toCurry (countXs emptyStore x)
countGarbage :: Curry a => a -> Result (T2 C_Int C_Int)
countGarbage x _ = error "countGarbage" --toCurry (countXs emptyStore x)
{-
countXs :: Curry a => Store -> a -> (Integer,Integer)
countXs st x = case consKind x of
Val -> foldCurry (\ xi -> plus (countXs st xi)) (0,0) x
......@@ -38,10 +51,12 @@ countXs st x = case consKind x of
where
plus (x1,x2) (y1,y2) = (x1+y1,x2+y2)
-}
optimizeST :: Curry a => State -> a -> a
optimizeST st x = opt (maybe emptyStore id st) x
optimizeST :: Curry a => a -> Result a
optimizeST x st = error "optimizeST" --opt (maybe emptyStore id st) x
{-
opt :: Curry a => Store -> a -> a
opt st x = case consKind x of
Val -> propagate (opt st) x
......@@ -56,3 +71,5 @@ opt st x = case consKind x of
-}
\ No newline at end of file
......@@ -13,16 +13,26 @@ import InstancesPrelude
import Data.IORef
import Control.Exception (catch)
import qualified Debug.Trace as D
infix 4 ===
infixr 0 &
-----------------------------------------------------------------------
-- IO starter
-----------------------------------------------------------------------
optChangeStore :: a -> (b -> Store -> a) -> ((Int -> Store) -> a)
-> OrRef -> Branches b -> Store -> a
optChangeStore err det br ref bs st = case changeStore ref st of
Inconsistent -> err
Found i -> det (bs!!i) st
NoBinding _ contSt -> br contSt
NewInfo ref st -> det (head bs) st
FoundAndNewInfo i ref st -> det (bs!!i) st
curryIO :: Curry a => (Result (C_IO a)) -> IO a
curryIO x = let st = emptyStore in ioStart st (x st)
......@@ -32,29 +42,29 @@ curryIOVoid x = curryIO x >> Prelude.return ()
ioStart :: Curry a => Store -> C_IO a -> IO a
ioStart st (C_IO act) = act st Prelude.>>= curryDo st
ioStart _ (C_IOFail es) = printExceptions es
ioStart st (C_IOOr ref bs)
| isChain ref = maybe (printExceptions (curryError "ioStart"))
(\st -> ioStart st (head bs))
(addToStore ref 0 st)
| otherwise = case fromStore ref st of
Nothing -> searchValC_IO [] (zipWith (mkChoice st ref) [0..] bs)
Just i -> ioStart st (bs !! i)
ioStart st (C_IOOr ref bs) =
optChangeStore
(printExceptions (curryError "ioStart"))
(flip ioStart)
(\st -> searchValC_IO [] (zipWith (mkChoice st) [0..] bs))
ref
bs
st
curryDo :: Curry a => Store -> IOVal a -> IO a
curryDo _ (IOVal x) = Prelude.return x
curryDo _ (IOValFail es) = printExceptions es
curryDo st (IOValOr ref bs)
| isChain ref = maybe (printExceptions (curryError "curryDo"))
(\ st -> head bs Prelude.>>= curryDo st)
(addToStore ref 0 st)
| otherwise = case fromStore ref st of
Nothing -> searchIOVal [] (zipWith (mkChoice st ref) [0..] bs)
Just i -> (bs !! i) Prelude.>>= curryDo st
mkChoice :: BaseCurry a => Store -> OrRef -> Int -> a -> (Store,a)
mkChoice st ref i x = maybe (st,Curry.failed $ curryError "mkChoice")
(\st -> (st,x))
(addToStore ref i st)
curryDo _ (IOVal x) = Prelude.return x
curryDo _ (IOValFail es) = printExceptions es
curryDo st (IOValOr ref bs) =
optChangeStore
(printExceptions (curryError "curryDo"))
(\ x st -> x Prelude.>>= curryDo st)
(\st -> searchIOVal [] (zipWith (mkChoice st) [0..] bs))
ref
bs
st
mkChoice :: BaseCurry a => (Int -> Store) -> Int -> a -> (Store,a)
mkChoice st i x = (st i,x)
searchValC_IO :: Curry a => [C_Exceptions] -> [(Store,C_IO a)] -> IO a
searchValC_IO es [] =
......@@ -64,8 +74,12 @@ searchValC_IO es ((_ ,C_IOFail e@(ErrorCall _)) : xs) =
searchValC_IO (e:es) xs
searchValC_IO es ((_ ,C_IOFail e) : xs) = searchValC_IO es xs
searchValC_IO es ((st,C_IOOr ref bs) : xs) =
-- switch arguments of (++) for breadth first (bad.), cf. also below
searchValC_IO es (zipWith (mkChoice st ref) [0..] bs ++ xs)
optChangeStore
(searchValC_IO es xs)
(\ (C_IO act) st -> act st Prelude.>>= curryDo st)
-- switch arguments of (++) for breadth first (bad.), cf. also below
(\ st -> searchValC_IO es (zipWith (mkChoice st) [0..] bs ++ xs))
ref bs st
searchIOVal :: Curry a => [C_Exceptions] -> [(Store,IO (IOVal a))] -> IO a
searchIOVal es [] =
......@@ -76,8 +90,13 @@ searchIOVal es ((st,act) : stacts) = do
IOVal a -> Prelude.return a
IOValFail e@(ErrorCall _) -> searchIOVal (e:es) stacts
IOValFail _ -> searchIOVal es stacts
-- switch arguments of (++) for breadth first (bad.)
IOValOr ref bs -> searchIOVal es (zipWith (mkChoice st ref) [0..] bs ++ stacts)
-- switch arguments of (++) for breadth first (bad.)
IOValOr ref bs ->
optChangeStore
(searchIOVal (curryError "inconsistent Store":es) stacts)
(\ x st -> searchIOVal es ((st,x):stacts))
(\st -> searchIOVal es (zipWith (mkChoice st) [0..] bs ++ stacts))
ref bs st
-- this is the place to change for implicit breadth first search
searchVal :: (Store -> a -> b) -> Store -> OrRef -> Branches a -> b
......@@ -212,7 +231,7 @@ prim_chr ci _ = toCurry (chr (fromCurry ci))
success :: C_Success
success = C_Success
concAnd' x y st = startBreadth [x,y] st
--concAnd' x y st = startBreadth [x,y] st
(&) :: C_Success -> C_Success -> Result C_Success
-- (&) x y st = boolToSuccess (concAnd' (successToBool x) (successToBool y) st)
......@@ -231,8 +250,8 @@ successToBool C_Success _ = C_True
successToBool (C_SuccessFail e) _ = C_BoolFail e
successToBool (C_SuccessOr r xs) st = mapOr successToBool r xs st
andBreadth :: List C_Bool -> Result C_Bool
andBreadth xs st = startBreadth (toHaskellList xs) st
--andBreadth :: List C_Bool -> Result C_Bool
--andBreadth xs st = startBreadth (toHaskellList xs) st
-- TODO: C_IO without State??? also other io-functions.
(>>=) :: (Curry a,Curry b) => C_IO a -> Prim (a -> Result (C_IO b)) -> Result (C_IO b)
......@@ -257,23 +276,15 @@ prim_do f x state = case x of
IOVal res -> hnfCTC exec2 (apply f res state) state
IOValFail es -> Prelude.return (IOValFail es)
IOValOr ref bs ->
if isChain ref
then chain (\ x st -> x Prelude.>>= \ x' -> prim_do f x' st) ref bs state
else case fromStore ref state of
Nothing ->
Prelude.return (IOValOr ref
(zipWith (ctcBranch (\ x st -> x Prelude.>>= \ x' -> cont x' st)
ref state) [0..] bs))
Just i -> (bs!!i) Prelude.>>= \ x' -> prim_do f x' state
optChangeStore
(Curry.failed $ curryError "prim_do")
(\ x st -> x Prelude.>>= \ x' -> prim_do f x' st)
(\ st -> Prelude.return (IOValOr ref
(zipWith (\ i x -> x Prelude.>>= \ x' -> cont x' (st i))
[0..] bs)))
ref bs state
where
cont x st = prim_do f x st
newSuspCont suspTest = do
mVal <- suspTest
case mVal of
Nothing -> Prelude.return Nothing
Just v -> do
result <- prim_do f v state
Prelude.return (Just result)
exec2 :: C_IO b -> Result (IO (IOVal b))
exec2 (C_IO f) = f
......@@ -301,22 +312,24 @@ catchFail :: Curry a => C_IO a -> C_IO a -> Result (C_IO a)
catchFail (C_IO act) err _ =
C_IO (\ st -> catch (act st) (const (hnfCTC exec2 err st)))
catchFail (C_IOFail _) err _ = err
catchFail (C_IOOr ref bs) err st
| isChain ref = maybe
err
(catchFail (head bs) err)
(addToStore ref 0 st)
| otherwise = case fromStore ref st of
Nothing -> searchValCatch (zipWith (mkChoice st ref) [0..] bs) err
Just i -> catchFail (bs !! i) err st
catchFail (C_IOOr ref bs) err st =
optChangeStore
err
(flip catchFail err)
(\st -> searchValCatch (zipWith (mkChoice st) [0..] bs) err)
ref bs st
searchValCatch :: Curry a => [(Store,C_IO a)] -> C_IO a -> C_IO a
searchValCatch [] err = err
searchValCatch ((st,C_IO act) : _) err = catchFail (C_IO act) err st
searchValCatch ((_ ,C_IOFail _) : xs) err = searchValCatch xs err
searchValCatch ((st,C_IOOr ref bs) : xs) err =
searchValCatch (zipWith (mkChoice st ref) [0..] bs ++ xs) err
optChangeStore
(searchValCatch xs err)
(\ x st -> catchFail x err st)
(\ st -> searchValCatch (zipWith (mkChoice st) [0..] bs ++ xs) err)
ref bs st
......@@ -329,7 +342,7 @@ getSearchTree x _ = C_IO (\ state -> Prelude.return (IOVal (searchTr x state)))
searchTr :: Curry a => a -> Result (C_SearchTree a)
searchTr x state = transVal (nfCTC (nfCTC (\ x st -> trace (show st) x)) x state)
searchTr x state = transVal (nfCTC (nfCTC (\ x st -> trace ('s':show st) x)) x state)
where
transVal x = case consKind x of
Val -> C_Value x
......@@ -339,7 +352,7 @@ searchTr x state = transVal (nfCTC (nfCTC (\ x st -> trace (show st) x)) x state
| otherwise -> transBranching (branches x)
transBranching [] = C_Fail
transBranching [x] = transVal x
transBranching [x] = transVal x
transBranching xs@(_:_:_) = C_Or (fromHaskellList (map transVal xs))
{-
......
......@@ -500,7 +500,7 @@ maySwitch y@(C_BoolOr _ _) (C_BoolOr r xs) st =
C_BoolOr r (map (\ x -> concAnd y x st) xs)
maySwitch x@(C_BoolFail _) _ _ = x
maySwitch x@C_False _ _ = x
{-
startBreadth :: [StrEqResult] -> Result StrEqResult
startBreadth cs st = onLists st [] cs
......@@ -547,7 +547,7 @@ insertAnd o1@(C_BoolOr ref1 xs1) o2@(C_BoolOr ref2 xs2)
insertAnd o@(C_BoolOr _ _) (C_BoolAnd ys) = C_BoolAnd (o:ys)
insertAnd (C_BoolAnd ys) o@(C_BoolOr _ _) = C_BoolAnd (o:ys)
insertAnd (C_BoolAnd xs) (C_BoolAnd ys) = C_BoolAnd (xs++ys)
-}
--- implementation of (==)
--- no other implementation
genEq :: Curry t0 => t0 -> t0 -> Result C_Bool
......@@ -567,7 +567,8 @@ genStrEq a b = (\ a' -> (onceMore a') `hnfCTC` b) `hnfCTC` a
checkFree Branching Branching
| drx Prelude.== dry
= trace "f" C_True
| otherwise = trace "g" branching (chainTo ax bx drx ay by dry) [C_True]
| otherwise = trace "g"
branching (equalFromTo ax bx drx ay by dry) [C_True]
where (ax,bx,drx)=genInfo (orRef x)
(ay,by,dry)=genInfo (orRef y)
......
......@@ -701,8 +701,8 @@ x =:= y | x===y = success
(&>) :: Success -> a -> a
c &> x | c = x
andBreadth :: [Bool] -> Bool
andBreadth external
--andBreadth :: [Bool] -> Bool
--andBreadth external
-- Maybe type
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment