X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=daf829258b388839959c5ca6d83becd1305645ef;hb=0b54fb07697815cb343e7f217b1bd8362365f22d;hp=56cbe5e698c764451f3f15bb19658f58e872cca2;hpb=553b58f58b14a0bbe3421fc7c69c268d071dd4bb;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index 56cbe5e..daf8292 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -124,21 +124,22 @@ getInstantiations ::
 	PortNameMap                  -- The arguments that need to be applied to the
 															 -- expression. Should always be the Args
 															 -- constructor.
+	-> PortNameMap               -- The output ports that the expression should generate.
 	-> [(CoreBndr, PortNameMap)] -- A list of bindings in effect
 	-> CoreSyn.CoreExpr          -- The expression to generate an architecture for
 	-> String                    -- The resulting VHDL code
 
 -- A lambda expression binds the first argument (a) to the binder b.
-getInstantiations (Args (a:as)) binds (Lam b expr) =
-	getInstantiations (Args as) ((b, a):binds) expr
+getInstantiations (Args (a:as)) outs binds (Lam b expr) =
+	getInstantiations (Args as) outs ((b, a):binds) expr
 
 -- A case expression that checks a single variable and has a single
 -- alternative, can be used to take tuples apart
-getInstantiations args binds (Case (Var v) b _ [res]) =
+getInstantiations args outs binds (Case (Var v) b _ [res]) =
 	case altcon of
 		DataAlt datacon ->
 			if (DataCon.isTupleCon datacon) then
-				getInstantiations args binds' expr
+				getInstantiations args outs binds' expr
 			else
 				error "Data constructors other than tuples not supported"
 		otherwise ->
@@ -152,21 +153,34 @@ getInstantiations args binds (Case (Var v) b _ [res]) =
 			(lookup v binds)
 
 -- An application is an instantiation of a component
-getInstantiations args binds app@(App expr arg) =
+getInstantiations args outs binds app@(App expr arg) =
 	--indent ++ "F:\n" ++ (getInstantiations (' ':indent) expr) ++ "\n" ++ indent ++ "A:\n" ++ (getInstantiations (' ':indent) arg) ++ "\n"
 	"app : " ++ (getOccString f) ++ "\n"
 	++ "port map (\n"
+	-- Map input ports of f
 	++ concat (zipWith (getPortMapEntry binds) ["portin0", "portin1"] args)
+	-- Map output ports of f
+	++ mapOutputPorts (Port "portout") outs
 	++ ");\n"
 	where
 		((Var f), args) = collectArgs app
 
-getInstantiations args binds expr = showSDoc $ ppr $ expr
+getInstantiations args outs binds expr = 
+	error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
+
+-- Map the output port of a component to the output port of the containing
+-- entity.
+mapOutputPorts (Port port) (Port signal) =
+	"\t" ++ port ++ " => " ++ signal ++ "\n"
+
+-- Map matching output ports in the tuple
+mapOutputPorts (Tuple ports) (Tuple signals) =
+	concat (zipWith mapOutputPorts ports signals)
 
 getArchitecture (NonRec var expr) =
 	"architecture structural of " ++ name ++ " is\n"
 	++ "begin\n"
-	++ getInstantiations (Args inportnames) [] expr
+	++ getInstantiations (Args inportnames) outport [] expr
 	++ "end structural\n"
 	where
 		name = (getOccString var)
@@ -177,6 +191,7 @@ getArchitecture (NonRec var expr) =
 		inportnames = case ports of
 			[port] -> [getPortNameMapForTy "portin" port]
 			ps     -> getPortNameMapForTys "portin" 0 ps
+		outport = getPortNameMapForTy "portout" res
 
 data PortNameMap =
 	Args [PortNameMap] -- Each of the submaps represent an argument to the