X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=705b552c876b1e2703a63855f819e5848d1a4233;hb=ac4f2be196c43f1ec0e1a9485f09afc239abfbe3;hp=29cf1481158bd3da9df5b49940e85aa68c9c7f08;hpb=ccb1999bfcce214b8a1de2f052367ac59b83a320;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index 29cf148..705b552 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -44,7 +44,7 @@ main =
           --core <- GHC.compileToCoreSimplified "Adders.hs"
           core <- GHC.compileToCoreSimplified "Adders.hs"
           liftIO $ printBinds (cm_binds core)
-          let bind = findBind "full_adder" (cm_binds core)
+          let bind = Maybe.fromJust $ findBind (cm_binds core) "full_adder" 
           let NonRec var expr = bind
           -- Turn bind into VHDL
           let vhdl = State.evalState (mkVHDL bind) (VHDLSession 0 builtin_funcs)
@@ -84,15 +84,15 @@ printBind' (b, expr) = do
   --putStr $ showSDoc $ ppr expr
   putStr "\n"
 
-findBind :: String -> [CoreBind] -> CoreBind
-findBind lookfor =
+findBind :: [CoreBind] -> String -> Maybe CoreBind
+findBind binds lookfor =
   -- This ignores Recs and compares the name of the bind with lookfor,
   -- disregarding any namespaces in OccName and extra attributes in Name and
   -- Var.
-  Maybe.fromJust . find (\b -> case b of 
+  find (\b -> case b of 
     Rec l -> False
     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
-  )
+  ) binds
 
 getPortMapEntry ::
   SignalNameMap AST.VHDLId  -- The port name to bind to
@@ -227,6 +227,16 @@ expandExpr binds (Var id) =
       (error $ "Argument " ++ getOccString id ++ "is unknown")
       (lookup id binds)
 
+expandExpr binds l@(Let (NonRec b bexpr) expr) = do
+  (signal_decls, statements, arg_signals, res_signals) <- expandExpr binds bexpr
+  let binds' = (b, res_signals) : binds
+  (signal_decls', statements', arg_signals', res_signals') <- expandExpr binds' expr
+  return (
+    signal_decls ++ signal_decls',
+    statements ++ statements',
+    arg_signals',
+    res_signals')
+
 expandExpr binds app@(App _ _) = do
   let ((Var f), args) = collectArgs app
   if isTupleConstructor f 
@@ -478,6 +488,9 @@ createSignalAssignments (Signal dst) (Signal src) =
 createSignalAssignments (Tuple dsts) (Tuple srcs) =
   concat $ zipWith createSignalAssignments dsts srcs
 
+createSignalAssignments dst src =
+  error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++  show src
+
 data SignalNameMap t =
   Tuple [SignalNameMap t]
   | Signal  t