+ where
+ init_session = VHDLState Map.empty Map.empty Map.empty Map.empty
+ (units, final_session) =
+ State.runState (createLibraryUnits binds) init_session
+ tyfun_decls = map snd $ Map.elems (final_session ^.vsTypeFuns)
+ ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
+ vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
+ tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
+ tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
+ tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
+ ieee_context = [
+ AST.Library $ mkVHDLBasicId "IEEE",
+ mkUseAll ["IEEE", "std_logic_1164"],
+ mkUseAll ["IEEE", "numeric_std"]
+ ]
+ full_context =
+ mkUseAll ["work", "types"]
+ : (mkUseAll ["work"]
+ : ieee_context)
+ type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs)
+ type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
+ subProgSpecs = map subProgSpec tyfun_decls
+ subProgSpec = \(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
+mkUseAll :: [String] -> AST.ContextItem
+mkUseAll ss =
+ AST.Use $ from AST.:.: AST.All
+ where
+ base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
+ from = foldl select base_prefix (tail ss)
+ select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
+
+createLibraryUnits ::
+ [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
+ -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
+
+createLibraryUnits binds = do
+ entities <- Monad.mapM createEntity binds
+ archs <- Monad.mapM createArchitecture binds
+ return $ zipWith
+ (\ent arch ->
+ let AST.EntityDec id _ = ent in
+ (id, [AST.LUEntity ent, AST.LUArch arch])
+ )
+ entities archs
+