diff --git a/ChangeLog.markdown b/ChangeLog.markdown --- a/ChangeLog.markdown +++ b/ChangeLog.markdown @@ -1,3 +1,10 @@ +v3.9 +-------- + +- Fixed a syntax error that prevented the FFI module from building. Thanks to Ricardo Lanziano for bringing this to my attention! +- Enhanced the compiler to use the name of the source file for the compiled Haskell output instead of hardcoding the file to `_tmp.hs`. For example, `my-file.scm` will compile to `my-file.hs`. +- Removed extraneous quotes when printing a lambda form. + v3.8 -------- diff --git a/hs-src/Compiler/huskc.hs b/hs-src/Compiler/huskc.hs --- a/hs-src/Compiler/huskc.hs +++ b/hs-src/Compiler/huskc.hs @@ -44,13 +44,14 @@ then showUsage else do let inFile = nonOpts !! 0 + outHaskell = (dropExtension inFile) ++ ".hs" outExec = case output of Just inFile -> inFile Nothing -> dropExtension inFile extraOpts = case extra of Just args -> args Nothing -> "" - process inFile outExec dynamic extraOpts + process inFile outHaskell outExec dynamic extraOpts -- -- For an explanation of the command line options code, see: @@ -128,8 +129,8 @@ exitWith ExitSuccess -- |High level code to compile the given file -process :: String -> String -> Bool -> String -> IO () -process inFile outExec dynamic extraArgs = do +process :: String -> String -> String -> Bool -> String -> IO () +process inFile outHaskell outExec dynamic extraArgs = do -- TODO: how to integrate r5rsEnv and libraries? @@ -138,14 +139,14 @@ env <- Language.Scheme.Core.primitiveBindings stdlib <- getDataFileName "lib/stdlib.scm" srfi55 <- getDataFileName "lib/srfi/srfi-55.scm" -- (require-extension) - result <- (Language.Scheme.Core.runIOThrows $ liftM show $ compileSchemeFile env stdlib srfi55 inFile) + result <- (Language.Scheme.Core.runIOThrows $ liftM show $ compileSchemeFile env stdlib srfi55 inFile outHaskell) case result of Just errMsg -> putStrLn errMsg - _ -> compileHaskellFile outExec dynamic extraArgs + _ -> compileHaskellFile outHaskell outExec dynamic extraArgs -- |Compile a scheme file to haskell -compileSchemeFile :: Env -> String -> String -> String -> IOThrowsError LispVal -compileSchemeFile env stdlib srfi55 filename = do +compileSchemeFile :: Env -> String -> String -> String -> String -> IOThrowsError LispVal +compileSchemeFile env stdlib srfi55 filename outHaskell = do let conv :: LispVal -> String conv (String s) = s -- TODO: it is only temporary to compile the standard library each time. It should be @@ -162,13 +163,15 @@ List imports <- getNamespacedVar env 't' {-"internal"-} "imports" let moreHeaderImports = map conv imports - outH <- liftIO $ openFile "_tmp.hs" WriteMode + outH <- liftIO $ openFile outHaskell WriteMode _ <- liftIO $ writeList outH headerModule _ <- liftIO $ writeList outH $ map (\mod -> "import " ++ mod ++ " ") $ headerImports ++ moreHeaderImports filepath <- liftIO $ getDataFileName "" _ <- liftIO $ writeList outH $ header filepath _ <- liftIO $ writeList outH $ map show libsC + _ <- liftIO $ hPutStrLn outH " ------ END OF STDLIB ------" _ <- liftIO $ writeList outH $ map show libSrfi55C + _ <- liftIO $ hPutStrLn outH " ------ END OF SRFI 55 ------" _ <- liftIO $ writeList outH $ map show execC _ <- liftIO $ hClose outH if not (null execC) @@ -176,11 +179,11 @@ else throwError $ Default "Empty file" --putStrLn "empty file" -- |Compile the intermediate haskell file using GHC -compileHaskellFile :: String -> Bool -> String -> IO() --ThrowsError LispVal -compileHaskellFile filename dynamic extraArgs = do +compileHaskellFile :: String -> String -> Bool -> String -> IO() --ThrowsError LispVal +compileHaskellFile hsInFile objOutFile dynamic extraArgs = do let ghc = "ghc" -- Need to make configurable?? dynamicArg = if dynamic then "-dynamic" else "" - compileStatus <- system $ ghc ++ " " ++ dynamicArg ++ " " ++ extraArgs ++ " -cpp --make -package ghc -o " ++ filename ++ " _tmp.hs" + compileStatus <- system $ ghc ++ " " ++ dynamicArg ++ " " ++ extraArgs ++ " -cpp --make -package ghc -o " ++ objOutFile ++ " " ++ hsInFile -- TODO: delete intermediate hs files if requested diff --git a/hs-src/Language/Scheme/Compiler.hs b/hs-src/Language/Scheme/Compiler.hs --- a/hs-src/Language/Scheme/Compiler.hs +++ b/hs-src/Language/Scheme/Compiler.hs @@ -683,27 +683,37 @@ return $ [entryPt, compiledUpdate] ++ compiledIdx -- TODO: eval env cont fargs@(List (Atom "hash-table-delete!" : args)) = do --- TODO: --- Testing this out; idea is to compile-in any code injected via load + +compile env (List (Atom "%import" : args)) copts = do + throwError $ NotImplemented $ "%import, with args: " ++ show args + compile env (List [Atom "load", filename, envSpec]) copts = do - -- More TODO: - -- Hacking around, the issue with require-extension / and-let* is that - -- the compiler loads (and-let*) and attempts to compile the argument - -- () which cannot be evaluated, hence the special form error on () - -- - -- LispEnv env - y <- Language.Scheme.Core.evalLisp env envSpec - -- TODO: I think this is no good because current-environment is really the - -- same as env here. it would need to be evaluated and stored when it is first found - -- hmm...not quite sure how to proceed here, need to think on it - LispEnv env' <- Language.Scheme.Core.evalLisp env y - compile env' (List [Atom "load", filename]) copts -compile env (List [Atom "load", Atom filename]) copts = do - String filename' <- getVar env filename - compile env (List [Atom "load", String filename']) copts -compile env (List [Atom "load", String filename]) copts = do -- TODO: allow filename from a var, support env optional arg + + -- F*ck it, just run the evaluator here since filename is req'd at compile time + -- TODO: error handling for string below + String filename' <- Language.Scheme.Core.evalLisp env filename + + Atom symEnv <- _gensym "loadEnv" + Atom symLoad <- _gensym "load" + compEnv <- compileExpr env envSpec symEnv + Nothing -- Return env to our custom func + compLoad <- compileLisp env filename' symLoad Nothing + + -- Entry point + f <- return $ [ + -- TODO: should do runtime error checking if something else + -- besides a LispEnv is returned + AstValue $ " LispEnv e <- " ++ symEnv ++ " env (makeNullContinuation env) (Nil \"\") [] ", + AstValue $ " result <- " ++ symLoad ++ " e (makeNullContinuation e) (Nil \"\") Nothing", + createAstCont copts "result" ""] + -- Join compiled code together + return $ [createAstFunc copts f] ++ compEnv ++ compLoad + +compile env (List [Atom "load", filename]) copts = do -- TODO: allow filename from a var, support env optional arg + -- TODO: error handling for string below + String filename' <- Language.Scheme.Core.evalLisp env filename Atom symEntryPt <- _gensym "load" - result <- compileLisp env filename symEntryPt Nothing + result <- compileLisp env filename' symEntryPt Nothing return $ result ++ [createAstFunc copts [ AstValue $ " result <- " ++ symEntryPt ++ " env (makeNullContinuation env) (Nil \"\") Nothing", @@ -862,3 +872,5 @@ rest <- compileArgs nextFunc True as -- True indicates nextFunc needs to use value arg passed into it return $ [ f, c] ++ _comp ++ rest +compileApply _ err _ = do + throwError $ Default $ "compileApply - Unexpected argument: " ++ show err diff --git a/hs-src/Language/Scheme/Core.hs b/hs-src/Language/Scheme/Core.hs --- a/hs-src/Language/Scheme/Core.hs +++ b/hs-src/Language/Scheme/Core.hs @@ -60,7 +60,7 @@ -- |husk version number version :: String -version = "3.8" +version = "3.9" -- |A utility function to display the husk console banner showBanner :: IO () diff --git a/hs-src/Language/Scheme/FFI.hs b/hs-src/Language/Scheme/FFI.hs --- a/hs-src/Language/Scheme/FFI.hs +++ b/hs-src/Language/Scheme/FFI.hs @@ -112,7 +112,7 @@ return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal) defineVar env internalFuncName (IOFunc result) -- >>= continueEval env cont -evalfuncLoadFFI _ = throwError $ NumArgs 3 [] +evalfuncLoadFFI _ = throwError $ NumArgs (Just 3) [] defaultRunGhc :: GHC.Ghc a -> IO a defaultRunGhc = diff --git a/hs-src/Language/Scheme/Types.hs b/hs-src/Language/Scheme/Types.hs --- a/hs-src/Language/Scheme/Types.hs +++ b/hs-src/Language/Scheme/Types.hs @@ -442,12 +442,12 @@ showVal (Syntax _ _ _ _ _) = "" showVal (SyntaxExplicitRenaming _) = "" showVal (Func {params = args, vararg = varargs, body = _, closure = _}) = - "(lambda (" ++ unwords (map show args) ++ + "(lambda (" ++ unwords args ++ (case varargs of Nothing -> "" Just arg -> " . " ++ arg) ++ ") ...)" showVal (HFunc {hparams = args, hvararg = varargs, hbody = _, hclosure = _}) = - "(lambda (" ++ unwords (map show args) ++ + "(lambda (" ++ unwords args ++ (case varargs of Nothing -> "" Just arg -> " . " ++ arg) ++ ") ...)" diff --git a/husk-scheme.cabal b/husk-scheme.cabal --- a/husk-scheme.cabal +++ b/husk-scheme.cabal @@ -1,5 +1,5 @@ Name: husk-scheme -Version: 3.8 +Version: 3.9 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <>