X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Flatten.hs;h=14fd781c5c6653ca989c393eb038f5af42cb38ab;hb=289124685555aeb479d5ab238585c5e27346cf09;hp=9d050435602a908b2a4e50aa0261c50e7fc18ef8;hpb=ade131124b0b12d47b4bcafd3808bd9db31428cd;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Flatten.hs b/Flatten.hs
index 9d05043..14fd781 100644
--- a/Flatten.hs
+++ b/Flatten.hs
@@ -259,7 +259,14 @@ flattenExpr binds app@(App _ _) = do
       let ((Var f), args) = collectArgs app in
       flattenApplicationExpr binds (CoreUtils.exprType app) f args
   where
-    flattenBuildTupleExpr = error $ "Tuple construction not supported: " ++ (showSDoc $ ppr app)
+    flattenBuildTupleExpr binds args = do
+      -- Flatten each of our args
+      flat_args <- (State.mapM (flattenExpr binds) args)
+      -- Check and split each of the arguments
+      let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
+      let res = Tuple arg_ress
+      return ([], res)
+
     -- | Flatten a normal application expression
     flattenApplicationExpr binds ty f args = do
       -- Find the function to call
@@ -287,6 +294,52 @@ flattenExpr binds app@(App _ _) = do
         then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
         else flat 
 
+flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
+  (b_args, b_res) <- flattenExpr binds bexpr
+  if not (null b_args)
+    then
+      error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
+    else
+      let binds' = (b, Left b_res) : binds in
+      flattenExpr binds' expr
+
+flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
+
+flattenExpr binds expr@(Case (Var v) b _ alts) =
+  case alts of
+    [alt] -> flattenSingleAltCaseExpr binds v b alt
+    otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
+  where
+    flattenSingleAltCaseExpr ::
+      BindMap
+                                -- A list of bindings in effect
+      -> Var.Var                -- The scrutinee
+      -> CoreBndr               -- The binder to bind the scrutinee to
+      -> CoreAlt                -- The single alternative
+      -> FlattenState ( [SignalDefMap], SignalUseMap)
+                                           -- See expandExpr
+    flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
+      if not (DataCon.isTupleCon datacon) 
+        then
+          error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
+        else
+          let
+            -- Lookup the scrutinee (which must be a variable bound to a tuple) in
+            -- the existing bindings list and get the portname map for each of
+            -- it's elements.
+            Left (Tuple tuple_sigs) = Maybe.fromMaybe 
+              (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
+              (lookup v binds)
+            -- TODO include b in the binds list
+            -- Merge our existing binds with the new binds.
+            binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds 
+          in
+            -- Expand the expression with the new binds list
+            flattenExpr binds' expr
+    flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
+
+
+      
 flattenExpr _ _ = do
   return ([], Tuple [])