Add comparisons; tak example

5 files changed, 58 insertions, 76 deletions

diff --git a/Sjit/Compile.dcl b/Sjit/Compile.dcl
index d373e42..e630178 100644
--- a/Sjit/Compile.dcl
+++ b/Sjit/Compile.dcl
@@ -13,17 +13,24 @@ from Sjit.Syntax import :: Function
 
 	| Call !Int
 	| Jmp !Int
-	| JmpTrue !Int
+	| JmpCond !Cond !Int
 	| Ret
 	| Halt
 
-	| IAdd
-	| IMul
-	| ISub
-	| IDiv
+	| Op !Op
 
 	| PlaceHolder !Int !Int // only used during compilation
 
+:: Op
+	= OAdd | OMul
+	| OSub | ODiv
+
+:: Cond
+	= CEq | CNe
+	| CLt | CLe
+	| CGt | CGe
+	| CTrue
+
 :: Program :== {!Instr}
 
 :: CompileState =
diff --git a/Sjit/Compile.icl b/Sjit/Compile.icl
index 527676f..b5ea1bf 100644
--- a/Sjit/Compile.icl
+++ b/Sjit/Compile.icl
@@ -98,13 +98,10 @@ where
 			Pop n           -> 0-n
 			Call _          ->   0
 			Jmp _           ->   0
-			JmpTrue _       ->   0
+			JmpCond c _     -> if (c=:CTrue) -1 -2
 			Ret             ->  -1
 			Halt            ->  -2
-			IAdd            ->  -1
-			IMul            ->  -1
-			ISub            ->  -1
-			IDiv            ->  -1
+			Op _            ->  -1
 			PlaceHolder _ n ->   n
 
 reserve :: !Int !CompileState -> m (!Int, !CompileState) | Monad m
@@ -152,20 +149,38 @@ where
 	# args = if (args=:[]) [Int 0] args
 	= foldM (flip expr) cs (reverse args) >>= \cs -> case get f cs.funs of
 		Nothing -> case f of
-			"+" -> gen [IAdd] cs
-			"-" -> gen [ISub] cs
-			"*" -> gen [IMul] cs
-			"/" -> gen [IDiv] cs
-			_ -> Left ("undefined function '" +++ toString f +++ "'")
+			"+" -> gen [Op OAdd] cs
+			"-" -> gen [Op OSub] cs
+			"*" -> gen [Op OMul] cs
+			"/" -> gen [Op ODiv] cs
+			_   -> Left ("undefined function '" +++ toString f +++ "'")
 		Just f -> case length args of
 			1 -> gen [Call f] cs
 			n -> gen [Pop (n-1),Call f] cs
+	expr (If (App cond [a,b]) t e) cs | isJust condop =
+		expr a cs >>=
+		expr b >>=
+		reserve -2 >>= \(jmpcond,cs=:{sp=orgsp}) ->
+		expr e cs >>=
+		reserve 0 >>= \(jmpend,cs) ->
+		fillPlaceHolder jmpcond (JmpCond (fromJust condop) cs.pc) {cs & sp=orgsp} >>=
+		expr t >>= \cs ->
+		fillPlaceHolder jmpend (Jmp cs.pc) cs
+	where
+		condop = case cond of
+			"==" -> Just CEq
+			"<>" -> Just CNe
+			"<"  -> Just CLt
+			"<=" -> Just CLe
+			">"  -> Just CGt
+			">=" -> Just CGe
+			_    -> Nothing
 	expr (If b t e) cs =
 		expr b cs >>=
-		reserve -1 >>= \(jmptrue,cs=:{sp=orgsp}) ->
+		reserve -1 >>= \(jmpcond,cs=:{sp=orgsp}) ->
 		expr e cs >>=
 		reserve 0 >>= \(jmpend,cs) ->
-		fillPlaceHolder jmptrue (JmpTrue cs.pc) {cs & sp=orgsp} >>=
+		fillPlaceHolder jmpcond (JmpCond CTrue cs.pc) {cs & sp=orgsp} >>=
 		expr t >>= \cs ->
 		fillPlaceHolder jmpend (Jmp cs.pc) cs
 
@@ -198,8 +213,8 @@ gEncode{|EITHER|} _ fr (RIGHT r) i arr = fr r i arr
 gEncode{|CONS of {gcd_index}|} fx (CONS x) i arr = fx x (i+1) {arr & [i]=gcd_index}
 gEncode{|OBJECT|} fx (OBJECT x) i arr = fx x i arr
 
-derive gEncodedSize Instr
-derive gEncode Instr
+derive gEncodedSize Cond, Op, Instr
+derive gEncode Cond, Op, Instr
 
 encode :: !a -> *{#Int} | gEncodedSize{|*|}, gEncode{|*|} a
 encode x
diff --git a/Sjit/Run.dcl b/Sjit/Run.dcl
index aff22fc..371f4f5 100644
--- a/Sjit/Run.dcl
+++ b/Sjit/Run.dcl
@@ -2,5 +2,4 @@ definition module Sjit.Run
 
 from Sjit.Compile import :: CompileState
 
-interpret :: !CompileState -> Int
 exec :: !CompileState -> Int
diff --git a/Sjit/Run.icl b/Sjit/Run.icl
index ad03e02..8bd3972 100644
--- a/Sjit/Run.icl
+++ b/Sjit/Run.icl
@@ -7,57 +7,6 @@ from Data.Map import :: Map(..), get
 
 import Sjit.Compile
 
-interpret :: !CompileState -> Int
-interpret cs = exec 0 []
-where
-	prog = get_program cs
-	sz = size prog
-
-	exec :: !Int ![Int] -> Int
-	exec i stack
-	| i < 0 || i >= sz = abort "out of bounds\n"
-	| otherwise = case prog.[i] of
-		PushI n   -> exec (i+1) [n:stack]
-		PushRef r -> exec (i+1) [stack!!r:stack]
-		Put n     -> case stack of
-			[val:stack] -> exec (i+1) (take (n-1) stack ++ [val:drop n stack])
-		Pop n     -> exec (i+1) (drop n stack)
-		Call f    -> exec f [i+1:stack]
-		Jmp f     -> exec f stack
-		JmpTrue f -> case stack of
-			[0:stack] -> exec (i+1) stack
-			[_:stack] -> exec f stack
-		Ret -> case stack of
-			[ret:stack] -> exec ret stack
-		Halt -> case stack of
-			[r] -> r
-			_   -> abort (toString (length stack) +++ " values left on stack\n")
-
-		IAdd -> case stack of
-			[a:b:stack] -> exec (i+1) [a+b:stack]
-		IMul -> case stack of
-			[a:b:stack] -> exec (i+1) [a*b:stack]
-		ISub -> case stack of
-			[a:b:stack] -> exec (i+1) [a-b:stack]
-		IDiv -> case stack of
-			[a:b:stack] -> exec (i+1) [a/b:stack]
-
-	get_program :: !CompileState -> Program
-	get_program cs
-	# prog = loop 0 cs.blocks (createArray (sum [size b \\ b <|- cs.blocks]) Halt)
-	# prog & [1] = Call (fromJust (get "main" cs.funs))
-	= prog
-	where
-		loop :: !Int ![!Program!] !*Program -> .Program
-		loop i [!b:bs!] prog
-		# (i,prog) = copy i 0 (size b-1) b prog
-		= loop i bs prog
-		where
-			copy :: !Int !Int !Int !Program !*Program -> *(!Int, !*Program)
-			copy i _ -1 _ prog = (i, prog)
-			copy i bi n b prog = copy (i+1) (bi+1) (n-1) b {prog & [i]=b.[bi]}
-		loop _ [!!] prog = prog
-
 exec :: !CompileState -> Int
 exec {jitst} = exec jitst.code_start
 where
diff --git a/Sjit/Syntax.icl b/Sjit/Syntax.icl
index 90aeb39..e382696 100644
--- a/Sjit/Syntax.icl
+++ b/Sjit/Syntax.icl
@@ -5,9 +5,12 @@ import StdEnv
 import Control.Applicative
 import Control.Monad
 import Data.Either
+from Data.Foldable import class Foldable(foldr1)
 from Data.Func import $
 import Data.Functor
 import Data.GenEq
+from Data.List import instance Foldable []
+import Data.Maybe
 import Text.Parsers.Simple.Core
 
 :: Token
@@ -60,13 +63,15 @@ where
 
 		n | isFunnyIdent n
 			# (i,n) = readIdent isFunnyIdent [] i e s
-			-> lex [TIdent n:tks] i e s
+			# tk = case n of
+				"=" -> TEq
+				n   -> TIdent n
+			-> lex [tk:tks] i e s
 
 		n | isDigit n
 			# (i,n) = readInt [] i e s
 			-> lex [TInt n:tks] i e s
 
-		'=' -> lex [TEq:        tks] (i+1) e s
 		',' -> lex [TComma:     tks] (i+1) e s
 		'(' -> lex [TParenOpen: tks] (i+1) e s
 		')' -> lex [TParenClose:tks] (i+1) e s
@@ -77,7 +82,7 @@ where
 	isIdent c = isAlpha c || c == '_'
 
 	isFunnyIdent :: !Char -> Bool
-	isFunnyIdent c = isMember c ['+-*/']
+	isFunnyIdent c = isMember c ['+-*/<>=']
 
 	readIdent :: !(Char -> Bool) ![Char] !Int !Int !String -> (!Int, !String)
 	readIdent ok cs i e s
@@ -102,12 +107,19 @@ where
 
 expr :: Parser Token Expr
 expr
-	= leftAssoc (tok "+" <|> tok "-")
-	$ leftAssoc (tok "*" <|> tok "/")
+	= rightAssoc (toks ["==","<>","<","<=",">",">="])
+	$ leftAssoc (toks ["+","-"])
+	$ leftAssoc (toks ["*","/"])
 	$ noInfix
 where
 	tok :: !String -> Parser Token String
 	tok s = pToken (TIdent s) $> s
+	toks = foldr1 (<|>) o map tok
+
+	rightAssoc :: !(Parser Token String) !(Parser Token Expr) -> Parser Token Expr
+	rightAssoc opp exprp = exprp >>= \e1 ->
+		optional (opp >>= \op -> rightAssoc opp exprp >>= \e -> pure (op,e)) >>=
+		pure o maybe e1 (\(op,e2) -> App op [e1,e2])
 
 	leftAssoc :: !(Parser Token String) !(Parser Token Expr) -> Parser Token Expr
 	leftAssoc opp exprp = exprp >>= \e1 ->