├── .gitignore ├── LICENSE ├── LibCompiler.hs ├── README.md ├── Setup.hs ├── app └── Main.hs ├── build.sh ├── libcompilerhelper.c ├── scheme2luac.cabal ├── src ├── Assembler.hs ├── CodeGenerator.hs ├── Macro.hs └── Parser2.hs ├── stack.yaml └── test ├── Spec.hs └── testfiles ├── arith1.scm ├── arith2.scm ├── arith3.scm ├── arith4.scm ├── arith5.scm ├── bool1.scm ├── bool2.scm ├── bool3.scm ├── bool4.scm ├── bool5.scm ├── bool6.scm ├── bool7.scm ├── bool8.scm ├── cons1.scm ├── cons2.scm ├── cons3.scm ├── define1.scm ├── define2.scm ├── define3.scm ├── define4.scm ├── define5.scm ├── eval1.result ├── eval1.scm ├── eval2.result ├── eval2.scm ├── eval3.result ├── eval3.scm ├── lambda1.scm ├── lambda2.scm ├── lambda3.scm ├── lambda4.scm ├── lambda5.scm ├── let1.scm ├── let2.scm ├── let3.scm ├── lookup1.scm ├── macro1.scm ├── macro2.scm ├── quote1.scm ├── recursive1.scm ├── recursive2.scm └── tailcall1.scm /.gitignore: -------------------------------------------------------------------------------- 1 | *.h 2 | *.cpp 3 | *.luac 4 | test.scm 5 | test2.scm 6 | .stack-work/ 7 | examples.hs 8 | luac.out 9 | simplecode.lua 10 | sample.hs 11 | *.o 12 | *.so 13 | *.hi 14 | *.lua -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /LibCompiler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} 2 | 3 | module LibCompiler where 4 | 5 | import Data.Maybe 6 | import Foreign.C.Types 7 | import qualified Data.ByteString as BS 8 | import Text.Trifecta (parseByteString, Result(..)) 9 | import Scripting.Lua 10 | import Scripting.Lua.Raw 11 | 12 | import Parser2 13 | import CodeGenerator 14 | 15 | foreign export ccall 16 | compile :: LuaState -> IO CInt 17 | 18 | filename :: BS.ByteString 19 | filename = "/tmp/scheme2luac.luac" 20 | 21 | compile :: LuaState -> IO CInt 22 | compile l = do 23 | -- putStrLn "compiling" -- for debugging 24 | str :: BS.ByteString <- fromJust `fmap` peek l 1 25 | -- print str -- for debugging 26 | let tree = parseByteString parProgram mempty str 27 | let luafunc = fmap evalWrapper tree 28 | case luafunc of 29 | Success x -> writeLuaFunc "/tmp/scheme2luac.luac" (Just x) 30 | Failure _ -> return () 31 | push l filename 32 | return 1 -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Scheme2Luac 2 | ============== 3 | [![made at Recurse Center](https://cdn.rawgit.com/heatherbooker/made_at_rc/master/made_at_RC.svg)](https://www.recurse.com) 4 | 5 | # Overview 6 | A Scheme compiler for the Lua VM, still in progress. It is designed for Lua 5.1 (download [here](https://www.lua.org/download.html)). Build using Haskell's package manager stack (available [here](https://www.haskellstack.org)): 7 | ``` 8 | $ git clone https://github.com/adamrk/scheme2luac.git 9 | $ cd scheme2luac 10 | $ stack build 11 | ``` 12 | 13 | To compile a Scheme script and run in Lua, first check you have Lua 5.1: 14 | ``` 15 | $ lua -v 16 | ``` 17 | This should return 'Lua 5.1.* Copyright (C) 1994-2012 Lua.org, PUR-Rio' or similar. 18 | 19 | Then create scheme script (`test.scm` in this example) and run: 20 | ``` 21 | $ stack exec -- scheme2luac-exe test.scm out.luac 22 | $ lua out.luac 23 | ``` 24 | 25 | # Implemented Components of R5RS Standard 26 | This project aims to implement the [R5RS](http://www.schemers.org/Documents/Standards/R5RS/) scheme standard. 27 | These expressions have been implemented: 28 | * `let` 29 | * `define` 30 | * `lambda` 31 | * `if` 32 | * `quote` 33 | * `eval` 34 | 35 | as well as several primitive functions (see the list of primitives in [CodeGenerator.hs](src/CodeGenerator.hs)). 36 | There is also support for macros using `define-syntax`. 37 | 38 | # Differences from R5RS Standard 39 | * The full heirarchy of numerical types is not supported. All numbers are converted to Lua Numbers which are doubles. 40 | * `quasiquote` is not supported. 41 | * `quoted` symbols do not yet print properly. 42 | * equivalence predicates are not supported. 43 | * input/output ports are not yet supported 44 | * many derived expressions are not supported, but can easily be implemented since we have support for macros. 45 | 46 | # Using 'eval' 47 | If your scheme script uses the `eval` function then it will need to have access to the compiler at runtime. This requires a special compilation process (these commands are in the file [build.sh](build.sh)): 48 | ``` 49 | $ stack build 50 | $ stack exec -- ghc LibCompiler.hs -shared -dynamic -fPIC -o libcompiler.so -lHSrts-ghc8.0.2 51 | $ stack exec -- ghc libcompilerhelper.c -no-hs-main -optl -L. -lcompiler -o lualibhelper.so -shared -fPIC -dynamic 52 | ``` 53 | Note that you will need to change the option `-lHSrts-ghc8.0.2` to match with your version of GHC. Check which version of ghc you're running with `stack exec -- ghc --version`. You will also need the lua header files `lua.h` and `luaconf.h` which are available [here](https://www.lua.org/source/5.1/). Modify the `-L.` flag to the path to these header files. 54 | 55 | This will create two shared libraries: `libcompiler.so` and `lualibhelper.so`. At runtime Lua must be able to access the `lualibhelper.so` library and the path to `libcompiler.so` must be in the `LD_LIBRARY_PATH` environment variable. Otherwise you will see an error like this: 56 | ``` 57 | lua: error loading module 'lualibhelper' from file './lualibhelper.so': 58 | libcompiler.so: cannot open shared object file: No such file or directory 59 | ``` -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Assembler 4 | import CodeGenerator 5 | import System.Environment(getArgs) 6 | 7 | main :: IO () 8 | main = do 9 | xs <- getArgs 10 | if length xs /= 2 11 | then putStrLn "Usage: scheme2luac-exe INPUT_FILE OUTPUT_FILE" 12 | else parseAndWrite (head xs) (head $ tail xs) 13 | -------------------------------------------------------------------------------- /build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | stack build 4 | stack exec -- ghc LibCompiler.hs -shared -dynamic -fPIC -o libcompiler.so -lHSrts-ghc8.0.2 5 | stack exec -- ghc libcompilerhelper.c -no-hs-main -optl -L. -lcompiler -o lualibhelper.so -shared -fPIC -dynamic -------------------------------------------------------------------------------- /libcompilerhelper.c: -------------------------------------------------------------------------------- 1 | #include "LibCompiler_stub.h" 2 | #include "lua.h" 3 | 4 | int hs_init_lua(lua_State *L) 5 | { 6 | hs_init(NULL, NULL); 7 | return 0; 8 | } 9 | 10 | int hs_exit_lua(lua_State *L) 11 | { 12 | hs_exit(); 13 | return 0; 14 | } 15 | 16 | int luaopen_lualibhelper(lua_State *L) 17 | { 18 | lua_pushcfunction(L, compile); 19 | lua_setglobal(L, "compile_in_haskell"); 20 | lua_pushcfunction(L, hs_init_lua); 21 | lua_setglobal(L, "hs_init"); 22 | lua_pushcfunction(L, hs_exit_lua); 23 | lua_setglobal(L, "hs_exit"); 24 | return 0; 25 | } -------------------------------------------------------------------------------- /scheme2luac.cabal: -------------------------------------------------------------------------------- 1 | name: scheme2luac 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/adamrk/scheme2luac#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Adam Bratschi-Kaye 9 | maintainer: ark.email@gmail.com 10 | copyright: 2017 Adam Bratschi-Kaye 11 | category: Compiler 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Assembler 19 | , Parser2 20 | , CodeGenerator 21 | , Macro 22 | build-depends: base >= 4.7 && < 5 23 | , bytestring 24 | , containers 25 | , text 26 | , trifecta 27 | , QuickCheck 28 | , mtl 29 | , hslua 30 | default-language: Haskell2010 31 | 32 | executable scheme2luac-exe 33 | hs-source-dirs: app 34 | main-is: Main.hs 35 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 36 | build-depends: base 37 | , scheme2luac 38 | default-language: Haskell2010 39 | 40 | test-suite scheme2luac-test 41 | type: exitcode-stdio-1.0 42 | hs-source-dirs: test 43 | main-is: Spec.hs 44 | build-depends: base 45 | , scheme2luac 46 | , containers 47 | , hspec 48 | , process 49 | , filepath 50 | , QuickCheck 51 | , directory 52 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 53 | default-language: Haskell2010 54 | 55 | source-repository head 56 | type: git 57 | location: https://github.com/adamrk/scheme2luac 58 | -------------------------------------------------------------------------------- /src/Assembler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, FlexibleInstances #-} 2 | 3 | module Assembler where 4 | 5 | import qualified Data.ByteString.Lazy as BL 6 | import Data.ByteString.Builder (Builder, 7 | word8, 8 | word32LE, 9 | doubleLE, 10 | stringUtf8, 11 | lazyByteString, 12 | toLazyByteString, 13 | ) 14 | import Data.Word (Word8, Word32) 15 | import Data.Text.Lazy (Text, pack) 16 | import qualified Data.Map as M 17 | 18 | data LuaConst = LuaNil | LuaBool Bool | LuaNumber Double | LuaString String 19 | deriving (Eq, Show) 20 | 21 | data LuaFunc = LuaFunc { source :: String, 22 | startline :: Word32, 23 | endline :: Word32, 24 | upvals :: Word8, 25 | params :: Word8, 26 | vararg :: Word8, 27 | maxstack :: Word8, 28 | instructions :: [LuaInstruction], 29 | constants :: [LuaConst], 30 | functions :: [LuaFunc] 31 | } deriving (Eq, Show) 32 | 33 | data LuaOp = OpMove | 34 | OpLoadK | 35 | OpLoadBool | 36 | OpLoadNil | 37 | OpGetUpVal | 38 | OpGetGlobal | 39 | OpGetTable | 40 | OpSetGlobal | 41 | OpSetUpVal | 42 | OpSetTable | 43 | OpNewTable | 44 | OpSelf | 45 | OpAdd | 46 | OpSub | 47 | OpMul | 48 | OpDiv | 49 | OpMod | 50 | OpPow | 51 | OpUnM | 52 | OpNot | 53 | OpLen | 54 | OpConcat | 55 | OpJmp | 56 | OpEq | 57 | OpLT | 58 | OpLE | 59 | OpTest | 60 | OpTestSet | 61 | OpCall | 62 | OpTailCall | 63 | OpReturn | 64 | OpForLoop | 65 | OpForPrep | 66 | OpTForLoop | 67 | OpSetList | 68 | OpClose | 69 | OpClosure | 70 | OpVarArg deriving (Eq, Show, Ord, Enum, Bounded) 71 | 72 | formats :: M.Map LuaOp LuaInstFormats 73 | formats = M.fromList[(OpMove, ABC), 74 | (OpLoadNil, ABC), 75 | (OpLoadK, ABx), 76 | (OpLoadBool, ABC), 77 | (OpGetGlobal, ABx), 78 | (OpSetGlobal, ABx), 79 | (OpGetUpVal, ABC), 80 | (OpSetUpVal, ABC), 81 | (OpGetTable, ABC), 82 | (OpSetTable, ABC), 83 | (OpAdd, ABC), 84 | (OpSub, ABC), 85 | (OpMul, ABC), 86 | (OpDiv, ABC), 87 | (OpMod, ABC), 88 | (OpPow, ABC), 89 | (OpUnM, ABC), 90 | (OpNot, ABC), 91 | (OpLen, ABC), 92 | (OpConcat, ABC), 93 | (OpJmp, AsBx), 94 | (OpCall, ABC), 95 | (OpReturn, ABC), 96 | (OpTailCall, ABC), 97 | (OpVarArg, ABC), 98 | (OpSelf, ABC), 99 | (OpEq, ABC), 100 | (OpLT, ABC), 101 | (OpLE, ABC), 102 | (OpTest, ABC), 103 | (OpTestSet, ABC), 104 | (OpForPrep, AsBx), 105 | (OpForLoop, AsBx), 106 | (OpTForLoop, ABC), 107 | (OpNewTable, ABC), 108 | (OpSetList, ABC), 109 | (OpClosure, ABx), 110 | (OpClose, ABC) 111 | ] 112 | 113 | data LuaInstFormats = ABC | ABx | AsBx deriving (Eq, Show, Ord) 114 | 115 | data LuaInstruction = IABC { op :: LuaOp, iA :: Int, iB :: Int, iC :: Int } | 116 | IABx { op :: LuaOp, iA :: Int, iBx :: Int } | 117 | IAsBx { op :: LuaOp, iA :: Int, isBx :: Int } 118 | deriving (Eq, Show) 119 | 120 | opFormat :: LuaInstruction -> LuaInstFormats 121 | opFormat (IABC _ _ _ _) = ABC 122 | opFormat (IABx _ _ _) = ABx 123 | opFormat (IAsBx _ _ _) = AsBx 124 | 125 | validOpFormat :: LuaInstruction -> Either String Int 126 | validOpFormat ins = if M.lookup opCode formats == Just (opFormat ins) 127 | then Right (fromEnum opCode) 128 | else Left $ "wrong opcode " ++ show ins 129 | where opCode = op ins 130 | 131 | validA :: Int -> Either String Int 132 | validA n = if 0 <= n && n < (2^8) then Right n else 133 | Left $ "invalid A: " ++ show n 134 | 135 | validB :: Int -> Either String Int 136 | validB n = if 0 <= n && n < (2^9) then Right n else 137 | Left $ "invalid B: " ++ show n 138 | 139 | validC :: Int -> Either String Int 140 | validC n = if 0 <= n && n < (2^9) then Right n else 141 | Left $ "invalid C: " ++ show n 142 | 143 | validBx :: Int -> Either String Int 144 | validBx n = if 0 <= n && n < (2^18) then Right n else 145 | Left $ "invalid Bx: " ++ show n 146 | 147 | validsBx :: Int -> Either String Int 148 | validsBx n = if (-131071) <= n && n < (2^18 - 131071) then Right n else 149 | Left $ "invalid sBx: " ++ show n 150 | -- The sBx entry represents negatives with a -131071 bias 151 | 152 | inst2int :: LuaInstruction -> Either String Word32 153 | inst2int ins@(IABC op a b c) = fmap fromIntegral $ sum <$> sequence 154 | [validOpFormat ins, 155 | fmap ((2^6)*) $ validA a, 156 | fmap ((2^14)*) $ validC c, 157 | fmap ((2^23)*) $ validB b] 158 | 159 | inst2int ins@(IABx op a b) = fmap fromIntegral $ sum <$> sequence 160 | [validOpFormat ins, 161 | fmap ((2^6)*) $ validA a, 162 | fmap ((2^14)*) $ validBx b] 163 | 164 | inst2int ins@(IAsBx op a b) = fmap fromIntegral $ sum <$> sequence 165 | [validOpFormat ins, 166 | fmap ((2^6*)) $ validA a, 167 | fmap (((2^14)*) . (+131071)) $ validsBx b] 168 | 169 | -- | The number of registers needed by a B or C code. If the most significant bit 170 | -- is set it indicates a constants and therefore doesn't need a register. 171 | -- 172 | rk :: Int -> Int 173 | rk n = if n >= 256 then 0 else n 174 | 175 | -- | Return the maximum number of registers needed for the instructions 176 | -- 177 | maxReg :: LuaInstruction -> Int 178 | maxReg (IABx _ a _) = a 179 | maxReg (IAsBx OpJmp _ _) = 0 180 | maxReg (IAsBx _ a _) = a + 3 181 | 182 | maxReg (IABC OpMove a b _) = max a b 183 | maxReg (IABC OpLoadNil a b c) = max a b 184 | maxReg (IABC OpUnM a b c) = max a b 185 | maxReg (IABC OpNot a b c) = max a b 186 | maxReg (IABC OpLen a b c) = max a b 187 | maxReg (IABC OpTestSet a b c) = max a b 188 | 189 | maxReg (IABC OpLoadBool a _ _) = a 190 | maxReg (IABC OpGetUpVal a _ _) = a 191 | maxReg (IABC OpSetUpVal a _ _) = a 192 | maxReg (IABC OpTest a _ _) = a 193 | maxReg (IABC OpNewTable a _ _) = a 194 | maxReg (IABC OpClose a _ _) = a 195 | 196 | maxReg (IABC OpGetTable a b c) = maximum [a, b, rk c] 197 | 198 | maxReg (IABC OpSetTable a b c) = maximum [a, rk b, rk c] 199 | maxReg (IABC OpAdd a b c) = maximum [a, rk b, rk c] 200 | maxReg (IABC OpSub a b c) = maximum [a, rk b, rk c] 201 | maxReg (IABC OpMul a b c) = maximum [a, rk b, rk c] 202 | maxReg (IABC OpDiv a b c) = maximum [a, rk b, rk c] 203 | maxReg (IABC OpMod a b c) = maximum [a, rk b, rk c] 204 | maxReg (IABC OpPow a b c) = maximum [a, rk b, rk c] 205 | 206 | maxReg (IABC OpConcat a b c) = maximum [a, b, c] 207 | 208 | maxReg (IABC OpCall a b c) = max (a + c - 2) (a + b - 1) 209 | 210 | maxReg (IABC OpReturn a b _) = a + b - 2 211 | 212 | maxReg (IABC OpTailCall a b _) = a + b - 1 -- could actually return more 213 | maxReg (IABC OpVarArg a b _) = a + b - 1 214 | 215 | maxReg (IABC OpEq _ b c) = max (rk b) (rk c) 216 | maxReg (IABC OpLT _ b c) = max (rk b) (rk c) 217 | maxReg (IABC OpLE _ b c) = max (rk b) (rk c) 218 | 219 | maxReg (IABC OpTForLoop a _ c) = a + c + 2 220 | 221 | maxReg (IABC OpSetList a b _) = a + b 222 | 223 | class ToByteString a where 224 | toBS :: a -> Either String Builder 225 | 226 | instance ToByteString Char where 227 | toBS c = Right $ stringUtf8 $ [c] 228 | 229 | instance ToByteString LuaInstruction where 230 | toBS = (fmap word32LE) . inst2int 231 | 232 | instance ToByteString LuaConst where 233 | toBS LuaNil = Right $ word8 0 234 | toBS (LuaBool b) = Right $ word8 1 `mappend` word32LE (if b then 1 else 0) 235 | -- how is bool is encoded as 0 and 1 in WHAT FORMAT ??? 236 | toBS (LuaNumber n) = Right $ word8 3 `mappend` doubleLE n 237 | toBS (LuaString str) = Right $ word8 4 `mappend` word32LE sz `mappend` strbytes 238 | where sz = fromIntegral $ length str + 1 239 | strbytes = stringUtf8 $ str ++ "\0" 240 | 241 | instance (ToByteString a) => ToByteString [a] where 242 | toBS xs = mappend <$> Right (word32LE (fromIntegral $ length xs)) <*> 243 | (fmap mconcat) (traverse toBS $ xs) 244 | 245 | instance ToByteString LuaFunc where 246 | toBS func = (fmap mconcat) . sequence $ 247 | (toBS $ source func) 248 | : map Right [ word32LE (startline func), 249 | word32LE (endline func), 250 | word8 (upvals func), 251 | word8 (params func), 252 | word8 (vararg func), 253 | word8 (maxstack func)] 254 | ++ [ toBS $ instructions func, 255 | toBS $ constants func, 256 | toBS $ functions func] 257 | ++ map Right [ word32LE 0, 258 | word32LE 0, 259 | word32LE 0] 260 | 261 | 262 | -- luac header for my setup 263 | luaHeader :: [Word8] 264 | luaHeader = [0x1b, 0x4c, 0x75, 0x61] ++ -- Header Signature 265 | [0x51] ++ -- Version Lua 5.1 266 | [0x00] ++ -- Format version official 267 | [0x01] ++ -- little endian 268 | [0x04] ++ -- size of int (bytes) 269 | [0x04] ++ -- size of size_t (bytes) 270 | [0x04] ++ -- size of instructions (bytes) 271 | [0x08] ++ -- size of lua_Number (bytes) 272 | [0x00] -- integral flag for floating point 273 | 274 | finalBuilder :: LuaFunc -> Either String Builder 275 | finalBuilder f = (fmap mconcat) . sequence $ 276 | [ Right $ foldMap word8 luaHeader, -- header 277 | toBS f -- main function 278 | --Just $ foldMap word32LE [0,0,0] -- 3 optional lists set to 0 279 | ] 280 | 281 | -- Write bytestring to file for testing 282 | writeBuilder :: String -> Builder -> IO () 283 | writeBuilder file = BL.writeFile file . toLazyByteString 284 | -------------------------------------------------------------------------------- /src/CodeGenerator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances 2 | , FlexibleInstances #-} 3 | 4 | module CodeGenerator where 5 | 6 | import Assembler 7 | import Parser2 8 | import Macro 9 | import Data.Monoid 10 | import Data.List (foldl', elemIndex) 11 | import Text.Trifecta (parseFromFile, Result(Success, Failure), parseString) 12 | import Data.List (nub) 13 | import Data.Maybe (maybeToList, isJust) 14 | import Control.Monad.State 15 | import qualified Data.Map as M 16 | import qualified Data.Set as S 17 | import Data.Word (Word8) 18 | 19 | -- | An unfinished Lua Function to be built upon. 20 | -- 21 | data PartialLuaFunc = PartialLuaFunc { inst :: [LuaInstruction] 22 | , cnst :: [LuaConst] 23 | , funcs :: [LuaFunc] 24 | , next :: Int 25 | -- ^ next open register 26 | } deriving (Eq, Show) 27 | 28 | emptyPartialFunc = PartialLuaFunc [] [] [] 0 29 | 30 | instance Monoid (State PartialLuaFunc ()) where 31 | mempty = return () 32 | mappend = (>>) 33 | 34 | -- | Find the index of a value in a list and append the value if not present. 35 | -- 36 | addSingle :: (Eq a) => a -> [a] -> (Int, [a]) 37 | addSingle a xs = 38 | let n = length xs 39 | place = elemIndex a xs 40 | in case place of 41 | Nothing -> (n, xs ++ [a]) 42 | Just m -> (m, xs) 43 | 44 | -- | Get index for multiple elements, appending them if not present. 45 | -- 46 | addAndGetNewInx :: (Eq a) => [a] -> [a] -> ([Int], [a]) 47 | addAndGetNewInx (x:xs) ys = 48 | let (n, zs) = addSingle x ys 49 | (ns, ws) = addAndGetNewInx xs zs 50 | in (n:ns, ws) 51 | addAndGetNewInx [] ys = ([], ys) 52 | 53 | addConstants :: [LuaConst] -> State PartialLuaFunc [Int] 54 | addConstants cs = state $ \f -> 55 | let (inxs, newcnst) = addAndGetNewInx cs (cnst f) 56 | newfunc = PartialLuaFunc 57 | { inst = inst f 58 | , cnst = newcnst 59 | , funcs = funcs f 60 | , next = next f 61 | } 62 | in (inxs, newfunc) 63 | 64 | addFunctions :: [LuaFunc] -> State PartialLuaFunc [Int] 65 | addFunctions fs = state $ \f -> 66 | let (inxs, newfs) = addAndGetNewInx fs (funcs f) 67 | newfunc = PartialLuaFunc 68 | { inst = inst f 69 | , cnst = cnst f 70 | , funcs = newfs 71 | , next = next f 72 | } 73 | in (inxs, newfunc) 74 | 75 | addInstructions :: [LuaInstruction] -> State PartialLuaFunc () 76 | addInstructions is = state $ \f -> ((), PartialLuaFunc 77 | { inst = inst f ++ is 78 | , cnst = cnst f 79 | , funcs = funcs f 80 | , next = next f 81 | }) 82 | 83 | -- | Increment the next open register. 84 | -- 85 | incNext :: State PartialLuaFunc () 86 | incNext = state $ \f -> 87 | let newf = PartialLuaFunc {inst=inst f, cnst=cnst f, funcs=funcs f, 88 | next=next f + 1} 89 | in ((), newf) 90 | 91 | -- | Get the next open register 92 | -- 93 | getNext :: State PartialLuaFunc Int 94 | getNext = state $ \f -> (next f, f) 95 | 96 | -- | Set the next open register 97 | -- 98 | setNext :: Int -> State PartialLuaFunc () 99 | setNext n = state $ \f -> ((), PartialLuaFunc 100 | { inst = inst f 101 | , cnst = cnst f 102 | , funcs = funcs f 103 | , next = n 104 | }) 105 | 106 | -- | If the last instruction is a Call, change it to a TailCall. 107 | -- 108 | changeToTail :: State PartialLuaFunc () 109 | changeToTail = state $ \f -> 110 | let 111 | newf = case last $ inst f of 112 | IABC OpCall n v _ -> PartialLuaFunc 113 | { inst = init (inst f) ++ [IABC OpTailCall n v 0] 114 | , cnst = cnst f 115 | , funcs = funcs f 116 | , next = 0 117 | } 118 | _ -> f 119 | in 120 | ((), newf) 121 | 122 | -- | Append instructions, constants, and functions to the partial func to place 123 | -- the evaluated expr in the register indicated by the int 124 | -- 125 | addExpr :: AnnExpr -> State PartialLuaFunc () 126 | addExpr (Var s label) = do 127 | inxs <- addConstants [ LuaString s ] 128 | let i = head inxs 129 | n <- getNext 130 | addInstructions [ IABC OpGetUpVal n 0 0 -- env table 131 | , IABC OpGetTable n n (256 + i) -- get s from env 132 | ] 133 | incNext 134 | 135 | addExpr (Literal (LitBool b)) = 136 | do 137 | n <- getNext 138 | addInstructions [ IABC OpLoadBool n val 0 ] 139 | incNext 140 | where 141 | val = if b then 1 else 0 142 | 143 | addExpr (Literal (LitQuote (SimpleDatum (Literal x)))) = addExpr (Literal x) 144 | 145 | addExpr (Literal (LitQuote (SimpleDatum (Var s ())))) = do 146 | n <- getNext 147 | inx <- addConstants [ LuaNumber 0 148 | , LuaString s 149 | , LuaString "quote" 150 | , LuaString "list" 151 | ] 152 | addInstructions [ IABC OpNewTable n 1 2 -- table for quote 153 | , IABC OpSetTable n (256 + inx !! 0) (256 + inx !! 1) 154 | -- ^ set var in 0 in table 155 | , IABC OpLoadBool (n+1) 1 0 -- load true reg n+1 156 | , IABC OpSetTable n (256 + inx !! 2) (n+1) -- set quote to T 157 | , IABC OpLoadBool (n+1) 0 0 -- load false 158 | , IABC OpSetTable n (256 + inx !! 3) (n+1) -- set list to F 159 | ] 160 | incNext 161 | 162 | addExpr (Literal (LitQuote (CompoundDatum []))) = do 163 | n <- getNext 164 | inx <- addConstants [ LuaString "quote" 165 | , LuaString "list" 166 | ] 167 | addInstructions [ IABC OpNewTable n 0 2 168 | , IABC OpLoadBool (n+1) 1 0 -- load true reg n+1 169 | , IABC OpSetTable n (256 + head inx) (n+1) -- 'quote' = T 170 | , IABC OpSetTable n (256 + inx !! 1) (n+1) -- 'list' = T 171 | ] 172 | incNext 173 | 174 | addExpr (Literal (LitQuote (CompoundDatum (y:ys)))) = do 175 | let x = Literal . LitQuote $ y 176 | let rest = Literal . LitQuote . CompoundDatum $ ys 177 | n <- getNext 178 | inx <- addConstants [ LuaNumber 0 179 | , LuaNumber 1 180 | , LuaString "quote" 181 | , LuaString "list" 182 | ] 183 | addInstructions [ IABC OpNewTable n 2 2 ] 184 | incNext 185 | addExpr x 186 | addExpr rest 187 | addInstructions [ IABC OpSetTable n (256 + inx !! 0) (n+1) -- 0 to car 188 | , IABC OpSetTable n (256 + inx !! 1) (n+2) -- 1 to cdr 189 | , IABC OpLoadBool (n+1) 1 0 -- load T 190 | , IABC OpSetTable n (256 + inx !! 2) (n+1) -- 'quote'=T 191 | , IABC OpSetTable n (256 + inx !! 3) (n+1) -- 'list'=T 192 | ] 193 | setNext $ n+1 194 | 195 | addExpr (Literal cs) = 196 | do 197 | n <- getNext 198 | inx <- addConstants [val] 199 | addInstructions [ IABx OpLoadK n (head inx) ] 200 | incNext 201 | where 202 | val = case cs of 203 | LitChar c -> LuaString [c] 204 | LitStr s -> LuaString s 205 | LitNum m -> LuaNumber m 206 | 207 | addExpr (Call (Var "eval" Global) xs) = 208 | do 209 | n <- getNext 210 | addExpr (Var "eval" Global) 211 | addInstructions [ IAsBx OpJmp 0 0 212 | , IABC OpGetUpVal (n+1) 0 0 -- env in reg n+1 213 | ] 214 | incNext 215 | addExpr (head xs) -- param in reg n+2 216 | addInstructions [ IABC OpCall n 3 3 -- call on env and param 217 | , IABC OpSetUpVal n 0 0 -- set upval to returned env 218 | , IABC OpMove n (n+1) 0 -- move result to n 219 | ] 220 | setNext (n+1) 221 | 222 | addExpr (Call f xs) = 223 | do 224 | n <- getNext 225 | let nvars = length xs 226 | addExpr f 227 | foldMap addExpr xs 228 | addInstructions [ IABC OpCall n (nvars + 1) 2 ] 229 | setNext (n + 1) 230 | 231 | addExpr (Lambda vs b) = 232 | do 233 | n <- getNext 234 | inx <- addFunctions [toFuncLambda vs b] 235 | addInstructions [ IABx OpClosure n (head inx) 236 | , IABC OpGetUpVal 0 0 0 237 | ] 238 | incNext 239 | 240 | addExpr (Cond a b c) = 241 | do 242 | n <- getNext 243 | inx <- addFunctions [toFunc a, toFunc b, toFunc c] 244 | addInstructions [ IABx OpClosure n (inx !! 0) -- cond closure 245 | , IABC OpGetUpVal 0 0 0 -- pass env 246 | , IABC OpCall 0 1 2 -- call cond 247 | , IABC OpLoadBool (n+1) 0 0 -- load false in reg n+1 248 | , IABC OpEq 1 (n+1) n -- skip if reg n is not false 249 | , IAsBx OpJmp 0 3 -- jump to false case 250 | , IABx OpClosure n (inx !! 1) -- exp1 closure 251 | , IABC OpGetUpVal 0 0 0 -- pass in env 252 | , IAsBx OpJmp 0 2 -- jump to return 253 | , IABx OpClosure n (inx !! 2) -- exp2 closure 254 | , IABC OpGetUpVal 0 0 0 -- pass in env 255 | , IABC OpCall n 1 0 -- get expr 256 | ] 257 | incNext 258 | 259 | 260 | completeFunc :: String -> PartialLuaFunc -> LuaFunc 261 | completeFunc s f = LuaFunc { startline=0, endline=0, upvals=1, params=0, 262 | vararg=0, source=s, instructions=inst f, 263 | constants=cnst f, functions=funcs f, 264 | maxstack = fromIntegral . (+1) . maximum $ 265 | map maxReg (inst f) 266 | } 267 | 268 | completeFuncParamUpval :: Word8 -> Word8 -> String -> PartialLuaFunc -> LuaFunc 269 | completeFuncParamUpval p u s f = 270 | LuaFunc { startline=0, endline=0, upvals=u, params=p, 271 | vararg=0, source=s, instructions=inst f, 272 | constants=cnst f, functions=funcs f, 273 | maxstack= fromIntegral . (+1) . maximum $ 274 | map maxReg (inst f) 275 | } 276 | 277 | completeTopLevel :: PartialLuaFunc -> LuaFunc 278 | completeTopLevel f = LuaFunc { startline=0, endline=0, upvals=0, params=0, 279 | vararg=0, source="@main\0", instructions = inst f, 280 | constants = cnst f, functions = funcs f, 281 | maxstack = fromIntegral . (+1) . maximum $ 282 | map maxReg (inst f) 283 | } 284 | 285 | -- | Converts an annotated scheme expression into a Lua chunk. The chunk takes 286 | -- no parameters and a single upval which is the evaluation environment. When 287 | -- called the chunk will return the value that the expression evaluates to. 288 | -- 289 | toFunc :: AnnExpr -> LuaFunc 290 | toFunc x = completeFunc name $ 291 | execState (do 292 | n <- getNext 293 | addExpr x 294 | changeToTail 295 | addInstructions [IABC OpReturn n 0 0]) 296 | emptyPartialFunc 297 | where 298 | name = case x of 299 | (Var s _) -> "@var_" ++ show s ++ "\0" 300 | (Literal (LitBool b)) -> "@litBool_" ++ show b ++ "\0" 301 | (Literal (LitChar c)) -> "@litChar_" ++ show c ++ "\0" 302 | (Literal (LitNum n)) -> "@litNum_" ++ show n ++ "\0" 303 | (Literal (LitStr s)) -> "@litStr_" ++ show s ++ "\0" 304 | (Call _ _) -> "@call\0" 305 | (Lambda _ _) -> "@lambda\0" 306 | (Cond _ _ _) -> "@cond\0" 307 | (Assign _ _) -> "@assign\0" 308 | 309 | -- |Turn a def into a lua chunk by evaluating the expression and then binding it 310 | -- to the proper variable name in the current environment. 311 | -- 312 | toFuncDef :: AnnDef -> LuaFunc 313 | toFuncDef x = completeFunc name $ 314 | execState (do 315 | addDef x 316 | addInstructions [IABC OpReturn 0 1 0]) 317 | emptyPartialFunc 318 | where 319 | name = case x of 320 | (Def1 x _) -> "@def1_" ++ show x ++ "\0" 321 | (Def2 x _ _) -> "@def2_" ++ show x ++ "\0" 322 | (Def3 _) -> "@def3\0" 323 | 324 | addLambda :: [Expr] -> AnnBody -> State PartialLuaFunc () 325 | addLambda vars f = do 326 | n <- getNext 327 | let nVars = length vars 328 | let varStart = n - nVars 329 | freeVarInxs <- addConstants 330 | (map LuaString . S.toList $ freeNonGlobalVars (Lambda vars f)) 331 | varInxs <- addConstants $ map (\(Var s _) -> LuaString s) vars 332 | funcInxs <- addFunctions [toFuncBody f] 333 | addInstructions $ [ IABC OpNewTable n 0 0 -- new env 334 | , IABC OpGetUpVal (n+1) 0 0 -- old env 335 | ] ++ 336 | (concatMap (\x -> [ IABC OpGetTable (n+2) (n+1) (256+x) --copy var to n+2 337 | , IABC OpSetTable n (256+x) (n+2) -- copy n+2 to new table 338 | ]) freeVarInxs) ++ 339 | (concatMap (\i -> [ IABC OpSetTable n (256+(varInxs !! i)) (varStart + i) ]) 340 | -- ^ insert ith variable in env at ith variable expr 341 | [0..nVars - 1]) ++ 342 | [ IABx OpClosure (n+1) 0 -- closure for f 343 | , IABC OpMove 0 n 0 -- pass in new env 344 | , IABC OpCall (n+1) 1 0 -- call f 345 | ] 346 | 347 | toFuncLambda :: [Expr] -> AnnBody -> LuaFunc 348 | toFuncLambda vars f = 349 | completeFuncParamUpval (fromIntegral $ length vars) 1 "@lambdabody\0" $ 350 | execState (do 351 | let n = length vars 352 | setNext n 353 | addLambda vars f 354 | changeToTail 355 | addInstructions [ IABC OpReturn n 0 0 ] 356 | ) emptyPartialFunc 357 | 358 | -- |The lua chunk that evaluates a body simply evaluates each def or expr in 359 | -- turn and then returns the last one. 360 | -- 361 | addBody :: AnnBody -> State PartialLuaFunc () 362 | addBody (Body ds es) = do 363 | n <- getNext 364 | dinx <- addFunctions (map toFuncDef ds) 365 | einx <- addFunctions (map toFunc es) 366 | mapM_ (\i -> addInstructions [ IABx OpClosure n i 367 | , IABC OpGetUpVal 0 0 0 368 | , IABC OpCall n 1 2 369 | ]) (dinx ++ einx) 370 | 371 | toFuncBody :: AnnBody -> LuaFunc 372 | toFuncBody b = completeFunc "@inBody\0" $ 373 | execState (do 374 | n <- getNext 375 | addBody b 376 | changeToTail 377 | addInstructions [IABC OpReturn n 0 0] 378 | ) emptyPartialFunc 379 | 380 | -- | Add a definition to a PartialFunc. 381 | -- 382 | addDef :: AnnDef -> State PartialLuaFunc () 383 | addDef (Def1 (Var x _) e) = do 384 | inx <- addConstants [LuaString x] 385 | n <- getNext 386 | addInstructions [ IABC OpGetUpVal n 0 0 ] 387 | incNext 388 | addExpr e 389 | addInstructions [ IABC OpSetTable n (256 + head inx) (n+1) ] 390 | setNext n 391 | 392 | addDef (Def2 x vs b) = addDef $ Def1 x (Lambda vs b) 393 | addDef (Def3 ds) = foldMap addDef ds 394 | 395 | addProgram :: [CommOrDef] -> State PartialLuaFunc () 396 | addProgram xs = do 397 | finxs <- addFunctions $ map tofunc axs 398 | ginxs <- addFunctions $ map snd prims 399 | cinxs <- addConstants $ map (LuaString . fst) prims 400 | n <- getNext 401 | traverse (\(ci, fi) -> addInstructions [ IABx OpClosure n fi 402 | , IABC OpSetTable 0 (256 + ci) n ]) 403 | (zip cinxs ginxs) -- ^ assume env in table in 0 404 | serfinxs <- addFunctions $ map snd serialized 405 | sercinxs <- addConstants $ map (LuaString . fst) serialized 406 | n <- getNext 407 | traverse (\(ci, fi) -> addInstructions [ IABx OpClosure n fi 408 | , IABx OpSetGlobal n ci ]) 409 | (zip sercinxs serfinxs) -- ^ serialization funcs in globals 410 | traverse (\fi -> addInstructions [ IABx OpClosure n fi 411 | , IABC OpMove 0 0 0 -- assume env table in 0 412 | , IABC OpCall n 1 2]) finxs 413 | return () 414 | where 415 | axs = annotateProgram xs -- annotate the parse tree 416 | freeVars = allVars xs -- search for free variables 417 | prims = filter ((`S.member` freeVars) . fst) primitives -- add primitives 418 | serialized = if "eval" `S.member` freeVars then serialize_funcs else [] 419 | tofunc (Comm x) = toFunc x 420 | tofunc (Def x) = toFuncDef x 421 | 422 | toFuncProgram :: [CommOrDef] -> LuaFunc 423 | toFuncProgram xs = completeFunc "@main\0" $ execState (do 424 | pinx <- addConstants [LuaString "print"] 425 | addInstructions [ IABC OpNewTable 0 0 0 426 | , IABx OpGetGlobal 1 (head pinx) ] 427 | setNext 2 428 | addProgram (preProcess xs) 429 | addInstructions [ IABC OpCall 1 2 1 430 | , IABC OpReturn 0 1 0 ]) 431 | emptyPartialFunc 432 | 433 | preProcess :: [CommOrDef] -> [CommOrDef] 434 | preProcess = applyMacrosProgram defaultMacros 435 | 436 | toFuncWithoutEnv :: [CommOrDef] -> LuaFunc 437 | toFuncWithoutEnv xs = completeFuncParamUpval 1 0 "@in_eval\0" $ execState (do 438 | setNext 1 439 | addProgram $ preProcess xs 440 | addInstructions [ IABC OpReturn 0 3 0 ] -- return env and result 441 | ) emptyPartialFunc 442 | 443 | evalWrapper :: [CommOrDef] -> LuaFunc 444 | evalWrapper xs = completeTopLevel $ execState (do 445 | inxs <- addFunctions [toFuncWithoutEnv xs] 446 | cinxs <- addConstants [LuaString "func_from_haskell"] 447 | addInstructions [ IABx OpClosure 0 (head inxs) 448 | , IABx OpSetGlobal 0 (head cinxs) 449 | , IABC OpReturn 0 1 0 450 | ] 451 | ) emptyPartialFunc 452 | 453 | ------------------- Functions to load at beginning ------------------------ 454 | 455 | primitives :: [(String, LuaFunc)] 456 | primitives = [ ("*", LuaFunc {startline=0, endline=0, upvals=0, params=0, 457 | vararg=2, maxstack=7, source="@prim*\0", 458 | instructions=[ 459 | IABC OpNewTable 0 0 0 -- to hold values 460 | , IABC OpVarArg 1 0 0 -- args in reg 1 and up 461 | , IABC OpSetList 0 0 1 -- save args to table 462 | , IABx OpLoadK 1 0 -- load 1 (loop init) 463 | , IABC OpLen 2 0 0 -- load length (loop max) 464 | , IABx OpLoadK 3 0 -- load 1 (loop step) 465 | , IABx OpLoadK 5 0 -- load unit 466 | , IAsBx OpForPrep 1 2 467 | , IABC OpGetTable 6 0 1 -- next arg 468 | , IABC OpMul 5 5 6 -- product -> r5 469 | , IAsBx OpForLoop 1 (-3) 470 | , IABC OpReturn 5 2 0 -- return 471 | ], 472 | constants= [ LuaNumber 1 473 | ], 474 | functions= []}) 475 | , ("+", LuaFunc {startline=0, endline=0, upvals=0, params=0, 476 | vararg=2, maxstack=7, source="@prim+\0", 477 | instructions=[ 478 | IABC OpNewTable 0 0 0 479 | , IABC OpVarArg 1 0 0 480 | , IABC OpSetList 0 0 1 481 | , IABx OpLoadK 1 1 482 | , IABC OpLen 2 0 0 483 | , IABx OpLoadK 3 1 484 | , IABx OpLoadK 5 0 485 | , IAsBx OpForPrep 1 2 486 | , IABC OpGetTable 6 0 1 487 | , IABC OpAdd 5 5 6 488 | , IAsBx OpForLoop 1 (-3) 489 | , IABC OpReturn 5 2 0 490 | ], 491 | 492 | constants= [ LuaNumber 0 493 | , LuaNumber 1 494 | ], 495 | 496 | functions= []}) 497 | , ("-", LuaFunc {startline=0, endline=0, upvals=0, params=0, 498 | vararg=2, maxstack=9, source="@prim-\0", 499 | instructions=[ 500 | IABC OpNewTable 0 0 0 -- table for args 501 | , IABC OpVarArg 1 0 0 -- load arguments 502 | , IABC OpSetList 0 0 1 -- save args in table 503 | , IABx OpLoadK 1 2 -- 2 -> reg 1 (loop init) 504 | , IABC OpLen 2 0 0 -- #args -> reg 2 (loop max) 505 | , IABx OpLoadK 3 1 -- 1 -> reg 3 (loop step) 506 | , IABC OpGetTable 5 0 257 -- first arg -> reg 5 507 | , IABC OpEq 0 3 2 -- if #args = 1 pc+ 508 | , IAsBx OpJmp 0 2 -- jump to for loop 509 | , IABC OpUnM 5 5 0 -- negate first arg 510 | , IAsBx OpJmp 0 4 -- jump to return 511 | , IAsBx OpForPrep 1 2 512 | , IABC OpGetTable 6 0 1 -- load table value 513 | , IABC OpSub 5 5 6 -- r5 = r5 - r6 514 | , IAsBx OpForLoop 1 (-3) 515 | , IABC OpReturn 5 2 0 516 | ], 517 | 518 | constants= [ LuaNumber 0 519 | , LuaNumber 1 520 | , LuaNumber 2 521 | ], 522 | 523 | functions= []}) 524 | , ("quotient", LuaFunc { startline=0, endline=0, upvals=0, 525 | params=2, vararg=0, maxstack = 2, 526 | source="@prim-quotient\0", 527 | instructions = [ IABC OpDiv 0 0 1 528 | , IABC OpReturn 0 2 0 529 | ], 530 | constants = [], 531 | functions = []}) 532 | , ("modulo", LuaFunc { startline=0, endline=0, upvals=0, 533 | params=2, vararg=0, maxstack = 2, 534 | source="@prim-modulo\0", 535 | instructions = [ IABC OpMod 0 0 1 536 | , IABC OpReturn 0 2 0 537 | ], 538 | constants = [], 539 | functions = []}) 540 | , ("expt", LuaFunc { startline=0, endline=0, upvals=0, 541 | params=2, vararg=0, maxstack = 2, 542 | source="@prim-expt\0", 543 | instructions = [ IABC OpPow 0 0 1 544 | , IABC OpReturn 0 2 0 545 | ], 546 | constants = [], 547 | functions = []}) 548 | , ("not", LuaFunc { startline=0, endline=0, upvals=0, 549 | params=1, vararg=0, maxstack = 1, 550 | source="@prim-not\0", 551 | instructions = [ IABC OpNot 0 0 0 552 | , IABC OpReturn 0 2 0 553 | ], 554 | constants = [], 555 | functions = []}) 556 | , ("=", LuaFunc { startline=0, endline=0, upvals=0, 557 | params=2, vararg=0, maxstack = 2, 558 | source="@prim=\0", 559 | instructions = [ IABC OpEq 0 0 1 -- if eq then PC++ 560 | , IAsBx OpJmp 0 1 -- jmp requred after eq 561 | , IABC OpLoadBool 0 1 1 -- load true, PC++ 562 | , IABC OpLoadBool 0 0 0 -- load false 563 | , IABC OpReturn 0 2 0 564 | ], 565 | constants = [], 566 | functions = []}) 567 | , ("<", LuaFunc { startline=0, endline=0, upvals=0, 568 | params=2, vararg=0, maxstack = 2, 569 | source="@prim<\0", 570 | instructions = [ IABC OpLT 0 0 1 -- if lt then PC++ 571 | , IAsBx OpJmp 0 1 -- jmp requred after lt 572 | , IABC OpLoadBool 0 1 1 -- load true, PC++ 573 | , IABC OpLoadBool 0 0 0 -- load false 574 | , IABC OpReturn 0 2 0 575 | ], 576 | constants = [], 577 | functions = []}) 578 | , (">", LuaFunc { startline=0, endline=0, upvals=0, 579 | params=2, vararg=0, maxstack = 2, 580 | source="@prim>\0", 581 | instructions = [ IABC OpLT 0 1 0 -- if gt then PC++ 582 | , IAsBx OpJmp 0 1 -- jmp requred after gt 583 | , IABC OpLoadBool 0 1 1 -- load true, PC++ 584 | , IABC OpLoadBool 0 0 0 -- load false 585 | , IABC OpReturn 0 2 0 586 | ], 587 | constants = [], 588 | functions = []}) 589 | , ("force", LuaFunc { startline=0, endline=0, upvals=0, 590 | params=1, vararg=0, maxstack=1, 591 | source="@prim_force\0", 592 | instructions = [ IABC OpTailCall 0 1 0 593 | , IABC OpReturn 0 0 0 594 | ], 595 | constants = [], 596 | functions = []}) 597 | , ("eval", LuaFunc { startline=0, endline=0, upvals=0, 598 | params=2, vararg=0, maxstack=6, 599 | source="@prim_eval\0", 600 | instructions = [ IABx OpGetGlobal 2 0 -- 'require' 601 | , IABx OpLoadK 3 1 -- 'lualibhelper' 602 | , IABC OpCall 2 2 1 -- req lualib 603 | , IABx OpGetGlobal 2 2 -- 'hs_init' 604 | , IABC OpCall 2 1 1 -- call hs_init 605 | , IABx OpGetGlobal 2 3 -- 'dofile' 606 | , IABx OpGetGlobal 3 4 -- 'compile_in_haskell' 607 | , IABx OpGetGlobal 4 5 -- 'serialize' 608 | , IABC OpMove 5 1 0 -- param1 -> reg 5 609 | , IABC OpCall 4 2 2 -- call serialize 610 | , IABC OpCall 3 2 2 -- call compile_in_haskell 611 | , IABC OpCall 2 2 1 -- call dofile 612 | , IABx OpGetGlobal 1 6 -- 'hs_exit' 613 | , IABC OpCall 1 1 1 -- call hs_exit 614 | , IABx OpGetGlobal 1 7 -- 'func_from_haskell' 615 | , IAsBx OpJmp 0 0 616 | , IABC OpMove 2 0 0 -- env -> reg 2 617 | , IABC OpTailCall 1 2 0 -- call with env 618 | , IABC OpReturn 1 0 0 619 | ], 620 | constants = [ LuaString "require" 621 | , LuaString "lualibhelper" 622 | , LuaString "hs_init" 623 | , LuaString "dofile" 624 | , LuaString "compile_in_haskell" 625 | , LuaString "serialize" 626 | , LuaString "hs_exit" 627 | , LuaString "func_from_haskell" 628 | ], 629 | functions = []}) 630 | , ("cons", LuaFunc{ startline=0, endline=0, upvals=0, 631 | params=2, vararg=0, maxstack=3, 632 | source="@prim_cons\0", 633 | instructions = [ IABC OpNewTable 2 2 0 634 | , IABC OpSetTable 2 256 0 635 | , IABC OpSetTable 2 257 1 636 | , IABC OpReturn 2 2 0 637 | ], 638 | constants = [ LuaNumber 0 639 | , LuaNumber 1 640 | ], 641 | functions = []}) 642 | , ("car", LuaFunc { startline=0, endline=0, upvals=0, 643 | params=1, vararg=0, maxstack=1, 644 | source="@prim_car\0", 645 | instructions = [ IABC OpGetTable 0 0 256 646 | , IABC OpReturn 0 2 0 647 | ], 648 | constants = [ LuaNumber 0 ], 649 | functions = []}) 650 | , ("cdr", LuaFunc { startline=0, endline=0, upvals=0, 651 | params=1, vararg=0, maxstack=1, 652 | source="@prim_cdr\0", 653 | instructions = [ IABC OpGetTable 0 0 256 654 | , IABC OpReturn 0 2 0 655 | ], 656 | constants = [ LuaNumber 1 ], 657 | functions = []}) 658 | ] 659 | 660 | serialize_funcs = 661 | [ ("serialize", LuaFunc { startline=0, endline=0, upvals=0, 662 | params=1, vararg=0, maxstack=3, 663 | source="@serialize\0", 664 | instructions = [ IABx OpGetGlobal 1 0 -- 'type' 665 | , IAsBx OpJmp 0 0 666 | , IABC OpMove 2 0 0 -- param to reg 2 667 | , IABC OpCall 1 2 2 -- call type on param 668 | , IABx OpLoadK 2 9 -- 'nil' 669 | , IABC OpEq 0 1 2 -- if type is nil pc++ 670 | , IAsBx OpJmp 0 2 -- to next loadk 671 | , IABx OpLoadK 1 10 -- load empty string 672 | , IAsBx OpJmp 0 22 -- to return 673 | , IABx OpLoadK 2 1 -- 'string' 674 | , IABC OpEq 0 1 2 -- if type is string pc++ 675 | , IAsBx OpJmp 0 2 -- to next loadk 676 | , IABx OpGetGlobal 1 5 -- get ser_str 677 | , IAsBx OpJmp 0 15 -- jump to last move 678 | , IABx OpLoadK 2 2 -- 'boolean' 679 | , IABC OpEq 0 1 2 -- if type is bool pc++ 680 | , IAsBx OpJmp 0 2 -- jump to next load 681 | , IABx OpGetGlobal 1 6 -- get ser_bool 682 | , IAsBx OpJmp 0 10 -- to last move 683 | , IABx OpLoadK 2 3 -- 'number' 684 | , IABC OpEq 0 1 2 -- if type is num pc++ 685 | , IAsBx OpJmp 0 2 -- to next load 686 | , IABx OpGetGlobal 1 7 -- get ser_num 687 | , IAsBx OpJmp 0 5 -- to last move 688 | , IABx OpLoadK 2 4 -- 'table' 689 | , IABC OpEq 0 1 2 -- if type is table pc++ 690 | , IAsBx OpJmp 0 2 -- to move 691 | , IABx OpGetGlobal 1 8 --get ser_quote 692 | , IAsBx OpJmp 0 0 693 | , IABC OpMove 2 0 0 -- param to 2 694 | , IABC OpTailCall 1 0 0 -- call ser_ on param 695 | , IABC OpReturn 1 0 0 696 | ], 697 | constants = [ LuaString "type" 698 | , LuaString "string" 699 | , LuaString "boolean" 700 | , LuaString "number" 701 | , LuaString "table" 702 | , LuaString "ser_str" 703 | , LuaString "ser_bool" 704 | , LuaString "ser_num" 705 | , LuaString "ser_quote" 706 | , LuaString "nil" 707 | , LuaString "" 708 | ], 709 | functions = []}) 710 | , ("ser_bool", LuaFunc { startline=0, endline=0, upvals=0, 711 | params=1, vararg=0, maxstack=2, 712 | source="@ser_bool\0", 713 | instructions = [ IABC OpLoadBool 1 1 0 -- load T 714 | , IABC OpEq 0 0 1 -- if param is T pc++ 715 | , IAsBx OpJmp 0 2 -- to next loadbool 716 | , IABx OpLoadK 0 0 -- '#t' 717 | , IAsBx OpJmp 0 4 -- to return 718 | , IABC OpLoadBool 1 0 0 -- load F 719 | , IABC OpEq 0 0 1 -- if param is F pc++ 720 | , IAsBx OpJmp 0 1 -- to return 721 | , IABx OpLoadK 0 1 -- '#f' 722 | , IABC OpReturn 0 2 0 -- return reg 0 723 | ], 724 | constants = [ LuaString "#t" 725 | , LuaString "#f" 726 | ], 727 | functions = []}) 728 | -- | TODO: change this from just the %f format so that we can 729 | -- actually properly pass numbers 730 | -- 731 | , ("ser_num", LuaFunc { startline=0, endline=0, upvals=0, 732 | params=1, vararg=0, maxstack=4, 733 | source="@ser_num\0", 734 | instructions = [ IABx OpGetGlobal 1 0 735 | , IABC OpGetTable 1 1 257 736 | , IABx OpLoadK 2 2 737 | , IABC OpMove 3 0 0 738 | , IABC OpCall 1 3 2 739 | , IABC OpReturn 1 2 0 740 | ], 741 | constants = [ LuaString "string" 742 | , LuaString "format" 743 | , LuaString "%f" 744 | ], 745 | functions = []}) 746 | , ("ser_quote", LuaFunc { startline=0, endline=0, upvals=0, 747 | params=1, vararg=0, maxstack=11, 748 | source="@ser_quote\0", 749 | instructions = [ IABC OpGetTable 1 0 256 -- get 'list' 750 | , IABC OpLoadBool 2 1 0 -- load true 751 | , IABC OpEq 0 1 2 -- if list=T then pc++ 752 | , IAsBx OpJmp 0 15 -- not list -> last get tab 753 | , IABx OpLoadK 1 4 -- '(' to acc (reg 1) 754 | , IABx OpClosure 4 0 -- loop closure 755 | , IAsBx OpJmp 0 0 -- noop 756 | , IABC OpMove 6 0 0 757 | -- ^ move param to cdr spot (reg 5) 758 | , IAsBx OpJmp 0 3 -- to tforloop 759 | , IABC OpMove 3 8 0 -- move str to 3 760 | , IABx OpLoadK 2 6 -- space -> reg 2 761 | , IABC OpConcat 1 1 3 -- concat acc with str 762 | , IABC OpTForLoop 4 0 2 -- call closure 763 | , IAsBx OpJmp 0 (-5) -- if not nil go back 764 | , IABx OpLoadK 2 6 -- space -> reg 2 765 | , IABC OpMove 3 8 0 -- move last str 766 | , IABx OpLoadK 4 5 -- load ')' 767 | , IABC OpConcat 1 1 4 -- concat acc, str, ')' 768 | , IAsBx OpJmp 0 1 -- to return 769 | , IABC OpGetTable 1 0 257 -- get index 0 770 | , IABC OpReturn 1 2 0 771 | ], 772 | constants = [ LuaString "list" 773 | , LuaNumber 0 774 | , LuaNumber 1 775 | , LuaString "ser_quote" 776 | , LuaString "(" 777 | , LuaString ")" 778 | , LuaString " " 779 | ], 780 | functions = [ LuaFunc { startline=0, endline=0, upvals=0, 781 | params=2, vararg=0, maxstack=4, 782 | source="@ser_quote_loop\0", 783 | instructions = [ IABx OpGetGlobal 2 0 -- 'serialize' 784 | , IABC OpGetTable 3 1 257 -- car 785 | , IABC OpCall 2 2 2 -- serialize car 786 | , IABC OpGetTable 1 1 258 -- cdr 787 | , IABC OpReturn 1 3 0 -- return cdr, str 788 | ], 789 | constants = [ LuaString "serialize" 790 | , LuaNumber 0 791 | , LuaNumber 1 792 | ], 793 | functions = []}]}) 794 | -- , ("serialize_literal", 795 | -- LuaFunc { startline=0, endline=0, upvals=0, 796 | -- params=1, vararg=0, maxstack=1, 797 | -- source="@prim_serialize_lit\0", 798 | -- instructions = [ IABC OpGetTable 1 0 256 799 | -- , ] 800 | -- constants = [ LuaString "type" 801 | -- , LuaString "bool" 802 | -- , LuaString "num" 803 | -- , LuaString ""]} 804 | -- , ("serialize_quote", LuaFunc { startline=0, endline=0, upvals=0, 805 | -- params=1, vararg=0, maxstack=???, 806 | -- source="@prim_serialize\0", 807 | -- instructions = [ IABC OpGetTable 1 0 257 808 | -- , IABC OpLoadBool 2 1 0 809 | -- , IABC OpEq ? 1 2 810 | -- , ] 811 | -- constants = [ LuaNumber 0 812 | -- , LuaString "list" 813 | -- ]} 814 | ] 815 | 816 | 817 | ------------------------- Main Functions ----------------------------- 818 | compileFromFile :: String -> IO (Maybe LuaFunc) 819 | compileFromFile = (fmap . fmap) toFuncProgram . parseFromFile parProgram 820 | 821 | parseAndWrite :: String -> String -> IO () 822 | parseAndWrite inp out = compileFromFile inp >>= writeLuaFunc out 823 | 824 | maybeToEither :: Maybe a -> Either String a 825 | maybeToEither (Just a) = Right a 826 | maybeToEither Nothing = Left "failed to parse file" 827 | 828 | writeLuaFunc :: String -> Maybe LuaFunc -> IO () 829 | writeLuaFunc f ml = case maybeToEither ml >>= finalBuilder of 830 | Right bs -> writeBuilder f bs 831 | Left s -> print s -------------------------------------------------------------------------------- /src/Macro.hs: -------------------------------------------------------------------------------- 1 | module Macro where 2 | 3 | import Parser2 4 | import qualified Data.Map as M 5 | import Data.Maybe (catMaybes) 6 | import Control.Applicative (liftA2) 7 | 8 | -- | Convert an expression to pure datum. TODO: change the name of this 9 | -- function. 10 | -- 11 | convMacro :: GenExpr () -> GenDatum () 12 | convMacro (Var s ()) = SimpleDatum (Var s ()) 13 | convMacro (Literal (LitQuote x)) = 14 | CompoundDatum $ (SimpleDatum $ Var "quote" ()) : [x] 15 | convMacro (Literal x) = SimpleDatum (Literal x) 16 | convMacro (Call x xs) = CompoundDatum $ convMacro x : map convMacro xs 17 | convMacro (Lambda vs b) = 18 | let bs = convMacroBody b 19 | in CompoundDatum $ SimpleDatum (Var "lambda" ()) 20 | : CompoundDatum (map convMacro vs) : bs 21 | convMacro (Cond a b c) = CompoundDatum $ SimpleDatum (Var "if" ()) 22 | : convMacro a : convMacro b : [convMacro c] 23 | convMacro (Assign a b) = CompoundDatum $ SimpleDatum (Var "set!" ()) 24 | : convMacro a : [convMacro b] 25 | 26 | convMacroBody :: GenBody () -> [GenDatum ()] 27 | convMacroBody (Body ds es) = map convMacroDef ds ++ map convMacro es 28 | 29 | convMacroDef :: GenDef () -> GenDatum () 30 | convMacroDef (Def1 x y) = CompoundDatum $ [ SimpleDatum (Var "define" ()) 31 | , SimpleDatum x 32 | , convMacro y 33 | ] 34 | convMacroDef (Def2 x ys b) = CompoundDatum $ [ SimpleDatum (Var "define" ()) 35 | , CompoundDatum $ SimpleDatum x : 36 | map SimpleDatum ys 37 | ] ++ convMacroBody b 38 | convMacroDef (Def3 ds) = CompoundDatum $ SimpleDatum (Var "begin" ()) : 39 | map convMacroDef ds 40 | 41 | -- | Result of matching a pattern with a datum. If a variable appears without 42 | -- in ellipses in the pattern it will show up in the map with the datum it 43 | -- matched against. If a variable has ellipses it will show up in the lists with 44 | -- each datum it matched with. 45 | -- 46 | data Matched a = Matched (M.Map String (GenDatum a)) [Matched a] 47 | deriving (Eq, Show) 48 | 49 | -- | zipWith, but we take values from the longer list after the shorter list has 50 | -- ended. 51 | -- 52 | extZipWith :: (a -> a -> a) -> [a] -> [a] -> [a] 53 | extZipWith f (b:bs) (c:cs) = f b c : extZipWith f bs cs 54 | extZipWith f [] cs = cs 55 | extZipWith f bs [] = bs 56 | 57 | -- | Combine two match results 58 | -- 59 | combine :: Matched a -> Matched a -> Matched a 60 | combine (Matched m1 l1) (Matched m2 l2) = 61 | Matched (M.union m1 m2) (extZipWith combine l1 l2) 62 | 63 | -- | Fills in a pattern from a GenDatum that matches it 64 | -- 65 | match :: Pattern -> GenDatum a -> Maybe (Matched a) 66 | match (PatEllipses patterns pattern) (CompoundDatum ds) = 67 | let n = length patterns 68 | in if length ds < n 69 | then Nothing 70 | else do 71 | a <- (match (PatternComp patterns) (CompoundDatum (take n ds))) 72 | b <- Matched M.empty <$> (traverse (match pattern) (drop n ds)) 73 | return $ combine a b 74 | match (PatternComp (x:xs)) (CompoundDatum (d:ds)) = 75 | combine <$> (match x d) <*> (match (PatternComp xs) (CompoundDatum ds)) 76 | match (PatternComp []) (CompoundDatum []) = Just $ Matched M.empty [] 77 | match (PatternComp []) _ = Nothing 78 | match (PatternDat x) (SimpleDatum (Literal y)) = 79 | if x == y 80 | then Just $ Matched M.empty [] 81 | else Nothing 82 | match (PatternId s) x = Just $ Matched (M.singleton s x) [] 83 | match (PatternLit s) (SimpleDatum (Var x _)) = if x == s 84 | then Just $ Matched M.empty [] 85 | else Nothing 86 | match _ _ = Nothing 87 | 88 | -- | Fill in template Element with matched data. If it is an ellipses element, 89 | -- fill in with each Matched in the list and take all the results that worked. 90 | -- 91 | useTemplateElem :: TempElement -> Matched () -> Maybe [GenDatum ()] 92 | useTemplateElem (PureTemp t) m = pure <$> useTemplate t m 93 | useTemplateElem (TempEllipses t) (Matched _ ls) = 94 | Just . catMaybes $ map (useTemplate t) ls 95 | 96 | -- | fill in template with Matched data. 97 | useTemplate :: Template -> Matched () -> Maybe (GenDatum ()) 98 | useTemplate (TemplateComp xs) m = 99 | CompoundDatum . concat <$> mapM (flip useTemplateElem m) xs 100 | useTemplate (TemplateDat x) _ = Just $ SimpleDatum (Literal x) 101 | useTemplate (TemplateId s) (Matched m l) = M.lookup s m 102 | useTemplate (TemplateLit s) _ = Just $ SimpleDatum (Var s ()) 103 | 104 | -- | Match against the pattern in the SyntaxRule and then fill in the template 105 | -- from the match. 106 | -- 107 | applyMacro :: SyntaxRule -> GenDatum () -> Maybe (GenDatum ()) 108 | applyMacro s dat = match (pat s) dat >>= useTemplate (temp s) 109 | 110 | type MacroList = [SyntaxRule] 111 | 112 | -- | Try to appyl multiple SyntaxRules and when one fails, recursively apply 113 | -- them to the children in the AST. 114 | -- 115 | applyMacros :: MacroList -> GenDatum () -> GenDatum () 116 | applyMacros ms ex = 117 | let conversions = map (flip applyMacro ex) ms 118 | in case take 1 $ catMaybes conversions of 119 | [x] -> applyMacros ms x 120 | [] -> case ex of 121 | CompoundDatum ds -> CompoundDatum $ map (applyMacros ms) ds 122 | SimpleDatum y -> SimpleDatum y 123 | 124 | convDatum :: GenDatum () -> GenExpr () 125 | convDatum (SimpleDatum x) = x 126 | convDatum (CompoundDatum (SimpleDatum (Var "if" ()) : [a,b,c])) = 127 | Cond (convDatum a) (convDatum b) (convDatum c) 128 | convDatum (CompoundDatum (SimpleDatum (Var "lambda" ()) 129 | : (CompoundDatum xs) : ys)) = 130 | Lambda (map convDatum xs) (convDatumBody ys) 131 | convDatum (CompoundDatum ( SimpleDatum (Var "set!" ()) 132 | : SimpleDatum (Var x ()) 133 | : [y])) = 134 | Assign (Var x ()) (convDatum y) 135 | convDatum (CompoundDatum (SimpleDatum (Var "quote" ()) : [x])) = 136 | Literal $ LitQuote x 137 | convDatum (CompoundDatum (x: xs)) = 138 | Call (convDatum x) (map convDatum xs) 139 | 140 | isDef :: GenDatum a -> Bool 141 | isDef (CompoundDatum (SimpleDatum (Var "define" _) : _)) = True 142 | isDef (CompoundDatum (SimpleDatum (Var "begin" _ ) : xs)) = and $ map isDef xs 143 | isDef _ = False 144 | 145 | convDatumDef :: GenDatum () -> GenDef () 146 | convDatumDef (CompoundDatum (SimpleDatum (Var "begin" ()) : xs)) = 147 | Def3 $ map convDatumDef xs 148 | convDatumDef (CompoundDatum (SimpleDatum (Var "define" ()) : 149 | CompoundDatum (SimpleDatum (Var x ()) : vs) : 150 | b)) = 151 | Def2 (Var x ()) (map convDatum vs) (convDatumBody b) 152 | convDatumDef (CompoundDatum (SimpleDatum (Var "define" ()) : x : [y])) = 153 | Def1 (convDatum x) (convDatum y) 154 | 155 | convDatumBody :: [GenDatum ()] -> GenBody () 156 | convDatumBody [] = Body [] [] 157 | convDatumBody (x:xs) = 158 | let Body ds es = convDatumBody xs 159 | in if isDef x 160 | then Body (convDatumDef x:ds) es 161 | else Body ds (convDatum x:es) 162 | 163 | applyMacrosExpr :: MacroList -> GenExpr () -> GenExpr () 164 | applyMacrosExpr ms = convDatum . applyMacros ms . convMacro 165 | 166 | applyMacrosDef :: MacroList -> GenDef () -> GenDef () 167 | applyMacrosDef ms = convDatumDef . applyMacros ms . convMacroDef 168 | 169 | applyMacrosProgram :: MacroList -> [CommOrDef] -> [CommOrDef] 170 | applyMacrosProgram ms xs = map (\x -> 171 | case x of 172 | Comm y -> Comm $ applyMacrosExpr (ms ++ newMacros) y 173 | Def y -> Def $ applyMacrosDef (ms ++ newMacros) y) $ filter notDef xs 174 | where 175 | getSynRule (DefSyn rs) = rs 176 | getSynRule _ = [] 177 | newMacros = concatMap getSynRule xs 178 | notDef (DefSyn _) = False 179 | notDef _ = True 180 | 181 | 182 | defaultMacros :: MacroList 183 | defaultMacros = 184 | [ SyntaxRule { --convert `let` to a lambda application 185 | pat = 186 | PatEllipses 187 | [ PatternLit "let" 188 | , PatEllipses [] 189 | (PatternComp [ PatternId "a" 190 | , PatternId "b" 191 | ]) 192 | , PatternId "c"] 193 | (PatternId "d") 194 | , temp = 195 | TemplateComp 196 | [ PureTemp $ TemplateComp 197 | [ PureTemp $ TemplateLit "lambda" 198 | , PureTemp $ TemplateComp $ [TempEllipses $ TemplateId "a"] 199 | , PureTemp $ TemplateId "c" 200 | , TempEllipses $ TemplateId "d" 201 | ] 202 | , TempEllipses $ TemplateId "b" 203 | ] 204 | } 205 | 206 | , SyntaxRule { -- convert `delay` to a lambda 207 | pat = 208 | PatternComp [ PatternLit "delay" 209 | , PatternId "a" 210 | ] 211 | , temp = 212 | TemplateComp [ PureTemp $ TemplateLit "lambda" 213 | , PureTemp $ TemplateComp [] 214 | , PureTemp $ TemplateId "a" 215 | ] 216 | } 217 | ] -------------------------------------------------------------------------------- /src/Parser2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | 3 | module Parser2 where 4 | 5 | import Text.Trifecta 6 | import Data.Char (isSpace, isAlpha, isAscii, isPrint) 7 | import Data.List (intercalate) 8 | import Control.Applicative ((<|>), empty, liftA2, liftA3) 9 | import Data.List (nub) 10 | import qualified Data.Set as S 11 | import qualified Data.Map as M 12 | 13 | ---------------------- Parse Tokens ----------------------------- 14 | 15 | data Token = Identifier String 16 | | Boolean' Bool 17 | | Number' Double 18 | | Character Char 19 | | String String 20 | | LeftPar 21 | | RightPar 22 | | Other String 23 | deriving (Eq, Show) 24 | 25 | exprKeywords = [ "quote", "lambda", "if", "set!", "begin", "cond", "and" 26 | , "case", "let*", "letrec", "do", "quasiquote" 27 | ] 28 | synKeywords = [ "else", "=>", "define", "unquote", "unquote-splicing" ] 29 | ++ exprKeywords 30 | 31 | parInit :: Parser Char 32 | parInit = oneOf ['a'..'z'] <|> oneOf [ '!', '$', '%', '&', '*', '/', ':', '<' 33 | , '=', '>', '?', '^', '_', '~' ] 34 | 35 | parSubseq :: Parser Char 36 | parSubseq = parInit <|> digit <|> oneOf ['+', '-', '.', '@'] 37 | 38 | parIdent :: Parser String 39 | parIdent = (:) <$> parInit <*> many parSubseq <|> string "+" <|> string "-" 40 | <|> string "..." 41 | 42 | parBool :: Parser String 43 | parBool = string "#t" <|> string "#f" 44 | 45 | parNum :: Parser Double 46 | parNum = do 47 | sign <- option "" $ string "-" 48 | integral <- many digit 49 | option "" $ string "." 50 | decimal <- many digit 51 | let figures = length decimal 52 | result = digits2Double integral + (digits2Double decimal / (10 ^ figures)) 53 | case (length integral, length decimal, sign) of 54 | (0,0,_) -> unexpected "number has no digits" 55 | (_,_,"") -> return result 56 | (_,_,"-") -> return (- result) 57 | 58 | digits2Double :: String -> Double 59 | digits2Double = 60 | let help n [] = n 61 | help n (x:xs) = help (n * 10 + read [x]) xs 62 | in help 0 63 | 64 | parChar :: Parser String 65 | parChar = (++) <$> string "#\\" <*> ( string "space" 66 | <|> string "newline" 67 | <|> fmap (:[]) characterChar ) 68 | 69 | parStr :: Parser String 70 | parStr = char '\"' *> 71 | some ( string "\\\"" *> return '\"' 72 | <|> string "\\\\" *> return '\\' 73 | <|> satisfy (\c -> (c /= '\"' && c /='\\' && c > '\026')) 74 | ) 75 | <* char '\"' 76 | 77 | parToken :: Parser Token 78 | parToken = fmap Identifier parIdent 79 | <|> fmap boolConv parBool 80 | <|> fmap numConv parNum 81 | <|> fmap charConv parChar 82 | <|> fmap String parStr 83 | <|> char '(' *> pure LeftPar 84 | <|> char ')' *> pure RightPar 85 | <|> fmap (\x -> Other [x]) (oneOf ['\'', '`', ',', '.']) 86 | <|> fmap Other (string "#(") 87 | <|> fmap Other (string ",@") 88 | where 89 | boolConv "#f" = Boolean' False 90 | boolConv "#t" = Boolean' True 91 | numConv = Number' 92 | charConv "space" = Character ' ' 93 | charConv "newline" = Character '\n' 94 | charConv (['#', '\\', x]) = Character x 95 | 96 | ------------------------- Parse Macros ------------------------------ 97 | 98 | -- | This is the type that is used for pattern matching in a macro. 99 | -- 100 | data Pattern = PatternId String -- a variable identifier (matches anything) 101 | | PatternDat Lit 102 | | PatternComp [Pattern] 103 | | PatternLit String -- an identifier that only matches itself 104 | | PatEllipses [Pattern] Pattern 105 | deriving (Eq, Show) 106 | 107 | -- | Macro template element to be filled in after the corresponding pattern 108 | -- was matched against. It is either an template or a template with ellipses 109 | -- which is to be filled in 0 or more times. 110 | -- 111 | data TempElement = PureTemp Template 112 | | TempEllipses Template 113 | deriving (Eq, Show) 114 | 115 | -- | Template to fill in after a match. 116 | -- 117 | data Template = TemplateId String -- variable to fill with matched data 118 | | TemplateDat Lit 119 | | TemplateComp [TempElement] 120 | | TemplateLit String -- literal identifier filled with itself 121 | deriving (Eq, Show) 122 | 123 | -- | Get a list of the variables used in a pattern. 124 | -- 125 | getPatVars :: Pattern -> [String] 126 | getPatVars (PatternId s) = [s] 127 | getPatVars (PatternDat _) = [] 128 | getPatVars (PatternComp xs) = concatMap getPatVars xs 129 | getPatVars (PatternLit _) = [] 130 | getPatVars (PatEllipses xs x) = concatMap getPatVars xs ++ getPatVars x 131 | 132 | parPattern :: [String] -> Parser Pattern 133 | parPattern lits = 134 | try (do 135 | token parLeft 136 | pats <- many $ token $ parPattern lits 137 | token parRight 138 | let initial = init pats 139 | if PatternId "..." `elem` initial 140 | then unexpected "ellipses not at pattern end" 141 | else if last pats == PatternId "..." 142 | then if length initial >= 1 143 | then return $ PatEllipses (init $ initial) (last $ initial) 144 | else unexpected "no pattern preceding ellipses" 145 | else return $ PatternComp pats) 146 | <|> try (fmap PatternDat parLitRaw) 147 | <|> try (do 148 | s <- token parIdent 149 | if s `elem` lits -- parse identifier as variable Id or literal? 150 | then return $ PatternLit s 151 | else return $ PatternId s) 152 | <|> unexpected "couldn't parse pattern" 153 | 154 | parTempElement :: [String] -> Parser TempElement 155 | parTempElement vars = do 156 | t <- token $ parTemplate vars 157 | try (token (string "...") >> return (TempEllipses t)) 158 | <|> return (PureTemp t) 159 | 160 | 161 | parTemplate :: [String] -> Parser Template 162 | parTemplate vars = 163 | try (do 164 | token parLeft 165 | ts <- many (token $ parTempElement vars) 166 | parRight 167 | return $ TemplateComp ts) 168 | <|> try (fmap TemplateDat parLitRaw) 169 | <|> try (do 170 | s <- token parIdent 171 | if s `elem` vars -- parse identifier as a var id or a literal id? 172 | then return $ TemplateId s 173 | else return $ TemplateLit s) 174 | <|> unexpected "couldn't parse template" 175 | 176 | data SyntaxRule = SyntaxRule { pat :: Pattern, temp :: Template} 177 | deriving (Eq, Show) 178 | 179 | parSynTaxRule :: [String] -> Parser SyntaxRule 180 | parSynTaxRule lits = do 181 | token parLeft 182 | p <- token $ parPattern lits 183 | let vars = getPatVars p 184 | t <- token $ parTemplate vars 185 | parRight 186 | return $ SyntaxRule p t 187 | 188 | parDefSyn :: Parser [SyntaxRule] 189 | parDefSyn = do 190 | token parLeft 191 | token $ string "define-syntax" 192 | key <- token parIdent 193 | token parLeft 194 | token $ string "syntax-rules" 195 | token parLeft 196 | ids <- many $ token parIdent 197 | token parRight 198 | rules <- many $ token (parSynTaxRule (key:ids)) 199 | token parRight 200 | parRight 201 | return $ rules 202 | 203 | ------------------------- Parse Expressions and Defs ----------------- 204 | 205 | data Lit = LitBool Bool 206 | | LitNum Double 207 | | LitChar Char 208 | | LitStr String 209 | | LitQuote (GenDatum ()) 210 | deriving (Eq, Show) 211 | 212 | -- | Data type for a Scheme expression. The a contains additional annotations. 213 | -- 214 | data GenExpr a = Var String a 215 | | Literal Lit 216 | | Call (GenExpr a) [GenExpr a] 217 | | Lambda [GenExpr ()] (GenBody a) 218 | -- ^ first list is variabls, should only be Vars 219 | | Cond (GenExpr a) (GenExpr a) (GenExpr a) 220 | | Assign (GenExpr a) (GenExpr a) 221 | | DerivedExpr 222 | | MacroUse (GenExpr ()) [GenDatum a] 223 | | MacroBlock 224 | deriving (Eq, Show) 225 | 226 | -- | Scheme definition, with annotations in the a type. 227 | -- 228 | data GenDef a = Def1 (GenExpr ()) (GenExpr a) 229 | -- ^ first expr should only be a Var (the variable we define) 230 | | Def2 (GenExpr ()) [GenExpr ()] (GenBody a) 231 | | Def3 [GenDef a] 232 | deriving (Eq, Show) 233 | 234 | -- | Schem lambda body, with annotations in the a type. 235 | -- 236 | data GenBody a = Body [GenDef a] [GenExpr a] deriving (Eq, Show) 237 | 238 | -- | Pure datum type. Anything that parses as a GenExpr should also parse as 239 | -- a GenDatum. This ignores all keywords and simple generates an AST with simple 240 | -- tokens or lists of tokens. 241 | -- 242 | data GenDatum a = SimpleDatum (GenExpr a) | CompoundDatum [GenDatum a] 243 | deriving (Eq, Show) 244 | 245 | -- | Top Level piece of a scheme program. Either an expression, definition or 246 | -- define-syntax. 247 | -- 248 | data GenCommOrDef a = Comm (GenExpr a) 249 | | Def (GenDef a) 250 | | DefSyn [SyntaxRule] 251 | deriving (Eq, Show) 252 | 253 | data DefinedEnv = Global | Local 254 | deriving (Eq, Show) 255 | 256 | type Expr = GenExpr () 257 | type Def = GenDef () 258 | type Body = GenBody () 259 | type CommOrDef = GenCommOrDef () 260 | 261 | type AnnExpr = GenExpr DefinedEnv 262 | type AnnDef = GenDef DefinedEnv 263 | type AnnBody = GenBody DefinedEnv 264 | type AnnCommOrDef = GenCommOrDef DefinedEnv 265 | 266 | parExpr :: Parser Expr 267 | parExpr = parVar 268 | <|> try parLit 269 | <|> try parCall 270 | <|> try parLambda 271 | <|> try parCond 272 | <|> parAssign 273 | 274 | parDatum :: Parser (GenDatum ()) 275 | parDatum = try parSimpleDatum <|> (do 276 | token parLeft 277 | xs <- many $ token parDatum 278 | parRight 279 | return $ CompoundDatum xs) 280 | 281 | parSimpleDatum :: Parser (GenDatum ()) 282 | parSimpleDatum = do 283 | x <- parToken 284 | case x of 285 | LeftPar -> unexpected "( is not simple Datum)" 286 | RightPar -> unexpected ") is not simple datum" 287 | Other _ -> unexpected "Other is not simple datum" 288 | Boolean' b -> return $ SimpleDatum (Literal $ LitBool b) 289 | Number' n -> return $ SimpleDatum (Literal $ LitNum n) 290 | Character c -> return $ SimpleDatum (Literal $ LitChar c) 291 | String s -> return $ SimpleDatum (Literal $ LitStr s) 292 | Identifier s -> return $ SimpleDatum (Var s ()) 293 | 294 | -- | Parse a literal without wrapping, so it can be used for patterns, 295 | -- templates, or expressions. 296 | -- 297 | parLitRaw :: Parser Lit 298 | parLitRaw = try (do 299 | x <- parToken 300 | if lit x then return (conv x) else empty) 301 | <|> try (do 302 | token parLeft 303 | x <- token parIdent 304 | if x == "quote" 305 | then (do 306 | x <- token parDatum <* parRight 307 | case x of 308 | SimpleDatum (Literal (LitBool b)) -> return $ LitBool b 309 | SimpleDatum (Literal (LitNum n)) -> return $ LitNum n 310 | SimpleDatum (Literal (LitChar c)) -> return $ LitChar c 311 | SimpleDatum (Literal (LitStr s)) -> return $ LitStr s 312 | x -> return $ LitQuote x) 313 | else unexpected "Not a quote") 314 | <|> try (do 315 | token $ char '\'' 316 | x <- token parDatum 317 | case x of 318 | SimpleDatum (Literal (LitBool b)) -> return $ LitBool b 319 | SimpleDatum (Literal (LitNum n)) -> return $ LitNum n 320 | SimpleDatum (Literal (LitChar c)) -> return $ LitChar c 321 | SimpleDatum (Literal (LitStr s)) -> return $ LitStr s 322 | x -> return $ LitQuote x 323 | ) 324 | <|> unexpected "Not a literal" 325 | where 326 | lit (Boolean' _) = True 327 | lit (Number' _) = True 328 | lit (Character _) = True 329 | lit (String _) = True 330 | lit _ = False 331 | conv (Boolean' x) = LitBool x 332 | conv (Number' x) = LitNum x 333 | conv (Character x) = LitChar x 334 | conv (String x) = LitStr x 335 | 336 | parLit :: Parser Expr 337 | parLit = fmap Literal parLitRaw 338 | 339 | parLeft :: Parser () 340 | parLeft = (try $ do 341 | x <- parToken 342 | if x == LeftPar then return () else empty 343 | ) <|> unexpected "Expected ( token" 344 | 345 | parRight :: Parser () 346 | parRight = (try $ do 347 | x <- parToken 348 | if x == RightPar then return () else empty 349 | ) <|> unexpected "Expected ) token" 350 | 351 | parCall :: Parser Expr 352 | parCall = do 353 | token parLeft 354 | operator <- token parExpr 355 | operands <- many (token parExpr) 356 | parRight 357 | return $ Call operator operands 358 | <|> unexpected "expected procedure call" 359 | 360 | parLambda :: Parser Expr 361 | parLambda = do 362 | token parLeft 363 | x <- token parToken 364 | if x /= Identifier "lambda" then empty else do 365 | formals <- token parFormals 366 | body <- token parBody 367 | parRight 368 | return $ Lambda formals body 369 | 370 | parVar :: Parser Expr 371 | parVar = try $ do 372 | x <- parToken 373 | case x of 374 | Identifier s -> if not (s `elem` synKeywords) 375 | then return (Var s ()) 376 | else empty 377 | _ -> empty 378 | <|> unexpected "expected variable" 379 | 380 | 381 | parFormals :: Parser [Expr] 382 | parFormals = try $ (do 383 | x <- parVar 384 | return [x]) 385 | <|> (do 386 | token parLeft 387 | vars <- many (token parVar) 388 | parRight 389 | return vars) 390 | 391 | parBody :: Parser Body 392 | parBody = do 393 | defs <- many (token parDef) 394 | exprs <- many (token parExpr) 395 | return $ Body defs exprs 396 | 397 | parSeq :: Parser [Expr] 398 | parSeq = some parExpr 399 | 400 | parDef :: Parser Def 401 | parDef = (<|> unexpected "not a definition" ) $ try $ do 402 | token parLeft 403 | x <- token parIdent 404 | if x == "define" then (try (do 405 | v <- token parVar 406 | e <- token parExpr 407 | parRight 408 | return $ Def1 v e) 409 | <|> (do 410 | token parLeft 411 | v <- token parVar 412 | formals <- many (token parVar) 413 | token parRight 414 | body <- parBody 415 | parRight 416 | return (Def2 v formals body))) 417 | else (if x /= "begin" then empty else 418 | do 419 | defs <- many (token parDef) 420 | parRight 421 | return (Def3 defs) ) 422 | 423 | parCond :: Parser Expr 424 | parCond = (<|> unexpected "no if statement") $ try $ do 425 | token parLeft 426 | x <- token parIdent 427 | if x /= "if" then empty else do 428 | test <- token parExpr 429 | conseq <- token parExpr 430 | altern <- token parExpr 431 | parRight 432 | return $ Cond test conseq altern 433 | 434 | parAssign :: Parser Expr 435 | parAssign = (<|> unexpected "not an assignment") $ try $ do 436 | token parLeft 437 | x <- token parIdent 438 | if x /= "set!" then empty else do 439 | var <- token parVar 440 | expr <- token parExpr 441 | parRight 442 | return $ Assign var expr 443 | 444 | parProgram :: Parser [CommOrDef] 445 | parProgram = many $ try (fmap Comm $ token parExpr) 446 | <|> try (fmap Def $ token parDef) 447 | <|> try (fmap DefSyn $ token parDefSyn) 448 | 449 | ---------------- Annotating functions ------------------------ 450 | 451 | -- | Which variables are being defined in this definition? 452 | -- 453 | definedVars :: GenDef a -> S.Set String 454 | definedVars (Def1 (Var s _) _) = S.singleton s 455 | definedVars (Def2 (Var s _) _ _) = S.singleton s 456 | definedVars (Def3 ds) = foldMap definedVars ds 457 | 458 | -- | Which variables appear free in the definition? But only those for which `f` 459 | -- evaluates to True. So we can use the annotation to filter which types of 460 | -- variables we want. 461 | -- 462 | freeInAnnDef :: (a -> Bool) -> GenDef a -> S.Set String 463 | freeInAnnDef f (Def1 _ e) = freeVarsAnnEx f e 464 | freeInAnnDef f (Def2 _ es b) = 465 | freeVarsAnnBody f b `S.difference` foldMap freeVarsEx es 466 | freeInAnnDef f (Def3 es) = foldMap (freeInAnnDef f) es 467 | 468 | freeInDef :: GenDef a -> S.Set String 469 | freeInDef = freeInAnnDef (const True) 470 | 471 | -- | Free variables in expression, but only those for which `f` evaluates to 472 | -- True. So we can use the annotation to filter which types of variables 473 | -- we want. 474 | -- 475 | freeVarsAnnEx :: (a -> Bool) -> GenExpr a -> S.Set String 476 | freeVarsAnnEx f (Var s a) = if f a then S.singleton s else S.empty 477 | freeVarsAnnEx _ (Literal _) = S.empty 478 | freeVarsAnnEx f (Call a b) = 479 | S.union (freeVarsAnnEx f a) (foldMap (freeVarsAnnEx f) b) 480 | freeVarsAnnEx f (Lambda vars body) = S.difference (freeVarsAnnBody f body) 481 | (foldMap freeVarsEx vars) 482 | freeVarsAnnEx f (Cond x y z) = foldMap (freeVarsAnnEx f) [x, y, z] 483 | freeVarsAnnEx f (Assign a b) = S.union (freeVarsAnnEx f a) (freeVarsAnnEx f b) 484 | 485 | -- | Free variables in expression 486 | -- 487 | freeVarsEx :: GenExpr a -> S.Set String 488 | freeVarsEx = freeVarsAnnEx (const True) 489 | 490 | -- | Free variables in body, But only those for which `f` 491 | -- evaluates to True. So we can use the annotation to filter which types of 492 | -- variables we want. 493 | -- 494 | freeVarsAnnBody :: (a -> Bool) -> GenBody a -> S.Set String 495 | freeVarsAnnBody f (Body defs exprs) = S.union (foldMap (freeVarsAnnEx f) exprs) 496 | (foldMap (freeInAnnDef f) defs) 497 | `S.difference` foldMap definedVars defs 498 | 499 | -- | All free variables in a body. 500 | -- 501 | freeVars :: GenBody a -> S.Set String 502 | freeVars = freeVarsAnnBody (const True) 503 | 504 | -- | Free vars in the expression that have been annotated as nonglobal 505 | -- 506 | freeNonGlobalVars :: AnnExpr -> S.Set String 507 | freeNonGlobalVars = freeVarsAnnEx (const True) 508 | 509 | -- | Annotate each expression by labeling each lambda with the variables in 510 | -- needs from the environment. 511 | -- 512 | annotateEx :: S.Set String -> GenExpr a -> AnnExpr 513 | annotateEx vars (Var s _) 514 | | s `S.member` vars = Var s Local 515 | | otherwise = Var s Global 516 | annotateEx _ (Literal x) = Literal x 517 | annotateEx vars (Call f xs) = 518 | Call (annotateEx vars f) (map (annotateEx vars) xs) 519 | annotateEx vars (Lambda es b) = Lambda es (annotateBody newVars b) 520 | where 521 | newVars = S.unions (vars : map freeVarsEx es) 522 | -- ^ add lambda variables to defined vars set 523 | annotateEx vars (Cond a b c) = 524 | Cond (annotateEx vars a) (annotateEx vars b) (annotateEx vars c) 525 | annotateEx vars (Assign a b) = Assign (annotateEx vars a) (annotateEx vars b) 526 | 527 | annotateBody :: S.Set String -> GenBody a -> AnnBody 528 | annotateBody vars (Body ds es) = 529 | Body (map (annotateDef vars) ds) (map (annotateEx newVars) es) 530 | where 531 | newVars = S.unions (vars : map definedVars ds) 532 | 533 | annotateDef :: S.Set String -> GenDef a -> AnnDef 534 | annotateDef vars (Def1 a b) = 535 | Def1 a $ annotateEx (S.union vars $ freeVarsEx a) b 536 | annotateDef vars (Def2 a b c) = Def2 a b (annotateBody newVars c) 537 | where 538 | newVars = S.unions (vars : freeVarsEx a : map freeVarsEx b) 539 | annotateDef vars d@(Def3 ds) = 540 | Def3 $ map (annotateDef (S.union vars $ definedVars d)) ds 541 | 542 | allDefined :: [GenCommOrDef a] -> S.Set String 543 | allDefined = foldMap definedVars' 544 | where 545 | definedVars' (Comm _) = S.empty 546 | definedVars' (Def x) = definedVars x 547 | 548 | annotateProgram :: [GenCommOrDef a] -> [AnnCommOrDef] 549 | annotateProgram xs = map ann xs 550 | where 551 | ann (Comm x) = Comm $ annotateEx (allDefined xs) x 552 | ann (Def x) = Def $ annotateDef (allDefined xs) x 553 | 554 | -- | All variables free in the program 555 | -- 556 | allVars :: [GenCommOrDef a] -> S.Set String 557 | allVars = foldMap getFree 558 | where 559 | getFree (Comm x) = freeVarsEx x 560 | getFree (Def x) = freeInDef x -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.0 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Assembler 2 | import CodeGenerator 3 | import Test.Hspec 4 | import Test.QuickCheck 5 | import System.Process 6 | import System.FilePath 7 | import System.Exit 8 | import System.Directory 9 | import qualified Data.Map as M 10 | import Data.List (nub, sort, groupBy) 11 | import Data.Char (isAlpha) 12 | 13 | 14 | endVal :: String -> String 15 | endVal s = let ls = lines s 16 | n = length ls 17 | in drop 8 $ ls !! (n - 5) 18 | 19 | fileExCompare :: [String] -> String -> SpecWith () 20 | fileExCompare res s = 21 | let outfile = replaceExtension s "luac" 22 | resultfile = replaceExtension s "result" 23 | in 24 | do 25 | (exitcode, b, _) <- runIO $ do 26 | f <- compileFromFile s 27 | case maybeToEither f >>= finalBuilder of 28 | Right bs -> writeBuilder outfile bs 29 | Left s -> print $ "assembly error: " ++ s 30 | readCreateProcessWithExitCode (shell $ "lua " ++ outfile) "" 31 | a <- if resultfile `elem` res 32 | then runIO $ readFile resultfile 33 | else runIO $ do 34 | (_,r,_) <- readCreateProcessWithExitCode (shell $ "scheme < " ++ s) "" 35 | return (endVal r) 36 | it s $ do 37 | exitcode `shouldBe` ExitSuccess 38 | a `shouldBe` (head . lines $ b) 39 | 40 | bytecodeParses :: String -> LuaFunc -> SpecWith () 41 | bytecodeParses s luafunc = do 42 | (exitCode, stdOut, stdErr) <- runIO $ 43 | case finalBuilder luafunc of 44 | Right bs -> writeBuilder outfile bs >> do 45 | readCreateProcessWithExitCode (shell $ "luac -l -l " ++ outfile) "" 46 | Left s -> return (ExitFailure 101, "AssemblyError: " ++ s, "AssemblyError: " ++ s) 47 | it (s ++ " assembled") $ exitCode `shouldNotBe` (ExitFailure 101) 48 | it (s ++ " valid bytecode") $ exitCode `shouldBe` ExitSuccess 49 | where outfile = "test/testfiles/temp.luac" 50 | 51 | main :: IO () 52 | main = hspec $ do 53 | (testFiles, resultFiles) <- runIO $ do 54 | files <- listDirectory "test/testfiles" 55 | let test = groupBy (\x y -> (takeWhile isAlpha x == takeWhile isAlpha y)) 56 | . sort 57 | . filter ((== ".scm") . takeExtension) 58 | $ files 59 | results = filter ((== ".result") . takeExtension) files 60 | return $ (test, results) 61 | mapM_ (run (map ("test/testfiles/" ++) resultFiles)) testFiles 62 | describe "bytecodeParses" 63 | $ mapM_ (uncurry bytecodeParses) primitives 64 | where 65 | run res xs = let name = takeWhile isAlpha (head xs) 66 | in describe (name ++ " tests") $ 67 | mapM_ (fileExCompare res . ("test/testfiles/" ++)) xs -------------------------------------------------------------------------------- /test/testfiles/arith1.scm: -------------------------------------------------------------------------------- 1 | (+ 1 2 3 4 5 6) -------------------------------------------------------------------------------- /test/testfiles/arith2.scm: -------------------------------------------------------------------------------- 1 | (- 3) -------------------------------------------------------------------------------- /test/testfiles/arith3.scm: -------------------------------------------------------------------------------- 1 | (- 10 1 2 3 4 5) -------------------------------------------------------------------------------- /test/testfiles/arith4.scm: -------------------------------------------------------------------------------- 1 | (* 1 2 3 4 5) -------------------------------------------------------------------------------- /test/testfiles/arith5.scm: -------------------------------------------------------------------------------- 1 | (+ (* 4 5) (- 25 3) 100) -------------------------------------------------------------------------------- /test/testfiles/bool1.scm: -------------------------------------------------------------------------------- 1 | (if (< 4 5) 0 1) -------------------------------------------------------------------------------- /test/testfiles/bool2.scm: -------------------------------------------------------------------------------- 1 | (if (not #f) 0 1) -------------------------------------------------------------------------------- /test/testfiles/bool3.scm: -------------------------------------------------------------------------------- 1 | (if (= 10 10) 0 1) -------------------------------------------------------------------------------- /test/testfiles/bool4.scm: -------------------------------------------------------------------------------- 1 | (if (= 3 4) 0 1) -------------------------------------------------------------------------------- /test/testfiles/bool5.scm: -------------------------------------------------------------------------------- 1 | (if (> 4 5) 0 1) -------------------------------------------------------------------------------- /test/testfiles/bool6.scm: -------------------------------------------------------------------------------- 1 | (if 100 0 1) -------------------------------------------------------------------------------- /test/testfiles/bool7.scm: -------------------------------------------------------------------------------- 1 | (if "hello" 0 1) -------------------------------------------------------------------------------- /test/testfiles/bool8.scm: -------------------------------------------------------------------------------- 1 | (if 0 0 1) -------------------------------------------------------------------------------- /test/testfiles/cons1.scm: -------------------------------------------------------------------------------- 1 | (car (cons 4 5)) 2 | -------------------------------------------------------------------------------- /test/testfiles/cons2.scm: -------------------------------------------------------------------------------- 1 | (cdr (cons 1 2)) 2 | -------------------------------------------------------------------------------- /test/testfiles/cons3.scm: -------------------------------------------------------------------------------- 1 | (cdr (cdr (cons 3 (cons 1 2)))) 2 | -------------------------------------------------------------------------------- /test/testfiles/define1.scm: -------------------------------------------------------------------------------- 1 | (define x 5) 2 | x 3 | -------------------------------------------------------------------------------- /test/testfiles/define2.scm: -------------------------------------------------------------------------------- 1 | (define y 5) 2 | (define (foo x) (+ x y)) 3 | (foo 5) 4 | -------------------------------------------------------------------------------- /test/testfiles/define3.scm: -------------------------------------------------------------------------------- 1 | (define g (lambda (x) x)) 2 | (g 2) 3 | -------------------------------------------------------------------------------- /test/testfiles/define4.scm: -------------------------------------------------------------------------------- 1 | (define (g x y) x) 2 | (g 5 6) 3 | -------------------------------------------------------------------------------- /test/testfiles/define5.scm: -------------------------------------------------------------------------------- 1 | (begin (define f 5) (define g 100)) 2 | g 3 | -------------------------------------------------------------------------------- /test/testfiles/eval1.result: -------------------------------------------------------------------------------- 1 | 10 -------------------------------------------------------------------------------- /test/testfiles/eval1.scm: -------------------------------------------------------------------------------- 1 | (eval '10) -------------------------------------------------------------------------------- /test/testfiles/eval2.result: -------------------------------------------------------------------------------- 1 | 10 -------------------------------------------------------------------------------- /test/testfiles/eval2.scm: -------------------------------------------------------------------------------- 1 | (define y 100) 2 | (define x '(define y 10)) 3 | (eval x) 4 | y -------------------------------------------------------------------------------- /test/testfiles/eval3.result: -------------------------------------------------------------------------------- 1 | 100 -------------------------------------------------------------------------------- /test/testfiles/eval3.scm: -------------------------------------------------------------------------------- 1 | (define y 100) 2 | (define x 'y) 3 | (eval x) -------------------------------------------------------------------------------- /test/testfiles/lambda1.scm: -------------------------------------------------------------------------------- 1 | ((lambda (x y z) x) 10 25 1) -------------------------------------------------------------------------------- /test/testfiles/lambda2.scm: -------------------------------------------------------------------------------- 1 | ((lambda (x) x) 100) -------------------------------------------------------------------------------- /test/testfiles/lambda3.scm: -------------------------------------------------------------------------------- 1 | ((lambda (f x) (+ 1 (f x))) (lambda (x) (+ x 10)) 10) -------------------------------------------------------------------------------- /test/testfiles/lambda4.scm: -------------------------------------------------------------------------------- 1 | ((lambda () 5)) -------------------------------------------------------------------------------- /test/testfiles/lambda5.scm: -------------------------------------------------------------------------------- 1 | ((lambda (x y z) (+ x y z)) 1 2 3) -------------------------------------------------------------------------------- /test/testfiles/let1.scm: -------------------------------------------------------------------------------- 1 | (let ((foo 100) (bar 35) (x 1)) (+ foo bar x)) -------------------------------------------------------------------------------- /test/testfiles/let2.scm: -------------------------------------------------------------------------------- 1 | (define x 10) 2 | (define (area r) 3 | (let ((pi 3)) 4 | (* pi r r) 5 | ) 6 | ) 7 | 8 | (area x) -------------------------------------------------------------------------------- /test/testfiles/let3.scm: -------------------------------------------------------------------------------- 1 | (let ((x 10) (y 100)) (+ x y) (+ x x)) -------------------------------------------------------------------------------- /test/testfiles/lookup1.scm: -------------------------------------------------------------------------------- 1 | (define x 10000) 2 | (define f 3 | (lambda () 4 | (lambda () 5 | (lambda () 6 | (lambda () 7 | (lambda () 8 | (lambda () 9 | (lambda () 10 | (lambda () 11 | (lambda () 12 | (lambda () 13 | (lambda () x 14 | ) 15 | ) 16 | ) 17 | ) 18 | ) 19 | ) 20 | ) 21 | ) 22 | ) 23 | ) 24 | ) 25 | ) 26 | 27 | (define main (lambda (n) (if (> (((((((((((f))))))))))) n) (main (+ n 1)) 5))) 28 | (main 0) -------------------------------------------------------------------------------- /test/testfiles/macro1.scm: -------------------------------------------------------------------------------- 1 | (define-syntax my-or 2 | (syntax-rules () 3 | ( 4 | (my-or) 5 | #f 6 | ) 7 | ( 8 | (my-or a) 9 | a 10 | ) 11 | ( 12 | (my-or a b c ...) 13 | (let ((x a)) (if x x (my-or b c ...))) 14 | ) 15 | ) 16 | ) 17 | 18 | (my-or #f #f 2 3) 19 | -------------------------------------------------------------------------------- /test/testfiles/macro2.scm: -------------------------------------------------------------------------------- 1 | (define-syntax inc_macro 2 | (syntax-rules () 3 | ( 4 | (inc_macro a) 5 | (+ a 1) 6 | ) 7 | ) 8 | ) 9 | 10 | (inc_macro (* 1 2 3)) -------------------------------------------------------------------------------- /test/testfiles/quote1.scm: -------------------------------------------------------------------------------- 1 | (car '(1 2 a)) -------------------------------------------------------------------------------- /test/testfiles/recursive1.scm: -------------------------------------------------------------------------------- 1 | (define fac (lambda (n) (if (= n 1) 1 (* n (fac (- n 1)))))) 2 | (fac 10) -------------------------------------------------------------------------------- /test/testfiles/recursive2.scm: -------------------------------------------------------------------------------- 1 | (define (fib n) 2 | (if (< n 2) 3 | 1 4 | (+ (fib (- n 1)) (fib (- n 2))) 5 | ) 6 | ) 7 | (fib 7) 8 | -------------------------------------------------------------------------------- /test/testfiles/tailcall1.scm: -------------------------------------------------------------------------------- 1 | (define g (lambda (x y) 2 | (if (< x 0) 3 | y 4 | (g (- x 1) (+ y 1)) 5 | ) 6 | )) 7 | 8 | (g 100000 0) 9 | --------------------------------------------------------------------------------