summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Grasp/Interpreter.hs42
-rw-r--r--src/Grasp/Monad.hs77
2 files changed, 111 insertions, 8 deletions
diff --git a/src/Grasp/Interpreter.hs b/src/Grasp/Interpreter.hs
index bca167a..c9d807e 100644
--- a/src/Grasp/Interpreter.hs
+++ b/src/Grasp/Interpreter.hs
@@ -152,12 +152,50 @@ pickI = GMonad.updateIP
callI :: GraspM ()
-callI = GMonad.updateIP
+callI = do
+ curNode <- GMonad.peekIP >>= return . Maybe.fromJust
+
+ funcNodes <- GMonad.nodesOut (EL.mk "func") curNode
+ argEdges <- GMonad.edgesOut curNode
+ ae <- return (filter (\x -> (GE.toLabel x) /= (EL.mk "name") && (GE.toLabel x) /= (EL.mk "cond") &&
+ (GE.toLabel x) /= (EL.mk "next") && (GE.toLabel x) /= (EL.mk "func")) argEdges)
+ possibleFuncs <- mapM GMonad.nodesWithName (map GN.toInst funcNodes) >>= return . concat
+
+ Monad.when (length possibleFuncs < 1) (error "Instruction call has no applicable func candidates")
+
+ r <- liftIO (Random.getStdRandom (Random.randomR (0, length possibleFuncs - 1)))
+ (sn, se) <- GMonad.subGraph (possibleFuncs !! r)
+
+ sn' <- GMonad.newNodes (map GN.toInst sn)
+ let nodeMap = zip (map GN.toNode sn) (map GN.toNode sn')
+ translate = Maybe.fromJust . (flip lookup nodeMap)
+ se' <- return (map (\x -> GE.mk (translate . GE.toSrc $ x, translate . GE.toDest $ x, GE.toLabel x)) se)
+
+ let calledNode = GN.mk (translate (GN.toNode (possibleFuncs !! r)), GN.toInst (possibleFuncs !! r))
+ ae' <- return (map (\x -> GE.mk (GN.toNode calledNode, GE.toDest x, GE.toLabel x)) ae)
+
+ GMonad.insNodes sn'
+ GMonad.insEdges (se' ++ ae')
+
+ GMonad.pushIP calledNode
retI :: GraspM ()
-retI = GMonad.updateIP
+retI = do
+ curNode <- GMonad.peekIP >>= return . Maybe.fromJust
+
+ retEdges <- GMonad.edgesOut curNode
+ re <- return (filter (\x -> (GE.toLabel x) /= (EL.mk "name") && (GE.toLabel x) /= (EL.mk "next") &&
+ (GE.toLabel x) /= (EL.mk "cond")) retEdges)
+
+ GMonad.popIP
+ GMonad.updateIP
+ curNode' <- GMonad.peekIP
+
+ Monad.when (Maybe.isJust curNode') (do
+ re' <- return (map (\x -> GE.mk (GN.toNode . Maybe.fromJust $ curNode', GE.toDest x, GE.toLabel x)) re)
+ GMonad.insEdges re' )
diff --git a/src/Grasp/Monad.hs b/src/Grasp/Monad.hs
index ba500af..86de9a2 100644
--- a/src/Grasp/Monad.hs
+++ b/src/Grasp/Monad.hs
@@ -15,6 +15,11 @@ module Grasp.Monad (
nodesOut, edgesOut,
reLabel,
+ nodesWithName,
+ subGraph,
+ newNodes,
+ insNode, insNodes,
+ delNode, delNodes,
insEdge, insEdges,
delEdge, delEdges
) where
@@ -81,7 +86,7 @@ construct (ns,es) = do
Monad.when (noMain ns es) (error "could not find grasp:main")
let graph = Graph.mkGraph (map GN.toLNode ns) (map GE.toLEdge es)
- ips = map IP.singleton (nodesWithName ns es "grasp:main")
+ ips = map IP.singleton (getNodesWithName ns es "grasp:main")
handles = Map.empty
State.put (graph, ips, handles)
@@ -111,14 +116,14 @@ nameNodeList ns es =
-nodesWithName :: [GNode] -> [GEdge] -> String -> [GNode]
-nodesWithName ns es name =
+getNodesWithName :: [GNode] -> [GEdge] -> String -> [GNode]
+getNodesWithName ns es name =
(map fst) . (filter (\x -> (GN.toInst . snd $ x) == (IN.mk name))) $ (nameNodeList ns es)
-namedNodes :: [GNode] -> [GEdge] -> [GNode]
-namedNodes ns es = map fst (nameNodeList ns es)
+getNamedNodes :: [GNode] -> [GEdge] -> [GNode]
+getNamedNodes ns es = map fst (nameNodeList ns es)
@@ -176,7 +181,7 @@ garbageCollect gr ips =
reachable :: Gr Instruction EdgeLabel -> [IP] -> [Node]
reachable gr ips =
- let named = namedNodes (map GN.mk (Graph.labNodes gr)) (map GE.mk (Graph.labEdges gr))
+ let named = getNamedNodes (map GN.mk (Graph.labNodes gr)) (map GE.mk (Graph.labEdges gr))
ipNodes = concatMap IP.toList ips
start = (map GN.toNode) . List.nub $ named ++ ipNodes
in reach gr start []
@@ -338,6 +343,66 @@ reLabel i n = do
+nodesWithName :: Instruction -> GraspM [GNode]
+nodesWithName x = do
+ (gr, ips, fh) <- State.get
+ let ns = map GN.mk (Graph.labNodes gr)
+ es = map GE.mk (Graph.labEdges gr)
+ return (getNodesWithName ns es (IN.toString x))
+
+
+
+subGraph :: GNode -> GraspM ([GNode],[GEdge])
+subGraph n = do
+ (gr, ips, fh) <- State.get
+ let rNodes = reach gr [GN.toNode n] []
+ rEdges = filter (\(x,y,z) -> x `elem` rNodes && y `elem` rNodes) (Graph.labEdges gr)
+ result = (map (\x -> GN.mk (x, Maybe.fromJust (Graph.lab gr x))) rNodes, map GE.mk rEdges)
+ return result
+
+
+
+newNodes :: [Instruction] -> GraspM [GNode]
+newNodes is = do
+ (gr, ips, fh) <- State.get
+ let newNs = Graph.newNodes (length is) gr
+ newGNs = map GN.mk (zip newNs is)
+ return newGNs
+
+
+
+insNode :: GNode -> GraspM ()
+insNode n = do
+ (gr, ips, fh) <- State.get
+ let gr' = Graph.insNode (GN.toLNode n) gr
+ State.put (gr', ips, fh)
+
+
+
+insNodes :: [GNode] -> GraspM ()
+insNodes ns = do
+ (gr, ips, fh) <- State.get
+ let gr' = Graph.insNodes (map GN.toLNode ns) gr
+ State.put (gr', ips, fh)
+
+
+
+delNode :: GNode -> GraspM ()
+delNode n = do
+ (gr, ips, fh) <- State.get
+ let gr' = Graph.delNode (GN.toNode n) gr
+ State.put (gr', ips, fh)
+
+
+
+delNodes :: [GNode] -> GraspM ()
+delNodes ns = do
+ (gr, ips, fh) <- State.get
+ let gr' = Graph.delNodes (map GN.toNode ns) gr
+ State.put (gr', ips, fh)
+
+
+
insEdge :: GEdge -> GraspM ()
insEdge e = do
(gr, ips, fh) <- State.get