feat: a proper dynamic numeric tower (#1140)

* feat: a proper dynamic numeric tower

The following things were changed and/or added:
- `Dynamic.neg` was added
- `Dynamic.mod` was changed to work on float values
- `Dynamic.cxr` was changed to work with `0` instructions
- `Dynamic.=` was changed to ignore the type of the number
- `Dynamic.round` was added
- dynamic arithmetic was changed to respect the numeric type tower
- the instances of `Eq` and `Ord` for `Number` are no longer derived, so that they work across numeric types
- the instance of `Num` for `Number` was changed to work across numeric types
- `promoteNumber` was added as a type function to implement the numeric tower.

The numeric tower is as follows:
Byte -> Int -> Long -> Float -> Double

* test: add tests for cxr, neg, and =

* test: add tests for Dynamic.round

core/Dynamic.carp

@@ -9,8 +9,16 @@
   (defndynamic dec [x]
     (- x 1))
 
+  (defndynamic neg [x]
+    (* -1 x))
+
   (defndynamic mod [x y]
-    (- x (* y (/ x y))))
+    (let-do [a (if (< x 0) (neg x) x)
+             b (if (< y 0) (neg y) y)
+             m a]
+      (while (or (> m b) (= m b))
+        (set! m (- m b)))
+      (if (< a 0) (neg m) m)))
 
   (defmodule Project
     (doc no-echo "Turn off debug printing in the compiler.")

core/List.carp

@@ -3,15 +3,17 @@
   (defndynamic cxr [x pair]
     (if (= (length x) 0)
       (list 'quote pair)
-      (list
-        (if (= 'a (cadr x))
-          'car
-          (if (= 'd (cadr x))
-            'cdr
-            (macro-error "`cxr` expects either `a` or `d` symbols, got " (cadr x))))
-        (if (= 1 (car x))
-          (cxr (cddr x) pair)
-          (cxr (cons (- (car x) 1) (cdr x)) pair)))))
+      (if (= 0 (car x))
+        (cxr (cddr x) pair)
+        (list
+          (if (= 'a (cadr x))
+            'car
+            (if (= 'd (cadr x))
+              'cdr
+              (macro-error "`cxr` expects either `a` or `d` symbols, got " (cadr x))))
+          (if (= 1 (car x))
+            (cxr (cddr x) pair)
+            (cxr (cons (- (car x) 1) (cdr x)) pair))))))
 
   (defndynamic nthcdr [n pair]
     (cxr (list (+ n 1) 'd) pair))

src/Commands.hs

@@ -534,6 +534,7 @@ commandEq ctx a b =
   pure (ctx, Right (boolToXObj (cmp (a, b))))
   where
     cmp (XObj (Sym sa _) _ _, XObj (Sym sb _) _ _) = sa == sb
+    cmp (XObj (Num _ na) _ _, XObj (Num _ nb) _ _) = na == nb
     cmp (XObj (Lst elemsA) _ _, XObj (Lst elemsB) _ _) =
       length elemsA == length elemsB && all cmp (zip elemsA elemsB)
     cmp (XObj (Arr elemsA) _ _, XObj (Arr elemsB) _ _) =
@@ -541,7 +542,7 @@ commandEq ctx a b =
     cmp (XObj x _ _, XObj y _ _) = x == y
 
 commandComp :: (Number -> Number -> Bool) -> String -> BinaryCommandCallback
-commandComp op _ ctx (XObj (Num aTy aNum) _ _) (XObj (Num bTy bNum) _ _) | aTy == bTy = pure (ctx, Right (boolToXObj (op aNum bNum)))
+commandComp op _ ctx (XObj (Num _ aNum) _ _) (XObj (Num _ bNum) _ _) = pure (ctx, Right (boolToXObj (op aNum bNum)))
 commandComp _ opname ctx a b = pure $ evalError ctx ("Can't compare (" ++ opname ++ ") " ++ pretty a ++ " with " ++ pretty b) (xobjInfo a)
 
 commandLt :: BinaryCommandCallback
@@ -550,6 +551,14 @@ commandLt = commandComp (<) "<"
 commandGt :: BinaryCommandCallback
 commandGt = commandComp (>) ">"
 
+commandRound :: UnaryCommandCallback
+commandRound ctx (XObj (Num _ (Floating i)) _ _) =
+  pure (ctx, Right (XObj (Num IntTy (Integral (round i))) (Just dummyInfo) (Just IntTy)))
+commandRound ctx i@(XObj (Num _ (Integral _)) _ _) =
+  pure (ctx, Right i)
+commandRound ctx a =
+  pure $ evalError ctx ("Can’t call round with " ++ pretty a) (xobjInfo a)
+
 commandCharAt :: BinaryCommandCallback
 commandCharAt ctx a b =
   pure $ case (a, b) of
@@ -651,9 +660,9 @@ commandPathAbsolute ctx a =
     _ -> pure $ evalError ctx ("Can't call `absolute` with " ++ pretty a) (xobjInfo a)
 
 commandArith :: (Number -> Number -> Number) -> String -> BinaryCommandCallback
-commandArith op _ ctx (XObj (Num aTy aNum) _ _) (XObj (Num bTy bNum) _ _)
-  | aTy == bTy =
-    pure (ctx, Right (XObj (Num aTy (op aNum bNum)) (Just dummyInfo) (Just aTy)))
+commandArith op _ ctx (XObj (Num aTy aNum) _ _) (XObj (Num bTy bNum) _ _) =
+  let newTy = promoteNumber aTy bTy
+  in pure (ctx, Right (XObj (Num newTy (op aNum bNum)) (Just dummyInfo) (Just newTy)))
 commandArith _ opname ctx a b = pure $ evalError ctx ("Can't call " ++ opname ++ " with " ++ pretty a ++ " and " ++ pretty b) (xobjInfo a)
 
 commandPlus :: BinaryCommandCallback
@@ -664,8 +673,7 @@ commandMinus = commandArith (-) "-"
 
 commandDiv :: BinaryCommandCallback
 commandDiv ctx p@(XObj (Num _ (Integral _)) _ _) q@(XObj (Num _ (Integral _)) _ _) = commandArith div "/" ctx p q
-commandDiv ctx p@(XObj (Num _ (Floating _)) _ _) q@(XObj (Num _ (Floating _)) _ _) = commandArith (/) "/" ctx p q
-commandDiv ctx p q = commandArith (error "div") "/" ctx p q
+commandDiv ctx p q = commandArith (/) "/" ctx p q
 
 commandMul :: BinaryCommandCallback
 commandMul = commandArith (*) "*"

src/Obj.hs

@@ -67,17 +67,31 @@ data MatchMode = MatchValue | MatchRef deriving (Eq, Show, Generic)
 
 instance Hashable MatchMode
 
-data Number = Floating Double | Integral Int deriving (Eq, Ord, Generic)
+data Number = Floating Double | Integral Int deriving (Generic)
 
 instance Hashable Number
 
+instance Eq Number where
+  (Floating a) == (Floating b) = a == b
+  (Integral a) == (Integral b) = a == b
+  (Floating a) == (Integral b) = a == fromIntegral b
+  (Integral a) == (Floating b) = fromIntegral a == b
+
+instance Ord Number where
+  (Floating a) <= (Floating b) = a <= b
+  (Integral a) <= (Integral b) = a <= b
+  (Floating a) <= (Integral b) = a <= fromIntegral b
+  (Integral a) <= (Floating b) = fromIntegral a <= b
+
 instance Num Number where
   (Floating a) + (Floating b) = Floating (a + b)
   (Integral a) + (Integral b) = Integral (a + b)
-  _ + _ = error "+"
-  (Floating a) * (Floating b) = Floating (a * b)
+  (Floating a) + (Integral b) = Floating (a + fromIntegral b)
+  (Integral a) + (Floating b) = Floating (fromIntegral a + b)
   (Integral a) * (Integral b) = Integral (a * b)
-  _ * _ = error "*"
+  (Floating a) * (Floating b) = Floating (a * b)
+  (Integral a) * (Floating b) = Floating (fromIntegral a * b)
+  (Floating a) * (Integral b) = Floating (a * fromIntegral b)
   negate (Floating a) = Floating (negate a)
   negate (Integral a) = Integral (negate a)
   abs (Floating a) = Floating (abs a)

src/StartingEnv.hs

@@ -262,7 +262,8 @@ dynamicModule =
             f "relative-include" commandAddRelativeInclude "adds a relative include, i.e. a C `include` with quotes. It also prepends the current directory." "(relative-include \"myheader.h\")",
             f "save-docs-internal" commandSaveDocsInternal "is the internal companion command to `save-docs`. `save-docs` should be called instead." "(save-docs-internal 'Module)",
             f "read-file" commandReadFile "reads a file into a string." "(read-file \"myfile.txt\")",
-            f "hash" commandHash "calculates the hash associated with a value." "(hash '('my 'value)) ; => 3175346968842793108"
+            f "hash" commandHash "calculates the hash associated with a value." "(hash '('my 'value)) ; => 3175346968842793108",
+            f "round" commandRound "rounds its numeric argument." "(round 2.4) ; => 2"
           ]
     binaries =
       let f = addBinaryCommand . spath

src/Types.hs

@@ -26,6 +26,7 @@ module Types
     getStructName,
     getPathFromStructName,
     getNameFromStructName,
+    promoteNumber,
   )
 where
 
@@ -350,3 +351,19 @@ getPathFromStructName structName =
 
 getNameFromStructName :: String -> String
 getNameFromStructName structName = last (map unpack (splitOn (pack ".") (pack structName)))
+
+-- N.B.: promoteNumber is only safe for numeric types!
+promoteNumber :: Ty -> Ty -> Ty
+promoteNumber a b | a == b = a
+promoteNumber ByteTy other = other
+promoteNumber other ByteTy = other
+promoteNumber IntTy other = other
+promoteNumber other IntTy = other
+promoteNumber LongTy other = other
+promoteNumber other LongTy = other
+promoteNumber FloatTy other = other
+promoteNumber other FloatTy = other
+promoteNumber DoubleTy _ = DoubleTy
+promoteNumber _ DoubleTy = DoubleTy
+promoteNumber a b =
+  error ("promoteNumber called with non-numbers: " ++ show a ++ ", " ++ show b)

test/macros.carp

@@ -142,6 +142,15 @@
 (defmacro test-walk-replace []
   (eval (walk-replace '((+ *)) '(+ 2 (+ 2 3)))))
 
+(defmacro test-cxr [ins l]
+  (eval (cxr ins l)))
+
+(defmacro test-neg [x]
+  (neg x))
+
+(defmacro test-round [n]
+  (round n))
+
 
 (deftest test
   (assert-true test
@@ -207,6 +216,12 @@
   (assert-false test
                 (test-< 2.0f 2.0f)
                 "< macro works as expected on floats II")
+  (assert-false test
+                (test-< 3.0 2.0f)
+                "< macro works as expected across types I")
+  (assert-true test
+               (test-< 1l 2.0f)
+               "< macro works as expected across types II")
   (assert-true test
                (test-> 2 1)
                "> macro works as expected on ints I")
@@ -231,6 +246,12 @@
   (assert-false test
                 (test-> 2.0f 2.0f)
                 "> macro works as expected on floats II")
+  (assert-true test
+               (test-> 2 1.0f)
+               "> macro works as expected across types I")
+  (assert-false test
+                (test-> 2.0 3l)
+                "> macro works as expected across types II")
 
   (assert-true test
                (test-= 2 2)
@@ -256,6 +277,12 @@
   (assert-false test
                 (test-= 2.0f 1.0f)
                 "= macro works as expected on floats II")
+  (assert-true test
+               (test-= 2.0f 2)
+               "= macro works as expected across numeric types I")
+  (assert-false test
+                (test-= 2.0 1l)
+                "= macro works as expected across numeric types II")
   (assert-true test
                (test-= "erik" "erik")
                "= macro works as expected on strings I")
@@ -268,6 +295,9 @@
   (assert-false test
                 (test-= veit heller)
                 "= macro works as expected on symbols II")
+  (assert-false test
+                (test-= veit "veit")
+                "= macro works as expected across types")
   (assert-false test
                 (and* true true false)
                 "and* macro works as expected I")
@@ -378,4 +408,24 @@
                 12
                 (test-walk-replace)
                 "walk-replace works as expected")
+  (assert-equal test
+                -1
+                (test-neg 1)
+                "Dynamic.neg works as expected")
+  (assert-equal test
+                4
+                (test-cxr (1 a 3 d) (1 2 3 4))
+                "Dynamic.cxr works as expected I")
+  (assert-equal test
+                1
+                (test-cxr (0 d 1 a) (1 2 3 4))
+                "Dynamic.cxr works as expected I")
+  (assert-equal test
+                3
+                (test-round 3.4)
+                "Dynamic.round works as expected I")
+  (assert-equal test
+                3
+                (test-round 2.51)
+                "Dynamic.round works as expected II")
 )