diff --git a/CarpHask.cabal b/CarpHask.cabal index 6bddff0f..5255fd18 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -63,7 +63,7 @@ library , blaze-html , blaze-markup , text - , ansi-terminal >= 0.9 + , ansi-terminal >= 0.10.3 , cmark , edit-distance @@ -80,6 +80,7 @@ executable carp , filepath , haskeline , process + , optparse-applicative default-language: Haskell2010 executable carp-header-parse @@ -90,8 +91,8 @@ executable carp-header-parse , CarpHask , containers , directory - , cmdargs , parsec + , optparse-applicative default-language: Haskell2010 test-suite CarpHask-test diff --git a/app/Main.hs b/app/Main.hs index 5057c18d..a9c18103 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,7 +2,9 @@ module Main where import qualified System.Environment as SystemEnvironment import System.Console.Haskeline (runInputT) +import Control.Monad (foldM) import GHC.IO.Encoding +import Data.Maybe import ColorText import Obj @@ -14,12 +16,20 @@ import Util import Path import Info +import Options.Applicative + defaultProject :: Project defaultProject = Project { projectTitle = "Untitled" , projectIncludes = [] - , projectCFlags = [""] - , projectLibFlags = [""] + , projectCFlags = case platform of + Windows -> ["-D_CRT_SECURE_NO_WARNINGS"] + _ -> [ "-fPIC" + , "-g" + ] + , projectLibFlags = case platform of + Windows -> [] + _ -> [ "-lm" ] , projectFiles = [] , projectAlreadyLoaded = [] , projectEchoC = False @@ -39,8 +49,8 @@ defaultProject = , projectCarpSearchPaths = [] , projectPrintTypedAST = False , projectCompiler = case platform of - Windows -> "clang-cl.exe -D _CRT_SECURE_NO_WARNINGS" - _ -> "clang -fPIC -lm -g" + Windows -> "clang-cl.exe" + _ -> "clang" , projectCore = True , projectEchoCompilationCommand = False , projectCanExecute = False @@ -54,94 +64,103 @@ main :: IO () main = do setLocaleEncoding utf8 args <- SystemEnvironment.getArgs sysEnv <- SystemEnvironment.getEnvironment - let (argFilesToLoad, execMode, otherOptions) = parseArgs args - logMemory = LogMemory `elem` otherOptions - noCore = NoCore `elem` otherOptions - noProfile = NoProfile `elem` otherOptions - optimize = Optimize `elem` otherOptions - generateOnly = GenerateOnly `elem` otherOptions - projectWithFiles = defaultProject { projectCFlags = ["-D LOG_MEMORY" | logMemory] ++ - ["-O3 -D NDEBUG" | optimize] ++ - projectCFlags defaultProject, - projectCore = not noCore, - projectGenerateOnly = generateOnly} + fullOpts <- execParser $ Options.Applicative.info (parseFull <**> helper) fullDesc + let execMode = optExecMode fullOpts + otherOptions = optOthers fullOpts + argFilesToLoad = optFiles fullOpts + logMemory = otherLogMemory otherOptions + core = not $ otherNoCore otherOptions + profile = not $ otherNoProfile otherOptions + optimize = otherOptimize otherOptions + generateOnly = otherGenerateOnly otherOptions + prompt = otherPrompt otherOptions + applySettings p = p { projectCFlags = ["-D LOG_MEMORY" | logMemory] ++ + ["-O3 -D NDEBUG" | optimize] + ++ projectCFlags p + , projectCore = core + , projectGenerateOnly = generateOnly + , projectCarpDir = fromMaybe (projectCarpDir p) $ lookup "CARP_DIR" sysEnv + , projectPrompt = fromMaybe (projectPrompt p) prompt + } + project = applySettings defaultProject noArray = False - coreModulesToLoad = if noCore then [] else coreModules (projectCarpDir projectWithCarpDir) - projectWithCarpDir = case lookup "CARP_DIR" sysEnv of - Just carpDir -> projectWithFiles { projectCarpDir = carpDir } - Nothing -> projectWithFiles - projectWithCustomPrompt = setCustomPromptFromOptions projectWithCarpDir otherOptions startingContext = Context - (startingGlobalEnv noArray) - Nothing - (TypeEnv startingTypeEnv) - [] - projectWithCustomPrompt - "" - execMode - [] - context <- loadFilesOnce startingContext coreModulesToLoad + (startingGlobalEnv noArray) + Nothing + (TypeEnv startingTypeEnv) + [] + project + "" + execMode + [] + coreModulesToLoad = if core then coreModules (projectCarpDir project) else [] + execStr :: String -> String -> Context -> IO Context + execStr info str ctx = executeString True False ctx str info + execStrs :: String -> [String] -> Context -> IO Context + execStrs info strs ctx = foldM (\ctx str -> execStr info str ctx) ctx strs + preloads = optPreload fullOpts + postloads = optPostload fullOpts + load = flip loadFiles carpProfile <- configPath "profile.carp" hasProfile <- doesFileExist carpProfile - context' <- if (not noProfile) && hasProfile - then loadFiles context [carpProfile] - else return context - finalContext <- loadFiles context' argFilesToLoad - case execMode of - Repl -> do putStrLn "Welcome to Carp 0.3.0" - putStrLn "This is free software with ABSOLUTELY NO WARRANTY." - putStrLn "Evaluate (help) for more information." - _ <- runRepl finalContext - return () - Build -> do _ <- executeString True False finalContext "(build)" "Compiler (Build)" - return () - Install thing -> - do _ <- executeString True False finalContext - ("(load \"" ++ thing ++ "\")") - "Installation" - return () - BuildAndRun -> do _ <- executeString True False finalContext "(do (build) (run))" "Compiler (Build & Run)" - -- TODO: Handle the return value from executeString and return that one to the shell - return () - Check -> return () - + _ <- loadFilesOnce startingContext coreModulesToLoad + >>= load [carpProfile | hasProfile] + >>= execStrs "Preload" preloads + >>= load argFilesToLoad + >>= execStrs "Postload" postloads + >>= \ctx -> case execMode of + Repl -> do putStrLn "Welcome to Carp 0.3.0" + putStrLn "This is free software with ABSOLUTELY NO WARRANTY." + putStrLn "Evaluate (help) for more information." + snd <$> runRepl ctx + Build -> execStr "Compiler (Build)" "(build)" ctx + Install thing -> execStr "Installation" ("(load \"" ++ thing ++ "\")") ctx + BuildAndRun -> execStr "Compiler (Build & Run)" "(do (build) (run))" ctx + Check -> execStr "Check" "" ctx + -- TODO: Handle the return value from executeString and return that one to the shell + pure () -- | Options for how to run the compiler. -data OtherOptions = NoCore - | NoProfile - | LogMemory - | Optimize - | GenerateOnly - | SetPrompt String - deriving (Show, Eq) +data FullOptions = FullOptions + { optExecMode :: ExecutionMode + , optOthers :: OtherOptions + , optPreload :: [String] + , optPostload :: [String] + , optFiles :: [FilePath] + } deriving Show --- | Parse the arguments sent to the compiler from the terminal. --- | TODO: Switch to 'cmdargs' library for parsing these! -parseArgs :: [String] -> ([FilePath], ExecutionMode, [OtherOptions]) -parseArgs args = parseArgsInternal [] Repl [] args - where parseArgsInternal filesToLoad execMode otherOptions [] = - (filesToLoad, execMode, otherOptions) - parseArgsInternal filesToLoad execMode otherOptions (arg:restArgs) = - case arg of - "-b" -> parseArgsInternal filesToLoad Build otherOptions restArgs - "-x" -> parseArgsInternal filesToLoad BuildAndRun otherOptions restArgs - "-i" -> parseArgsInternal filesToLoad (Install (head restArgs)) otherOptions (tail restArgs) - "--check" -> parseArgsInternal filesToLoad Check otherOptions restArgs - "--no-core" -> parseArgsInternal filesToLoad execMode (NoCore : otherOptions) restArgs - "--no-profile" -> parseArgsInternal filesToLoad execMode (NoProfile : otherOptions) restArgs - "--log-memory" -> parseArgsInternal filesToLoad execMode (LogMemory : otherOptions) restArgs - "--optimize" -> parseArgsInternal filesToLoad execMode (Optimize : otherOptions) restArgs - "--generate-only" -> parseArgsInternal filesToLoad execMode (GenerateOnly : otherOptions) restArgs - "--prompt" -> case restArgs of - newPrompt : restRestArgs -> - parseArgsInternal filesToLoad execMode (SetPrompt newPrompt : otherOptions) restRestArgs - _ -> - error "No prompt given after --prompt" - file -> parseArgsInternal (filesToLoad ++ [file]) execMode otherOptions restArgs +parseFull :: Parser FullOptions +parseFull = FullOptions + <$> parseExecMode + <*> parseOther + <*> many (strOption (long "eval-preload" <> metavar "CODE" <> help "Eval CODE after loading config and before FILES")) + <*> many (strOption (long "eval-postload" <> metavar "CODE" <> help "Eval CODE after loading FILES")) + <*> parseFiles -setCustomPromptFromOptions :: Project -> [OtherOptions] -> Project -setCustomPromptFromOptions project (o:os) = - case o of - SetPrompt newPrompt -> setCustomPromptFromOptions (project { projectPrompt = newPrompt }) os - _ -> setCustomPromptFromOptions project os -setCustomPromptFromOptions project _ = - project +data OtherOptions = OtherOptions + { otherNoCore :: Bool + , otherNoProfile :: Bool + , otherLogMemory :: Bool + , otherOptimize :: Bool + , otherGenerateOnly :: Bool + , otherPrompt :: Maybe String + } deriving Show + +parseOther :: Parser OtherOptions +parseOther = OtherOptions + <$> switch (long "no-core" <> help "Don't load Core.carp") + <*> switch (long "no-profile" <> help "Don't load profile.carp") + <*> switch (long "log-memory" <> help "Log memory allocations") + <*> switch (long "optimize" <> help "Optimized build") + <*> switch (long "generate-only" <> help "Stop after generating the C code") + <*> optional (strOption (long "prompt" <> help "Set REPL prompt")) + +parseExecMode :: Parser ExecutionMode +parseExecMode = + flag' Check (long "check" <> help "Check project") + <|> flag' Build (short 'b' <> help "Build project") + <|> flag' BuildAndRun (short 'x' <> help "Build an run project") + <|> Install <$> strOption (short 'i' <> help "Install built product") + <|> pure Repl + +parseFiles :: Parser [FilePath] +parseFiles = many (argument str (metavar "FILES...")) diff --git a/carp.sh b/carp.sh index 41321c0a..453879dd 100755 --- a/carp.sh +++ b/carp.sh @@ -1,3 +1,4 @@ +#!/usr/bin/env bash if [ -z "$CARP" ] then if [ -z "$NIX_CC" ] @@ -7,4 +8,4 @@ then CARP="cabal -v0 run carp" fi fi -$CARP $BUILD_OPTS $"--" $* +$CARP $BUILD_OPTS -- $CARP_OPTS "$@" diff --git a/core/SafeInt.carp b/core/SafeInt.carp index 779a43e2..97cf0796 100644 --- a/core/SafeInt.carp +++ b/core/SafeInt.carp @@ -1,12 +1,10 @@ (system-include "carp_safe_int.h") (defmodule Int - (not-on-windows ; this seems to generate invalid code on some windows machines - (doc safe-add "Performs an addition and checks whether it overflowed.") - (register safe-add (λ [Int Int (Ref Int)] Bool)) - (doc safe-sub "Performs an substraction and checks whether it overflowed.") - (register safe-sub (λ [Int Int (Ref Int)] Bool)) - (doc safe-mul "Performs an multiplication and checks whether it overflowed.") - (register safe-mul (λ [Int Int (Ref Int)] Bool)) - ) + (doc safe-add "Performs an addition and checks whether it overflowed.") + (register safe-add (λ [Int Int (Ref Int)] Bool)) + (doc safe-sub "Performs an substraction and checks whether it overflowed.") + (register safe-sub (λ [Int Int (Ref Int)] Bool)) + (doc safe-mul "Performs an multiplication and checks whether it overflowed.") + (register safe-mul (λ [Int Int (Ref Int)] Bool)) ) diff --git a/core/carp_long.h b/core/carp_long.h index d7cdc7ad..b512eced 100644 --- a/core/carp_long.h +++ b/core/carp_long.h @@ -10,7 +10,7 @@ Long Long__MUL_(Long x, Long y) { Long Long__DIV_(Long x, Long y) { return x / y; } -#ifndef _WIN32 +#if defined __GNUC__ bool Long_safe_MINUS_add(Long x, Long y, Long* res) { return __builtin_add_overflow(x, y, res); } @@ -20,6 +20,22 @@ bool Long_safe_MINUS_sub(Long x, Long y, Long* res) { bool Long_safe_MINUS_mul(Long x, Long y, Long* res) { return __builtin_mul_overflow(x, y, res); } +#else +bool Long_safe_MINUS_add(Long x, Long y, Long* res) { + Long r = x + y; + *res = r; + return (y > 0) && (x > (INT64_MAX - y)) || (y < 0) && (x < (INT64_MIN - y)); +} +bool Long_safe_MINUS_sub(Long x, Long y, Long* res) { + Long r = x - y; + *res = r; + return (y > 0 && x < (INT64_MIN + y)) || (y < 0 && x > (INT64_MAX + y)); +} +bool Long_safe_MINUS_mul(Long x, Long y, Long* res) { + Long r = x * y; + *res = r; + return y == 0 || (r / y) != x; +} #endif bool Long__EQ_(Long x, Long y) { return x == y; diff --git a/core/carp_safe_int.h b/core/carp_safe_int.h index 019183f4..cc55374e 100644 --- a/core/carp_safe_int.h +++ b/core/carp_safe_int.h @@ -1,4 +1,4 @@ -#ifndef _WIN32 +#if defined __GNUC__ bool Int_safe_MINUS_add(int x, int y, int* res) { return __builtin_add_overflow(x, y, res); } @@ -8,4 +8,21 @@ bool Int_safe_MINUS_sub(int x, int y, int* res) { bool Int_safe_MINUS_mul(int x, int y, int* res) { return __builtin_mul_overflow(x, y, res); } +#else +bool Int_safe_MINUS_add(int x, int y, int* res) { + int r = x + y; + *res = r; + return (y > 0) && (x > (INT_MAX - y)) || (y < 0) && (x < (INT_MIN - y)); +} +bool Int_safe_MINUS_sub(int x, int y, int* res) { + int r = x - y; + *res = r; + *res = x - y; + return (y > 0 && x < (INT_MIN + y)) || (y < 0 && x > (INT_MAX + y)); +} +bool Int_safe_MINUS_mul(int x, int y, int* res) { + int r = x * y; + *res = r; + return y == 0 || (r / y) != x; +} #endif diff --git a/default.nix b/default.nix index 18f68d2e..0a9d104a 100644 --- a/default.nix +++ b/default.nix @@ -11,9 +11,10 @@ let optionals = nixpkgs.stdenv.lib.optionals; linuxOnly = optionals nixpkgs.stdenv.isLinux; - f = { mkDerivation, ansi-terminal, base, blaze-html, blaze-markup - , cmark, cmdargs, containers, directory, edit-distance, filepath - , haskeline, HUnit, mtl, parsec, process, split, stdenv, text + f = { mkDerivation, stdenv + , ansi-terminal, base, blaze-html, blaze-markup + , cmark, containers, directory, edit-distance, filepath + , haskeline, HUnit, mtl, optparse-applicative, parsec, process, split, text , darwin, glfw3, SDL2, SDL2_image, SDL2_gfx, SDL2_mixer, SDL2_ttf , ghc-prof-flamegraph , clang , makeWrapper @@ -39,7 +40,7 @@ let [ glfw3 SDL2 SDL2_image SDL2_gfx SDL2_mixer SDL2_ttf ] ++ linuxOnly [ libXext libXcursor libXinerama libXi libXrandr libXScrnSaver libXxf86vm libpthreadstubs libXdmcp libGL]; executableHaskellDepends = [ - base cmdargs containers directory haskeline parsec process + base containers directory haskeline optparse-applicative parsec process clang ]; executableFrameworkDepends = with darwin.apple_sdk.frameworks; optionals stdenv.isDarwin [ @@ -73,6 +74,6 @@ in if pkgs.lib.inNixShell then drv.env.overrideAttrs (o: { buildInputs = with pkgs; o.buildInputs ++ [ haskellPackages.cabal-install clang gdb ] - ++ linuxOnly [ flamegraph linuxPackages.perf ]; + ++ linuxOnly [ flamegraph linuxPackages.perf tinycc ]; }) else drv diff --git a/examples/basics.carp b/examples/basics.carp index fee76dee..c01356cb 100644 --- a/examples/basics.carp +++ b/examples/basics.carp @@ -234,4 +234,5 @@ (two-lengths-in-same-func) (changing-target-of-ref) (resolve-correctly) + 0 )) diff --git a/headerparse/Main.hs b/headerparse/Main.hs index e7e13a4a..c1275549 100644 --- a/headerparse/Main.hs +++ b/headerparse/Main.hs @@ -3,7 +3,7 @@ module Main where -import System.Console.CmdArgs +import Options.Applicative hiding ((<|>)) import Text.Parsec ((<|>)) import qualified Text.Parsec as Parsec import Data.Char (toLower, isUpper) @@ -12,16 +12,18 @@ import Types import Obj import Path -data Args = Args { sourcePath :: String - , prefixToRemove :: String +data Args = Args { prefixToRemove :: String , kebabCase :: Bool - } deriving (Show, Data, Typeable) + , sourcePath :: String + } deriving Show -main = do parsedArgs <- cmdArgs (Args { sourcePath = def &= argPos 0 - , prefixToRemove = def - , kebabCase = False - } - &= summary "Carp Header Parse 0.0.1") +parseArgs :: Parser Args +parseArgs = Args + <$> strOption (long "prefixtoremove" <> short 'p' <> metavar "ITEM" <> value "") + <*> switch (long "kebabcase" <> short 'f') + <*> argument str (metavar "FILE") + +main = do parsedArgs <- execParser $ Options.Applicative.info (parseArgs <**> helper) fullDesc let path = sourcePath parsedArgs if path /= "" then do source <- slurp path diff --git a/src/Emit.hs b/src/Emit.hs index 76a12a80..06fa6a41 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -702,10 +702,12 @@ memberToDecl indent (memberName, memberType) = defStructToDeclaration :: Ty -> SymPath -> [XObj] -> String defStructToDeclaration structTy@(StructTy typeName typeVariables) path rest = - let indent' = indentAmount + let indent = indentAmount typedefCaseToMemberDecl :: XObj -> State EmitterState [()] - typedefCaseToMemberDecl (XObj (Arr members) _ _) = mapM (memberToDecl indent') (pairwise members) + -- ANSI C doesn't allow empty structs, insert a dummy member to keep the compiler happy. + typedefCaseToMemberDecl (XObj (Arr []) _ _) = sequence $ pure $ appendToSrc (addIndent indent ++ "char __dummy;\n") + typedefCaseToMemberDecl (XObj (Arr members) _ _) = mapM (memberToDecl indent) (pairwise members) typedefCaseToMemberDecl _ = error "Invalid case in typedef." -- Note: the names of types are not namespaced diff --git a/src/Eval.hs b/src/Eval.hs index 5486f53d..1d4a4971 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -814,18 +814,21 @@ printC xobj = buildMainFunction :: XObj -> XObj buildMainFunction xobj = - XObj (Lst [ XObj (Defn Nothing) (Just dummyInfo) Nothing - , XObj (Sym (SymPath [] "main") Symbol) (Just dummyInfo) Nothing - , XObj (Arr []) (Just dummyInfo) Nothing - , case ty xobj of - Just UnitTy -> xobj - Just (RefTy _ _) -> XObj (Lst [XObj (Sym (SymPath [] "println*") Symbol) (Just dummyInfo) Nothing, xobj]) - (Just dummyInfo) (Just UnitTy) - Just _ -> XObj (Lst [XObj (Sym (SymPath [] "println*") Symbol) (Just dummyInfo) Nothing, - XObj (Lst [XObj Ref (Just dummyInfo) Nothing, xobj]) - (Just dummyInfo) (Just UnitTy)]) - (Just dummyInfo) (Just UnitTy) - ]) (Just dummyInfo) (Just (FuncTy [] UnitTy StaticLifetimeTy)) + XObj (Lst [ XObj (Defn Nothing) di Nothing + , XObj (Sym (SymPath [] "main") Symbol) di Nothing + , XObj (Arr []) di Nothing + , XObj (Lst [ XObj Do di Nothing + , case ty xobj of + Just UnitTy -> xobj + Just (RefTy _ _) -> XObj (Lst [XObj (Sym (SymPath [] "println*") Symbol) di Nothing, xobj]) + di (Just UnitTy) + Just _ -> XObj (Lst [XObj (Sym (SymPath [] "println*") Symbol) di Nothing, + XObj (Lst [XObj Ref di Nothing, xobj]) + di (Just UnitTy)]) + di (Just UnitTy) + , XObj (Num IntTy 0) di Nothing + ]) di Nothing]) di (Just (FuncTy [] UnitTy StaticLifetimeTy)) + where di = Just dummyInfo primitiveDefdynamic :: Primitive primitiveDefdynamic _ ctx [XObj (Sym (SymPath [] name) _) _ _, value] = do diff --git a/src/Repl.hs b/src/Repl.hs index 34dacddf..7ede7792 100644 --- a/src/Repl.hs +++ b/src/Repl.hs @@ -151,6 +151,7 @@ resetAlreadyLoadedFiles context = proj' = proj { projectAlreadyLoaded = [] } in context { contextProj = proj' } +runRepl :: Context -> IO ((), Context) runRepl context = do historyFile <- configPath "history" createDirectoryIfMissing True (takeDirectory historyFile) diff --git a/stack.yaml b/stack.yaml index 042bea02..19fd11f7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: lts-14.9 +resolver: lts-15.3 # User packages to be built. # Various formats can be used as shown in the example below. @@ -39,7 +39,7 @@ packages: - '.' # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) -extra-deps: [ansi-terminal-0.9] +extra-deps: [] # Override default flag values for local packages and extra-deps flags: {} diff --git a/test/init_global.carp b/test/init_global.carp index 0b06cfd7..73818c83 100644 --- a/test/init_global.carp +++ b/test/init_global.carp @@ -6,4 +6,6 @@ ;; The one allocation left after 'carp_init_globals' should be 'g' itself: (defn main [] - (assert (= 1l (Debug.memory-balance)))) + (do + (assert (= 1l (Debug.memory-balance))) + 0))