diff options
| -rw-r--r-- | Compiler.hs | 47 | ||||
| -rw-r--r-- | CompilerMacros.hs | 51 | ||||
| -rw-r--r-- | Main.hs | 4 | ||||
| -rw-r--r-- | lisphs.cabal | 2 |
4 files changed, 56 insertions, 48 deletions
diff --git a/Compiler.hs b/Compiler.hs index 37f3d0d..f973afa 100644 --- a/Compiler.hs +++ b/Compiler.hs @@ -24,50 +24,6 @@ data TaggedValue | TVEllipsis deriving Show -preprocess :: Value -> Value -preprocess (VList [VName "define", VName name, VList args, body]) - | Just names <- mapM fromVName args = preprocess (VList [VName "define", VName name, VLambda names body]) - | otherwise = error "Invalid 'define' shorthand syntax: Invalid argument list" -preprocess (VList [VName "define", VName name, value]) = VDefine name (preprocess value) -preprocess (VList (VName "define" : _)) = error "Invalid 'define' syntax" - -preprocess (VList [VName "lambda", VList args, body]) - | Just names <- mapM fromVName args = preprocess (VLambda names body) - | otherwise = error "Invalid 'lambda' syntax: Invalid argument list" -preprocess (VList (VName "lambda" : _)) = error "Invalid 'lambda' syntax" - -preprocess (VList [VName "lambdarec", VName recname, VList args, body]) - | Just names <- mapM fromVName args = preprocess (VLambdaRec recname names body) - | otherwise = error "Invalid 'lambdarec' syntax: Invalid argument list" -preprocess (VList (VName "lambdarec" : _)) = error "Invalid 'lambdarec' syntax" - --- preprocess (VList [VName "let", VList args, body]) = --- case sequence [case p of { [n, v] -> Just (n, v); _ -> Nothing } | VList p <- args] of --- Just pairs -> --- preprocess (VList (VList [VName "lambda", VList (map fst pairs), body] : map snd pairs)) --- Nothing -> --- error "Invalid 'let' syntax: Invalid variable list (not all pairs)" -preprocess (VList [VName "let", VList args, body]) = - case sequence [case p of { [VName n, v] -> Just (n, v); _ -> Nothing } | VList p <- args] of - Just pairs -> - preprocess (VLet pairs body) - Nothing -> - error "Invalid 'let' syntax: Invalid variable list (not all pairs)" -preprocess (VList (VName "let" : _)) = error "Invalid 'let' syntax: Invalid argument list" - -preprocess (VList values) = VList (map preprocess values) - -preprocess (VDefine name body) = VDefine name (preprocess body) -preprocess (VLambda args body) = VLambda args (preprocess body) -preprocess (VLambdaRec recname args body) = VLambdaRec recname args (preprocess body) -preprocess (VLet args body) = VLet [(name, preprocess value) | (name, value) <- args] (preprocess body) -preprocess v@(VNum _) = v -preprocess v@(VString _) = v -preprocess v@(VName _) = v -preprocess v@(VQuoted _) = v -preprocess v@(VBuiltin _) = v -preprocess v@VEllipsis = v - analyseValue :: Value -> TaggedValue analyseValue = go (Map.empty, 0) where @@ -213,8 +169,7 @@ compileProgram (Program values) = runCM $ do bstart <- newBlockSwitch forM_ values $ \value -> do bnext <- newBlock - let value' = preprocess value - tvalue = analyseValue value' + let tvalue = analyseValue value ref <- genTValue tvalue bnext switchBlock bnext addIns (RNone, IDiscard ref) diff --git a/CompilerMacros.hs b/CompilerMacros.hs new file mode 100644 index 0000000..610e659 --- /dev/null +++ b/CompilerMacros.hs @@ -0,0 +1,51 @@ +module CompilerMacros(compilerMacros) where + +import AST + + +compilerMacros :: Program -> Program +compilerMacros (Program values) = Program (map process values) + +process :: Value -> Value +process (VList [VName "define", VName name, VList args, body]) + | Just names <- mapM fromVName args = process (VList [VName "define", VName name, VLambda names body]) + | otherwise = error "Invalid 'define' shorthand syntax: Invalid argument list" +process (VList [VName "define", VName name, value]) = VDefine name (process value) +process (VList (VName "define" : _)) = error "Invalid 'define' syntax" + +process (VList [VName "lambda", VList args, body]) + | Just names <- mapM fromVName args = process (VLambda names body) + | otherwise = error "Invalid 'lambda' syntax: Invalid argument list" +process (VList (VName "lambda" : _)) = error "Invalid 'lambda' syntax" + +process (VList [VName "lambdarec", VName recname, VList args, body]) + | Just names <- mapM fromVName args = process (VLambdaRec recname names body) + | otherwise = error "Invalid 'lambdarec' syntax: Invalid argument list" +process (VList (VName "lambdarec" : _)) = error "Invalid 'lambdarec' syntax" + +-- process (VList [VName "let", VList args, body]) = +-- case sequence [case p of { [n, v] -> Just (n, v); _ -> Nothing } | VList p <- args] of +-- Just pairs -> +-- process (VList (VList [VName "lambda", VList (map fst pairs), body] : map snd pairs)) +-- Nothing -> +-- error "Invalid 'let' syntax: Invalid variable list (not all pairs)" +process (VList [VName "let", VList args, body]) = + case sequence [case p of { [VName n, v] -> Just (n, v); _ -> Nothing } | VList p <- args] of + Just pairs -> + process (VLet pairs body) + Nothing -> + error "Invalid 'let' syntax: Invalid variable list (not all pairs)" +process (VList (VName "let" : _)) = error "Invalid 'let' syntax: Invalid argument list" + +process (VList values) = VList (map process values) + +process (VDefine name body) = VDefine name (process body) +process (VLambda args body) = VLambda args (process body) +process (VLambdaRec recname args body) = VLambdaRec recname args (process body) +process (VLet args body) = VLet [(name, process value) | (name, value) <- args] (process body) +process v@(VNum _) = v +process v@(VString _) = v +process v@(VName _) = v +process v@(VQuoted _) = v +process v@(VBuiltin _) = v +process v@VEllipsis = v @@ -5,6 +5,7 @@ import System.Environment import System.Exit import Compiler +import CompilerMacros import Optimiser import Parser import VM @@ -23,7 +24,8 @@ main = do _ -> usage >> exitFailure prog <- parseProgram mfname source >>= either (die . show) return - irprog <- either die return (compileProgram prog) + let prog' = compilerMacros prog + irprog <- either die return (compileProgram prog') let opt = optimise irprog -- print opt vmRun opt diff --git a/lisphs.cabal b/lisphs.cabal index 83d844d..b054466 100644 --- a/lisphs.cabal +++ b/lisphs.cabal @@ -13,4 +13,4 @@ executable lisp ghc-options: -Wall -O2 build-depends: base >= 4 && < 5, containers, filepath, mtl, parsec - other-modules: AST, Compiler, Intermediate, Optimiser, Parser, VM + other-modules: AST, Compiler, CompilerMacros, Intermediate, Optimiser, Parser, VM |