From: Christiaan Baaij Date: Fri, 19 Jun 2009 14:14:02 +0000 (+0200) Subject: Added support for RangedWords X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=c5cde0d59dbe9dccb7a7d1752f2d2e6c7001e8bb;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Added support for RangedWords --- diff --git a/CoreTools.hs b/CoreTools.hs index a8dce3f..0dee471 100644 --- a/CoreTools.hs +++ b/CoreTools.hs @@ -58,6 +58,14 @@ sized_word_len ty = where (tycon, args) = Type.splitTyConApp ty [len] = args + +-- | Get the upperbound of a RangedWord type +ranged_word_bound :: Type.Type -> Int +ranged_word_bound ty = + eval_tfp_int len + where + (tycon, args) = Type.splitTyConApp ty + [len] = args -- | Evaluate a core Type representing type level int from the TypeLevel -- library to a real int. diff --git a/VHDL.hs b/VHDL.hs index 8eb130f..f838cba 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -48,14 +48,16 @@ createDesignFiles :: -> [(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 + init_session = VHDLSession Map.empty Map.empty Map.empty builtin_funcs globalNameTable (units, final_session) = State.runState (createLibraryUnits binds) init_session ty_decls = Map.elems (final_session ^. vsTypes) + subty_decls = Map.elems (final_session ^. vsSubTypes) + tyfun_decls = Map.elems (final_session ^.vsTypeFuns) ieee_context = [ AST.Library $ mkVHDLBasicId "IEEE", mkUseAll ["IEEE", "std_logic_1164"], @@ -64,7 +66,12 @@ createDesignFiles binds = full_context = mkUseAll ["work", "types"] : ieee_context - type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls) + type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (packageTypeDecs ++ packageSubtypeDecs ++ subProgSpecs) + type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls) + packageTypeDecs = map (AST.PDITD . snd) ty_decls + packageSubtypeDecs = map (AST.PDISD . snd) subty_decls + subProgSpecs = concat (map subProgSpec tyfun_decls) + subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) -- Create a use foo.bar.all statement. Takes a list of components in the used -- name. Must contain at least two components @@ -443,6 +450,7 @@ vhdl_ty ty = do case name of "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty + "RangedWord" -> Just $ mk_natural_ty 0 (ranged_word_bound ty) ty otherwise -> Nothing -- Return new_ty when a new type was successfully created Maybe.fromMaybe @@ -468,6 +476,18 @@ mk_vector_ty len ty = do modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id)) return ty_id +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 -- 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) + let ty_dec = AST.SubtypeDec ty_id ty_def + modA vsSubTypes (Map.insert (OrdType ty) (ty_id, ty_dec)) + return ty_id + builtin_types = Map.fromList [ diff --git a/VHDLTypes.hs b/VHDLTypes.hs index e517a8b..9b48579 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -45,6 +45,9 @@ instance Ord OrdType where -- A map of a Core type to the corresponding type name type TypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDec) +-- A map of a Core type to the corresponding VHDL subtype +type SubTypeMap = Map.Map OrdType (AST.VHDLId, AST.SubtypeDec) + -- A map of a vector Core type to the coressponding VHDL functions type TypeFunMap = Map.Map OrdType [AST.SubProgBody] @@ -57,6 +60,8 @@ type NameTable = Map.Map String (Int, [AST.Expr] -> AST.Expr ) data VHDLSession = VHDLSession { -- | A map of Core type -> VHDL Type vsTypes_ :: TypeMap, + -- | A map of Core type -> VHDL SubType + vsSubTypes_ :: SubTypeMap, -- | A map of vector Core type -> VHDL type function vsTypeFuns_ :: TypeFunMap, -- | A map of HsFunction -> hardware signature (entity name, port names,