feat: Add support for emitting literal C (#1178)

app/Main.hs

@@ -71,7 +71,8 @@ defaultProject =
       projectForceReload = False,
       projectPkgConfigFlags = [],
       projectCModules = [],
-      projectLoadStack = []
+      projectLoadStack = [],
+      projectPreproc = []
     }
 
 -- | Starting point of the application.

core/core.h

@@ -15,6 +15,7 @@ typedef char *Pattern;
 typedef int64_t Long;
 typedef uint32_t Char;
 typedef char CChar;
+typedef void *c_code;
 
 #if defined NDEBUG
 #define CHK_INDEX(i, n)

docs/CInterop.md

@@ -12,6 +12,8 @@ This is an extension of what is covered in the [Language Guide](./LanguageGuide.
   - [`deftemplate`](#deftemplate)
     - [`Basic example`](#basic-example)
     - [`Generics`](#generics)
+  - [`emit-c`](#unsafe-emit-c)
+  - [`preproc`](#unsafe-preproc)
 - [Callbacks](#callbacks)
 
 
@@ -40,7 +42,7 @@ generated on the C side. Here are some examples:
 
 ; Generic signature
 (sig print-first-and-add (Fn [(Ref (Array a)) b b] b))
-(defn print-first-and-add [arr x y] 
+(defn print-first-and-add [arr x y]
  (do
    (println* (Array.unsafe-first arr))
    (+ x y)))
@@ -52,10 +54,10 @@ generated on the C side. Here are some examples:
 ; => print_MINUS_first_MINUS_and_MINUS_add__String_Long
 ```
 
-Looking at the examples should be clear enough but let's break it down:  
+Looking at the examples should be clear enough but let's break it down:
 Carp will replace illegal characters in C with a string representation of them
-(`- => _MINUS_`, `? => _QMARK_`, etc...)  
-If in modules it will prefix the identifier with the modules name.  
+(`- => _MINUS_`, `? => _QMARK_`, etc...)
+If in modules it will prefix the identifier with the modules name.
 When the arguments to a function are generic it will suffix the types to the
 identifiers, the identifiers are not able to be generated until it is used. If
 a function is potentially generic but you don't want it to be you can add a
@@ -274,19 +276,19 @@ We can instead define the previous example like so:
 (print @"Print this!")
 ```
 
-Let's break down what's going on here:  
+Let's break down what's going on here:
 The **first** argument to `deftemplate` is the name we'll use to refer to the
-function.  
+function.
 The **second** is a type signature and is identical to the one found
-in our previous `register` call.  
+in our previous `register` call.
 The **third** is our function declaration, it'll be injected at the top of the
-generated C file.  
+generated C file.
 The **last** argument represent the function definition.
 
-Two more things to look at:  
+Two more things to look at:
 `$NAME` is a variable that will be derived from the name you've given the
 function plus any module it's defined in, so no need to worry about name
-clashes with other `print` functions in other modules.  
+clashes with other `print` functions in other modules.
 `$DECL` will be replaced with the declaration passed as a third argument when
 the function is defined
 
@@ -343,6 +345,70 @@ out/main.c:9153:29: error: invalid operands to binary expression ('String' (aka
 1 error generated.
 ```
 
+### `Unsafe.emit-c`
+
+While `deftemplate` is flexible and sufficient for most use cases, there are
+certain scenarios in which it won't accomplish what you need. For example, some
+C macros, such as c11's `static_assert` require a string literal argument.
+`deftemplate` can't accomplish this. In such cases, you can use `Unsafe.emit-c`
+to emit a literal string in the Carp compiler's C output. `emit-c` is perfect
+for scenarios like `static_assert` calls. Assuming `static_assert` is
+`register`ed as `static-assert`, we can use `emit-c` in the following way to
+ensure it is passed a string literal in the compiler's emitted C code:
+
+```
+(register static-assert (Fn [a C] ()))
+
+(static-assert 0 (Unsafe.emit-c "\"foo\""))
+```
+
+which will emit the corresponding C:
+
+```
+static_assert(0, "foo")
+```
+
+`emit-C` returns values of the `C` type, a special type that represents literal
+C code in Carp.
+
+### `Unsafe.preproc`
+
+The Carp compiler emits C code in an order that ensures the dependencies of
+functions are available before functions are called. Sometimes, you may want to
+include C code before the Carp compiler's output. For instance, you might want
+to provide some preprocessor directives to a C compiler. The `Unsafe.preproc`
+function was designed with this use case in mind. You can use `preproc` to
+inject arbitrary C code prior to the Carp compiler's normal C output. Any code
+passed to `preproc` will be emitted after file `includes` but before any other
+emitted C code.
+
+`preproc` takes a value of type `C` as an argument, so it must be used in
+combination with `Unsafe.emit-c`. The C code you pass to `preproc` isn't
+checked at all, so be careful!
+
+If you do define C symbols using `preproc`, you'll still need to call
+`register` to reference them in Carp code. For example, the following snippet
+uses `preproc` to make a C macro and function available in the Carp compiler's
+output and then calls `register` to reference these symbols in the `main`
+function in the Carp source:
+
+```
+(Unsafe.preproc (Unsafe.emit-c "#define FOO 0"))
+(Unsafe.preproc (Unsafe.emit-c "void foo() { printf(\"%d\\n\", 1); }"))
+
+(register FOO Int)
+(register foo (Fn [] ()))
+
+(defn main []
+  (do (foo)
+      (IO.println &(fmt "%d" FOO))))
+```
+
+You can use this technique to add provisional definitions you need to reference
+in compiler output. If your helper functions, macros, or preprocessor
+directives are lengthy or complex, you may want to define them in a separate
+`h` file and `relative-include` it in your Carp source instead.
+
 ## Callbacks
 
 Some C APIs rely on callbacks, let's define a C function that accepts a

src/Commands.hs

@@ -1,6 +1,7 @@
 module Commands where
 
 import ColorText
+import Context
 import Control.Exception
 import Control.Monad (join, when)
 import Control.Monad.IO.Class (MonadIO, liftIO)
@@ -303,6 +304,7 @@ commandBuild ctx [XObj (Bol shutUp) _ _] = do
         let compiler = projectCompiler proj
             echoCompilationCommand = projectEchoCompilationCommand proj
             incl = projectIncludesToC proj
+            preproc = projectPreprocToC proj
             includeCorePath = projectCarpDir proj ++ "/core/ "
             cModules = projectCModules proj
             flags = projectFlags proj
@@ -334,7 +336,7 @@ commandBuild ctx [XObj (Bol shutUp) _ _] = do
         liftIO $ createDirectoryIfMissing False outDir
         outputHandle <- openFile outMain WriteMode
         hSetEncoding outputHandle utf8
-        hPutStr outputHandle (incl ++ okSrc)
+        hPutStr outputHandle (incl ++ preproc ++ okSrc)
         hClose outputHandle
         if generateOnly
           then pure (ctx, dynamicNil)
@@ -396,6 +398,17 @@ commandAddInclude includerConstructor ctx x =
     _ ->
       pure (evalError ctx ("Argument to 'include' must be a string, but was `" ++ pretty x ++ "`") (xobjInfo x))
 
+-- | Command for adding preprocessing directives to emitted C output.
+-- All of the directives will be emitted after the project includes and before any other code.
+commandPreproc :: UnaryCommandCallback
+commandPreproc ctx (XObj (C c) _ _) =
+  let proj = contextProj ctx
+      preprocs = (projectPreproc proj) ++ [c]
+      proj' = proj {projectPreproc = preprocs}
+   in pure (replaceProject ctx proj', dynamicNil)
+commandPreproc ctx x =
+  pure (evalError ctx ("Argument to 'preproc' must be C code, but was `" ++ pretty x ++ "`") (xobjInfo x))
+
 commandAddSystemInclude :: UnaryCommandCallback
 commandAddSystemInclude = commandAddInclude SystemInclude
 
@@ -715,6 +728,17 @@ commandSaveDocsInternal ctx modulePath = do
         Nothing ->
           Left ("I can’t find the module `" ++ show path ++ "`")
 
+-- | Command for emitting literal C code from Carp.
+-- The string passed to this function will be emitted as is.
+-- This is necessary in some C interop contexts, e.g. calling macros that only accept string literals:
+--   (static-assert 0 (emit-c "\"foo\""))
+-- Also used in combination with the preproc command.
+commandEmitC :: UnaryCommandCallback
+commandEmitC ctx (XObj (Str c) i _) =
+  pure (ctx, Right (XObj (C c) i (Just CTy)))
+commandEmitC ctx xobj =
+  pure (evalError ctx ("Invalid argument to emit-c (expected a string):" ++ pretty xobj) (xobjInfo xobj))
+
 saveDocs :: Context -> [(SymPath, Binder)] -> IO (Context, Either a XObj)
 saveDocs ctx pathsAndEnvBinders = do
   liftIO (saveDocsForEnvs (contextProj ctx) pathsAndEnvBinders)
@@ -807,6 +831,7 @@ commandType :: UnaryCommandCallback
 commandType ctx (XObj x _ _) =
   pure (ctx, Right (XObj (Sym (SymPath [] (typeOf x)) Symbol) Nothing Nothing))
   where
+    typeOf (C _) = "C"
     typeOf (Str _) = "string"
     typeOf (Sym _ _) = "symbol"
     typeOf (MultiSym _ _) = "multi-symbol"

src/Emit.hs

@@ -3,6 +3,7 @@ module Emit
     envToC,
     globalsToC,
     projectIncludesToC,
+    projectPreprocToC,
     envToDeclarations,
     checkForUnresolvedSymbols,
     ToCMode (..),
@@ -172,6 +173,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
             (Match _) -> dontVisit
             With -> dontVisit
             MetaStub -> dontVisit
+            C c -> pure c
     visitStr' indent str i shouldEscape =
       -- This will allocate a new string every time the code runs:
       -- do let var = freshVar i
@@ -946,6 +948,11 @@ projectIncludesToC proj = intercalate "\n" (map includerToC includes) ++ "\n\n"
     includerToC (RelativeInclude file) = "#include \"" ++ file ++ "\""
     includes = projectIncludes proj
 
+projectPreprocToC :: Project -> String
+projectPreprocToC proj = intercalate "\n" preprocs ++ "\n\n"
+  where
+    preprocs = projectPreproc proj
+
 binderToC :: ToCMode -> Binder -> Either ToCError String
 binderToC toCMode binder =
   let xobj = binderXObj binder

src/InitialTypes.hs

@@ -74,6 +74,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
     visit env xobj = case xobjObj xobj of
       (Num t _) -> pure (Right (xobj {xobjTy = Just t}))
       (Bol _) -> pure (Right (xobj {xobjTy = Just BoolTy}))
+      (C _) -> pure (Right xobj {xobjTy = Just CTy})
       (Str _) -> do
         lt <- genVarTy
         pure (Right (xobj {xobjTy = Just (RefTy StringTy lt)}))

src/Obj.hs

@@ -170,6 +170,7 @@ data Obj
   | Ref
   | Deref
   | Interface Ty [SymPath]
+  | C String -- C literal
   deriving (Show, Eq, Generic)
 
 instance Hashable Obj
@@ -411,6 +412,7 @@ pretty = visit 0
     visit :: Int -> XObj -> String
     visit indent xobj =
       case xobjObj xobj of
+        C c -> show c
         Lst lst -> "(" ++ joinWithSpace (map (visit indent) lst) ++ ")"
         Arr arr -> "[" ++ joinWithSpace (map (visit indent) arr) ++ "]"
         StaticArr arr -> "$[" ++ joinWithSpace (map (visit indent) arr) ++ "]"
@@ -488,6 +490,7 @@ prettyUpTo lim xobj =
         Num DoubleTy _ -> ""
         Num _ _ -> error "Invalid number type."
         Str _ -> ""
+        C _ -> ""
         Pattern _ -> ""
         Chr _ -> ""
         Sym _ _ -> ""
@@ -778,6 +781,7 @@ incrementEnvNestLevel env =
 
 -- | Converts an S-expression to one of the Carp types.
 xobjToTy :: XObj -> Maybe Ty
+xobjToTy (XObj (Sym (SymPath _ "C") _) _ _) = Just CTy
 xobjToTy (XObj (Sym (SymPath _ "Unit") _) _ _) = Just UnitTy
 xobjToTy (XObj (Sym (SymPath _ "Int") _) _ _) = Just IntTy
 xobjToTy (XObj (Sym (SymPath _ "Float") _) _ _) = Just FloatTy

src/Project.hs

@@ -18,6 +18,7 @@ instance Show Target where
 data Project = Project
   { projectTitle :: String,
     projectIncludes :: [Includer],
+    projectPreproc  :: [String],
     projectCFlags :: [String],
     projectLibFlags :: [String],
     projectPkgConfigFlags :: [String],
@@ -59,6 +60,7 @@ instance Show Project where
         "Compiler: " ++ projectCompiler,
         "Target: " ++ show projectTarget,
         "Includes:\n    " ++ joinIndented (map show projectIncludes),
+        "Preprocessor directives:\n    " ++ joinIndented (map show projectPreproc),
         "Cflags:\n    " ++ joinIndented projectCFlags,
         "Library flags:\n    " ++ joinIndented projectLibFlags,
         "Flags for pkg-config:\n    " ++ joinIndented projectPkgConfigFlags,

src/StartingEnv.hs

@@ -365,6 +365,25 @@ dynamicStringModule =
       let f = addTernaryCommand . spath
        in [f "slice" commandSubstring "creates a substring from a beginning index to an end index." "(String.slice \"hello\" 1 3) ; => \"ell\""]
 
+unsafeModule :: Env
+unsafeModule =
+  Env {
+    envBindings = bindings,
+    envParent = Nothing,
+    envModuleName = Just "Unsafe",
+    envUseModules = Set.empty,
+    envMode = ExternalEnv,
+    envFunctionNestingLevel = 0
+  }
+  where
+    spath = SymPath ["Unsafe"]
+    bindings = Map.fromList unaries
+    unaries =
+      let f = addUnaryCommand . spath
+       in [ f "emit-c" commandEmitC "emits literal C inline" "(Unsafe.emit-c \"#if 0\")",
+            f "preproc" commandPreproc "adds preprocessing C code to emitted output" "(Unsafe.preproc (Unsafe.emit-c \"#define FOO 0\"))"
+          ]
+
 -- | A submodule of the Dynamic module. Contains functions for working with symbols in the repl or during compilation.
 dynamicSymModule :: Env
 dynamicSymModule =
@@ -457,6 +476,7 @@ startingGlobalEnv noArray =
           ++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule) Nothing Nothing))]
           ++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule) Nothing Nothing))]
           ++ [("Function", Binder emptyMeta (XObj (Mod functionModule) Nothing Nothing))]
+          ++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule) Nothing Nothing))]
 
 -- | The type environment (containing deftypes and interfaces) before any code is run.
 startingTypeEnv :: Env

src/Types.hs

@@ -65,6 +65,7 @@ data Ty
   | MacroTy
   | DynamicTy -- the type of dynamic functions (used in REPL and macros)
   | InterfaceTy
+  | CTy -- C literals
   | Universe -- the type of types of types (the type of TypeTy)
   deriving (Eq, Ord, Generic)
 
@@ -192,6 +193,7 @@ instance Show Ty where
   show MacroTy = "Macro"
   show DynamicTy = "Dynamic"
   show Universe = "Universe"
+  show CTy = "C"
 
 showMaybeTy :: Maybe Ty -> String
 showMaybeTy (Just t) = show t

src/TypesToC.hs

@@ -54,4 +54,5 @@ tyToCManglePtr _ ty = f ty
     f Universe = err "universe"
     f (PointerTy _) = err "pointers"
     f (RefTy _ _) = err "references"
+    f CTy = "c_code" -- Literal C; we shouldn't emit anything.
     err s = error ("Can't emit the type of " ++ s ++ ".")