diff --git a/docs/CInterop.md b/docs/CInterop.md index f0ac688b..94251602 100644 --- a/docs/CInterop.md +++ b/docs/CInterop.md @@ -14,6 +14,7 @@ This is an extension of what is covered in the [Language Guide](./LanguageGuide. - [`Generics`](#generics) - [`emit-c`](#unsafe-emit-c) - [`preproc`](#unsafe-preproc) + - [Registering Types](#register-types) - [Callbacks](#callbacks) @@ -409,6 +410,113 @@ 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. +### Registering Types + +Carp supports a few different ways of registering types defined in C. You can +register types using the `register-type` function. Calling `register-type` with +only a symbol argument registers the C type with a name corresponding to the +symbol. For example, the following code registers the C type `A` as the type +`A` in Carp. + +```c +typedef int A; +``` + +```clojure +(register-type A) +``` + +After this call to `register-type`, you can use the type `A` anywhere type +names are valid in Carp code. For example, you can use it in function +signatures: + +```clojure +(sig a-prn (Fn [A] String)) +``` + +The prior type registration *only* registers the type name in Carp. In other +words, the type is entirely "opaque" from the perspective of your Carp program. +Carp knows the type exists, but it knows nothing about its implementation or +how to construct values of the type--all of that is left up to your C code. + +If you want to construct values of this type from Carp code, you have two +options: + +1. You can define your own initializers for the type in C and register them in Carp. +2. You can use `register-type` to generate initializers for the type in Carp. + +If you define an initializer for the type in C, you can access it from Carp by +using `register`: + +```c +typedef int A; + +A initializer() { + return 0; +} +``` + +```clojure +(register-type A) +(register initializer (Fn [] A)) +;; returns a value of type A +(initializer) +``` + +Alternatively, you can add a non-empty array of type members in your +`register-type` call to have Carp generate initializers, getters and setters, +and printing functions for the external type. The initializer Carp generates +will only initialize the fields you specify. If you omit or misname a field, +the generated initializer might cause errors. + +```clojure +(register-type B []) +:i B +=> B : Type + init : (Fn [] B) + prn : (Fn [(Ref B q)] String) + str : (Fn [(Ref B q)] String) +} +(register-type C [x Int]) +:i C +=> C : Type + C : Module { + init : (Fn [Int] C) + prn : (Fn [(Ref C q) String]) + str : (Fn [(Ref C q) String]) + set-x : (Fn [C, Int] C) + set-x! : (Fn [(Ref C q), Int] ()) + update-x : (Fn [C, (Ref (Fn [Int] Int) q)] C) + x : (Fn [(Ref C q)] (Ref Int q)) +} +``` + +The `prn` and `str` functions for the type will also automatically implement +their corresponding interfaces. + +Be mindful that Carp *does not manage the memory associated with external types +by default!* Unlike types defined in Carp, Carp will not generate `copy` and +`delete` functions for registered types. If you use generated initializers for +a registered type for convenience, remember that you still need to manage the +memory associated with values of the type manually. If you want Carp to manage +the memory for a registered type, you can provide implementations of the `copy` +and `delete` interfaces. + +If needed, you can override the name Carp emits for a registered type by +providing an additional string argument. This comes in handy when the type's +name in C does not follow lisp or Carp naming conventions. For example, the +type in C might begin with a lowercase letter, while Carp requires all types to +begin with uppercase letters: + +```clojure +;; Emitted in C code as "A" +(register-type A) +;; Emitted in C code a "a_type" +(register-type A "a_type") +;; Emitted in C code as "b_type" +(register-type B "b_type" [x Int]) +``` + ## Callbacks Some C APIs rely on callbacks, let's define a C function that accepts a diff --git a/src/Deftype.hs b/src/Deftype.hs index c4dbc87d..1ab08b36 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -59,11 +59,17 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i -- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'. -- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc. insidePath = pathStrings ++ [typeName] + initmembers = case rest of + -- ANSI C does not allow empty structs. We add a dummy member here to account for this. + -- Note that we *don't* add this member for external types--we leave those definitions up to the user. + -- The corresponding field is emitted for the struct definition in Emit.hs + [(XObj (Arr []) ii t)] -> [(XObj (Arr [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)]) ii t)] + _ -> rest in do validateMemberCases typeEnv env typeVariables rest let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest - okInit <- binderForInit insidePath structTy rest + okInit <- binderForInit insidePath structTy initmembers (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str" (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn" (okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest @@ -336,15 +342,21 @@ templateUpdater member _ = -- | Helper function to create the binder for the 'init' template. binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder) binderForInit insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = - if isTypeGeneric structTy - then Right (genericInit StackAlloc insidePath structTy membersXObjs) - else - Right $ - instanceBinder - (SymPath insidePath "init") - (FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy) - (concreteInit StackAlloc structTy membersXObjs) - ("creates a `" ++ show structTy ++ "`.") + -- Remove the __dummy field from the members array to ensure we can call the initializer with no arguments. + -- See the implementation of moduleForDeftype for more details. + let nodummy = case membersXObjs of + [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)] -> [] + _ -> membersXObjs + in if isTypeGeneric structTy + then Right (genericInit StackAlloc insidePath structTy membersXObjs) + else + Right $ + instanceBinder + (SymPath insidePath "init") + -- don't include the dummy field in arg lists + (FuncTy (initArgListTypes nodummy) structTy StaticLifetimeTy) + (concreteInit StackAlloc structTy membersXObjs) + ("creates a `" ++ show structTy ++ "`.") binderForInit _ _ _ = error "binderforinit" -- | Generate a list of types from a deftype declaration. @@ -361,7 +373,7 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) mem let mappings = unifySignatures originalStructTy concreteStructTy correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs memberPairs = memberXObjsToPairs correctedMembers - in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (unitless memberPairs)) ++ ")") + in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (nodummy (unitless memberPairs))) ++ ")") ) ( \(FuncTy _ concreteStructTy _) -> let mappings = unifySignatures originalStructTy concreteStructTy @@ -371,6 +383,9 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) mem (\FuncTy {} -> []) where unitless = remove (isUnit . snd) + nodummy = remove (isDummy . fst) + isDummy "__dummy" = True + isDummy _ = False concreteInit _ _ _ = error "concreteinit" -- | The template for the 'init' and 'new' functions for a generic deftype. @@ -379,7 +394,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT defineTypeParameterizedTemplate templateCreator path t docs where path = SymPath pathStrings "init" - t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy + t = FuncTy (map snd (nodummy (memberXObjsToPairs membersXObjs))) originalStructTy StaticLifetimeTy docs = "creates a `" ++ show originalStructTy ++ "`." templateCreator = TemplateCreator $ \typeEnv env -> @@ -389,7 +404,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT let mappings = unifySignatures originalStructTy concreteStructTy correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs memberPairs = memberXObjsToPairs correctedMembers - in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (remove (isUnit . snd) memberPairs)) ++ ")") + in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (nodummy (remove (isUnit . snd) memberPairs))) ++ ")") ) ( \(FuncTy _ concreteStructTy _) -> let mappings = unifySignatures originalStructTy concreteStructTy @@ -401,6 +416,9 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT Left _ -> [] Right ok -> ok ) + nodummy = remove (isDummy . fst) + isDummy "__dummy" = True + isDummy _ = False genericInit _ _ _ _ = error "genericinit" tokensForInit :: AllocationMode -> String -> [XObj] -> [Token] @@ -421,7 +439,7 @@ tokensForInit allocationMode typeName membersXObjs = "}" ] where - assignments [] = " instance.__dummy = 0;" + assignments [] = "" assignments _ = go unitless where go [] = "" @@ -537,9 +555,13 @@ calculateStructStrSize typeEnv env members s@(StructTy (ConcreteNameTy _) _) = calculateStructStrSize _ _ _ _ = error "calculatestructstrsize" -- | Generate C code for assigning to a member variable. --- | Needs to know if the instance is a pointer or stack variable. +-- Needs to know if the instance is a pointer or stack variable. +-- Also handles the special dummy member we add for empty structs to be ANSI C compatible. memberAssignment :: AllocationMode -> String -> String -memberAssignment allocationMode memberName = " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";" +memberAssignment allocationMode memberName = + case memberName of + "__dummy" -> " instance" ++ sep ++ memberName ++ " = " ++ "0" ++ ";" + _ -> " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";" where sep = case allocationMode of StackAlloc -> "." diff --git a/src/Primitives.hs b/src/Primitives.hs index 4e914984..24345f9c 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -263,7 +263,10 @@ primitiveRegisterTypeWithFields ctx x t override members = Right ctx' = update ctx -- TODO: Another case where define does not get formally qualified deps! contextWithDefs <- liftIO $ foldM (define True) ctx' (map Qualified deps) - pure (contextWithDefs, dynamicNil) + autoDerive contextWithDefs (StructTy (ConcreteNameTy (unqualify path')) []) + [ lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "str")), + lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "prn")) + ] path = SymPath [] t preExistingModule = case lookupBinderInGlobalEnv ctx path of Right (Binder _ (XObj (Mod found et) _ _)) -> Just (found, et) @@ -612,6 +615,10 @@ deftype ctx x@(XObj (Sym (SymPath [] name) _) _ _) constructor = case e of Left err -> pure (evalError ctx (show err) (xobjInfo x)) Right t -> autoDerive ctxWithType t + [ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")), + lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")), + lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy")) + ] deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) constructor = do (ctxWithType, e) <- @@ -623,6 +630,10 @@ deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) c case e of Left err -> pure (evalError ctx (show err) (xobjInfo x)) Right t -> autoDerive ctxWithType t + [ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")), + lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")), + lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy")) + ] deftype ctx name _ = pure $ toEvalError ctx name (InvalidTypeName name) checkVariables :: [XObj] -> Maybe [Ty] @@ -658,21 +669,17 @@ unwrapTypeErr ctx (Left err) = Left (typeErrorToString ctx err) unwrapTypeErr _ (Right x) = Right x -- | Automatically derive implementations of interfaces. -autoDerive :: Context -> Ty -> IO (Context, Either EvalError XObj) -autoDerive c ty = +autoDerive :: Context -> Ty -> [Either ContextError Binder] -> IO (Context, Either EvalError XObj) +autoDerive c ty interfaces = let (SymPath mods tyname) = (getStructPath ty) implBinder :: String -> Ty -> Binder implBinder name t = Binder emptyMeta (XObj (Sym (SymPath (mods ++ [tyname]) name) Symbol) (Just dummyInfo) (Just t)) getSig :: String -> Ty getSig "delete" = FuncTy [ty] UnitTy StaticLifetimeTy getSig "str" = FuncTy [RefTy ty (VarTy "q")] StringTy StaticLifetimeTy + getSig "prn" = FuncTy [RefTy ty (VarTy "q")] StringTy StaticLifetimeTy getSig "copy" = FuncTy [RefTy ty (VarTy "q")] ty StaticLifetimeTy getSig _ = VarTy "z" - interfaces = - [ lookupBinderInTypeEnv c (markQualified (SymPath [] "delete")), - lookupBinderInTypeEnv c (markQualified (SymPath [] "str")), - lookupBinderInTypeEnv c (markQualified (SymPath [] "copy")) - ] registration interface = let name = getSimpleName (binderXObj interface) sig = getSig name