X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=clash%2FCLasH%2FVHDL%2FVHDLTools.hs;h=4e396cae620695772c586c82350490e7d4e84338;hb=6823534f88656932f8ea21d3c0abfe75e76f3935;hp=70b09cae169392dac0b7653494b451e3979ae1ef;hpb=d52922fb4330e6a7e3bc8bd860a8bf5f98142509;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/clash/CLasH/VHDL/VHDLTools.hs b/clash/CLasH/VHDL/VHDLTools.hs
index 70b09ca..4e396ca 100644
--- a/clash/CLasH/VHDL/VHDLTools.hs
+++ b/clash/CLasH/VHDL/VHDLTools.hs
@@ -206,10 +206,7 @@ dataconToVHDLExpr dc = do
 varToVHDLId ::
   CoreSyn.CoreBndr
   -> AST.VHDLId
-varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))
-  where
-    lowers :: String -> Int
-    lowers xs = length [x | x <- xs, Char.isLower x]
+varToVHDLId var = mkVHDLExtId $ varToUniqString var
 
 -- Creates a VHDL Name from a binder
 varToVHDLName ::
@@ -223,6 +220,14 @@ varToString ::
   -> String
 varToString = OccName.occNameString . Name.nameOccName . Var.varName
 
+varToUniqString ::
+  CoreSyn.CoreBndr
+  -> String
+varToUniqString var = (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))
+  where
+    lowers :: String -> Int
+    lowers xs = length [x | x <- xs, Char.isLower x]
+
 -- Get the string version a Var's unique
 varToStringUniq :: Var.Var -> String
 varToStringUniq = show . Var.varUnique
@@ -256,12 +261,18 @@ mkVHDLBasicId s =
 -- basic ids.
 -- Use extended Ids for any values that are taken from the source file.
 mkVHDLExtId :: String -> AST.VHDLId
-mkVHDLExtId s = 
-  AST.unsafeVHDLExtId $ strip_invalid s
+mkVHDLExtId s =
+  (AST.unsafeVHDLBasicId . zEncodeString . strip_multiscore . strip_leading . strip_invalid) s
   where 
     -- Allowed characters, taken from ForSyde's mkVHDLExtId
     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
     strip_invalid = filter (`elem` allowed)
+    strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
+    strip_multiscore = concatMap (\cs -> 
+        case cs of 
+          ('_':_) -> "_"
+          _ -> cs
+      ) . List.group
 
 -- Create a record field selector that selects the given label from the record
 -- stored in the given binder.
@@ -378,7 +389,7 @@ mkTyConHType tycon args =
                 -- If we get here, then all of the argument types were state
                 -- types (we check for enumeration types at the top). Not
                 -- sure how to handle this, so error out for now.
-                (_, []) -> error $ "ADT with only State elements (or something like that?) Dunno how to handle this yet. Tycon: " ++ pprString tycon ++ " Arguments: " ++ pprString args
+                (_, []) -> return $ Right StateType --error $ "VHDLTools.mkTyConHType: ADT with only State elements (or something like that?) Dunno how to handle this yet. Tycon: " ++ pprString tycon ++ " Arguments: " ++ pprString args
                 -- A full ADT (with multiple fields and one or multiple
                 -- constructors).
                 (_, elem_htys) -> do
@@ -717,7 +728,7 @@ mkVectorShow elemTM vectorTM =
                                                              AST.:-: AST.PrimLit "1"))
     tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
     showSpec  = AST.Function showId [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec parenPar booleanTM] stringTM
-    doShowId  = AST.unsafeVHDLExtId "doshow"
+    doShowId  = AST.unsafeVHDLBasicId "doshow"
     doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
       where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM] 
                                            stringTM