feat: add box type

CarpHask.cabal

@@ -18,6 +18,7 @@ library
   hs-source-dirs:      src
   exposed-modules:     ArrayTemplates,
                        AssignTypes,
+                       BoxTemplates,
                        ColorText,
                        Commands,
                        Concretize,

app/Main.hs

@@ -36,7 +36,6 @@ defaultProject =
             "-Wall",
             "-Werror",
             "-Wno-unused-variable",
-            "-Wno-unused-but-set-variable",
             "-Wno-self-assign"
           ],
       projectLibFlags = case platform of

core/Box.carp

@@ -0,0 +1,5 @@
+(defmodule Box
+  (defn = [box-a box-b]
+    (= (Box.unbox @box-a) (Box.unbox @box-b)))
+  (implements = =)
+)

core/Core.carp

@@ -18,6 +18,7 @@
 (load-once "Interfaces.carp")
 (load-once "Blitable.carp")
 (load-once "Bool.carp")
+(load-once "Box.carp")
 (load-once "Macros.carp")
 (load-once "BoolExtras.carp")
 (load-once "List.carp")

examples/functor.carp

@@ -10,14 +10,14 @@
   (implements fmap ArrayExtension.fmap)
   )
 
-(deftype (Box a) [x a])
+(deftype (MyBox a) [x a])
 
-(defmodule Box
-  (defn fmap [f box] (let [new-x (~f @(Box.x &box))]
-                       (Box.set-x box new-x)))
-  (implements fmap Box.fmap))
+(defmodule MyBox
+  (defn fmap [f box] (let [new-x (~f @(MyBox.x &box))]
+                       (MyBox.set-x box new-x)))
+  (implements fmap MyBox.fmap))
 
-(use Box)
+(use MyBox)
 (use ArrayExtension)
 
 ;; TODO: This function currently concretizes to the type of the first (f *) it
@@ -29,8 +29,8 @@
 
 (defn main []
   (do
-    (println &(str @(Box.x &(fmap &Int.inc (Box.init 100)))))
-    (println &(str @(Box.x &(Box.fmap &inc (Box.init 100)))))
+    (println &(str @(MyBox.x &(fmap &Int.inc (MyBox.init 100)))))
+    (println &(str @(MyBox.x &(MyBox.fmap &inc (MyBox.init 100)))))
     (println &(str &(ArrayExtension.fmap &inc [10 20 30 40 50])))
     (println &(str &(fmap &Int.inc [10 20 30 40 50])))
     (println &(Array.str &(fmap &Int.inc [10 20 30 40 50])))

src/BoxTemplates.hs

@@ -0,0 +1,237 @@
+-- | Module BoxTemplates defines Carp's Box type, a container for managed,
+-- heap allocated objects.
+module BoxTemplates
+  ( delete,
+    str,
+    prn,
+    BoxTemplates.init,
+    copy,
+    unbox,
+    peek,
+  )
+where
+
+import Concretize
+import Obj
+import Polymorphism
+import Template
+import ToTemplate
+import Types
+
+boxTy :: Ty
+boxTy = StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]
+
+-- | Defines a template for initializing Boxes.
+init :: (String, Binder)
+init = let path = SymPath ["Box"] "init"
+           t = FuncTy [(VarTy "t")] boxTy StaticLifetimeTy
+           docs = "Initializes a box pointing to value t."
+           decl = templateLiteral "$t* $NAME ($t t)"
+           body = const (multilineTemplate
+                                  [ "$DECL {",
+                                    "  $t* instance;",
+                                    "  instance = CARP_MALLOC(sizeof($t));",
+                                    "  *instance = t;",
+                                    "  return instance;",
+                                    "}"
+                                  ])
+           deps = const []
+           template = TemplateCreator $ \_ _ -> Template t decl body deps
+        in defineTypeParameterizedTemplate template path t docs
+
+-- | Defines a template for converting a boxed value to a local value.
+unbox :: (String, Binder)
+unbox = let path = SymPath ["Box"] "unbox"
+            t = FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")])] (VarTy "t") StaticLifetimeTy
+            docs = "Converts a boxed value to a reference to the value and delete the box."
+            decl = templateLiteral "$t $NAME($t* box)"
+            body = const (multilineTemplate
+                           [ "$DECL {",
+                             "  $t local;",
+                             "  local = *box;",
+                             "  CARP_FREE(box);",
+                             "  return local;",
+                             "}"
+                           ])
+            deps = const []
+            template = TemplateCreator $ \_ _ -> Template t decl body deps
+         in defineTypeParameterizedTemplate template path t docs
+
+-- | Defines a template for getting a reference to the value stored in a box without performing an additional allocation.
+peek :: (String, Binder)
+peek = let path = SymPath ["Box"] "peek"
+           t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (RefTy (VarTy "t") (VarTy "q")) StaticLifetimeTy
+           docs = "Returns a reference to the value stored in a box without performing an additional allocation."
+           decl = templateLiteral "$t* $NAME($t** box_ref)"
+           body = const (multilineTemplate
+                          [ "$DECL {",
+                            "  return *box_ref;",
+                            "}"
+                          ])
+           deps = const []
+           template = TemplateCreator $ \_ _ -> Template t decl body deps
+        in defineTypeParameterizedTemplate template path t docs
+
+-- | Defines a template for copying a box. The copy will also be heap allocated.
+copy :: (String, Binder)
+copy =
+  let path = SymPath ["Box"] "copy"
+      t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) StaticLifetimeTy
+      docs = "Copies a box."
+      decl = (templateLiteral "$t* $NAME ($t** box)")
+      template = TemplateCreator $
+        \tenv env ->
+          Template
+            t
+            decl
+            ( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) ->
+                innerCopy tenv env inner
+            )
+            ( \(FuncTy [RefTy boxType@(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) ->
+                depsForCopyFunc tenv env inner
+                  ++ depsForDeleteFunc tenv env boxType
+            )
+   in defineTypeParameterizedTemplate template path t docs
+  where
+    innerCopy typeEnv valEnv innerTy =
+      case findFunctionForMemberIncludePrimitives typeEnv valEnv "copy" (typesCopyFunctionType innerTy) ("Inside box.", innerTy) of
+        FunctionFound functionFullName ->
+          multilineTemplate
+            [ "$DECL {",
+              "  $t* copy;",
+              "  copy = CARP_MALLOC(sizeof($t));",
+              "  *copy = " ++ functionFullName ++ "(*box);",
+              "  return copy;",
+              "}"
+            ]
+        _ ->
+          multilineTemplate
+            [ "$DECL {",
+              "  $t* copy;",
+              "  copy = CARP_MALLOC(sizeof($t));",
+              "  *copy = *box;",
+              "  return copy;",
+              "}"
+            ]
+
+-- | Defines a template for deleting a box.
+delete :: (String, Binder)
+delete =
+  let path = SymPath ["Box"] "delete"
+      t = FuncTy [boxTy] UnitTy StaticLifetimeTy
+      docs = "Deletes a box, freeing its associated memory."
+      decl = (templateLiteral "void $NAME ($t* box)")
+      templateCreator = TemplateCreator $
+        \tenv env ->
+          Template
+            t
+            decl
+            ( \(FuncTy [bTy] UnitTy _) ->
+                multilineTemplate
+                  [ "$DECL {",
+                    "  " ++ innerDelete tenv env bTy,
+                    "}"
+                  ]
+            )
+            ( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Box")) [insideType]] UnitTy _) ->
+                depsForDeleteFunc tenv env insideType
+            )
+   in defineTypeParameterizedTemplate templateCreator path t docs
+  where
+    innerDelete :: TypeEnv -> Env -> Ty -> String
+    innerDelete tenv env (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) =
+      case findFunctionForMember tenv env "delete" (typesDeleterFunctionType inner) ("Inside box.", inner) of
+        FunctionFound functionFullName ->
+            "  " ++ functionFullName ++ "(*box);\n"
+            ++ "  CARP_FREE(box);"
+        FunctionNotFound msg -> error msg
+        FunctionIgnored ->
+          "  /* Ignore non-managed type inside Box: '" ++ show inner ++ "' */\n"
+            ++ "  CARP_FREE(box);"
+    innerDelete _ _ _ = ""
+
+-- | Defines a template for printing a box as a string.
+prn :: (String, Binder)
+prn =
+  let path = SymPath ["Box"] "prn"
+      t = FuncTy [boxTy] StringTy StaticLifetimeTy
+      docs = "Returns a string representation of a Box."
+      decl = templateLiteral "String $NAME ($t* box)"
+      templateCreator =
+        TemplateCreator $
+          ( \tenv env ->
+              Template
+                t
+                decl
+                ( \(FuncTy [boxT] StringTy _) ->
+                    multilineTemplate
+                      [ "$DECL {",
+                        "  if(!box){",
+                        "    String buffer = CARP_MALLOC(4);",
+                        "    sprintf(buffer, \"Nil\");",
+                        "    return buffer;",
+                        "  }",
+                        innerStr tenv env boxT,
+                        "  return buffer;",
+                        "}"
+                      ]
+                )
+                ( \(FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner])] StringTy _) ->
+                    depsForPrnFunc tenv env inner
+                )
+          )
+   in defineTypeParameterizedTemplate templateCreator path t docs
+
+-- | Defines a template for printing a reference to a box as a string.
+str :: (String, Binder)
+str =
+  let path = SymPath ["Box"] "str"
+      t = FuncTy [(RefTy boxTy (VarTy "q"))] StringTy StaticLifetimeTy
+      docs = "Returns a string representation of a Box."
+      templateCreator =
+        TemplateCreator $
+          ( \tenv env ->
+              Template
+                t
+                (templateLiteral "String $NAME ($t** box)")
+                ( \(FuncTy [RefTy boxT _] StringTy _) ->
+                    multilineTemplate
+                      [ "$DECL {",
+                        "  if(!box){",
+                        "    String buffer = CARP_MALLOC(4);",
+                        "    sprintf(buffer, \"Nil\");",
+                        "    return buffer;",
+                        "  }",
+                        innerStr tenv env boxT,
+                        "  return buffer;",
+                        "}"
+                      ]
+                )
+                ( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] StringTy _) ->
+                    depsForPrnFunc tenv env inner
+                )
+          )
+   in defineTypeParameterizedTemplate templateCreator path t docs
+
+innerStr :: TypeEnv -> Env -> Ty -> String
+innerStr tenv env (StructTy _ [t]) =
+  case findFunctionForMemberIncludePrimitives tenv env "prn" (typesStrFunctionType tenv env (RefTy t StaticLifetimeTy)) ("Inside box.", t) of
+    FunctionFound functionFullName ->
+      unlines
+        [ "  char* temp = " ++ functionFullName ++ "(*box);",
+          "  int size = snprintf(NULL, 0, \"(Box %s)\", temp);",
+          "  String buffer = CARP_MALLOC(size);",
+          "  sprintf(buffer, \"(Box %s)\", temp);",
+          "  if(temp) {",
+          "    CARP_FREE(temp);",
+          "    temp = NULL;",
+          "  }"
+        ]
+    FunctionNotFound _ ->
+      unlines
+        [ "  String buffer = CARP_MALLOC(14);",
+          "  sprintf(buffer, \"(Box unknown)\");"
+        ]
+    FunctionIgnored -> "    /* Ignore type inside Box: '" ++ show t ++ "' ??? */\n"
+innerStr _ _ _ = ""
+

src/StartingEnv.hs

@@ -14,6 +14,7 @@ import qualified StaticArrayTemplates
 import Template
 import ToTemplate
 import Types
+import qualified BoxTemplates
 
 -- | These modules will be loaded in order before any other code is evaluated.
 coreModules :: String -> [String]
@@ -108,6 +109,28 @@ templatePointerCopy =
     )
     (const [])
 
+-- | The Box module contains functions for working with Boxes (pointers to heap allocated values).
+boxModule :: Env
+boxModule =
+  Env
+    { envBindings = bindings,
+      envParent = Nothing,
+      envModuleName = Just "Box",
+      envUseModules = Set.empty,
+      envMode = ExternalEnv,
+      envFunctionNestingLevel = 0
+    }
+  where
+    bindings = Map.fromList
+      [ BoxTemplates.init,
+        BoxTemplates.unbox,
+        BoxTemplates.peek,
+        BoxTemplates.delete,
+        BoxTemplates.copy,
+        BoxTemplates.prn,
+        BoxTemplates.str
+      ]
+
 maxArity :: Int
 maxArity = 9
 
@@ -506,6 +529,7 @@ startingGlobalEnv noArray =
           ++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule E.empty) Nothing Nothing))]
           ++ [("Function", Binder emptyMeta (XObj (Mod functionModule E.empty) Nothing Nothing))]
           ++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule E.empty) Nothing Nothing))]
+          ++ [("Box", Binder emptyMeta (XObj (Mod boxModule E.empty) Nothing Nothing))]
 
 -- | The type environment (containing deftypes and interfaces) before any code is run.
 startingTypeEnv :: Env
@@ -524,22 +548,22 @@ startingTypeEnv =
         [ interfaceBinder
             "delete"
             (FuncTy [VarTy "a"] UnitTy StaticLifetimeTy)
-            ([SymPath ["Array"] "delete", SymPath ["StaticArray"] "delete"] ++ registerFunctionFunctionsWithInterface "delete")
+            ([SymPath ["Array"] "delete", SymPath ["StaticArray"] "delete", SymPath ["Box"] "delete"] ++ registerFunctionFunctionsWithInterface "delete")
             builtInSymbolInfo,
           interfaceBinder
             "copy"
             (FuncTy [RefTy (VarTy "a") (VarTy "q")] (VarTy "a") StaticLifetimeTy)
-            ([SymPath ["Array"] "copy", SymPath ["Pointer"] "copy"] ++ registerFunctionFunctionsWithInterface "copy")
+            ([SymPath ["Array"] "copy", SymPath ["Pointer"] "copy", SymPath ["Box"] "copy"] ++ registerFunctionFunctionsWithInterface "copy")
             builtInSymbolInfo,
           interfaceBinder
             "str"
             (FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
-            (SymPath ["Array"] "str" : SymPath ["StaticArray"] "str" : registerFunctionFunctionsWithInterface "str")
+            (SymPath ["Array"] "str" : SymPath ["StaticArray"] "str" : SymPath ["Box"] "str" : registerFunctionFunctionsWithInterface "str")
             builtInSymbolInfo,
           interfaceBinder
             "prn"
             (FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
-            (SymPath ["StaticArray"] "str" : registerFunctionFunctionsWithInterface "prn") -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is)
+            (SymPath ["StaticArray"] "str" : SymPath ["Box"] "prn" : registerFunctionFunctionsWithInterface "prn") -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is)
             builtInSymbolInfo
         ]
     builtInSymbolInfo = Info (-1) (-1) "Built-in." Set.empty (-1)

src/TypesToC.hs

@@ -26,6 +26,7 @@ tyToCRawFunctionPtrFix FuncTy {} = "void*"
 tyToCRawFunctionPtrFix t = tyToCManglePtr False t
 
 tyToCManglePtr :: Bool -> Ty -> String
+tyToCManglePtr b (StructTy (ConcreteNameTy (SymPath [] "Box")) [t]) = tyToCManglePtr b t ++ (if b then mangle "*" else "*")
 tyToCManglePtr b (PointerTy p) = tyToCManglePtr b p ++ (if b then mangle "*" else "*")
 tyToCManglePtr b (RefTy r _) = tyToCManglePtr b r ++ (if b then mangle "*" else "*")
 tyToCManglePtr _ ty = f ty