X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=clash%2FCLasH%2FVHDL%2FVHDLTools.hs;h=8f282b422afa4c7a5047f15e47f08d03c11466dd;hb=34a7251cff433852cee6c26c7309bd4425740333;hp=639452bcbef3f6a00aa6f1189e88e70e343d4b59;hpb=4583b2b6d86da12e795f199f2951b193efed613f;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/clash/CLasH/VHDL/VHDLTools.hs b/clash/CLasH/VHDL/VHDLTools.hs
index 639452b..8f282b4 100644
--- 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))
@@ -487,14 +488,16 @@ mkTyconTy htype =
           let enum_decs = Maybe.maybeToList enum_dec_maybe
           let enum_tys = Maybe.maybeToList enum_ty_maybe
           let ty_def = AST.TDR $ AST.RecordTypeDef (enum_decs ++ concat elemss)
-          let tupshow = mkTupleShow (enum_tys ++ concat elem_tyss) ty_id
-          MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
+          let aggrshow = case enum_field_maybe of 
+                          Nothing -> mkTupleShow (enum_tys ++ concat elem_tyss) ty_id
+                          Just (conLbl, EnumType tycon dcs) -> mkAdtShow conLbl dcs (map (map fst) fieldss) ty_id
+          MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, aggrshow)
           return $ Just (ty_id, Just $ Left ty_def)
     (EnumType tycon dcs) -> do
-      let elems = map mkVHDLExtId dcs
       let ty_id = mkVHDLExtId tycon
-      let ty_def = AST.TDE $ AST.EnumTypeDef elems
-      let enumShow = mkEnumShow elems ty_id
+      let range = AST.SubTypeRange (AST.PrimLit "0") (AST.PrimLit $ show ((length dcs) - 1))
+      let ty_def = AST.TDI $ AST.IntegerTypeDef range
+      let enumShow = mkEnumShow dcs ty_id
       MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
       return $ Just (ty_id, Just $ Left ty_def)
     otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
@@ -538,7 +541,7 @@ mkNaturalTy ::
 mkNaturalTy min_bound max_bound = do
   let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
   let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
-  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show bitsize) (AST.PrimLit $ show min_bound)]
   let ty_def = AST.SubtypeIn unsignedTM (Just range)
   return (Just (ty_id, Just $ Right ty_def))
 
@@ -546,8 +549,8 @@ mkUnsignedTy ::
   Int -- ^ Haskell type of the unsigned integer
   -> TypeSession TypeMapRec
 mkUnsignedTy size = do
-  let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
-  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+  let ty_id = mkVHDLExtId $ "unsigned_" ++ show size
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
   let ty_def = AST.SubtypeIn unsignedTM (Just range)
   return (Just (ty_id, Just $ Right ty_def))
   
@@ -555,8 +558,8 @@ mkSignedTy ::
   Int -- ^ Haskell type of the signed integer
   -> TypeSession TypeMapRec
 mkSignedTy size = do
-  let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
-  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+  let ty_id = mkVHDLExtId $ "signed_" ++ show size
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
   let ty_def = AST.SubtypeIn signedTM (Just range)
   return (Just (ty_id, Just $ Right ty_def))
 
@@ -570,8 +573,8 @@ getFields ::
 getFields htype dc_i = case htype of
   (AggrType name _ fieldss) 
     | dc_i >= 0 && dc_i < length fieldss -> fieldss!!dc_i
-    | otherwise -> error $ "Invalid constructor index: " ++ (show dc_i) ++ ". No such constructor in HType: " ++ (show htype)
-  _ -> error $ "Can't get fields from non-aggregate HType: " ++ show htype
+    | otherwise -> error $ "VHDLTool.getFields: Invalid constructor index: " ++ (show dc_i) ++ ". No such constructor in HType: " ++ (show htype)
+  _ -> error $ "VHDLTool.getFields: Can't get fields from non-aggregate HType: " ++ show htype
 
 -- Finds the field labels for an aggregation type, as VHDLIds.
 getFieldLabels ::
@@ -581,6 +584,28 @@ 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
+
+
+getConstructorIndex ::
+  HType ->
+  String ->
+  Int
+getConstructorIndex (EnumType etype cons) dc = case List.elemIndex dc cons of
+  Just (index) -> index
+  Nothing -> error $ "VHDLTools.getConstructor: constructor: " ++ show dc ++ " is not part of type: " ++ show etype ++ ", which only has constructors: " ++ show cons
+getConstructorIndex htype _ = error $ "Can't get constructor index for non-Enum type: " ++ 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
@@ -610,16 +635,38 @@ mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
     tupSize = length elemTMs
 
+mkAdtShow ::
+  String
+  -> [String] -- Constructors
+  -> [[String]] -- Fields for every constructor
+  -> AST.TypeMark
+  -> AST.SubProgBody
+mkAdtShow conLbl conIds elemIdss adtTM = AST.SubProgBody showSpec [] [showExpr]
+  where  
+    adtPar   = AST.unsafeVHDLBasicId "adt"
+    showSpec  = AST.Function showId [AST.IfaceVarDec adtPar adtTM] stringTM
+    showExpr  = AST.CaseSm ((selectedName adtPar) (mkVHDLBasicId conLbl))
+                  [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] 
+                    [AST.ReturnSm (Just $ ((genExprFCall showId) . (selectedName adtPar) $ mkVHDLBasicId conLbl) AST.:&: showFields x)] | x <- [0..(length conIds) -1]]
+    showFields i = if (null (elemIdss!!i)) then
+        AST.PrimLit "nul"
+      else
+        foldr1 (\e1 e2 -> e1 AST.:&: e2) $
+              map ((AST.PrimLit "' '" AST.:&:) . (genExprFCall showId) . (selectedName adtPar))
+                  (map mkVHDLBasicId (elemIdss!!i))
+    selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)       
+    
 mkEnumShow ::
-  [AST.VHDLId]
+  [String]
   -> AST.TypeMark
   -> AST.SubProgBody
 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
-  where
-    enumPar    = AST.unsafeVHDLBasicId "enum"
+  where  
+    enumPar   = AST.unsafeVHDLBasicId "enum"
     showSpec  = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
-    showExpr  = AST.ReturnSm (Just $
-                  AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
+    showExpr  = AST.CaseSm (AST.PrimName $ AST.NSimple enumPar)
+                  [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] [AST.ReturnSm (Just $ AST.PrimLit $ '"':(elemIds!!x)++['"'])] | x <- [0..(length elemIds) -1]]
+            
 
 mkVectorShow ::
   AST.TypeMark -- ^ elemtype