X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=13a92942e171508e13ddffcf8287a04091422a5d;hb=51de92c87cbd5a40c7e58480deef1af00418790f;hp=8bc67a39dba4cdc9592e35fd17724c27e2871246;hpb=fc9e13429a9f75f03ef75b91ca540c08b40083a2;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/VHDL.hs b/VHDL.hs
index 8bc67a3..13a9294 100644
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -47,12 +47,11 @@ createDesignFiles binds =
   map (Arrow.second $ AST.DesignFile full_context) units
   
   where
-    init_session = VHDLState Map.empty Map.empty Map.empty Map.empty
+    init_session = VHDLState Map.empty [] Map.empty Map.empty
     (units, final_session) = 
       State.runState (createLibraryUnits binds) init_session
     tyfun_decls = map snd $ Map.elems (final_session ^.vsTypeFuns)
-    ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
-    vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
+    ty_decls = final_session ^.vsTypeDecls
     tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
     tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
     tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
@@ -65,13 +64,10 @@ createDesignFiles binds =
       mkUseAll ["work", "types"]
       : (mkUseAll ["work"]
       : ieee_context)
-    type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs)
+    type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
     type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
     subProgSpecs = map subProgSpec tyfun_decls
     subProgSpec = \(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
@@ -129,8 +125,9 @@ createEntity (fname, expr) = do
         --  Assume the bndr has a valid VHDL id already
         id = varToVHDLId bndr
         ty = Var.varType bndr
+        error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr 
       in do
-        type_mark <- vhdl_ty ty
+        type_mark <- vhdl_ty error_msg ty
         return (id, type_mark)
      )
 
@@ -176,7 +173,7 @@ createArchitecture ::
 createArchitecture (fname, expr) = do
   signaturemap <- getA vsSignatures
   let signature = Maybe.fromMaybe 
-        (error $ "Generating architecture for function " ++ (pprString fname) ++ "without signature? This should not happen!")
+        (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
         (Map.lookup fname signaturemap)
   let entity_id = ent_id signature
   -- Strip off lambda's, these will be arguments
@@ -239,7 +236,8 @@ getSignalId info =
 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
 mkSigDec bndr =
   if True then do --isInternalSigUse use || isStateSigUse use then do
-    type_mark <- vhdl_ty $ Var.varType bndr
+    let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr 
+    type_mark <- (vhdl_ty error_msg) $ Var.varType bndr
     return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
   else
     return Nothing
@@ -278,9 +276,9 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
           let sel_name = mkSelectedName (varToVHDLName scrut) label
           let sel_expr = AST.PrimName sel_name
           return [mkUncondAssign (Left bndr) sel_expr]
-        Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
+        Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
       
-    _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
+    _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
 
 -- Multiple case alt are be conditional assignments and have only wild
 -- binders in the alts and only variables in the case values and a variable
@@ -293,6 +291,6 @@ mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)]))
     false_expr  = (varToVHDLExpr false)
   in
     return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
-mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
-mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
-mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
+mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
+mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
+mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr