Initial commit of base functionality for compare

src/boot/boot.janet

@@ -667,6 +667,66 @@
   [xs]
   (get xs (- (length xs) 1)))
 
+## Polymorphic comparisons
+
+(defn compare-primitive
+  "Compare x and y using primitive operators.
+   Returns -1,0,1 for x < y, x = y, x > y respectively.
+   Present mostly for constructing 'compare' methods in prototypes."
+  [x y]
+  (cond
+    (= x y) 0
+    (< x y) -1
+    (> x y) 1))
+
+(defn compare
+  "Polymorphic compare.  Returns -1,0,1 for x < y, x = y, x > y respectively.
+   Differs from the primitive comparators in that it first checks to
+   see whether either x or y implement a 'compare' method which can
+   compare x and y.  If so it uses that compare method.  If not, it
+   delegates to the primitive comparators."
+  [x y]
+  (or
+    (when-let [f (get x :compare)] (f x y))
+    (when-let [f (get y :compare)
+               fyx (f y x)] (- fyx))
+    (compare-primitive x y)))
+
+(defn compare-reduce- [op & xs]
+  (var r true)
+  (loop [i :range [0 (- (length xs) 1)]
+         c (compare (xs i) (xs (+ i 1)))
+         ok (op c 0)
+         :when (not ok)]
+    (set r false)
+    (break))
+  r)
+
+(defn compare=
+  "Equivalent of '=' but using compare function instead of primitive comparator"
+  [& xs]
+  (compare-reduce := xs))
+
+(defn compare<
+  "Equivalent of '<' but using compare function instead of primitive comparator"
+  [& xs]
+  (compare-reduce :< xs))
+
+(defn compare<=
+  "Equivalent of '<=' but using compare function instead of primitive comparator"
+  [& xs]
+  (compare-reduce :<= xs))
+
+(defn compare>
+  "Equivalent of '>' but using compare function instead of primitive comparator"
+  [& xs]
+  (compare-reduce :> xs))
+
+(defn compare>=
+  "Equivalent of '>=' but using compare function instead of primitive comparator"
+  [& xs]
+  (compare-reduce :>= xs))
+
 ###
 ###
 ### Indexed Combinators

test/suite0.janet

@@ -334,5 +334,52 @@
 (assert (deep= @{:a 3 :b 2} @{:a 1 :b 2 :a 3}) "table literal duplicate keys")
 (assert (deep= @{:a 3 :b 2} (table :a 1 :b 2 :a 3)) "table constructor duplicate keys")
 
+## Polymorphic comparison -- Issue #272
+
+# confirm delegation to primitive comparators:
+(assert (= 0 (compare 1 1)) "compare integers (1)")
+(assert (< 0 (compare 1 2)) "compare integers (2)")
+(assert (> 0 (compare "foo" "bar")) "compare strings (1)")
+
+(assert (compare< 1 2 3 4 5 6) "compare less than integers")
+(assert (compare< 1.0 2.0 3.0 4.0 5.0 6.0) "compare less than reals")
+(assert (compare> 6 5 4 3 2 1) "compare greater than integers")
+(assert (compare> 6.0 5.0 4.0 3.0 2.0 1.0) "compare greater than reals")
+(assert (compare<= 1 2 3 3 4 5 6) "compare less than or equal to integers")
+(assert (compare<= 1.0 2.0 3.0 3.0 4.0 5.0 6.0) "compare less than or equal to reals")
+(assert (compare>= 6 5 4 4 3 2 1) "compare greater than or equal to integers")
+(assert (compare>= 6.0 5.0 4.0 4.0 3.0 2.0 1.0) "compare greater than or equal to reals")
+(assert (compare< 1.0 nil false true
+           (fiber/new (fn [] 1))
+           "hi"
+           (quote hello)
+           :hello
+           (array 1 2 3)
+           (tuple 1 2 3)
+           (table "a" "b" "c" "d")
+           (struct 1 2 3 4)
+           (buffer "hi")
+           (fn [x] (+ x x))
+           print) "compare type ordering")
+
+# test polymorphic
+(def mynum
+  @{:type :mynum :v 0 :compare
+    (fn [self other]
+      (case (type other)
+      :number (compare-primitive (self :v) other))
+      :table (when (= (get self :type) :mynum)
+               (compare-primitive (self :v) (other :v))))})
+
+(let [n3 (table/setproto @{:v 3} mynum)]
+  (assert (= 0 (compare 3 n3)) "compare num to object (1)")
+  (assert (< 0 (compare n3 4)) "compare object to num (2)")
+  (assert (> 0 (compare (table/setproto @{:v 4} mynum) n3)) "compare object to object")
+  (assert (compare< 2 n3 4) "compare< poly")
+  (assert (compare> 4 n3 2) "compare> poly")
+  (assert (compare<= 2 3 n3 4) "compare<= poly")
+  (assert (compare= 3 n3 (table/setproto @{:v 3} mynum)) "compare= poly")
+  (assert (deep= (sorted [4 5 n3 2] compare<) @[2 n3 4 5])))
+
 (end-suite)