Merge pull request #894 from jacereda/addc

Added add-c to include additional compilation units in the compiler i…

app/Main.hs

@@ -70,6 +70,8 @@ defaultProject =
           , projectGenerateOnly = False
           , projectForceReload = False
           , projectPkgConfigFlags = []
+          , projectCModules = []
+          , projectLoadStack = []
           }
 
 -- | Starting point of the application.

core/Dynamic.carp

@@ -49,3 +49,14 @@
   (do
     (add-cflag (pkg-config pkg "--cflags"))
     (add-lib (pkg-config pkg "--libs"))))
+
+(defndynamic current-file []
+  (car (Project.get-config "load-stack")))
+
+(defndynamic relative-to [path relpath]
+  (Dynamic.String.concat [(Dynamic.Path.directory path)
+                          "/"
+                          relpath]))
+
+(defndynamic add-c [relpath]
+  (Project.config "cmod" (relative-to (current-file) relpath)))

src/Commands.hs

@@ -10,6 +10,7 @@ import System.Exit (exitSuccess, exitFailure, exitWith, ExitCode(..))
 import System.Info (os)
 import System.Process (callCommand, spawnCommand, waitForProcess)
 import System.IO (openFile, hPutStr, hClose, utf8, hSetEncoding, IOMode(..))
+import System.Directory (makeAbsolute)
 import qualified Data.Map as Map
 
 import Parsing
@@ -90,6 +91,8 @@ commandProjectConfig ctx [xobj@(XObj (Str key) _ _), value] = do
                                   return (proj { projectLibFlags = addIfNotPresent libflag (projectLibFlags proj) })
                   "pkgconfigflag" -> do pkgconfigflag <- unwrapStringXObj value
                                         return (proj { projectPkgConfigFlags = addIfNotPresent pkgconfigflag (projectPkgConfigFlags proj) })
+                  "cmod" -> do cmod <- unwrapStringXObj value
+                               return (proj { projectCModules = addIfNotPresent cmod (projectCModules proj) })
                   "prompt" -> do prompt <- unwrapStringXObj value
                                  return (proj { projectPrompt = prompt })
                   "search-path" -> do searchPath <- unwrapStringXObj value
@@ -148,6 +151,7 @@ commandProjectGetConfig ctx [xobj@(XObj (Str key) _ _)] =
           "cflag" -> Right $ Str $ show $ projectCFlags proj
           "libflag" -> Right $ Str $ show $ projectLibFlags proj
           "pkgconfigflag" -> Right $ Arr $ xstr . Str <$> projectPkgConfigFlags proj
+          "load-stack" -> Right $ Arr $ xstr . Str <$> projectLoadStack proj
           "prompt" -> Right $ Str $ projectPrompt proj
           "search-path" -> Right $ Str $ show $ projectCarpSearchPaths proj
           "print-ast" -> Right $ Bol $ projectPrintTypedAST proj
@@ -226,8 +230,9 @@ commandBuild shutUp ctx args = do
       do let compiler = projectCompiler proj
              echoCompilationCommand = projectEchoCompilationCommand proj
              incl = projectIncludesToC proj
-             includeCorePath = " -I" ++ projectCarpDir proj ++ "/core/ "
-             flags = includeCorePath ++ projectFlags proj
+             includeCorePath = projectCarpDir proj ++ "/core/ "
+             cModules = projectCModules proj
+             flags = projectFlags proj
              outDir = projectOutDir proj
              outMain = outDir </> "main.c"
              outExe = outDir </> projectTitle proj
@@ -240,7 +245,14 @@ commandBuild shutUp ctx args = do
          hClose outputHandle
          if generateOnly then return (ctx, dynamicNil) else
              case Map.lookup "main" (envBindings env) of
-                             Just _ -> do let cmd = compiler ++ " " ++ outMain ++ " -o \"" ++ outExe ++ "\" " ++ flags
+                             Just _ -> do let cmd = joinWithSpace $ [ compiler
+                                                                    , "-o"
+                                                                    , outExe
+                                                                    , "-I"
+                                                                    , includeCorePath
+                                                                    , flags
+                                                                    , outMain
+                                                                    ] ++ cModules
                                           liftIO $ do when echoCompilationCommand (putStrLn cmd)
                                                       callCommand cmd
                                                       when (execMode == Repl && not shutUp) (putStrLn ("Compiled to '" ++ outExe ++ "' (executable)"))
@@ -381,6 +393,7 @@ commandHelp ctx [XObj(Str "interop") _ _] =
               putStrLn "(local-include <file>)           - Include a local header file."
               putStrLn "(add-cflag <flag>)               - Add a cflag to the compilation step."
               putStrLn "(add-lib <flag>)                 - Add a library flag to the compilation step."
+              putStrLn "(add-c <flag>)                   - Add a C/ObjC/C++ module to the compilation step."
               return (ctx, dynamicNil)
 
 commandHelp ctx [XObj(Str "project") _ _] =
@@ -389,6 +402,7 @@ commandHelp ctx [XObj(Str "project") _ _] =
               putStrLn "'cflag'                - Add a flag to the compiler."
               putStrLn "'libflag'              - Add a library flag to the compiler."
               putStrLn "'pkgconfigflag'        - Add a flag to pkg-config invocations."
+              putStrLn "'cmod'                 - Add a C/ObjC/C++ module to the compiler invocation."
               putStrLn "'compiler'             - Set what compiler should be run with the 'build' command."
               putStrLn "'title'                - Set the title of the current project, will affect the name of the binary produced."
               putStrLn "'output-directory'     - Where to put compiler artifacts, etc."
@@ -739,13 +753,21 @@ simpleFromNum (Num IntTy num) = show (round num :: Int)
 simpleFromNum (Num LongTy num) = show (round num :: Int)
 simpleFromNum (Num _ num) = show num
 
-commandStringDirectory :: CommandCallback
-commandStringDirectory ctx [a] =
+commandPathDirectory :: CommandCallback
+commandPathDirectory ctx [a] =
   return $ case a of
     XObj (Str s) _ _ ->
       (ctx, Right (XObj (Str (takeDirectory s)) (Just dummyInfo) (Just StringTy)))
     _ -> evalError ctx ("Can't call `directory` with " ++ pretty a) (info a)
 
+commandPathAbsolute :: CommandCallback
+commandPathAbsolute ctx [a] =
+  case a of
+    XObj (Str s) _ _ -> do
+      abs <- makeAbsolute s
+      pure $ (ctx, Right (XObj (Str abs) (Just dummyInfo) (Just StringTy)))
+    _ -> pure $ evalError ctx ("Can't call `absolute` with " ++ pretty a) (info a)
+
 commandPlus :: CommandCallback
 commandPlus ctx [a, b] =
   return $ case (a, b) of

src/Eval.hs

@@ -641,9 +641,14 @@ loadInternal ctx xobj path i reloadMode = do
                           files' = if canonicalPath `elem` (map fst files)
                                    then files
                                    else files ++ [(canonicalPath, reloadMode)]
-                          proj' = proj { projectFiles = files', projectAlreadyLoaded = canonicalPath : alreadyLoaded }
+                          prevStack = projectLoadStack proj
+                          proj' = proj { projectFiles = files'
+                                       , projectAlreadyLoaded = canonicalPath : alreadyLoaded
+                                       , projectLoadStack = canonicalPath : prevStack
+                                       }
                       newCtx <- liftIO $ executeString True False (ctx { contextProj = proj' }) contents canonicalPath
-                      return (newCtx, dynamicNil)
+
+                      return (newCtx { contextProj = (contextProj newCtx) { projectLoadStack = prevStack } }, dynamicNil)
   where
     frozenPaths proj =
       if projectForceReload proj

src/Project.hs

@@ -33,6 +33,8 @@ data Project = Project { projectTitle :: String
                        , projectGenerateOnly :: Bool
                        , projectBalanceHints :: Bool
                        , projectForceReload :: Bool -- Setting this to true will make the `load-once` command work just like `load`.
+                       , projectCModules :: [FilePath]
+                       , projectLoadStack :: [FilePath]
                        }
 
 projectFlags :: Project -> String
@@ -68,6 +70,8 @@ instance Show Project where
             , "Generate Only: " ++ showB projectGenerateOnly
             , "Balance Hints: " ++ showB projectBalanceHints
             , "Force Reload: " ++ showB projectForceReload
+            , "C modules:\n    " ++ joinIndented projectCModules
+            , "Load stack:\n    "++ joinIndented projectLoadStack
             ]
     where showB b = if b then "true" else "false"
           joinIndented = joinWith "\n    "

src/StartingEnv.hs

@@ -254,6 +254,7 @@ dynamicModule = Env { envBindings = bindings
                     ++ [("String", Binder emptyMeta (XObj (Mod dynamicStringModule) Nothing Nothing))
                        ,("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule) Nothing Nothing))
                        ,("Project", Binder emptyMeta (XObj (Mod dynamicProjectModule) Nothing Nothing))
+                       ,("Path", Binder emptyMeta (XObj (Mod dynamicPathModule) Nothing Nothing))
                        ]
 
 -- | A submodule of the Dynamic module. Contains functions for working with strings in the repl or during compilation.
@@ -270,7 +271,6 @@ dynamicStringModule = Env { envBindings = bindings
                                 , addCommand (SymPath path "slice") 3 commandSubstring "creates a substring from a beginning index to an end index." "(String.slice \"hello\" 1 3) ; => \"ell\""
                                 , addCommand (SymPath path "length") 1 commandStringLength "gets the length of a string." "(String.length \"hi\") ; => 2"
                                 , addCommand (SymPath path "concat") 1 commandStringConcat "concatenates a list of strings together." "(String.concat [\"hi \" \"there\"]) ; => \"hi there\""
-                                , addCommand (SymPath path "directory") 1 commandStringDirectory "takes the basename of a string taken to be a filepath.\n\nHistorical note: this is a command because it used to power one of the `include` macros." "(String.directory \"dir/file\") ; => \"dir\""
                                 ]
 
 -- | A submodule of the Dynamic module. Contains functions for working with symbols in the repl or during compilation.
@@ -301,6 +301,19 @@ dynamicProjectModule = Env { envBindings = bindings
                                 , addCommand (SymPath path "get-config") 1 commandProjectGetConfig "gets a project config value under a key." "(Project.get-config \"paren-balance-hints\")"
                                 ]
 
+-- | A submodule of the Dynamic module. Contains functions for working with paths.
+dynamicPathModule :: Env
+dynamicPathModule = Env { envBindings = bindings
+                        , envParent = Nothing
+                        , envModuleName = Just "Path"
+                        , envUseModules = []
+                        , envMode = ExternalEnv
+                        , envFunctionNestingLevel = 0 }
+  where path = ["Dynamic", "Path"]
+        bindings = Map.fromList [ addCommand (SymPath path "directory") 1 commandPathDirectory "takes the basename of a string taken to be a filepath.\n\nHistorical note: this is a command because it used to power one of the `include` macros." "(String.directory \"dir/file\") ; => \"dir\""
+                                , addCommand (SymPath path "absolute") 1 commandPathAbsolute "converts a filepath to absolute." "(String.absolute \"dir/file\") ; => \"/home/foo/dir/file\""
+                                ]
+
 -- | The global environment before any code is run.
 startingGlobalEnv :: Bool -> Env
 startingGlobalEnv noArray =

test/add-c.carp

@@ -0,0 +1,9 @@
+(load "Test.carp")
+(use Test)
+(add-c "csquare.c")
+
+(relative-include "csquare.h")
+(register csquare (Fn [Int] Int))
+
+(deftest test
+    (assert-equal test (csquare 2) 4 "add-c works"))

test/csquare.c

@@ -0,0 +1,3 @@
+int csquare(int a) {
+    return a * a;
+}

test/csquare.h

@@ -0,0 +1 @@
+int csquare(int);