X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;fp=VHDL.hs;h=fcfd91171376aff196e9f2514e5dacf1ad927d39;hb=ef589dec9b04aa3d0a30a2b0787c50d07c320563;hp=f0bd3c4cca75a4a1314a87e2cb47a3b02c67ecf3;hpb=dc9b719e624788cd0ced12ba45f8761382755ad5;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/VHDL.hs b/VHDL.hs
index f0bd3c4..fcfd911 100644
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -52,14 +52,15 @@ 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
     (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"],
@@ -68,7 +69,13 @@ createDesignFiles binds =
     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
@@ -403,7 +410,7 @@ getFieldLabels ty = do
   -- 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
@@ -550,7 +557,7 @@ vhdl_ty ty = do
         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
@@ -558,16 +565,19 @@ construct_vhdl_ty ty = 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
@@ -586,7 +596,7 @@ mk_tycon_ty tycon args =
       -- 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
@@ -610,6 +620,16 @@ mk_vector_ty len ty = do
   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 [