mathista (empty) → 0.0.1
raw patch · 11 files changed
+745/−0 lines, 11 filesdep +MissingHdep +basedep +filepathsetup-changed
Dependencies added: MissingH, base, filepath, hspec, mathista, parsec, regex-compat, split
Files
- LICENSE +1/−0
- Setup.hs +2/−0
- mathista.cabal +56/−0
- src/Main.hs +59/−0
- src/Mathista/AST.hs +40/−0
- src/Mathista/Compiler.hs +168/−0
- src/Mathista/Generator/C.hs +76/−0
- src/Mathista/Generator/Matlab.hs +54/−0
- src/Mathista/IL.hs +17/−0
- src/Mathista/Parser.hs +271/−0
- tests/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,1 @@+Public Domain
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ mathista.cabal view
@@ -0,0 +1,56 @@+name: mathista+version: 0.0.1+synopsis: A programming language for numerical computing+description: Mathista is a simple programming language for+ numerical computing especially matrix manipulations.+homepage: https://github.com/nuta/mathista+license: PublicDomain+license-file: LICENSE+author: Seiya Nuta+maintainer: nuta@seiya.me+category: Language+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/nuta/mathista.git++executable mathista+ build-depends: base >= 4.7 && < 5,+ split,+ regex-compat,+ MissingH,+ parsec,+ filepath+ hs-source-dirs: src+ main-is: Main.hs+ ghc-options: -Wall+ default-language: Haskell2010++library+ build-depends: base,+ split,+ regex-compat,+ MissingH,+ parsec+ exposed-modules: Mathista.Parser,+ Mathista.Compiler,+ Mathista.AST,+ Mathista.IL,+ Mathista.Generator.C,+ Mathista.Generator.Matlab+ hs-source-dirs: src+ ghc-options: -Wall+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Spec.hs+ build-depends: base,+ mathista,+ parsec,+ hspec+ ghc-options: -Wall+ default-language: Haskell2010
+ src/Main.hs view
@@ -0,0 +1,59 @@+import System.Environment+import System.FilePath.Posix+import System.Exit+import Mathista.Parser+import Mathista.Compiler+import Mathista.Generator.C+import Mathista.Generator.Matlab+++version :: String+version = "version 0.1.0"++usage :: String+usage = unlines [+ "The Mathista compiler",+ "",+ "USAGE:",+ "",+ " mathista <command>",+ "",+ "COMMANDS:",+ "",+ " compile out src Compile a source file to the speicifed file type.",+ " verison Show version.",+ " help Show this message."+ ]+++main :: IO ()+main = do+ args <- getArgs+ let args' = drop 1 args+ let cmd = if length(args) > 0+ then args !! 0+ else ""+ case cmd of+ "compile" -> compileCommand args'+ "run" -> putStrLn "not supported yet" >> exitWith (ExitFailure 1)+ "version" -> putStrLn version+ _ -> putStrLn usage+++compileCommand :: [String] -> IO ()+compileCommand args+ | length(args) < 2 = putStrLn "mathista: specify a source and output file"+ | otherwise = do+ let out = args !! 0+ let src = args !! 1+ let name = takeBaseName out+ let generator = case takeExtension out of+ ".m" -> generate_matlab+ ".c" -> generate_c+ _ -> error "mathista: invalid extension of output file"+ source <- readFile src+ let ast = case parse_str source of+ Right s -> s+ Left _ -> error "mathista: failed to parse"+ let code = generator name (compile ast)+ writeFile out code
+ src/Mathista/AST.hs view
@@ -0,0 +1,40 @@+module Mathista.AST where+type Id = String++type Var = (Id, Maybe [(Expr, Maybe Expr)])++data Stmt+ = If [(Expr, [Stmt])] (Maybe [Stmt])+ | While Expr [Stmt]+ | For Id Integer Integer [Stmt]+ | Assign [Var] Expr+ | Return [Expr]+ | Break+ | Continue+ | FuncDecl Id [(Id, Id)] [Id] [Stmt]+ | ExprStmt Expr+ | DoNothing+ deriving (Show, Eq)++data Expr+ = VarRef Var+ | Add Expr Expr+ | Sub Expr Expr+ | Mul Expr Expr+ | Div Expr Expr+ | Eq Expr Expr+ | Neq Expr Expr+ | Gt Expr Expr+ | Gte Expr Expr+ | Lt Expr Expr+ | Lte Expr Expr+ | And Expr Expr+ | Or Expr Expr+ | Not Expr+ | Plus Expr+ | Minus Expr+ | FuncCall Id [Expr]+ | Number Double+ | Matrix [Expr]+ deriving (Show, Eq)+
+ src/Mathista/Compiler.hs view
@@ -0,0 +1,168 @@+module Mathista.Compiler (compile) where+import Mathista.AST+import Mathista.IL+++--+-- Helper functions+--++allocTmpId :: Int -> String+allocTmpId n = "$" ++ show n++--+-- Expressions+--+compileExpr :: Int -> Expr -> ([IL], Id)++-- Number literal+compileExpr c (Number n) =+ let val = allocTmpId c+ in ([ILLAssign val [] [1] [n]], val)++-- Matrix literal+compileExpr c (Matrix rows) =+ let+ length' :: [a] -> Integer+ length' = toInteger . length+ vec m x = case x of+ Number n -> m ++ [n]+ _ -> error "invalid element in a matrix literal"+ mtx m x = case x of+ Matrix mtx -> m ++ (foldl vec [] mtx)+ _ -> error "invalid element in a matrix literal"+ val = allocTmpId c+ dims = case (rows !! 0) of+ Matrix cols -> [length' rows, length' cols] -- 2d matrix+ Number _ -> [length' rows] -- vector+ _ -> error "invalid element in a matrix literal"+ elems = case (rows !! 0) of+ Matrix cols -> foldl mtx [] rows -- 2d matrix+ Number _ -> foldl vec [] rows -- vector+ _ -> error "invalid element in a matrix literal"+ in+ ([ILLAssign val [] [] []], val)++-- variable+compileExpr c (VarRef (name, Nothing)) = ([], name)+compileExpr c (VarRef (name, Just indexes)) = error "submatrix is not supported yet"++-- function call (with only one return value)+compileExpr c (FuncCall name argExprs) =+ let+ ret = allocTmpId c+ (ils, args) = compileExprs (c + 1) argExprs+ in+ (ils ++ [ILCall name args [ret]], ret)++-- unary operators+compileExpr c (Not expr) = compileUnaryExpr c "not" expr+compileExpr c (Plus expr) = compileUnaryExpr c "plus" expr+compileExpr c (Minus expr) = compileUnaryExpr c "minus" expr++-- binary operators+compileExpr c (Add lhs rhs) = compileBinaryExpr c "add" lhs rhs+compileExpr c (Sub lhs rhs) = compileBinaryExpr c "sub" lhs rhs+compileExpr c (Mul lhs rhs) = compileBinaryExpr c "mul" lhs rhs+compileExpr c (Div lhs rhs) = compileBinaryExpr c "div" lhs rhs+compileExpr c (Eq lhs rhs) = compileBinaryExpr c "eq" lhs rhs+compileExpr c (Neq lhs rhs) = compileBinaryExpr c "neq" lhs rhs+compileExpr c (Gt lhs rhs) = compileBinaryExpr c "gt" lhs rhs+compileExpr c (Gte lhs rhs) = compileBinaryExpr c "gte" lhs rhs+compileExpr c (Lt lhs rhs) = compileBinaryExpr c "lt" lhs rhs+compileExpr c (Lte lhs rhs) = compileBinaryExpr c "lte" lhs rhs+compileExpr c (And lhs rhs) = compileBinaryExpr c "and" lhs rhs+compileExpr c (Or lhs rhs) = compileBinaryExpr c "or" lhs rhs+++compileUnaryExpr c name expr =+ let+ val = allocTmpId c+ (ils, ret) = compileExpr (c + 1) expr+ in+ (ils ++ [ILCall name [ret] [val]], val)++compileBinaryExpr c name lhsExpr rhsExpr =+ let+ val = allocTmpId c+ (lhs_ils, lhs) = compileExpr (c + 1) lhsExpr+ (rhs_ils, rhs) = compileExpr (c + 2) rhsExpr+ in+ (lhs_ils ++ rhs_ils ++ [ILCall name [lhs, rhs] [val]], val)+++-- multiple expressions+compileExprs :: Int -> [Expr] -> ([IL], [Id])+compileExprs c_start exprs =+ let+ (_, ils, ids) = foldl f (c_start, [], []) exprs+ f (c, ils, ids) x =+ let (ils', ret) = compileExpr c x+ in (c + 1, ils ++ ils', ids ++ [ret])+ in+ (ils, ids)+++-- function call in an assign statement+compileAssignCall :: Id -> [Expr] -> [Id] -> [IL]+compileAssignCall name argExprs rets =+ let+ c = 0+ ret = allocTmpId c+ (ils, args) = compileExprs (c + 1) argExprs+ in+ ils ++ [ILCall name args rets]+++--+-- Statements+--+compileStmt :: Stmt -> [IL]+compileStmt (FuncDecl name args rets stmts) =+ [ILFuncDecl name args rets] ++ (compile stmts) ++ [ILEnd]++compileStmt (For var from to stmts) =+ error "unimplemented" -- TODO++compileStmt (While expr stmts) =+ let+ (cond_ils, cond_v) = compileExpr 0 expr+ in+ cond_ils ++ [ILWhile cond_v] ++ (compile stmts) ++ cond_ils ++ [ILEnd]++compileStmt (Assign vars expr) =+ case expr of+ FuncCall name argExprs -> compileAssignCall name argExprs (idsFromVars vars)+ where idsFromVars = map fst+ _ -> case vars of+ [v] -> let (ils, ret) = compileExpr 0 expr+ in ils ++ [ILAssign (fst v) [] [] ret]+ _ -> error "rhs of a multiple assignment must be a function call"++compileStmt (If ifblocks elseblock) =+ let+ else_ils = case elseblock of+ Just stmts -> [ILElse] ++ (compile stmts)+ Nothing -> []+ if_ils = let (ils, ret) = compileExpr 0 (fst (ifblocks !! 0))+ in ils ++ [ILIf ret] ++ compile (snd (ifblocks !! 0))+ elseif_ils = if length(ifblocks) > 1+ then error "elseif not supported yet"+ else []+ in+ if_ils ++ elseif_ils ++ else_ils ++ [ILEnd]++compileStmt (ExprStmt expr) = fst $ compileExpr 0 expr++compileStmt (Continue) = [ILContinue]++compileStmt (Break) = [ILBreak]++compileStmt (Return exprs) = + let (ils, ids) = compileExprs 0 exprs+ in ils ++ [ILReturn ids]++compileStmt (DoNothing) = []++compile :: [Stmt] -> [IL]+compile = foldl (\ils x -> ils ++ compileStmt x) []
+ src/Mathista/Generator/C.hs view
@@ -0,0 +1,76 @@+module Mathista.Generator.C where+import Mathista.IL+import Data.List+import Data.List.Utils+import Data.String.Utils+import Text.Regex++vstr s =+ if (startswith "$" s)+ then "mt_tmp_" ++ (replace "$" "" s)+ else "mt_val_" ++ s+len = show . length++generate :: IL -> String+generate (ILLAssign v indexes dims elems) =+ "mt_lassign(instance, &" +++ (vstr v) ++ ", " +++ (len dims) ++ ", {" ++ (join' dims) ++ "}, " +++ (len elems) ++ ", {" ++ (join' elems) ++ "}" +++ ");"+ where+ join' xs = intercalate ", " $ map show xs++generate (ILAssign to indexes dims from) =+ "mt_assign(instance, &" +++ (vstr to) ++ ", " +++ (len indexes) ++ ", {" ++ (join' indexes) ++ "}, " +++ (len dims) ++ ", {" ++ (join' dims) ++ "}, &" +++ (vstr from) ++ ");"+ where+ join' xs = intercalate ", " $ map show xs++generate (ILCall func args rets) =+ "mt_func_" ++ func ++ "(instance, " +++ (len args) ++ ", &" ++ (join' args) ++ ", " ++ -- FIXME: it won't works with no arg.+ (len rets) ++ ", &" ++ (join' rets) +++ ");"+ where+ join' xs = intercalate ", &" $ map vstr xs++generate (ILFuncDecl name args rets) = ""++ +generate (ILReturn vs) = error "unimplemented yet"+generate (ILIf v) = "if (mt_cond(" ++ (vstr v) ++ ")) {"+generate (ILElseIf v) = "} else if (mt_cond(" ++ (vstr v) ++ ")) {"+generate (ILElse) = "} else {"+generate (ILWhile v) = "while (mt_cond(" ++ (vstr v) ++ ")) {"+generate (ILBreak) = "break;"+generate (ILContinue) = "continue;"+generate ILEnd = "}"+++extract_vars :: String -> [String]+extract_vars s = uniq $ match_all "(mt_tmp_[0-9]+|mt_val_[a-zA-Z0-9_']+)" s+ where+ match_all re s = case (matchRegexAll (mkRegex re) s) of+ Just (_, _, rest, xs) -> xs ++ (match_all re rest)+ Nothing -> []++generate_c :: String -> [IL] -> String+generate_c name ils = header ++ main+ where+ _main = foldl (\s il -> s ++ generate il ++ "\n") [] ils+ body = ""+ vars = extract_vars (_main ++ body)+ join'' pre suf xs = intercalate "\n" $+ map (\x -> pre ++ x ++ suf) xs+ main = "void mt_main_" ++ name ++ "(mt_instance *instance) {\n" +++ join'' "mt_initval(instance, &" ");" vars +++ "\n" +++ _main +++ "}\n"+ header = "#include <mathista.h>\n" +++ join'' "static mt_value " ";" vars +++ "\n"
+ src/Mathista/Generator/Matlab.hs view
@@ -0,0 +1,54 @@+module Mathista.Generator.Matlab (generate_matlab) where+import Mathista.IL+import Data.List.Split+import Data.String.Utils+++vstr :: String -> String+vstr s =+ if (startswith "$" s)+ then "__" ++ (replace "$" "" s)+ else s++genRetVars :: Int -> [String]+genRetVars n = map (("__r" ++ ) . show) [0..(n - 1)]+++generate :: IL -> String+generate (ILLAssign v indexes dims elems) = vstr v ++ " = [" ++ elems' ++ "];"+ where+ elems' = if length dims >= 2+ then join ";" $ map (join " ") $+ chunksOf ((fromInteger (dims !! 1)) :: Int) (map show elems)+ else join " " (map show elems)++generate (ILAssign to indexes dims from) = (vstr to) ++ " = " ++ (vstr from) ++ ";" -- TODO: support indexes and dims++generate (ILCall func args rets) = (lhs rets) ++ "mt_" ++ func ++ "(" ++ (join ", " (map vstr args)) ++ ");"+ where+ lhs [] = ""+ lhs rs = "[" ++ (join ", " (map vstr rs)) ++ "] = "++generate (ILFuncDecl name args rets) = "function " ++ ret rets ++ " = " +++ name ++ "(" ++ (join ", " (map fst args)) ++ ")"+ where+ ret xs+ | length(xs) == 0 = ""+ | length(xs) == 1 = "__r0"+ | otherwise = "[" ++ (join ", " (genRetVars (length xs))) ++ "]"+++generate (ILReturn vs) = join "\n" $ zipWith f rs vs+ where+ rs = genRetVars (length vs)+ f r v = r ++ " = " ++ (vstr v)+generate (ILIf v) = "if " ++ (vstr v) ++ " != 0"+generate (ILElseIf v) = "elseif " ++ (vstr v) ++ " != 0" +generate (ILElse) = "else"+generate (ILWhile v) = "while " ++ (vstr v) ++ " != 0"+generate (ILBreak) = "break"+generate (ILContinue) = "continue"+generate ILEnd = "end"++generate_matlab :: String -> [IL] -> String+generate_matlab name ils = foldl (\s il -> s ++ generate il ++ "\n") [] ils
+ src/Mathista/IL.hs view
@@ -0,0 +1,17 @@+module Mathista.IL where+import Mathista.AST++data IL+ = ILFuncDecl String [(Id, Id)] [Id]+ | ILCall String [Id] [Id]+ | ILReturn [Id]+ | ILLAssign Id [Id] [Integer] [Double] -- Vto, indexes, dims, elements+ | ILAssign Id [Id] [Id] Id -- Vto, indexes, dims, Vform+ | ILIf Id+ | ILElseIf Id+ | ILElse+ | ILWhile Id+ | ILBreak+ | ILContinue+ | ILEnd+ deriving (Eq, Show)
+ src/Mathista/Parser.hs view
@@ -0,0 +1,271 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-missing-signatures #-}++module Mathista.Parser (parse_str) where+import Data.List.Split hiding (sepBy)+import Data.String.Utils+import Text.Regex+import Text.Parsec+import Text.Parsec.Expr+import Text.Parsec.String+import Text.Parsec.Language (emptyDef)+import qualified Text.Parsec.Token as Token+import Mathista.AST+++lexer :: Token.TokenParser ()+lexer = Token.makeTokenParser emptyDef+ { Token.commentLine = "//"+ , Token.reservedNames = ["if", "then", "else", "elseif", "function",+ "end", "for", "break", "continue", "return",+ "while", "to", "step"]+ , Token.caseSensitive = False+ , Token.identStart = letter+ , Token.identLetter = alphaNum <|> char '_' <|> char '\''+ , Token.reservedOpNames = ["+", "-", "*", "/", "==", "!=", ">", "<",+ ">=", "<=", "and", "or", "not", "=", "@"]+ }++semi = Token.semi lexer+float = Token.float lexer+symbol = Token.symbol lexer+parens = Token.parens lexer+comma = Token.comma lexer+identifier = Token.identifier lexer+integer = Token.integer lexer+reserved = Token.reserved lexer+reservedOp = Token.reservedOp lexer+whiteSpace = Token.whiteSpace lexer+++--+-- Var+--+var :: Parser Var+var = do+ name <- identifier+ is <- optionMaybe indexes+ return (name, is)+ where indexes = do+ char '['+ is <- index `sepBy` comma+ char ']'+ return is+ index = do+ st <- choice [expr, return $ Number $ 0]+ end <- optionMaybe $ do+ char ':'+ end <- choice [expr, return $ Number $ -1]+ return end+ return (st, end)+ ++--+-- Statements+--+stmt :: Parser Stmt+stmt = try assignStmt+ <|> debugprintStmt+ <|> ifStmt+ <|> whileStmt+ <|> forStmt+ <|> breakStmt+ <|> continueStmt+ <|> returnStmt+ <|> funcDeclStmt+ <|> exprStmt+ <?> "stmt"++stmts :: Parser [Stmt]+stmts = many stmt++assignStmt :: Parser Stmt+assignStmt = do+ lhs <- var `sepBy` comma+ whiteSpace+ reservedOp "="+ e <- expr+ semi+ return $ Assign lhs e++debugprintStmt :: Parser Stmt+debugprintStmt = do+ reservedOp "@"+ e <- expr+ semi+ return $ ExprStmt (FuncCall "debugprint" [e])++ifStmt :: Parser Stmt+ifStmt = do+ between (reserved "if") (reserved "end") inIfBlock+ where+ inIfBlock = do+ ifBlock <- block+ elseifBlocks <- many elseifStmt+ elseBlock <- optionMaybe elseStmt+ return $ If (ifBlock:elseifBlocks) elseBlock+ elseifStmt = reserved "elseif" >> block+ elseStmt = reserved "else" >> stmts+ block = do+ e <- expr+ whiteSpace+ reserved "then"+ st <- stmts+ return (e, st)++whileStmt :: Parser Stmt+whileStmt = do+ reserved "while"+ e <- expr+ whiteSpace+ st <- between (reserved "then") (reserved "end") stmts+ return $ While e st++forStmt :: Parser Stmt+forStmt = do+ reserved "for"+ v <- identifier+ reservedOp "="+ from <- integer+ char ':'+ to <- integer+ whiteSpace+ st <- between (reserved "then") (reserved "end") stmts+ return $ For v from to st++breakStmt :: Parser Stmt+breakStmt = do+ reserved "break"+ return $ Break++continueStmt :: Parser Stmt+continueStmt = do+ reserved "continue"+ return $ Continue++returnStmt :: Parser Stmt+returnStmt = do+ reserved "return"+ e <- expr `sepBy` comma+ return $ Return e++exprStmt :: Parser Stmt+exprStmt = do+ e <- optionMaybe expr+ semi+ case e of+ Just x -> return $ ExprStmt x+ Nothing -> return $ DoNothing -- semicolon only lines++arg :: Parser (Id, Id)+arg = do+ name <- identifier+ symbol ":"+ type_ <- identifier+ return (name, type_)++funcDeclStmt = do+ reserved "function"+ name <- identifier+ args <- parens (arg `sepBy` comma)+ symbol "->"+ returns <- parens (identifier `sepBy` comma)+ st <- stmts+ reserved "end"+ return $ FuncDecl name args returns st+++--+-- Expressions+--++integerNumber :: Parser Expr+integerNumber = do+ ds <- many1 digit+ return $ Number (read ds :: Double)++floatNumber :: Parser Expr+floatNumber = do+ n <- float+ return $ Number n++number :: Parser Expr+number = try floatNumber+ <|> integerNumber++matrixElems :: Parser Expr+matrixElems = do+ elems <- literal `sepBy` whiteSpace+ return $ Matrix elems++matrix1d :: Parser Expr+matrix1d = do+ char '['+ elems <- matrixElems+ char ']'+ return elems++matrix2d :: Parser Expr+matrix2d = do+ char '['+ rows <- matrixElems `sepBy` semi+ char ']'+ return $ Matrix rows++matrix :: Parser Expr+matrix = try matrix1d+ <|> matrix2d++literal :: Parser Expr+literal = try number+ <|> matrix++funcCall :: Parser Expr+funcCall = do+ name <- identifier+ exprs <- parens (expr `sepBy` comma)+ return $ FuncCall name exprs++varRef :: Parser Expr+varRef = do + v <- var+ return $ VarRef v+++term = parens expr+ <|> try funcCall+ <|> literal+ <|> varRef+ <?> "term"++ops = [ [unaryOp "-" Minus, unaryOp "+" Plus ]+ , [unaryOp "not" Not]+ , [binaryOp "*" Mul AssocLeft, binaryOp "/" Div AssocLeft ]+ , [binaryOp "+" Add AssocLeft, binaryOp "-" Sub AssocLeft ]+ , [binaryOp "==" Eq AssocLeft, binaryOp "!=" Neq AssocLeft ]+ , [binaryOp ">" Gt AssocLeft, binaryOp "<" Lt AssocLeft ]+ , [binaryOp ">=" Gte AssocLeft, binaryOp "<=" Lte AssocLeft ]+ , [binaryOp "and" And AssocLeft, binaryOp "or" Or AssocLeft ]+ ]+ where+ unaryOp name f = Prefix (do{ reservedOp name; return f })+ binaryOp name f assoc = Infix (do{ reservedOp name; return f }) assoc++expr :: Parser Expr+expr = buildExpressionParser ops term+++--+-- A full featured parser+--+program :: Parser [Stmt]+program = do+ whiteSpace+ decls <- many stmt+ eof+ return decls++parse_str :: [Char] -> Either ParseError [Stmt]+parse_str s = parse program "" s'+ where+ stripComment x = subRegex (mkRegex "-- .*$") x ""+ s' = join "\n" $ map stripComment $ splitOn "\n" s
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}