Commit 52ef02ea authored by Michael Hanus 's avatar Michael Hanus

Handling of free variables via narrowing added to interpreter

parent 573f41c4
-- graph coloring with non-deterministic functions
-- exploiting the demand-driven search due to lazy evaluation in Curry
-- This is our actual map:
--
-- --------------------------
-- | | | |
-- | | L2 | |
-- | | | |
-- | L1 |--------| L4 |
-- | | | |
-- | | L3 | |
-- | | | |
-- --------------------------
--
data Color = Red | Green | Blue
aColor = Red
aColor = Green
aColor = Blue
True && x = x
False && _ = False
cond True x = x
diff Red Green = True
diff Red Blue = True
diff Green Red = True
diff Green Blue = True
diff Blue Red = True
diff Blue Green = True
-- correct coloring where non-deterministic generators are provided
correct l1 l2 l3 l4 =
cond (diff l1 l2 && diff l1 l3 && diff l2 l3 && diff l2 l4 && diff l3 l4)
[l1,l2,l3,l4]
main1 = normalForm (correct aColor aColor aColor aColor)
-- correct coloring with free variables (and narrowing on `diff`)
correctFree =
cond (diff l1 l2 && diff l1 l3 && diff l2 l3 && diff l2 l4 && diff l3 l4)
[l1,l2,l3,l4]
where l1,l2,l3,l4 free
main2 = normalForm correctFree
main = main2
......@@ -132,6 +132,11 @@ funNotBool :: IFunction
funNotBool = iFunction "notBool" 0 [] $ IFuncBody $
simpleRHS (iFCall "not" [iFCall "aBool" []])
-- notFree = not b where b free
funNotFree :: IFunction
funNotFree = iFunction "notFree" 0 [] $ IFuncBody $
IBlock [IFreeDecl 1] [] (IReturn $ iFCall "not" [IVar 1])
-- xorSelfBool = xorSelf aBool
funXorSelfBool :: IFunction
funXorSelfBool = iFunction "xorSelfBool" 0 [] $ IFuncBody $
......@@ -169,6 +174,14 @@ funNormalForm :: IFunction
funNormalForm =
iFunction "normalForm" 1 [0] (IExternal "normalForm")
-- f $$! x = f (id $! x), i.e., first f and then x is demanded, returns (f x).
-- Used for computations of normal forms with left to right argument evaluation.
funDollarDollarBang :: IFunction
funDollarDollarBang = iFunction "$$!" 2 [0] $ IFuncBody $
IBlock [IVarDecl 1,IVarDecl 2]
[IVarAssign 1 (IVarAccess 0 [0]),IVarAssign 2 (IVarAccess 0 [1])]
(IReturn (iFCall "$!" [IVar 1, IVar 2]))
-- xorSelfSeqBool = let x = aBool in seq x (xorSelf x)
funXorSelfSeqBool :: IFunction
funXorSelfSeqBool = iFunction "xorSelfSeqBool" 0 [] $ IFuncBody $
......@@ -263,9 +276,10 @@ funPerm123 = iFunction "perm123" 0 [] $ IFuncBody $
allFuns :: [IFunction]
allFuns =
[ funCoin, funHead, funHeadEmpty, funHead1, funHead12
, funNot,funAnd, funNotBool, funXor,funXorSelf,funABool,funXorSelfBool
, funNot,funAnd, funNotBool, funNotFree
, funXor,funXorSelf,funABool,funXorSelfBool
, funOneTwo, funHeadOneTwo
, funApply, funDollarBang, funSeq, funNormalForm
, funApply, funDollarBang, funDollarDollarBang, funSeq, funNormalForm
, funXorSelfSeqBool, funXorSelfDollarBangBool
, funAndNotFalse, funCoinList, funCoinCoinList
, funNDInsert, funNDInsert1, funPerm, funInsert123, funPerm123
......@@ -290,7 +304,8 @@ stdint = std { interactive = True }
details :: IOptions
details = stdint { verbosity = 4 }
m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11, m12, m13, m14 :: IOptions -> IO ()
m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11, m12, m13, m14, m15
:: IOptions -> IO ()
m1 o = execIProg o exampleProg "coin"
m2 o = execIProg o exampleProg "headempty"
m3 o = execIProg o exampleProg "head1"
......@@ -305,6 +320,7 @@ m11 o = execIProg o exampleProg "coinCoinList"
m12 o = execIProg o exampleProg "perm123"
m13 o = execIProg o exampleProg "idTrue"
m14 o = execIProg o exampleProg "notBool"
m15 o = execIProg o exampleProg "notFree"
------------------------------------------------------------------------------
-- Testing with CurryCheck.
......@@ -345,6 +361,9 @@ testAndNotFalse = evalFunND exampleProg "andNotFalse" <~> "True"
testNotBool :: Prop
testNotBool = evalFunND exampleProg "notBool" <~> ("True" ? "False")
testNotFree :: Prop
testNotFree = evalFunND exampleProg "notFree" <~> ("True" ? "False")
testIdTrue :: Prop
testIdTrue = evalFunND exampleProg "idTrue" <~> "True"
......
......@@ -54,11 +54,13 @@ type ChoiceID = Int
data PartCall = PartFuncCall Int | PartConsCall Int
deriving Show
-- A graph node is a function, constructor, or choice node.
-- A graph node is a function, constructor, choice, or free node.
-- The latter represents unbound variables.
data Node = FuncNode String [NodeID]
| ConsNode String [NodeID]
| PartNode String PartCall [NodeID]
| ChoiceNode ChoiceID NodeID NodeID
| FreeNode
deriving Show
-- The label of a node.
......@@ -67,6 +69,7 @@ nodeLabel (FuncNode f _) = f
nodeLabel (ConsNode f _) = f
nodeLabel (PartNode f _ _) = f
nodeLabel (ChoiceNode cid _ _) = "?" ++ show cid
nodeLabel FreeNode = "free"
-- Add an argument node to a node representing a partial call.
addPartialArg :: Node -> NodeID -> Node
......@@ -99,6 +102,10 @@ lookupNode ni (Graph nodes _) =
id
(lookup ni nodes)
-- Returns maximum node id of a graph.
maxNodeID :: Graph -> NodeID
maxNodeID (Graph _ m) = m
-- Adds a new node in a graph.
addNode :: Node -> Graph -> (Graph,NodeID)
addNode node (Graph nodes mx) =
......@@ -121,11 +128,12 @@ replaceNode (Graph nodes mx) oldnid newid =
where
redirect (ni, n) = (ni, redirectTargets n)
redirectTargets (FuncNode f ns) = FuncNode f (map redirectTarget ns)
redirectTargets (ConsNode f ns) = ConsNode f (map redirectTarget ns)
redirectTargets (PartNode f n ns) = PartNode f n (map redirectTarget ns)
redirectTargets (FuncNode f ns) = FuncNode f (map redirectTarget ns)
redirectTargets (ConsNode f ns) = ConsNode f (map redirectTarget ns)
redirectTargets (PartNode f n ns) = PartNode f n (map redirectTarget ns)
redirectTargets (ChoiceNode c n1 n2) =
ChoiceNode c (redirectTarget n1) (redirectTarget n2)
redirectTargets FreeNode = FreeNode
redirectTarget ni = if ni == oldnid then newid else ni
......@@ -139,6 +147,7 @@ showGraphExp g nid = showExp [] 10 nid
showExp lets d ni | d == 0 = "..."
| otherwise = showNExp (lookupNode ni g)
where
showNExp FreeNode = "_x" ++ show ni
showNExp (ConsNode f args) = showNExp (FuncNode f args)
showNExp (PartNode f _ args) = showNExp (FuncNode f args)
showNExp (ChoiceNode c n1 n2) = showNExp (FuncNode ('?' : show c) [n1,n2])
......@@ -150,17 +159,17 @@ showGraphExp g nid = showExp [] 10 nid
then ""
else "let {" ++
intercalate " ; " (map showLetDecl arglets) ++ "} in ") ++
showCall f (map (\a -> if a `elem` alllets
then showVar a
else showExp alllets (d-1) a) args) ++
showCall (map (\a -> if a `elem` alllets
then showVar a
else showExp alllets (d-1) a) args) ++
")"
where
showCall f args =
showCall cargs =
if isInfixOp f
then case args of
then case cargs of
[a1,a2] -> unwords [a1,f,a2]
_ -> unwords (('(' : f ++ ")") : args)
else unwords (f : args)
_ -> unwords (('(' : f ++ ")") : cargs)
else unwords (f : cargs)
where
isInfixOp = all (`elem` "!@#$%^&*+-=<>?./|\\:")
......@@ -190,6 +199,7 @@ showGraphExp g nid = showExp [] 10 nid
PartNode _ _ args -> foldr (+) 0 (map (occursInGraphExp (d-1) ni) args)
ChoiceNode _ a1 a2 -> occursInGraphExp (d-1) ni a1 +
occursInGraphExp (d-1) ni a2
FreeNode -> 0
-- Transforms a graph (w.r.t. given node attributes) into a dot graph.
......@@ -213,10 +223,11 @@ fullGraphToDot (Graph nodes _) ndattrs withnids =
ndlabel = nodeLabel n ++ if withnids then " [" ++ show nid ++ "]" else ""
addAttrs = maybe [] id (lookup nid ndattrs)
toEdges (nid, FuncNode _ ns) = addEdges nid ns
toEdges (nid, ConsNode _ ns) = addEdges nid ns
toEdges (nid, PartNode _ _ ns) = addEdges nid ns
toEdges (nid, FuncNode _ ns ) = addEdges nid ns
toEdges (nid, ConsNode _ ns ) = addEdges nid ns
toEdges (nid, PartNode _ _ ns ) = addEdges nid ns
toEdges (nid, ChoiceNode _ n1 n2) = addEdges nid [n1,n2]
toEdges (_ , FreeNode ) = []
addEdges src ns =
map (\ (i,n) -> Dot.Edge (show src) (show n) [("label",show i)])
......@@ -238,7 +249,8 @@ reachableGraph (Graph nodes mx) initnids =
(\nd -> case nd of FuncNode _ ns -> ns
ConsNode _ ns -> ns
PartNode _ _ ns -> ns
ChoiceNode _ n1 n2 -> [n1,n2])
ChoiceNode _ n1 n2 -> [n1,n2]
FreeNode -> [])
(lookup ni nodes)
------------------------------------------------------------------------------
This diff is collapsed.
......@@ -2,7 +2,7 @@
--- This module contains a simple compiler from FlatCurry to ICurry programs.
---
--- @author Michael Hanus
--- @version January 2020
--- @version February 2020
------------------------------------------------------------------------------
module ICurry.Main where
......@@ -22,7 +22,7 @@ import ICurry.Types
banner :: String
banner = unlines [bannerLine,bannerText,bannerLine]
where
bannerText = "ICurry Compiler (Version of 23/01/20)"
bannerText = "ICurry Compiler (Version of 03/02/20)"
bannerLine = take (length bannerText) (repeat '=')
main :: IO ()
......
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