-> [(AST.VHDLId, AST.DesignFile)]
createDesignFiles binds =
- (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
+ (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
map (Arrow.second $ AST.DesignFile full_context) units
where
init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
(units, final_session) =
State.runState (createLibraryUnits binds) init_session
- ty_decls = map (uncurry AST.TypeDec) $ Map.elems (final_session ^. vsTypes)
+ tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
+ ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
ieee_context = [
AST.Library $ mkVHDLBasicId "IEEE",
mkUseAll ["IEEE", "std_logic_1164"],
full_context =
mkUseAll ["work", "types"]
: ieee_context
- type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map AST.PDITD ty_decls)
+ type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (ty_decls ++ subProgSpecs)
+ type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
+ subProgSpecs = concat (map subProgSpec tyfun_decls)
+ subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
+ mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
+ mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
+ mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
-- Create a use foo.bar.all statement. Takes a list of components in the used
-- name. Must contain at least two components
let sel_name = mkSelectedName bndr label in
mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
IdInfo.VanillaGlobal -> do
- -- It's a global value imported from elsewhere. These can be builting
+ -- It's a global value imported from elsewhere. These can be builtin
-- functions.
funSignatures <- getA vsNameTable
case (Map.lookup (bndrToString f) funSignatures) of
- Just funSignature ->
- let
- sigs = map (bndrToString.varBndr) args
- sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
- func = (snd funSignature) sigsNames
- src_wform = AST.Wform [AST.WformElem func Nothing]
- dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
- assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
- in
- return $ AST.CSSASm assign
+ Just (arg_count, builder) ->
+ if length args == arg_count then
+ let
+ sigs = map (bndrToString.varBndr) args
+ sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
+ func = builder sigsNames
+ src_wform = AST.Wform [AST.WformElem func Nothing]
+ dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
+ assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+ in
+ return $ AST.CSSASm assign
+ else
+ error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString args
Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
IdInfo.NotGlobalId -> do
signatures <- getA vsSignatures
-- Get the types map, lookup and unpack the VHDL TypeDef
types <- getA vsTypes
case Map.lookup (OrdType ty) types of
- Just (_, AST.TDR (AST.RecordTypeDef elems)) -> return $ map (\(AST.ElementDec id _) -> id) elems
+ Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
_ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
-- Turn a variable reference into a AST expression
Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
-- Construct a new VHDL type for the given Haskell type.
-construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
+construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
construct_vhdl_ty ty = do
case Type.splitTyConApp_maybe ty of
Just (tycon, args) -> do
case name of
"TFVec" -> do
res <- mk_vector_ty (tfvec_len ty) ty
- return $ Just res
+ return $ Just $ (Arrow.second Left) res
"SizedWord" -> do
res <- mk_vector_ty (sized_word_len ty) ty
- return $ Just res
+ return $ Just $ (Arrow.second Left) res
+ "RangedWord" -> do
+ res <- mk_natural_ty 0 (ranged_word_bound ty) ty
+ return $ Just $ (Arrow.second Right) res
-- Create a custom type from this tycon
otherwise -> mk_tycon_ty tycon args
Nothing -> return $ Nothing
-- | Create VHDL type for a custom tycon
-mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
+mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
mk_tycon_ty tycon args =
case TyCon.tyConDataCons tycon of
-- Not an algebraic type
-- TODO: Special handling for tuples?
let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
let ty_def = AST.TDR $ AST.RecordTypeDef elems
- return $ Just (ty_id, ty_def)
+ return $ Just (ty_id, Left ty_def)
dcs -> error $ "Only single constructor datatypes supported: " ++ (showSDoc $ ppr tycon)
where
-- Create a subst that instantiates all types passed to the tycon
modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
return (ty_id, ty_def)
+mk_natural_ty ::
+ Int -- ^ The minimum bound (> 0)
+ -> Int -- ^ The maximum bound (> minimum bound)
+ -> Type.Type -- ^ The Haskell type to create a VHDL type for
+ -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
+mk_natural_ty min_bound max_bound ty = do
+ let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
+ let ty_def = AST.SubtypeIn naturalTM (Nothing)
+ return (ty_id, ty_def)
+
builtin_types =
Map.fromList [