Fix vhdl type generation of index type, as upper bound is now exclusive

[matthijs/master-project/cλash.git] / clash / CLasH / VHDL / VHDLTools.hs

diff --git a/clash/CLasH/VHDL/VHDLTools.hs b/clash/CLasH/VHDL/VHDLTools.hs
index 639452bcbef3f6a00aa6f1189e88e70e343d4b59..8cb2f5e5881ebf022d91dd829de2707f2d0ebe7f 100644 (file)
--- a/clash/CLasH/VHDL/VHDLTools.hs
+++ b/clash/CLasH/VHDL/VHDLTools.hs
@@ -346,7 +346,8 @@ mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHType
                   return $ Right $ SizedIType len
                 "Index" -> do
                   bound <- tfp_to_int (ranged_word_bound_ty ty)
-                  return $ Right $ RangedWType bound
+                  -- Upperbound is exclusive, hence the -1
+                  return $ Right $ RangedWType (bound - 1)
                 otherwise ->
                   mkTyConHType tycon args
     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
@@ -370,8 +371,8 @@ mkTyConHType tycon args =
           let real_arg_tyss_nostate = map (filter (\x -> not (isStateType x))) real_arg_tyss
           elem_htyss_either <- mapM (mapM mkHTypeEither) real_arg_tyss_nostate
           let (errors, elem_htyss) = unzip (map Either.partitionEithers elem_htyss_either)
-          case errors of
-            [] -> case (dcs, concat elem_htyss) of
+          case (all null errors) of
+            True -> case (dcs, concat elem_htyss) of
                 -- A single constructor with a single (non-state) field?
                 ([dc], [elem_hty]) -> return $ Right elem_hty
                 -- If we get here, then all of the argument types were state
@@ -390,8 +391,8 @@ mkTyConHType tycon args =
                   -- Create the AggrType HType
                   return $ Right $ AggrType name enum_ty_part fieldss
                 -- There were errors in element types
-            errors -> return $ Left $
-              "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
+            False -> return $ Left $
+              "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" 
               ++ (concat $ concat errors)
   where
     name = (nameToString (TyCon.tyConName tycon))
@@ -581,6 +582,17 @@ getFieldLabels ::
   -> [AST.VHDLId]      -- ^ The labels
 getFieldLabels htype dc_i = ((map mkVHDLBasicId) . (map fst)) (getFields htype dc_i)
 
+-- Finds the field label for the constructor field, if any.
+getConstructorFieldLabel ::
+  HType
+  -> Maybe AST.VHDLId
+getConstructorFieldLabel (AggrType _ (Just con) _) =
+       Just $ mkVHDLBasicId (fst con)
+getConstructorFieldLabel (AggrType _ Nothing _) =
+       Nothing
+getConstructorFieldLabel htype =
+       error $ "Can't get constructor field label from non-aggregate HType: " ++ show htype
+
 mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
 mytydecl (_, Nothing) = Nothing
 mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def