8 files changed, 421 insertions, 0 deletions

diff --git a/assignment-13/uFPL/Arduino.dcl b/assignment-13/uFPL/Arduino.dcl
new file mode 100644
index 0000000..efed603
--- /dev/null
+++ b/assignment-13/uFPL/Arduino.dcl
@@ -0,0 +1,10 @@
+definition module uFPL.Arduino
+
+from StdOverloaded import class toString
+
+from uFPL.Util import class print
+
+:: Button = B0 | B1 | B2 | B3 | B4 | B5
+
+instance toString Button
+instance print Button
diff --git a/assignment-13/uFPL/Arduino.icl b/assignment-13/uFPL/Arduino.icl
new file mode 100644
index 0000000..2fbab30
--- /dev/null
+++ b/assignment-13/uFPL/Arduino.icl
@@ -0,0 +1,16 @@
+implementation module uFPL.Arduino
+
+import StdOverloaded
+
+import uFPL.Util
+
+instance toString Button
+where
+	toString B0 = "B0"
+	toString B1 = "B1"
+	toString B2 = "B2"
+	toString B3 = "B3"
+	toString B4 = "B4"
+	toString B5 = "B5"
+
+instance print Button where print b = print (toString b)
diff --git a/assignment-13/uFPL/Bootstrap.dcl b/assignment-13/uFPL/Bootstrap.dcl
new file mode 100644
index 0000000..201957c
--- /dev/null
+++ b/assignment-13/uFPL/Bootstrap.dcl
@@ -0,0 +1,37 @@
+definition module uFPL.Bootstrap
+
+from StdOverloaded import class zero
+
+import uFPL
+
+rwBool :: String Bool -> Expr Bool RW
+roBool :: String Bool -> Expr Bool RO
+
+rwInt :: String Int -> Expr Int RW
+roInt :: String Int -> Expr Int RO
+rwUInt :: String Int -> Expr Int RW
+roUInt :: String Int -> Expr Int RO
+
+rwLong :: String Int -> Expr Int RW
+roLong :: String Int -> Expr Int RO
+rwULong :: String Int -> Expr Int RW
+roULong :: String Int -> Expr Int RO
+
+boolmap :: Bimap Bool CExpr
+intmap :: Bimap Int CExpr
+longmap :: Bimap Int CExpr
+
+b0 :: Expr Bool RO
+b1 :: Expr Bool RO
+b2 :: Expr Bool RO
+b3 :: Expr Bool RO
+b4 :: Expr Bool RO
+
+millis :: Expr Int RO
+
+false :: Expr Bool RO
+true :: Expr Bool RO
+
+rts :: String
+
+instance zero CProg
diff --git a/assignment-13/uFPL/Bootstrap.icl b/assignment-13/uFPL/Bootstrap.icl
new file mode 100644
index 0000000..8e00e97
--- /dev/null
+++ b/assignment-13/uFPL/Bootstrap.icl
@@ -0,0 +1,120 @@
+implementation module uFPL.Bootstrap
+
+from StdFunc import const
+import StdGeneric
+from StdMisc import undef
+import StdString
+
+import uFPL.Arduino
+import uFPL.C
+import uFPL
+
+rwBool :: String Bool -> Expr Bool RW
+rwBool n d = EShared {sname=n, stype=CTBool, sinit=d, srepr=boolmap}
+
+roBool :: String Bool -> Expr Bool RO
+roBool n d = EShared {sname=n, stype=CTBool, sinit=d, srepr=boolmap}
+
+rwInt :: String Int -> Expr Int RW
+rwInt n d = EShared {sname=n, stype=CTInt Sig, sinit=d, srepr=intmap}
+
+roInt :: String Int -> Expr Int RO
+roInt n d = EShared {sname=n, stype=CTInt Sig, sinit=d, srepr=intmap}
+
+rwUInt :: String Int -> Expr Int RW
+rwUInt n d = EShared {sname=n, stype=CTInt Unsig, sinit=d, srepr=intmap}
+
+roUInt :: String Int -> Expr Int RO
+roUInt n d = EShared {sname=n, stype=CTInt Unsig, sinit=d, srepr=intmap}
+
+rwLong :: String Int -> Expr Int RW
+rwLong n d = EShared {sname=n, stype=CTLong Sig, sinit=d, srepr=longmap}
+
+roLong :: String Int -> Expr Int RO
+roLong n d = EShared {sname=n, stype=CTLong Sig, sinit=d, srepr=longmap}
+
+rwULong :: String Int -> Expr Int RW
+rwULong n d = EShared {sname=n, stype=CTLong Unsig, sinit=d, srepr=longmap}
+
+roULong :: String Int -> Expr Int RO
+roULong n d = EShared {sname=n, stype=CTLong Unsig, sinit=d, srepr=longmap}
+
+boolmap :: Bimap Bool CExpr
+boolmap = {map_to=CEBool, map_from= \(CEBool b) -> b}
+
+intmap :: Bimap Int CExpr
+intmap = {map_to=CEInt, map_from= \(CEInt i) -> i}
+
+longmap :: Bimap Int CExpr
+longmap = {map_to=CEInt, map_from= \(CEInt i) -> i}
+
+b0 :: Expr Bool RO
+b0 = roBool "b0" False
+
+b1 :: Expr Bool RO
+b1 = roBool "b1" False
+
+b2 :: Expr Bool RO
+b2 = roBool "b2" False
+
+b3 :: Expr Bool RO
+b3 = roBool "b3" False
+
+b4 :: Expr Bool RO
+b4 = roBool "b4" False
+
+millis :: Expr Int RO
+millis = roLong "millis" 0
+
+false :: Expr Bool RO
+false = lit False
+
+true :: Expr Bool RO
+true = lit True
+
+rts :: String
+rts =
+	"#include <LiquidCrystal.h>" +:
+	"LiquidCrystal lcd = LiquidCrystal(8, 9, 4, 5, 6, 7);" +:
+	
+	sharetype "b"  "bool" +:
+	sharetype "c"  "signed char" +:
+	sharetype "uc" "unsigned char" +:
+	sharetype "i"  "signed int" +:
+	sharetype "ui" "unsigned int" +:
+	sharetype "l"  "signed long" +:
+	sharetype "ul" "unsigned long"
+where
+	(+:) infixl 6 :: String String -> String
+	(+:) a b = a +++ "\n" +++ b
+
+	sharetype :: String String -> String
+	sharetype short long =
+		"struct " +++ short +++ "share {" +:
+		"	" +++ long +++ " val;" +:
+		"	unsigned char dirty;" +:
+		"	unsigned char subscriptions;" +:
+		"};" +:
+
+		"void " +++ short +++ "subscribe(struct " +++ short +++ "share *share) {" +:
+		"	share->subscriptions++;" +:
+		"}" +:
+
+		"void " +++ short +++ "release(struct " +++ short +++ "share *share) {" +:
+		"	share->subscriptions--;" +:
+		"}" +:
+
+		"void " +++ short +++ "set(struct " +++ short +++ "share *share, " +++ long +++ " val) {" +:
+		"	share->val = val;" +:
+		"	share->dirty = share->subscriptions;" +:
+		"}" +:
+
+		"bool " +++ short +++ "dirty(struct " +++ short +++ "share *share) {" +:
+		"	if (share->dirty) {" +:
+		"		share->dirty--;" +:
+		"		return 1;" +:
+		"	}" +:
+		"	return 0;" +:
+		"}"
+
+instance zero CProg where zero = {bootstrap=rts, globals=[], funs=[]}
diff --git a/assignment-13/uFPL/C.dcl b/assignment-13/uFPL/C.dcl
new file mode 100644
index 0000000..f9d3595
--- /dev/null
+++ b/assignment-13/uFPL/C.dcl
@@ -0,0 +1,73 @@
+definition module uFPL.C
+
+from Data.Maybe import :: Maybe
+
+from uFPL.Arduino import :: Button
+from uFPL.Util import class print
+
+:: Signedness = Sig | Unsig
+
+:: CType
+	= CTChar Signedness
+	| CTBool
+	| CTInt Signedness
+	| CTLong Signedness
+	| CTVoid
+	| CTArray CType
+	| CTStruct String
+
+:: CExpr
+	= CEButton Button
+	| CEGlobal String
+	| CEInfix String CExpr CExpr
+	| CEApp String [CExpr]
+	| CEBool Bool
+	| CEInt Int
+	| CEChar Char
+	| CEBArray Int [Bool]
+	| CEIArray Int [Int]
+	| CEIf CExpr CExpr CExpr
+	| CERef CExpr
+	| CEDeref CExpr
+	| CEStruct [(String, CExpr)]
+
+:: CBody
+	= CBReturn (Maybe CExpr)
+	| CBIf CExpr CBody CBody
+	| CBWhile CExpr CBody
+	| CBAssign String CExpr
+	| CBSeq CBody CBody
+	| CBEmpty
+	| CBExpr CExpr
+
+(`seq`) infix 0 :: CBody CBody -> CBody
+
+:: CVar =
+	{ name  :: String
+	, type  :: CType
+	, value :: CExpr
+	}
+
+:: CFun =
+	{ params :: [(Int, CType)]
+	, body   :: CBody
+	, fresh  :: Int
+	, type   :: CType
+	, name   :: String
+	}
+
+:: CProg =
+	{ bootstrap :: String
+	, globals   :: [CVar]
+	, funs      :: [CFun]
+	}
+
+instance print Signedness
+instance print CType
+instance print CExpr
+instance print CBody
+instance print CVar
+instance print CFun
+instance print CProg
+
+combinePrograms :: CProg CProg -> CProg
diff --git a/assignment-13/uFPL/C.icl b/assignment-13/uFPL/C.icl
new file mode 100644
index 0000000..763774c
--- /dev/null
+++ b/assignment-13/uFPL/C.icl
@@ -0,0 +1,107 @@
+implementation module uFPL.C
+
+from StdFunc import id, o, twice
+import StdList
+import StdOrdList
+import StdString
+import StdTuple
+
+from Data.Func import $
+import Data.Generics.GenDefault
+import Data.List
+import Data.Maybe
+import Data.Tuple
+
+import uFPL.Arduino
+import uFPL.Util
+
+(`seq`) infix 0 :: CBody CBody -> CBody
+(`seq`) CBEmpty cb = cb
+(`seq`) cb CBEmpty = cb
+(`seq`) a b = CBSeq a b
+
+gDefault{|UNIT|} = UNIT
+gDefault{|RECORD|} f = RECORD f
+gDefault{|Bool|} = False
+gDefault{|Char|} = '\x00'
+gDefault{|Maybe|} _ = Nothing
+
+derive gDefault Button, Signedness, CType, CExpr, CBody, CFun
+
+instance print Signedness
+where
+	print Sig   = print "signed"
+	print Unsig = print "unsigned"
+
+instance print CType
+where
+	print (CTChar s)   = print s o print " char"
+	print CTBool       = print "bool"
+	print (CTInt s)    = print s o print " int"
+	print (CTLong s)   = print s o print " long"
+	print CTVoid       = print "void"
+	print (CTArray t)  = print "*" o print t
+	print (CTStruct s) = print "struct " o print s
+
+instance print (Int,CType) // Variable
+where
+	print (i,t) = print t o print " v" o print i
+
+instance print CExpr
+where
+	print (CEButton b) = print b
+	print (CEGlobal g) = print g
+	print (CEInfix op a b) = print "(" o print a o print ") " o print op o print " (" o print b o print ")"
+	print (CEApp f ps) = print f o print "(" o prsperse ", " ps o print ")"
+	print (CEBool b) = print (if b "true" "false")
+	print (CEInt i)  = print i
+	print (CEChar c) = print "'" o print (toString c) o print "'"
+	print (CEIf b t e) = print "(" o print b o print " ? " o print t o print " : " o print e o print ")"
+	print (CERef e) = print "&(" o print e o print ")"
+	print (CEDeref e) = print "*(" o print e o print ")"
+	print (CEStruct m) = print "{" o indent o nl o prsperse (print "," o nl) (map pr m) o unindent o nl o print "}"
+	where
+		pr :: (String, CExpr) -> String
+		pr (s, e) = "." +++ s +++ " = " +++ printToString e
+
+instance print CBody
+where
+	print (CBReturn Nothing)  = print "return;"
+	print (CBReturn (Just e)) = print "return " o print e o print ";"
+	print (CBIf c t e) = print "if (" o print c o print ") {" o indent o nl
+		o print t o unindent o nl
+		o print "} else {" o indent o nl
+		o print e o unindent o nl o print "}"
+	print (CBWhile e b) = print "while (" o print e o print ") {" o nl o print b o nl o print "}"
+	print (CBAssign v e) = print v o print " = " o print e o print ";"
+	print (CBSeq a b) = print a o nl o print b
+	print CBEmpty = id
+	print (CBExpr e) = print e o print ";"
+
+instance print CVar
+where
+	print v = print v.CVar.type o print " " o print v.CVar.name o print " = " o print v.value o print ";"
+
+instance print CFun
+where
+	print cf = print cf.CFun.type o print " " o print cf.CFun.name
+		o print "(" o prsperse ", " cf.params o print ") {" o indent o nl
+		o print cf.body o unindent o nl o print "}"
+
+instance print CProg
+where
+	print prog = print prog.bootstrap o twice nl
+		o prsperse (twice nl) prog.globals o twice nl
+		o prsperse (twice nl) prog.funs
+
+combinePrograms :: CProg CProg -> CProg
+combinePrograms a b =
+	{ bootstrap = if (a.bootstrap == b.bootstrap) id ((+++) a.bootstrap) b.bootstrap
+	, globals   = sortBy varLt $ nubBy varEq (a.globals ++ b.globals)
+	, funs      = sortBy funLt $ nubBy funEq (a.funs    ++ b.funs)
+	}
+where
+	varEq a b = a.CVar.name == b.CVar.name
+	varLt a b = a.CVar.name <  b.CVar.name
+	funEq a b = a.CFun.name == b.CFun.name
+	funLt a b = a.CFun.name <  b.CFun.name
diff --git a/assignment-13/uFPL/Util.dcl b/assignment-13/uFPL/Util.dcl
new file mode 100644
index 0000000..0370fc9
--- /dev/null
+++ b/assignment-13/uFPL/Util.dcl
@@ -0,0 +1,20 @@
+definition module uFPL.Util
+
+:: PrState =
+	{ indent :: Int
+	, output :: [String]
+	}
+
+class print a :: a -> PrState -> PrState
+
+printToString :: a -> String | print a
+
+instance print (PrState -> PrState)
+instance print String
+instance print Int
+
+nl :: PrState -> PrState
+indent :: PrState -> PrState
+unindent :: PrState -> PrState
+
+prsperse :: a [b] -> PrState -> PrState | print a & print b
diff --git a/assignment-13/uFPL/Util.icl b/assignment-13/uFPL/Util.icl
new file mode 100644
index 0000000..42f7c27
--- /dev/null
+++ b/assignment-13/uFPL/Util.icl
@@ -0,0 +1,38 @@
+implementation module uFPL.Util
+
+import StdClass
+from StdFunc import id, o
+import StdInt
+import StdList
+import StdOverloaded
+import StdString
+
+from Text import class Text(concat), instance Text String
+
+instance zero PrState
+where
+	zero =
+		{ indent = 0
+		, output = []
+		}
+
+printToString :: a -> String | print a
+printToString x = concat (print x zero).output
+
+instance print (PrState -> PrState) where print p = p
+instance print String where print s = \st -> {st & output=[s:st.output]}
+instance print Int    where print i = \st -> {st & output=[toString i:st.output]}
+
+nl :: PrState -> PrState
+nl st = {st & output=["\n":repeatn st.indent "\t"] ++ st.output}
+
+indent :: PrState -> PrState
+indent st = {st & indent=max 0 (st.indent - 1)}
+
+unindent :: PrState -> PrState
+unindent st = {st & indent=st.indent + 1}
+
+prsperse :: a [b] -> PrState -> PrState | print a & print b
+prsperse _ []     = id
+prsperse _ [x]    = print x
+prsperse g [x:xs] = print x o print g o prsperse g xs