├── Abstract.hs ├── Definition.hs ├── Grammar.hs ├── Interpret.hs ├── LICENSE ├── Main.hs ├── Parse.hs ├── README.md ├── Runtime.hs ├── Storage.hs ├── Type.hs ├── UnsupportedFeature.txt ├── Utils.hs └── Value.hs /Abstract.hs: -------------------------------------------------------------------------------- 1 | module Abstract( 2 | makeIf, 3 | makeLoop, 4 | makeJump 5 | )where 6 | 7 | import Program 8 | 9 | makeIf :: Call -> (Call, Call) -> Call 10 | makeIf guard (pos, neg) = Call "void" f [(0, guard)] where 11 | f :: Ins 12 | f (State _ v c) [condition] = 13 | return (case convert condition "bool" of 14 | Value "bool" "true" -> State pos v c 15 | _ -> State neg v c, nullVal) 16 | 17 | convert :: Value -> Type -> Value 18 | convert = undefined 19 | 20 | nullVal :: Value 21 | nullVal = undefined 22 | 23 | makeLoop :: Call -> Call -> Call -> Call 24 | makeLoop guard body esc = makeIf guard (makeLoop guard body esc, esc) 25 | 26 | makeJump :: Call -> Call 27 | makeJump target = Call "void" (\(State _ v c) _ -> return (State target v c, nullVal)) [] 28 | -------------------------------------------------------------------------------- /Definition.hs: -------------------------------------------------------------------------------- 1 | module Definition( 2 | Identifier, 3 | Literal, 4 | Id 5 | )where 6 | 7 | type Identifier = String 8 | type Literal = String 9 | type Id = Integer 10 | -------------------------------------------------------------------------------- /Grammar.hs: -------------------------------------------------------------------------------- 1 | module Grammar( 2 | Exp(..), 3 | VarInit(..), 4 | VariableDeclaration(..), 5 | FunctionDefinition(..), 6 | StructDefinition(..), 7 | Jump(..), 8 | Program(..), 9 | Structure(..), 10 | )where 11 | 12 | import Definition 13 | import Type 14 | 15 | data Exp = Exp Identifier [Exp] | Constant Literal deriving Show 16 | data VarInit = InitList [Exp] | InitExp Exp deriving Show 17 | data VariableDeclaration = VarDecl Type Identifier (Maybe VarInit) | ArrDecl Type Identifier Exp (Maybe VarInit) deriving Show 18 | data FunctionDefinition = FuncDef Identifier Type [(Type, Identifier)] [Structure] deriving Show 19 | data StructDefinition = StructDef Identifier [(Type, Identifier)] deriving Show 20 | data Jump = Return Exp | Break | Continue deriving Show 21 | data Program = Program [FunctionDefinition] [StructDefinition] [VariableDeclaration] deriving Show 22 | 23 | data Structure = 24 | IfBlock Exp [Structure] [Structure] | 25 | SwitchBlock Exp [([Exp], [Structure])] | 26 | WhileBlock Exp [Structure] | 27 | DoWhileBlock Exp [Structure] | 28 | ForBlock Exp Exp Exp [Structure] | 29 | Expression Exp | 30 | Declaration VariableDeclaration | 31 | UCJump Jump | 32 | LocalStructDefinition StructDefinition | 33 | DarkMagic Identifier 34 | deriving Show 35 | 36 | -------------------------------------------------------------------------------- /Interpret.hs: -------------------------------------------------------------------------------- 1 | module Interpret( 2 | run 3 | )where 4 | 5 | import Grammar 6 | import Utils 7 | import Runtime 8 | import Value 9 | import Definition 10 | import Type 11 | import Storage 12 | import Parse 13 | import Control.Applicative 14 | import Control.Monad hiding (void) 15 | import qualified Data.Map.Strict as M 16 | import Data.List 17 | import Data.Maybe 18 | 19 | import Control.Exception.Base 20 | 21 | type SymbolTable = M.Map Identifier Id 22 | 23 | data State = State Memory (Stack SymbolTable) deriving Show 24 | 25 | declareVar :: Program -> State -> VariableDeclaration -> IO State 26 | declareVar p s (VarDecl type' name init') = do 27 | (v, newS) <- 28 | if isJust init' 29 | then initialize p s $ fromJust init' 30 | else return (defaultVal type', s) 31 | return $ newVar newS name v 32 | 33 | declareArr :: Program -> State -> VariableDeclaration -> IO State 34 | declareArr p s@(State mem _) (ArrDecl type' name size init') = do 35 | (RVal _ size', State newMem table) <- computeExp p s size 36 | let sizeVal = read size' :: Int 37 | let (newNewMem, ptr) = blockAllocate newMem (defaultVal type') sizeVal 38 | let (Type typeName ptrLv) = type' 39 | let newState = newVar (State newNewMem table) name (RVal (Type typeName (ptrLv + 1)) (show ptr)) 40 | -- TODO: initialization 41 | return newState 42 | 43 | pushScope :: State -> State 44 | pushScope (State m s) = State m $ push (M.empty) s 45 | 46 | popScope :: State -> State 47 | popScope (State m s) = State (M.foldl (\m i -> free m i) m $ top s) $ pop s 48 | 49 | toRVal :: State -> Value -> Value 50 | toRVal s@(State m _) (LVal i) = toRVal s $ readMem m i 51 | toRVal _ x = x 52 | 53 | isLVal (LVal _) = True 54 | isLVal _ = False 55 | 56 | isRVal = not . isLVal 57 | 58 | -- Return left value 59 | getVar :: State -> Identifier -> Value 60 | getVar (State m s) x = LVal $ work s x where 61 | work s' x' = 62 | if x' `M.member` top s' 63 | then (top s') M.! x' 64 | else work (pop s') x' 65 | 66 | -- Follow left value link 67 | follow :: Memory -> Id -> Id 68 | follow m t = case readMem m t of 69 | LVal k -> follow m k 70 | _ -> t 71 | 72 | -- If identifier is a left value, follow the link 73 | modifyVar :: State -> Identifier -> (Value -> Value) -> State 74 | modifyVar state@(State m s) x f = State (modify m i f) s where 75 | i = let LVal k = getVar state x in follow m k 76 | 77 | -- Return right value 78 | getVal :: State -> Identifier -> Value 79 | getVal s = toRVal s . getVar s 80 | 81 | newVar :: State -> Identifier -> Value -> State 82 | newVar state@(State m s) n v = 83 | let (newM, i) = allocate m v 84 | in State newM $ updateTop (M.insert n i) s 85 | 86 | data StructureRt = Breaked | Normal | Continued | Returned Value deriving Eq 87 | 88 | rt2Value :: StructureRt -> Value 89 | rt2Value (Returned v) = v 90 | rt2Value _ = void 91 | 92 | 93 | -- Run a program 94 | -- Input: Program, Entry function, Args 95 | -- run :: Program -> Identifier -> [Value] -> IO Value 96 | -- run p@(Program _ _ vars) entry args = fst <$> computeFunc p initialState (getFunc p entry) args where 97 | run p@(Program fs ss vars) entry args = computeFunc newP initialState (getFunc newP entry) args where 98 | newP = Program (fs ++ compileDarkMagicBook darkMagicBook ++ magicBook) ss vars 99 | initialState = State newMem empty 100 | 101 | 102 | getFunc :: Program -> Identifier -> FunctionDefinition 103 | getFunc (Program fs _ _) n = fromJust $ find (\(FuncDef x _ _ _) -> x == n) fs 104 | 105 | computeFunc :: Program -> State -> FunctionDefinition -> [Value] -> IO (Value, State) 106 | computeFunc p s (FuncDef name rtType paras ins) args = do 107 | let lrVal = if isDarkMagic name then id else map $ toRVal s 108 | let cast = if isDarkMagic name then flip const else typeCast 109 | let argVals = zipWith (\(t, n) v -> (n, cast t v)) paras $ lrVal args 110 | let state = foldl (uncurry . newVar) (pushScope s) argVals 111 | snd' popScope <$> fst' (cast rtType . rt2Value) <$> runStructure p state ins 112 | -- Really smelly hack, but I doubt if I can bypass it without thorough modifications 113 | 114 | computeArgs :: Program -> State -> [Exp] -> IO ([Value], State) 115 | computeArgs _ s [] = return ([], s) 116 | computeArgs p s (x:xs) = do 117 | (v, newS) <- computeExp p s x 118 | fst' (v:) <$> computeArgs p newS xs 119 | 120 | -- Return Left Value if Possible 121 | computeExp :: Program -> State -> Exp -> IO (Value, State) 122 | computeExp p s (Constant x) 123 | | x `elem` ["true", "false"] = return (RVal boolType x, s) 124 | | isValidIdentifier x = return (getVar s x, s) 125 | | otherwise = return (RVal Polymorphism x, s) 126 | 127 | computeExp p s (Exp "?" args) = undefined -- lazy trinary 128 | computeExp p s (Exp f args) = do 129 | (para, newS) <- computeArgs p s args 130 | computeFunc p newS (getFunc p f) para 131 | 132 | runStructure :: Program -> State -> [Structure] -> IO (StructureRt, State) 133 | runStructure _ s [] = return (Normal, s) 134 | runStructure p _s (t:ts) = handler _s t where 135 | handler :: State -> Structure -> IO (StructureRt, State) 136 | handler = case t of 137 | IfBlock _ _ _ -> runIfBlock 138 | WhileBlock _ _ -> runWhileBlock 139 | DoWhileBlock _ _ -> runDoWhileBlock 140 | ForBlock _ _ _ _ -> runForBlock 141 | Expression _ -> runExpression 142 | Declaration _ -> runDeclaration 143 | UCJump _ -> runUCJump 144 | DarkMagic _ -> runDarkMagic 145 | where 146 | runIfBlock s (IfBlock con pri alt) = do 147 | (conVal, newS) <- computeExp p (pushScope s) con 148 | (rt, newerS) <- 149 | if isTrue $ toRVal newS conVal 150 | then snd' popScope <$> runStructure p newS pri 151 | else runStructure p newS alt 152 | if rt `elem` [Normal, Breaked] 153 | then snd' popScope <$> runStructure p newerS ts 154 | else return (rt, popScope newerS) 155 | 156 | runWhileBlock s (WhileBlock con body) = snd' popScope <$> (loop $ pushScope s) where 157 | loop :: State -> IO (StructureRt, State) 158 | loop state = do 159 | (conVal, newS) <- computeExp p state con 160 | if isTrue conVal 161 | then do 162 | (rt, newS) <- runStructure p newS body 163 | case rt of 164 | Normal -> loop newS 165 | Breaked -> runStructure p newS ts 166 | k@(Returned _) -> return (k, newS) 167 | else runStructure p newS ts 168 | 169 | runDoWhileBlock s (DoWhileBlock con body) = 170 | snd' popScope <$> runStructure p (pushScope s) (body ++ [WhileBlock con body]) 171 | 172 | runForBlock s (ForBlock init' con delta body) = do 173 | (init', newS) <- computeExp p s init' 174 | runWhileBlock newS $ WhileBlock con (body ++ [Expression delta]) 175 | 176 | runExpression s (Expression exp) = do 177 | (_, newS) <- computeExp p s exp 178 | runStructure p newS ts 179 | 180 | runDeclaration s (Declaration decl) = do 181 | newS <- (case decl of 182 | (VarDecl _ _ _) -> declareVar 183 | (ArrDecl _ _ _ _) -> declareArr) p s decl 184 | runStructure p newS ts 185 | 186 | runUCJump s (UCJump Break) = return (Breaked, s) 187 | runUCJump s (UCJump Continue) = return (Continued, s) 188 | runUCJump s (UCJump (Return exp)) = do 189 | (v, newS) <- computeExp p s exp 190 | return (Returned $ toRVal newS v, newS) 191 | 192 | runDarkMagic s (DarkMagic curse) = fst' Returned <$> getDarkMagic curse s 193 | 194 | initialize :: Program -> State -> VarInit -> IO (Value, State) 195 | initialize p s (InitExp exp) = computeExp p s exp 196 | 197 | type Magic = State -> IO (Value, State) 198 | 199 | uselessMagic s = return (void, s) 200 | 201 | getDarkMagic :: Identifier -> Magic 202 | getDarkMagic = (M.!) _darkMagic 203 | 204 | _darkMagic = M.fromList $ map (\(n, it ,im) -> (n, im)) darkMagicBook 205 | 206 | isDarkMagic s = (not $ isValidIdentifier s) || s `M.member` _darkMagic 207 | 208 | -- (Name, Interface, Implement) 209 | darkMagicBook :: [(Identifier, FunctionDefinition, Magic)] 210 | darkMagicBook = [("/", divide, divideMagic), ("+", add, addMagic), ("-neg", neg, negMagic), ("=", assign, assignMagic), ("debuginfo", debugInfo, debugInfoMagic), ("debugprint", debugPrint, debugPrintMagic), ("&addr", addr, addrMagic), ("*deref", deref, derefMagic), ("print", print_, printMagic), ("input", input, inputMagic), ("*", multi, multiMagic), ("==", eq, eqMagic), ("<", less, lessMagic), ("!", logNeg, logNegMagic), ("&&", logAnd, logAndMagic), ("||", logOr, logOrMagic), ("-=", minusAssign, uselessMagic), ("+=", plusAssign, uselessMagic), ("*=", multiAssign, uselessMagic), ("/=", divideAssign, uselessMagic), ("--suf", suffixDec, uselessMagic), ("++suf", suffixInc, uselessMagic), ("--pre", prefixDec, uselessMagic), ("++pre", prefixInc, uselessMagic)] 211 | 212 | compileDarkMagicBook = map (\(n, it, im) -> it) 213 | 214 | add = FuncDef "+" Polymorphism [(Polymorphism, "a"), (Polymorphism, "b")] [DarkMagic "+"] 215 | addMagic s = 216 | let RVal _ a = getVal s "a"; RVal _ b = getVal s "b" 217 | in return (RVal intType $ show (read a + read b :: Integer), s) 218 | 219 | divide = FuncDef "/" Polymorphism [(Polymorphism, "a"), (Polymorphism, "b")] [DarkMagic "/"] 220 | divideMagic s = 221 | let RVal _ a = getVal s "a"; RVal _ b = getVal s "b" 222 | in return (RVal intType $ show (read a `div` read b :: Integer), s) 223 | -- TODO: support float 224 | 225 | plusAssign = FuncDef "+=" Polymorphism [(Polymorphism, "a"), (Polymorphism, "b")] $ parseFuncBody "a=a+b;return a;" 226 | minusAssign = FuncDef "-=" Polymorphism [(Polymorphism, "a"), (Polymorphism, "b")] $ parseFuncBody "a=a-b;return a;" 227 | multiAssign = FuncDef "*=" Polymorphism [(Polymorphism, "a"), (Polymorphism, "b")] $ parseFuncBody "a=a*b;return a;" 228 | divideAssign = FuncDef "/=" Polymorphism [(Polymorphism, "a"), (Polymorphism, "b")] $ parseFuncBody "a=a/b;return a;" 229 | 230 | prefixInc = FuncDef "++pre" Polymorphism [(Polymorphism, "a")] $ parseFuncBody "a+=1;return a;" 231 | prefixDec = FuncDef "--pre" Polymorphism [(Polymorphism, "a")] $ parseFuncBody "a-=1;return a;" 232 | suffixInc = FuncDef "++suf" Polymorphism [(Polymorphism, "a")] $ parseFuncBody "a+=1;return a-1;" 233 | suffixDec = FuncDef "--suf" Polymorphism [(Polymorphism, "a")] $ parseFuncBody "a-=1;return a+1;" 234 | 235 | multi = FuncDef "*" Polymorphism [(Polymorphism, "a"), (Polymorphism, "b")] [DarkMagic "*"] 236 | multiMagic s = 237 | let RVal _ a = getVal s "a"; RVal _ b = getVal s "b" 238 | in return (RVal intType $ show (read a * read b :: Integer), s) 239 | 240 | eq = FuncDef "==" Polymorphism [(Polymorphism, "a"), (Polymorphism, "b")] [DarkMagic "=="] 241 | eqMagic s = 242 | let RVal _ a = getVal s "a"; RVal _ b = getVal s "b" 243 | in return (if a == b then true else false, s) 244 | 245 | less = FuncDef "<" Polymorphism [(Polymorphism, "a"), (Polymorphism, "b")] [DarkMagic "<"] 246 | lessMagic s = 247 | let RVal _ a = getVal s "a"; RVal _ b = getVal s "b" 248 | in return (if (read a :: Integer) < (read b :: Integer) then true else false, s) 249 | 250 | neg = FuncDef "-neg" Polymorphism [(Polymorphism, "a")] [DarkMagic "-neg"] 251 | negMagic s = 252 | let RVal _ a = getVal s "a" 253 | in return (RVal intType $ show (- read a :: Integer), s) 254 | 255 | logNeg = FuncDef "!" Polymorphism [(Polymorphism, "a")] [DarkMagic "!"] 256 | logNegMagic s = 257 | let b = toBool $ getVal s "a" 258 | in return (if b == true then false else true, s) 259 | 260 | logAnd = FuncDef "&&" Polymorphism [(Polymorphism, "a"), (Polymorphism, "b")] [DarkMagic "&&"] 261 | logAndMagic s = 262 | let a = toBool $ getVal s "a"; b = toBool $ getVal s "b" 263 | in return (if a == true && b == true then true else false, s) 264 | 265 | logOr = FuncDef "||" Polymorphism [(Polymorphism, "a"), (Polymorphism, "b")] [DarkMagic "||"] 266 | logOrMagic s = 267 | let a = toBool $ getVal s "a"; b = toBool $ getVal s "b" 268 | in return (if a == true || b == true then true else false, s) 269 | 270 | assign = FuncDef "=" Polymorphism [(Polymorphism, "a"), (Polymorphism, "b")] [DarkMagic "="] 271 | assignMagic s = 272 | let var = getVar s "a"; val@(RVal _ _) = getVal s "b" 273 | in return (var, modifyVar s "a" (return val)) 274 | 275 | debugInfo = FuncDef "debuginfo" voidType [] [DarkMagic "debuginfo"] 276 | debugInfoMagic s = (print $ popScope s) >> return (void, s) 277 | 278 | debugPrint = FuncDef "debugprint" voidType [(Polymorphism, "a")] [DarkMagic "debugprint"] 279 | debugPrintMagic s@(State m t) = (print $ getVar s "a") >> return (void, s) 280 | 281 | addr = FuncDef "&addr" Polymorphism [(Polymorphism, "a")] [DarkMagic "&addr"] 282 | addrMagic s@(State m _) = 283 | let LVal i = getVar s "a" 284 | in return (RVal (makePtr "void" 1) $ show $ follow m i, s) 285 | 286 | deref = FuncDef "*deref" Polymorphism [(Polymorphism, "a")] [DarkMagic "*deref"] 287 | derefMagic s@(State m _) = let RVal _ a = getVal s "a" in return (LVal $ follow m (read a :: Id), s) 288 | 289 | print_ = FuncDef "print" voidType [(Polymorphism, "a")] [DarkMagic "print"] 290 | printMagic s = let RVal _ x = getVal s "a" in putStrLn x >> return (void, s) 291 | 292 | input = FuncDef "input" Polymorphism [] [DarkMagic "input"] 293 | inputMagic s = do 294 | x <- getString 295 | return (RVal Polymorphism x, s) 296 | 297 | magicBook = writeMagicBook theStandardBookOfSpell 298 | 299 | writeMagicBook :: [(Identifier, String)] -> [FunctionDefinition] 300 | writeMagicBook spells = (\(name, s) -> let Program [f] _ _ = parse s in let FuncDef _ rt args ins = f in FuncDef name rt args ins) <$> spells 301 | 302 | theStandardBookOfSpell = [("-", "int f(int a,int b){return a+(-b);}"), ("!=", "int f(int a,int b){return !(a==b);}"), ("<=", "int f(int a,int b){return (a", "int f(int a,int b){return !(a<=b);}"), (">=", "int f(int a,int b){return (a>b)||(a==b);}"), (",", "int f(int a,int b){return b;}")] 303 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 sqd 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Interpret 4 | import Parse 5 | import Value 6 | import System.IO 7 | import System.Environment 8 | 9 | import Control.Applicative 10 | 11 | main = do 12 | args <- getArgs 13 | if null args 14 | then putStrLn "No input file." 15 | else do 16 | let filename = head args 17 | handle <- openFile filename ReadMode 18 | code <- hGetContents handle 19 | (RVal _ x, _) <- run (parse code) "main" [] 20 | putStr x 21 | 22 | parseNrun s = do 23 | (v, _) <- run (parse s) "main" [] 24 | print v 25 | -------------------------------------------------------------------------------- /Parse.hs: -------------------------------------------------------------------------------- 1 | module Parse( 2 | parse, 3 | parseFuncBody 4 | )where 5 | 6 | import Utils 7 | import Grammar 8 | import Type 9 | import Data.List 10 | import Data.Char 11 | import Data.List.Split 12 | import Control.Applicative 13 | 14 | -- Find a bracket (in a wide term) 15 | -- Input: left bracket, right bracket, a list starts with the left bracket 16 | -- Output: (Content_in_Bracket_with_the_Brackets, Rest) 17 | -- eg. spanBracket "(" ")" "(abc)def" = ("(abc)", "def") 18 | spanBracket :: Eq a => a -> a -> [a] -> ([a], [a]) 19 | spanBracket l r s = fst' (l:) $ work 1 $ tail s where 20 | work 0 x = ([], x) 21 | work i (x:xs) = fst' (x:) $ work (i + if x == l then 1 else if x == r then -1 else 0) xs 22 | 23 | -- Similiar to `splitOn`, but do not split inside a bracket 24 | -- eg. splitTopLevelOn "," $ split2w "abc(,),def" = [split2w "abc(,)", split2w "def"] 25 | -- Input: left bracket, right bracket, splitter 26 | splitTopLevelOn :: Eq a => a -> a -> a -> [a] -> [[a]] 27 | splitTopLevelOn _ _ _ [] = [[]] 28 | splitTopLevelOn l r splitter s@(k:ks) 29 | | k == l = (bracket ++ x):xs 30 | | k == splitter = []:(splitTopLevelOn l r splitter ks) 31 | | otherwise = let (t:ts) = splitTopLevelOn l r splitter ks in (k:t):ts 32 | where 33 | (bracket, rest) = spanBracket l r s 34 | (x:xs) = splitTopLevelOn l r splitter rest 35 | 36 | -- Delete all brackets in the top level 37 | dropTopLevelBrackets :: Eq a => a -> a -> [a] -> [a] 38 | dropTopLevelBrackets _ _ [] = [] 39 | dropTopLevelBrackets left right s@(x:xs) = 40 | if x == left 41 | then snd $ spanBracket left right s 42 | else x:(dropTopLevelBrackets left right xs) 43 | 44 | -- Is a string in the top level? 45 | elemTopLevel :: String -> [String] -> Bool 46 | elemTopLevel x l = x `elem` dropTopLevelBrackets "(" ")" l 47 | 48 | -- Split only once, searching from the left 49 | -- eg. split ';' "abc;def;ghi" = ("abc", "def;ghi") 50 | splitOnceL :: Eq a => a -> [a] -> ([a], [a]) 51 | splitOnceL _ [] = ([], []) 52 | splitOnceL t (x:xs) = if t == x then ([], xs) else fst' (x:) $ splitOnceL t xs 53 | 54 | -- Split only once, searching from the right 55 | splitOnceR :: Eq a => a -> [a] -> ([a], [a]) 56 | splitOnceR t l = let (x, y) = fst' reverse $ snd' reverse $ splitOnceL t $ reverse l in (y, x) 57 | 58 | decomment :: String -> String 59 | decomment "" = "" 60 | decomment str@(x:xs) 61 | | "//" `isPrefixOf` str = decomment $ dropWhile (/='\n') str 62 | | "/*" `isPrefixOf` str = decomment $ drop 2 $ head $ filter (isPrefixOf "*/") $ tails str 63 | | otherwise = x:(decomment xs) 64 | 65 | -- Get a string, ignoring escaped quatation mark 66 | -- Input: a string STARTS WITH A STRING 67 | -- Output: (the_String_with_Quotation_Mark, rest) 68 | spanString :: String -> (String, String) 69 | spanString = fst' ('"':) . spanString' . tail where 70 | spanString' ('\\':c:xs) = fst' (++ ['\\', c]) $ spanString' xs 71 | spanString' ('"':xs) = ("\"", xs) 72 | spanString' (x:xs) = fst' (x:) $ spanString' xs 73 | 74 | -- Split a string into a list of words 75 | split2w :: String -> [String] 76 | split2w "" = [] 77 | split2w str@(x:xs) 78 | | x `elem` "|?!%^&*()-=+[]{};:,<.>/~" = [x]:(split2w xs) 79 | | isAlpha x || x == '_' = let (w, rest) = span (\c -> isAlphaNum c || c == '_') xs in (x:w):(split2w rest) 80 | | isNumber x = let (w, rest) = span isNumber str in w:(split2w rest) 81 | | x == '"' = let (w, rest) = spanString str in w:(split2w rest) 82 | | x == '\'' = (take 3 str):(split2w $ drop 3 str) 83 | | isSpace x || x == '\0' = split2w xs 84 | 85 | -- Merge 2-char operators 86 | mergeOps :: [String] -> [String] 87 | mergeOps [] = [] 88 | mergeOps [x] = [x] 89 | mergeOps (a:b:xs) = 90 | if a ++ b `elem` list 91 | then (a ++ b):(mergeOps xs) 92 | else a:(mergeOps (b:xs)) 93 | where 94 | list = ["++", "--", "+=", "-=", "*=", "/=", "&&", "||", "==", "!=", ">=", "<=", ">>", "<<", "^=", "|=", "&=", "%=", "->"] 95 | -- >>= and <<=, shame you for being the only 3-char operators 96 | 97 | -- Input: initialization list WITH BOTH BRACES 98 | parseInitList :: [String] -> VarInit 99 | parseInitList x = InitList $ map parseExp $ splitOn [","] $ extract x 100 | 101 | -- Parse an expression 102 | -- Input: an expression only 103 | parseExp :: [String] -> Exp 104 | parseExp [x] = Constant x 105 | parseExp l 106 | | "," `elemTopLevel` l = binaryl "," 107 | | "*=" `elemTopLevel` l = binaryr "*=" 108 | | "/=" `elemTopLevel` l = binaryr "/=" 109 | | "%=" `elemTopLevel` l = binaryr "%=" 110 | | "+=" `elemTopLevel` l = binaryr "+=" 111 | | "-=" `elemTopLevel` l = binaryr "-=" 112 | | "=" `elemTopLevel` l = binaryr "=" 113 | | "?" `elemTopLevel` l = handleTernary 114 | | "||" `elemTopLevel` l = binaryl "||" 115 | | "&&" `elemTopLevel` l = binaryl "&&" 116 | | "|" `elemTopLevel` l = binaryl "|" 117 | | "^" `elemTopLevel` l = binaryl "^" 118 | | (not $ null l) && (head l == "&") = Exp "&addr" [parseExp $ tail l] 119 | | "&" `elemTopLevel` l = binaryl "&" 120 | | "==" `elemTopLevel` l = binaryl "==" 121 | | "!=" `elemTopLevel` l = binaryl "!=" 122 | | (not $ null l) && (head l == "!") = Exp "!" [parseExp $ tail l] 123 | | ">" `elemTopLevel` l = binaryl ">" 124 | | ">=" `elemTopLevel` l = binaryl ">=" 125 | | "<" `elemTopLevel` l = binaryl "<" 126 | | "<=" `elemTopLevel` l = binaryl "<=" 127 | | ">>" `elemTopLevel` l = binaryl ">>" 128 | | "<<" `elemTopLevel` l = binaryl "<<" 129 | | (not $ null l) && (head l == "+") = Exp "+pos" [parseExp $ tail l] 130 | | "+" `elemTopLevel` l = binaryl "+" 131 | | (not $ null l) && (head l == "-") = Exp "-neg" [parseExp $ tail l] 132 | | "-" `elemTopLevel` l = binaryl "-" 133 | | (not $ null l) && (head l == "*") = Exp "*deref" [parseExp $ tail l] 134 | | "*" `elemTopLevel` l = binaryl "*" 135 | | "/" `elemTopLevel` l = binaryl "/" 136 | | "%" `elemTopLevel` l = binaryl "%" 137 | | (not $ null l) && (head l == "~") = Exp "~" [parseExp $ tail l] 138 | | (not $ null l) && (head l == "++") = Exp "++pre" [parseExp $ tail l] 139 | | (not $ null l) && (head l == "--") = Exp "--pre" [parseExp $ tail l] 140 | | "->" `elemTopLevel` l = binaryl "->" 141 | | "." `elemTopLevel` l = binaryl "." 142 | | "[" `elemTopLevel` l = parseExp handleSBrackets 143 | | (not $ null l) && (isValidIdentifier $ head l) && (l !! 1 == "(") = handleCall 144 | | (not $ null l) && last l == "++" = Exp "++suf" [parseExp $ init l] 145 | | (not $ null l) && last l == "--" = Exp "--suf" [parseExp $ init l] 146 | | (not $ null l) && head l == "(" && last l == ")" = parseExp $ extract l 147 | | otherwise = error ("Fail all patterns in `parseExp`, arg: " ++ show l) 148 | where 149 | binaryl x = let (left, right) = splitOnceL x l in Exp x [parseExp left, parseExp right] 150 | binaryr x = let (left, right) = splitOnceR x l in Exp x [parseExp left, parseExp right] 151 | 152 | handleTernary = Exp "?" [parseExp condition, parseExp pos, parseExp neg] where 153 | (condition, branches) = splitOnceR "?" l 154 | (pos, neg) = fst' extract $ spanBracket "?" ":" ("?":branches) 155 | 156 | handleCall = Exp (head l) $ map parseExp $ let t = splitTopLevelOn "(" ")" "," $ extract $ tail l in if t == [[]] then [] else t 157 | -- smelly, whatever 158 | 159 | handleSBrackets = front ++ ["(", "*", "(", "("] ++ [name] ++ [")", "+", "("] ++ offset ++ [")", ")", ")"] ++ back where 160 | (beforeLBracket, fromLBracket) = snd' ("[":) $ splitOnceL "[" l 161 | (offset, back) = fst' extract $ spanBracket "[" "]" fromLBracket 162 | front = init beforeLBracket 163 | name = last beforeLBracket 164 | 165 | 166 | 167 | -- If the input is preceded by a variable declaration 168 | -- Input: An input that may be preceded by a declaration 169 | -- Type [Star*] Name [=,;] 170 | isDeclaration :: [String] -> Bool 171 | isDeclaration (x:xs) 172 | | x `elem` ["signed", "unsigned", "static"] = isDeclaration xs 173 | isDeclaration ("long":x:xs) 174 | | x `elem` ["int", "double"] = isDeclaration (x:xs) 175 | isDeclaration ("short":"int":xs) = isDeclaration ("int":xs) 176 | isDeclaration x = isHeadIdentifier && hasName && hasValidFollowers where 177 | isHeadIdentifier = isValidIdentifier $ head x 178 | hasName = isValidIdentifier $ head afterStars 179 | hasValidFollowers = head afterName `elem` ["[", "=", ",", ";"] 180 | afterStars = dropWhile (== "*") $ tail x 181 | afterName = tail afterStars 182 | 183 | isJump :: [String] -> Bool 184 | isJump ("break":";":_) = True 185 | isJump ("continue":";":_) = True 186 | isJump ("return":_) = True 187 | isJump _ = False 188 | 189 | isTypeDef :: [String] -> Bool 190 | isTypeDef ("typedef":"struct":_) = True 191 | isTypeDef _ = False 192 | 193 | -- Parse a type 194 | -- Input: a type strings ONLY, such as ["int", "*"] 195 | parseType :: [String] -> Type 196 | parseType (s:t:ss) 197 | | s `elem` ["struct", "static", "signed", "unsigned"] = parseType (t:ss) 198 | | s `elem` ["long", "short"] && t == "int" = parseType (t:ss) 199 | | (s, t) == ("long", "double") = parseType (t:ss) 200 | | s `elem` ["long", "short"] = parseType ("int":t:ss) 201 | parseType (typeName:stars) = Type typeName $ length stars 202 | 203 | -- Extract the type name 204 | -- Input: code starts with a type name 205 | -- Output: (Type_Name, Rest) 206 | spanTypeName :: [String] -> ([String], [String]) 207 | spanTypeName (s:t:ss) 208 | | s `elem` ["struct", "static", "signed", "unsigned"] = spanTypeName (t:ss) 209 | | s `elem` ["long", "short"] && t == "int" = fst' ("int":) $ getStars ss 210 | | [s, t] == ["long", "double"] = fst' ("double":) $ getStars ss 211 | | otherwise = fst' (s:) $ getStars (t:ss) 212 | where 213 | getStars = span (=="*") 214 | 215 | -- Parse variable declarations 216 | -- Input: ONLY variable declarations (WITHOUT SEMICOLON) 217 | -- Output: A list of declarations 218 | -- We don't distinguish signed and unsigned, short or long integers here, 219 | -- so that the type name would be a lot easier to handle 220 | -- No weird brackets should be included 221 | parseDeclaration :: [String] -> [VariableDeclaration] 222 | parseDeclaration x = [parseVar _x | _x <- variables] where 223 | (typeName, afterTypeName) = spanTypeName x 224 | type_ = parseType typeName 225 | variables = splitTopLevelOn "{" "}" "," afterTypeName 226 | parseVar t = if isArr t then arrDecl t else varDecl t 227 | 228 | isArr [_:"["] = True 229 | isArr _ = False 230 | 231 | arrDecl (name:afterName) = ArrDecl type_ name size init_ where 232 | (size, afterSBrackets) = fst' (parseExp . extract) $ spanBracket "[" "]" afterName 233 | init_ = 234 | if null afterSBrackets 235 | then Nothing 236 | else Just $ parseInitList $ tail afterSBrackets 237 | varDecl (name:afterName) = VarDecl type_ name init_ where 238 | init_ = 239 | if null afterName 240 | then Nothing 241 | else if afterName !! 1 == "{" 242 | then Just $ parseInitList $ tail afterName 243 | else Just $ InitExp $ parseExp $ tail afterName 244 | 245 | -- If an input is immediately preceded by a subblock 246 | isSubBlock :: [String] -> Bool 247 | isSubBlock x = (not $ null x) && (head x `elem` ["if", "switch", "while", "for", "do"]) 248 | 249 | -- Parse a subblock 250 | -- Input: An input that IS preceded by a subblock 251 | -- Output: (The_Subblock, Code_after_the_Subblock) 252 | -- Works by entailing specific subblock parser functions 253 | spanParseSubBlock :: [String] -> (Structure, [String]) 254 | spanParseSubBlock s@(x:_) = 255 | case x of 256 | "if" -> spanParseIfElse s 257 | "switch" -> parseSwitch s 258 | "do" -> parseDoWhile s 259 | "while" -> spanParseWhile s 260 | "for" -> spanParseFor s 261 | "struct" -> fst' LocalStructDefinition $ spanParseStruct s 262 | 263 | -- Parse an if..else subblock 264 | -- Input: An input that IS preceded by an if..else.. subblock 265 | -- Output: (The_IfElse_Subblock, Code_after_the_Subblock) 266 | spanParseIfElse :: [String] -> (Structure, [String]) 267 | spanParseIfElse ("if":afterIf) = (IfBlock (parseExp condition) primaryBranch secondaryBranch, rest) where 268 | (condition, afterCondition) = spanBracket "(" ")" afterIf 269 | (primaryBranch, afterPrimaryBranch) 270 | | head afterCondition == "{" = fst' (parseCtlFlow . extract) $ spanBracket "{" "}" afterCondition 271 | | isSubBlock afterCondition = fst' return $ spanParseSubBlock afterCondition 272 | | otherwise = fst' parseCtlFlow $ span' (/= ";") afterCondition 273 | (secondaryBranch, rest) 274 | | (not $ null afterPrimaryBranch) && (head afterPrimaryBranch == "else") = hasSecondaryBranch 275 | | otherwise = ([], afterPrimaryBranch) 276 | where 277 | t = tail afterPrimaryBranch 278 | hasSecondaryBranch 279 | | afterPrimaryBranch !! 1 == "{" = fst' (parseCtlFlow . extract) $ spanBracket "{" "}" t 280 | | isSubBlock t = fst' return $ spanParseSubBlock t 281 | | otherwise = fst' parseCtlFlow $ span' (/= ";") t 282 | 283 | parseSwitch = undefined 284 | 285 | parseDoWhile ("do":afterDo) = (DoWhileBlock (parseExp con) $ parseCtlFlow body, rest) where 286 | (body, afterBody) = fst' extract $ spanBracket "{" "}" afterDo 287 | (con, ";":rest) = spanBracket "(" ")" $ tail afterBody 288 | 289 | spanParseStruct :: [String] -> (StructDefinition, [String]) 290 | spanParseStruct ("struct":name:x) = (StructDef name vars, rest) where 291 | (body, rest') = fst' extract $ spanBracket "{" "}" x 292 | vars = foldl (\l (Declaration (VarDecl type_ n _)) -> (type_, n):l ) [] $ parseCtlFlow body 293 | rest = case rest' of 294 | ";":xs -> xs 295 | t:";":xs -> [name, t, ";"] ++ xs 296 | 297 | spanParseFor :: [String] -> (Structure, [String]) 298 | spanParseFor ("for":afterFor) = (ForBlock (parseExp init') condition (parseExp delta) body, rest) where 299 | (bracket, afterBracket) = fst' extract $ spanBracket "(" ")" afterFor 300 | (body, rest) 301 | | head afterBracket == "{" = fst' (parseCtlFlow . extract) $ spanBracket "{" "}" afterBracket 302 | | isSubBlock afterBracket = fst' pure $ spanParseSubBlock afterBracket 303 | | otherwise = fst' parseCtlFlow $ span' (/= ";") afterBracket 304 | [init', condition', delta] = splitOn [";"] bracket 305 | condition = foldl1 (\a b -> Exp "&&" [a, b]) $ map parseExp $ splitTopLevelOn "(" ")" "," condition' 306 | 307 | -- Parse a while subblock 308 | -- Input: An input that IS preceded by a while subblock 309 | -- Output: (The_While_Subblock, Code_after_the_Subblock) 310 | spanParseWhile :: [String] -> (Structure, [String]) 311 | spanParseWhile ("while":afterWhile) = (WhileBlock (parseExp condition) loopBody, rest) where 312 | (condition, afterCondition) = spanBracket "(" ")" afterWhile 313 | (loopBody, rest) 314 | | head afterCondition == "{" = fst' (parseCtlFlow . extract) $ spanBracket "{" "}" afterCondition 315 | | isSubBlock afterCondition = fst' return $ spanParseSubBlock afterCondition 316 | | otherwise = fst' parseCtlFlow $ span' (/= ";") afterCondition 317 | 318 | 319 | -- Parse a serial of code 320 | -- Such as void function(){__code__} 321 | -- or while(0){__code__} 322 | -- Input: A serial of code 323 | -- Output: A list of parsed structures 324 | parseCtlFlow :: [String] -> [Structure] 325 | parseCtlFlow [] = [] 326 | parseCtlFlow (";":xs) = parseCtlFlow xs 327 | parseCtlFlow x 328 | | isJump x = let (s, rest) = spanParseJump x in s:(parseCtlFlow rest) 329 | parseCtlFlow x 330 | | isDeclaration x = 331 | let (decls, ";":rest) = span (/= ";") x 332 | in foldr (\t l -> (Declaration t):l) (parseCtlFlow rest) (parseDeclaration decls) 333 | parseCtlFlow x = let (s, rest) = f x in s:(parseCtlFlow rest) where 334 | f 335 | | isSubBlock x = spanParseSubBlock 336 | | isTypeDef x = parseTypeDef 337 | | otherwise = (\s -> let (exp, ";":rest) = span (/= ";") x in (Expression $ parseExp exp, rest)) 338 | 339 | spanParseJump :: [String] -> (Structure, [String]) 340 | spanParseJump ("break":";":xs) = (UCJump Break, xs) 341 | spanParseJump ("continue":";":xs) = (UCJump Continue, xs) 342 | spanParseJump ("return":xs) = let (x, ";":rest) = span (/= ";") xs in (UCJump $ Return $ parseExp x, rest) 343 | 344 | parseTypeDef = undefined 345 | 346 | -- If the input is preceded by a function definition 347 | -- Input: An input that may be preceded by a definition 348 | -- Assuming that this function would be called only in the top scope 349 | isFunctionDefinition :: [String] -> Bool 350 | isFunctionDefinition x = (not $ isDeclaration x) && (not $ isStruct x) 351 | 352 | isStruct :: [String] -> Bool 353 | isStruct ("struct":_) = True 354 | isStruct _ = False 355 | 356 | spanParseFuncDef :: [String] -> (FunctionDefinition, [String]) 357 | spanParseFuncDef ("struct":xs) = spanParseFuncDef xs 358 | spanParseFuncDef x = (FuncDef name rtType args ins, rest) where 359 | (typeName, afterTypeName) = spanTypeName x 360 | (name:afterName) = afterTypeName 361 | (args', afterArgs) = fst' extract $ spanBracket "(" ")" afterName 362 | (body, rest) = fst' extract $ spanBracket "{" "}" afterArgs 363 | rtType = parseType typeName 364 | args = 365 | let l = splitOn [","] args' 366 | in 367 | if l == [[]] 368 | then [] 369 | else (\(VarDecl t n _) -> (t, n)) <$> (head . parseDeclaration) <$> splitOn [","] args' 370 | ins = parseCtlFlow body 371 | 372 | 373 | parse :: String -> Program 374 | parse = parse' (Program [] [] []) . mergeOps . split2w . decomment 375 | 376 | parse' :: Program -> [String] -> Program 377 | parse' p [] = p 378 | parse' (Program funcs types vars) x 379 | | isStruct x = 380 | let (s, rest) = spanParseStruct x 381 | in parse' (Program funcs (s:types) vars) rest 382 | | isDeclaration x = 383 | let (vs, ";":rest) = fst' parseDeclaration $ span (/= ";") x 384 | in parse' (Program funcs types (vs ++ vars)) rest 385 | | isFunctionDefinition x = 386 | let (f, rest) = spanParseFuncDef x 387 | in parse' (Program (f:funcs) types vars) rest 388 | 389 | parseFuncBody = parseCtlFlow . mergeOps . split2w 390 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # haskell-C89-interpreter 2 | Interpreter for C89 in Haskell 3 | 4 | Run the interpreter by giving the source file path in the first positon of the arguments. 5 | 6 | Eg. 7 | 8 | $ runhaskell Main.hs test.c 9 | 10 | Unsupported (yet) features 11 | 12 | 1. `goto` (Not in current plan) 13 | 2. Function pointer (In plan) 14 | 3. Default parameters (In plan) 15 | 4. `do..while` (Coming) 16 | 5. `#include` (Coming) 17 | 6. `struct` (Coming) 18 | 7. Access Containment. (Will never be implemented) 19 | 8. Distinguish between `int`, `long int` and `short int` (Not in current plan) 20 | 9. "Real world" `int` (one that can over/underflow). (Not in current plan) 21 | 22 | ... and the list goes on 23 | 24 | And, uhm, the memory allocated for arrays wouldn't be recycled ... yet, due to some ... lapses. 25 | -------------------------------------------------------------------------------- /Runtime.hs: -------------------------------------------------------------------------------- 1 | module Runtime( 2 | typeCast, 3 | defaultVal, 4 | toBool, 5 | boolType, 6 | true, 7 | false, 8 | isTrue, 9 | isFalse, 10 | voidType, 11 | void, 12 | intType, 13 | makePtr 14 | )where 15 | 16 | import Grammar 17 | import Parse 18 | import Type 19 | import Value 20 | import Control.Applicative 21 | 22 | -- Input: Target type, a RIGHT value 23 | typeCast :: Type -> Value -> Value 24 | typeCast t1 v@(RVal t2 x) 25 | | t1 == t1 = v 26 | typeCast (Type "bool" 0) (RVal _ x) = if x == "0" then false else true 27 | typeCast (Type "int" 0) (RVal Polymorphism x) = RVal intType $ show $ (read x :: Integer) 28 | typeCast Polymorphism (RVal _ x) = RVal Polymorphism x 29 | typeCast x v = error $ "Type Cast error: " ++ show x ++ " | " ++ show v 30 | 31 | defaultVal :: Type -> Value 32 | defaultVal (Type "bool" 0) = false 33 | defaultVal (Type "int" 0) = RVal intType "0" 34 | 35 | toBool = typeCast boolType 36 | boolType = Type "bool" 0 37 | true = RVal boolType "true" 38 | false = RVal boolType "false" 39 | isTrue = (== true) . toBool 40 | isFalse = not . isTrue 41 | 42 | voidType = Type "void" 0 43 | void = RVal voidType "" 44 | 45 | intType = Type "int" 0 46 | makeInt = RVal intType . (show :: Integer -> String) 47 | 48 | makePtr = Type 49 | -------------------------------------------------------------------------------- /Storage.hs: -------------------------------------------------------------------------------- 1 | module Storage( 2 | Memory, 3 | readMem, 4 | Id, 5 | allocate, 6 | free, 7 | modify, 8 | newMem, 9 | blockAllocate 10 | )where 11 | 12 | import Value 13 | import Definition 14 | import Type 15 | import qualified Data.Map.Strict as M 16 | 17 | import Control.Exception.Base 18 | 19 | data Memory = Mem (M.Map Id Value) Id deriving Show 20 | 21 | newMem = Mem M.empty 1 22 | 23 | readMem :: Memory -> Id -> Value 24 | readMem (Mem m _) x = m M.! x 25 | 26 | allocate :: Memory -> Value -> (Memory, Id) 27 | allocate (Mem m i) v = (Mem (M.insert i v m) (i+1), i) 28 | 29 | blockAllocate :: Memory -> Value -> Int -> (Memory, Id) 30 | blockAllocate (Mem m i) v n = (Mem newMap (i + fromIntegral n), i) where 31 | newMap = foldl (\dict (key, val) -> M.insert key val dict) m $ zip [i..] (replicate n v) 32 | 33 | free :: Memory -> Id -> Memory 34 | free (Mem m i) x = Mem (M.delete x m) i 35 | 36 | modify :: Memory -> Id -> (Value -> Value) -> Memory 37 | modify (Mem m i) x f = Mem (M.adjust f x m) i 38 | -------------------------------------------------------------------------------- /Type.hs: -------------------------------------------------------------------------------- 1 | module Type( 2 | Type(..) 3 | )where 4 | 5 | import Definition 6 | 7 | data Type = Polymorphism | TypeAlias Identifier Identifier | TypeArray Type Int | Type Identifier Int deriving (Eq) 8 | 9 | instance Show Type where 10 | show Polymorphism = "?Type?" 11 | show (Type n i) = n ++ replicate i '*' 12 | -------------------------------------------------------------------------------- /UnsupportedFeature.txt: -------------------------------------------------------------------------------- 1 | ANY access control 2 | Function Pointer (coming soon) 3 | Weird usage of brackets in variable declaration 4 | `goto` 5 | Assembly 6 | Default parameters (coming soon) 7 | struct (coming soon) 8 | struct within struct 9 | do while (coming soon) 10 | ... and many more 11 | 12 | long/short/int are not distinguished 13 | -------------------------------------------------------------------------------- /Utils.hs: -------------------------------------------------------------------------------- 1 | module Utils( 2 | fst', 3 | snd', 4 | span', 5 | extract, 6 | lastN, 7 | race, 8 | isValidIdentifier, 9 | Stack, 10 | top, 11 | pop, 12 | push, 13 | singleton, 14 | updateTop, 15 | while, 16 | (<>>), 17 | getString 18 | )where 19 | 20 | import Control.Applicative 21 | import Data.Char 22 | 23 | -- Apply a function to the fst element of a pair 24 | fst' :: (a -> b) -> (a, c) -> (b, c) 25 | fst' f (a, b) = (f a, b) 26 | 27 | -- Apply a function to the snd element of a pair 28 | snd' :: (a -> b) -> (c, a) -> (c, b) 29 | snd' f (a, b) = (a, f b) 30 | 31 | -- Similiar to `span`, but put the first unqualified element in the fst position 32 | -- eg. span (/=';') "abc;efg" = ("abc", ";efg") 33 | -- eg. span' (/=';') "abc;efg" = ("abc;", "efg") 34 | span' :: (a -> Bool) -> [a] -> ([a], [a]) 35 | span' f [] = ([], []) 36 | span' f (x:xs) = if f x then fst' (x:) $ span' f xs else ([x], xs) 37 | 38 | 39 | -- Drop the fst and last elements of a list 40 | extract :: [a] -> [a] 41 | extract = tail . init 42 | 43 | -- Find the last n elements of a list 44 | lastN :: Int -> [a] -> [a] 45 | lastN n l = reverse $ take n $ reverse l 46 | 47 | -- race a b l: if a appears first in l, returns LT; else GT. If neither, returns EQ 48 | race :: Eq a => a -> a -> [a] -> Ordering 49 | race _ _ [] = EQ 50 | race x y (a:as) = 51 | if x == y then EQ 52 | else if x == a then LT 53 | else if y == a then GT 54 | else race x y as 55 | 56 | isValidIdentifier :: String -> Bool 57 | isValidIdentifier s@(x:xs) = (isAlpha x || x == '_') && (all (\c -> isAlphaNum c || c == '_') xs) 58 | 59 | type Stack = [] 60 | top = head 61 | pop = tail 62 | push = (:) 63 | -- null 64 | singleton = pure :: a -> Stack a 65 | updateTop f s = push (f $ top s) $ pop s 66 | 67 | while con = until (not . con) 68 | 69 | (<>>) :: (Monad f, Applicative f) => f (a -> b) -> a -> f b 70 | f <>> x = f <*> return x 71 | 72 | getString :: IO String 73 | getString = do 74 | c <- getChar 75 | if isSpace c then return "" else (c:) <$> getString 76 | -------------------------------------------------------------------------------- /Value.hs: -------------------------------------------------------------------------------- 1 | module Value( 2 | Value(..) 3 | )where 4 | 5 | import Definition 6 | import Type 7 | 8 | data Value = LVal Id | RVal Type Literal 9 | 10 | instance Eq Value where 11 | (LVal a) == (LVal b) = a == b 12 | (RVal t1 l1) == (RVal t2 l2) = t1 == t2 && l1 == l2 13 | (LVal _) == (RVal _ _) = error "LVal compared with RVal" 14 | 15 | instance Show Value where 16 | show (RVal t x) = x ++ " :: " ++ show t 17 | show (LVal i) = "Lvalue at " ++ show i 18 | 19 | --------------------------------------------------------------------------------