From f32bd335e3e0f46c3199ccc79e2b4d65685bbdf2 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Sat, 27 Jun 2026 19:08:34 -0400 Subject: [PATCH] test.check generators: rand-double, take +Inf, UUID/Long/shiftLeft, transient MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 | 9 +++++++++ host/chez/java/host-static.ss | 8 ++++++-- host/chez/java/io.ss | 21 ++++++++++++++++++++- host/chez/seq.ss | 33 +++++++++++++++++++++------------ test/chez/corpus.edn | 3 +++ 5 files changed, 59 insertions(+), 15 deletions(-) diff --git a/host/chez/java/dot-forms.ss b/host/chez/java/dot-forms.ss index fd61301..40d35a9 100644 --- a/host/chez/java/dot-forms.ss +++ b/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 diff --git a/host/chez/java/host-static.ss b/host/chez/java/host-static.ss index 5b646b7..7518c76 100644 --- a/host/chez/java/host-static.ss +++ b/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 diff --git a/host/chez/java/io.ss b/host/chez/java/io.ss index 64c4843..f23bcbd 100644 --- a/host/chez/java/io.ss +++ b/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, diff --git a/host/chez/seq.ss b/host/chez/seq.ss index d3b5e4c..96e3899 100644 --- a/host/chez/seq.ss +++ b/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))) -(define (jolt-uncsub2 a b) (jolt-wrap64 (- a b))) -(define (jolt-uncmul2 a b) (jolt-wrap64 (* a b))) -(define (jolt-uncinc x) (jolt-wrap64 (+ x 1))) -(define (jolt-uncdec x) (jolt-wrap64 (- x 1))) -(define (jolt-uncneg x) (jolt-wrap64 (- x))) +;; unchecked-* only WRAP integer (long) math; on a flonum operand they are an +;; ordinary float op, since *unchecked-math* never wraps doubles — Clojure: +;; (unchecked-multiply 1.5 2.0) => 3.0, not a truncated long. (test.check's +;; rand-double is (* double-unit shifted) under *unchecked-math*.) +(define (jolt-uncadd2 a b) (if (or (flonum? a) (flonum? b)) (+ a b) (jolt-wrap64 (+ a b)))) +(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))) - (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)))))))))) + ;; (take Double/POSITIVE_INFINITY coll) takes the whole coll on the JVM (the + ;; count never reaches 0); test.check's rose-tree unchunk relies on it. Coercing + ;; +inf.0 to a fixnum index would throw, so take all up front. + (if (and (flonum? n) (infinite? n)) + (if (> n 0.0) (jolt-seq coll) jolt-empty-list) + (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) diff --git a/test/chez/corpus.edn b/test/chez/corpus.edn index 565bbac..2f8b098 100644 --- a/test/chez/corpus.edn +++ b/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)]"} ]