Commit 66c8cca1 authored by Michael Hanus 's avatar Michael Hanus

Add constructor arity to IConsBranch

parent 62b4147a
......@@ -34,7 +34,7 @@ iFPCall n = IFPCall (siq n)
iCPCall :: String -> Int -> [IExpr] -> IExpr
iCPCall n = ICPCall (siq n)
iConsBranch :: String -> IBlock -> IConsBranch
iConsBranch :: String -> Int -> IBlock -> IConsBranch
iConsBranch n = IConsBranch (siq n)
icurryList :: [IExpr] -> IExpr
......@@ -72,8 +72,8 @@ funHead :: IFunction
funHead = iFunction "head" 1 [0] $ IFuncBody $
iBlock [1] [IVarAssign 1 (IVarAccess 0 [0])]
(ICaseCons 1
[iConsBranch "[]" (IBlock [] [] IExempt),
iConsBranch ":" (simpleRHS (IVarAccess 1 [0]))])
[iConsBranch "[]" 0 (IBlock [] [] IExempt),
iConsBranch ":" 2 (simpleRHS (IVarAccess 1 [0]))])
funHeadEmpty :: IFunction
funHeadEmpty = iFunction "headempty" 0 [] $ IFuncBody $
......@@ -94,8 +94,8 @@ funNot :: IFunction
funNot = iFunction "not" 1 [0] $ IFuncBody $
iBlock [1] [IVarAssign 1 (IVarAccess 0 [0])]
(ICaseCons 1
[iConsBranch "False" (simpleRHS (iCCall "True" [])),
iConsBranch "True" (simpleRHS (iCCall "False" []))])
[iConsBranch "False" 0 (simpleRHS (iCCall "True" [])),
iConsBranch "True" 0 (simpleRHS (iCCall "False" []))])
-- (&&) x y = case { False -> False ; True -> y }
funAnd :: IFunction
......@@ -103,8 +103,8 @@ funAnd = iFunction "&&" 2 [0] $ IFuncBody $
iBlock [1,2] [IVarAssign 1 (IVarAccess 0 [0]),
IVarAssign 2 (IVarAccess 0 [1])]
(ICaseCons 1
[iConsBranch "False" (simpleRHS (iCCall "False" [])),
iConsBranch "True" (simpleRHS (IVar 2))])
[iConsBranch "False" 0 (simpleRHS (iCCall "False" [])),
iConsBranch "True" 0 (simpleRHS (IVar 2))])
-- xor x y = case { False -> y ; True -> not y }
funXor :: IFunction
......@@ -113,8 +113,8 @@ funXor = iFunction "xor" 2 [0] $ IFuncBody $
[IVarAssign 1 (IVarAccess 0 [0]),
IVarAssign 2 (IVarAccess 0 [1])]
(ICaseCons 1
[iConsBranch "False" (simpleRHS (IVar 2)),
iConsBranch "True" (simpleRHS (iFCall "not" [IVar 2]))])
[iConsBranch "False" 0 (simpleRHS (IVar 2)),
iConsBranch "True" 0 (simpleRHS (iFCall "not" [IVar 2]))])
-- xorSelf x = xor x x
funXorSelf :: IFunction
......@@ -221,8 +221,8 @@ funNDInsert1 :: IFunction
funNDInsert1 = iFunction "ndinsert1" 1 [1] $ IFuncBody $
iBlock [1] [IVarAssign 1 (IVarAccess 0 [1])]
(ICaseCons 1
[iConsBranch "[]" (IBlock [] [] IExempt),
iConsBranch ":"
[iConsBranch "[]" 0 (IBlock [] [] IExempt),
iConsBranch ":" 2
(IBlock [] []
(IReturn
(iCCall ":" [IVarAccess 1 [0],
......@@ -244,8 +244,8 @@ funPerm :: IFunction
funPerm = iFunction "perm" 1 [0] $ IFuncBody $
iBlock [1] [IVarAssign 1 (IVarAccess 0 [0])]
(ICaseCons 1
[iConsBranch "[]" (simpleRHS (iCCall "[]" [])),
iConsBranch ":"
[iConsBranch "[]" 0 (simpleRHS (iCCall "[]" [])),
iConsBranch ":" 2
(IBlock [] []
(IReturn
(iFCall "ndinsert" [IVarAccess 1 [0],
......
......@@ -61,8 +61,10 @@ icCompile opts p = do
printDetails opts (textWithLines "Generated ICurry file:" ++ showIProg icprog)
return icprog
where
consMapOfProg prog = concatMap (\ (_,cars) -> zip (map fst cars) [0..])
(dataDeclsOf prog)
consMapOfProg prog =
concatMap (\ (_,cars) -> map (\ ((cname,car),pos) -> (cname,(car,pos)))
(zip cars [0..]))
(dataDeclsOf prog)
-- compute mapping of public function names to indices
publicFunMapOfProg prog =
......@@ -91,18 +93,23 @@ data ICOptions = ICOptions
, optShowGraph :: Bool -- visualize graph during execution?
, optViewPDF :: String -- command to view graph PDF
, optInteractive :: Bool -- interactive execution?
, optConsMap :: [(QName,Int)] -- map from constructor names to positions
, optFunMap :: [(QName,Int)] -- map from function names to module indices
, optConsMap :: [(QName,(Int,Int))] -- map: constr names to arity/position
, optFunMap :: [(QName,Int)] -- map: function names to module indices
, optFun :: QName -- currently compiled function
}
defaultICOptions :: ICOptions
defaultICOptions = ICOptions 1 False "" False "evince" False [] [] ("","")
posOfCons :: ICOptions -> QName -> Int
posOfCons opts qn =
-- Lookup arity and position index of a constructor.
arityPosOfCons :: ICOptions -> QName -> (Int,Int)
arityPosOfCons opts qn =
maybe (error "Internal error: posOfCons") id (lookup qn (optConsMap opts))
-- Lookup position index of a constructor.
posOfCons :: ICOptions -> QName -> Int
posOfCons opts qn = snd (arityPosOfCons opts qn)
posOfFun :: ICOptions -> QName -> Int
posOfFun opts qn =
maybe (error "Internal error: posOfFun") id (lookup qn (optFunMap opts))
......@@ -205,7 +212,8 @@ toIBlock opts vs e root =
_ -> caseVar
trPBranch carg (Branch (Pattern qn@(mn,cn) pvs) be) =
IConsBranch (mn, cn, posOfCons opts qn) (toIBlock opts pvs be carg)
let (ar,pos) = arityPosOfCons opts qn
in IConsBranch (mn, cn, pos) ar (toIBlock opts pvs be carg)
trPBranch _ (Branch (LPattern _) _) = funError opts "trPBranch with LPattern"
trLBranch carg (Branch (LPattern lit) be) =
......
......@@ -383,7 +383,7 @@ lookupIntNode nid gr = case lookupNode nid gr of
selectConsBranch :: Node -> [IConsBranch] -> IBlock
selectConsBranch nd [] =
error $ "selectConsBranch: no branch for node: " ++ show nd
selectConsBranch nd (IConsBranch (_,c,_) blck : branches) = case nd of
selectConsBranch nd (IConsBranch (_,c,_) _ blck : branches) = case nd of
ConsNode nc _ -> if nc == c then blck
else selectConsBranch nd branches
_ -> error $ "selectConsBranch: unevaluated branch node: " ++
......
......@@ -183,7 +183,8 @@ ppConsBranches = vcat . map ppConsBranch
--- @param b the branch
--- @return the pretty printed branch
ppConsBranch :: IConsBranch -> Doc
ppConsBranch (IConsBranch c block) = ppQName c <+> rarrow <+> ppBlock block
ppConsBranch (IConsBranch c ar block) =
ppQName c <+> char '/' <+> int ar <+> rarrow <+> ppBlock block
--- Pretty print branches over literals
--- @param bs the branches
......
......@@ -107,10 +107,10 @@ data IStatement =
deriving (Show, Read)
--- An ICurry case branch over algebraic constructors.
--- Only the constructor matching this branch is given.
--- Only the constructor and its arity matching this branch is given.
--- The assignments of constructor arguments to pattern variables
--- must be done in the ICurry block.
data IConsBranch = IConsBranch IQName IBlock
data IConsBranch = IConsBranch IQName Int IBlock
deriving (Show, Read)
--- An ICurry case branch over literals.
......
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