X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=80b069be1dca016621384dbda3c91507a991d8f7;hb=2ee391fd9b32f39872abfcf339e949f5139c6cbd;hp=57bebfc12ab0265369ecb7028a6a8740c579d2d6;hpb=1e30fe04f4c285970ad2d5e23930dd935b4214fa;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/VHDL.hs b/VHDL.hs
index 57bebfc..80b069b 100644
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -21,18 +21,16 @@ import FlattenTypes
 import TranslatorTypes
 import Pretty
 
-getDesignFile :: VHDLState AST.DesignFile
-getDesignFile = do
+getDesignFiles :: VHDLState [AST.DesignFile]
+getDesignFiles = do
   -- Extract the library units generated from all the functions in the
   -- session.
   funcs <- getFuncs
-  let units = concat $ map getLibraryUnits funcs
+  let units = Maybe.mapMaybe getLibraryUnits funcs
   let context = [
         AST.Library $ mkVHDLId "IEEE",
         AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
-  return $ AST.DesignFile 
-    context
-    units
+  return $ map (\(ent, arch) -> AST.DesignFile context [ent, arch]) units
   
 -- | Create an entity for a given function
 createEntity ::
@@ -139,11 +137,26 @@ createArchitecture hsfunc fdata =
       let sig_decs = Maybe.catMaybes $ map (mkSigDec . snd) sigs
       -- Create concurrent statements for all signal definitions
       statements <- mapM (mkConcSm sigs) defs
-      let procs = map mkStateProcSm (getOwnStates hsfunc flatfunc)
+      let procs = map mkStateProcSm (makeStatePairs flatfunc)
       let procs' = map AST.CSPSm procs
       let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
       setArchitecture hsfunc arch
 
+-- | Looks up all pairs of old state, new state signals, together with
+--   the state id they represent.
+makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
+makeStatePairs flatfunc =
+  [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info) 
+    | old_info <- map snd (flat_sigs flatfunc)
+    , new_info <- map snd (flat_sigs flatfunc)
+	-- old_info must be an old state (and, because of the next equality,
+	-- new_info must be a new state).
+	, Maybe.isJust $ oldStateId $ sigUse old_info
+	-- And the state numbers must match
+    , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
+
+    -- Replace the second tuple element with the corresponding SignalInfo
+    --args_states = map (Arrow.second $ signalInfo sigs) args
 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 mkStateProcSm (num, old, new) =
   AST.ProcSm label [clk] [statement]
@@ -205,6 +218,10 @@ mkConcSm sigs (UncondDef src dst) = do
       case expr of
         (EqLit id lit) ->
           (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
+        (Literal lit) ->
+          AST.PrimLit lit
+        (Eq a b) ->
+          (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 
 mkConcSm sigs (CondDef cond true false dst) = do
   let cond_expr  = mkIdExpr sigs cond
@@ -273,18 +290,19 @@ getEntityId fdata =
 
 getLibraryUnits ::
   (HsFunction, FuncData)      -- | A function from the session
-  -> [AST.LibraryUnit]        -- | The library units it generates
+  -> Maybe (AST.LibraryUnit, AST.LibraryUnit) -- | The entity and architecture for the function
 
 getLibraryUnits (hsfunc, fdata) =
   case funcEntity fdata of 
-    Nothing -> []
-    Just ent -> case ent_decl ent of
-      Nothing -> []
-      Just decl -> [AST.LUEntity decl]
-  ++
-  case funcArch fdata of
-    Nothing -> []
-    Just arch -> [AST.LUArch arch]
+    Nothing -> Nothing
+    Just ent -> 
+      case ent_decl ent of
+      Nothing -> Nothing
+      Just decl ->
+        case funcArch fdata of
+          Nothing -> Nothing
+          Just arch ->
+            Just (AST.LUEntity decl, AST.LUArch arch)
 
 -- | The VHDL Bit type
 bit_ty :: AST.TypeMark
@@ -316,10 +334,14 @@ vhdl_ty_maybe ty =
           let name = TyCon.tyConName tycon in
             -- TODO: Do something more robust than string matching
             case Name.getOccString name of
-              "Bit"      -> Just bit_ty
+              "Bit"      -> Just std_logic_ty
               otherwise  -> Nothing
         otherwise -> Nothing
 
 -- Shortcut
 mkVHDLId :: String -> AST.VHDLId
-mkVHDLId = AST.unsafeVHDLBasicId
+mkVHDLId s = 
+  AST.unsafeVHDLBasicId s'
+  where
+    -- Strip invalid characters.
+    s' = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.") s