aboutsummaryrefslogtreecommitdiff
path: root/Sjit
diff options
context:
space:
mode:
authorCamil Staps2018-12-24 23:54:26 +0100
committerCamil Staps2018-12-24 23:54:26 +0100
commit391c80e4df40ddc21641aa06aa0224460a53ba90 (patch)
tree617a099611e210b5290111a7ac4c44ef06a2842d /Sjit
parentDivide in modules (diff)
Add interactive shell
Diffstat (limited to 'Sjit')
-rw-r--r--Sjit/Compile.dcl4
-rw-r--r--Sjit/Compile.icl54
-rw-r--r--Sjit/Syntax.dcl5
-rw-r--r--Sjit/Syntax.icl130
4 files changed, 167 insertions, 26 deletions
diff --git a/Sjit/Compile.dcl b/Sjit/Compile.dcl
index 4bc1ed5..166b5c4 100644
--- a/Sjit/Compile.dcl
+++ b/Sjit/Compile.dcl
@@ -1,5 +1,6 @@
definition module Sjit.Compile
+from Data.Either import :: Either
from Data.Map import :: Map
from Data.Maybe import :: Maybe
from Sjit.Syntax import :: Function
@@ -40,5 +41,4 @@ from Sjit.Syntax import :: Function
appendProgram :: !Bool !Program !JITState -> JITState
bootstrap :: (!Program, !CompileState)
-compile :: !Function !CompileState -> CompileState
-compile_all :: !(Maybe CompileState) ![Function] -> CompileState
+compile :: !Function !CompileState -> Either String CompileState
diff --git a/Sjit/Compile.icl b/Sjit/Compile.icl
index 31b6523..5e4cef5 100644
--- a/Sjit/Compile.icl
+++ b/Sjit/Compile.icl
@@ -5,6 +5,9 @@ import StdGeneric
import StdMaybe
import StdOverloadedList
+import Control.Applicative
+import Control.Monad
+import Data.Either
from Data.Func import mapSt, $
from Data.Map import :: Map(..), get, put, newMap, fromList
@@ -80,39 +83,42 @@ where
ccall init_jit "II:Vpp"
}
-compile :: !Function !CompileState -> CompileState
+compile :: !Function !CompileState -> Either String CompileState
compile f cs
# cs & funs = put f.fun_name cs.pc cs.funs
# vars = cs.vars
# cs & vars = foldr (uncurry put) cs.vars [(v,sp) \\ v <- f.fun_args & sp <- [cs.sp+1..]]
-# (is,cs) = expr f.fun_expr cs
-# is = {i \\ i <- reverse [Ret:Put (max 1 (length f.fun_args)+1):is]}
-=
- { cs
- & vars = vars
- , pc = cs.pc+2
- , blocks = cs.blocks ++| [!is!]
- , jitst = appendProgram (f.fun_name == "main") is cs.jitst
- }
+= case expr f.fun_expr cs of
+ Left e -> Left e
+ Right (is,cs)
+ # is = {i \\ i <- reverse [Ret:Put (max 1 (length f.fun_args)+1):is]}
+ -> Right
+ { cs
+ & vars = vars
+ , pc = cs.pc+2
+ , blocks = cs.blocks ++| [!is!]
+ , jitst = appendProgram (f.fun_name == "main") is cs.jitst
+ }
where
- expr :: !Expr !CompileState -> (![Instr], !CompileState)
- expr (Int i) cs = ([PushI i], {cs & sp=cs.sp+1, pc=cs.pc+1})
+ expr :: !Expr !CompileState -> Either String (![Instr], !CompileState)
+ expr (Int i) cs = Right ([PushI i], {cs & sp=cs.sp+1, pc=cs.pc+1})
expr (Var v) cs = case get v cs.vars of
- Just i -> ([PushRef (i-cs.sp)], {cs & sp=cs.sp+1, pc=cs.pc+1})
- Nothing -> abort "undefined variable\n"
+ Just i -> Right ([PushRef (i-cs.sp)], {cs & sp=cs.sp+1, pc=cs.pc+1})
+ Nothing -> Left ("undefined variable '" +++ v +++ "'")
expr (App f args) cs
# args = if (args=:[]) [Int 0] args
- # (iss,cs) = mapSt expr args {cs & sp=cs.sp+1}
- = case get f cs.funs of
- Just f -> ([Pop (length args-1):Call f:flatten iss], {cs & sp=cs.sp+2-length args, pc=cs.pc+2})
- Nothing -> abort "undefined function\n"
+ = case mapStM expr args {cs & sp=cs.sp+1} of
+ Left e -> Left e
+ Right (iss,cs) -> case get f cs.funs of
+ Just f -> Right
+ ( [Pop (length args-1):Call f:flatten iss]
+ , {cs & sp=cs.sp+2-length args, pc=cs.pc+2}
+ )
+ Nothing -> Left ("undefined function '" +++ toString f +++ "'")
-compile_all :: !(Maybe CompileState) ![Function] -> CompileState
-compile_all mcs funs
-# cs = case mcs of
- Just cs -> cs
- Nothing -> snd bootstrap
-= foldl (flip compile) cs funs
+ mapStM :: !(a st -> m (b, st)) ![a] !st -> m ([b], st) | Monad m
+ mapStM _ [] st = pure ([], st)
+ mapStM f [x:xs] st = f x st >>= \(y,st) -> mapStM f xs st >>= \(ys,st) -> pure ([y:ys],st)
generic gEncodedSize a :: !a -> Int
gEncodedSize{|Int|} _ = 1
diff --git a/Sjit/Syntax.dcl b/Sjit/Syntax.dcl
index a289b5a..44adbfa 100644
--- a/Sjit/Syntax.dcl
+++ b/Sjit/Syntax.dcl
@@ -1,5 +1,7 @@
definition module Sjit.Syntax
+from Data.Either import :: Either
+
:: Expr
= Int !Int
| Var !String
@@ -10,3 +12,6 @@ definition module Sjit.Syntax
, fun_args :: ![String]
, fun_expr :: !Expr
}
+
+parse_function :: !String -> Either String Function
+parse_interactive_line :: !String -> Either String Function
diff --git a/Sjit/Syntax.icl b/Sjit/Syntax.icl
index e512e0c..ae75087 100644
--- a/Sjit/Syntax.icl
+++ b/Sjit/Syntax.icl
@@ -1 +1,131 @@
implementation module Sjit.Syntax
+
+import StdEnv
+
+import Control.Applicative
+import Control.Monad
+import Data.Either
+from Data.Func import $
+import Data.Functor
+import Data.GenEq
+import Text.Parsers.Simple.Core
+
+:: Token
+ = TIdent !String
+ | TInt !Int
+
+ | TEq
+ | TComma
+
+ | TParenOpen
+ | TParenClose
+
+derive gEq Token
+instance == Token where == a b = a === b
+
+instance toString Token
+where
+ toString t = case t of
+ TIdent s -> "'" +++ s +++ "'"
+ TInt n -> toString n
+ TEq -> "="
+ TComma -> ","
+ TParenOpen -> "("
+ TParenClose -> ")"
+
+lex :: !String -> Either String [Token]
+lex s = reverse <$> lex [] 0 (size s) s
+where
+ lex :: ![Token] !Int !Int !String -> Either String [Token]
+ lex tks i e s | i >= e = Right tks
+ lex tks i e s = case s.[i] of
+ w | isSpace w
+ -> lex tks (i+1) e s
+
+ n | isIdent n
+ # (i,n) = readIdent isIdent [] i e s
+ -> lex [TIdent n:tks] i e s
+
+ n | isFunnyIdent n
+ # (i,n) = readIdent isFunnyIdent [] i e s
+ -> lex [TIdent n: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
+
+ c -> Left ("Unexpected character '" +++ {c} +++ "'")
+
+ isIdent :: !Char -> Bool
+ isIdent c = isAlpha c || c == '_'
+
+ isFunnyIdent :: !Char -> Bool
+ isFunnyIdent c = isMember c ['+-*/']
+
+ readIdent :: !(Char -> Bool) ![Char] !Int !Int !String -> (!Int, !String)
+ readIdent ok cs i e s
+ | i >= e = (i,{c \\ c <- reverse cs})
+ # c = s.[i]
+ | ok c = readIdent ok [c:cs] (i+1) e s
+ | otherwise = (i,{c \\ c <- reverse cs})
+
+ readInt :: ![Char] !Int !Int !String -> (!Int, !Int)
+ readInt cs i e s
+ | i >= e = (i,toInt {#c \\ c <- reverse cs})
+ # c = s.[i]
+ | isDigit c = readInt [c:cs] (i+1) e s
+ | otherwise = (i,toInt {#c \\ c <- reverse cs})
+
+function :: Parser Token Function
+function =:
+ liftM3 make_fun ident (many arg) (pToken TEq *> expr)
+where
+ make_fun :: !String ![String] !Expr -> Function
+ make_fun name args expr = {fun_name=name, fun_args=args, fun_expr=expr}
+
+expr :: Parser Token Expr
+expr
+ = leftAssoc (tok "+" <|> tok "-")
+ $ leftAssoc (tok "*" <|> tok "/")
+ $ noInfix
+where
+ tok :: !String -> Parser Token String
+ tok s = pToken (TIdent s) $> s
+
+ leftAssoc :: !(Parser Token String) !(Parser Token Expr) -> Parser Token Expr
+ leftAssoc opp exprp = exprp >>= \e1 ->
+ many (opp >>= \op -> exprp >>= \e -> pure (op,e)) >>=
+ foldM (\e (op,e2) -> pure $ App op [e,e2]) e1
+
+ noInfix :: Parser Token Expr
+ noInfix =
+ liftM2 App ident (pToken TParenOpen *> pSepBy expr (pToken TComma) <* pToken TParenClose)
+ <|> Var <$> ident
+ <|> Int <$> int
+ <|> (pToken TParenOpen *> expr <* pToken TParenClose)
+
+ident :: Parser Token String
+ident =: (\(TIdent n) -> n) <$> pSatisfy (\t->t=:TIdent _)
+
+arg :: Parser Token String
+arg =: ident
+
+int :: Parser Token Int
+int =: (\(TInt n) -> n) <$> pSatisfy (\t->t=:TInt _)
+
+parse_function :: !String -> Either String Function
+parse_function s = lex s >>= \tks -> case parse function tks of
+ Right f -> Right f
+ Left _ -> Left "parsing failed"
+
+parse_interactive_line :: !String -> Either String Function
+parse_interactive_line s = lex s >>= \tks -> case parse function tks of
+ Right f -> Right f
+ Left _ -> case parse expr tks of
+ Right e -> Right {fun_name="main", fun_args=[], fun_expr=e}
+ Left _ -> Left "parsing failed"