diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,1 @@ +Public Domain diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/mathista.cabal b/mathista.cabal new file mode 100644 --- /dev/null +++ b/mathista.cabal @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 ", + "", + "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 diff --git a/src/Mathista/AST.hs b/src/Mathista/AST.hs new file mode 100644 --- /dev/null +++ b/src/Mathista/AST.hs @@ -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) + diff --git a/src/Mathista/Compiler.hs b/src/Mathista/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Mathista/Compiler.hs @@ -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) [] diff --git a/src/Mathista/Generator/C.hs b/src/Mathista/Generator/C.hs new file mode 100644 --- /dev/null +++ b/src/Mathista/Generator/C.hs @@ -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 \n" ++ + join'' "static mt_value " ";" vars ++ + "\n" diff --git a/src/Mathista/Generator/Matlab.hs b/src/Mathista/Generator/Matlab.hs new file mode 100644 --- /dev/null +++ b/src/Mathista/Generator/Matlab.hs @@ -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 diff --git a/src/Mathista/IL.hs b/src/Mathista/IL.hs new file mode 100644 --- /dev/null +++ b/src/Mathista/IL.hs @@ -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) diff --git a/src/Mathista/Parser.hs b/src/Mathista/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Mathista/Parser.hs @@ -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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}