test.check generators: rand-double, take +Inf, UUID/Long/shiftLeft, transient

More general fixes from clojure.test.check's own suite.

- *unchecked-math* on doubles: unchecked-* only wrap integer math; on a flonum
  operand they're an ordinary float op (Clojure: (unchecked-multiply 1.5 2.0) =>
  3.0). test.check's rand-double is (* double-unit shifted) under *unchecked-math*
  and was truncating to a long 0, so every distribution-driven generator (choose,
  vector, …) collapsed to its lower bound.
- (take Double/POSITIVE_INFINITY coll) takes the whole coll instead of throwing
  on the infinite count coercion (rose-tree unchunk relies on it).
- (java.util.UUID. msb lsb) 2-long constructor (the uuid generator), formatted as
  the canonical lowercase 8-4-4-4-12 string; (Long. n) constructor; BigInteger
  .shiftLeft / .shiftRight (size-bounded-bigint); number methods now receive args.
- A transient (ITransientSet) responds to .contains / .valAt / .count
  (distinct-collection generators).

make test green (+3 corpus rows, 0 new divergences), runtime only (no re-mint).

host/chez/java/dot-forms.ss

@@ -96,6 +96,15 @@
         ;; (.getClass x) universal — the class token for any value, before the
         ;; collection/map field-lookup arms below would read it as a missing key.
         ((string=? method-name "getClass") (jolt-class obj))
+        ;; a transient (ITransientCollection/Set/Map): .contains / .valAt / .count —
+        ;; test.check's distinct-collection gen uses (.contains transient-set k).
+        ((jolt-transient? obj)
+         (cond
+           ((string=? mname "contains") (if (jolt-truthy? (t-contains? obj (car rest))) #t #f))
+           ((or (string=? mname "valAt") (string=? mname "get"))
+            (t-get obj (car rest) (if (null? (cdr rest)) jolt-nil (cadr rest))))
+           ((string=? mname "count") (t-count obj))
+           (else (%dot-rmd obj method-name rest-args))))
         ;; a deftype/record's OWN declared method (matched by name AND arity) wins
         ;; over the generic collection interop below — e.g. data.priority-map
         ;; declares both seq[this] (Seqable) and seq[this ascending] (Sorted), and

host/chez/java/host-static.ss

@@ -103,13 +103,13 @@
            (if f
                (apply f obj (if (jolt-nil? rest-args) '() (seq->list rest-args)))
                (error #f (string-append "No method " method-name " on host " (jhost-tag obj)))))))
-      ((number? obj) (number-method method-name obj))
+      ((number? obj) (apply number-method method-name obj (if (jolt-nil? rest-args) '() (seq->list rest-args))))
       (else (%hs-record-method-dispatch obj method-name rest-args)))))
 
 ;; java.lang.Number method surface (the boxed-number methods cljc code calls). The
 ;; integer projections wrap modulo their width (ring-codec relies on byteValue
 ;; overflow: (.byteValue 255) => -1); the float projections are identity flonums.
-(define (number-method method n)
+(define (number-method method n . args)
   (cond
     ((string=? method "byteValue") (let ((b (modulo (jnum->exact n) 256))) (->num (if (>= b 128) (- b 256) b))))
     ((string=? method "shortValue") (let ((b (modulo (jnum->exact n) 65536))) (->num (if (>= b 32768) (- b 65536) b))))
@@ -129,6 +129,10 @@
     ((string=? method "abs") (->num (abs (jnum->exact n))))
     ((string=? method "bitLength") (->num (integer-length (jnum->exact n))))
     ((string=? method "signum") (->num (let ((e (jnum->exact n))) (cond ((> e 0) 1) ((< e 0) -1) (else 0)))))
+    ;; BigInteger.shiftLeft/shiftRight (test.check's size-bounded-bigint): arbitrary
+    ;; precision, so an arithmetic shift by the (positive) amount.
+    ((string=? method "shiftLeft") (->num (bitwise-arithmetic-shift-left (jnum->exact n) (jnum->exact (car args)))))
+    ((string=? method "shiftRight") (->num (bitwise-arithmetic-shift-right (jnum->exact n) (jnum->exact (car args)))))
     (else (error #f (string-append "No method " method " for number")))))
 
 ;; Mutable static fields: "Class" -> (member -> 1-vector cell). A library that

host/chez/java/io.ss

@@ -536,7 +536,26 @@
 (register-class-statics! "java.util.UUID"
   (list (cons "randomUUID" (lambda () (jolt-random-uuid)))
         (cons "fromString" (lambda (s) (jolt-parse-uuid (jolt-str-render-one s))))))
-(register-class-ctor! "UUID" (lambda (s) (jolt-parse-uuid (jolt-str-render-one s))))
+;; (UUID. msb lsb): build from the most/least-significant 64-bit halves (the JVM's
+;; 2-long ctor), the form test.check's uuid generator uses. (UUID. s) parses a
+;; string. The 128 bits format as the canonical 8-4-4-4-12 lowercase hex string.
+(define (uuid-long->hex16 n)
+  (let* ((u (bitwise-and (jnum->exact n) #xFFFFFFFFFFFFFFFF))
+         (s (string-downcase (number->string u 16))))   ; JVM UUIDs are lowercase
+    (string-append (make-string (- 16 (string-length s)) #\0) s)))
+(define (uuid-from-halves msb lsb)
+  (let ((h (uuid-long->hex16 msb)) (l (uuid-long->hex16 lsb)))
+    (make-juuid (string-append (substring h 0 8) "-" (substring h 8 12) "-" (substring h 12 16)
+                               "-" (substring l 0 4) "-" (substring l 4 16)))))
+(define (uuid-ctor . args)
+  (if (= (length args) 2)
+      (uuid-from-halves (car args) (cadr args))
+      (jolt-parse-uuid (jolt-str-render-one (car args)))))
+(register-class-ctor! "UUID" uuid-ctor)
+(register-class-ctor! "java.util.UUID" uuid-ctor)
+;; (Long. n) / (Long. "n"): a Long is just jolt's integer; return it (parse a string).
+(register-class-ctor! "Long" (lambda (x) (if (string? x) (parse-int-or-throw x 10 "Long") (->num (jnum->exact x)))))
+(register-class-ctor! "java.lang.Long" (lambda (x) (if (string? x) (parse-int-or-throw x 10 "Long") (->num (jnum->exact x)))))
 
 ;; --- java.net.URI -----------------------------------------------------------
 ;; A minimal RFC-3986 split into scheme/authority/host/port/path/query/fragment,

host/chez/seq.ss

@@ -165,12 +165,16 @@
 (define (jolt-wrap64 x)
   (let ((m (bitwise-and (if (and (number? x) (exact? x) (integer? x)) x (exact (floor x))) unc-mask64)))
     (if (>= m unc-2^63) (- m unc-2^64) m)))
-(define (jolt-uncadd2 a b) (jolt-wrap64 (+ a b)))
+;; unchecked-* only WRAP integer (long) math; on a flonum operand they are an
-(define (jolt-uncsub2 a b) (jolt-wrap64 (- a b)))
+;; ordinary float op, since *unchecked-math* never wraps doubles — Clojure:
-(define (jolt-uncmul2 a b) (jolt-wrap64 (* a b)))
+;; (unchecked-multiply 1.5 2.0) => 3.0, not a truncated long. (test.check's
-(define (jolt-uncinc x)    (jolt-wrap64 (+ x 1)))
+;; rand-double is (* double-unit shifted) under *unchecked-math*.)
-(define (jolt-uncdec x)    (jolt-wrap64 (- x 1)))
+(define (jolt-uncadd2 a b) (if (or (flonum? a) (flonum? b)) (+ a b) (jolt-wrap64 (+ a b))))
-(define (jolt-uncneg x)    (jolt-wrap64 (- x)))
+(define (jolt-uncsub2 a b) (if (or (flonum? a) (flonum? b)) (- a b) (jolt-wrap64 (- a b))))
+(define (jolt-uncmul2 a b) (if (or (flonum? a) (flonum? b)) (* a b) (jolt-wrap64 (* a b))))
+(define (jolt-uncinc x)    (if (flonum? x) (+ x 1.0) (jolt-wrap64 (+ x 1))))
+(define (jolt-uncdec x)    (if (flonum? x) (- x 1.0) (jolt-wrap64 (- x 1))))
+(define (jolt-uncneg x)    (if (flonum? x) (- x) (jolt-wrap64 (- x))))
 (define (jolt-unchecked-add . xs) (if (null? xs) 0 (fold-left jolt-uncadd2 (car xs) (cdr xs))))
 (define (jolt-unchecked-mul . xs) (if (null? xs) 1 (fold-left jolt-uncmul2 (car xs) (cdr xs))))
 (define (jolt-unchecked-sub . xs)
@@ -328,12 +332,17 @@
 ;; (take 0 (rest s)) never seqs coll. Realizing one more, as forcing seq-more at
 ;; the boundary would, over-runs the source by one (medley's sequence-padded).
 (define (jolt-take n coll)
-  (let ((n (->idx n)))
+  ;; (take Double/POSITIVE_INFINITY coll) takes the whole coll on the JVM (the
-    (let loop ((n n) (s (jolt-seq coll)))
+  ;; count never reaches 0); test.check's rose-tree unchunk relies on it. Coercing
-      (cond
+  ;; +inf.0 to a fixnum index would throw, so take all up front.
-        ((or (fx<=? n 0) (jolt-nil? s)) jolt-empty-list)
+  (if (and (flonum? n) (infinite? n))
-        ((fx=? n 1) (cseq-lazy (seq-first s) (lambda () jolt-empty-list)))
+      (if (> n 0.0) (jolt-seq coll) jolt-empty-list)
-        (else (cseq-lazy (seq-first s) (lambda () (loop (fx- n 1) (jolt-seq (seq-more s))))))))))
+      (let ((n (->idx n)))
+        (let loop ((n n) (s (jolt-seq coll)))
+          (cond
+            ((or (fx<=? n 0) (jolt-nil? s)) jolt-empty-list)
+            ((fx=? n 1) (cseq-lazy (seq-first s) (lambda () jolt-empty-list)))
+            (else (cseq-lazy (seq-first s) (lambda () (loop (fx- n 1) (jolt-seq (seq-more s)))))))))))
 (define (jolt-drop n coll)
   (let loop ((n (->idx n)) (s (jolt-seq coll)))
     (if (or (fx<=? n 0) (jolt-nil? s)) (if (jolt-nil? s) jolt-empty-list s)

test/chez/corpus.edn

@@ -3382,4 +3382,7 @@
   {:suite "macros / letfn mutual recursion" :label "letfn binds mutually-recursive named fns" :expected "[true false]" :actual "(letfn [(ev? [n] (if (zero? n) true (od? (dec n)))) (od? [n] (if (zero? n) false (ev? (dec n))))] [(ev? 10) (ev? 7)])"}
   {:suite "host-interop / extend-protocol IPersistentList" :label "a protocol extended to IPersistentList dispatches on a list, not a vector" :expected "[:list :vec :list]" :actual "(do (defprotocol PL (m [x])) (extend-protocol PL clojure.lang.IPersistentList (m [_] :list) clojure.lang.IPersistentVector (m [_] :vec)) [(m (list 1 2)) (m [1 2]) (m ())])"}
   {:suite "scope / qualified ref vs same-named local" :label "clojure.core/max wins over a local named max" :expected "[10 5]" :actual "[((fn [max] (clojure.core/max 5 10)) 100) ((fn [min] (clojure.core/min 5 10)) 0)]"}
+  {:suite "numbers / unchecked on doubles" :label "unchecked-multiply of doubles is a double, not a truncated long" :expected "3.0" :actual "(unchecked-multiply 1.5 2.0)"}
+  {:suite "seq / take infinite count" :label "(take +Infinity coll) takes the whole coll" :expected "7" :actual "(count (take (/ 1.0 0.0) (range 7)))"}
+  {:suite "host-interop / UUID + Long + shiftLeft" :label "(UUID. msb lsb), .shiftLeft, (Long. n)" :expected "[\"00000000-0000-007b-0000-0000000001c8\" 40 10 42]" :actual "[(str (java.util.UUID. 123 456)) (.shiftLeft 5 3) (.shiftRight 40 2) (Long. 42)]"}
 ]