----------------------------------------------------------------------------- -- | -- Module : ForSyDe.Deep.Backend.VHDL.Generate -- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : forsyde-dev@ict.kth.se -- Stability : experimental -- Portability : portable -- -- Functions used to generate VHDL AST elements without making any -- explicit translation. -- ----------------------------------------------------------------------------- module ForSyDe.Deep.Backend.VHDL.Generate where import ForSyDe.Deep.Backend.VHDL.Constants import ForSyDe.Deep.Backend.VHDL.AST import ForSyDe.Deep.Backend.VHDL.Traverse.VHDLM -- | Generate a list of asignments (in 'ConcSm' form) of intermediate signals -- (first argument) to final output signals (second argument) genOutAssigns :: [VHDLId] -> [VHDLId] -> [ConcSm] genOutAssigns = zipWith assign where assign dest orig = CSSASm $ dest `genSignalAssign` orig -- | Generate a simple signal assignment, from a VHDL identifier to a -- VHDL identifier genSignalAssign :: VHDLId -- ^ destination -> VHDLId -- ^ origin -> ConSigAssignSm genSignalAssign dest orig = genExprAssign dest (PrimName $ NSimple orig) -- | Generate a function call asignment genFCallAssign :: VHDLId -- ^ destination signal -> VHDLId -- ^ Function Name -> [VHDLId] -- ^ Function formal parameters -> [VHDLId] -- ^ Function actual parameters -> ConSigAssignSm genFCallAssign dest fName formal actual = genExprAssign dest (PrimFCall $ genFCall fName formal actual) -- | Generate a simple assignment from an expression to a name genExprAssign :: VHDLId -> Expr -> ConSigAssignSm genExprAssign dest origExpr = NSimple dest :<==: (ConWforms [] (Wform [WformElem origExpr Nothing]) Nothing) -- | Generate a system design file for a system from the global system -- identifier, -- local traversing results and the translated entity declaration genSysDesignFile :: String -> EntityDec -> LocalTravResult -> DesignFile genSysDesignFile globalSysId ent@(EntityDec id _) (LocalTravResult decs stms) = DesignFile contextClause [LUEntity ent, LUArch archBody] where archBody = ArchBody archId (NSimple id) decs stms archId = unsafeVHDLBasicId "synthesizable" libName = globalSysId ++ "_lib" libId = unsafeVHDLBasicId libName contextClause = commonContextClause ++ [Library libId, Use $ NSelected (NSimple libId :.: SSimple typesId) :.: All] -- | Generate a library design file from the global results genLibDesignFile :: GlobalTravResult -> DesignFile genLibDesignFile (GlobalTravResult typeDecs subtypeDecs subProgBodies) = DesignFile commonContextClause [LUPackageDec packageDec, LUPackageBody packageBody] -- Due to dependency among types and subtypes we first output -- unconstrained types (which may have constarined types depending on), -- then subtypes (which we may have composite types depending on) -- A general solution could be a type dependency resolving algorithm where packageDec = PackageDec typesId (packageUnconsTypeDecs ++ packageSubtypeDecs ++ packageTypeDecs ++ subProgSpecs) packageUnconsTypeDecs = map PDITD $ filter (\a -> isUnconsType a) typeDecs packageTypeDecs = map PDITD $ filter (\a -> (not.isUnconsType) a) typeDecs packageSubtypeDecs = map PDISD subtypeDecs subProgSpecs = map (\(SubProgBody spec _ _) -> PDISS spec) subProgBodies packageBody = PackageBody typesId subProgBodies isUnconsType (TypeDec _ (TDA (UnconsArrayDef _ _))) = True isUnconsType _ = False -- | Generate a list of association from two lists of signal identifiers -- The first one establishes the formal parameters genAssocElems :: [VHDLId] -> [VHDLId] -> [AssocElem] genAssocElems formalNames actualNames = zipWith genAssoc formalNames actualNames -- | Generate a port map from two lists of signal identifiers -- The first list establishes the formal parameters genPMap :: [VHDLId] -> [VHDLId] -> PMapAspect genPMap formalIds actualIds = PMapAspect $ genAssocElems formalIds actualIds -- | Generate a function call from two lists of signal identifiers -- The first list establishes the formal parameters genFCall :: VHDLId -> [VHDLId] -> [VHDLId] -> FCall genFCall fName formalIds actualIds = FCall (NSimple fName) $ zipWith genAssoc formalIds actualIds -- | Generate a function call from the Function Name and a list of expressions -- (its arguments) genExprFCall :: VHDLId -> [Expr] -> Expr genExprFCall fName args = PrimFCall $ FCall (NSimple fName) $ map (\exp -> Nothing :=>: ADExpr exp) args -- | version of genExprFCall which requires exactly n arguments genExprFCallN :: VHDLId -> Int -> [Expr] -> Expr genExprFCallN fName n args = genExprFCall fName (takeExactly n args) where takeExactly 0 [] = [] takeExactly n (x:xs) | n > 0 = x : takeExactly (n-1) xs takeExactly _ _ = error "takeExactly: non exact length of input list" -- | Generate a function call from the Function Name (constant function) genExprFCall0 :: VHDLId -> Expr genExprFCall0 fName = genExprFCall fName [] -- | List version of genExprFCall0 genExprFCall0L :: VHDLId -> [Expr] -> Expr genExprFCall0L fName [] = genExprFCall fName [] genExprFCall0L _ _ = error "ForSyDe.Backend.VHDL.Generate.genExprFCall0L incorrect length" -- | Generate a function call from the Function Name and an expression argument genExprFCall1 :: VHDLId -> Expr -> Expr genExprFCall1 fName arg = genExprFCall fName [arg] -- | List version of genExprFCall1 genExprFCall1L :: VHDLId -> [Expr] -> Expr genExprFCall1L fName [arg] = genExprFCall fName [arg] genExprFCall1L _ _ = error "ForSyDe.Backend.VHDL.Generate.genExprFCall1L incorrect length" -- | Generate a function call from the Function Name and two expression arguments genExprFCall2 :: VHDLId -> Expr -> Expr -> Expr genExprFCall2 fName arg1 arg2 = genExprFCall fName [arg1,arg2] -- | List version of genExprFCall2 genExprFCall2L :: VHDLId -> [Expr] -> Expr genExprFCall2L fName [arg1, arg2] = genExprFCall fName [arg1,arg2] genExprFCall2L _ _ = error "ForSyDe.Backend.VHDL.Generate.genExprFCall2L incorrect length" -- | Generate a function call from the Function Name and two expression arguments genExprFCall4 :: VHDLId -> Expr -> Expr -> Expr -> Expr -> Expr genExprFCall4 fName arg1 arg2 arg3 arg4 = genExprFCall fName [arg1,arg2,arg2,arg3,arg4] -- | List version of genExprFCall4 genExprFCall4L :: VHDLId -> [Expr] -> Expr genExprFCall4L fName [arg1, arg2, arg3, arg4] = genExprFCall fName [arg1,arg2,arg2,arg3,arg4] genExprFCall4L _ _ = error "ForSyDe.Backend.VHDL.Generate.genExprFCall4L incorrect length" -- | Generate a procedure call from the Function Name and a list of expressions -- (its arguments) genExprProcCall :: VHDLId -> [Expr] -> SeqSm genExprProcCall pName args = ProcCall (NSimple pName) $ map (\exp -> Nothing :=>: ADExpr exp) args -- | Generate a procedure call from the Function Name (constant procedure) genExprProcCall0 :: VHDLId -> SeqSm genExprProcCall0 fName = genExprProcCall fName [] -- | Generate a procedure call from the Function Name and an expression argument genExprProcCall1 :: VHDLId -> Expr -> SeqSm genExprProcCall1 pName arg = genExprProcCall pName [arg] -- | Generate a procedure call from the Function Name and four expression -- arguments genExprProcCall2 :: VHDLId -> Expr -> Expr -> SeqSm genExprProcCall2 pName arg1 arg2 = genExprProcCall pName [arg1,arg2] -- | Generate a procedure call from the Function Name and two expression -- arguments genExprProcCall4 :: VHDLId -> Expr -> Expr -> Expr -> Expr -> SeqSm genExprProcCall4 pName arg1 arg2 arg3 arg4 = genExprProcCall pName [arg1,arg2,arg2,arg3,arg4] -- Generate an association of a formal and actual parameter genAssoc :: VHDLId -> VHDLId -> AssocElem genAssoc formal actual = Just formal :=>: ADName (NSimple actual) -- | Generate the default functions for an unconstrained custom vector type genUnconsVectorFuns :: TypeMark -- ^ type of the vector elements -> TypeMark -- ^ type of the vector -> [SubProgBody] genUnconsVectorFuns elemTM vectorTM = [SubProgBody exSpec [] [exExpr] , SubProgBody selSpec [SPVD selVar] [selFor, selRet] , SubProgBody emptySpec [SPVD emptyVar] [emptyExpr] , SubProgBody lengthSpec [] [lengthExpr] , SubProgBody isnullSpec [] [isnullExpr] , SubProgBody replaceSpec [SPVD replaceVar] [replaceExpr, replaceRet] , SubProgBody headSpec [] [headExpr] , SubProgBody lastSpec [] [lastExpr] , SubProgBody initSpec [SPVD initVar] [initExpr, initRet] , SubProgBody tailSpec [SPVD tailVar] [tailExpr, tailRet] , SubProgBody takeSpec [SPVD takeVar] [takeExpr, takeRet] , SubProgBody dropSpec [SPVD dropVar] [dropExpr, dropRet] , SubProgBody shiftlSpec [SPVD shiftlVar] [shiftlExpr, shiftlRet] , SubProgBody shiftrSpec [SPVD shiftrVar] [shiftrExpr, shiftrRet] , SubProgBody rotlSpec [SPVD rotlVar] [rotlExpr, rotlRet] , SubProgBody rotrSpec [SPVD rotrVar] [rotrExpr, rotrRet] , SubProgBody reverseSpec [SPVD reverseVar] [reverseFor, reverseRet] , SubProgBody copySpec [SPVD copyVar] [copyExpr] , SubProgBody plusgtSpec [SPVD plusgtVar] [plusgtExpr, plusgtRet] , SubProgBody ltplusSpec [SPVD ltplusVar] [ltplusExpr, ltplusRet] , SubProgBody plusplusSpec [SPVD plusplusVar] [plusplusExpr, plusplusRet] , SubProgBody singletonSpec [SPVD singletonVar] [singletonRet] , SubProgBody showSpec [SPSB doShowDef] [showRet] , SubProgBody defaultSpec [] [defaultExpr] ] where ixPar = unsafeVHDLBasicId "ix" vecPar = unsafeVHDLBasicId "vec" vec1Par = unsafeVHDLBasicId "vec1" vec2Par = unsafeVHDLBasicId "vec2" fPar = unsafeVHDLBasicId "f" nPar = unsafeVHDLBasicId "n" sPar = unsafeVHDLBasicId "s" iId = unsafeVHDLBasicId "i" iPar = iId aPar = unsafeVHDLBasicId "a" resId = unsafeVHDLBasicId "res" exSpec = Function exId [IfaceVarDec vecPar vectorTM, IfaceVarDec ixPar naturalTM] elemTM exExpr = ReturnSm (Just $ PrimName $ NIndexed (IndexedName (NSimple vecPar) [PrimName $ NSimple ixPar])) selSpec = Function selId [IfaceVarDec fPar naturalTM, IfaceVarDec nPar naturalTM, IfaceVarDec sPar naturalTM, IfaceVarDec vecPar vectorTM ] vectorTM -- variable res : fsvec_x (0 to n-1); selVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") ((PrimName (NSimple nPar)) :-: (PrimLit "1")) ])) Nothing -- for i res'range loop -- res(i) := vec(f+i*s); -- end loop; selFor = ForSM iId (AttribRange $ applyRangeAttrib resId) [selAssign] -- res(i) := vec(f+i*s); selAssign = let origExp = PrimName (NSimple fPar) :+: (PrimName (NSimple iId) :*: PrimName (NSimple sPar)) in NIndexed (IndexedName (NSimple resId) [PrimName (NSimple iId)]) := (PrimName $ NIndexed (IndexedName (NSimple vecPar) [origExp])) -- return res; selRet = ReturnSm (Just $ PrimName (NSimple resId)) emptySpec = Function emptyId [] vectorTM emptyVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimLit "-1")])) Nothing emptyExpr = ReturnSm (Just $ PrimName (NSimple resId)) lengthSpec = Function lengthId [IfaceVarDec vecPar vectorTM] naturalTM lengthExpr = ReturnSm (Just $ PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing)) isnullSpec = Function isnullId [IfaceVarDec vecPar vectorTM] booleanTM -- return vec'length = 0 isnullExpr = ReturnSm (Just $ PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :=: PrimLit "0") replaceSpec = Function replaceId [IfaceVarDec vecPar vectorTM, IfaceVarDec iPar naturalTM, IfaceVarDec aPar elemTM ] vectorTM -- variable res : fsvec_x (0 to vec'length-1); replaceVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: (PrimLit "1")) ])) Nothing -- res := vec(0 to i-1) & a & vec(i+1 to length'vec-1) replaceExpr = NSimple resId := (vecSlice (PrimLit "0") (PrimName (NSimple iPar) :-: PrimLit "1") :&: PrimName (NSimple aPar) :&: vecSlice (PrimName (NSimple iPar) :+: PrimLit "1") ((PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing)) :-: PrimLit "1")) replaceRet = ReturnSm (Just $ PrimName $ NSimple resId) vecSlice init last = PrimName (NSlice (SliceName (NSimple vecPar) (ToRange init last))) headSpec = Function headId [IfaceVarDec vecPar vectorTM] elemTM -- return vec(0); headExpr = ReturnSm (Just $ (PrimName $ NIndexed (IndexedName (NSimple vecPar) [PrimLit "0"]))) lastSpec = Function lastId [IfaceVarDec vecPar vectorTM] elemTM -- return vec(vec'length-1); lastExpr = ReturnSm (Just $ (PrimName $ NIndexed (IndexedName (NSimple vecPar) [PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: PrimLit "1"]))) initSpec = Function initId [IfaceVarDec vecPar vectorTM] vectorTM -- variable res : fsvec_x (0 to vec'length-2); initVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: (PrimLit "2")) ])) Nothing -- res:= vec(0 to vec'length-2) initExpr = NSimple resId := (vecSlice (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: PrimLit "2")) initRet = ReturnSm (Just $ PrimName $ NSimple resId) tailSpec = Function tailId [IfaceVarDec vecPar vectorTM] vectorTM -- variable res : fsvec_x (0 to vec'length-2); tailVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: (PrimLit "2")) ])) Nothing -- res := vec(1 to vec'length-1) tailExpr = NSimple resId := (vecSlice (PrimLit "1") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: PrimLit "1")) tailRet = ReturnSm (Just $ PrimName $ NSimple resId) takeSpec = Function takeId [IfaceVarDec nPar naturalTM, IfaceVarDec vecPar vectorTM ] vectorTM -- variable res : fsvec_x (0 to n-1); takeVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") ((PrimName (NSimple nPar)) :-: (PrimLit "1")) ])) Nothing -- res := vec(0 to n-1) takeExpr = NSimple resId := (vecSlice (PrimLit "1") (PrimName (NSimple $ nPar) :-: PrimLit "1")) takeRet = ReturnSm (Just $ PrimName $ NSimple resId) dropSpec = Function dropId [IfaceVarDec nPar naturalTM, IfaceVarDec vecPar vectorTM ] vectorTM -- variable res : fsvec_x (0 to vec'length-n-1); dropVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: (PrimName $ NSimple nPar):-: (PrimLit "1")) ])) Nothing -- res := vec(n to vec'length-1) dropExpr = NSimple resId := (vecSlice (PrimName $ NSimple nPar) (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: PrimLit "1")) dropRet = ReturnSm (Just $ PrimName $ NSimple resId) shiftlSpec = Function shiftlId [IfaceVarDec vecPar vectorTM, IfaceVarDec aPar elemTM ] vectorTM -- variable res : fsvec_x (0 to vec'length-1); shiftlVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: (PrimLit "1")) ])) Nothing -- res := a & init(vec) shiftlExpr = NSimple resId := (PrimName (NSimple aPar) :&: genExprFCall1 initId (PrimName $ NSimple vecPar)) shiftlRet = ReturnSm (Just $ PrimName $ NSimple resId) shiftrSpec = Function shiftrId [IfaceVarDec vecPar vectorTM, IfaceVarDec aPar elemTM ] vectorTM -- variable res : fsvec_x (0 to vec'length-1); shiftrVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: (PrimLit "1")) ])) Nothing -- res := tail(vec) & a shiftrExpr = NSimple resId := (genExprFCall1 tailId (PrimName $ NSimple vecPar) :&: PrimName (NSimple aPar)) shiftrRet = ReturnSm (Just $ PrimName $ NSimple resId) rotlSpec = Function rotlId [IfaceVarDec vecPar vectorTM] vectorTM -- variable res : fsvec_x (0 to vec'length-1); rotlVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: (PrimLit "1")) ])) Nothing -- if null(vec) then res := vec else res := last(vec) & init(vec) rotlExpr = IfSm (genExprFCall1 isnullId (PrimName $ NSimple vecPar)) [NSimple resId := (PrimName $ NSimple vecPar)] [] (Just $ Else [rotlExprRet]) where rotlExprRet = NSimple resId := (genExprFCall1 lastId (PrimName $ NSimple vecPar) :&: genExprFCall1 initId (PrimName $ NSimple vecPar)) rotlRet = ReturnSm (Just $ PrimName $ NSimple resId) rotrSpec = Function rotrId [IfaceVarDec vecPar vectorTM] vectorTM -- variable res : fsvec_x (0 to vec'length-1); rotrVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: (PrimLit "1")) ])) Nothing -- if null(vec) then res := vec else res := tail(vec) & head(vec) rotrExpr = IfSm (genExprFCall1 isnullId (PrimName $ NSimple vecPar)) [NSimple resId := (PrimName $ NSimple vecPar)] [] (Just $ Else [rotrExprRet]) where rotrExprRet = NSimple resId := (genExprFCall1 lastId (PrimName $ NSimple vecPar) :&: genExprFCall1 initId (PrimName $ NSimple vecPar)) rotrRet = ReturnSm (Just $ PrimName $ NSimple resId) reverseSpec = Function reverseId [IfaceVarDec vecPar vectorTM] vectorTM reverseVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: (PrimLit "1")) ])) Nothing -- for i in 0 to res'range loop -- res(vec'length-i-1) := vec(i); -- end loop; reverseFor = ForSM iId (AttribRange $ applyRangeAttrib resId) [reverseAssign] -- res(vec'length-i-1) := vec(i); reverseAssign = NIndexed (IndexedName (NSimple resId) [destExp]) := (PrimName $ NIndexed (IndexedName (NSimple vecPar) [PrimName $ NSimple iId])) where destExp = PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing) :-: PrimName (NSimple iId) :-: (PrimLit "1") -- return res; reverseRet = ReturnSm (Just $ PrimName (NSimple resId)) copySpec = Function copyId [IfaceVarDec nPar naturalTM, IfaceVarDec aPar elemTM ] vectorTM -- variable res : fsvec_x (0 to n-1) := (others => a); copyVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") ((PrimName (NSimple nPar)) :-: (PrimLit "1")) ])) (Just $ Aggregate [ElemAssoc (Just Others) (PrimName $ NSimple aPar)]) -- return res copyExpr = ReturnSm (Just $ PrimName $ NSimple resId) plusgtSpec = Function plusgtId [IfaceVarDec aPar elemTM, IfaceVarDec vecPar vectorTM] vectorTM -- variable res : fsvec_x (0 to vec'length); plusgtVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing))])) Nothing plusgtExpr = NSimple resId := ((PrimName $ NSimple aPar) :&: (PrimName $ NSimple vecPar)) plusgtRet = ReturnSm (Just $ PrimName $ NSimple resId) ltplusSpec = Function ltplusId [IfaceVarDec vecPar vectorTM, IfaceVarDec aPar elemTM] vectorTM -- variable res : fsvec_x (0 to vec'length); ltplusVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing))])) Nothing ltplusExpr = NSimple resId := ((PrimName $ NSimple vecPar) :&: (PrimName $ NSimple aPar)) ltplusRet = ReturnSm (Just $ PrimName $ NSimple resId) plusplusSpec = Function plusplusId [IfaceVarDec vec1Par vectorTM, IfaceVarDec vec2Par vectorTM ] vectorTM -- variable res : fsvec_x (0 to vec1'length + vec2'length -1); plusplusVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimName (NAttribute $ AttribName (NSimple vec1Par) lengthId Nothing) :+: PrimName (NAttribute $ AttribName (NSimple vec2Par) lengthId Nothing) :-: PrimLit "1")])) Nothing plusplusExpr = NSimple resId := ((PrimName $ NSimple vec1Par) :&: (PrimName $ NSimple vec2Par)) plusplusRet = ReturnSm (Just $ PrimName $ NSimple resId) singletonSpec = Function singletonId [IfaceVarDec aPar elemTM ] vectorTM -- variable res : fsvec_x (0 to 0) := (others => a); singletonVar = VarDec resId (SubtypeIn vectorTM (Just $ IndexConstraint [ToRange (PrimLit "0") (PrimLit "0")])) (Just $ Aggregate [ElemAssoc (Just Others) (PrimName $ NSimple aPar)]) singletonRet = ReturnSm (Just $ PrimName $ NSimple resId) showSpec = Function showId [IfaceVarDec vecPar vectorTM] stringTM doShowId = unsafeVHDLBasicId "doshow" doShowDef = SubProgBody doShowSpec [] [doShowRet] where doShowSpec = Function doShowId [IfaceVarDec vecPar vectorTM] stringTM -- case vec'len is -- when 0 => return ""; -- when 1 => return head(vec); -- when others => return show(head(vec)) & ',' & -- doshow (tail(vec)); -- end case; doShowRet = CaseSm (PrimName (NAttribute $ AttribName (NSimple vecPar) lengthId Nothing)) [CaseSmAlt [ChoiceE $ PrimLit "0"] [ReturnSm (Just $ PrimLit "\"\"")], CaseSmAlt [ChoiceE $ PrimLit "1"] [ReturnSm (Just $ genExprFCall1 showId (genExprFCall1 headId (PrimName $ NSimple vecPar)) )], CaseSmAlt [Others] [ReturnSm (Just $ genExprFCall1 showId (genExprFCall1 headId (PrimName $ NSimple vecPar)) :&: PrimLit "','" :&: genExprFCall1 doShowId (genExprFCall1 tailId (PrimName $ NSimple vecPar)) ) ]] -- return '<' & doshow(vec) & '>'; showRet = ReturnSm (Just $ PrimLit "'<'" :&: genExprFCall1 doShowId (PrimName $ NSimple vecPar) :&: PrimLit "'>'" ) defaultSpec = Function defaultId [] vectorTM defaultExpr = ReturnSm (Just $ genExprFCall0 emptyId) -- | Generate the default functions for a custom tuple type genTupleFuns :: [TypeMark] -- ^ type of each tuple element -> TypeMark -- ^ type of the tuple -> [SubProgBody] genTupleFuns elemTMs tupleTM = [SubProgBody defaultSpec [] [defaultExpr], SubProgBody showSpec [] [showExpr]] where tupPar = unsafeVHDLBasicId "tup" defaultSpec = Function defaultId [] tupleTM defaultExpr = ReturnSm (Just $ Aggregate (replicate tupSize (ElemAssoc Nothing $ PrimName defaultSN))) showSpec = Function showId [IfaceVarDec tupPar tupleTM ] stringTM -- return '(' & show(tup. showExpr = ReturnSm (Just $ PrimLit "'('" :&: showMiddle :&: PrimLit "')'") where showMiddle = foldr1 (\e1 e2 -> e1 :&: PrimLit "','" :&: e2) $ map ((genExprFCall1 showId). PrimName . NSelected. (NSimple tupPar:.:). tupVHDLSuffix) [1..tupSize] tupSize = length elemTMs -- | Generate the default functions for a custom abst_ext_ type genAbstExtFuns :: TypeMark -- ^ type of the values nested in AbstExt -> TypeMark -- ^ type of the extended values -> [SubProgBody] genAbstExtFuns elemTM absExtTM = [SubProgBody defaultSpec [] [defaultExpr], SubProgBody absentSpec [] [absentExpr] , SubProgBody presentSpec [] [presentExpr], SubProgBody fromAbstExtSpec [] [fromAbstExtExpr], SubProgBody unsafeFromAbstExtSpec [] [unsafeFromAbstExtExpr], SubProgBody isPresentSpec [] [isPresentExpr], SubProgBody isAbsentSpec [] [isAbsentExpr], SubProgBody showSpec [] [showExpr] ] where defaultPar = unsafeVHDLBasicId "default" extPar = unsafeVHDLBasicId "extabst" defaultSpec = Function defaultId [] absExtTM defaultExpr = ReturnSm (Just $ PrimName $ NSimple absentId) absentSpec = Function absentId [] absExtTM absentExpr = ReturnSm (Just $ Aggregate [ElemAssoc Nothing falseExpr, ElemAssoc Nothing $ PrimName $ defaultSN ]) presentSpec = Function presentId [IfaceVarDec extPar elemTM] absExtTM presentExpr = ReturnSm (Just $ Aggregate [ElemAssoc Nothing trueExpr, ElemAssoc Nothing $ PrimName $ NSimple extPar ]) fromAbstExtSpec = Function fromAbstExtId [IfaceVarDec defaultPar elemTM, IfaceVarDec extPar absExtTM] elemTM fromAbstExtExpr = IfSm (PrimName $ NSelected (NSimple extPar :.: SSimple isPresentId)) [ReturnSm (Just $ PrimName $ (NSelected (NSimple extPar :.: SSimple valueId)))] [] (Just $ Else [ReturnSm (Just $ PrimName $ NSimple defaultPar)]) unsafeFromAbstExtSpec = Function unsafeFromAbstExtId [IfaceVarDec extPar absExtTM] elemTM unsafeFromAbstExtExpr = ReturnSm (Just $ PrimName (NSelected (NSimple extPar :.: SSimple valueId))) isPresentSpec = Function isPresentId [IfaceVarDec extPar absExtTM] booleanTM isPresentExpr = ReturnSm (Just $ PrimName (NSelected (NSimple extPar :.: SSimple isPresentId))) isAbsentSpec = Function isAbsentId [IfaceVarDec extPar absExtTM] booleanTM isAbsentExpr = ReturnSm (Just $ Not $ PrimName (NSelected (NSimple extPar :.: SSimple isPresentId))) showSpec = Function showId [IfaceVarDec extPar absExtTM ] stringTM -- if extabs.isPresent -- return "Prst " & show(extabs.value); -- else -- return "Abst"; -- end if; showExpr = IfSm (PrimName $ NSelected (NSimple extPar :.: SSimple isPresentId)) [ReturnSm (Just $ PrimLit "\"Prst \"" :&: genExprFCall1 showId (PrimName $ (NSelected (NSimple extPar :.: SSimple valueId))))] [] (Just $ Else [ReturnSm (Just $ PrimLit "\"Abst\"")]) -- | Generate the default functions for a custom enumeration type genEnumAlgFuns :: TypeMark -- ^ enumeration type -> VHDLId -- ^ First enumeration literal of the type -> [SubProgBody] genEnumAlgFuns enumTM firstLit = [SubProgBody defaultSpec [] [defaultExpr], SubProgBody showSpec [] [showExpr]] where enumPar = unsafeVHDLBasicId "enum" defaultSpec = Function defaultId [] enumTM defaultExpr = ReturnSm (Just $ PrimName (NSimple firstLit)) showSpec = Function showId [IfaceVarDec enumPar enumTM] stringTM -- we slice the resulting image in order to eliminate the -- leading and trailing slashes -- -- return enumTM'image(enum)(2 to enumTM'image(enum)'length-1); showExpr = ReturnSm (Just $ PrimName $ NSlice $ SliceName image (ToRange (PrimLit "2") ((PrimName $ NAttribute $ AttribName image lengthId Nothing) :-: PrimLit "1"))) where image = NAttribute$ AttribName (NSimple enumTM) imageId (Just $ PrimName $ NSimple enumPar) -- | Apply the range attribute out of a simple name applyRangeAttrib :: SimpleName -> AttribName applyRangeAttrib sName = AttribName (NSimple sName) rangeId Nothing