let valargs = get_val_args (Var.varType f) args
genApplication (Left bndr) f (map Left valargs)
--- A single alt case must be a selector. This means thee scrutinee is a simple
+-- A single alt case must be a selector. This means the scrutinee is a simple
-- variable, the alternative is a dataalt with a single non-wild binder that
-- is also returned.
mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
-- binders in the alts and only variables in the case values and a variable
-- for a scrutinee. We check the constructor of the second alt, since the
-- first is the default case, if there is any.
-mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
+
+-- mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
+-- scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
+-- altcon <- MonadState.lift tsType $ altconToVHDLExpr con
+-- let cond_expr = scrut' AST.:=: altcon
+-- true_expr <- MonadState.lift tsType $ varToVHDLExpr true
+-- false_expr <- MonadState.lift tsType $ varToVHDLExpr false
+-- return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
+mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do --error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
- let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
- true_expr <- MonadState.lift tsType $ varToVHDLExpr true
- false_expr <- MonadState.lift tsType $ varToVHDLExpr false
- return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
+ -- Omit first condition, which is the default
+ altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts
+ let cond_exprs = map (\x -> scrut' AST.:=: x) altcons
+ -- Rotate expressions to the left, so that the expression related to the default case is the last
+ exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])
+ return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
-mkConcSm (_, (CoreSyn.Case (CoreSyn.Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
-- | A function to wrap a builder-like function that expects its arguments to
-- be Literals
genLitArgs ::
- (dst -> func -> [Literal.Literal] -> res)
- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genLitArgs wrap dst func args = wrap dst func args'
- where
- args' = map exprToLit litargs
- -- FIXME: Check if we were passed an CoreSyn.App
- litargs = concat (map getLiterals exprargs)
- (exprargs, []) = Either.partitionEithers args
+ (dst -> func -> [Literal.Literal] -> TranslatorSession [AST.ConcSm])
+ -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm])
+genLitArgs wrap dst func args = do
+ hscenv <- MonadState.lift tsType $ getA tsHscEnv
+ let (exprargs, []) = Either.partitionEithers args
+ -- FIXME: Check if we were passed an CoreSyn.App
+ let litargs = concat (map (getLiterals hscenv) exprargs)
+ let args' = map exprToLit litargs
+ concsms <- wrap dst func args'
+ return concsms
-- | A function to wrap a builder-like function that produces an expression
-- and expects it to be assigned to the destination.