feat: add c-name meta field (#1398)

* feat: add box templates and box type

This commit adds an implementation of Boxes, memory manged heap
allocated values.

Boxes are implemented as C pointers, with no additional structure but
are treated as structs in Carp. To facilitate this, we need to add them
as a clause to our special type emissions (TypesToC) as they'd otherwise
be emitted like other struct types.

Co-authored-by: Veit Heller <[email protected]>

* fix: slight memory management fix for Box

Make sure we free the box!

* test: add tests for box (including memory checks)

* Revert "fix: Ignore clang nitpick"

This reverts commit 70ec6d4.

* fix: update example/functor.carp

Now that a builtin type named Box exists, the definitions in this file
cause a conflict. I've renamed the "Box" type in the functor example to
remove the conflict.

* feat: add Box.peek

Box.peek allows users to transform a reference to a box into a a
reference to the box's contained value. The returned reference will have
the same lifetime as the box. This function allows callers to manipulate
the value in a box without re-allocation, for example:

```clojure
(deftype Num [val Int])

(let-do [box (Box.init (Num.init 0))]
  (Num.set-val! (Box.peek &box) 1)
  @(Num.val (Box.peek &box)))
```

This commit also includes tests for Box.peek.

Co-authored-by: TimDeve <[email protected]>

* feat: add c-name meta key for code emission overrides

This commit adds a new special compiler meta key, c-name, that enables
users to explicitly c the C identifier Carp should emit for a given
symbol. For now, it is only explicitly supported for Def and Defn forms.

For example:

```clojure
(defn foo-bar [] 2)
(c-name foo-bar "foo_bar")
```

Will cause foo-bar in emitted C code to be emitted as `foo_bar` instead
of `foo_MINUS_bar`.

I've also refactored some of the meta code to be a bit more principled
about keys that are understood by the compiler.

* docs: update CInterop docs

Adds a section on using the c-name meta field to override identifiers
exclusively defined in Carp. Also performs some minor editorial.

Co-authored-by: Veit Heller <[email protected]>
Co-authored-by: Erik Svedäng <[email protected]>
Co-authored-by: TimDeve <[email protected]>

core/Macros.carp

@@ -104,6 +104,16 @@
 (defmacro private [name]
  (eval (list 'meta-set! name "private" true)))
 
+(doc c-name
+ "Override the identifiers Carp generates for a given symbol in C output."
+ ""
+ "```"
+ "(defn foo-bar [] 1)"
+ "(c-name foo-bar \"foo_bar\")"
+ "```")
+(defmacro c-name [sym cname]
+ (eval (list 'meta-set! sym "c-name" cname)))
+
 (hidden and-)
 (defndynamic and- [xs]
 ; (defndynamic and- [xs] ; shorter but currently not entirely stable

docs/CInterop.md

@@ -18,7 +18,6 @@ This is an extension of what is covered in the [Language Guide](./LanguageGuide.
 - [Callbacks](#callbacks)
 - [Headerparse](#headerparse)
 
-
 ## How Carp generates identifiers
 
 When creating a function or def it might be useful to know what identifier gets
@@ -56,8 +55,9 @@ 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:
-Carp will replace illegal characters in C with a string representation of them
+Looking at the examples should help illustrate how Carp transforms identifiers
+before producing C code, 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.
 When the arguments to a function are generic it will suffix the types to the
@@ -66,16 +66,54 @@ a function is potentially generic but you don't want it to be you can add a
 non-generic signature to it to make Carp generate your function like in our
 `true?` example.
 
-When creating bindings to a library it would be hard to coerce this logic into
-creating the exact identifiers the library uses, this is why `register` and
-`register-type` accepts an optional argument to specify what identifiers to use:
+This process is called *mangling* and is necessary to ensure that identifiers
+that are valid in Carp but invalid in C don't produce invalid C code.
+
+### Overriding Carp's default C identifier names
+
+When creating bindings to an existing C library in Carp, it's inconvenient to
+have to replicate C identifiers exactly as they're declared in C. For example,
+due to mangling, you couldn't wrap your Carp bindings in a module, since the
+resulting identifiers would be prefixed, and probably incorrect. It would be
+inconvenient and tedious to have to replicate existing C identifiers exactly
+whenever you had to create bindings to an existing library , so, to help with
+this, `register` and `register-type` accepts an optional argument to specify
+what identifiers to use:
 
 ```clojure
 (defmodule CURL
  (register-type HttpPost "curl_httppost")
  (register form-free (Fn [(Ref HttpPost)] ()) "curl_formfree"))
 ```
 
+This enables you to define whatever structure you want in Carp code (for
+example, here we wrap cURL bindings in a CURL module) while ensuring the
+emitted identifiers are correct and map to the identifiers used by the existing
+C library you're calling. For example, the `form-free` identifier in Carp would
+normally be subject to mangling and emitted as `form_MINUS_free`, but the
+override argument ensures this identifier is emitted as `curl_formfree`
+instead.
+
+Likewise, you can override the C identifiers Carp generates for code
+exclusively defined in Carp. For instance, you may want to migrate
+safety-critical code in an existing C program into Carp, then call the
+resulting safe C code in your original C program. This can become tedious if
+your Carp code utilizes a lot of nested modules, custom types, or special
+characters in identifiers.
+
+You can use the `c-name` meta field to explicitly set the C identifier Carp
+generates for a given definition. This can help make your compiled C more
+readable and easier to call from other languages. For example, given the
+definition and c-name call:
+
+```clojure
+(defn foo-bar [] 2)
+(c-name foo-bar "foo_bar")
+```
+
+Carp will generate a corresponding identifier `foo_bar` in its C output,
+instead of the default `foo_MINUS_bar`.
+
 ## Managed types
 
 In Carp types like `String` and `Array` are _managed_ types in that they are

src/Emit.hs

@@ -306,8 +306,10 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
  do
  appendToSrc (addIndent indent ++ "{\n")
  let innerIndent = indent + indentAmount
+ cname = (Meta.getString (Meta.getCompilerKey Meta.CNAME) meta)
+ fullname = if (null cname) then pathToC path else cname
  ret <- visit innerIndent expr
- when (ret /= "") $ appendToSrc (addIndent innerIndent ++ pathToC path ++ " = " ++ ret ++ ";\n")
+ when (ret /= "") $ appendToSrc (addIndent innerIndent ++ fullname ++ " = " ++ ret ++ ";\n")
  delete innerIndent info
  appendToSrc (addIndent indent ++ "}\n")
  pure ""
@@ -782,16 +784,18 @@ delete indent i = mapM_ deleterToC (infoDelete i)
 
 defnToDeclaration :: MetaData -> SymPath -> [XObj] -> Ty -> String
 defnToDeclaration meta path@(SymPath _ name) argList retTy =
- let (XObj (Lst annotations) _ _) = fromMaybe emptyList (Meta.get "annotations" meta)
+ let override = Meta.getString (Meta.getCompilerKey Meta.CNAME) meta
+ (XObj (Lst annotations) _ _) = fromMaybe emptyList (Meta.get "annotations" meta)
  annotationsStr = joinWith " " (map strToC annotations)
  sep = if not (null annotationsStr) then " " else ""
+ fullname = if (null override) then (pathToC path) else override
  in annotationsStr ++ sep
  ++ if name == "main"
  then "int main(int argc, char** argv)"
  else
  let retTyAsC = tyToCLambdaFix retTy
  paramsAsC = paramListToC argList
- in (retTyAsC ++ " " ++ pathToC path ++ "(" ++ paramsAsC ++ ")")
+ in (retTyAsC ++ " " ++ fullname ++ "(" ++ paramsAsC ++ ")")
  where
  strToC (XObj (Str s) _ _) = s
  strToC xobj = pretty xobj
@@ -895,9 +899,11 @@ toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ ty)) =
  in defnToDeclaration meta path argList retTy ++ ";\n"
  [XObj Def _ _, XObj (Sym path _) _ _, _] ->
  let Just t = ty
+ cname = (Meta.getString (Meta.getCompilerKey Meta.CNAME) meta)
+ fullname = if (null cname) then pathToC path else cname
  in if (isUnit t)
  then ""
- else tyToCLambdaFix t ++ " " ++ pathToC path ++ ";\n"
+ else tyToCLambdaFix t ++ " " ++ fullname ++ ";\n"
  XObj (Deftype t) _ _ : XObj (Sym path _) _ _ : rest ->
  defStructToDeclaration t path rest
  XObj (DefSumtype t) _ _ : XObj (Sym _ _) _ _ : rest ->

src/Meta.hs

@@ -8,6 +8,10 @@ module Meta
  Meta.member,
  binderMember,
  hide,
+ getString,
+ getCompilerKey,
+ validateAndSet,
+ CompilerKey(..),
  )
 where
 
@@ -16,6 +20,41 @@ import qualified Map
 import Obj
 import SymPath
 import Types
+import Data.Maybe(fromMaybe)
+import Data.Either(fromRight)
+
+--------------------------------------------------------------------------------
+-- builtin special meta key values
+-- These keys, when set, alter the compiler's behavior.
+
+data CompilerKey = CNAME
+
+-- Given a compiler key, returns the key name as a string along with a default value.
+toKeyValue :: CompilerKey -> (String, XObj)
+toKeyValue CNAME = ("c-name", (XObj (Str "") Nothing Nothing))
+
+-- | Get the key associated with a compiler Meta key as a string.
+getCompilerKey :: CompilerKey -> String
+getCompilerKey = fst . toKeyValue
+
+-- | Special meta KV pairs expect values of a certain XObj form.
+--
+-- Returns True for valid values for the given compiler key, False otherwise.
+validateCompilerKeyValue :: CompilerKey -> Obj -> Bool
+validateCompilerKeyValue CNAME (Str _) = True
+validateCompilerKeyValue CNAME _ = False
+
+-- | Validate and set a compiler key for a given MetaData object.
+--
+-- If the key or value is invalid, returns Left containing the original metadata.
+-- If the key and value is valid, return Right containing the updated metadata.
+validateAndSet :: MetaData -> CompilerKey -> XObj -> Either MetaData MetaData
+validateAndSet meta key val
+ | validateCompilerKeyValue key (xobjObj val) =
+ Right (set (getCompilerKey key) val meta)
+ | otherwise = Left meta
+
+--------------------------------------------------------------------------------
 
 -- | A temporary binder for meta calls on symbols that haven't been declared yet.
 -- Used in situations such as:
@@ -61,3 +100,7 @@ binderMember key binder = Meta.member key $ fromBinder binder
 hide :: Binder -> Binder
 hide binder =
  updateBinderMeta binder "hidden" trueXObj
+
+-- | Get the value of a string valued meta key.
+getString :: String -> MetaData -> String
+getString key meta = fromMaybe "" $ fmap (fromRight "" . unwrapStringXObj) (Meta.get key meta)

src/Qualify.hs

@@ -27,6 +27,7 @@ import Obj
 import qualified Set
 import SymPath
 import Util
+import qualified Meta
 
 --------------------------------------------------------------------------------
 -- Errors
@@ -353,7 +354,7 @@ qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path@(SymPath _ name) _) i
  )
  )
  >>= \(origin, (e, binder)) ->
- resolve (E.prj origin) (E.prj e) (binderXObj binder)
+ resolve (E.prj origin) (E.prj e) binder
  >>= pure . Qualified
  )
  <> ((resolveMulti path (E.lookupInUsed localEnv globalEnv path)) >>= pure . Qualified)
@@ -362,34 +363,38 @@ qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path@(SymPath _ name) _) i
  <> pure (Qualified xobj)
  )
  where
- resolve :: Env -> Env -> XObj -> Either QualificationError XObj
- resolve _ _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _) =
+ resolve :: Env -> Env -> Binder -> Either QualificationError XObj
+ resolve _ _ (Binder _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _)) =
  -- Before we return an interface, double check that it isn't shadowed by a local let-binding.
  case (E.searchValue localEnv path) of
  Right (e, Binder _ _) ->
  case envMode e of
  InternalEnv -> pure (XObj (Sym (getPath xobj) (LookupLocal (captureOrNot e localEnv))) i t)
  _ -> pure (XObj (InterfaceSym name) i t)
  _ -> pure (XObj (InterfaceSym name) i t)
- resolve _ _ x@(XObj (Lst (XObj (External (Just overrideName)) _ _ : _)) _ _) =
+ resolve _ _ (Binder _ x@(XObj (Lst (XObj (External (Just overrideName)) _ _ : _)) _ _)) =
  pure (XObj (Sym (getPath x) (LookupGlobalOverride overrideName)) i t)
- resolve _ _ (XObj (Mod modenv _) _ _) =
+ resolve _ _ (Binder _ (XObj (Mod modenv _) _ _)) =
  nakedInit modenv
- resolve origin found xobj' =
- if (isTypeDef xobj')
- then
- ( (replaceLeft (FailedToFindSymbol xobj') (fmap (globalEnv,) (E.searchValue globalEnv path)))
- >>= \(origin', (e', binder)) -> resolve (E.prj origin') (E.prj e') (binderXObj binder)
- )
- else case envMode (E.prj found) of
- RecursionEnv -> pure (XObj (Sym (getPath xobj') LookupRecursive) i t)
- InternalEnv -> pure (XObj (Sym (getPath xobj') (LookupLocal (captureOrNot found origin))) i t)
- ExternalEnv -> pure (XObj (Sym (getPath xobj') (LookupGlobal (if isExternalFunction xobj' then ExternalCode else CarpLand) (definitionMode xobj'))) i t)
+ resolve origin found (Binder meta xobj') =
+ let cname = (Meta.getString (Meta.getCompilerKey Meta.CNAME) meta)
+ modality = if (null cname)
+ then (LookupGlobal (if isExternalFunction xobj' then ExternalCode else CarpLand) (definitionMode xobj'))
+ else (LookupGlobalOverride cname)
+ in if (isTypeDef xobj')
+ then
+ ( (replaceLeft (FailedToFindSymbol xobj') (fmap (globalEnv,) (E.searchValue globalEnv path)))
+ >>= \(origin', (e', binder)) -> resolve (E.prj origin') (E.prj e') binder
+ )
+ else case envMode (E.prj found) of
+ RecursionEnv -> pure (XObj (Sym (getPath xobj') LookupRecursive) i t)
+ InternalEnv -> pure (XObj (Sym (getPath xobj') (LookupLocal (captureOrNot found origin))) i t)
+ ExternalEnv -> pure (XObj (Sym (getPath xobj') modality) i t)
  resolveMulti :: (Show e, E.Environment e) => SymPath -> [(e, Binder)] -> Either QualificationError XObj
  resolveMulti _ [] =
  Left (FailedToFindSymbol xobj)
  resolveMulti _ [(e, b)] =
- resolve (E.prj e) (E.prj e) (binderXObj b)
+ resolve (E.prj e) (E.prj e) b
  resolveMulti spath xs =
  let localOnly = remove (E.envIsExternal . fst) xs
  paths = map (getModuleSym . (second binderXObj)) xs