Merge branch 'master' of https://github.com/carp-lang/Carp into rectype

Author: scolsen

core/Array.carp

@@ -43,6 +43,30 @@ It will sum the previous sum with each new value, starting at `0`.")
           (set! total (~f total (unsafe-nth xs i))))
         total)))
 
+  (doc scan "Similar to `Array.reduce`, but instead returns an array with the starting element,
+and then all intermediate values.
+
+For example, a scan using `Int.+` over the array [1 1 1 1 1] (starting at 0) will return [0 1 2 3 4 5].")
+  (defn scan [f x xs]
+    (let [n (length xs)
+          ys (allocate (inc n))]
+      (do
+        (aset-uninitialized! &ys 0 @&x)
+        (for [i 1 (inc n)]
+          (aset-uninitialized! &ys i (~f (unsafe-nth &ys (dec i)) (unsafe-nth xs (dec i)))))
+        ys)))
+
+  (doc endo-scan "Like `Array.scan`, but uses the first element of the array as the starting value.
+Also does not create a new array, but reuses the initial one instead (by taking ownership over `xs`.)
+
+For example, an endo-scan using `Int.+` over the array [1 1 1 1 1] will return [1 2 3 4 5]")
+  (defn endo-scan [f xs]
+    (let [n (length &xs)]
+      (do
+        (for [i 1 n]
+          (aset! &xs i (~f (unsafe-nth &xs (dec i)) (unsafe-nth &xs i))))
+        xs)))
+
   (doc empty? "checks whether the array `a` is empty.")
   (defn empty? [a]
     (= (Array.length a) 0))

core/ControlMacros.carp

@@ -28,7 +28,7 @@
 (defmacro => [:rest forms]
   (thread-first-internal forms))
 
-(deprecated ==> "deprecated in favor of `==>`.")
+(deprecated ==> "deprecated in favor of `-->`.")
 (defmacro ==> [:rest forms]
   (thread-last-internal forms))
 

core/StaticArray.carp

@@ -38,6 +38,14 @@ stack-allocated. For a more flexible, heap-allocated version, you might want to
           (set! total (~f total (StaticArray.unsafe-nth xs i))))
         total)))
 
+    (doc scan! "Scans and replaces the array in-place, using a binary function.
+
+For example, give `(def numbers [1 1 1])`, a `scan!` using `Int.+` will mutate `numbers` to be `[1 2 3]`.")
+  (defn scan! [f xs]
+    (let [n (StaticArray.length xs)]
+      (for [i 1 n]
+        (StaticArray.aset! xs i (~f @(unsafe-nth xs (dec i)) @(unsafe-nth xs i))))))
+
   (doc = "compares two static arrays.")
   (defn = [a b]
     (if (/= (StaticArray.length a) (StaticArray.length 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

src/Deftype.hs

@@ -62,19 +62,25 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
       -- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
       insidePath = pathStrings ++ [typeName]
       candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = typeVariables, typemembers = [], interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env}
+      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
-        mems <- case rest of
+        mems <- case initmembers of
                   [XObj (Arr membersXObjs) _ _] -> Right membersXObjs
                   _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy))
         let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
-            ptrmembers = map (recursiveMembersToPointers structTy) rest
+            ptrmembers = map (recursiveMembersToPointers structTy) initmembers
         innermems <- case ptrmembers of
                        [XObj (Arr membersXObjs) _ _] -> Right membersXObjs
                        _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy))
         okRecursive (candidate {typemembers = mems})
         validateMembers typeEnv env (candidate {typemembers = innermems})
         (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy ptrmembers
-        okInit <- if (any (isValueRecursive structTy) ptrmembers) then recursiveProductInitBinder insidePath structTy ptrmembers else binderForInit insidePath structTy ptrmembers
+        okInit <- if (any (isValueRecursive structTy) ptrmembers) then recursiveProductInitBinder insidePath structTy ptrmembers else binderForInit insidePath structTy initmembers
         okMake <- recursiveProductMakeBinder insidePath structTy ptrmembers
         (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers "str"
         (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers"prn"
@@ -359,16 +365,22 @@ 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 ++ "`.")
+binderForInit insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] =
+  -- 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.
@@ -385,7 +397,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
@@ -395,6 +407,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.
@@ -403,7 +418,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 ->
@@ -413,7 +428,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
@@ -425,6 +440,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]
@@ -445,7 +463,7 @@ tokensForInit allocationMode typeName membersXObjs =
         "}"
       ]
   where
-    assignments [] = "    instance.__dummy = 0;"
+    assignments [] = ""
     assignments _ = go unitless
       where
         go [] = ""
@@ -562,9 +580,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 -> "."

src/Emit.hs

@@ -446,9 +446,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
                 when isNotVoid $
                   appendToSrc (addIndent indent' ++ retVar ++ " = " ++ caseExprRetVal ++ ";\n")
                 let Just caseLhsInfo' = caseLhsInfo
-                when
-                  (matchMode == MatchValue)
-                  (delete indent' caseLhsInfo')
+                delete indent' caseLhsInfo'
                 appendToSrc (addIndent indent ++ "}\n")
            in do
                 exprVar <- visit indent expr
@@ -533,7 +531,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
             var <- visit indent value
             let Just t = ty
                 fresh = mangle (freshVar info)
-            appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = " ++ var ++ "; // From the 'the' function.\n")
+            unless (isUnit t)
+              (appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = " ++ var ++ "; // From the 'the' function.\n"))
             pure fresh
         -- Ref
         [XObj Ref _ _, value] ->

src/Expand.hs

@@ -41,6 +41,19 @@ expand eval ctx xobj =
     Lst _ -> expandList xobj
     Arr _ -> expandArray xobj
     Sym _ _ -> expandSymbol xobj
+    -- This case is needed to ensure we expand naked mod names to initers consistently.
+    -- Consider both:
+    --   (width (address &(B 2)))
+    --   (width B)
+    -- The first case is correct code and was handled by expandList. The second case is an error and previously resulted in a loop because
+    -- module expansion wasn't handled in expandSymbol, but handling it there
+    -- by ending the expansion loop breaks init expansion in the first case,
+    -- since expandList calls expand.
+    -- So, we have no choice but to add a case here to cut the recursion and to expand this form consistently in all places.
+    Mod e _ ->
+      let pathToModule = pathToEnv e
+          implicitInit = XObj (Sym (SymPath pathToModule "init") Symbol) (xobjInfo xobj) (xobjTy xobj)
+       in pure (ctx, Right implicitInit)
     _ -> pure (ctx, Right xobj)
   where
     expandList :: XObj -> IO (Context, Either EvalError XObj)

src/InitialTypes.hs

@@ -98,7 +98,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
       If -> pure (Left (InvalidObj If xobj))
       While -> pure (Left (InvalidObj While xobj))
       Do -> pure (Left (InvalidObj Do xobj))
-      (Mod _ _) -> pure (Left (InvalidObj If xobj))
+      m@(Mod _ _) -> pure (Left (InvalidObj m xobj))
       e@(Deftype _) -> pure (Left (InvalidObj e xobj))
       e@(External _) -> pure (Left (InvalidObj e xobj))
       e@(ExternalType _) -> pure (Left (InvalidObj e xobj))