Commit 08fb81a3 authored by Michael Hanus 's avatar Michael Hanus

Nice interpreter and pretty ICurry output, Arithmetic example added

parent 09fb28ea
------------------------------------------------------------------------------
-- Example with arithmetic computations to demonstrate the treatment
-- of external operations. Note that this works with the
-- ICurry interpreter in order to avoid the compilation
-- of the complete Curry prelude.
------------------------------------------------------------------------------
(+) :: Int -> Int -> Int
x + y = (prim_Int_plus $# y) $# x
-- The primitive addition `prim_Int_plus` is treated by the ICurry interpreter.
prim_Int_plus :: Int -> Int -> Int
prim_Int_plus external
(*) :: Int -> Int -> Int
x * y = (prim_Int_mult $# y) $# x
-- The primitive addition `prim_Int_mult` is treated by the ICurry interpreter.
prim_Int_mult :: Int -> Int -> Int
prim_Int_mult external
------------------------------------------------------------------------------
-- Combining arithmetic and non-determinism:
coin :: Int
coin = 0
coin = 1
coinCoin = coin + coin
double :: Int -> Int
double x = x + x
doubleCoin = double coin
------------------------------------------------------------------------------
-- Higher-order with arithmetic operations.
map :: (a -> b) -> [a] -> [b]
map _ [] = []
map f (x : xs) = f x : map f xs
inc123 :: [Int]
inc123 = normalForm (map (1+) [1,2,3])
foldr :: (a -> b -> b) -> b -> [a] -> b
foldr _ z [] = z
foldr f z (x:xs) = f x (foldr f z xs)
fac5 :: Int
fac5 = foldr (*) 1 [1,2,3,4,5]
------------------------------------------------------------------------------
......@@ -93,6 +93,6 @@ one can wrap it with the function `normalForm`, e.g.,
mymain = normalForm (reverse [1,2,3])
The current version of the interpreter supports only the prelude
operations `normalForm` and `$!`.
operations `normalForm`, `$#`, and `$!`.
----------------------------------------------------------------------------
......@@ -349,17 +349,17 @@ testIdTrue :: Prop
testIdTrue = evalFunND exampleProg "idTrue" <~> "True"
testCoinList :: Prop
testCoinList = evalFunND exampleProg "coinList" <~> ("(: 1 [])" ? "(: 2 [])")
testCoinList = evalFunND exampleProg "coinList" <~> ("(1 : [])" ? "(2 : [])")
testCoinCoinList :: Prop
testCoinCoinList =
evalFunND exampleProg "coinCoinList" <~>
("(: 1 (: 1 []))" ? "(: 2 (: 1 []))" ? "(: 1 (: 2 []))" ? "(: 2 (: 2 []))")
("(1 : (1 : []))" ? "(2 : (1 : []))" ? "(1 : (2 : []))" ? "(2 : (2 : []))")
testPerm123 :: Prop
testPerm123 =
evalFunND exampleProg "perm123" <~>
("(: 1 (: 2 (: 3 [])))" ? "(: 1 (: 3 (: 2 [])))" ? "(: 2 (: 1 (: 3 [])))" ?
"(: 2 (: 3 (: 1 [])))" ? "(: 3 (: 1 (: 2 [])))" ? "(: 3 (: 2 (: 1 [])))")
("(1 : (2 : (3 : [])))" ? "(1 : (3 : (2 : [])))" ? "(2 : (1 : (3 : [])))" ?
"(2 : (3 : (1 : [])))" ? "(3 : (1 : (2 : [])))" ? "(3 : (2 : (1 : [])))")
------------------------------------------------------------------------------
......@@ -132,7 +132,7 @@ replaceNode (Graph nodes mx) oldnid newid =
-- Shows the expression represented by the graph starting with a given node.
-- In order to visualize sharing, shared subexpressions are shown
-- by let expressions.
-- as let expressions.
showGraphExp :: Graph -> NodeID -> String
showGraphExp g nid = showExp [] 10 nid
where
......@@ -150,11 +150,20 @@ showGraphExp g nid = showExp [] 10 nid
then ""
else "let {" ++
intercalate " ; " (map showLetDecl arglets) ++ "} in ") ++
unwords (f : map (\a -> if a `elem` alllets
then showVar a
else showExp alllets (d-1) a) args) ++
showCall f (map (\a -> if a `elem` alllets
then showVar a
else showExp alllets (d-1) a) args) ++
")"
where
showCall f args =
if isInfixOp f
then case args of
[a1,a2] -> unwords [a1,f,a2]
_ -> unwords (('(' : f ++ ")") : args)
else unwords (f : args)
where
isInfixOp = all (`elem` "!@#$%^&*+-=<>?./|\\:")
arglets = nub (concatMap
(\a -> let occs = occursInGraphExp d a ni
in if occs < 2 || isConst a then [] else [a])
......
......@@ -333,32 +333,52 @@ evalFirstTask st (Task (IBlockEnv (IBlock vs asgns stm) ienv) stk fp : tsks) =
invokeFunction :: State -> [Task] -> State
invokeFunction _ [] = error "invokeFunction: empty tasks"
invokeFunction st (Task (CNode nid) stk fp : tsks) =
case lookupNode nid (graph st) of
case lookupNode nid gr of
FuncNode f ns -> case bodyOf f (program st) of
IFuncBody blck ->
let ienv = [(0, nid)]
in st { tasks = Task (IBlockEnv blck ienv) stk fp : tsks }
IExternal en -> case en of
"apply" ->
let node = addPartialArg (lookupNode (ns!!0) (graph st)) (ns!!1)
in st { graph = updateNode (graph st) nid node }
"$!" -> st { graph = updateNode (graph st) nid (FuncNode "apply" ns) }
"normalForm" -> case lookupNode (ns!!0) (graph st) of
"normalForm" -> case lookupNode (ns!!0) gr of
ConsNode c cargs ->
let argsenv = zip [1..] cargs
evalcargs = foldl (\xs x -> IFCall ("","$!",0)
[xs, IFCall ("","normalForm",0)
[IVar (fst x)]])
(ICPCall ("",c,0) (length cargs) []) argsenv
(g1,nexp) = extendGraph (graph st) argsenv evalcargs
(gr1,nexp) = extendGraph gr argsenv evalcargs
in st { graph = either (error "Internal error in normalForm")
(updateNode g1 nid) nexp }
(updateNode gr1 nid) nexp }
_ -> error "step: use of 'normalForm' without constructor argument"
_ -> error $ "step: unknown external function: " ++ en
_ -> st { graph = updateNode gr nid (evalExternal gr en ns) }
_ -> error "invokeFunction: no function node in control"
where gr = graph st
invokeFunction _ (Task (IBlockEnv _ _) _ _ : _) =
error "invokeFunction: no function node in control"
-- Evaluates an external function to a node containing the evaluated value.
-- The arguments are the current graph, the external name,
-- and the argument nodes.
evalExternal :: Graph -> String -> [NodeID] -> Node
evalExternal gr ename ns = case unQName ename of
"apply" -> addPartialArg (lookupNode (ns!!0) gr) (ns!!1)
"$!" -> FuncNode "apply" ns
"$#" -> FuncNode "apply" ns
"prim_Int_plus" ->
ConsNode (show (lookupIntNode (ns!!0) gr + lookupIntNode (ns!!1) gr)) []
"prim_Int_mult" ->
ConsNode (show (lookupIntNode (ns!!0) gr * lookupIntNode (ns!!1) gr)) []
_ -> error $ "step: unknown external function: " ++ ename
where
unQName s = let (mn,ufn) = break (=='.') s
in if null ufn then mn else unQName (tail ufn)
lookupIntNode :: NodeID -> Graph -> Int
lookupIntNode nid gr = case lookupNode nid gr of
ConsNode c [] -> read c :: Int
_ -> error "lookupIntNode: no integer found"
-- Selects the constructor branch corresponding to some constructor node.
selectConsBranch :: Node -> [IConsBranch] -> IBlock
selectConsBranch nd [] =
......@@ -493,12 +513,17 @@ funSeq = IFunction ("Prelude","seq",0) 2 Public [0] $ IFuncBody $
funDollarBang :: IFunction
funDollarBang = IFunction ("Prelude","$!",0) 2 Public [1] (IExternal "$!")
-- f $# x: demands x and returns (f x) (and suspends on a free variable
-- which is not yet implemented)
funDollarHash :: IFunction
funDollarHash = IFunction ("Prelude","$#",0) 2 Public [1] (IExternal "$#")
-- normalForm x: demands x and returns the normal form of x
funNormalForm :: IFunction
funNormalForm =
IFunction ("Prelude","normalForm",0) 1 Public [0] (IExternal "normalForm")
standardFuncs :: [IFunction]
standardFuncs = [funApply, funSeq, funDollarBang, funNormalForm]
standardFuncs = [funApply, funSeq, funDollarBang, funDollarHash, funNormalForm]
------------------------------------------------------------------------------
......@@ -205,8 +205,8 @@ ppPos pos = text (show pos)
--- @param lit the literal
--- @return the pretty printed literal
ppLit :: ILiteral -> Doc
ppLit (IInt v) = int v
ppLit (IFloat v) = float v
ppLit (IChar v) = char v
ppLit (IInt i) = int i
ppLit (IFloat f) = float f
ppLit (IChar c) = text (show c)
------------------------------------------------------------------------------
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