Commit 0809f040 authored by bbr's avatar bbr
Browse files

CurryPrelude compiles now

- several changes in the external functions of prelude still necessary
- main change in the teatment of part calls
parent 6714e1e2
......@@ -646,7 +646,7 @@ transFunc opts _ (Func (m,fname) arity vis t (External _)) =
C.Func (funName (m,fname)) (transvis vis) (transFType opts arity t)
(Just [rule (map toPVar [1..arity])
(noguard (fapp (C.Symbol (extFuncModName m,fname))
(st:map toVar [1..arity]))) []])
(addStateArg (map toVar [1..arity])))) []])
transFType :: Options -> Int -> TypeExpr -> Maybe C.TypeExpr
......@@ -680,12 +680,13 @@ transExpr opts (Comb combType fname args)
= newExpr
where
newArgs = map (transExpr opts) args
partArgs i = newArgs ++ map (toVar' "v") [i,i-1 .. 1]
call = case combType of
ConsCall -> symApp (consName opts fname) newArgs
FuncCall -> symApp (funName fname) (st:newArgs)
FuncPartCall _ -> symApp (funName fname) (st:newArgs)
ConsPartCall _ -> symApp (consName opts fname) newArgs
FuncCall -> symApp (funName fname) (addStateArg newArgs)
FuncPartCall i -> symApp (funName fname) (addStateArg (partArgs i))
ConsPartCall i -> symApp (consName opts fname) (partArgs i)
symApp s xs = fapp (C.Symbol s) xs
......@@ -702,12 +703,10 @@ transLit opts (Charc c) = toChar opts c
transLit opts (Floatc f) = toFloat opts f
transLit opts (Intc i) = toInt opts i
part opts i e = primPart opts (i-1) (fapp e (map (toVar' "v") [i-1,i-2 .. 1]))
primPart opts i e =
if i<1
then primValue opts (C.Lambda [C.PVar "st"] e)
else primValue opts (C.Lambda [_x,toPVar' "v" i] (primPart opts (i-1) e))
part opts i e =
if i<2
then primValue opts (C.Lambda (addStatePat [toPVar' "v" 1]) e)
else primValue opts (C.Lambda [toPVar' "v" i, _x] (part opts (i-1) e))
transBranching :: CaseType -> ([VarIndex],[VarIndex]) -> Options -> QName ->
(QName -> QName) -> QName -> [BranchExpr] -> [C.Rule]
......
......@@ -21,7 +21,7 @@ infixr 0 &
-- IO starter
-----------------------------------------------------------------------
curryIO :: Curry a => (State -> C_IO a) -> IO a
curryIO :: Curry a => (Result (C_IO a)) -> IO a
curryIO x = let st = emptyStore in ioStart st (x (Just st))
ioStart :: Curry a => Store -> C_IO a -> IO a
......@@ -200,11 +200,11 @@ instance (ConvertCH a b) => ConvertCH (C_Maybe a) (Maybe b) where
($##) :: (Curry a, Curry b) => Prim (a -> Result b) -> a -> Result b
($##) cont x = prepApply gnfCTC x cont
prim_error :: Curry a => State -> C_String -> a
prim_error _ s = failed (ErrorCall (fromCurry s))
prim_error :: Curry a => C_String -> Result a
prim_error s _ = failed (ErrorCall (fromCurry s))
prim_failed :: Curry a => State -> a
prim_failed st = prim_error st (toCurry "Prelude.failed")
prim_failed :: Curry a => Result a
prim_failed st = prim_error (toCurry "Prelude.failed") st
(==) :: Curry a => a -> a -> Result C_Bool
(==) = genEq
......@@ -233,8 +233,8 @@ successToBool C_Success = C_True
successToBool (C_SuccessFail e) = C_BoolFail e
successToBool (C_SuccessOr r xs) = C_BoolOr r (map successToBool xs)
andBreadth :: State -> List C_Bool -> C_Bool
andBreadth st xs = startBreadth st (toHaskellList xs)
andBreadth :: List C_Bool -> Result C_Bool
andBreadth xs st = startBreadth (toHaskellList xs) st
-- TODO: C_IO without State??? also other io-functions.
prim_bind :: (Curry a,Curry b) => C_IO a -> Prim (a -> Result (C_IO b)) -> Result (C_IO b)
......@@ -299,11 +299,11 @@ prim_writeFile = ioFunc2 writeFile
prim_appendFile :: C_String -> C_String -> Result (C_IO T0)
prim_appendFile = ioFunc2 appendFile
catchFail :: State -> C_IO a -> C_IO a -> Result (C_IO a)
catchFail :: C_IO a -> C_IO a -> Result (C_IO a)
catchFail act err _ = error "catchFail not supported yet" --catch act (const err)
prim_show :: (Show a,Curry a) => State -> a -> C_String
prim_show _ = trace "show" $ toCurry . show
prim_show :: (Show a,Curry a) => a -> Result C_String
prim_show x _ = toCurry (show x)
getSearchTree :: Curry a => a -> Result (C_IO (C_SearchTree a))
getSearchTree x _ = C_IO (\ state -> return (IOVal (searchTr x state)))
......@@ -324,12 +324,12 @@ searchTr x state = transVal (nfCTC (nfCTC (\ x _ -> x)) x state)
transBranching xs@(_:_:_) = C_Or (fromHaskellList (map transVal xs))
toData :: Curry a => State -> a -> C_Data
toData st _ = prim_error st (toCurry "toData not implemented") --ctcStore True (toC_Term True) Nothing
toData :: Curry a => a -> Result C_Data
toData _ st = prim_error (toCurry "toData not implemented") st --ctcStore True (toC_Term True) Nothing
toNumData :: Curry a => State -> a -> C_NumData
toNumData st _ = prim_error st (toCurry "toNumData not implemented")
toNumData :: Curry a => a -> Result C_NumData
toNumData _ st = prim_error (toCurry "toNumData not implemented") st
--ctcStore True (\ store x -> (conv2num (toC_Term True store x))) Nothing
......@@ -337,8 +337,8 @@ toNumData st _ = prim_error st (toCurry "toNumData not implemented")
cmap _ List = List
cmap f (x :< xs) = f x :< cmap f xs
fromData :: Curry a => State -> C_Data -> a
fromData st _ = prim_error st (toCurry "fromData not implemented") --fromC_Term
fromData :: Curry a => C_Data -> Result a
fromData _ st = prim_error (toCurry "fromData not implemented") st --fromC_Term
prepApply :: (BaseCurry a,BaseCurry b) =>
((b -> Result a) -> b -> Result a) -> b -> (Prim (b -> Result a)) -> Result a
......@@ -363,8 +363,8 @@ cond (C_SuccessSusp r susp) x st = treatSusp (\ c -> cond c x) r susp st
cond x _ _ = patternFail "Prelude.cond" x
commit :: Curry a => State -> a -> a
commit st _ = prim_error st (toCurry "committed choice not implemented")
commit :: Curry a => a -> Result a
commit _ st = prim_error (toCurry "committed choice not implemented") st
ifVar :: (Curry a,Curry b) => b -> a -> a -> a
ifVar = error "ifVar not implemented"
......
......@@ -526,8 +526,8 @@ maySwitch s@(C_BoolSusp _ wake) x st =
Nothing -> susp x s
Just v -> maySwitch v x st
startBreadth :: State -> [StrEqResult] -> StrEqResult
startBreadth st cs = onLists (maybe emptyStore id st) [] cs
startBreadth :: [StrEqResult] -> Result StrEqResult
startBreadth cs st = onLists (maybe emptyStore id st) [] cs
instance Eq C_Bool where
C_True == C_True = True
......
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